From 89024703a19d25c51f9c10d00a7f6cad15e6c952 Mon Sep 17 00:00:00 2001 From: gingold Date: Wed, 26 Oct 2005 04:01:32 +0000 Subject: ortho/debug and ortho/oread added --- README | 31 +- ortho/debug/Makefile | 29 + ortho/debug/ortho_debug-disp.adb | 982 +++++++++++++ ortho/debug/ortho_debug-disp.ads | 12 + ortho/debug/ortho_debug-main.adb | 133 ++ ortho/debug/ortho_debug.adb | 1959 ++++++++++++++++++++++++++ ortho/debug/ortho_debug.private.ads | 439 ++++++ ortho/debug/ortho_debug_front.ads | 2 + ortho/debug/ortho_ident.ads | 2 + ortho/debug/ortho_ident_hash.adb | 54 + ortho/debug/ortho_ident_hash.ads | 28 + ortho/debug/ortho_ident_simple.adb | 26 + ortho/debug/ortho_ident_simple.ads | 13 + ortho/debug/ortho_nodes.ads | 3 + ortho/oread/Makefile | 25 + ortho/oread/ortho_front.adb | 2650 +++++++++++++++++++++++++++++++++++ 16 files changed, 6384 insertions(+), 4 deletions(-) create mode 100644 ortho/debug/Makefile create mode 100644 ortho/debug/ortho_debug-disp.adb create mode 100644 ortho/debug/ortho_debug-disp.ads create mode 100644 ortho/debug/ortho_debug-main.adb create mode 100644 ortho/debug/ortho_debug.adb create mode 100644 ortho/debug/ortho_debug.private.ads create mode 100644 ortho/debug/ortho_debug_front.ads create mode 100644 ortho/debug/ortho_ident.ads create mode 100644 ortho/debug/ortho_ident_hash.adb create mode 100644 ortho/debug/ortho_ident_hash.ads create mode 100644 ortho/debug/ortho_ident_simple.adb create mode 100644 ortho/debug/ortho_ident_simple.ads create mode 100644 ortho/debug/ortho_nodes.ads create mode 100644 ortho/oread/Makefile create mode 100644 ortho/oread/ortho_front.adb diff --git a/README b/README index 6d5e8f9..0a9dfae 100644 --- a/README +++ b/README @@ -4,6 +4,9 @@ GHDL is free software. See the file COPYING for copying permission. The manuals, and some of the runtime libraries, are under different terms; see the individual source files for details. +### Creating a source tar. ### +############################## + GHDL requires GCC to be compiled. The exact version of GCC is defined in ./translate/gcc/dist.sh, in the GCCVERSION= line. Do not try to change the version, this may not compile or create a buggy compiler. @@ -19,6 +22,9 @@ $ ./dist.sh sources # This generates a ghdl-VERSION.tar.bz2 file. +### Compiling for development. ### +################################### + These steps can make GHDL development hard. You can avoid to compile GCC everytime. To do this, edit ortho/gcc/Makefile and set two variables: AGCC_GCCSRC_DIR is the GCC sources directory, while AGCC_GCCOBJ_DIR is where @@ -27,17 +33,34 @@ the GHDL back-end (ghdl1) in ./translate: $ make BE=gcc the GHDL driver in ./translate/ghdldrv: $ make ghdl_gcc -the GHDL run-time (GRT) in ./translate/grt: +the VHDL libraries: + $ cd translate/ghdldrv + $ make install.all +and the GHDL run-time (GRT) in ./translate/grt: $ make To use this GRT, you must create two links in translate/lib: $ ln -s ../grt/grt.lst . $ ln -s ../grt/libgrt.a . -You should also compile the VHDL libraries: - $ cd translate/ghdldrv - $ make install.all Once this is done, you can use the ghdl_gcc from translate/ghdldrv. +### Compiling and using the debug back-end. ### +################################################ + +Debugging GHDL outputs can be very difficuly with the GCC back-end, since you +don't see the high level code generated by GHDL. To help debugging the +translator, I have written a debug back-end. This back-end is used instead of +the GCC back-end and displays pseudo-code (as well as declarations). This +pseudo-code can be then compiled with a reader. +To compile it, go to ./translate: + $ make BE=debug +This creates a ghdl1-debug. Then go to ./ortho/oread and compile the reader: + $ make BE=gcc +You can now use this chain by adding the '--post' option to the ghdl driver: + $ ghdl_gcc -a --post my_file.vhdl +This creates an intermediate file my_file.on, which is then compiled by + oread-gcc. + Tristan. diff --git a/ortho/debug/Makefile b/ortho/debug/Makefile new file mode 100644 index 0000000..8bb4ffc --- /dev/null +++ b/ortho/debug/Makefile @@ -0,0 +1,29 @@ +BE=debug +ortho_srcdir=.. + +orthobe_srcdir=$(ortho_srcdir)/$(BE) + +GNATMAKE=gnatmake +CC=gcc +CFLAGS=-g +ALL_GNAT_FLAGS=-pipe -g -gnato -gnatwl -gnatf -gnaty3befhkmr -gnatwu +GNATMAKE_FLAGS=-m $(ALL_GNAT_FLAGS) $(GNAT_FLAGS) -aI$(ortho_srcdir) -aI$(orthobe_srcdir) -aI. +#LARGS=-largs -static +SED=sed + +all: $(ortho_exec) + + +$(ortho_exec): force $(orthobe_srcdir)/ortho_debug.ads + gnatmake -o $@ $(GNATMAKE_FLAGS) ortho_debug-main -bargs -E $(LARGS) + +clean: + $(RM) -f *.o *.ali *~ b~*.ad? ortho_nodes-main + $(RM) $(orthobe_srcdir)/ortho_debug.ads + +force: + +ORTHO_PACKAGE=Ortho_Debug +ORTHO_BASENAME=$(orthobe_srcdir)/ortho_debug + +include $(ortho_srcdir)/Makefile.inc \ No newline at end of file diff --git a/ortho/debug/ortho_debug-disp.adb b/ortho/debug/ortho_debug-disp.adb new file mode 100644 index 0000000..27faf98 --- /dev/null +++ b/ortho/debug/ortho_debug-disp.adb @@ -0,0 +1,982 @@ +package body Ortho_Debug.Disp is + package Formated_Output is + use Interfaces.C_Streams; + + type Disp_Context is limited private; + + procedure Init_Context (File : FILEs); + + -- Save the current context, and create a new one. + procedure Push_Context (File : FILEs; Prev_Ctx : out Disp_Context); + + -- Restore a previous context, saved by Push_Context. + procedure Pop_Context (Prev_Ctx : Disp_Context); + + procedure Put (Str : String); + + procedure Put_Line (Str : String); + + -- Add a tabulation. + -- Every new line will start at this tabulation. + procedure Add_Tab; + + -- Removed a tabulation. + -- The next new line will start at the previous tabulation. + procedure Rem_Tab; + + -- Flush the current output. + procedure Flush; + + -- Return TRUE if the ident level is nul. + function Is_Top return Boolean; + + procedure Put_Tab; + + procedure New_Line; + + procedure Put (C : Character); + + procedure Put_Trim (Str : String); + + procedure Set_Mark; + private + type Disp_Context is record + -- File where the info are written to. + File : FILEs; + -- Line number of the line to be written. + Lineno : Natural; + -- Buffer for the current line. + Line : String (1 .. 256); + -- Number of characters currently in the line. + Line_Len : Natural; + + -- Current tabulation. + Tab : Natural; + -- Tabulation to be used for the next line. + Next_Tab : Natural; + + Mark : Natural; + end record; + end Formated_Output; + + package body Formated_Output is + -- The current context. + Ctx : Disp_Context; + + procedure Init_Context (File : FILEs) is + begin + Ctx.File := File; + Ctx.Lineno := 1; + Ctx.Line_Len := 0; + Ctx.Tab := 0; + Ctx.Next_Tab := 0; + Ctx.Mark := 0; + end Init_Context; + + procedure Push_Context (File : FILEs; Prev_Ctx : out Disp_Context) + is + begin + Prev_Ctx := Ctx; + Init_Context (File); + end Push_Context; + + -- Restore a previous context, saved by Push_Context. + procedure Pop_Context (Prev_Ctx : Disp_Context) is + begin + Flush; + Ctx := Prev_Ctx; + end Pop_Context; + + procedure Flush + is + Status : size_t; + Res : int; + begin + if Ctx.Line_Len > 0 then + Status := fwrite (Ctx.Line'Address, size_t (Ctx.Line_Len), 1, + Ctx.File); + Res := fputc (Character'Pos (ASCII.Lf), Ctx.File); + Ctx.Line_Len := 0; + end if; + Ctx.Mark := 0; + end Flush; + + function Is_Top return Boolean is + begin + return Ctx.Tab = 0; + end Is_Top; + + procedure Put_Tab is + begin + Ctx.Line (1 .. Ctx.Next_Tab) := (others => ' '); + Ctx.Line_Len := Ctx.Next_Tab; + Ctx.Next_Tab := Ctx.Tab + 2; + end Put_Tab; + + procedure Put (Str : String) is + Saved : String (1 .. 80); + Len : Natural; + begin + if Ctx.Line_Len + Str'Length >= 80 then + if Ctx.Mark > 0 then + Len := Ctx.Line_Len - Ctx.Mark + 1; + Saved (1 .. Len) := Ctx.Line (Ctx.Mark .. Ctx.Line_Len); + Ctx.Line_Len := Ctx.Mark - 1; + Flush; + Put_Tab; + Ctx.Line (Ctx.Line_Len + 1 .. Ctx.Line_Len + Len) := + Saved (1 .. Len); + Ctx.Line_Len := Ctx.Line_Len + Len; + else + Flush; + end if; + end if; + if Ctx.Line_Len = 0 then + Put_Tab; + end if; + Ctx.Line (Ctx.Line_Len + 1 .. Ctx.Line_Len + Str'Length) := Str; + Ctx.Line_Len := Ctx.Line_Len + Str'Length; + end Put; + + procedure Put_Trim (Str : String) is + begin + for I in Str'Range loop + if Str (I) /= ' ' then + Put (Str (I .. Str'Last)); + return; + end if; + end loop; + end Put_Trim; + + procedure Put_Line (Str : String) is + begin + Put (Str); + Flush; + Ctx.Next_Tab := Ctx.Tab; + end Put_Line; + + procedure New_Line + is + Status : int; + begin + if Ctx.Line_Len > 0 then + Flush; + else + Status := fputc (Character'Pos (ASCII.LF), Ctx.File); + end if; + Ctx.Next_Tab := Ctx.Tab; + end New_Line; + + procedure Put (C : Character) is + S : String (1 .. 1) := (1 => C); + begin + Put (S); + end Put; + + -- Add a tabulation. + -- Every new line will start at this tabulation. + procedure Add_Tab is + begin + Ctx.Tab := Ctx.Tab + 2; + Ctx.Next_Tab := Ctx.Tab; + end Add_Tab; + + -- Removed a tabulation. + -- The next new line will start at the previous tabulation. + procedure Rem_Tab is + begin + Ctx.Tab := Ctx.Tab - 2; + Ctx.Next_Tab := Ctx.Tab; + end Rem_Tab; + + procedure Set_Mark is + begin + Ctx.Mark := Ctx.Line_Len; + end Set_Mark; + end Formated_Output; + + use Formated_Output; + + procedure Init_Context (File : Interfaces.C_Streams.FILEs) is + begin + Formated_Output.Init_Context (File); + end Init_Context; + + procedure Disp_Enode (E : O_Enode); + procedure Disp_Lnode (Node : O_Lnode); + procedure Disp_Snode (First, Last : O_Snode); + procedure Disp_Dnode (Decl : O_Dnode); + procedure Disp_Tnode (Atype : O_Tnode; Full : Boolean); + + procedure Disp_Ident (Id : O_Ident) is + begin + Put (Get_String (Id)); + end Disp_Ident; + + procedure Disp_Tnode_Name (Atype : O_Tnode) is + begin + Disp_Tnode (Atype, False); + end Disp_Tnode_Name; + + procedure Disp_Dnode_Name (Decl : O_Dnode) is + begin + Disp_Ident (Decl.Name); + end Disp_Dnode_Name; + + procedure Disp_Loop_Name (Stmt : O_Snode) is + begin + Put ("loop" & Natural'Image (Stmt.Loop_Level)); + end Disp_Loop_Name; + + function Get_Enode_Name (Kind : OE_Kind) return String + is + begin + case Kind is +-- when OE_Boolean_Lit => +-- return "boolean_lit"; +-- when OE_Unsigned_Lit => +-- return "unsigned_lit"; +-- when OE_Signed_Lit => +-- return "signed lit"; +-- when OE_Float_Lit => +-- return "float lit"; +-- when OE_Null_Lit => +-- return "null lit"; +-- when OE_Enum_Lit => +-- return "enum lit"; + +-- when OE_Sizeof_Lit => +-- return "sizeof lit"; +-- when OE_Offsetof_Lit => +-- return "offsetof lit"; +-- when OE_Aggregate => +-- return "aggregate"; +-- when OE_Aggr_Element => +-- return "aggr_element"; +-- when OE_Union_Aggr => +-- return "union aggr"; + + when OE_Lit => + return "lit"; + when OE_Add_Ov => + return "+#"; + when OE_Sub_Ov => + return "-#"; + when OE_Mul_Ov => + return "*#"; + when OE_Div_Ov => + return "/#"; + when OE_Rem_Ov => + return "rem#"; + when OE_Mod_Ov => + return "mod#"; + when OE_Exp_Ov => + return "**#"; + + when OE_And => + return "and"; + when OE_Or => + return "or"; + when OE_Xor => + return "xor"; + when OE_And_Then => + return "and_then"; + when OE_Or_Else => + return "or_else"; + + when OE_Not => + return "not"; + when OE_Neg_Ov => + return "-"; + when OE_Abs_Ov => + return "abs"; + + when OE_Eq => + return "="; + when OE_Neq => + return "/="; + when OE_Le => + return "<="; + when OE_Lt => + return "<"; + when OE_Ge => + return ">="; + when OE_Gt => + return ">"; + + when OE_Function_Call => + return "function call"; + when OE_Convert_Ov => + return "convert_ov"; + when OE_Address => + return "address"; + when OE_Unchecked_Address => + return "unchecked_address"; +-- when OE_Subprogram_Address => +-- return "subprg_address"; + when OE_Alloca => + return "alloca"; + when OE_Value => + return "value"; + when OE_Nil => + return "??"; + end case; + end Get_Enode_Name; + + function Get_Lnode_Name (Kind : OL_Kind) return String + is + begin + case Kind is + when OL_Obj => + return "obj"; + when OL_Indexed_Element => + return "indexed_element"; + when OL_Slice => + return "slice"; + when OL_Selected_Element => + return "selected_element"; + when OL_Access_Element => + return "access_element"; +-- when OL_Param_Ref => +-- return "param_ref"; +-- when OL_Var_Ref => +-- return "var_ref"; +-- when OL_Const_Ref => +-- return "const_ref"; + end case; + end Get_Lnode_Name; + + procedure Disp_Enode_Name (Kind : OE_Kind) is + begin + Put (Get_Enode_Name (Kind)); + end Disp_Enode_Name; + + procedure Disp_Assoc_List (Head : O_Anode) + is + El : O_Anode; + begin + El := Head; + Put ("("); + if El /= null then + loop + Disp_Enode (El.Actual); + El := El.Next; + exit when El = null; + Put (", "); + end loop; + end if; + Put (")"); + end Disp_Assoc_List; + + function Image (Lit : Integer) return String + is + S : String := Integer'Image (Lit); + begin + if S (1) = ' ' then + return S (2 .. S'Length); + else + return S; + end if; + end Image; + + procedure Disp_Lit (Lit_Type : O_Tnode; Str : String) is + begin + if False then + Put_Trim (Str); + else + Disp_Tnode_Name (Lit_Type); + Put ("'["); + Put_Trim (Str); + Put (']'); + end if; + end Disp_Lit; + + procedure Disp_Cnode (C : O_Cnode) is + begin + case C.Kind is + when OC_Unsigned_Lit => + if False and then (C.U_Val >= Character'Pos(' ') + and C.U_Val <= Character'Pos ('~')) + then + Put ('''); + Put (Character'Val (C.U_Val)); + Put ('''); + else + Disp_Lit (C.Ctype, Unsigned_64'Image (C.U_Val)); + end if; + when OC_Signed_Lit => + Disp_Lit (C.Ctype, Integer_64'Image (C.S_Val)); + when OC_Float_Lit => + Disp_Lit (C.Ctype, IEEE_Float_64'Image (C.F_Val)); + when OC_Boolean_Lit => + Disp_Lit (C.Ctype, Get_String (C.B_Id)); + when OC_Null_Lit => + Disp_Lit (C.Ctype, "null"); + when OC_Enum_Lit => + Disp_Lit (C.Ctype, Get_String (C.E_Name)); + when OC_Sizeof_Lit => + Disp_Tnode_Name (C.Ctype); + Put ("'sizeof ("); + Disp_Tnode_Name (C.S_Type); + Put (")"); + when OC_Offsetof_Lit => + Disp_Tnode_Name (C.Ctype); + Put ("'offsetof ("); + Disp_Tnode_Name (C.Off_Field.Parent); + Put ("."); + Disp_Ident (C.Off_Field.Ident); + Put (")"); + when OC_Aggregate => + declare + El : O_Cnode; + Field : O_Fnode; + begin + Put ('{'); + El := C.Aggr_Els; + if C.Ctype.Kind = ON_Record_Type then + Field := C.Ctype.Elements; + else + Field := null; + end if; + if El /= null then + loop + Set_Mark; + if Field /= null then + Put ('.'); + Disp_Ident (Field.Ident); + Put (" = "); + Field := Field.Next; + end if; + Disp_Cnode (El.Aggr_Value); + El := El.Aggr_Next; + exit when El = null; + Put (", "); + end loop; + end if; + Put ('}'); + end; + when OC_Aggr_Element => + Disp_Cnode (C.Aggr_Value); + when OC_Union_Aggr => + Put ('{'); + Put ('.'); + Disp_Ident (C.Uaggr_Field.Ident); + Put (" = "); + Disp_Cnode (C.Uaggr_Value); + Put ('}'); + when OC_Address => + Disp_Tnode_Name (C.Ctype); + Put ("'address ("); + Disp_Dnode_Name (C.Decl); + Put (")"); + when OC_Unchecked_Address => + Disp_Tnode_Name (C.Ctype); + Put ("'unchecked_address ("); + Disp_Dnode_Name (C.Decl); + Put (")"); + when OC_Subprogram_Address => + Disp_Tnode_Name (C.Ctype); + Put ("'subprg_addr ("); + Disp_Dnode_Name (C.Decl); + Put (")"); + end case; + end Disp_Cnode; + + procedure Disp_Enode (E : O_Enode) + is + begin + case E.Kind is + when OE_Lit => + Disp_Cnode (E.Lit); + when OE_Dyadic_Expr_Kind => + Put ("("); + Disp_Enode (E.Left); + Put (' '); + Disp_Enode_Name (E.Kind); + Put (' '); + Disp_Enode (E.Right); + Put (')'); + when OE_Compare_Expr_Kind => + Disp_Tnode_Name (E.Rtype); + Put ("'("); + Disp_Enode (E.Left); + Put (' '); + Disp_Enode_Name (E.Kind); + Put (' '); + Disp_Enode (E.Right); + Put (')'); + when OE_Monadic_Expr_Kind => + Disp_Enode_Name (E.Kind); + if E.Kind /= OE_Neg_Ov then + Put (' '); + end if; + Disp_Enode (E.Operand); + when OE_Address => + Disp_Tnode_Name (E.Rtype); + Put ("'address ("); + Disp_Lnode (E.Lvalue); + Put (")"); + when OE_Unchecked_Address => + Disp_Tnode_Name (E.Rtype); + Put ("'unchecked_address ("); + Disp_Lnode (E.Lvalue); + Put (")"); + when OE_Convert_Ov => + Disp_Tnode_Name (E.Rtype); + Put ("'conv ("); + Disp_Enode (E.Conv); + Put (')'); + when OE_Function_Call => + Disp_Dnode_Name (E.Func); + Put (' '); + Disp_Assoc_List (E.Assoc); + when OE_Alloca => + Disp_Tnode_Name (E.Rtype); + Put ("'alloca ("); + Disp_Enode (E.A_Size); + Put (')'); + when OE_Value => + Disp_Lnode (E.Value); + when OE_Nil => + null; + end case; + end Disp_Enode; + + procedure Disp_Lnode (Node : O_Lnode) is + begin + case Node.Kind is + when OL_Obj => + Disp_Dnode_Name (Node.Obj); + when OL_Access_Element => + Disp_Enode (Node.Acc_Base); + Put (".all"); + when OL_Indexed_Element => + Disp_Lnode (Node.Array_Base); + Put ('['); + Disp_Enode (Node.Index); + Put (']'); + when OL_Slice => + Disp_Lnode (Node.Slice_Base); + Put ('['); + Disp_Enode (Node.Slice_Index); + Put ("...]"); + when OL_Selected_Element => + Disp_Lnode (Node.Rec_Base); + Put ('.'); + Disp_Ident (Node.Rec_El.Ident); +-- when OL_Var_Ref +-- | OL_Const_Ref +-- | OL_Param_Ref => +-- Disp_Dnode_Name (Node.Decl); + end case; + end Disp_Lnode; + + procedure Disp_Fnodes (First : O_Fnode) + is + El : O_Fnode; + begin + Add_Tab; + El := First; + while El /= null loop + Disp_Ident (El.Ident); + Put (": "); + Disp_Tnode (El.Ftype, False); + Put_Line ("; "); + El := El.Next; + end loop; + Rem_Tab; + end Disp_Fnodes; + + procedure Disp_Tnode (Atype : O_Tnode; Full : Boolean) is + begin + if not Full and Atype.Decl /= null then + Disp_Ident (Atype.Decl.Name); + return; + end if; + case Atype.Kind is + when ON_Boolean_Type => + Put ("boolean {"); + Disp_Ident (Atype.False_N.B_Id); + Put (", "); + Disp_Ident (Atype.True_N.B_Id); + Put ("}"); + when ON_Unsigned_Type => + Put ("unsigned ("); + Put_Trim (Unsigned_32'Image (8 * Atype.Size)); + Put (")"); + when ON_Signed_Type => + Put ("signed ("); + Put_Trim (Unsigned_32'Image (8 * Atype.Size)); + Put (")"); + when ON_Float_Type => + Put ("float"); + when ON_Enum_Type => + declare + El : O_Cnode; + begin + Put ("enum {"); + El := Atype.Literals; + while El /= O_Cnode_Null loop + Set_Mark; + Disp_Ident (El.E_Name); + Put (" = "); + Put (Image (El.E_Val)); + El := El.E_Next; + exit when El = O_Cnode_Null; + Put (", "); + end loop; + Put ("}"); + end; + when ON_Array_Type => + Put ("array ["); + Disp_Tnode (Atype.Index_Type, False); + Put ("] of "); + Disp_Tnode (Atype.El_Type, False); + when ON_Access_Type => + Put ("access "); + if Atype.D_Type /= O_Tnode_Null then + Disp_Tnode (Atype.D_Type, False); + end if; + when ON_Record_Type => + Put_Line ("record "); + Disp_Fnodes (Atype.Elements); + Put ("end record"); + when ON_Union_Type => + Put_Line ("union "); + Disp_Fnodes (Atype.Elements); + Put ("end union"); + when ON_Array_Sub_Type => + Put ("subarray "); + Disp_Tnode_Name (Atype.Base_Type); + Put ("["); + Disp_Cnode (Atype.Length); + Put ("]"); + end case; + end Disp_Tnode; + + procedure Disp_Storage_Name (Storage : O_Storage) is + begin + case Storage is + when O_Storage_External => + Put ("external"); + when O_Storage_Public => + Put ("public"); + when O_Storage_Private => + Put ("private"); + when O_Storage_Local => + Put ("local"); + end case; + end Disp_Storage_Name; + + procedure Disp_Decls (Decls : O_Dnode) + is + El : O_Dnode; + begin + El := Decls; + while El /= null loop + Disp_Dnode (El); + El := El.Next; + if Is_Top then + -- NOTE: some declaration does not disp anything, so there may be + -- double new line. + New_Line; + end if; + end loop; + end Disp_Decls; + + procedure Disp_Function_Decl (Decl : O_Dnode) is + begin + Disp_Storage_Name (Decl.Storage); + Put (" "); + if Decl.Dtype = null then + Put ("procedure "); + else + Put ("function "); + end if; + Disp_Ident (Decl.Name); + Put_Line (" ("); + Add_Tab; + declare + El : O_Dnode; + begin + El := Decl.Interfaces; + if El /= null then + loop + Disp_Dnode (El); + El := El.Next; + exit when El = null; + Put_Line (";"); + end loop; + end if; + Put (")"); + end; + if Decl.Dtype /= null then + New_Line; + Put ("return "); + Disp_Tnode (Decl.Dtype, False); + end if; + Rem_Tab; + end Disp_Function_Decl; + + procedure Disp_Dnode (Decl : O_Dnode) is + begin + case Decl.Kind is + when ON_Type_Decl => + Put ("type "); + Disp_Ident (Decl.Name); + Put (" is "); + if not Decl.Dtype.Uncomplete then + Disp_Tnode (Decl.Dtype, True); + else + case Decl.Dtype.Kind is + when ON_Record_Type => + Put ("record"); + when ON_Access_Type => + Put ("access"); + when others => + raise Program_Error; + end case; + end if; + Put_Line (";"); + when ON_Completed_Type_Decl => + Put ("type "); + Disp_Ident (Decl.Name); + Put (" is "); + Disp_Tnode (Decl.Dtype, True); + Put_Line (";"); + when ON_Const_Decl => + Disp_Storage_Name (Decl.Storage); + Put (" "); + Put ("constant "); + Disp_Ident (Decl.Name); + Put (" : "); + Disp_Tnode_Name (Decl.Dtype); + Put_Line (";"); + when ON_Const_Value => + Put ("constant "); + Disp_Ident (Decl.Name); + Put (" := "); + Disp_Cnode (Decl.Value); + Put_Line (";"); + when ON_Var_Decl => + Disp_Storage_Name (Decl.Storage); + Put (" "); + Put ("var "); + Disp_Ident (Decl.Name); + Put (" : "); + Disp_Tnode_Name (Decl.Dtype); + Put_Line (";"); + when ON_Function_Decl => + if Decl.Next = null or Decl.Next /= Decl.Func_Body then + -- This is a forward/external declaration. + Disp_Function_Decl (Decl); + Put_Line (";"); + end if; + when ON_Function_Body => + Disp_Function_Decl (Decl.Func_Decl); + New_Line; + Disp_Snode (Decl.Func_Stmt, Decl.Func_Stmt); + when ON_Interface_Decl => + Disp_Ident (Decl.Name); + Put (": "); + Disp_Tnode (Decl.Dtype, False); + when ON_Debug_Line_Decl => + Put_Line ("--#" & Natural'Image (Decl.Line)); + when ON_Debug_Comment_Decl => + Put_Line ("-- " & Decl.Comment.all); + when ON_Debug_Filename_Decl => + Put_Line ("--F " & Decl.Filename.all); + end case; + end Disp_Dnode; + + procedure Disp_Snode (First : O_Snode; Last : O_Snode) is + Stmt : O_Snode; + begin + Stmt := First; + loop + --if Stmt.Kind = ON_Elsif_Stmt or Stmt.Kind = ON_When_Stmt then + -- Put_Indent (Tab - 1); + --else + -- Put_Indent (Tab); + --end if; + case Stmt.Kind is + when ON_Declare_Stmt => + Put_Line ("declare"); + Add_Tab; + Disp_Decls (Stmt.Decls); + Rem_Tab; + Put_Line ("begin"); + Add_Tab; + if Stmt.Stmts /= null then + Disp_Snode (Stmt.Stmts, null); + end if; + Rem_Tab; + Put_Line ("end;"); + when ON_Assign_Stmt => + Disp_Lnode (Stmt.Target); + Put (" := "); + Disp_Enode (Stmt.Value); + Put_Line (";"); + when ON_Return_Stmt => + Put ("return "); + if Stmt.Ret_Val /= null then + Disp_Enode (Stmt.Ret_Val); + end if; + Put_Line (";"); + when ON_If_Stmt => + Add_Tab; + Disp_Snode (Stmt.Next, Stmt.If_Last); + Stmt := Stmt.If_Last; + Rem_Tab; + Put_Line ("end if;"); + when ON_Elsif_Stmt => + Rem_Tab; + if Stmt.Cond = null then + Put_Line ("else"); + else + if First = Stmt then + Put ("if "); + else + Put ("elsif "); + end if; + Disp_Enode (Stmt.Cond); + Put_Line (" then"); + end if; + Add_Tab; + when ON_Loop_Stmt => + Disp_Loop_Name (Stmt); + Put_Line (":"); + Add_Tab; + Disp_Snode (Stmt.Next, Stmt.Loop_Last); + Stmt := Stmt.Loop_Last; + Rem_Tab; + Put_Line ("end loop;"); + when ON_Exit_Stmt => + Put ("exit "); + Disp_Loop_Name (Stmt.Loop_Id); + Put_Line (";"); + when ON_Next_Stmt => + Put ("next "); + Disp_Loop_Name (Stmt.Loop_Id); + Put_Line (";"); + when ON_Case_Stmt => + Put ("case "); + Disp_Enode (Stmt.Selector); + Put_Line (" is"); + Add_Tab; + Disp_Snode (Stmt.Next, Stmt.Case_Last); + Stmt := Stmt.Case_Last; + Rem_Tab; + Put_Line ("end case;"); + when ON_When_Stmt => + declare + Choice: O_Choice; + begin + Rem_Tab; + Choice := Stmt.Choice_List; + while Choice /= null loop + Put ("when "); + case Choice.Kind is + when ON_Choice_Expr => + Disp_Cnode (Choice.Expr); + when ON_Choice_Range => + Disp_Cnode (Choice.Low); + Put (" ... "); + Disp_Cnode (Choice.High); + when ON_Choice_Default => + Put ("default"); + end case; + Put_Line (" =>"); + Choice := Choice.Next; + end loop; + Add_Tab; + end; + when ON_Call_Stmt => + Disp_Dnode_Name (Stmt.Proc); + Put (' '); + Disp_Assoc_List (Stmt.Assoc); + Put_Line (";"); + when ON_Debug_Line_Stmt => + Put_Line ("--#" & Natural'Image (Stmt.Line)); + when ON_Debug_Comment_Stmt => + Put_Line ("-- " & Stmt.Comment.all); + end case; + exit when Stmt = Last; + Stmt := Stmt.Next; + exit when Stmt = null and Last = null; + end loop; + end Disp_Snode; + + procedure Disp_Ortho (Decls : O_Snode) is + begin + Disp_Decls (Decls.Decls); + Flush; + end Disp_Ortho; + + procedure Disp_Tnode_Decl (N : O_Tnode) is + begin + Disp_Ident (N.Decl.Name); + Put (" : "); + Disp_Tnode (N, True); + end Disp_Tnode_Decl; + + procedure Debug_Tnode (N : O_Tnode) + is + Ctx : Disp_Context; + begin + Push_Context (Interfaces.C_Streams.stdout, Ctx); + Disp_Tnode_Decl (N); + Pop_Context (Ctx); + end Debug_Tnode; + + procedure Debug_Enode (N : O_Enode) + is + Ctx : Disp_Context; + begin + Push_Context (Interfaces.C_Streams.stdout, Ctx); + Disp_Enode (N); + Put (" : "); + Disp_Tnode_Decl (N.Rtype); + Pop_Context (Ctx); + end Debug_Enode; + + procedure Debug_Fnode (N : O_Fnode) + is + Ctx : Disp_Context; + begin + Push_Context (Interfaces.C_Streams.stdout, Ctx); + Disp_Ident (N.Ident); + Put (": "); + Disp_Tnode (N.Ftype, False); + Pop_Context (Ctx); + end Debug_Fnode; + + procedure Debug_Dnode (N : O_Dnode) + is + Ctx : Disp_Context; + begin + Push_Context (Interfaces.C_Streams.stdout, Ctx); + Disp_Dnode (N); + Pop_Context (Ctx); + end Debug_Dnode; + + procedure Debug_Lnode (N : O_Lnode) + is + Ctx : Disp_Context; + begin + Push_Context (Interfaces.C_Streams.stdout, Ctx); + Disp_Lnode (N); + Put (" : "); + Disp_Tnode_Decl (N.Rtype); + Pop_Context (Ctx); + end Debug_Lnode; + + procedure Debug_Snode (N : O_Snode) + is + Ctx : Disp_Context; + begin + Push_Context (Interfaces.C_Streams.stdout, Ctx); + Disp_Snode (N, null); + Pop_Context (Ctx); + end Debug_Snode; +end Ortho_Debug.Disp; diff --git a/ortho/debug/ortho_debug-disp.ads b/ortho/debug/ortho_debug-disp.ads new file mode 100644 index 0000000..1f8a028 --- /dev/null +++ b/ortho/debug/ortho_debug-disp.ads @@ -0,0 +1,12 @@ +with Interfaces.C_Streams; + +package Ortho_Debug.Disp is + -- Initialize the current context. + -- Must be called before any use of the DISP_* subprograms. + procedure Init_Context (File : Interfaces.C_Streams.FILEs); + + -- Disp nodes in a pseudo-language. + procedure Disp_Ortho (Decls : O_Snode); + +private +end Ortho_Debug.Disp; diff --git a/ortho/debug/ortho_debug-main.adb b/ortho/debug/ortho_debug-main.adb new file mode 100644 index 0000000..7da84d5 --- /dev/null +++ b/ortho/debug/ortho_debug-main.adb @@ -0,0 +1,133 @@ +with Ada.Command_Line; use Ada.Command_Line; +with Ada.Unchecked_Deallocation; +with Ada.Text_IO; use Ada.Text_IO; +with Ortho_Debug; use Ortho_Debug; +with Ortho_Debug_Front; use Ortho_Debug_Front; +with Ortho_Debug.Disp; +with System; use System; +with Interfaces.C_Streams; use Interfaces.C_Streams; + +procedure Ortho_Debug.Main is + -- Do not output the ortho code. + Flag_Silent : Boolean := False; + + -- Force output, even in case of crash. + Flag_Force : Boolean := False; + + I : Natural; + Argc : Natural; + Arg : String_Acc; + Opt : String_Acc; + Res : Natural; + File : String_Acc; + Output : FILEs; + R : Boolean; + + procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation + (Name => String_Acc, Object => String); +begin + Ortho_Debug_Front.Init; + Output := NULL_Stream; + + Set_Exit_Status (Failure); + + -- Decode options. + Argc := Argument_Count; + I := 1; + loop + exit when I > Argc; + exit when Argument (I) (1) /= '-'; + if Argument (I) = "--silent" or else Argument (I) = "-quiet" then + Flag_Silent := True; + I := I + 1; + elsif Argument (I) = "--force" then + Flag_Force := True; + I := I + 1; + elsif Argument (I)'Length >= 2 and then Argument (I)(2) = 'g' then + -- Skip -g[XXX] flags. + I := I + 1; + elsif Argument (I) = "-o" and then I + 1 <= Argc then + -- TODO: write the output to the file ? + if Output /= NULL_Stream then + Put_Line (Command_Name & ": only one output allowed"); + return; + end if; + declare + Name : String := Argument (I + 1) & ASCII.Nul; + Mode : String := 'w' & ASCII.Nul; + begin + Output := fopen (Name'Address, Mode'Address); + if Output = NULL_Stream then + Put_Line (Command_Name & ": cannot open " & Argument (I + 1)); + return; + end if; + end; + I := I + 2; + else + Opt := new String'(Argument (I)); + if I < Argc then + Arg := new String'(Argument (I + 1)); + else + Arg := null; + end if; + Res := Ortho_Debug_Front.Decode_Option (Opt, Arg); + Unchecked_Deallocation (Opt); + Unchecked_Deallocation (Arg); + if Res = 0 then + Put_Line (Argument (I) & ": unknown option"); + return; + else + I := I + Res; + end if; + end if; + end loop; + + -- Initialize tree. + begin + Ortho_Debug.Init; + + if I <= Argc then + R := True; + for J in I .. Argc loop + File := new String'(Argument (J)); + R := R and Ortho_Debug_Front.Parse (File); + Unchecked_Deallocation (File); + end loop; + else + R := Ortho_Debug_Front.Parse (null); + end if; + Ortho_Debug.Finish; + exception + when others => + if not Flag_Force then + raise; + else + R := False; + end if; + end; + + -- Write down the result. + if (R and (Output /= NULL_Stream or not Flag_Silent)) + or Flag_Force + then + if Output = NULL_Stream then + Ortho_Debug.Disp.Init_Context (stdout); + else + Ortho_Debug.Disp.Init_Context (Output); + end if; + Ortho_Debug.Disp.Disp_Ortho (Ortho_Debug.Top); + if Output /= NULL_Stream then + declare + Status : int; + begin + Status := fclose (Output); + end; + end if; + end if; + + if R then + Set_Exit_Status (Success); + else + Set_Exit_Status (Failure); + end if; +end Ortho_Debug.Main; diff --git a/ortho/debug/ortho_debug.adb b/ortho/debug/ortho_debug.adb new file mode 100644 index 0000000..0e6a616 --- /dev/null +++ b/ortho/debug/ortho_debug.adb @@ -0,0 +1,1959 @@ +with Ada.Unchecked_Deallocation; + +package body Ortho_Debug is + -- Metrics: + -- Alignment and size for an address. + Metric_Access_Align : constant Natural := 2; + Metric_Access_Size : constant Unsigned_32 := 4; + + type ON_Op_To_OE_Type is array (ON_Op_Kind) of OE_Kind; + ON_Op_To_OE : constant ON_Op_To_OE_Type := + ( + ON_Nil => OE_Nil, + + -- Dyadic operations. + ON_Add_Ov => OE_Add_Ov, + ON_Sub_Ov => OE_Sub_Ov, + ON_Mul_Ov => OE_Mul_Ov, + ON_Div_Ov => OE_Div_Ov, + ON_Rem_Ov => OE_Rem_Ov, + ON_Mod_Ov => OE_Mod_Ov, + + -- Binary operations. + ON_And => OE_And, + ON_Or => OE_Or, + ON_Xor => OE_Xor, + ON_And_Then => OE_And_Then, + ON_Or_Else => OE_Or_Else, + + -- Monadic operations. + ON_Not => OE_Not, + ON_Neg_Ov => OE_Neg_Ov, + ON_Abs_Ov => OE_Abs_Ov, + + -- Comparaisons + ON_Eq => OE_Eq, + ON_Neq => OE_Neq, + ON_Le => OE_Le, + ON_Lt => OE_Lt, + ON_Ge => OE_Ge, + ON_Gt => OE_Gt + ); + + type Decl_Scope_Type is record + -- Declarations are chained. + Parent : O_Snode; + Last_Decl : O_Dnode; + Last_Stmt : O_Snode; + + -- If this scope corresponds to a function, PREV_FUNCTION contains + -- the previous function. + Prev_Function : O_Dnode; + + -- Declaration scopes are chained. + Prev : Decl_Scope_Acc; + end record; + + type Stmt_Kind is + (Stmt_Function, Stmt_Declare, Stmt_If, Stmt_Loop, Stmt_Case); + type Stmt_Scope_Type (Kind : Stmt_Kind); + type Stmt_Scope_Acc is access Stmt_Scope_Type; + type Stmt_Scope_Type (Kind : Stmt_Kind) is record + -- Statement which created this scope. + Parent : O_Snode; + -- Previous (parent) scope. + Prev : Stmt_Scope_Acc; + case Kind is + when Stmt_Function => + Prev_Function : Stmt_Scope_Acc; + -- Declaration for the function. + Decl : O_Dnode; + when Stmt_Declare => + null; + when Stmt_If => + Last_Elsif : O_Snode; + when Stmt_Loop => + null; + when Stmt_Case => + Last_Branch : O_Snode; + Last_Choice : O_Choice; + Case_Type : O_Tnode; + end case; + end record; + subtype Stmt_Function_Scope_Type is Stmt_Scope_Type (Stmt_Function); + subtype Stmt_Declare_Scope_Type is Stmt_Scope_Type (Stmt_Declare); + subtype Stmt_If_Scope_Type is Stmt_Scope_Type (Stmt_If); + subtype Stmt_Loop_Scope_Type is Stmt_Scope_Type (Stmt_Loop); + subtype Stmt_Case_Scope_Type is Stmt_Scope_Type (Stmt_Case); + + Current_Stmt_Scope : Stmt_Scope_Acc := null; + Current_Function : Stmt_Scope_Acc := null; + Current_Decl_Scope : Decl_Scope_Acc := null; + Current_Loop_Level : Natural := 0; + + procedure Push_Decl_Scope (Parent : O_Snode) + is + Res : Decl_Scope_Acc; + begin + Res := new Decl_Scope_Type'(Parent => Parent, + Last_Decl => null, + Last_Stmt => null, + Prev_Function => null, + Prev => Current_Decl_Scope); + Parent.Alive := True; + Current_Decl_Scope := Res; + end Push_Decl_Scope; + + procedure Pop_Decl_Scope + is + procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation + (Object => Decl_Scope_Type, Name => Decl_Scope_Acc); + Old : Decl_Scope_Acc; + begin + Old := Current_Decl_Scope; + Old.Parent.Alive := False; + Current_Decl_Scope := Old.Prev; + Unchecked_Deallocation (Old); + end Pop_Decl_Scope; + + procedure Add_Decl (El : O_Dnode; Check_Dup : Boolean := True) is + begin + if Current_Decl_Scope = null then + -- Not yet initialized, or after compilation. + raise Program_Error; + end if; + + -- Note: this requires an hashed ident table. + -- Use ortho_ident_hash. + if False and then Check_Dup + and then not Is_Nul (El.Name) + then + -- Check the name is not already defined. + declare + E : O_Dnode; + begin + E := Current_Decl_Scope.Parent.Decls; + while E /= O_Dnode_Null loop + if Is_Equal (E.Name, El.Name) then + raise Syntax_Error; + end if; + E := E.Next; + end loop; + end; + end if; + + if Current_Decl_Scope.Last_Decl = null then + if Current_Decl_Scope.Parent.Kind = ON_Declare_Stmt then + Current_Decl_Scope.Parent.Decls := El; + else + raise Type_Error; + end if; + else + Current_Decl_Scope.Last_Decl.Next := El; + end if; + El.Next := null; + Current_Decl_Scope.Last_Decl := El; + end Add_Decl; + + procedure Add_Stmt (Stmt : O_Snode) + is + begin + if Current_Decl_Scope = null or Current_Function = null then + -- You are adding a statement at the global level, ie not inside + -- a function. + raise Syntax_Error; + end if; + + Stmt.Next := null; + if Current_Decl_Scope.Last_Stmt = null then + if Current_Decl_Scope.Parent.Kind = ON_Declare_Stmt then + Current_Decl_Scope.Parent.Stmts := Stmt; + else + raise Syntax_Error; + end if; + else + Current_Decl_Scope.Last_Stmt.Next := Stmt; + end if; + Current_Decl_Scope.Last_Stmt := Stmt; + end Add_Stmt; + + procedure Push_Stmt_Scope (Scope : Stmt_Scope_Acc) + is + begin + if Scope.Prev /= Current_Stmt_Scope then + -- SCOPE was badly initialized. + raise Program_Error; + end if; + Current_Stmt_Scope := Scope; + end Push_Stmt_Scope; + + procedure Pop_Stmt_Scope (Kind : Stmt_Kind) + is + procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation + (Object => Stmt_Scope_Type, Name => Stmt_Scope_Acc); + Old : Stmt_Scope_Acc; + begin + Old := Current_Stmt_Scope; + if Old.Kind /= Kind then + raise Syntax_Error; + end if; + --Old.Parent.Last_Stmt := Current_Decl_Scope.Last_Stmt; + Current_Stmt_Scope := Old.Prev; + Unchecked_Deallocation (Old); + end Pop_Stmt_Scope; + + -- Check declaration DECL is reachable, ie its scope is in the current + -- stack of scopes. + procedure Check_Scope (Decl : O_Dnode) + is + Res : Boolean; + begin + case Decl.Kind is + when ON_Interface_Decl => + Res := Decl.Func_Scope.Alive; + when others => + Res := Decl.Scope.Alive; + end case; + if not Res then + raise Syntax_Error; + end if; + end Check_Scope; + + -- Raise SYNTAX_ERROR if OBJ is not at a constant address. +-- procedure Check_Const_Address (Obj : O_Lnode) is +-- begin +-- case Obj.Kind is +-- when OL_Const_Ref +-- | OL_Var_Ref => +-- case Obj.Decl.Storage is +-- when O_Storage_External +-- | O_Storage_Public +-- | O_Storage_Private => +-- null; +-- when O_Storage_Local => +-- raise Syntax_Error; +-- end case; +-- when others => +-- -- FIXME: constant indexed element, selected element maybe +-- -- of const address. +-- raise Syntax_Error; +-- end case; +-- end Check_Const_Address; + + procedure Check_Type (T1, T2 : O_Tnode) is + begin + if T1 = T2 then + return; + end if; + if T1.Kind = ON_Array_Sub_Type and then T2.Kind = ON_Array_Sub_Type + and then T1.Base_Type = T2.Base_Type + and then T1.Length.all = T2.Length.all + then + return; + end if; + raise Type_Error; + end Check_Type; + + procedure Check_Ref (N : O_Enode) is + begin + if N.Ref then + -- Already referenced. + raise Syntax_Error; + end if; + N.Ref := True; + end Check_Ref; + + procedure Check_Ref (N : O_Lnode) is + begin + if N.Ref then + raise Syntax_Error; + end if; + N.Ref := True; + end Check_Ref; + + procedure Check_Complete_Type (T : O_Tnode) is + begin + if not T.Complete then + -- Uncomplete type cannot be used here (since its size is required, + -- for example). + raise Syntax_Error; + end if; + end Check_Complete_Type; + + function New_Dyadic_Op (Kind : ON_Dyadic_Op_Kind; Left, Right : O_Enode) + return O_Enode + is + K : constant OE_Kind := ON_Op_To_OE (Kind); + Res : O_Enode; + begin + Check_Type (Left.Rtype, Right.Rtype); + Check_Ref (Left); + Check_Ref (Right); + Res := new O_Enode_Type (K); + Res.Rtype := Left.Rtype; + Res.Ref := False; + Res.Left := Left; + Res.Right := Right; + return Res; + end New_Dyadic_Op; + + function New_Monadic_Op (Kind : ON_Monadic_Op_Kind; Operand : O_Enode) + return O_Enode + is + Res : O_Enode; + begin + Check_Ref (Operand); + Res := new O_Enode_Type (ON_Op_To_OE (Kind)); + Res.Ref := False; + Res.Operand := Operand; + Res.Rtype := Operand.Rtype; + return Res; + end New_Monadic_Op; + + function New_Compare_Op + (Kind : ON_Compare_Op_Kind; Left, Right : O_Enode; Ntype : O_Tnode) + return O_Enode + is + Res : O_Enode; + begin + if Ntype.Kind /= ON_Boolean_Type then + raise Type_Error; + end if; + if Left.Rtype /= Right.Rtype then + raise Type_Error; + end if; + Check_Ref (Left); + Check_Ref (Right); + Res := new O_Enode_Type (ON_Op_To_OE (Kind)); + Res.Ref := False; + Res.Left := Left; + Res.Right := Right; + Res.Rtype := Ntype; + return Res; + end New_Compare_Op; + + + function New_Signed_Literal (Ltype : O_Tnode; Value : Integer_64) + return O_Cnode + is + subtype O_Cnode_Signed_Lit is O_Cnode_Type (OC_Signed_Lit); + begin + if Ltype.Kind = ON_Signed_Type then + return new O_Cnode_Signed_Lit'(Kind => OC_Signed_Lit, + Ctype => Ltype, + Ref => False, + S_Val => Value); + else + raise Type_Error; + end if; + end New_Signed_Literal; + + function New_Unsigned_Literal (Ltype : O_Tnode; Value : Unsigned_64) + return O_Cnode + is + subtype O_Cnode_Unsigned_Lit is O_Cnode_Type (OC_Unsigned_Lit); + begin + if Ltype.Kind = ON_Unsigned_Type then + return new O_Cnode_Unsigned_Lit'(Kind => OC_Unsigned_Lit, + Ctype => Ltype, + Ref => False, + U_Val => Value); + else + raise Type_Error; + end if; + end New_Unsigned_Literal; + + function New_Float_Literal (Ltype : O_Tnode; Value : IEEE_Float_64) + return O_Cnode + is + subtype O_Cnode_Float_Lit is O_Cnode_Type (OC_Float_Lit); + begin + if Ltype.Kind = ON_Float_Type then + return new O_Cnode_Float_Lit'(Kind => OC_Float_Lit, + Ctype => Ltype, + Ref => False, + F_Val => Value); + else + raise Type_Error; + end if; + end New_Float_Literal; + + function New_Null_Access (Ltype : O_Tnode) return O_Cnode + is + subtype O_Cnode_Null_Lit_Type is O_Cnode_Type (OC_Null_Lit); + begin + if Ltype.Kind /= ON_Access_Type then + raise Type_Error; + end if; + return new O_Cnode_Null_Lit_Type'(Kind => OC_Null_Lit, + Ctype => Ltype, + Ref => False); + end New_Null_Access; + + function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode + is + subtype O_Cnode_Sizeof_Type is O_Cnode_Type (OC_Sizeof_Lit); + begin + if Rtype.Kind /= ON_Unsigned_Type then + raise Type_Error; + end if; + Check_Complete_Type (Atype); + if Atype.Kind = ON_Array_Type then + raise Type_Error; + end if; + return new O_Cnode_Sizeof_Type'(Kind => OC_Sizeof_Lit, + Ctype => Rtype, + Ref => False, + S_Type => Atype); + end New_Sizeof; + + function New_Offsetof (Field : O_Fnode; Rtype : O_Tnode) return O_Cnode + is + subtype O_Cnode_Offsetof_Type is O_Cnode_Type (OC_Offsetof_Lit); + begin + if Rtype.Kind /= ON_Unsigned_Type then + raise Type_Error; + end if; + return new O_Cnode_Offsetof_Type'(Kind => OC_Offsetof_Lit, + Ctype => Rtype, + Ref => False, + Off_Field => Field); + end New_Offsetof; + + function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode + is + subtype O_Enode_Alloca_Type is O_Enode_Type (OE_Alloca); + Res : O_Enode; + begin + if Rtype.Kind /= ON_Access_Type then + raise Type_Error; + end if; + if Size.Rtype.Kind /= ON_Unsigned_Type then + raise Type_Error; + end if; + Res := new O_Enode_Alloca_Type'(Kind => OE_Alloca, + Rtype => Rtype, + Ref => False, + A_Size => Size); + return Res; + end New_Alloca; + + procedure Check_Constrained_Type (Atype : O_Tnode) is + begin + case Atype.Kind is + when ON_Array_Type => + raise Type_Error; + when ON_Unsigned_Type + | ON_Signed_Type + | ON_Boolean_Type + | ON_Record_Type + | ON_Union_Type + | ON_Access_Type + | ON_Float_Type + | ON_Array_Sub_Type + | ON_Enum_Type => + null; + end case; + end Check_Constrained_Type; + + procedure New_Completed_Type_Decl (Atype : O_Tnode) + is + N : O_Dnode; + begin + if Atype.Decl = null then + -- The uncompleted type must have been declared. + raise Type_Error; + end if; + N := new O_Dnode_Type (ON_Completed_Type_Decl); + N.Name := Atype.Decl.Name; + N.Dtype := Atype; + Add_Decl (N, False); + end New_Completed_Type_Decl; + + procedure New_Uncomplete_Record_Type (Res : out O_Tnode) + is + subtype O_Tnode_Record_Type is O_Tnode_Type (ON_Record_Type); + begin + Res := new O_Tnode_Record_Type'(Kind => ON_Record_Type, + Decl => O_Dnode_Null, + Align => 0, + Size => 0, + Uncomplete => True, + Complete => False, + Elements => O_Fnode_Null); + end New_Uncomplete_Record_Type; + + procedure Start_Uncomplete_Record_Type (Res : O_Tnode; + Elements : out O_Element_List) is + begin + if not Res.Uncomplete then + -- RES record type is not an uncomplete record type. + raise Syntax_Error; + end if; + if Res.Elements /= O_Fnode_Null then + -- RES record type already has elements... + raise Syntax_Error; + end if; + Elements.Res := Res; + Elements.Last := null; + end Start_Uncomplete_Record_Type; + + procedure Start_Record_Type (Elements : out O_Element_List) + is + subtype O_Tnode_Record_Type is O_Tnode_Type (ON_Record_Type); + begin + Elements.Res := new O_Tnode_Record_Type'(Kind => ON_Record_Type, + Decl => O_Dnode_Null, + Align => 0, + Size => 0, + Uncomplete => False, + Complete => False, + Elements => O_Fnode_Null); + Elements.Last := null; + end Start_Record_Type; + + function Align_Size (Size : Unsigned_32; Align : Natural) + return Unsigned_32 + is + M : Unsigned_32; + begin + M := (2 ** Align) - 1; + return (Size + M) and (not M); + end Align_Size; + + procedure New_Record_Field + (Elements : in out O_Element_List; + El : out O_Fnode; + Ident : O_Ident; Etype : O_Tnode) + is + begin + Check_Complete_Type (Etype); + Check_Constrained_Type (Etype); + -- The alignment of a structure is the max alignment of its field. + if Etype.Align > Elements.Res.Align then + Elements.Res.Align := Etype.Align; + end if; + -- Align the current size for the new field. + Elements.Res.Size := Align_Size (Elements.Res.Size, Etype.Align); + El := new O_Fnode_Type'(Parent => Elements.Res, + Next => null, + Ident => Ident, + Ftype => Etype, + Offset => Elements.Res.Size); + -- Add the size of the field. + Elements.Res.Size := Elements.Res.Size + Etype.Size; + if Elements.Last = null then + Elements.Res.Elements := El; + else + Elements.Last.Next := El; + end if; + Elements.Last := El; + end New_Record_Field; + + procedure Finish_Record_Type + (Elements : in out O_Element_List; Res : out O_Tnode) is + begin + -- Align the structure. + Res := Elements.Res; + Res.Size := Align_Size (Res.Size, Res.Align); + if Res.Uncomplete then + New_Completed_Type_Decl (Res); + end if; + Res.Complete := True; + end Finish_Record_Type; + + procedure Start_Union_Type (Elements : out O_Element_List) + is + subtype O_Tnode_Union_Type is O_Tnode_Type (ON_Union_Type); + begin + Elements.Res := new O_Tnode_Union_Type'(Kind => ON_Union_Type, + Decl => O_Dnode_Null, + Align => 0, + Size => 0, + Uncomplete => False, + Complete => False, + Elements => O_Fnode_Null); + Elements.Last := null; + end Start_Union_Type; + + procedure New_Union_Field + (Elements : in out O_Element_List; + El : out O_Fnode; + Ident : O_Ident; Etype : O_Tnode) + is + begin + New_Record_Field (Elements, El, Ident, Etype); + end New_Union_Field; + + procedure Finish_Union_Type + (Elements : in out O_Element_List; Res : out O_Tnode) is + begin + -- Align the structure. + Res := Elements.Res; + Res.Size := Align_Size (Res.Size, Res.Align); + Res.Complete := True; + end Finish_Union_Type; + + function New_Access_Type (Dtype : O_Tnode) return O_Tnode + is + subtype O_Tnode_Access is O_Tnode_Type (ON_Access_Type); + Res : O_Tnode; + begin + if Dtype /= O_Tnode_Null + and then Dtype.Kind = ON_Array_Sub_Type + then + -- Access to sub array are not allowed, use access to array. + raise Type_Error; + end if; + Res := new O_Tnode_Access'(Kind => ON_Access_Type, + Decl => O_Dnode_Null, + Align => Metric_Access_Align, + Size => Metric_Access_Size, + Uncomplete => Dtype = O_Tnode_Null, + Complete => True, + D_Type => Dtype); + return Res; + end New_Access_Type; + + procedure Finish_Access_Type (Atype : O_Tnode; Dtype : O_Tnode) + is + begin + if Dtype.Kind = ON_Array_Sub_Type then + -- Access to sub array are not allowed, use access to array. + raise Type_Error; + end if; + if Atype.D_Type /= O_Tnode_Null + or Atype.Uncomplete = False + then + -- Type already completed. + raise Syntax_Error; + end if; + Atype.D_Type := Dtype; + New_Completed_Type_Decl (Atype); + end Finish_Access_Type; + + function New_Array_Type (El_Type : O_Tnode; Index_Type : O_Tnode) + return O_Tnode + is + subtype O_Tnode_Array is O_Tnode_Type (ON_Array_Type); + begin + Check_Constrained_Type (El_Type); + Check_Complete_Type (El_Type); + return new O_Tnode_Array'(Kind => ON_Array_Type, + Decl => O_Dnode_Null, + Align => El_Type.Align, + Size => 0, + Uncomplete => False, + Complete => True, + El_Type => El_Type, + Index_Type => Index_Type); + end New_Array_Type; + + function New_Constrained_Array_Type (Atype : O_Tnode; Length : O_Cnode) + return O_Tnode + is + subtype O_Tnode_Sub_Array is O_Tnode_Type (ON_Array_Sub_Type); + Size : Unsigned_32; + begin + if Atype.Kind /= ON_Array_Type then + raise Type_Error; + end if; + Size := Unsigned_32 (Length.U_Val) * Atype.El_Type.Size; + return new O_Tnode_Sub_Array'(Kind => ON_Array_Sub_Type, + Decl => O_Dnode_Null, + Align => Atype.Align, + Size => Size, + Uncomplete => False, + Complete => True, + Base_Type => Atype, + Length => Length); + end New_Constrained_Array_Type; + + function Get_Scalar_Pow (Bit_Size : Natural) return Natural is + begin + if Bit_Size <= 8 then + return 0; + elsif Bit_Size <= 32 then + return 2; + elsif Bit_Size <= 64 then + return 3; + else + raise Type_Error; + end if; + end Get_Scalar_Pow; + + function New_Unsigned_Type (Size : Natural) return O_Tnode + is + subtype O_Tnode_Unsigned is O_Tnode_Type (ON_Unsigned_Type); + Align : Natural; + begin + Align := Get_Scalar_Pow (Size); + return new O_Tnode_Unsigned'(Kind => ON_Unsigned_Type, + Decl => O_Dnode_Null, + Align => Align, + Size => 2 ** Align, + Uncomplete => False, + Complete => True); + end New_Unsigned_Type; + + function New_Signed_Type (Size : Natural) return O_Tnode + is + subtype O_Tnode_Signed is O_Tnode_Type (ON_Signed_Type); + Align : Natural; + begin + Align := Get_Scalar_Pow (Size); + return new O_Tnode_Signed'(Kind => ON_Signed_Type, + Decl => O_Dnode_Null, + Align => Align, + Size => 2 ** Align, + Uncomplete => False, + Complete => True); + end New_Signed_Type; + + function New_Float_Type return O_Tnode + is + subtype O_Tnode_Float is O_Tnode_Type (ON_Float_Type); + begin + return new O_Tnode_Float'(Kind => ON_Float_Type, + Decl => O_Dnode_Null, + Align => 0, + Size => 1, + Uncomplete => False, + Complete => True); + end New_Float_Type; + + procedure New_Boolean_Type (Res : out O_Tnode; + False_Id : O_Ident; + False_E : out O_Cnode; + True_Id : O_Ident; + True_E : out O_Cnode) + is + subtype O_Tnode_Boolean is O_Tnode_Type (ON_Boolean_Type); + subtype O_Cnode_Boolean_Lit is O_Cnode_Type (OC_Boolean_Lit); + begin + Res := new O_Tnode_Boolean'(Kind => ON_Boolean_Type, + Decl => O_Dnode_Null, + Align => 0, + Size => 1, + Uncomplete => False, + Complete => True, + True_N => O_Cnode_Null, + False_N => O_Cnode_Null); + True_E := new O_Cnode_Boolean_Lit'(Kind => OC_Boolean_Lit, + Ctype => Res, + Ref => False, + B_Val => True, + B_Id => True_Id); + False_E := new O_Cnode_Boolean_Lit'(Kind => OC_Boolean_Lit, + Ctype => Res, + Ref => False, + B_Val => False, + B_Id => False_Id); + Res.True_N := True_E; + Res.False_N := False_E; + end New_Boolean_Type; + + procedure Start_Enum_Type (List : out O_Enum_List; Size : Natural) + is + subtype O_Tnode_Enum is O_Tnode_Type (ON_Enum_Type); + Res : O_Tnode; + Align : Natural; + begin + Align := Get_Scalar_Pow (Size); + Res := new O_Tnode_Enum'(Kind => ON_Enum_Type, + Decl => O_Dnode_Null, + Align => Align, + Size => 2 ** Align, + Uncomplete => False, + Complete => False, + Nbr => 0, + Literals => O_Cnode_Null); + List.Res := Res; + List.Last := O_Cnode_Null; + end Start_Enum_Type; + + procedure New_Enum_Literal (List : in out O_Enum_List; + Ident : O_Ident; + Res : out O_Cnode) + is + subtype O_Cnode_Enum_Lit is O_Cnode_Type (OC_Enum_Lit); + begin + Res := new O_Cnode_Enum_Lit'(Kind => OC_Enum_Lit, + Ctype => List.Res, + Ref => False, + E_Val => List.Res.Nbr, + E_Name => Ident, + E_Next => O_Cnode_Null); + -- Link it. + if List.Last = O_Cnode_Null then + List.Res.Literals := Res; + else + List.Last.E_Next := Res; + end if; + List.Last := Res; + + List.Res.Nbr := List.Res.Nbr + 1; + end New_Enum_Literal; + + procedure Finish_Enum_Type (List : in out O_Enum_List; Res : out O_Tnode) is + begin + Res := List.Res; + Res.Complete := True; + end Finish_Enum_Type; + + function Get_Base_Type (Atype : O_Tnode) return O_Tnode + is + begin + case Atype.Kind is + when ON_Array_Sub_Type => + return Atype.Base_Type; + when others => + return Atype; + end case; + end Get_Base_Type; + + + procedure Start_Record_Aggr (List : out O_Record_Aggr_List; Atype : O_Tnode) + is + subtype O_Cnode_Aggregate is O_Cnode_Type (OC_Aggregate); + Res : O_Cnode; + begin + if Atype.Kind /= ON_Record_Type then + raise Type_Error; + end if; + Check_Complete_Type (Atype); + Res := new O_Cnode_Aggregate'(Kind => OC_Aggregate, + Ctype => Atype, + Ref => False, + Aggr_Els => null); + List.Res := Res; + List.Last := null; + List.Field := Atype.Elements; + end Start_Record_Aggr; + + procedure New_Record_Aggr_El (List : in out O_Record_Aggr_List; + Value : O_Cnode) + is + subtype O_Cnode_Aggrel_Type is O_Cnode_Type (OC_Aggr_Element); + El : O_Cnode; + begin + if List.Field = O_Fnode_Null then + -- No more element in the aggregate. + raise Syntax_Error; + end if; + Check_Type (Value.Ctype, List.Field.Ftype); + El := new O_Cnode_Aggrel_Type'(Kind => OC_Aggr_Element, + Ctype => Value.Ctype, + Ref => False, + Aggr_Value => Value, + Aggr_Next => null); + if List.Last = null then + List.Res.Aggr_Els := El; + else + List.Last.Aggr_Next := El; + end if; + List.Last := El; + List.Field := List.Field.Next; + end New_Record_Aggr_El; + + procedure Finish_Record_Aggr + (List : in out O_Record_Aggr_List; Res : out O_Cnode) + is + begin + if List.Field /= null then + -- Not enough elements in aggregate. + raise Type_Error; + end if; + Res := List.Res; + end Finish_Record_Aggr; + + procedure Start_Array_Aggr (List : out O_Array_Aggr_List; Atype : O_Tnode) + is + subtype O_Cnode_Aggregate is O_Cnode_Type (OC_Aggregate); + Res : O_Cnode; + begin + if Atype.Kind /= ON_Array_Sub_Type then + raise Type_Error; + end if; + Check_Complete_Type (Atype); + Res := new O_Cnode_Aggregate'(Kind => OC_Aggregate, + Ctype => Atype, + Ref => False, + Aggr_Els => null); + List.Res := Res; + List.Last := null; + List.El_Type := Atype.Base_Type.El_Type; + end Start_Array_Aggr; + + procedure New_Array_Aggr_El (List : in out O_Array_Aggr_List; + Value : O_Cnode) + is + subtype O_Cnode_Aggrel_Type is O_Cnode_Type (OC_Aggr_Element); + El : O_Cnode; + begin + Check_Type (Value.Ctype, List.El_Type); + El := new O_Cnode_Aggrel_Type'(Kind => OC_Aggr_Element, + Ctype => Value.Ctype, + Ref => False, + Aggr_Value => Value, + Aggr_Next => null); + if List.Last = null then + List.Res.Aggr_Els := El; + else + List.Last.Aggr_Next := El; + end if; + List.Last := El; + end New_Array_Aggr_El; + + procedure Finish_Array_Aggr + (List : in out O_Array_Aggr_List; Res : out O_Cnode) is + begin + Res := List.Res; + end Finish_Array_Aggr; + + function New_Union_Aggr (Atype : O_Tnode; Field : O_Fnode; Value : O_Cnode) + return O_Cnode + is + subtype O_Cnode_Union_Aggr is O_Cnode_Type (OC_Union_Aggr); + Res : O_Cnode; + begin + if Atype.Kind /= ON_Union_Type then + raise Type_Error; + end if; + Check_Type (Value.Ctype, Field.Ftype); + + Res := new O_Cnode_Union_Aggr'(Kind => OC_Union_Aggr, + Ctype => Atype, + Ref => False, + Uaggr_Field => Field, + Uaggr_Value => Value); + return Res; + end New_Union_Aggr; + + function New_Obj (Obj : O_Dnode) return O_Lnode + is + subtype O_Lnode_Obj is O_Lnode_Type (OL_Obj); + begin + case Obj.Kind is + when ON_Const_Decl + | ON_Var_Decl + | ON_Interface_Decl => + null; + when others => + raise Program_Error; + end case; + Check_Scope (Obj); + return new O_Lnode_Obj'(Kind => OL_Obj, + Rtype => Obj.Dtype, + Ref => False, + Obj => Obj); + end New_Obj; + + function New_Indexed_Element (Arr : O_Lnode; Index : O_Enode) + return O_Lnode + is + subtype O_Lnode_Indexed is O_Lnode_Type (OL_Indexed_Element); + Res : O_Lnode; + Rtype : O_Tnode; + begin + case Arr.Rtype.Kind is + when ON_Array_Type => + Rtype := Arr.Rtype.El_Type; + when ON_Array_Sub_Type => + Rtype := Arr.Rtype.Base_Type.El_Type; + when others => + raise Type_Error; + end case; + Check_Ref (Arr); + Res := new O_Lnode_Indexed'(Kind => OL_Indexed_Element, + Rtype => Get_Base_Type (Arr.Rtype).El_Type, + Ref => False, + Array_Base => Arr, + Index => Index); + return Res; + end New_Indexed_Element; + + function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode) + return O_Lnode + is + subtype O_Lnode_Slice is O_Lnode_Type (OL_Slice); + Res : O_Lnode; + begin + if Res_Type.Kind /= ON_Array_Type + and then Res_Type.Kind /= ON_Array_Sub_Type + then + raise Type_Error; + end if; + Check_Ref (Arr); + Check_Ref (Index); + -- FIXME: check type. + Res := new O_Lnode_Slice'(Kind => OL_Slice, + Rtype => Res_Type, + Ref => False, + Slice_Base => Arr, + Slice_Index => Index); + return Res; + end New_Slice; + + function New_Selected_Element (Rec : O_Lnode; El : O_Fnode) + return O_Lnode + is + subtype O_Lnode_Selected_Element is O_Lnode_Type (OL_Selected_Element); + begin + if Rec.Rtype.Kind /= ON_Record_Type then + raise Type_Error; + end if; + if Rec.Rtype /= El.Parent then + raise Type_Error; + end if; + Check_Ref (Rec); + return new O_Lnode_Selected_Element'(Kind => OL_Selected_Element, + Rtype => El.Ftype, + Ref => False, + Rec_Base => Rec, + Rec_El => El); + end New_Selected_Element; + + function New_Access_Element (Acc : O_Enode) return O_Lnode + is + subtype O_Lnode_Access_Element is O_Lnode_Type (OL_Access_Element); + begin + if Acc.Rtype.Kind /= ON_Access_Type then + raise Type_Error; + end if; + Check_Ref (Acc); + return new O_Lnode_Access_Element'(Kind => OL_Access_Element, + Rtype => Acc.Rtype.D_Type, + Ref => False, + Acc_Base => Acc); + end New_Access_Element; + + function Check_Conv (Source : ON_Type_Kind; Target : ON_Type_Kind) + return Boolean + is + type Conv_Array is array (ON_Type_Kind, ON_Type_Kind) of Boolean; + T : constant Boolean := True; + F : constant Boolean := False; + Conv_Allowed : constant Conv_Array := + (ON_Boolean_Type => (T, F, T, T, F, F, F, F, F, F), + ON_Enum_Type => (F, F, T, T, F, F, F, F, F, F), + ON_Unsigned_Type => (T, T, T, T, F, F, F, F, F, F), + ON_Signed_Type => (T, T, T, T, T, F, F, F, F, F), + ON_Float_Type => (F, F, F, T, T, F, F, F, F, F), + ON_Array_Type => (F, F, F, F, F, F, T, F, F, F), + ON_Array_Sub_Type =>(F, F, F, F, F, T, T, F, F, F), + ON_Record_Type => (F, F, F, F, F, F, F, F, F, F), + ON_Union_Type => (F, F, F, F, F, F, F, F, F, F), + ON_Access_Type => (F, F, F, F, F, F, F, F, F, T)); + begin + if Source = Target then + return True; + else + return Conv_Allowed (Source, Target); + end if; + end Check_Conv; + + function New_Convert_Ov (Val : O_Enode; Rtype : O_Tnode) return O_Enode + is + subtype O_Enode_Convert is O_Enode_Type (OE_Convert_Ov); + Res : O_Enode; + begin + Check_Ref (Val); + if not Check_Conv (Val.Rtype.Kind, Rtype.Kind) then + raise Type_Error; + end if; + Res := new O_Enode_Convert'(Kind => OE_Convert_Ov, + Rtype => Rtype, + Ref => False, + Conv => Val); + return Res; + end New_Convert_Ov; + + function New_Unchecked_Address (Lvalue : O_Lnode; Atype : O_Tnode) + return O_Enode + is + subtype O_Enode_Address is O_Enode_Type (OE_Unchecked_Address); + begin + Check_Ref (Lvalue); + if Atype.Kind /= ON_Access_Type then + -- An address is of type access. + raise Type_Error; + end if; + return new O_Enode_Address'(Kind => OE_Unchecked_Address, + Rtype => Atype, + Ref => False, + Lvalue => Lvalue); + end New_Unchecked_Address; + + function New_Address (Lvalue : O_Lnode; Atype : O_Tnode) return O_Enode + is + subtype O_Enode_Address is O_Enode_Type (OE_Address); + begin + Check_Ref (Lvalue); + if Atype.Kind /= ON_Access_Type then + -- An address is of type access. + raise Type_Error; + end if; + if Get_Base_Type (Lvalue.Rtype) /= Get_Base_Type (Atype.D_Type) then + raise Type_Error; + end if; + return new O_Enode_Address'(Kind => OE_Address, + Rtype => Atype, + Ref => False, + Lvalue => Lvalue); + end New_Address; + + function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode) + return O_Cnode + is + subtype O_Cnode_Address is O_Cnode_Type (OC_Unchecked_Address); + begin + Check_Scope (Decl); + if Atype.Kind /= ON_Access_Type then + -- An address is of type access. + raise Type_Error; + end if; + return new O_Cnode_Address'(Kind => OC_Unchecked_Address, + Ctype => Atype, + Ref => False, + Decl => Decl); + end New_Global_Unchecked_Address; + + function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode) return O_Cnode + is + subtype O_Cnode_Address is O_Cnode_Type (OC_Address); + begin + Check_Scope (Decl); + if Atype.Kind /= ON_Access_Type then + -- An address is of type access. + raise Type_Error; + end if; + if Get_Base_Type (Decl.Dtype) /= Get_Base_Type (Atype.D_Type) then + raise Type_Error; + end if; + return new O_Cnode_Address'(Kind => OC_Address, + Ctype => Atype, + Ref => False, + Decl => Decl); + end New_Global_Address; + + function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode) + return O_Cnode + is + subtype O_Cnode_Subprg_Address is O_Cnode_Type (OC_Subprogram_Address); + begin + if Atype.Kind /= ON_Access_Type then + -- An address is of type access. + raise Type_Error; + end if; + return new O_Cnode_Subprg_Address'(Kind => OC_Subprogram_Address, + Ctype => Atype, + Ref => False, + Decl => Subprg); + end New_Subprogram_Address; + + -- Raise TYPE_ERROR is ATYPE is a composite type. + procedure Check_Not_Composite (Atype : O_Tnode) is + begin + case Atype.Kind is + when ON_Boolean_Type + | ON_Unsigned_Type + | ON_Signed_Type + | ON_Float_Type + | ON_Enum_Type + | ON_Access_Type=> + return; + when ON_Array_Type + | ON_Record_Type + | ON_Union_Type + | ON_Array_Sub_Type => + raise Type_Error; + end case; + end Check_Not_Composite; + + function New_Value (Lvalue : O_Lnode) return O_Enode is + subtype O_Enode_Value is O_Enode_Type (OE_Value); + begin + Check_Not_Composite (Lvalue.Rtype); + Check_Ref (Lvalue); + return new O_Enode_Value'(Kind => OE_Value, + Rtype => Lvalue.Rtype, + Ref => False, + Value => Lvalue); + end New_Value; + + function New_Obj_Value (Obj : O_Dnode) return O_Enode is + begin + return New_Value (New_Obj (Obj)); + end New_Obj_Value; + + function New_Lit (Lit : O_Cnode) return O_Enode is + subtype O_Enode_Lit is O_Enode_Type (OE_Lit); + begin + Check_Not_Composite (Lit.Ctype); + return new O_Enode_Lit'(Kind => OE_Lit, + Rtype => Lit.Ctype, + Ref => False, + Lit => Lit); + end New_Lit; + + --------------------- + -- Declarations. -- + --------------------- + + procedure New_Debug_Filename_Decl (Filename : String) + is + subtype O_Dnode_Filename_Decl is O_Dnode_Type (ON_Debug_Filename_Decl); + N : O_Dnode; + begin + N := new O_Dnode_Filename_Decl; + N.Filename := new String'(Filename); + Add_Decl (N, False); + end New_Debug_Filename_Decl; + + procedure New_Debug_Line_Decl (Line : Natural) + is + subtype O_Dnode_Line_Decl is O_Dnode (ON_Debug_Line_Decl); + N : O_Dnode_Line_Decl; + begin + N := new O_Dnode_Type (ON_Debug_Line_Decl); + N.Line := Line; + Add_Decl (N, False); + end New_Debug_Line_Decl; + + procedure New_Debug_Comment_Decl (Comment : String) + is + subtype O_Dnode_Comment_Decl is O_Dnode (ON_Debug_Comment_Decl); + N : O_Dnode_Comment_Decl; + begin + N := new O_Dnode_Type (ON_Debug_Comment_Decl); + N.Comment := new String'(Comment); + Add_Decl (N, False); + end New_Debug_Comment_Decl; + + procedure New_Type_Decl (Ident : O_Ident; Atype : O_Tnode) + is + N : O_Dnode; + begin + if Atype.Decl /= null then + -- Type was already declared. + raise Type_Error; + end if; + N := new O_Dnode_Type (ON_Type_Decl); + N.Name := Ident; + N.Dtype := Atype; + Atype.Decl := N; + Add_Decl (N); + end New_Type_Decl; + + procedure Check_Object_Storage (Storage : O_Storage) is + begin + if Current_Function /= null then + -- Inside a subprogram. + case Storage is + when O_Storage_Public => + -- Cannot create public variables inside a subprogram. + raise Syntax_Error; + when O_Storage_Private + | O_Storage_Local + | O_Storage_External => + null; + end case; + else + -- Global scope. + case Storage is + when O_Storage_Public + | O_Storage_Private + | O_Storage_External => + null; + when O_Storage_Local => + -- Cannot create a local variables outside a subprogram. + raise Syntax_Error; + end case; + end if; + end Check_Object_Storage; + + procedure New_Const_Decl + (Res : out O_Dnode; + Ident : O_Ident; + Storage : O_Storage; + Atype : O_Tnode) + is + subtype O_Dnode_Const is O_Dnode_Type (ON_Const_Decl); + begin + Check_Complete_Type (Atype); + if Storage = O_Storage_Local then + -- A constant cannot be local. + raise Syntax_Error; + end if; + Check_Object_Storage (Storage); + Res := new O_Dnode_Const'(Kind => ON_Const_Decl, + Name => Ident, + Next => null, + Dtype => Atype, + Storage => Storage, + Scope => Current_Decl_Scope.Parent, + Lineno => 0, + Const_Value => O_Dnode_Null); + Add_Decl (Res); + end New_Const_Decl; + + procedure Start_Const_Value (Const : in out O_Dnode) + is + subtype O_Dnode_Const_Value is O_Dnode_Type (ON_Const_Value); + N : O_Dnode; + begin + if Const.Const_Value /= O_Dnode_Null then + -- Constant already has a value. + raise Syntax_Error; + end if; + + if Const.Storage = O_Storage_External then + -- An external constant must not have a value. + raise Syntax_Error; + end if; + + -- FIXME: check scope is the same. + + N := new O_Dnode_Const_Value'(Kind => ON_Const_Value, + Name => Const.Name, + Next => null, + Dtype => Const.Dtype, + Storage => Const.Storage, + Scope => Current_Decl_Scope.Parent, + Lineno => 0, + Const_Decl => Const, + Value => O_Cnode_Null); + Const.Const_Value := N; + Add_Decl (N, False); + end Start_Const_Value; + + procedure Finish_Const_Value (Const : in out O_Dnode; Val : O_Cnode) + is + begin + if Const.Const_Value = O_Dnode_Null then + -- Start_Const_Value not called. + raise Syntax_Error; + end if; + if Const.Const_Value.Value /= O_Cnode_Null then + -- Finish_Const_Value already called. + raise Syntax_Error; + end if; + if Val = O_Cnode_Null then + -- No value or bad type. + raise Type_Error; + end if; + Check_Type (Val.Ctype, Const.Dtype); + Const.Const_Value.Value := Val; + end Finish_Const_Value; + + procedure New_Var_Decl + (Res : out O_Dnode; + Ident : O_Ident; + Storage : O_Storage; + Atype : O_Tnode) + is + subtype O_Dnode_Var is O_Dnode_Type (ON_Var_Decl); + begin + Check_Complete_Type (Atype); + Check_Object_Storage (Storage); + Res := new O_Dnode_Var'(Kind => ON_Var_Decl, + Name => Ident, + Next => null, + Dtype => Atype, + Storage => Storage, + Lineno => 0, + Scope => Current_Decl_Scope.Parent); + Add_Decl (Res); + end New_Var_Decl; + + procedure Start_Subprogram_Decl_1 + (Interfaces : out O_Inter_List; + Ident : O_Ident; + Storage : O_Storage; + Rtype : O_Tnode) + is + subtype O_Dnode_Function is O_Dnode_Type (ON_Function_Decl); + N : O_Dnode; + begin + N := new O_Dnode_Function'(Kind => ON_Function_Decl, + Next => null, + Name => Ident, + Dtype => Rtype, + Storage => Storage, + Scope => Current_Decl_Scope.Parent, + Lineno => 0, + Interfaces => null, + Func_Body => null, + Alive => False); + Add_Decl (N); + Interfaces.Func := N; + Interfaces.Last := null; + end Start_Subprogram_Decl_1; + + procedure Start_Function_Decl + (Interfaces : out O_Inter_List; + Ident : O_Ident; + Storage : O_Storage; + Rtype : O_Tnode) + is + begin + Check_Not_Composite (Rtype); + Check_Complete_Type (Rtype); + Start_Subprogram_Decl_1 (Interfaces, Ident, Storage, Rtype); + end Start_Function_Decl; + + procedure Start_Procedure_Decl + (Interfaces : out O_Inter_List; + Ident : O_Ident; + Storage : O_Storage) is + begin + Start_Subprogram_Decl_1 (Interfaces, Ident, Storage, null); + end Start_Procedure_Decl; + + procedure New_Interface_Decl + (Interfaces : in out O_Inter_List; + Res : out O_Dnode; + Ident : O_Ident; + Atype : O_Tnode) + is + subtype O_Dnode_Interface is O_Dnode_Type (ON_Interface_Decl); + begin + Check_Not_Composite (Atype); + Check_Complete_Type (Atype); + Res := new O_Dnode_Interface'(Kind => ON_Interface_Decl, + Next => null, + Name => Ident, + Dtype => Atype, + Storage => O_Storage_Private, + Scope => Current_Decl_Scope.Parent, + Lineno => 0, + Func_Scope => Interfaces.Func); + if Interfaces.Last = null then + Interfaces.Func.Interfaces := Res; + else + Interfaces.Last.Next := Res; + end if; + Interfaces.Last := Res; + end New_Interface_Decl; + + procedure Finish_Subprogram_Decl + (Interfaces : in out O_Inter_List; Res : out O_Dnode) + is + begin + Res := Interfaces.Func; + end Finish_Subprogram_Decl; + + procedure Start_Subprogram_Body (Func : O_Dnode) + is + B : O_Dnode; + S : O_Snode; + begin + if Func.Func_Body /= null then + -- Function was already declared. + raise Syntax_Error; + end if; + S := new O_Snode_Type (ON_Declare_Stmt); + S.all := O_Snode_Type'(Kind => ON_Declare_Stmt, + Next => null, + Decls => null, + Stmts => null, + Lineno => 0, + Alive => True); + B := new O_Dnode_Type (ON_Function_Body); + B.all := O_Dnode_Type'(ON_Function_Body, + Name => Func.Name, + Dtype => Func.Dtype, + Storage => Func.Storage, + Scope => Current_Decl_Scope.Parent, + Lineno => 0, + Func_Decl => Func, + Func_Stmt => S, + Next => null); + Add_Decl (B, False); + Func.Func_Body := B; + Push_Decl_Scope (S); + Push_Stmt_Scope + (new Stmt_Function_Scope_Type'(Kind => Stmt_Function, + Parent => S, + Prev => Current_Stmt_Scope, + Prev_Function => Current_Function, + Decl => Func)); + Current_Function := Current_Stmt_Scope; + Func.Alive := True; + end Start_Subprogram_Body; + + procedure Finish_Subprogram_Body is + begin + Pop_Decl_Scope; + if Current_Function.Kind /= Stmt_Function then + -- Internal error. + raise Syntax_Error; + end if; + Current_Function.Decl.Alive := False; + Current_Function := Current_Function.Prev_Function; + Pop_Stmt_Scope (Stmt_Function); + end Finish_Subprogram_Body; + + ------------------- + -- Statements. -- + ------------------- + + procedure New_Debug_Line_Stmt (Line : Natural) + is + subtype O_Snode_Line_Stmt is O_Snode_Type (ON_Debug_Line_Stmt); + begin + Add_Stmt (new O_Snode_Line_Stmt'(Kind => ON_Debug_Line_Stmt, + Next => null, + Lineno => 0, + Line => Line)); + end New_Debug_Line_Stmt; + + procedure New_Debug_Comment_Stmt (Comment : String) + is + subtype O_Snode_Comment_Stmt is O_Snode_Type (ON_Debug_Comment_Stmt); + begin + Add_Stmt (new O_Snode_Comment_Stmt'(Kind => ON_Debug_Comment_Stmt, + Next => null, + Lineno => 0, + Comment => new String'(Comment))); + end New_Debug_Comment_Stmt; + + procedure Start_Declare_Stmt + is + N : O_Snode; + begin + N := new O_Snode_Type (ON_Declare_Stmt); + Add_Stmt (N); + Push_Decl_Scope (N); + Push_Stmt_Scope + (new Stmt_Declare_Scope_Type'(Kind => Stmt_Declare, + Parent => N, + Prev => Current_Stmt_Scope)); + end Start_Declare_Stmt; + + procedure Finish_Declare_Stmt is + begin + Pop_Decl_Scope; + Pop_Stmt_Scope (Stmt_Declare); + end Finish_Declare_Stmt; + + procedure New_Assign_Stmt (Target : O_Lnode; Value : O_Enode) + is + N : O_Snode; + begin + Check_Type (Target.Rtype, Value.Rtype); + Check_Not_Composite (Target.Rtype); + Check_Ref (Target); + Check_Ref (Value); + N := new O_Snode_Type (ON_Assign_Stmt); + N.all := O_Snode_Type'(Kind => ON_Assign_Stmt, + Next => null, + Lineno => 0, + Target => Target, + Value => Value); + Add_Stmt (N); + end New_Assign_Stmt; + + procedure New_Return_Stmt_1 (Value : O_Enode) + is + subtype O_Snode_Return_Stmt is O_Snode_Type (ON_Return_Stmt); + N : O_Snode; + begin + N := new O_Snode_Return_Stmt'(Kind => ON_Return_Stmt, + Next => null, + Lineno => 0, + Ret_Val => Value); + Add_Stmt (N); + end New_Return_Stmt_1; + + procedure New_Return_Stmt (Value : O_Enode) + is + begin + if Current_Function = null + or else Current_Function.Decl.Dtype = O_Tnode_Null + then + -- Either not in a function or in a procedure. + raise Syntax_Error; + end if; + Check_Type (Value.Rtype, Current_Function.Decl.Dtype); + Check_Ref (Value); + New_Return_Stmt_1 (Value); + end New_Return_Stmt; + + procedure New_Return_Stmt is + begin + if Current_Function = null + or else Current_Function.Decl.Dtype /= O_Tnode_Null + then + -- Not in a procedure. + raise Syntax_Error; + end if; + New_Return_Stmt_1 (null); + end New_Return_Stmt; + + procedure Start_Association (Assocs : out O_Assoc_List; Subprg : O_Dnode) + is + begin + Check_Scope (Subprg); + Assocs.Subprg := Subprg; + Assocs.Interfaces := Subprg.Interfaces; + Assocs.First := null; + Assocs.Last := null; + end Start_Association; + + procedure New_Association (Assocs : in out O_Assoc_List; Val : O_Enode) + is + N : O_Anode; + begin + Check_Type (Assocs.Interfaces.Dtype, Val.Rtype); + Assocs.Interfaces := Assocs.Interfaces.Next; + Check_Ref (Val); + N := new O_Anode_Type'(Next => null, Formal => null, Actual => Val); + if Assocs.Last = null then + Assocs.First := N; + else + Assocs.Last.Next := N; + end if; + Assocs.Last := N; + end New_Association; + + function New_Function_Call (Assocs : O_Assoc_List) return O_Enode + is + subtype O_Enode_Call is O_Enode_Type (OE_Function_Call); + Res : O_Enode; + begin + if Assocs.Interfaces /= null then + -- Not enough arguments. + raise Syntax_Error; + end if; + if Assocs.Subprg.Dtype = null then + -- This is a procedure. + raise Syntax_Error; + end if; + + Res := new O_Enode_Call'(Kind => OE_Function_Call, + Rtype => Assocs.Subprg.Dtype, + Ref => False, + Func => Assocs.Subprg, + Assoc => Assocs.First); + return Res; + end New_Function_Call; + + procedure New_Procedure_Call (Assocs : in out O_Assoc_List) + is + N : O_Snode; + begin + if Assocs.Interfaces /= null then + -- Not enough arguments. + raise Syntax_Error; + end if; + if Assocs.Subprg.Dtype /= null then + -- This is a function. + raise Syntax_Error; + end if; + N := new O_Snode_Type (ON_Call_Stmt); + N.Proc := Assocs.Subprg; + N.Assoc := Assocs.First; + Add_Stmt (N); + end New_Procedure_Call; + + procedure Start_If_Stmt (Block : in out O_If_Block; Cond : O_Enode) + is + subtype O_Snode_If is O_Snode_Type (ON_If_Stmt); + N : O_Snode; + begin + -- Note: no checks are performed here, since they are done in + -- new_elsif_stmt. + N := new O_Snode_If'(Kind => ON_If_Stmt, + Next => null, + Lineno => 0, + Elsifs => null, + If_Last => null); + Add_Stmt (N); + Push_Stmt_Scope (new Stmt_If_Scope_Type'(Kind => Stmt_If, + Parent => N, + Prev => Current_Stmt_Scope, + Last_Elsif => null)); + New_Elsif_Stmt (Block, Cond); + end Start_If_Stmt; + + procedure New_Elsif_Stmt (Block : in out O_If_Block; Cond : O_Enode) + is + pragma Unreferenced (Block); + N : O_Snode; + begin + if Cond /= null then + if Cond.Rtype.Kind /= ON_Boolean_Type then + raise Type_Error; + end if; + Check_Ref (Cond); + end if; + N := new O_Snode_Type (ON_Elsif_Stmt); + N.all := O_Snode_Type'(Kind => ON_Elsif_Stmt, + Next => null, + Lineno => 0, + Cond => Cond, + Next_Elsif => null); + if Current_Stmt_Scope.Kind /= Stmt_If then + raise Syntax_Error; + end if; + Add_Stmt (N); + if Current_Stmt_Scope.Last_Elsif = null then + Current_Stmt_Scope.Parent.Elsifs := N; + else + -- Check for double 'else' + if Current_Stmt_Scope.Last_Elsif.Cond = null then + raise Syntax_Error; + end if; + Current_Stmt_Scope.Last_Elsif.Next_Elsif := N; + end if; + Current_Stmt_Scope.Last_Elsif := N; + end New_Elsif_Stmt; + + procedure New_Else_Stmt (Block : in out O_If_Block) is + begin + New_Elsif_Stmt (Block, null); + end New_Else_Stmt; + + procedure Finish_If_Stmt (Block : in out O_If_Block) + is + pragma Unreferenced (Block); + Parent : O_Snode; + begin + Parent := Current_Stmt_Scope.Parent; + Pop_Stmt_Scope (Stmt_If); + Parent.If_Last := Current_Decl_Scope.Last_Stmt; + end Finish_If_Stmt; + + procedure Start_Loop_Stmt (Label : out O_Snode) + is + subtype O_Snode_Loop_Type is O_Snode_Type (ON_Loop_Stmt); + begin + Current_Loop_Level := Current_Loop_Level + 1; + Label := new O_Snode_Loop_Type'(Kind => ON_Loop_Stmt, + Next => null, + Lineno => 0, + Loop_Last => null, + Loop_Level => Current_Loop_Level); + Add_Stmt (Label); + Push_Stmt_Scope (new Stmt_Loop_Scope_Type'(Kind => Stmt_Loop, + Parent => Label, + Prev => Current_Stmt_Scope)); + end Start_Loop_Stmt; + + procedure Finish_Loop_Stmt (Label : in out O_Snode) + is + pragma Unreferenced (Label); + Parent : O_Snode; + begin + Parent := Current_Stmt_Scope.Parent; + Pop_Stmt_Scope (Stmt_Loop); + Parent.Loop_Last := Current_Decl_Scope.Last_Stmt; + Current_Loop_Level := Current_Loop_Level - 1; + end Finish_Loop_Stmt; + + procedure New_Exit_Next_Stmt (Kind : ON_Stmt_Kind; L : O_Snode) + is + N : O_Snode; + begin + N := new O_Snode_Type (Kind); + N.Next := null; + N.Loop_Id := L; + Add_Stmt (N); + end New_Exit_Next_Stmt; + + procedure New_Exit_Stmt (L : O_Snode) is + begin + New_Exit_Next_Stmt (ON_Exit_Stmt, L); + end New_Exit_Stmt; + + procedure New_Next_Stmt (L : O_Snode) is + begin + New_Exit_Next_Stmt (ON_Next_Stmt, L); + end New_Next_Stmt; + + procedure Start_Case_Stmt (Block : in out O_Case_Block; Value : O_Enode) + is + pragma Unreferenced (Block); + subtype O_Snode_Case_Type is O_Snode_Type (ON_Case_Stmt); + N : O_Snode; + begin + case Value.Rtype.Kind is + when ON_Boolean_Type + | ON_Unsigned_Type + | ON_Signed_Type + | ON_Enum_Type => + null; + when others => + raise Type_Error; + end case; + Check_Ref (Value); + N := new O_Snode_Case_Type'(Kind => ON_Case_Stmt, + Next => null, + Lineno => 0, + Case_Last => null, + Selector => Value, + Branches => null); + Add_Stmt (N); + Push_Stmt_Scope (new Stmt_Case_Scope_Type'(Kind => Stmt_Case, + Parent => N, + Prev => Current_Stmt_Scope, + Last_Branch => null, + Last_Choice => null, + Case_Type => Value.Rtype)); + end Start_Case_Stmt; + + procedure Start_Choice (Block : in out O_Case_Block) + is + pragma Unreferenced (Block); + N : O_Snode; + begin + if Current_Stmt_Scope.Kind /= Stmt_Case then + -- You are adding a branch outside a case statment. + raise Syntax_Error; + end if; + if Current_Stmt_Scope.Last_Choice /= null then + -- You are creating branch while the previous one was not finished. + raise Syntax_Error; + end if; + + N := new O_Snode_Type (ON_When_Stmt); + N.all := O_Snode_Type'(Kind => ON_When_Stmt, + Next => null, + Lineno => 0, + Choice_List => null, + Next_Branch => null); + if Current_Stmt_Scope.Last_Branch = null then + Current_Stmt_Scope.Parent.Branches := N; + else + Current_Stmt_Scope.Last_Branch.Next_Branch := N; + end if; + Current_Stmt_Scope.Last_Branch := N; + Current_Stmt_Scope.Last_Choice := null; + Add_Stmt (N); + end Start_Choice; + + procedure Add_Choice (Block : in out O_Case_Block; Choice : O_Choice) + is + pragma Unreferenced (Block); + begin + if Current_Stmt_Scope.Kind /= Stmt_Case then + -- You are adding a choice not inside a case statement. + raise Syntax_Error; + end if; + if Current_Stmt_Scope.Last_Branch = null then + -- You are not inside a branch. + raise Syntax_Error; + end if; + if Current_Stmt_Scope.Last_Choice = null then + if Current_Stmt_Scope.Last_Branch.Choice_List /= null then + -- The branch was already closed. + raise Syntax_Error; + end if; + Current_Stmt_Scope.Last_Branch.Choice_List := Choice; + else + Current_Stmt_Scope.Last_Choice.Next := Choice; + end if; + Current_Stmt_Scope.Last_Choice := Choice; + end Add_Choice; + + procedure New_Expr_Choice (Block : in out O_Case_Block; Expr : O_Cnode) + is + N : O_Choice; + begin + if Current_Stmt_Scope.Kind /= Stmt_Case then + -- You are creating a choice not inside a case statement. + raise Syntax_Error; + end if; + if Current_Stmt_Scope.Case_Type /= Expr.Ctype then + -- Expr type is not the same as choice type. + raise Type_Error; + end if; + + N := new O_Choice_Type (ON_Choice_Expr); + N.all := O_Choice_Type'(Kind => ON_Choice_Expr, + Next => null, + Expr => Expr); + Add_Choice (Block, N); + end New_Expr_Choice; + + procedure New_Range_Choice (Block : in out O_Case_Block; + Low, High : O_Cnode) + is + N : O_Choice; + begin + if Current_Stmt_Scope.Kind /= Stmt_Case then + -- You are creating a choice not inside a case statement. + raise Syntax_Error; + end if; + if Current_Stmt_Scope.Case_Type /= Low.Ctype + or Current_Stmt_Scope.Case_Type /= High.Ctype + then + -- Low/High type is not the same as choice type. + raise Type_Error; + end if; + + N := new O_Choice_Type (ON_Choice_Range); + N.all := O_Choice_Type'(Kind => ON_Choice_Range, + Next => null, + Low => Low, + High => High); + Add_Choice (Block, N); + end New_Range_Choice; + + procedure New_Default_Choice (Block : in out O_Case_Block) + is + N : O_Choice; + begin + if Current_Stmt_Scope.Kind /= Stmt_Case then + -- You are creating a choice not inside a case statement. + raise Syntax_Error; + end if; + + N := new O_Choice_Type (ON_Choice_Default); + N.all := O_Choice_Type'(Kind => ON_Choice_Default, + Next => null); + Add_Choice (Block, N); + end New_Default_Choice; + + procedure Finish_Choice (Block : in out O_Case_Block) + is + pragma Unreferenced (Block); + begin + if Current_Stmt_Scope.Kind /= Stmt_Case then + -- You are adding a choice not inside a case statement. + raise Syntax_Error; + end if; + if Current_Stmt_Scope.Last_Branch = null then + -- You are not inside a branch. + raise Syntax_Error; + end if; + if Current_Stmt_Scope.Last_Choice = null then + -- The branch is empty or you are not inside a branch. + raise Syntax_Error; + end if; + Current_Stmt_Scope.Last_Choice := null; + end Finish_Choice; + + procedure Finish_Case_Stmt (Block : in out O_Case_Block) + is + pragma Unreferenced (Block); + Parent : O_Snode; + begin + Parent := Current_Stmt_Scope.Parent; + Pop_Stmt_Scope (Stmt_Case); + Parent.Case_Last := Current_Decl_Scope.Last_Stmt; + end Finish_Case_Stmt; + + procedure Init is + begin + Top := new O_Snode_Type (ON_Declare_Stmt); + Push_Decl_Scope (Top); + end Init; + + procedure Finish is + begin + Pop_Decl_Scope; + end Finish; +end Ortho_Debug; diff --git a/ortho/debug/ortho_debug.private.ads b/ortho/debug/ortho_debug.private.ads new file mode 100644 index 0000000..d54d542 --- /dev/null +++ b/ortho/debug/ortho_debug.private.ads @@ -0,0 +1,439 @@ +with Ortho_Ident; +use Ortho_Ident; + +package Ortho_Debug is + type O_Enode is private; + type O_Cnode is private; + type O_Lnode is private; + -- A node for a type. + type O_Tnode_Type (<>) is private; + type O_Tnode is access O_Tnode_Type; + -- A node for a statement. + type O_Snode_Type (<>) is private; + type O_Snode is access O_Snode_Type; + -- A node for a function. + type O_Dnode_Type (<>) is private; + type O_Dnode is access O_Dnode_Type; + -- A node for a record element. + type O_Fnode_Type is private; + type O_Fnode is access O_Fnode_Type; + + procedure Init; + procedure Finish; + Top : O_Snode; +private + type Str_Acc is access String; + + type Decl_Scope_Type; + type Decl_Scope_Acc is access Decl_Scope_Type; + + type On_Decl_Kind is + (ON_Type_Decl, ON_Completed_Type_Decl, + ON_Const_Decl, ON_Var_Decl, ON_Interface_Decl, + ON_Function_Decl, ON_Function_Body, + ON_Const_Value, + ON_Debug_Line_Decl, ON_Debug_Comment_Decl, ON_Debug_Filename_Decl); + O_Dnode_Null : constant O_Dnode := null; + type O_Dnode_Type (Kind : On_Decl_Kind) is record + Next : O_Dnode; + Name : O_Ident; + Dtype : O_Tnode; + Storage : O_Storage; + -- Declare statement in which the declaration appears. + Scope : O_Snode; + -- Line number, for regen. + Lineno : Natural; + case Kind is + when ON_Type_Decl => + null; + when ON_Completed_Type_Decl => + null; + when ON_Const_Decl => + Const_Value : O_Dnode; + when ON_Const_Value => + Const_Decl : O_Dnode; + Value : O_Cnode; + when ON_Var_Decl => + null; + when ON_Function_Decl => + Interfaces : O_Dnode; + Func_Body : O_Dnode; + Alive : Boolean; + when ON_Function_Body => + Func_Decl : O_Dnode; + Func_Stmt : O_Snode; + when ON_Interface_Decl => + Func_Scope : O_Dnode; + when ON_Debug_Line_Decl => + Line : Natural; + when ON_Debug_Comment_Decl => + Comment : Str_Acc; + when ON_Debug_Filename_Decl => + Filename : Str_Acc; + end case; + end record; + + O_Fnode_Null : constant O_Fnode := null; + type O_Fnode_Type is record + -- Record type. + Parent : O_Tnode; + -- Next field in the record. + Next : O_Fnode; + -- Name of the record field. + Ident : O_Ident; + -- Type of the record field. + Ftype : O_Tnode; + -- Offset in the field. + Offset : Unsigned_32; + end record; + + type O_Anode_Type; + type O_Anode is access O_Anode_Type; + type O_Anode_Type is record + Next : O_Anode; + Formal : O_Dnode; + Actual : O_Enode; + end record; + + type OC_Kind is + ( + OC_Boolean_Lit, + OC_Unsigned_Lit, + OC_Signed_Lit, + OC_Float_Lit, + OC_Enum_Lit, + OC_Null_Lit, + OC_Sizeof_Lit, + OC_Offsetof_Lit, + OC_Aggregate, + OC_Aggr_Element, + OC_Union_Aggr, + OC_Address, + OC_Unchecked_Address, + OC_Subprogram_Address + ); + type O_Cnode_Type (Kind : OC_Kind) is record + -- Type of the constant. + Ctype : O_Tnode; + -- True if referenced. + Ref : Boolean; + case Kind is + when OC_Unsigned_Lit => + U_Val : Unsigned_64; + when OC_Signed_Lit => + S_Val : Integer_64; + when OC_Float_Lit => + F_Val : IEEE_Float_64; + when OC_Boolean_Lit => + B_Val : Boolean; + B_Id : O_Ident; + when OC_Enum_Lit => + E_Val : Integer; + E_Next : O_Cnode; + E_Name : O_Ident; + when OC_Null_Lit => + null; + when OC_Sizeof_Lit => + S_Type : O_Tnode; + when OC_Offsetof_Lit => + Off_Field : O_Fnode; + when OC_Aggregate => + Aggr_Els : O_Cnode; + when OC_Union_Aggr => + Uaggr_Field : O_Fnode; + Uaggr_Value : O_Cnode; + when OC_Aggr_Element => + Aggr_Value : O_Cnode; + Aggr_Next : O_Cnode; + when OC_Address + | OC_Unchecked_Address + | OC_Subprogram_Address => + Decl : O_Dnode; + end case; + end record; + + type O_Cnode is access O_Cnode_Type; + O_Cnode_Null : constant O_Cnode := null; + + type OE_Kind is + ( + -- Literals. + OE_Lit, + + -- Dyadic operations. + OE_Add_Ov, -- OE_Dyadic_Op_Kind + OE_Sub_Ov, -- OE_Dyadic_Op_Kind + OE_Mul_Ov, -- OE_Dyadic_Op_Kind + OE_Div_Ov, -- OE_Dyadic_Op_Kind + OE_Rem_Ov, -- OE_Dyadic_Op_Kind + OE_Mod_Ov, -- OE_Dyadic_Op_Kind + OE_Exp_Ov, -- OE_Dyadic_Op_Kind + + -- Binary operations. + OE_And, -- OE_Dyadic_Op_Kind + OE_Or, -- OE_Dyadic_Op_Kind + OE_Xor, -- OE_Dyadic_Op_Kind + OE_And_Then, -- OE_Dyadic_Op_Kind + OE_Or_Else, -- OE_Dyadic_Op_Kind + + -- Monadic operations. + OE_Not, -- OE_Monadic_Op_Kind + OE_Neg_Ov, -- OE_Monadic_Op_Kind + OE_Abs_Ov, -- OE_Monadic_Op_Kind + + -- Comparaisons + OE_Eq, -- OE_Compare_Op_Kind + OE_Neq, -- OE_Compare_Op_Kind + OE_Le, -- OE_Compare_Op_Kind + OE_Lt, -- OE_Compare_Op_Kind + OE_Ge, -- OE_Compare_Op_Kind + OE_Gt, -- OE_Compare_Op_Kind + + -- Misc. + OE_Convert_Ov, + OE_Address, + OE_Unchecked_Address, + OE_Alloca, + OE_Function_Call, + + OE_Value, + OE_Nil + ); + + subtype OE_Dyadic_Expr_Kind is OE_Kind range OE_Add_Ov .. OE_Or_Else; + subtype OE_Monadic_Expr_Kind is OE_Kind range OE_Not .. OE_Abs_Ov; + subtype OE_Compare_Expr_Kind is OE_Kind range OE_Eq .. OE_Gt; + + type O_Enode_Type (Kind : OE_Kind); + type O_Enode is access O_Enode_Type; + O_Enode_Null : constant O_Enode := null; + + type O_Enode_Type (Kind : OE_Kind) is record + -- Type of the result. + Rtype : O_Tnode; + -- True if referenced. + Ref : Boolean; + case Kind is + when OE_Dyadic_Expr_Kind + | OE_Compare_Expr_Kind => + Left : O_Enode; + Right : O_Enode; + when OE_Monadic_Expr_Kind => + Operand : O_Enode; + when OE_Lit => + Lit : O_Cnode; + when OE_Address + | OE_Unchecked_Address => + Lvalue : O_Lnode; + when OE_Convert_Ov => + Conv : O_Enode; + when OE_Function_Call => + Func : O_Dnode; + Assoc : O_Anode; + when OE_Value => + Value : O_Lnode; + when OE_Alloca => + A_Size : O_Enode; + when OE_Nil => + null; + end case; + end record; + type O_Enode_Array is array (Natural range <>) of O_Enode; + type O_Enode_Array_Acc is access O_Enode_Array; + + type OL_Kind is + ( + -- Name. + OL_Obj, + OL_Indexed_Element, + OL_Slice, + OL_Selected_Element, + OL_Access_Element + + -- Variable, constant, parameter reference. + -- This allows to read/write a declaration. + --OL_Var_Ref, + --OL_Const_Ref, + --OL_Param_Ref + ); + + type O_Lnode_Type (Kind : OL_Kind); + type O_Lnode is access O_Lnode_Type; + O_Lnode_Null : constant O_Lnode := null; + + type O_Lnode_Type (Kind : OL_Kind) is record + -- Type of the result. + Rtype : O_Tnode; + -- True if referenced. + Ref : Boolean; + case Kind is + when OL_Obj => + Obj : O_Dnode; + when OL_Indexed_Element => + Array_Base : O_Lnode; + Index : O_Enode; + when OL_Slice => + Slice_Base : O_Lnode; + Slice_Index : O_Enode; + when OL_Selected_Element => + Rec_Base : O_Lnode; + Rec_El : O_Fnode; + when OL_Access_Element => + Acc_Base : O_Enode; +-- when OL_Var_Ref +-- | OL_Const_Ref +-- | OL_Param_Ref => +-- Decl : O_Dnode; + end case; + end record; + + O_Tnode_Null : constant O_Tnode := null; + type ON_Type_Kind is + (ON_Boolean_Type, ON_Enum_Type, + ON_Unsigned_Type, ON_Signed_Type, ON_Float_Type, ON_Array_Type, + ON_Array_Sub_Type, ON_Record_Type, ON_Union_Type, ON_Access_Type); + type O_Tnode_Type (Kind : ON_Type_Kind) is record + Decl : O_Dnode; + -- Alignment, in power of 2. + Align : Natural; + -- Size in bytes. + Size : Unsigned_32; + -- True if the type was first created as an uncomplete type. + Uncomplete : Boolean; + -- True if the type is complete. + Complete : Boolean; + case Kind is + when ON_Boolean_Type => + True_N : O_Cnode; + False_N : O_Cnode; + when ON_Unsigned_Type + | ON_Signed_Type => + null; + when ON_Float_Type => + null; + when ON_Enum_Type => + Nbr : Natural; + Literals: O_Cnode; + when ON_Array_Type => + El_Type : O_Tnode; + Index_Type : O_Tnode; + when ON_Access_Type => + D_Type : O_Tnode; + when ON_Record_Type + | ON_Union_Type => + Elements : O_Fnode; + when ON_Array_Sub_Type => + Length : O_Cnode; + Base_Type : O_Tnode; + end case; + end record; + + type ON_Choice_Kind is (ON_Choice_Expr, ON_Choice_Range, ON_Choice_Default); + type O_Choice_Type (Kind : ON_Choice_Kind); + type O_Choice is access O_Choice_Type; + type O_Choice_Type (Kind : ON_Choice_Kind) is record + Next : O_Choice; + case Kind is + when ON_Choice_Expr => + Expr : O_Cnode; + when ON_Choice_Range => + Low, High : O_Cnode; + when ON_Choice_Default => + null; + end case; + end record; + + O_Snode_Null : constant O_Snode := null; + type ON_Stmt_Kind is + (ON_Declare_Stmt, ON_Assign_Stmt, ON_Return_Stmt, ON_If_Stmt, + ON_Elsif_Stmt, ON_Loop_Stmt, ON_Exit_Stmt, ON_Next_Stmt, + ON_Case_Stmt, ON_When_Stmt, ON_Call_Stmt, + ON_Debug_Line_Stmt, ON_Debug_Comment_Stmt); + type O_Snode_Type (Kind : ON_Stmt_Kind) is record + Next : O_Snode; + Lineno : Natural; + case Kind is + when ON_Declare_Stmt => + Decls : O_Dnode; + Stmts : O_Snode; + -- True if the statement is currently open. + Alive : Boolean; + when ON_Assign_Stmt => + Target : O_Lnode; + Value : O_Enode; + when ON_Return_Stmt => + Ret_Val : O_Enode; + when ON_If_Stmt => + Elsifs : O_Snode; + If_Last : O_Snode; + when ON_Elsif_Stmt => + Cond : O_Enode; + Next_Elsif : O_Snode; + when ON_Loop_Stmt => + Loop_Last : O_Snode; + Loop_Level : Natural; + when ON_Exit_Stmt + | ON_Next_Stmt => + Loop_Id : O_Snode; + when ON_Case_Stmt => + Selector : O_Enode; + Branches : O_Snode; + Case_Last : O_Snode; + when ON_When_Stmt => + Choice_List : O_Choice; + Next_Branch : O_Snode; + when ON_Call_Stmt => + Proc : O_Dnode; + Assoc : O_Anode; + when ON_Debug_Line_Stmt => + Line : Natural; + when ON_Debug_Comment_Stmt => + Comment : Str_Acc; + end case; + end record; + + type O_Inter_List is record + Func : O_Dnode; + Last : O_Dnode; + end record; + + type O_Element_List is record + -- The type definition. + Res : O_Tnode; + -- The last element added. + Last : O_Fnode; + end record; + + type O_Record_Aggr_List is record + Res : O_Cnode; + Last : O_Cnode; + Field : O_Fnode; + end record; + + type O_Array_Aggr_List is record + Res : O_Cnode; + Last : O_Cnode; + El_Type : O_Tnode; + end record; + + type O_Assoc_List is record + Subprg : O_Dnode; + Interfaces : O_Dnode; + First, Last : O_Anode; + end record; + + type O_Enum_List is record + -- The type built. + Res : O_Tnode; + + -- the chain of declarations. + Last : O_Cnode; + end record; + type O_Case_Block is record + null; + end record; + + type O_If_Block is record + null; + end record; +end Ortho_Debug; diff --git a/ortho/debug/ortho_debug_front.ads b/ortho/debug/ortho_debug_front.ads new file mode 100644 index 0000000..454c868 --- /dev/null +++ b/ortho/debug/ortho_debug_front.ads @@ -0,0 +1,2 @@ +with Ortho_Front; +package Ortho_Debug_Front renames Ortho_Front; diff --git a/ortho/debug/ortho_ident.ads b/ortho/debug/ortho_ident.ads new file mode 100644 index 0000000..9b00d03 --- /dev/null +++ b/ortho/debug/ortho_ident.ads @@ -0,0 +1,2 @@ +with Ortho_Ident_Simple; +package Ortho_Ident renames Ortho_Ident_Simple; diff --git a/ortho/debug/ortho_ident_hash.adb b/ortho/debug/ortho_ident_hash.adb new file mode 100644 index 0000000..c22b130 --- /dev/null +++ b/ortho/debug/ortho_ident_hash.adb @@ -0,0 +1,54 @@ +package body Ortho_Ident_Hash is + type O_Ident_Array is array (Hash_Type range <>) of O_Ident; + Hash_Max : constant Hash_Type := 511; + Symtable : O_Ident_Array (0 .. Hash_Max - 1) := (others => null); + + function Get_Identifier (Str : String) return O_Ident + is + Hash : Hash_Type; + Ent : Hash_Type; + Res : O_Ident; + begin + -- 1. Compute Hash. + Hash := 0; + for I in Str'Range loop + Hash := Hash * 31 + Character'Pos (Str (I)); + end loop; + + -- 2. Search. + Ent := Hash mod Hash_Max; + Res := Symtable (Ent); + while Res /= null loop + if Res.Hash = Hash and then Res.Ident.all = Str then + return Res; + end if; + Res := Res.Next; + end loop; + + -- Not found: add. + Res := new Ident_Type'(Hash => Hash, + Ident => new String'(Str), + Next => Symtable (Ent)); + Symtable (Ent) := Res; + return Res; + end Get_Identifier; + + function Get_String (Id : O_Ident) return String is + begin + if Id = null then + return "?ANON?"; + else + return Id.Ident.all; + end if; + end Get_String; + + function Is_Nul (Id : O_Ident) return Boolean is + begin + return Id = null; + end Is_Nul; + + function Is_Equal (Id : O_Ident; Str : String) return Boolean is + begin + return Id.Ident.all = Str; + end Is_Equal; +end Ortho_Ident_Hash; diff --git a/ortho/debug/ortho_ident_hash.ads b/ortho/debug/ortho_ident_hash.ads new file mode 100644 index 0000000..9ef2bd4 --- /dev/null +++ b/ortho/debug/ortho_ident_hash.ads @@ -0,0 +1,28 @@ +package Ortho_Ident_Hash is + type O_Ident is private; + O_Ident_Nul : constant O_Ident; + + function Get_Identifier (Str : String) return O_Ident; + function Get_String (Id : O_Ident) return String; + function Is_Equal (L, R : O_Ident) return Boolean renames "="; + function Is_Equal (Id : O_Ident; Str : String) return Boolean; + function Is_Nul (Id : O_Ident) return Boolean; +private + type Hash_Type is mod 2**32; + + type String_Acc is access constant String; + + -- Symbol table. + type Ident_Type; + type O_Ident is access Ident_Type; + type Ident_type is record + -- The hash for the symbol. + Hash : Hash_Type; + -- Identification of the symbol. + Ident : String_Acc; + -- Next symbol with the same collision. + Next : O_Ident; + end record; + + O_Ident_Nul : constant O_Ident := null; +end Ortho_Ident_Hash; diff --git a/ortho/debug/ortho_ident_simple.adb b/ortho/debug/ortho_ident_simple.adb new file mode 100644 index 0000000..2c641c3 --- /dev/null +++ b/ortho/debug/ortho_ident_simple.adb @@ -0,0 +1,26 @@ +package body Ortho_Ident_Simple is + function Get_Identifier (Str : String) return O_Ident + is + begin + return new String'(Str); + end Get_Identifier; + + function Get_String (Id : O_Ident) return String is + begin + if Id = null then + return "?ANON?"; + else + return Id.all; + end if; + end Get_String; + + function Is_Nul (Id : O_Ident) return Boolean is + begin + return Id = null; + end Is_Nul; + + function Is_Equal (Id : O_Ident; Str : String) return Boolean is + begin + return Id.all = Str; + end Is_Equal; +end Ortho_Ident_Simple; diff --git a/ortho/debug/ortho_ident_simple.ads b/ortho/debug/ortho_ident_simple.ads new file mode 100644 index 0000000..63bd769 --- /dev/null +++ b/ortho/debug/ortho_ident_simple.ads @@ -0,0 +1,13 @@ +package Ortho_Ident_Simple is + type O_Ident is private; + O_Ident_Nul : constant O_Ident; + + function Get_Identifier (Str : String) return O_Ident; + function Get_String (Id : O_Ident) return String; + function Is_Equal (L, R : O_Ident) return Boolean renames "="; + function Is_Equal (Id : O_Ident; Str : String) return Boolean; + function Is_Nul (Id : O_Ident) return Boolean; +private + type O_Ident is access String; + O_Ident_Nul : constant O_Ident := null; +end Ortho_Ident_Simple; diff --git a/ortho/debug/ortho_nodes.ads b/ortho/debug/ortho_nodes.ads new file mode 100644 index 0000000..a6c9c51 --- /dev/null +++ b/ortho/debug/ortho_nodes.ads @@ -0,0 +1,3 @@ +with Ortho_Debug; + +package Ortho_Nodes renames Ortho_Debug; diff --git a/ortho/oread/Makefile b/ortho/oread/Makefile new file mode 100644 index 0000000..c297af0 --- /dev/null +++ b/ortho/oread/Makefile @@ -0,0 +1,25 @@ +BE = gcc +ortho_srcdir=.. +BACK_END=$(ortho_srcdir)/$(BE) +ortho_exec=oread-$(BE) +all: $(ortho_exec) + +test: test.s + $(CC) -o $@ $^ + +test.s: $(ortho_exec) + ./$(ortho_exec) test + +$(ortho_exec): force + $(MAKE) -f $(BACK_END)/Makefile ortho_exec=$(ortho_exec) + +clean: + $(MAKE) -f $(BACK_END)/Makefile clean + $(RM) -f oread *.o *~ + +distclean: clean + $(MAKE) -f $(BACK_END)/Makefile distclean + +force: + +.PHONY: force diff --git a/ortho/oread/ortho_front.adb b/ortho/oread/ortho_front.adb new file mode 100644 index 0000000..8821ce9 --- /dev/null +++ b/ortho/oread/ortho_front.adb @@ -0,0 +1,2650 @@ +with Ada.Unchecked_Deallocation; +with Ortho_Nodes; use Ortho_Nodes; +with Ortho_Ident; use Ortho_Ident; +with Ada.Characters.Latin_1; use Ada.Characters.Latin_1; +with GNAT.OS_Lib; use GNAT.OS_Lib; +with Interfaces; use Interfaces; +with Ada.Exceptions; +--with GNAT.Debug_Pools; + +-- TODO: +-- uncomplete type: check for type redefinition + +package body Ortho_Front is + -- If true, emit line number before each statement. + -- If flase, keep line number indication in the source file. + Flag_Renumber : Boolean := True; + + procedure Init is + begin + null; + end Init; + + function Decode_Option (Opt : String_Acc; Arg : String_Acc) return Natural + is + pragma Unreferenced (Arg); + begin + if Opt.all = "-r" then + Flag_Renumber := True; + return 1; + else + return 0; + end if; + end Decode_Option; + + -- File buffer. + File_Name : String_Acc; + Buf : String (1 .. 2048 + 1); + Buf_Len : Natural; + Pos : Natural; + Lineno : Natural; + + Fd : File_Descriptor; + + Error : exception; + + procedure Puterr (Msg : String) + is + L : Integer; + begin + L := Write (Standerr, Msg'Address, Msg'Length); + end Puterr; + + procedure Puterr (N : Natural) + is + Str : String := Natural'Image (N); + begin + Puterr (Str (Str'First + 1 .. Str'Last)); + end Puterr; + + procedure Newline_Err is + begin + Puterr ((1 => LF)); + end Newline_Err; + + procedure Scan_Error (Msg : String) is + begin + Puterr (File_Name.all); + Puterr (":"); + Puterr (Lineno); + Puterr (": "); + Puterr (Msg); + Newline_Err; + raise Error; + end Scan_Error; + + procedure Parse_Error (Msg : String); + pragma No_Return (Parse_Error); + + procedure Parse_Error (Msg : String) is + begin + Puterr (File_Name.all); + Puterr (":"); + Puterr (Lineno); + Puterr (": "); + Puterr (Msg); + Newline_Err; + raise Error; + end Parse_Error; + + +-- Uniq_Num : Natural := 0; + +-- function Get_Uniq_Id return O_Ident +-- is +-- Str : String (1 .. 8); +-- V : Natural; +-- begin +-- V := Uniq_Num; +-- Uniq_Num := Uniq_Num + 1; +-- Str (1) := 'L'; +-- Str (2) := '.'; +-- for I in reverse 3 .. Str'Last loop +-- Str (I) := Character'Val ((V mod 10) + Character'Pos('0')); +-- V := V / 10; +-- end loop; +-- return Get_Identifier (Str); +-- end Get_Uniq_Id; + + -- Get the next character. + -- Return NUL on end of file. + function Get_Char return Character + is + Res : Character; + begin + if Buf (Pos) = NUL then + -- Read line. + Buf_Len := Read (Fd, Buf'Address, Buf'Length - 1); + if Buf_Len <= 0 then + -- End of file. + return NUL; + end if; + Pos := 1; + Buf (Buf_Len + 1) := NUL; + end if; + + Res := Buf (Pos); + Pos := Pos + 1; + return Res; + end Get_Char; + + procedure Unget_Char is + begin + if Pos = Buf'First then + raise Program_Error; + end if; + Pos := Pos - 1; + end Unget_Char; + + type Token_Type is + (Tok_Eof, + Tok_Line_Number, Tok_File_Name, Tok_Comment, + Tok_Ident, Tok_Num, Tok_String, Tok_Float_Num, + Tok_Plus, Tok_Minus, + Tok_Star, Tok_Div, Tok_Mod, Tok_Rem, + Tok_Sharp, + Tok_Not, Tok_Abs, + Tok_Or, Tok_And, Tok_Xor, + Tok_Equal, Tok_Not_Equal, + Tok_Greater, Tok_Greater_Eq, + Tok_Less, Tok_Less_Eq, + Tok_Colon, Tok_Semicolon, + Tok_Comma, Tok_Dot, Tok_Tick, Tok_Arob, Tok_Elipsis, + Tok_Assign, + Tok_Left_Paren, Tok_Right_Paren, + Tok_Left_Brace, Tok_Right_Brace, + Tok_Left_Brack, Tok_Right_Brack, + Tok_Unsigned, Tok_Signed, Tok_Float, + Tok_Array, Tok_Subarray, + Tok_Access, Tok_Record, Tok_Union, + Tok_Boolean, Tok_Enum, + Tok_If, Tok_Then, Tok_Else, + Tok_Loop, Tok_Exit, Tok_Next, + Tok_Is, Tok_Of, Tok_All, + Tok_Return, + Tok_Type, + Tok_External, Tok_Private, Tok_Public, Tok_Local, + Tok_Procedure, Tok_Function, + Tok_Constant, Tok_Var, + Tok_Declare, Tok_Begin, Tok_End, + Tok_Case, Tok_When, Tok_Default, Tok_Arrow, + Tok_Null); + + type Hash_Type is new Unsigned_32; + + type Name_Type; + type Name_Acc is access Name_Type; + + -- Symbol table. + type Syment_Type; + type Syment_Acc is access Syment_Type; + type Syment_type is record + -- The hash for the symbol. + Hash : Hash_Type; + -- Identification of the symbol. + Ident : O_Ident; + -- Next symbol with the same collision. + Next : Syment_Acc; + -- Meaning of the symbol. + Name : Name_Acc; + end record; + + -- Well known identifiers (used for attributes). + Id_Address : Syment_Acc; + Id_Unchecked_Address : Syment_Acc; + Id_Subprg_Addr : Syment_Acc; + Id_Conv : Syment_Acc; + Id_Sizeof : Syment_Acc; + Id_Alloca : Syment_Acc; + Id_Offsetof : Syment_Acc; + + Token_Number : Unsigned_64; + Token_Float : IEEE_Float_64; + Token_Ident : String (1 .. 256); + Token_Idlen : Natural; + Token_Hash : Hash_Type; + Token_Sym : Syment_Acc; + + -- The symbol table. + type Syment_Acc_Array is array (Hash_Type range <>) of Syment_Acc; + Hash_Max : constant Hash_Type := 511; + Symtable : Syment_Acc_Array (0 .. Hash_Max - 1) := (others => null); + + type Node_Kind is (Decl_Keyword, Decl_Type, Decl_Param, + Node_Function, Node_Procedure, Node_Object, Node_Field, + Node_Lit, + Type_Boolean, Type_Enum, + Type_Unsigned, Type_Signed, Type_Float, + Type_Array, Type_Subarray, + Type_Access, Type_Record, Type_Union); + subtype Nodes_Subprogram is Node_Kind range Node_Function .. Node_Procedure; + + type Node (<>); + type Node_Acc is access Node; + type Node (Kind : Node_Kind) is record + case Kind is + when Decl_Keyword => + -- Keyword. + -- A keyword is not a declaration since the identifier has only + -- one meaning (the keyword). + Keyword : Token_Type; + when Decl_Type + | Decl_Param + | Node_Function + | Node_Procedure + | Node_Object + | Node_Lit => + -- Declarations + -- All declarations but NODE_PROCEDURE have a type. + Decl_Dtype : Node_Acc; + Decl_Storage : O_Storage; + case Kind is + when Decl_Type => + -- Type declaration. + null; + when Decl_Param => + -- Parameter identifier. + Param_Name : Syment_Acc; + -- Parameter ortho node. + Param_Node : O_Dnode; + -- Next parameter of the parameters list. + Param_Next : Node_Acc; + when Node_Procedure + | Node_Function => + -- Subprogram symbol name. + Subprg_Name : Syment_Acc; + -- List of parameters. + Subprg_Params : Node_Acc; + -- Subprogram ortho node. + Subprg_Node : O_Dnode; + when Node_Object => + -- Name of the object (constant, variable). + Obj_Name : O_Ident; + -- Ortho node of the object. + Obj_Node : O_Dnode; + when Node_Lit => + -- Name of the literal. + Lit_Name : O_Ident; + -- Enum literal + Lit_Cnode : O_Cnode; + -- Next literal for the type. + Lit_Next : Node_Acc; + when others => + null; + end case; + when Node_Field => + -- Record field. + Field_Ident : Syment_Acc; + Field_Fnode : O_Fnode; + Field_Type : Node_Acc; + Field_Next : Node_Acc; + when Type_Signed + | Type_Unsigned + | Type_Float + | Type_Array + | Type_Subarray + | Type_Record + | Type_Union + | Type_Access + | Type_Boolean + | Type_Enum => + -- Ortho node type. + Type_Onode : O_Tnode; + case Kind is + when Type_Array => + Array_Index : Node_Acc; + Array_Element : Node_Acc; + when Type_Subarray => + Subarray_Base : Node_Acc; + --Subarray_Length : Natural; + when Type_Access => + Access_Dtype : Node_Acc; + when Type_Record + | Type_Union => + Record_Union_Fields : Node_Acc; + when Type_Enum + | Type_Boolean => + Enum_Lits : Node_Acc; + when Type_Float => + null; + when others => + null; + end case; + end case; + end record; + + type Scope_Type; + type Scope_Acc is access Scope_Type; + + type Name_Type is record + -- Current interpretation of the symbol. + Inter : Node_Acc; + -- Next declaration in the current scope. + Next : Syment_Acc; + -- Interpretation in a previous scope. + Up : Name_Acc; + -- Current scope. + Scope : Scope_Acc; + end record; + + type Scope_Type is record + -- Simply linked list of names. + Names : Syment_Acc; + -- Previous scope. + Prev : Scope_Acc; + end record; + + -- Return the current declaration for symbol SYM. + function Get_Decl (Sym : Syment_Acc) return Node_Acc; + pragma Inline (Get_Decl); + + procedure Scan_Char (C : Character) + is + R : Character; + begin + + if C = '\' then + R := Get_Char; + case R is + when 'n' => + R := LF; + when 'r' => + R := CR; + when ''' => + R := '''; + when '"' => -- " + R := '"'; -- " + when others => + Scan_Error ("bad character sequence \" & R); + end case; + else + R := C; + end if; + Token_Idlen := Token_Idlen + 1; + Token_Ident (Token_Idlen) := R; + end Scan_Char; + + function Get_Hash (Str : String) return Hash_Type + is + Res : Hash_Type; + begin + Res := 0; + for I in Str'Range loop + Res := Res * 31 + Character'Pos (Str (I)); + end loop; + return Res; + end Get_Hash; + + -- Previous token. + Tok_Previous : Token_Type; + + function Scan_Number (First_Char : Character) return Token_Type + is + function To_Digit (C : Character) return Integer is + begin + case C is + when '0' .. '9' => + return Character'Pos (C) - Character'Pos ('0'); + when 'A' .. 'F' => + return Character'Pos (C) - Character'Pos ('A') + 10; + when 'a' .. 'f' => + return Character'Pos (C) - Character'Pos ('a') + 10; + when others => + return -1; + end case; + end To_Digit; + + function Is_Digit (C : Character) return Boolean is + begin + case C is + when '0' .. '9' + | 'A' .. 'F' + | 'a' .. 'f' => + return True; + when others => + return False; + end case; + end Is_Digit; + + After_Point : Integer; + C : Character; + Exp : Integer; + Exp_Neg : Boolean; + Base : Unsigned_64; + begin + Token_Number := 0; + C := First_Char; + loop + Token_Number := Token_Number * 10 + Unsigned_64 (To_Digit (C)); + C := Get_Char; + exit when not Is_Digit (C); + end loop; + if C = '#' then + Base := Token_Number; + Token_Number := 0; + C := Get_Char; + loop + Token_Number := Token_Number * Base + Unsigned_64 (To_Digit (C)); + C := Get_Char; + exit when C = '#'; + end loop; + return Tok_Num; + end if; + if C = '.' then + -- A real number. + After_Point := 0; + Token_Float := IEEE_Float_64 (Token_Number); + loop + C := Get_Char; + exit when C not in '0' .. '9'; + Token_Float := Token_Float * 10.0 + IEEE_Float_64 (To_Digit (C)); + After_Point := After_Point + 1; + end loop; + if C = 'e' or C = 'E' then + Exp := 0; + C := Get_Char; + Exp_Neg := False; + if C = '-' then + Exp_Neg := True; + C := Get_Char; + elsif C = '+' then + C := Get_Char; + elsif not Is_Digit (C) then + Scan_Error ("digit expected"); + end if; + while Is_Digit (C) loop + Exp := Exp * 10 + To_Digit (C); + C := Get_Char; + end loop; + if Exp_Neg then + Exp := -Exp; + end if; + Exp := Exp - After_Point; + else + Exp := - After_Point; + end if; + Unget_Char; + Token_Float := Token_Float * 10.0 ** Exp; + if Token_Float > IEEE_Float_64'Last then + Token_Float := IEEE_Float_64'Last; + end if; + return Tok_Float_Num; + else + Unget_Char; + return Tok_Num; + end if; + end Scan_Number; + + procedure Scan_Comment + is + C : Character; + begin + Token_Idlen := 0; + loop + C := Get_Char; + exit when C = CR or C = LF; + Token_Idlen := Token_Idlen + 1; + Token_Ident (Token_Idlen) := C; + end loop; + Unget_Char; + end Scan_Comment; + + -- Get the next token. + function Get_Token return Token_Type + is + C : Character; + begin + loop + + C := Get_Char; + << Again >> null; + case C is + when NUL => + return Tok_Eof; + when ' ' | HT => + null; + when LF => + Lineno := Lineno + 1; + C := Get_Char; + if C /= CR then + goto Again; + end if; + when CR => + Lineno := Lineno + 1; + C := Get_Char; + if C /= LF then + goto Again; + end if; + when '+' => + return Tok_Plus; + when '-' => + C := Get_Char; + if C = '-' then + C := Get_Char; + if C = '#' then + return Tok_Line_Number; + elsif C = 'F' then + Scan_Comment; + return Tok_File_Name; + elsif C = ' ' then + Scan_Comment; + return Tok_Comment; + else + Scan_Error ("bad comment"); + end if; + else + Unget_Char; + return Tok_Minus; + end if; + when '/' => + C := Get_Char; + if C = '=' then + return Tok_Not_Equal; + else + Unget_Char; + return Tok_Div; + end if; + when '*' => + return Tok_Star; + when '#' => + return Tok_Sharp; + when '=' => + C := Get_Char; + if C = '>' then + return Tok_Arrow; + else + Unget_Char; + return Tok_Equal; + end if; + when '>' => + C := Get_Char; + if C = '=' then + return Tok_Greater_Eq; + else + Unget_Char; + return Tok_Greater; + end if; + when '(' => + return Tok_Left_Paren; + when ')' => + return Tok_Right_Paren; + when '{' => + return Tok_Left_Brace; + when '}' => + return Tok_Right_Brace; + when '[' => + return Tok_Left_Brack; + when ']' => + return Tok_Right_Brack; + when '<' => + C := Get_Char; + if C = '=' then + return Tok_Less_Eq; + else + Unget_Char; + return Tok_Less; + end if; + when ':' => + C := Get_Char; + if C = '=' then + return Tok_Assign; + else + Unget_Char; + return Tok_Colon; + end if; + when '.' => + C := Get_Char; + if C = '.' then + C := Get_Char; + if C = '.' then + return Tok_Elipsis; + else + Scan_Error ("'...' expected"); + end if; + else + Unget_Char; + return Tok_Dot; + end if; + when ';' => + return Tok_Semicolon; + when ',' => + return Tok_Comma; + when '@' => + return Tok_Arob; + when ''' => + if Tok_Previous = Tok_Ident then + return Tok_Tick; + else + Token_Number := Character'Pos (Get_Char); + C := Get_Char; + if C /= ''' then + Scan_Error ("ending single quote expected"); + end if; + return Tok_Num; + end if; + when '"' => -- " + -- Eat double quote. + C := Get_Char; + Token_Idlen := 0; + loop + Scan_Char (C); + C := Get_Char; + exit when C = '"'; -- " + end loop; + return Tok_String; + when '0' .. '9' => + return Scan_Number (C); + when 'a' .. 'z' + | 'A' .. 'Z' + | '_' => + Token_Idlen := 0; + Token_Hash := 0; + loop + Token_Idlen := Token_Idlen + 1; + Token_Ident (Token_Idlen) := C; + Token_Hash := Token_Hash * 31 + Character'Pos (C); + C := Get_Char; + exit when (C < 'A' or C > 'Z') + and (C < 'a' or C > 'z') + and (C < '0' or C > '9') + and (C /= '_'); + end loop; + Unget_Char; + declare + H : Hash_Type; + S : Syment_Acc; + N : Node_Acc; + begin + H := Token_Hash mod Hash_Max; + S := Symtable (H); + while S /= null loop + if S.Hash = Token_Hash + and then Is_Equal (S.Ident, + Token_Ident (1 .. Token_Idlen)) + then + -- This identifier is known. + Token_Sym := S; + + -- It may be a keyword. + if S.Name /= null then + N := Get_Decl (S); + if N.Kind = Decl_Keyword then + return N.Keyword; + end if; + end if; + + return Tok_Ident; + end if; + S := S.Next; + end loop; + Symtable (H) := new Syment_Type' + (Hash => Token_Hash, + Ident => Get_Identifier (Token_Ident (1 .. Token_Idlen)), + Next => Symtable (H), + Name => null); + Token_Sym := Symtable (H); + return Tok_Ident; + end; + when others => + Scan_Error ("Bad character:" + & Integer'Image (Character'Pos (C)) + & C); + return Tok_Eof; + end case; + end loop; + end Get_Token; + + -- The current token. + Tok : Token_Type; + + procedure Next_Token is + begin + Tok_Previous := Tok; + Tok := Get_Token; + end Next_Token; + + procedure Expect (T : Token_Type; Msg : String := "") is + begin + if Tok /= T then + if Msg'Length = 0 then + case T is + when Tok_Left_Brace => + Parse_Error ("'{' expected"); + when others => + if Tok = Tok_Ident then + Parse_Error + (Token_Type'Image (T) & " expected, found '" & + Token_Ident (1 .. Token_Idlen) & "'"); + else + Parse_Error (Token_Type'Image (T) & " expected, found " + & Token_Type'Image (Tok)); + end if; + end case; + else + Parse_Error (Msg); + end if; + end if; + end Expect; + + procedure Next_Expect (T : Token_Type; Msg : String := "") is + begin + Next_Token; + Expect (T, Msg); + end Next_Expect; + + -- Scopes and identifiers. + + + -- Current scope. + Scope : Scope_Acc := null; + + -- Add a declaration for symbol SYM in the current scope. + -- INTER defines the meaning of the declaration. + -- There must be at most one declaration for a symbol in the current scope, + -- i.e. a symbol cannot be redefined. + procedure Add_Decl (Sym : Syment_Acc; Inter : Node_Acc); + + -- Return TRUE iff SYM is already defined in the current scope. + function Is_Defined (Sym : Syment_Acc) return Boolean; + + -- Create new scope. + procedure Push_Scope; + + -- Close the current scope. Symbols defined in the scope regain their + -- previous declaration. + procedure Pop_Scope; + + + procedure Push_Scope + is + Nscope : Scope_Acc; + begin + Nscope := new Scope_Type'(Names => null, Prev => Scope); + Scope := Nscope; + end Push_Scope; + + procedure Pop_Scope + is + procedure Free is new Ada.Unchecked_Deallocation + (Object => Name_Type, Name => Name_Acc); + + procedure Free is new Ada.Unchecked_Deallocation + (Object => Scope_Type, Name => Scope_Acc); + + Sym : Syment_Acc; + N_Sym : Syment_Acc; + Name : Name_Acc; + Old_Scope : Scope_Acc; + begin + Sym := Scope.Names; + while Sym /= null loop + Name := Sym.Name; + -- Check. + if Name.Scope /= Scope then + raise Program_Error; + end if; + + -- Set the interpretation of this symbol. + Sym.Name := Name.Up; + + N_Sym := Name.Next; + + Free (Name); + Sym := N_Sym; + end loop; + + -- Free scope. + Old_Scope := Scope; + Scope := Scope.Prev; + Free (Old_Scope); + end Pop_Scope; + + function Is_Defined (Sym : Syment_Acc) return Boolean is + begin + if Sym.Name /= null + and then Sym.Name.Scope = Scope + then + return True; + else + return False; + end if; + end Is_Defined; + + function New_Symbol (Str : String) return Syment_Acc + is + Ent : Syment_Acc; + H : Hash_Type; + begin + Ent := new Syment_Type'(Hash => Get_Hash (Str), + Ident => Get_Identifier (Str), + Next => null, + Name => null); + H := Ent.Hash mod Hash_Max; + Ent.Next := Symtable (H); + Symtable (H) := Ent; + return Ent; + end New_Symbol; + + procedure Add_Keyword (Str : String; Token : Token_Type) + is + Ent : Syment_Acc; + begin + Ent := New_Symbol (Str); + if Ent.Name /= null + or else Scope /= null + then + -- Redefinition of a keyword. + raise Program_Error; + end if; + Ent.Name := new Name_Type'(Inter => new Node'(Kind => Decl_Keyword, + Keyword => Token), + Next => null, + Up => null, + Scope => null); + end Add_Keyword; + + procedure Add_Decl (Sym : Syment_Acc; Inter : Node_Acc) + is + Name : Name_Acc; + Prev : Node_Acc; + begin + Name := Sym.Name; + if Name /= null and then Name.Scope = Scope then + Prev := Name.Inter; + if Prev.Kind = Inter.Kind + and then Prev.Decl_Dtype = Inter.Decl_Dtype + and then Prev.Decl_Storage = O_Storage_External + and then Inter.Decl_Storage = O_Storage_Public + then + -- Redefinition + Name.Inter := Inter; + return; + end if; + Parse_Error ("redefinition of " & Get_String (Sym.Ident)); + end if; + Name := new Name_Type'(Inter => Inter, + Next => Scope.Names, + Up => Sym.Name, + Scope => Scope); + Sym.Name := Name; + Scope.Names := Sym; + end Add_Decl; + + function Get_Decl (Sym : Syment_Acc) return Node_Acc is + begin + if Sym.Name = null then + Parse_Error ("undefined identifier " & Get_String (Sym.Ident)); + else + return Sym.Name.Inter; + end if; + end Get_Decl; + + function Parse_Constant_Value (Atype : Node_Acc) return O_Cnode; + function Parse_Address (Prefix : Node_Acc) return O_Enode; + procedure Parse_Declaration; + procedure Parse_Compound_Statement; + + function Parse_Type return Node_Acc; + + procedure Parse_Fields (Aggr_Type : Node_Acc; + Constr : in out O_Element_List) + is + F_Type : Node_Acc; + F : Syment_Acc; + Last_Field : Node_Acc; + Field : Node_Acc; + begin + Last_Field := null; + loop + exit when Tok = Tok_End; + + if Tok /= Tok_Ident then + Parse_Error ("field name expected"); + end if; + F := Token_Sym; + Next_Expect (Tok_Colon, "':' expected"); + Next_Token; + F_Type := Parse_Type; + Field := new Node'(Kind => Node_Field, + Field_Ident => F, + Field_Fnode => O_Fnode_Null, + Field_Type => F_Type, + Field_Next => null); + case Aggr_Type.Kind is + when Type_Record => + New_Record_Field (Constr, Field.Field_Fnode, F.Ident, + F_Type.Type_Onode); + when Type_Union => + New_Union_Field (Constr, Field.Field_Fnode, F.Ident, + F_Type.Type_Onode); + when others => + raise Program_Error; + end case; + if Last_Field = null then + Aggr_Type.Record_Union_Fields := Field; + else + Last_Field.Field_Next := Field; + end if; + Last_Field := Field; + Expect (Tok_Semicolon, "';' expected"); + Next_Token; + end loop; + end Parse_Fields; + + procedure Parse_Record_Type (Def : Node_Acc) + is + Constr : O_Element_List; + begin + if Def.Type_Onode = O_Tnode_Null then + Start_Record_Type (Constr); + else + Start_Uncomplete_Record_Type (Def.Type_Onode, Constr); + end if; + Parse_Fields (Def, Constr); + Next_Expect (Tok_Record, "end record expected"); + Finish_Record_Type (Constr, Def.Type_Onode); + end Parse_Record_Type; + + procedure Parse_Union_Type (Def : Node_Acc) + is + Constr : O_Element_List; + begin + Start_Union_Type (Constr); + Parse_Fields (Def, Constr); + Next_Expect (Tok_Union, "end union expected"); + Finish_Union_Type (Constr, Def.Type_Onode); + end Parse_Union_Type; + + function Parse_Type return Node_Acc + is + Res : Node_Acc; + T : Token_Type; + begin + T := Tok; + case T is + when Tok_Unsigned + | Tok_Signed => + Next_Expect (Tok_Left_Paren, "'(' expected"); + Next_Expect (Tok_Num, "number expected"); + case T is + when Tok_Unsigned => + Res := new Node' + (Kind => Type_Unsigned, + Type_Onode => New_Unsigned_Type (Natural + (Token_Number))); + when Tok_Signed => + Res := new Node' + (Kind => Type_Signed, + Type_Onode => New_Signed_Type (Natural + (Token_Number))); + when others => + raise Program_Error; + end case; + Next_Expect (Tok_Right_Paren, "')' expected"); + when Tok_Float => + Res := new Node'(Kind => Type_Float, + Type_Onode => New_Float_Type); + when Tok_Array => + declare + Index_Node : Node_Acc; + El_Node : Node_Acc; + begin + Next_Expect (Tok_Left_Brack, "'[' expected"); + Next_Token; + Index_Node := Parse_Type; + Expect (Tok_Right_Brack, "']' expected"); + Next_Expect (Tok_Of, "'of' expected"); + Next_Token; + El_Node := Parse_Type; + Res := new Node' + (Kind => Type_Array, + Type_Onode => New_Array_Type (El_Node.Type_Onode, + Index_Node.Type_Onode), + Array_Index => Index_Node, + Array_Element => El_Node); + end; + return Res; + when Tok_Subarray => + declare + Base_Node : Node_Acc; + Res_Type : O_Tnode; + begin + Next_Token; + Base_Node := Parse_Type; + Expect (Tok_Left_Brack); + Next_Token; + Res_Type := New_Constrained_Array_Type + (Base_Node.Type_Onode, + Parse_Constant_Value (Base_Node.Array_Index)); + Expect (Tok_Right_Brack); + Next_Token; + Res := new Node' (Kind => Type_Subarray, + Type_Onode => Res_Type, + Subarray_Base => Base_Node); + return Res; + end; + when Tok_Ident => + declare + Inter : Node_Acc; + begin + Inter := Get_Decl (Token_Sym); + if Inter = null then + Parse_Error ("undefined type name symbol " + & Get_String (Token_Sym.Ident)); + end if; + if Inter.Kind /= Decl_Type then + Parse_Error ("type declarator expected"); + end if; + Res := Inter.Decl_Dtype; + end; + when Tok_Access => + declare + Dtype : Node_Acc; + begin + Next_Token; + if Tok = Tok_Semicolon then + Res := new Node' + (Kind => Type_Access, + Type_Onode => New_Access_Type (O_Tnode_Null), + Access_Dtype => null); + else + Dtype := Parse_Type; + Res := new Node' + (Kind => Type_Access, + Type_Onode => New_Access_Type (Dtype.Type_Onode), + Access_Dtype => Dtype); + end if; + return Res; + end; + when Tok_Record => + Next_Token; + if Tok = Tok_Semicolon then + -- Uncomplete record type. + Res := new Node'(Kind => Type_Record, + Type_Onode => O_Tnode_Null, + Record_Union_Fields => null); + New_Uncomplete_Record_Type (Res.Type_Onode); + return Res; + end if; + + Res := new Node'(Kind => Type_Record, + Type_Onode => O_Tnode_Null, + Record_Union_Fields => null); + Parse_Record_Type (Res); + when Tok_Union => + Next_Token; + Res := new Node'(Kind => Type_Union, + Type_Onode => O_Tnode_Null, + Record_Union_Fields => null); + Parse_Union_Type (Res); + + when Tok_Boolean => + declare + False_Lit, True_Lit : Node_Acc; + begin + Res := new Node'(Kind => Type_Boolean, + Type_Onode => O_Tnode_Null, + Enum_Lits => null); + Next_Expect (Tok_Left_Brace, "'{' expected"); + Next_Expect (Tok_Ident, "identifier expected"); + False_Lit := new Node'(Kind => Node_Lit, + Decl_Dtype => Res, + Decl_Storage => O_Storage_Public, + Lit_Name => Token_Sym.Ident, + Lit_Cnode => O_Cnode_Null, + Lit_Next => null); + Next_Expect (Tok_Comma, "',' expected"); + Next_Expect (Tok_Ident, "identifier expected"); + True_Lit := new Node'(Kind => Node_Lit, + Decl_Dtype => Res, + Decl_Storage => O_Storage_Public, + Lit_Name => Token_Sym.Ident, + Lit_Cnode => O_Cnode_Null, + Lit_Next => null); + Next_Expect (Tok_Right_Brace, "'}' expected"); + False_Lit.Lit_Next := True_Lit; + Res.Enum_Lits := False_Lit; + New_Boolean_Type (Res.Type_Onode, + False_Lit.Lit_Name, False_Lit.Lit_Cnode, + True_Lit.Lit_Name, True_Lit.Lit_Cnode); + end; + when Tok_Enum => + declare + List : O_Enum_List; + Lit : Node_Acc; + Last_Lit : Node_Acc; + begin + Res := new Node'(Kind => Type_Enum, + Type_Onode => O_Tnode_Null, + Enum_Lits => null); + Last_Lit := null; + Push_Scope; + Next_Expect (Tok_Left_Brace); + Next_Token; + -- FIXME: set a size to the enum. + Start_Enum_Type (List, 8); + loop + Expect (Tok_Ident); + Lit := new Node'(Kind => Node_Lit, + Decl_Dtype => Res, + Decl_Storage => O_Storage_Public, + Lit_Name => Token_Sym.Ident, + Lit_Cnode => O_Cnode_Null, + Lit_Next => null); + Add_Decl (Token_Sym, Lit); + New_Enum_Literal (List, Lit.Lit_Name, Lit.Lit_Cnode); + if Last_Lit = null then + Res.Enum_Lits := Lit; + else + Last_Lit.Lit_Next := Lit; + end if; + Last_Lit := Lit; + Next_Expect (Tok_Equal); + Next_Expect (Tok_Num); + Next_Token; + exit when Tok = Tok_Right_Brace; + Expect (Tok_Comma); + Next_Token; + end loop; + Finish_Enum_Type (List, Res.Type_Onode); + Pop_Scope; + end; + when others => + Parse_Error ("bad type " & Token_Type'Image (Tok)); + return null; + end case; + Next_Token; + return Res; + end Parse_Type; + + procedure Parse_Type_Completion (Decl : Node_Acc) + is + begin + case Tok is + when Tok_Record => + Next_Token; + Parse_Record_Type (Decl.Decl_Dtype); + Next_Token; + when Tok_Access => + Next_Token; + declare + Dtype : Node_Acc; + begin + Dtype := Parse_Type; + Decl.Decl_Dtype.Access_Dtype := Dtype; + Finish_Access_Type (Decl.Decl_Dtype.Type_Onode, + Dtype.Type_Onode); + end; + when others => + Parse_Error ("'access' or 'record' expected"); + end case; + end Parse_Type_Completion; + +-- procedure Parse_Declaration; + + function Parse_Unary_Expression (Atype : Node_Acc) return O_Enode; + function Parse_Expression (Expr_Type : Node_Acc) return O_Enode; + procedure Parse_Name (Prefix : Node_Acc; + Name : out O_Lnode; N_Type : out Node_Acc); + procedure Parse_Lvalue (N : in out O_Lnode; N_Type : in out Node_Acc); + + -- Expect: '(' + -- Let: next token. + procedure Parse_Association (Constr : in out O_Assoc_List; + Decl : Node_Acc); + + function Find_Field_By_Name (Aggr_Type : Node_Acc) return Node_Acc + is + Field : Node_Acc; + begin + Field := Aggr_Type.Record_Union_Fields; + while Field /= null loop + exit when Field.Field_Ident = Token_Sym; + Field := Field.Field_Next; + end loop; + if Field = null then + Parse_Error ("no such field name"); + end if; + return Field; + end Find_Field_By_Name; + + -- expect: offsetof id. + function Parse_Offsetof (Atype : Node_Acc) return O_Cnode + is + Rec_Type : Node_Acc; + Rec_Field : Node_Acc; + begin + Next_Expect (Tok_Left_Paren); + Next_Expect (Tok_Ident); + Rec_Type := Get_Decl (Token_Sym); + if Rec_Type.Kind /= Decl_Type + or else Rec_Type.Decl_Dtype.Kind /= Type_Record + then + Parse_Error ("type name expected"); + end if; + Next_Expect (Tok_Dot); + Next_Expect (Tok_Ident); + Rec_Field := Find_Field_By_Name (Rec_Type.Decl_Dtype); + Next_Expect (Tok_Right_Paren); + return New_Offsetof (Rec_Field.Field_Fnode, + Atype.Type_Onode); + end Parse_Offsetof; + + function Parse_Sizeof (Atype : Node_Acc) return O_Cnode + is + Res : O_Cnode; + begin + Next_Expect (Tok_Left_Paren); + Next_Token; + if Tok /= Tok_Ident then + Parse_Error ("type name expected"); + end if; + Res := New_Sizeof + (Get_Decl (Token_Sym).Decl_Dtype.Type_Onode, + Atype.Type_Onode); + Next_Expect (Tok_Right_Paren); + return Res; + end Parse_Sizeof; + + function Parse_Typed_Literal (Atype : Node_Acc) return O_Cnode + is + Res : O_Cnode; + begin + case Tok is + when Tok_Num => + case Atype.Kind is + when Type_Signed => + Res := New_Signed_Literal + (Atype.Type_Onode, Integer_64 (Token_Number)); + when Type_Unsigned => + Res := New_Unsigned_Literal + (Atype.Type_Onode, Token_Number); + when others => + Parse_Error ("bad type for integer literal"); + end case; + when Tok_Minus => + Next_Token; + case Tok is + when Tok_Num => + declare + V : Integer_64; + begin + if Token_Number = Unsigned_64 (Integer_64'Last) + 1 then + V := Integer_64'First; + else + V := -Integer_64 (Token_Number); + end if; + Res := New_Signed_Literal (Atype.Type_Onode, V); + end; + when Tok_Float_Num => + Res := New_Float_Literal (Atype.Type_Onode, -Token_Float); + when others => + Parse_Error ("bad token after '-'"); + end case; + when Tok_Float_Num => + Res := New_Float_Literal (Atype.Type_Onode, Token_Float); + when Tok_Ident => + declare + N : Node_Acc; + begin + -- Note: we don't use get_decl, since the name can be a literal + -- name, which is not directly visible. + if Token_Sym.Name /= null + and then Token_Sym.Name.Inter.Kind = Decl_Type + then + -- A typed expression. + N := Token_Sym.Name.Inter.Decl_Dtype; + if Atype /= null and then N /= Atype then + Parse_Error ("type mismatch"); + end if; + Next_Expect (Tok_Tick); + Next_Token; + if Tok = Tok_Left_Brack then + Next_Token; + Res := Parse_Typed_Literal (N); + Expect (Tok_Right_Brack); + elsif Tok = Tok_Ident then + if Token_Sym = Id_Offsetof then + Res := Parse_Offsetof (N); + elsif Token_Sym = Id_Sizeof then + Res := Parse_Sizeof (N); + elsif Token_Sym = Id_Conv then + Next_Expect (Tok_Left_Paren); + Next_Token; + Res := Parse_Typed_Literal (N); + Expect (Tok_Right_Paren); + else + Parse_Error ("offsetof or sizeof attributes expected"); + end if; + else + Parse_Error ("'[' or attribute expected"); + end if; + else + if Atype.Kind /= Type_Enum + and then Atype.Kind /= Type_Boolean + then + Parse_Error ("name allowed only for enumeration"); + end if; + N := Atype.Enum_Lits; + while N /= null loop + if Is_Equal (N.Lit_Name, Token_Sym.Ident) then + Res := N.Lit_Cnode; + exit; + end if; + N := N.Lit_Next; + end loop; + if N = null then + Parse_Error ("no matching literal"); + return O_Cnode_Null; + end if; + end if; + end; + when Tok_Null => + Res := New_Null_Access (Atype.Type_Onode); + when others => + Parse_Error ("bad primary expression: " & Token_Type'Image (Tok)); + return O_Cnode_Null; + end case; + Next_Token; + return Res; + end Parse_Typed_Literal; + + -- expect: next token + function Parse_Named_Expression + (Atype : Node_Acc; Name : Node_Acc; Stop_At_All : Boolean) + return O_Enode + is + Res : O_Enode; + R_Type : Node_Acc; + begin + if Tok = Tok_Tick then + Next_Token; + if Tok = Tok_Left_Brack then + -- Typed literal. + Next_Token; + Res := New_Lit (Parse_Typed_Literal (Name.Decl_Dtype)); + Expect (Tok_Right_Brack); + Next_Token; + return Res; + elsif Tok = Tok_Left_Paren then + -- Typed expression. + Next_Token; + Res := Parse_Expression (Name.Decl_Dtype); + Expect (Tok_Right_Paren); + Next_Token; + return Res; + elsif Tok = Tok_Ident then + -- Attribute. + if Token_Sym = Id_Conv then + Next_Expect (Tok_Left_Paren); + Next_Token; + Res := Parse_Expression (null); + Expect (Tok_Right_Paren); + Next_Token; + R_Type := Name.Decl_Dtype; + Res := New_Convert_Ov (Res, R_Type.Type_Onode); + -- Fall-through. + elsif Token_Sym = Id_Address + or Token_Sym = Id_Unchecked_Address + or Token_Sym = Id_Subprg_Addr + then + R_Type := Name.Decl_Dtype; + Res := Parse_Address (Name); + -- Fall-through. + elsif Token_Sym = Id_Sizeof then + Res := New_Lit (Parse_Sizeof (Name.Decl_Dtype)); + Next_Token; + return Res; + elsif Token_Sym = Id_Alloca then + Next_Expect (Tok_Left_Paren); + Next_Token; + Res := New_Alloca + (Name.Decl_Dtype.Type_Onode, + Parse_Expression (null)); + Expect (Tok_Right_Paren); + Next_Token; + return Res; + elsif Token_Sym = Id_Offsetof then + Res := New_Lit (Parse_Offsetof (Atype)); + Next_Token; + return Res; + else + Parse_Error ("unknown attribute name"); + end if; + -- Fall-through. + else + Parse_Error ("typed expression expected"); + end if; + elsif Tok = Tok_Left_Paren then + if Name.Kind /= Node_Function then + Parse_Error ("function name expected"); + end if; + declare + Constr : O_Assoc_List; + begin + Parse_Association (Constr, Name); + Res := New_Function_Call (Constr); + R_Type := Name.Decl_Dtype; + -- Fall-through. + end; + elsif Name.Kind = Node_Object + or else Name.Kind = Decl_Param + then + -- Name. + declare + Lval : O_Lnode; + L_Type : Node_Acc; + begin + Parse_Name (Name, Lval, L_Type); + return New_Value (Lval); + end; + else + Parse_Error ("bad ident expression: " + & Token_Type'Image (Tok)); + end if; + + -- Continue. + -- R_TYPE and RES must be set. + if Tok = Tok_Dot then + if Stop_At_All then + return Res; + end if; + Next_Token; + if Tok = Tok_All then + if R_Type.Kind /= Type_Access then + Parse_Error ("type of prefix is not an access"); + end if; + declare + N : O_Lnode; + begin + Next_Token; + N := New_Access_Element (Res); + R_Type := R_Type.Access_Dtype; + Parse_Lvalue (N, R_Type); + Res := New_Value (N); + end; + return Res; + else + Parse_Error ("'.all' expected"); + end if; + else + return Res; + end if; + end Parse_Named_Expression; + + function Parse_Primary_Expression (Atype : Node_Acc) return O_Enode + is + Res : O_Enode; + begin + case Tok is + when Tok_Num + | Tok_Float_Num => + return New_Lit (Parse_Typed_Literal (Atype)); + when Tok_Ident => + declare + N : Node_Acc; + begin + N := Get_Decl (Token_Sym); + Next_Token; + return Parse_Named_Expression (Atype, N, False); + end; + when Tok_Left_Paren => + Next_Token; + Res := Parse_Expression (Atype); + Expect (Tok_Right_Paren); + Next_Token; + return Res; +-- when Tok_Ident => +-- declare +-- Inter : Node_Acc; +-- begin +-- Inter := Token_Sym.Inter; +-- while Inter /= null loop +-- case Inter.Kind is +-- when Inter_Var +-- | Inter_Param => +-- Res := New_Value (Inter.Object_Node); +-- Next_Token; +-- return Res; +-- when Inter_Subprg => +-- return Parse_Function_Call (Inter); +-- when Inter_Keyword => +-- raise Program_Error; +-- end case; +-- Inter := Inter.Next; +-- end loop; +-- Parse_Error ("undefined name " & Get_String (Token_Sym.Ident)); +-- return O_Enode_Null; +-- end; + when others => + Parse_Error ("bad primary expression: " & Token_Type'Image (Tok)); + return O_Enode_Null; + end case; + end Parse_Primary_Expression; + + function Parse_Unary_Expression (Atype : Node_Acc) return O_Enode + is + Operand : O_Enode; + begin + case Tok is + when Tok_Minus => + Next_Token; + case Tok is +-- when Tok_Float_Num => +-- Operand := New_Float_Literal (Atype.Type_Onode, +-- -Token_Float); +-- Next_Token; +-- return Operand; +-- when Tok_Num => +-- Operand := New_Signed_Literal (Atype.Type_Onode, +-- -Integer_64 (Token_Number)); +-- Next_Token; +-- return Operand; + when others => + Operand := Parse_Primary_Expression (Atype); + return New_Monadic_Op (ON_Neg_Ov, Operand); + end case; + when Tok_Not => + Next_Token; + Operand := Parse_Unary_Expression (Atype); + return New_Monadic_Op (ON_Not, Operand); + when Tok_Abs => + Next_Token; + Operand := Parse_Unary_Expression (Atype); + return New_Monadic_Op (ON_Abs_Ov, Operand); + when others => + return Parse_Primary_Expression (Atype); + end case; + end Parse_Unary_Expression; + + function Check_Sharp (Op_Ov : ON_Op_Kind) return ON_Op_Kind is + begin + Next_Expect (Tok_Sharp); + Next_Token; + return Op_Ov; + end Check_Sharp; + + function Parse_Expression (Expr_Type : Node_Acc) return O_Enode + is + L : O_Enode; + R : O_Enode; + Op : ON_Op_Kind; + begin + L := Parse_Unary_Expression (Expr_Type); + case Tok is + when Tok_Div => + Op := Check_Sharp (ON_Div_Ov); + when Tok_Plus => + Op := Check_Sharp (ON_Add_Ov); + when Tok_Minus => + Op := Check_Sharp (ON_Sub_Ov); + when Tok_Star => + Op := Check_Sharp (ON_Mul_Ov); + when Tok_Mod => + Op := Check_Sharp (ON_Mod_Ov); + when Tok_Rem => + Op := Check_Sharp (ON_Rem_Ov); + + when Tok_Equal => + Op := ON_Eq; + when Tok_Not_Equal => + Op := ON_Neq; + when Tok_Greater => + Op := ON_Gt; + when Tok_Greater_Eq => + Op := ON_Ge; + when Tok_Less => + Op := ON_Lt; + when Tok_Less_Eq => + Op := ON_Le; + + when Tok_Or => + Op := ON_Or; + Next_Token; + when Tok_And => + Op := ON_And; + Next_Token; + when Tok_Xor => + Op := ON_Xor; + Next_Token; + + when others => + return L; + end case; + if Op in ON_Compare_Op_Kind then + Next_Token; + end if; + + R := Parse_Unary_Expression (Expr_Type); + case Op is + when ON_Dyadic_Op_Kind => + return New_Dyadic_Op (Op, L, R); + when ON_Compare_Op_Kind => + return New_Compare_Op (Op, L, R, Expr_Type.Type_Onode); + when others => + raise Program_Error; + end case; + end Parse_Expression; + + -- Expect and leave: next token + procedure Parse_Lvalue (N : in out O_Lnode; N_Type : in out Node_Acc) + is + begin + loop + case Tok is + when Tok_Dot => + Next_Token; + if Tok = Tok_All then + if N_Type.Kind /= Type_Access then + Parse_Error ("type of prefix is not an access"); + end if; + N := New_Access_Element (New_Value (N)); + N_Type := N_Type.Access_Dtype; + Next_Token; + elsif Tok = Tok_Ident then + if N_Type.Kind /= Type_Record and N_Type.Kind /= Type_Union + then + Parse_Error + ("type of prefix is neither a record nor an union"); + end if; + declare + Field : Node_Acc; + begin + Field := Find_Field_By_Name (N_Type); + N := New_Selected_Element (N, Field.Field_Fnode); + N_Type := Field.Field_Type; + Next_Token; + end; + else + Parse_Error + ("'.' must be followed by 'all' or a field name"); + end if; + when Tok_Left_Brack => + declare + V : O_Enode; + Bt : Node_Acc; + begin + Next_Token; + if N_Type.Kind = Type_Subarray then + Bt := N_Type.Subarray_Base; + else + Bt := N_Type; + end if; + if Bt.Kind /= Type_Array then + Parse_Error ("type of prefix is not an array"); + end if; + V := Parse_Expression (Bt.Array_Index); + if Tok = Tok_Elipsis then + N := New_Slice (N, Bt.Type_Onode, V); + Next_Token; + else + N := New_Indexed_Element (N, V); + N_Type := Bt.Array_Element; + end if; + Expect (Tok_Right_Brack); + Next_Token; + end; + when others => + return; + end case; + end loop; + end Parse_Lvalue; + + procedure Parse_Name (Prefix : Node_Acc; + Name : out O_Lnode; N_Type : out Node_Acc) + is + begin + case Prefix.Kind is + when Decl_Param => + Name := New_Obj (Prefix.Param_Node); + N_Type := Prefix.Decl_Dtype; + when Node_Object => + Name := New_Obj (Prefix.Obj_Node); + N_Type := Prefix.Decl_Dtype; + when Decl_Type => + declare + Val : O_Enode; + begin + Val := Parse_Named_Expression (null, Prefix, True); + N_Type := Prefix.Decl_Dtype; + if Tok = Tok_Dot then + Next_Token; + if Tok = Tok_All then + if N_Type.Kind /= Type_Access then + Parse_Error ("type of prefix is not an access"); + end if; + Name := New_Access_Element (Val); + N_Type := N_Type.Access_Dtype; + Next_Token; + else + Parse_Error ("'.all' expected"); + end if; + else + Parse_Error ("name expected"); + end if; + end; + when others => + Parse_Error ("invalid name"); + end case; + Parse_Lvalue (Name, N_Type); + end Parse_Name; + + -- Expect: '(' + -- Let: next token. + procedure Parse_Association (Constr : in out O_Assoc_List; Decl : Node_Acc) + is + Param : Node_Acc; + begin + Start_Association (Constr, Decl.Subprg_Node); + if Tok /= Tok_Left_Paren then + Parse_Error ("'(' expected for a subprogram call"); + end if; + Next_Token; + Param := Decl.Subprg_Params; + while Tok /= Tok_Right_Paren loop + if Param = null then + Parse_Error ("too many parameters"); + end if; + New_Association (Constr, Parse_Expression (Param.Decl_Dtype)); + Param := Param.Param_Next; + exit when Tok /= Tok_Comma; + Next_Token; + end loop; + if Param /= null then + Parse_Error ("missing parameters"); + end if; + if Tok /= Tok_Right_Paren then + Parse_Error ("')' expected to finish a subprogram call, found " + & Token_Type'Image (Tok)); + end if; + Next_Token; + end Parse_Association; + + type Loop_Info; + type Loop_Info_Acc is access Loop_Info; + type Loop_Info is record + Num : Natural; + Blk : O_Snode; + Prev : Loop_Info_Acc; + end record; + procedure Free is new Ada.Unchecked_Deallocation + (Name => Loop_Info_Acc, Object => Loop_Info); + + Loop_Stack : Loop_Info_Acc := null; + + function Find_Loop (N : Natural) return Loop_Info_Acc + is + Res : Loop_Info_Acc; + begin + Res := Loop_Stack; + while Res /= null loop + if Res.Num = N then + return Res; + end if; + Res := Res.Prev; + end loop; + return null; + end Find_Loop; + + Current_Subprg : Node_Acc := null; + + -- Expect : next token + -- Let: next token + procedure Parse_Statement is + begin + if Flag_Renumber then + New_Debug_Line_Stmt (Lineno); + end if; + + case Tok is + when Tok_Comment => + Next_Token; + + when Tok_Declare => + Start_Declare_Stmt; + Parse_Compound_Statement; + Expect (Tok_Semicolon); + Next_Token; + Finish_Declare_Stmt; + + when Tok_Line_Number => + Next_Expect (Tok_Num); + if Flag_Renumber = False then + New_Debug_Line_Stmt (Natural (Token_Number)); + end if; + Next_Token; + + when Tok_If => + declare + If_Blk : O_If_Block; + begin + Next_Token; + Start_If_Stmt (If_Blk, Parse_Expression (null)); + Expect (Tok_Then); + Next_Token; + loop + exit when Tok = Tok_Else or Tok = Tok_End; + pragma Warnings (Off); + Parse_Statement; + pragma Warnings (On); + end loop; + if Tok = Tok_Else then + Next_Token; + New_Else_Stmt (If_Blk); + loop + exit when Tok = Tok_End; + pragma Warnings (Off); + Parse_Statement; + pragma Warnings (On); + end loop; + end if; + Finish_If_Stmt (If_Blk); + Expect (Tok_End); + Next_Expect (Tok_If); + Next_Expect (Tok_Semicolon); + Next_Token; + end; + + when Tok_Loop => + declare + Info : Loop_Info_Acc; + Num : Natural; + begin + Next_Expect (Tok_Num); + Num := Natural (Token_Number); + if Find_Loop (Num) /= null then + Parse_Error ("loop label already defined"); + end if; + Info := new Loop_Info; + Info.Num := Num; + Info.Prev := Loop_Stack; + Loop_Stack := Info; + Start_Loop_Stmt (Info.Blk); + Next_Expect (Tok_Colon); + Next_Token; + while Tok /= Tok_End loop + pragma Warnings (Off); + Parse_Statement; + pragma Warnings (On); + end loop; + Finish_Loop_Stmt (Info.Blk); + Next_Expect (Tok_Loop); + Next_Expect (Tok_Semicolon); + Loop_Stack := Info.Prev; + Free (Info); + Next_Token; + end; + + when Tok_Exit + | Tok_Next => + declare + Label : Loop_Info_Acc; + Etok : Token_Type; + begin + Etok := Tok; + Next_Expect (Tok_Loop); + Next_Expect (Tok_Num); + Label := Find_Loop (Natural (Token_Number)); + if Label = null then + Parse_Error ("no such loop"); + end if; + if Etok = Tok_Exit then + New_Exit_Stmt (Label.Blk); + else + New_Next_Stmt (Label.Blk); + end if; + Next_Expect (Tok_Semicolon); + Next_Token; + end; + + when Tok_Return => + Next_Token; + if Tok /= Tok_Semicolon then + New_Return_Stmt (Parse_Expression (Current_Subprg.Decl_Dtype)); + if Tok /= Tok_Semicolon then + Parse_Error ("';' expected at end of return statement"); + end if; + else + New_Return_Stmt; + end if; + Next_Token; + + when Tok_Ident => + -- This is either a procedure call or an assignment. + declare + Inter : Node_Acc; + begin + Inter := Get_Decl (Token_Sym); + Next_Token; + if Tok = Tok_Left_Paren then + -- A procedure call. + declare + Constr : O_Assoc_List; + begin + Parse_Association (Constr, Inter); + New_Procedure_Call (Constr); + if Tok /= Tok_Semicolon then + Parse_Error ("';' expected after call"); + end if; + Next_Token; + return; + end; + else + -- An assignment. + declare + Name : O_Lnode; + N_Type : Node_Acc; + begin + Parse_Name (Inter, Name, N_Type); + if Tok /= Tok_Assign then + Parse_Error ("`:=' expected after a variable"); + end if; + Next_Token; + New_Assign_Stmt (Name, Parse_Expression (N_Type)); + if Tok /= Tok_Semicolon then + Parse_Error ("';' expected at end of assignment"); + end if; + Next_Token; + return; + end; + end if; + end; + + when Tok_Case => + declare + Case_Blk : O_Case_Block; + L : O_Cnode; + begin + Next_Token; + Start_Case_Stmt (Case_Blk, Parse_Expression (null)); + Expect (Tok_Is); + Next_Token; + loop + exit when Tok = Tok_End; + Expect (Tok_When); + Start_Choice (Case_Blk); + Next_Token; + if Tok = Tok_Default then + New_Default_Choice (Case_Blk); + Next_Token; + else + L := Parse_Typed_Literal (null); + if Tok = Tok_Elipsis then + Next_Token; + New_Range_Choice + (Case_Blk, L, Parse_Typed_Literal (null)); + else + New_Expr_Choice (Case_Blk, L); + end if; + end if; + Finish_Choice (Case_Blk); + Expect (Tok_Arrow); + Next_Token; + loop + exit when Tok = Tok_End or Tok = Tok_When; + pragma Warnings (Off); + Parse_Statement; + pragma Warnings (On); + end loop; + end loop; + Finish_Case_Stmt (Case_Blk); + Expect (Tok_End); + Next_Expect (Tok_Case); + Next_Expect (Tok_Semicolon); + Next_Token; + end; + when others => + Parse_Error ("bad statement: " & Token_Type'Image (Tok)); + end case; + end Parse_Statement; + + procedure Parse_Compound_Statement is + begin + if Tok /= Tok_Declare then + Parse_Error ("'declare' expected to start a statements block"); + end if; + Next_Token; + + Push_Scope; + + -- Parse declarations. + while Tok /= Tok_Begin loop + Parse_Declaration; + end loop; + Next_Token; + + -- Parse statements. + while Tok /= Tok_End loop + Parse_Statement; + end loop; + Next_Token; + + Pop_Scope; + end Parse_Compound_Statement; + + -- Parse (P1 : T1; P2: T2; ...) + function Parse_Parameter_List return Node_Acc + is + First, Last : Node_Acc; + P : Node_Acc; + begin + Expect (Tok_Left_Paren); + Next_Token; + if Tok = Tok_Right_Paren then + Next_Token; + return null; + end if; + First := null; + Last := null; + loop + Expect (Tok_Ident); + P := new Node'(Kind => Decl_Param, + Decl_Dtype => null, + Decl_Storage => O_Storage_Public, + Param_Node => O_Dnode_Null, + Param_Name => Token_Sym, + Param_Next => null); + -- Link + if Last = null then + First := P; + else + Last.Param_Next := P; + end if; + Last := P; + Next_Expect (Tok_Colon); + Next_Token; + P.Decl_Dtype := Parse_Type; + exit when Tok = Tok_Right_Paren; + Expect (Tok_Semicolon); + Next_Token; + end loop; + Next_Token; + return First; + end Parse_Parameter_List; + + procedure Create_Interface_List (Constr : in out O_Inter_List; + First_Inter : Node_Acc) + is + Inter : Node_Acc; + begin + Inter := First_Inter; + while Inter /= null loop + New_Interface_Decl (Constr, Inter.Param_Node, Inter.Param_Name.Ident, + Inter.Decl_Dtype.Type_Onode); + Inter := Inter.Param_Next; + end loop; + end Create_Interface_List; + + procedure Check_Parameter_List (List : Node_Acc) + is + Param : Node_Acc; + begin + Next_Expect (Tok_Left_Paren); + Next_Token; + Param := List; + while Tok /= Tok_Right_Paren loop + if Param = null then + Parse_Error ("subprogram redefined with more parameters"); + end if; + Expect (Tok_Ident); + if Token_Sym /= Param.Param_Name then + Parse_Error ("subprogram redefined with different parameter name"); + end if; + Next_Expect (Tok_Colon); + Next_Token; + if Parse_Type /= Param.Decl_Dtype then + Parse_Error ("subprogram redefined with different parameter type"); + end if; + Param := Param.Param_Next; + exit when Tok = Tok_Right_Paren; + Expect (Tok_Semicolon); + Next_Token; + end loop; + Expect (Tok_Right_Paren); + Next_Token; + if Param /= null then + Parse_Error ("subprogram redefined with less parameters"); + end if; + end Check_Parameter_List; + + procedure Parse_Subprogram_Body (Subprg : Node_Acc) + is + Param : Node_Acc; + Prev_Subprg : Node_Acc; + begin + Prev_Subprg := Current_Subprg; + Current_Subprg := Subprg; + + Start_Subprogram_Body (Subprg.Subprg_Node); + Push_Scope; + + -- Put parameters in the current scope. + Param := Subprg.Subprg_Params; + while Param /= null loop + Add_Decl (Param.Param_Name, Param); + Param := Param.Param_Next; + end loop; + + Parse_Compound_Statement; + + Pop_Scope; + Finish_Subprogram_Body; + + Current_Subprg := Prev_Subprg; + end Parse_Subprogram_Body; + + procedure Parse_Function_Definition (Storage : O_Storage) + is + Constr : O_Inter_List; + Sym : Syment_Acc; + N : Node_Acc; + begin + Expect (Tok_Function); + Next_Expect (Tok_Ident); + Sym := Token_Sym; + if Sym.Name /= null then + N := Get_Decl (Sym); + Check_Parameter_List (N.Subprg_Params); + Expect (Tok_Return); + Next_Expect (Tok_Ident); + Next_Token; + else + N := new Node'(Kind => Node_Function, + Decl_Dtype => null, + Decl_Storage => Storage, + Subprg_Node => O_Dnode_Null, + Subprg_Name => Sym, + Subprg_Params => null); + Next_Token; + N.Subprg_Params := Parse_Parameter_List; + Expect (Tok_Return); + Next_Token; + N.Decl_Dtype := Parse_Type; + + Start_Function_Decl (Constr, N.Subprg_Name.Ident, Storage, + N.Decl_Dtype.Type_Onode); + Create_Interface_List (Constr, N.Subprg_Params); + Finish_Subprogram_Decl (Constr, N.Subprg_Node); + + Add_Decl (Sym, N); + end if; + + if Tok = Tok_Declare then + Parse_Subprogram_Body (N); + end if; + end Parse_Function_Definition; + + procedure Parse_Procedure_Definition (Storage : O_Storage) + is + Constr : O_Inter_List; + Sym : Syment_Acc; + N : Node_Acc; + begin + Expect (Tok_Procedure); + Next_Expect (Tok_Ident); + Sym := Token_Sym; + if Sym.Name /= null then + N := Get_Decl (Sym); + Check_Parameter_List (N.Subprg_Params); + else + N := new Node'(Kind => Node_Procedure, + Decl_Dtype => null, + Decl_Storage => Storage, + Subprg_Node => O_Dnode_Null, + Subprg_Name => Sym, + Subprg_Params => null); + Next_Token; + N.Subprg_Params := Parse_Parameter_List; + + Start_Procedure_Decl (Constr, N.Subprg_Name.Ident, Storage); + Create_Interface_List (Constr, N.Subprg_Params); + Finish_Subprogram_Decl (Constr, N.Subprg_Node); + + Add_Decl (Sym, N); + end if; + + if Tok = Tok_Declare then + Parse_Subprogram_Body (N); + end if; + end Parse_Procedure_Definition; + + function Parse_Address (Prefix : Node_Acc) return O_Enode + is + Pfx : Node_Acc; + N : O_Lnode; + N_Type : Node_Acc; + Res : O_Enode; + Attr : Syment_Acc; + T : O_Tnode; + begin + Attr := Token_Sym; + Next_Expect (Tok_Left_Paren); + Next_Expect (Tok_Ident); + Pfx := Get_Decl (Token_Sym); + T := Prefix.Decl_Dtype.Type_Onode; + if Attr = Id_Subprg_Addr then + Expect (Tok_Ident); + Pfx := Get_Decl (Token_Sym); + if Pfx.Kind not in Nodes_Subprogram then + Parse_Error ("subprogram identifier expected"); + end if; + Res := New_Lit (New_Subprogram_Address (Pfx.Subprg_Node, T)); + Next_Token; + else + Next_Token; + Parse_Name (Pfx, N, N_Type); + if Attr = Id_Address then + Res := New_Address (N, T); + elsif Attr = Id_Unchecked_Address then + Res := New_Unchecked_Address (N, T); + else + Parse_Error ("address attribute expected"); + end if; + end if; + Expect (Tok_Right_Paren); + Next_Token; + return Res; + end Parse_Address; + + function Parse_Constant_Address (Prefix : Node_Acc) return O_Cnode + is + Pfx : Node_Acc; + Res : O_Cnode; + Attr : Syment_Acc; + T : O_Tnode; + begin + Attr := Token_Sym; + Next_Expect (Tok_Left_Paren); + Next_Expect (Tok_Ident); + Pfx := Get_Decl (Token_Sym); + T := Prefix.Decl_Dtype.Type_Onode; + if Attr = Id_Subprg_Addr then + Expect (Tok_Ident); + Pfx := Get_Decl (Token_Sym); + if Pfx.Kind not in Nodes_Subprogram then + Parse_Error ("subprogram identifier expected"); + end if; + Res := New_Subprogram_Address (Pfx.Subprg_Node, T); + Next_Token; + else + Next_Token; + if Attr = Id_Address then + Res := New_Global_Address (Pfx.Obj_Node, T); + elsif Attr = Id_Unchecked_Address then + Res := New_Global_Unchecked_Address (Pfx.Obj_Node, T); + else + Parse_Error ("address attribute expected"); + end if; + end if; + Expect (Tok_Right_Paren); + Next_Token; + return Res; + end Parse_Constant_Address; + + function Parse_Constant_Value (Atype : Node_Acc) return O_Cnode + is + Res : O_Cnode; + begin + case Atype.Kind is + when Type_Subarray => + declare + Constr : O_Array_Aggr_List; + El : Node_Acc; + begin + Expect (Tok_Left_Brace); + Next_Token; + Start_Array_Aggr (Constr, Atype.Type_Onode); + El := Atype.Subarray_Base.Array_Element; + for I in Natural loop + exit when Tok = Tok_Right_Brace; + if I /= 0 then + Expect (Tok_Comma); + Next_Token; + end if; + New_Array_Aggr_El (Constr, Parse_Constant_Value (El)); + end loop; + Finish_Array_Aggr (Constr, Res); + Next_Token; + return Res; + end; + when Type_Unsigned + | Type_Signed + | Type_Enum + | Type_Float + | Type_Boolean => + --return Parse_Primary_Expression (Atype); + return Parse_Typed_Literal (Atype); + when Type_Record => + declare + Constr : O_Record_Aggr_List; + Field : Node_Acc; + begin + Expect (Tok_Left_Brace); + Next_Token; + Start_Record_Aggr (Constr, Atype.Type_Onode); + Field := Atype.Record_Union_Fields; + while Field /= null loop + Expect (Tok_Dot); + Next_Expect (Tok_Ident); + if Token_Sym /= Field.Field_Ident then + Parse_Error ("bad field name"); + end if; + Next_Expect (Tok_Equal); + Next_Token; + New_Record_Aggr_El + (Constr, Parse_Constant_Value (Field.Field_Type)); + Field := Field.Field_Next; + if Field /= null then + Expect (Tok_Comma); + Next_Token; + end if; + end loop; + Finish_Record_Aggr (Constr, Res); + Expect (Tok_Right_Brace); + Next_Token; + return Res; + end; + when Type_Union => + declare + Field : Node_Acc; + begin + Expect (Tok_Left_Brace); + Next_Token; + Expect (Tok_Dot); + Next_Expect (Tok_Ident); + Field := Find_Field_By_Name (Atype); + Next_Expect (Tok_Equal); + Next_Token; + Res := New_Union_Aggr + (Atype.Type_Onode, Field.Field_Fnode, + Parse_Constant_Value (Field.Field_Type)); + Expect (Tok_Right_Brace); + Next_Token; + return Res; + end; + when Type_Access => + -- The only way to initialize an access is either NULL + -- or 'Address. + if Tok = Tok_Null then + Res := New_Null_Access (Atype.Type_Onode); + Next_Token; + return Res; + end if; + + if Tok /= Tok_Ident then + Parse_Error ("identifier expected for access literal"); + end if; + + declare + T : Node_Acc; + begin + T := Get_Decl (Token_Sym); + Next_Expect (Tok_Tick); + Next_Token; + if Tok = Tok_Left_Brack then + if T.Kind /= Decl_Type + or else T.Decl_Dtype.Kind /= Type_Access + then + Parse_Error ("name is not an access type name"); + end if; + Next_Expect (Tok_Null); + Next_Expect (Tok_Right_Brack); + Next_Token; + return New_Null_Access (Atype.Type_Onode); + else + Expect (Tok_Ident); + return Parse_Constant_Address (T); + end if; + end; + when others => + raise Program_Error; + end case; + end Parse_Constant_Value; + + procedure Parse_Constant_Declaration (Storage : O_Storage) + is + N : Node_Acc; + Sym : Syment_Acc; + --Val : O_Cnode; + begin + Expect (Tok_Constant); + Next_Expect (Tok_Ident); + Sym := Token_Sym; + N := new Node'(Kind => Node_Object, + Decl_Dtype => null, + Decl_Storage => Storage, + Obj_Name => Sym.Ident, + Obj_Node => O_Dnode_Null); + Next_Expect (Tok_Colon); + Next_Token; + N.Decl_Dtype := Parse_Type; + New_Const_Decl (N.Obj_Node, Sym.Ident, Storage, N.Decl_Dtype.Type_Onode); + Add_Decl (Sym, N); + +-- if Storage /= O_Storage_External then +-- Expect (Tok_Assign); +-- Next_Token; +-- Start_Const_Value (N.Obj_Node); +-- Val := Parse_Constant_Value (N.Decl_Dtype); +-- Finish_Const_Value (N.Obj_Node, Val); +-- end if; + end Parse_Constant_Declaration; + + procedure Parse_Constant_Value_Declaration + is + N : Node_Acc; + Val : O_Cnode; + begin + Next_Expect (Tok_Ident); + N := Get_Decl (Token_Sym); + if N.Kind /= Node_Object then + Parse_Error ("name of a constant expected"); + end if; + -- FIXME: should check storage, + -- should check the object is a constant, + -- should check the object has no value. + Next_Expect (Tok_Assign); + Next_Token; + Start_Const_Value (N.Obj_Node); + Val := Parse_Constant_Value (N.Decl_Dtype); + Finish_Const_Value (N.Obj_Node, Val); + end Parse_Constant_Value_Declaration; + + procedure Parse_Var_Declaration (Storage : O_Storage) + is + N : Node_Acc; + Sym : Syment_Acc; + begin + Expect (Tok_Var); + Next_Expect (Tok_Ident); + Sym := Token_Sym; + N := new Node'(Kind => Node_Object, + Decl_Dtype => null, + Decl_Storage => Storage, + Obj_Name => Sym.Ident, + Obj_Node => O_Dnode_Null); + Next_Expect (Tok_Colon); + Next_Token; + N.Decl_Dtype := Parse_Type; + New_Var_Decl (N.Obj_Node, Sym.Ident, Storage, N.Decl_Dtype.Type_Onode); + Add_Decl (Sym, N); + end Parse_Var_Declaration; + + procedure Parse_Stored_Decl (Storage : O_Storage) + is + begin + Next_Token; + if Tok = Tok_Function then + Parse_Function_Definition (Storage); + elsif Tok = Tok_Procedure then + Parse_Procedure_Definition (Storage); + elsif Tok = Tok_Constant then + Parse_Constant_Declaration (Storage); + elsif Tok = Tok_Var then + Parse_Var_Declaration (Storage); + else + Parse_Error ("function declaration expected"); + end if; + end Parse_Stored_Decl; + + procedure Parse_Declaration + is + Inter : Node_Acc; + S : Syment_Acc; + begin + if Flag_Renumber then + New_Debug_Line_Decl (Lineno); + end if; + + case Tok is + when Tok_Type => + Next_Token; + if Tok /= Tok_Ident then + Parse_Error ("identifier for type expected"); + end if; + S := Token_Sym; + Next_Expect (Tok_Is); + Next_Token; + if Is_Defined (S) then + Parse_Type_Completion (Get_Decl (S)); + else + Inter := new Node'(Kind => Decl_Type, + Decl_Storage => O_Storage_Public, + Decl_Dtype => Parse_Type); + Add_Decl (S, Inter); + New_Type_Decl (S.Ident, Inter.Decl_Dtype.Type_Onode); + end if; + when Tok_External => + Parse_Stored_Decl (O_Storage_External); + when Tok_Private => + Parse_Stored_Decl (O_Storage_Private); + when Tok_Public => + Parse_Stored_Decl (O_Storage_Public); + when Tok_Local => + Parse_Stored_Decl (O_Storage_Local); + when Tok_Constant => + Parse_Constant_Value_Declaration; + when Tok_Comment => + New_Debug_Comment_Decl (Token_Ident (1 .. Token_Idlen)); + Next_Token; + return; + when Tok_File_Name => + if Flag_Renumber = False then + New_Debug_Filename_Decl (Token_Ident (1 .. Token_Idlen)); + end if; + Next_Token; + return; + when others => + Parse_Error ("declaration expected"); + end case; + Expect (Tok_Semicolon); + Next_Token; + end Parse_Declaration; + +-- procedure Put (Str : String) +-- is +-- L : Integer; +-- begin +-- L := Write (Standout, Str'Address, Str'Length); +-- end Put; + + function Parse (Filename : String_Acc) return Boolean + is + begin + -- Initialize symbol table. + Add_Keyword ("type", Tok_Type); + Add_Keyword ("return", Tok_Return); + Add_Keyword ("if", Tok_If); + Add_Keyword ("then", Tok_Then); + Add_Keyword ("else", Tok_Else); + Add_Keyword ("loop", Tok_Loop); + Add_Keyword ("exit", Tok_Exit); + Add_Keyword ("next", Tok_Next); + Add_Keyword ("signed", Tok_Signed); + Add_Keyword ("unsigned", Tok_Unsigned); + Add_Keyword ("float", Tok_Float); + Add_Keyword ("is", Tok_Is); + Add_Keyword ("of", Tok_Of); + Add_Keyword ("all", Tok_All); + Add_Keyword ("not", Tok_Not); + Add_Keyword ("abs", Tok_Abs); + Add_Keyword ("or", Tok_Or); + Add_Keyword ("and", Tok_And); + Add_Keyword ("xor", Tok_Xor); + Add_Keyword ("mod", Tok_Mod); + Add_Keyword ("rem", Tok_Rem); + Add_Keyword ("array", Tok_Array); + Add_Keyword ("access", Tok_Access); + Add_Keyword ("record", Tok_Record); + Add_Keyword ("union", Tok_Union); + Add_Keyword ("end", Tok_End); + Add_Keyword ("boolean", Tok_Boolean); + Add_Keyword ("enum", Tok_Enum); + Add_Keyword ("external", Tok_External); + Add_Keyword ("private", Tok_Private); + Add_Keyword ("public", Tok_Public); + Add_Keyword ("local", Tok_Local); + Add_Keyword ("procedure", Tok_Procedure); + Add_Keyword ("function", Tok_Function); + Add_Keyword ("constant", Tok_Constant); + Add_Keyword ("var", Tok_Var); + Add_Keyword ("subarray", Tok_Subarray); + Add_Keyword ("declare", Tok_Declare); + Add_Keyword ("begin", Tok_Begin); + Add_Keyword ("end", Tok_End); + Add_Keyword ("null", Tok_Null); + Add_Keyword ("case", Tok_Case); + Add_Keyword ("when", Tok_When); + Add_Keyword ("default", Tok_Default); + + Id_Address := New_Symbol ("address"); + Id_Unchecked_Address := New_Symbol ("unchecked_address"); + Id_Subprg_Addr := New_Symbol ("subprg_addr"); + Id_Conv := New_Symbol ("conv"); + Id_Sizeof := New_Symbol ("sizeof"); + Id_Alloca := New_Symbol ("alloca"); + Id_Offsetof := New_Symbol ("offsetof"); + + -- Initialize the scanner. + Buf (1) := NUL; + Pos := 1; + Lineno := 1; + if Filename = null then + Fd := Standin; + File_Name := new String'("*stdin*"); + else + declare + Name : String (1 .. Filename'Length + 1); + --("C:\cygwin\home\tgingold\src\ortho\x86\tests\olang\ex2.ol", + begin + Name (1 .. Filename'Length) := Filename.all; + Name (Name'Last) := NUL; + File_Name := Filename; + Fd := Open_Read (Name'Address, Text); + if Fd = Invalid_FD then + Puterr ("cannot open '" & Filename.all & '''); + Newline_Err; + return False; + end if; + end; + end if; + + New_Debug_Filename_Decl (File_Name.all); + + Push_Scope; + Next_Token; + while Tok /= Tok_Eof loop + Parse_Declaration; + end loop; + Pop_Scope; + + if Fd /= Standin then + Close (Fd); + end if; + return True; + exception + when E : others => + Puterr (Ada.Exceptions.Exception_Information (E)); + raise; + end Parse; +end Ortho_Front; -- cgit