diff options
Diffstat (limited to 'ortho/oread')
| -rw-r--r-- | ortho/oread/Makefile | 43 | ||||
| -rw-r--r-- | ortho/oread/ortho_front.adb | 2677 |
2 files changed, 0 insertions, 2720 deletions
diff --git a/ortho/oread/Makefile b/ortho/oread/Makefile deleted file mode 100644 index f945351..0000000 --- a/ortho/oread/Makefile +++ /dev/null @@ -1,43 +0,0 @@ -# -*- Makefile -*- for the ortho-code compiler. -# Copyright (C) 2005 Tristan Gingold -# -# GHDL is free software; you can redistribute it and/or modify it under -# the terms of the GNU General Public License as published by the Free -# Software Foundation; either version 2, or (at your option) any later -# version. -# -# GHDL is distributed in the hope that it will be useful, but WITHOUT ANY -# WARRANTY; without even the implied warranty of MERCHANTABILITY or -# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -# for more details. -# -# You should have received a copy of the GNU General Public License -# along with GCC; see the file COPYING. If not, write to the Free -# Software Foundation, 59 Temple Place - Suite 330, Boston, MA -# 02111-1307, USA. -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-gcc oread-mcode *.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 deleted file mode 100644 index 84bbd1b..0000000 --- a/ortho/oread/ortho_front.adb +++ /dev/null @@ -1,2677 +0,0 @@ --- Ortho code compiler. --- Copyright (C) 2005 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -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" or Opt.all = "--ghdl-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; - pragma Unreferenced (L); - begin - L := Write (Standerr, Msg'Address, Msg'Length); - end Puterr; - - procedure Puterr (N : Natural) - is - Str : constant 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_Elsif, - 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_Alignof : 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; - function Parse_Constant_Address (Prefix : Node_Acc) return O_Cnode; - 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; - - procedure Parse_Expression (Expr_Type : Node_Acc; - Expr : out O_Enode; - Res_Type : out Node_Acc); - 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_Type.Decl_Dtype.Type_Onode, - 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_Alignof (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_Alignof - (Get_Decl (Token_Sym).Decl_Dtype.Type_Onode, - Atype.Type_Onode); - Next_Expect (Tok_Right_Paren); - return Res; - end Parse_Alignof; - - -- Parse a literal whose type is ATYPE. - 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 - Pfx : Node_Acc; - 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. - Pfx := Token_Sym.Name.Inter; - N := Pfx.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_Alignof then - Res := Parse_Alignof (N); - elsif Token_Sym = Id_Address - or Token_Sym = Id_Unchecked_Address - or Token_Sym = Id_Subprg_Addr - then - Res := Parse_Constant_Address (Pfx); - 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 - -- Parse an expression starting with NAME. - procedure Parse_Named_Expression - (Atype : Node_Acc; Name : Node_Acc; Stop_At_All : Boolean; - Res : out O_Enode; - Res_Type : out Node_Acc) - is - 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)); - Res_Type := Name.Decl_Dtype; - Expect (Tok_Right_Brack); - Next_Token; - elsif Tok = Tok_Left_Paren then - -- Typed expression (used for comparaison operators) - Next_Token; - Parse_Expression (Name.Decl_Dtype, Res, Res_Type); - Expect (Tok_Right_Paren); - Next_Token; - elsif Tok = Tok_Ident then - -- Attribute. - if Token_Sym = Id_Conv then - Next_Expect (Tok_Left_Paren); - Next_Token; - Parse_Expression (null, Res, Res_Type); - -- Discard Res_Type. - Expect (Tok_Right_Paren); - Next_Token; - Res_Type := Name.Decl_Dtype; - Res := New_Convert_Ov (Res, Res_Type.Type_Onode); - -- Fall-through. - elsif Token_Sym = Id_Address - or Token_Sym = Id_Unchecked_Address - or Token_Sym = Id_Subprg_Addr - then - Res_Type := Name.Decl_Dtype; - Res := Parse_Address (Name); - -- Fall-through. - elsif Token_Sym = Id_Sizeof then - Res_Type := Name.Decl_Dtype; - Res := New_Lit (Parse_Sizeof (Res_Type)); - Next_Token; - return; - elsif Token_Sym = Id_Alignof then - Res_Type := Name.Decl_Dtype; - Res := New_Lit (Parse_Alignof (Res_Type)); - Next_Token; - return; - elsif Token_Sym = Id_Alloca then - Next_Expect (Tok_Left_Paren); - Next_Token; - Parse_Expression (null, Res, Res_Type); - -- Discard Res_Type. - Res_Type := Name.Decl_Dtype; - Res := New_Alloca (Res_Type.Type_Onode, Res); - Expect (Tok_Right_Paren); - Next_Token; - return; - elsif Token_Sym = Id_Offsetof then - Res_Type := Atype; - Res := New_Lit (Parse_Offsetof (Res_Type)); - Next_Token; - return; - 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); - Res_Type := Name.Decl_Dtype; - -- Fall-through. - end; - elsif Name.Kind = Node_Object - or else Name.Kind = Decl_Param - then - -- Name. - declare - Lval : O_Lnode; - begin - Parse_Name (Name, Lval, Res_Type); - Res := 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; - end if; - Next_Token; - if Tok = Tok_All then - if Res_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); - Res_Type := Res_Type.Access_Dtype; - Parse_Lvalue (N, Res_Type); - Res := New_Value (N); - end; - return; - else - Parse_Error ("'.all' expected"); - end if; - end if; - end Parse_Named_Expression; - - procedure Parse_Primary_Expression (Atype : Node_Acc; - Res : out O_Enode; - Res_Type : out Node_Acc) - is - begin - case Tok is - when Tok_Num - | Tok_Float_Num => - if Atype = null then - Parse_Error ("numeric literal without type context"); - end if; - Res_Type := Atype; - Res := New_Lit (Parse_Typed_Literal (Atype)); - when Tok_Ident => - declare - N : Node_Acc; - begin - N := Get_Decl (Token_Sym); - Next_Token; - Parse_Named_Expression (Atype, N, False, Res, Res_Type); - end; - when Tok_Left_Paren => - Next_Token; - Parse_Expression (Atype, Res, Res_Type); - Expect (Tok_Right_Paren); - Next_Token; - when others => - Parse_Error ("bad primary expression: " & Token_Type'Image (Tok)); - end case; - end Parse_Primary_Expression; - - -- Parse '-' EXPR, 'not' EXPR, 'abs' EXPR or EXPR. - procedure Parse_Unary_Expression (Atype : Node_Acc; - Res : out O_Enode; - Res_Type : out Node_Acc) - is - begin - case Tok is - when Tok_Minus => - Next_Token; - Parse_Primary_Expression (Atype, Res, Res_Type); - Res := New_Monadic_Op (ON_Neg_Ov, Res); - when Tok_Not => - Next_Token; - Parse_Unary_Expression (Atype, Res, Res_Type); - Res := New_Monadic_Op (ON_Not, Res); - when Tok_Abs => - Next_Token; - Parse_Unary_Expression (Atype, Res, Res_Type); - Res := New_Monadic_Op (ON_Abs_Ov, Res); - when others => - Parse_Primary_Expression (Atype, Res, Res_Type); - 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; - - procedure Parse_Expression (Expr_Type : Node_Acc; - Expr : out O_Enode; - Res_Type : out Node_Acc) - is - Op_Type : Node_Acc; - L : O_Enode; - R : O_Enode; - Op : ON_Op_Kind; - begin - if Expr_Type = null or else Expr_Type.Kind = Type_Boolean then - -- The type of the expression isn't known, as this can be a - -- comparaison operator. - Op_Type := null; - else - Op_Type := Expr_Type; - end if; - Parse_Unary_Expression (Op_Type, L, Res_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 => - Expr := L; - return; - end case; - if Op in ON_Compare_Op_Kind then - Next_Token; - end if; - - Parse_Unary_Expression (Res_Type, R, Res_Type); - case Op is - when ON_Dyadic_Op_Kind => - Expr := New_Dyadic_Op (Op, L, R); - when ON_Compare_Op_Kind => - if Expr_Type = null then - Parse_Error ("comparaison operator requires a type"); - end if; - Expr := New_Compare_Op (Op, L, R, Expr_Type.Type_Onode); - Res_Type := Expr_Type; - 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; - Res_Type : 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; - Parse_Expression (Bt.Array_Index, V, Res_Type); - 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 - Parse_Named_Expression (null, Prefix, True, Val, N_Type); - if N_Type /= Prefix.Decl_Dtype then - Parse_Error ("type doesn't match"); - end if; - 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; - Expr : O_Enode; - Expr_Type : 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; - Parse_Expression (Param.Decl_Dtype, Expr, Expr_Type); - New_Association (Constr, Expr); - 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; - - procedure Parse_Statement; - - -- Expect : next token - -- Let: next token - procedure Parse_Statements is - begin - loop - exit when Tok = Tok_End; - exit when Tok = Tok_Else; - exit when Tok = Tok_When; - Parse_Statement; - end loop; - end Parse_Statements; - - -- 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; - Cond : O_Enode; - Cond_Type : Node_Acc; - begin - Next_Token; - Parse_Expression (null, Cond, Cond_Type); - Start_If_Stmt (If_Blk, Cond); - Expect (Tok_Then); - Next_Token; - Parse_Statements; - if Tok = Tok_Else then - Next_Token; - New_Else_Stmt (If_Blk); - Parse_Statements; - 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; - Parse_Statements; - 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 => - declare - Res : O_Enode; - Res_Type : Node_Acc; - begin - Next_Token; - if Tok /= Tok_Semicolon then - Parse_Expression (Current_Subprg.Decl_Dtype, Res, Res_Type); - New_Return_Stmt (Res); - if Tok /= Tok_Semicolon then - Parse_Error ("';' expected at end of return statement"); - end if; - else - New_Return_Stmt; - end if; - Next_Token; - end; - - 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; - Expr : O_Enode; - Expr_Type : Node_Acc; - 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; - Parse_Expression (N_Type, Expr, Expr_Type); - New_Assign_Stmt (Name, Expr); - 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; - Choice : O_Enode; - Choice_Type : Node_Acc; - begin - Next_Token; - Parse_Expression (null, Choice, Choice_Type); - Start_Case_Stmt (Case_Blk, Choice); - Expect (Tok_Is); - Next_Token; - loop - exit when Tok = Tok_End; - Expect (Tok_When); - Next_Token; - Start_Choice (Case_Blk); - loop - if Tok = Tok_Default then - New_Default_Choice (Case_Blk); - Next_Token; - else - L := Parse_Typed_Literal (Choice_Type); - if Tok = Tok_Elipsis then - Next_Token; - New_Range_Choice - (Case_Blk, L, Parse_Typed_Literal (Choice_Type)); - else - New_Expr_Choice (Case_Blk, L); - end if; - end if; - exit when Tok = Tok_Arrow; - Expect (Tok_Comma); - Next_Token; - end loop; - -- Skip '=>'. - Next_Token; - Finish_Choice (Case_Blk); - Parse_Statements; - 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. - Parse_Statements; - Expect (Tok_End); - 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); - 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 - | Type_Access => - --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 - if Tok = Tok_Dot then - Next_Expect (Tok_Ident); - if Token_Sym /= Field.Field_Ident then - Parse_Error ("bad field name"); - end if; - Next_Expect (Tok_Equal); - Next_Token; - end if; - 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 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 ("elsif", Tok_Elsif); - 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_Alignof := New_Symbol ("alignof"); - 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; |