1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382 | -------------------------------------------------------------------------------------
--
-- HAC - HAC Ada Compiler
--
-- A compiler in Ada for an Ada subset
--
-- Copyright, license, etc. : see top package.
--
-------------------------------------------------------------------------------------
--
-- Co_Defs: Compiler Definitions
with HAC_Sys.Defs,
HAC_Sys.PCode,
HAC_Sys.Targets;
with HAT;
with Ada.Containers.Hashed_Maps,
Ada.Containers.Indefinite_Hashed_Maps,
Ada.Finalization,
Ada.Streams,
Ada.Strings.Hash,
Ada.Strings.Unbounded.Hash,
Ada.Text_IO;
package HAC_Sys.Co_Defs is
-- NB: cannot be a child package of Compiler because of Parser, Scanner, ...
use HAC_Sys.Defs;
type Exact_Typ is tagged record -- NB: was called "Item" in SmallAda.
TYP : Typen;
Ref : Index;
-- If TYP is not a standard type, then (TYP, Ref) does identify the base type.
-- E.g. it can be (Enums, [index of the enumerated type definition]).
--
-- Ref is an index into different tables, depending on TYP:
-- If TYP = Records, Block_Table;
-- if TYP = Arrays, Arrays_Table;
-- if TYP = Enums, Idtab (the enumeration type's declaration).
--
Is_Range : Boolean;
-- ^ For X'Range expressions, indicates a pair of values waiting on the stack.
end record;
procedure Construct_Root (Root : out Exact_Typ; Typ : Typen);
pragma Inline (Construct_Root);
function Construct_Root (Typ : Typen) return Exact_Typ;
function Undefined return Exact_Typ;
type Exact_Subtyp is new Exact_Typ with record
Discrete_First : HAC_Integer; -- If subtype S is discrete, S'First
Discrete_Last : HAC_Integer; -- If subtype S is discrete, S'Last
end record;
overriding procedure Construct_Root (Root : out Exact_Subtyp; Typ : Typen);
pragma Inline (Construct_Root);
overriding function Construct_Root (Typ : Typen) return Exact_Subtyp;
overriding function Undefined return Exact_Subtyp;
-------------------------------------------------------------------------
------------------------------------------------------------ATabEntry----
-------------------------------------------------------------------------
-- Array-Table Entry : Array table entry represents an array. Each entry
-- contains the following fields (fields marked with a C are used only by
-- the compiler and ignored by the interpreter):
--
type ATabEntry is record
Index_xTyp : Exact_Subtyp; -- C Type of the index.
Element_Size : Index; -- Size of an element.
Element_xTyp : Exact_Subtyp; -- C Subtype of the elements of the array.
-- If the elements of the array are themselves
-- arrays, Element_xTYP.Ref is an index to an
-- entry in Arrays_Table (it's not a special case).
Array_Size : Index; -- C Total size of the array.
dimensions : Positive; -- C Total dimensions of the array.
end record;
-------------------------------------------------------------------------
------------------------------------------------------------BTabEntry----
-------------------------------------------------------------------------
-- Block-table Entry : Each entry represents a subprogram or a record type.
--
-- A subprogram activation record consists of:
--
-- (1) the five word fixed area; (see definition of S in Interpreter)
-- (2) an area for the actual parameters (whether values or
-- addresses), and
-- (3) an area for the local variables of the subprogram
--
-- Once again, fields marked with C are used only by the compiler
--
type BTabEntry is record
Id : Alfa; -- Name of the block
Last_Id_Idx : Index; -- C index of the last identifier in this block
First_Param_Id_Idx : Index; -- C index of the first parameter in this block
Last_Param_Id_Idx : Index; -- C index of the last parameter in this block
-- (if first > last, it's parameterless)
PSize : Index; -- sum of the lengths of areas (1) & (2) above
VSize : Index := 0; -- sum of PSize and length of area (3)
-- (i.e. size of the activation record for
-- this block if it is a subprogram)
SrcFrom : Positive; -- Source code line count. Source starts here
SrcTo : Positive; -- and goes until here (* Manuel *)
end record;
fixed_area_size : constant := 5; -- Size of area (1) described above.
type Package_Table_Entry is record
first_public_declaration : Positive;
last_public_declaration : Natural; -- = 0 if none.
last_private_declaration : Natural; -- = 0 if none.
end record;
type Entity_Kind is -- RM 3.1
(
-- Declared number: untyped constant, like
-- "pi : constant := 3.1415927"; (RM 3.3.2).
Declared_Number_or_Enum_Item,
--
Variable,
TypeMark,
--
Paquetage,
Paquetage_Body,
Prozedure,
Prozedure_Intrinsic,
Funktion,
Funktion_Intrinsic,
--
aTask,
aEntry,
--
Loop_Identifier,
Alias -- Short name of another entity ("use" clause).
);
type Declaration_Kind is
(spec_unresolved, spec_resolved, complete,
param_in, param_in_out, param_out);
subtype Split_Declaration_Kind is Declaration_Kind range spec_unresolved .. complete;
subtype Parameter_Kind is Declaration_Kind range param_in .. param_out;
------------------------------
-- Identifier Table Entry --
------------------------------
type IdTabEntry is record
name : Alfa; -- identifier name in ALL CAPS
name_with_case : Alfa; -- identifier name with original casing
link : Index;
entity : Entity_Kind;
read_only : Boolean; -- If Entity = Variable and read_only = True,
-- it's a typed constant.
decl_kind : Declaration_Kind; -- Declaration kind: forward or complete.
-- Matters for a type, a constant, a subprogram;
-- Values param_in .. param_out are
-- for subprogram parameters.
xtyp : Exact_Subtyp; -- Subtype identification
block_or_pkg_ref : Index; -- Reference in the block or package tables.
normal : Boolean; -- value param?
lev : Nesting_Level;
adr_or_sz : HAC_Integer; -- Address, Size; index of aliased entity (USE) !! rather use block_or_pkg_ref ?!
end record;
-- Entity Meaning of Adr_or_Sz
-- -------------------------------------------------------------------------------
-- Declared_Number_or_Enum_Item Value (number), position (enumerated type)
-- Variable Relative position in the stack.
-- TypeMark Size (in PCode stack items) of an object
-- of the declared type.
-- Prozedure Index into the Object Code table.
-- Prozedure_Intrinsic Standard Procedure code (SP_Code).
-- Funktion Index into the Object Code table.
-- Funktion_Intrinsic Standard Function code (SF_Code).
-- aTask ?
-- aEntry ?
-- Label ?
-- Alias Index into the Identifier table of the aliased entity.
type Loop_Info is record
loop_Id : Natural; -- No_Id : no identifier
is_FOR_loop : Boolean; -- Emit k_FOR_Release_Stack for each exited FOR loop
start_line : Natural;
end record;
subtype Source_Line_String is String (1 .. 1000); -- Must be at least 200 (RM 2.2 (15))
-----------------------
-- Compiler tables --
-----------------------
type Arrays_Table_Type is array (1 .. AMax) of ATabEntry;
type Blocks_Table_Type is array (0 .. BMax) of BTabEntry;
type Display_Type is array (Nesting_Level) of Integer;
type Entries_Table_Type is array (0 .. entry_table_max) of Index;
type Identifier_Table_Type is array (0 .. Id_Table_Max) of IdTabEntry;
type Nested_Loop_Table_Type is array (1 .. loop_nesting_max) of Loop_Info;
type Packages_Table_Type is array (0 .. package_table_max) of Package_Table_Entry;
type Tasks_Definitions_Table_Type is array (0 .. TaskMax) of Index;
-- ^ Task #0 is main task.
type Use_HAT_Stack_Type is array (0 .. nesting_and_descending_max) of Boolean;
-- Display: keeps track of addressing by nesting level. See Ben-Ari Appendix A.
No_Id : constant := 0;
No_Id_Cache : constant := -1;
type Source_Stream_Access is access all Ada.Streams.Root_Stream_Type'Class;
package Id_Maps is new Ada.Containers.Hashed_Maps
(Key_Type => Alfa,
Element_Type => Positive,
Hash => Ada.Strings.Unbounded.Hash,
Equivalent_Keys => HAT."=");
type Current_Unit_Data is record
-- Current source code information and scanner data
compiler_stream : Source_Stream_Access;
source_file_name : HAT.VString; -- Indicative, for error messages
-- Parsing
line_count : Natural; -- Source line counter, used for listing
input_line : Source_Line_String;
c : Character; -- Character read from source program
CC : Integer; -- Character counter (=column in current line)
LL : Natural; -- Length of current line
-- Level 0 definitions visible to currently compiled unit:
level_0_def : Id_Maps.Map;
Use_HAT_Stack : Use_HAT_Stack_Type;
use_hat_stack_top : Natural;
end record;
-- Set current source stream (file, editor data, zipped file,...)
procedure Set_Source_Stream (
CUD : in out Current_Unit_Data;
s : access Ada.Streams.Root_Stream_Type'Class;
file_name : in String; -- Can be a virtual name (editor title, zip entry)
start_line : in Natural := 0 -- We could have a shebang or other Ada sources before
);
function Get_Source_Name (SD : Current_Unit_Data) return String;
type Compilation_Feedback is access procedure (message : String);
type Compilation_Trace_Parameters is record
pipe : Defs.Smart_Error_Pipe := null; -- Default: messages to Current_Error.
progress : Compilation_Feedback := null; -- Default: messages to Current_Output.
detail_level : Natural := 0;
end record;
default_trace : constant Compilation_Trace_Parameters := (others => <>);
procedure Silent_Diagnostics (diagnostic : Diagnostic_Kit) is null;
procedure Silent_Feedback (message : String) is null;
silent_trace : constant Compilation_Trace_Parameters :=
(Silent_Diagnostics'Access, Silent_Feedback'Access, 0);
type Dummy_Procedure_Access is access procedure;
package Exported_Procedure_Mapping is new Ada.Containers.Indefinite_Hashed_Maps
(Key_Type => String,
Element_Type => Dummy_Procedure_Access,
-- Actually: HAC_Sys.Interfacing.Exported_Procedure, but we
-- end up in a circular unit dependency mess.
Hash => Ada.Strings.Hash,
Equivalent_Keys => "=");
---------------------
-- Compiler_Data --
---------------------
type Compiler_Data is new Ada.Finalization.Limited_Controlled with record
CUD : Current_Unit_Data;
-- Scanning & Parsing
Sy, prev_sy : KeyWSymbol; -- Last KeyWSymbol read by InSymbol
syStart, syEnd : Integer; -- Start and end on line for the symbol in Sy
prev_sy_start,
prev_sy_end,
prev_sy_line : Integer;
Id : Alfa; -- Identifier from InSymbol
Id_with_case : Alfa; -- Same as Id, but with casing.
Id_location : Integer; -- Cache for Locate_CD_Id
INum : HAC_Integer; -- Integer from InSymbol
RNum : HAC_Float; -- FLOAT Number from InSymbol
SLeng : Integer; -- String Length
pkg_prefix : HAT.VString; -- Prefix of package being currently parsed.
-- Compiler tables. Floats and Strings are used by interpreter at run-time.
Arrays_Table : Arrays_Table_Type; -- NB: only static-sized arrays so far.
Blocks_Table : Blocks_Table_Type;
Display : Display_Type;
Entries_Table : Entries_Table_Type;
Float_Constants_Table : Float_Constants_Table_Type;
IdTab : Identifier_Table_Type;
Nested_Loop_Table : Nested_Loop_Table_Type;
Packages_Table : Packages_Table_Type;
Strings_Constants_Table : Strings_Constants_Table_Type;
Tasks_Definitions_Table : Tasks_Definitions_Table_Type;
-- Indices to compiler tables
Arrays_Count : Natural;
Blocks_Count : Natural;
Entries_Count : Natural;
Float_Constants_Count : Natural;
Id_Count : Natural;
loop_nesting_level : Natural;
Main_Proc_Id_Index : Natural;
Packages_Count : Natural;
String_Id_Index : Natural;
Strings_Table_Top : Natural;
Tasks_Definitions_Count : Natural;
-- Object code
-- Mostly for HAC VM / p-code -> will be moved to HAC_Sys.Targets.HAC_Virtual_Machine)
target : Targets.Abstract_Machine_Reference := null;
ObjCode : PCode.Object_Code_Table (0 .. CDMax);
LC : Integer; -- Location counter in the Object_Code_Table
CMax : Integer; -- Top of available ObjCode table;
-- CMax + 1 .. CDMax: variable initialization code
folded_instructions : Natural;
specialized_instructions : Natural;
-- Information about source code
Full_Block_Id : HAT.VString; -- Full block's Id (P1.P2.F3.P4)
Main_Program_ID : Alfa := Empty_Alfa; -- Main program name
Main_Program_ID_with_case : Alfa := Empty_Alfa;
Exported_Procedures : Exported_Procedure_Mapping.Map;
--
listing_requested : Boolean := False;
comp_dump_requested : Boolean := False;
listing : Ada.Text_IO.File_Type;
comp_dump : Ada.Text_IO.File_Type;
--
error_count, minor_error_count : Natural;
remarks : Remark_Set := default_remarks;
diags : Diagnostic_Set;
total_lines : Natural;
trace : Compilation_Trace_Parameters;
-- On `WITH X`, we start the recursive compilation of X,
-- if X is not yet compiled or built-in. We monitor the
-- recursion level for the fun of it.
recursion : Natural := 0;
end record;
overriding procedure Initialize (CD : in out Compiler_Data);
overriding procedure Finalize (CD : in out Compiler_Data);
function Is_HAC_VM (CD : Compiler_Data) return Boolean;
procedure Set_Target
(CD : in out Compiler_Data; new_target : Targets.Abstract_Machine_Reference);
type Compiler_Data_Access is access all Co_Defs.Compiler_Data;
-- Image function for compilation errors or out-of-range exception messages.
--
function Discrete_Image
(CD : Compiler_Data; value : HAC_Integer; Typ : Typen; Ref : Index) return String;
function Discrete_Range_Image
(CD : Compiler_Data; value_1, value_2 : HAC_Integer; Typ : Typen; Ref : Index) return String;
-- Size of a variable or subprogram parameter
--
function Size_of (CD : Compiler_Data; Id_Index : Natural) return Positive;
procedure Increment_Nesting_or_Descending_Level (CD : in out Compiler_Data);
procedure Decrement_Nesting_or_Descending_Level (CD : in out Compiler_Data);
Universe : constant HAT.VString := HAT.To_VString ("[-- The Universe --]");
type Constant_Rec is record
TP : Exact_Subtyp;
I : HAC_Integer; -- Includes Character and enumeration types (including Boolean)
R : HAC_Float;
end record;
end HAC_Sys.Co_Defs;
|