-- 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;
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_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_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;
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;
begin
Next_Token;
Start_If_Stmt (If_Blk, Parse_Expression (null));
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 =>
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;
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);
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 ("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_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;