@@ -368,6 +368,25 @@ def follow_irep_set_all_subs(self, b, sn, subs, i, needs_null):
368
368
write (b , "Integer (Follow_Irep (Irep (%s), Follow_Symbol));" % tbl_field )
369
369
return needs_null
370
370
371
+ def wrap_pointer_set_all_subs (self , b , sn , subs , i , needs_null ):
372
+ needs_null = False
373
+ setter_name , is_list = subs [i ]
374
+ layout_kind , layout_index , layout_typ = \
375
+ self .layout [sn ][setter_name ]
376
+ tbl_index = ada_component_name (layout_kind ,
377
+ layout_index )
378
+ tbl_field = "N." + tbl_index
379
+ if is_list :
380
+ assert len (subs ) == 1
381
+ write (b , "Irep_Table.Table (I).%s :=" % tbl_index )
382
+ with indent (b ):
383
+ write (b , "Integer (Wrap_Pointer (Irep_List (%s), Name));" % tbl_field )
384
+ else :
385
+ write (b , "Irep_Table.Table (I).%s :=" % tbl_index )
386
+ with indent (b ):
387
+ write (b , "Integer (Wrap_Pointer (Irep (%s), Name));" % tbl_field )
388
+ return needs_null
389
+
371
390
def remove_extra_type_information_set_all_subs (self , b , sn , subs , i , needs_null ):
372
391
needs_null = False
373
392
setter_name , is_list = subs [i ]
@@ -444,6 +463,26 @@ def follow_irep_set_all_namedsubs_and_comments(self, b, sn, setter_name, needs_n
444
463
needs_null = False
445
464
return needs_null
446
465
466
+ def wrap_pointer_set_all_namedsubs_and_comments (self , b , sn , setter_name , needs_null ):
467
+ needs_null = True
468
+ for kind in self .named_setters [setter_name ]:
469
+ assert kind in ("irep" , "list" , "trivial" )
470
+ if sn in self .named_setters [setter_name ][kind ]:
471
+ is_comment , _ , _ = \
472
+ self .named_setters [setter_name ][kind ][sn ]
473
+ layout_kind , layout_index , layout_typ = \
474
+ self .layout [sn ][setter_name ]
475
+ tbl_index = ada_component_name (layout_kind ,
476
+ layout_index )
477
+ tbl_field = "N." + tbl_index
478
+
479
+ if kind == "irep" :
480
+ write (b , "Irep_Table.Table (I).%s :=" % tbl_index )
481
+ with indent (b ):
482
+ write (b , "Integer (Wrap_Pointer (Irep (%s), Name));" % tbl_field )
483
+ needs_null = False
484
+ return needs_null
485
+
447
486
def remove_extra_type_information_set_all_namedsubs_and_comments (self , b , sn , setter_name , needs_null ):
448
487
needs_null = True
449
488
for kind in self .named_setters [setter_name ]:
@@ -530,6 +569,28 @@ def follow_irep_single_schema_name(self, b, sn):
530
569
write (b , "null;" )
531
570
write (b , "" )
532
571
572
+ def wrap_pointer_single_schema_name (self , b , sn ):
573
+ schema = self .schemata [sn ]
574
+ with indent (b ):
575
+ write (b , "when %s =>" % schema ["ada_name" ])
576
+ with indent (b ):
577
+ # the ensuing case analysis may end up doing nothing for some irep kinds
578
+ # in Ada cases cannot be empty hence we insert null statement if necessary
579
+ needs_null = True
580
+
581
+ # Set all subs
582
+ subs = self .collect_subs (sn )
583
+ for i in xrange (len (subs )):
584
+ needs_null = self .wrap_pointer_set_all_subs (b , sn , subs , i , needs_null )
585
+
586
+ # Set all namedSub and comments
587
+ for setter_name in self .named_setters :
588
+ needs_null = self .wrap_pointer_set_all_namedsubs_and_comments (b , sn , setter_name , needs_null )
589
+
590
+ if needs_null :
591
+ write (b , "null;" )
592
+ write (b , "" )
593
+
533
594
def remove_extra_type_information_single_schema_name (self , b , sn ):
534
595
schema = self .schemata [sn ]
535
596
with indent (b ):
@@ -1813,6 +1874,10 @@ def generate_code(self, optimize, schema_file_names):
1813
1874
write (s , "-- Replace Symbol Types" )
1814
1875
write (s , "" )
1815
1876
1877
+ write (s , "function Wrap_Pointer (I : Irep; Name : String) return Irep;" )
1878
+ write (s , "-- Increase Pointer Depth" )
1879
+ write (s , "" )
1880
+
1816
1881
write (s , "function Remove_Extra_Type_Information (I : Irep) return Irep;" )
1817
1882
write (s , "-- Remove Type Bounds" )
1818
1883
write (s , "" )
@@ -1829,6 +1894,10 @@ def generate_code(self, optimize, schema_file_names):
1829
1894
write (b , "-- Replace Symbol Types" )
1830
1895
write (b , "" )
1831
1896
1897
+ write (b , "function Wrap_Pointer (L : Irep_List; Name : String) return Irep_List;" )
1898
+ write (b , "-- Increase Pointer Depth" )
1899
+ write (b , "" )
1900
+
1832
1901
write (b , "function Remove_Extra_Type_Information (L : Irep_List) return Irep_List;" )
1833
1902
write (b , "-- Remove Type Bounds" )
1834
1903
write (b , "" )
@@ -1880,6 +1949,11 @@ def generate_code(self, optimize, schema_file_names):
1880
1949
continuation (b )
1881
1950
write (b , "" )
1882
1951
1952
+ write (b , "function Wrap_Pointer (L : Irep_List; Name : String) return Irep_List" )
1953
+ write (b , "is separate;" )
1954
+ continuation (b )
1955
+ write (b , "" )
1956
+
1883
1957
write (b , "function Remove_Extra_Type_Information (L : Irep_List) return Irep_List" )
1884
1958
write (b , "is separate;" )
1885
1959
continuation (b )
@@ -2036,6 +2110,47 @@ def generate_code(self, optimize, schema_file_names):
2036
2110
write (b , "end Follow_Irep;" )
2037
2111
write (b , "" )
2038
2112
2113
+ write_comment_block (b , "Wrap_Pointer" )
2114
+ write (b , "function Wrap_Pointer (I : Irep; Name : String) return Irep" )
2115
+ write (b , "is" )
2116
+ write (b , "begin" )
2117
+ manual_indent (b )
2118
+ write (b , "if I = 0 then" )
2119
+ with indent (b ):
2120
+ write (b , "return I;" )
2121
+ write (b , "end if;" )
2122
+ write (b , "" )
2123
+ write (b , "if Kind (I) = I_Code_Decl then" )
2124
+ with indent (b ):
2125
+ write (b , "return I;" )
2126
+ write (b , "end if;" )
2127
+ write (b , "" )
2128
+ write (b , "if Kind (I) = I_Symbol_Expr and then Get_Identifier (I) = Name" )
2129
+ write (b , "then" )
2130
+ with indent (b ):
2131
+ write (b , "return Make_Dereference_Expr (Make_Symbol_Expr (Get_Source_Location (I)," )
2132
+ with indent (b ):
2133
+ write (b , "Make_Pointer_Type (Get_Type (I), 64), False, \" Ptr_\" & Name)," )
2134
+ write (b , "Get_Source_Location (I), Get_Type (I));" )
2135
+ write (b , "end if;" )
2136
+ write (b , "" )
2137
+ write (b , "declare" )
2138
+ with indent (b ):
2139
+ write (b , "N : Irep_Node renames Irep_Table.Table (I);" )
2140
+ write (b , "begin" )
2141
+ manual_indent (b )
2142
+ write (b , "case N.Kind is" )
2143
+
2144
+ for sn in self .top_sorted_sn :
2145
+ self .wrap_pointer_single_schema_name (b , sn )
2146
+ write (b , "end case;" )
2147
+ manual_outdent (b )
2148
+ write (b , "end;" )
2149
+ write (b , "return I;" )
2150
+ manual_outdent (b )
2151
+ write (b , "end Wrap_Pointer;" )
2152
+ write (b , "" )
2153
+
2039
2154
write_comment_block (b , "Remove_Extra_Type_Information" )
2040
2155
write (b , "function Remove_Extra_Type_Information (I : Irep) return Irep" )
2041
2156
write (b , "is" )
0 commit comments