|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - download
Length: 410338 (0x642e2)
Types: TextFile
Notes: R1k Text-file segment
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─ ⟦5a81ac88f⟧ »Space Info Vol 1«
└─⟦9f8806f61⟧
└─⟦this⟧
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- The primary authors of ayacc were David Taback and Deepak Tolani.
-- Enhancements were made by Ronald J. Schmalz.
--
-- Send requests for ayacc information to ayacc-info@ics.uci.edu
-- Send bug reports for ayacc to ayacc-bugs@ics.uci.edu
--
-- Redistribution and use in source and binary forms are permitted
-- provided that the above copyright notice and this paragraph are
-- duplicated in all such forms and that any documentation,
-- advertising materials, and other materials related to such
-- distribution and use acknowledge that the software was developed
-- by the University of California, Irvine. The name of the
-- University may not be used to endorse or promote products derived
-- from this software without specific prior written permission.
-- THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
-- IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
-- WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
-- Module : actions_file.ada
-- Component of : ayacc
-- Version : 1.2
-- Date : 11/21/86 12:27:44
-- SCCS File : disk21~/rschm/hasee/sccs/ayacc/sccs/sxactions_file.ada
-- $Header: actions_file.a,v 0.1 86/04/01 15:03:51 ada Exp $
-- $Log: actions_file.a,v $
-- Revision 0.1 86/04/01 15:03:51 ada
-- This version fixes some minor bugs with empty grammars
-- and $$ expansion. It also uses vads5.1b enhancements
-- such as pragma inline.
--
--
-- Revision 0.0 86/02/19 18:35:43 ada
--
-- These files comprise the initial version of Ayacc
-- designed and implemented by David Taback and Deepak Tolani.
-- Ayacc has been compiled and tested under the Verdix Ada compiler
-- version 4.06 on a vax 11/750 running Unix 4.2BSD.
--
with Text_IO; use Text_IO;
package Actions_File is
-- --
-- Standard file access routines for the file containing --
-- the procedure user_action which associates rules to the --
-- user executable code. --
-- --
type File_Mode is (Read_File, Write_File);
procedure Open(Mode: in File_Mode);
procedure Write(C: in Character);
procedure Write(S: in String);
procedure Writeln;
procedure Read_Line(S: out String; Last: out Natural);
procedure Close;
procedure Delete;
-- Initializes and finishes the decalarations for the --
-- procedure user_action. --
procedure Initialize;
procedure Finish;
function Is_End_of_File return Boolean;
end Actions_File;
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- The primary authors of ayacc were David Taback and Deepak Tolani.
-- Enhancements were made by Ronald J. Schmalz.
--
-- Send requests for ayacc information to ayacc-info@ics.uci.edu
-- Send bug reports for ayacc to ayacc-bugs@ics.uci.edu
--
-- Redistribution and use in source and binary forms are permitted
-- provided that the above copyright notice and this paragraph are
-- duplicated in all such forms and that any documentation,
-- advertising materials, and other materials related to such
-- distribution and use acknowledge that the software was developed
-- by the University of California, Irvine. The name of the
-- University may not be used to endorse or promote products derived
-- from this software without specific prior written permission.
-- THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
-- IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
-- WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
-- Module : actions_file_body.ada
-- Component of : ayacc
-- Version : 1.2
-- Date : 11/21/86 12:28:04
-- SCCS File : disk21~/rschm/hasee/sccs/ayacc/sccs/sxactions_file_body.ada
-- $Header: actions_file_body.a,v 0.1 86/04/01 15:29:59 ada Exp $
-- $Log: actions_file_body.a,v $
--Revision 0.1 86/04/01 15:29:59 ada
-- This version fixes some minor bugs with empty grammars
-- and $$ expansion. It also uses vads5.1b enhancements
-- such as pragma inline.
--
with File_Names;
use File_Names;
package body Actions_File is
SCCS_ID : constant String := "@(#) actions_file_body.ada, Version 1.2";
-- The maximum length of the text that an action can expand into.
Maximum_Action_Length : constant Count := 1000;
The_File : File_Type;
procedure Open(Mode: in File_Mode) is
begin
if Mode = Read_File then
Open(The_File, In_File, Get_Actions_File_Name);
else
Create(The_File, Out_File, Get_Actions_File_Name);
--RJS Set_Line_Length(The_File, To => Maximum_Action_Length);
end if;
end Open;
procedure Close is
begin
Close(The_File);
end Close;
procedure Delete is
begin
Delete(The_File);
end Delete;
procedure Read_Line(S: out String; Last: out Natural) is
begin
Get_Line(The_File, S, Last);
end;
procedure Write(S: in String) is
begin
Put(The_File, S);
end;
procedure Write(C: in Character) is
begin
Put(The_File, C);
end;
procedure Writeln is
begin
New_Line(The_File);
end;
function Is_End_of_File return Boolean is
begin
return End_of_File(The_File);
end Is_End_of_File;
procedure Initialize is
begin
Open(Write_File);
end Initialize;
procedure Finish is
begin
Close;
end Finish;
end Actions_File;
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- The primary authors of ayacc were David Taback and Deepak Tolani.
-- Enhancements were made by Ronald J. Schmalz.
--
-- Send requests for ayacc information to ayacc-info@ics.uci.edu
-- Send bug reports for ayacc to ayacc-bugs@ics.uci.edu
--
-- Redistribution and use in source and binary forms are permitted
-- provided that the above copyright notice and this paragraph are
-- duplicated in all such forms and that any documentation,
-- advertising materials, and other materials related to such
-- distribution and use acknowledge that the software was developed
-- by the University of California, Irvine. The name of the
-- University may not be used to endorse or promote products derived
-- from this software without specific prior written permission.
-- THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
-- IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
-- WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
--************************************************************************
-- ayacc
-- version 1.0
--
--***********************************************************************
--
-- Arcadia Project
-- Department of Information and Computer Science
-- University of California
-- Irvine, California 92717
--
--***************************************************************************
-- Module : ayacc.ada
-- Component of : ayacc
-- Version : 1.2
-- Date : 11/21/86 12:28:24
-- SCCS File : disk21~/rschm/hasee/sccs/ayacc/sccs/sxayacc.ada
-- $Header: ayacc.a,v 0.1 86/04/01 15:04:07 ada Exp $
-- $Log: ayacc.a,v $
-- Revision 0.1 86/04/01 15:04:07 ada
-- This version fixes some minor bugs with empty grammars
-- and $$ expansion. It also uses vads5.1b enhancements
-- such as pragma inline.
--
--
-- Revision 0.0 86/02/19 19:00:49 ada
--
-- These files comprise the initial version of Ayacc
-- designed and implemented by David Taback and Deepak Tolani.
-- Ayacc has been compiled and tested under the Verdix Ada compiler
-- version 4.06 on a vax 11/750 running Unix 4.2BSD.
--
with Source_File,
File_Names,
Options,
Parser,
Tokens_File,
Output_File,
Parse_Table,
Text_IO,
-- u_env, -- For getting the command line arguments
Symbol_Table, -- Used for statistics only
Rule_Table; -- Used for statistics only
procedure Ayacc is
Rcs_ID : constant String := "$Header: ayacc.a,v 0.1 86/04/01 15:04:07 ada Exp $";
copyright : constant string :=
"@(#) Copyright (c) 1990 Regents of the University of California.";
copyright2 : constant string :=
"All rights reserved.";
use Text_IO;
Illegal_Argument_List : exception;
procedure Initialize is separate;
procedure Print_Statistics is separate;
begin
Initialize;
Source_File.Open;
Tokens_File.Open;
Parser.Parse_Declarations;
Parser.Parse_Rules;
Parse_Table.Make_Parse_Table;
Output_File.Make_Output_File;
Tokens_File.Complete_Tokens_Package;
Source_File.Close;
Tokens_File.Close;
if Options.Interface_to_C then
Tokens_File.Make_C_Lex_Package;
end if;
Print_Statistics;
exception
when File_Names.Illegal_File_Name =>
Put_Line("Ayacc: Illegal Filename.");
when Options.Illegal_Option | Illegal_Argument_List =>
null;
when Parser.Syntax_Error => -- Error has already been reported.
Source_File.Close;
when Text_IO.Name_Error | Text_IO.Use_Error =>
null; -- Error has already been reported.
when others =>
Put_Line ("Ayacc: Internal Error, Please Submit an LCR.");
end Ayacc;
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- The primary authors of ayacc were David Taback and Deepak Tolani.
-- Enhancements were made by Ronald J. Schmalz.
--
-- Send requests for ayacc information to ayacc-info@ics.uci.edu
-- Send bug reports for ayacc to ayacc-bugs@ics.uci.edu
--
-- Redistribution and use in source and binary forms are permitted
-- provided that the above copyright notice and this paragraph are
-- duplicated in all such forms and that any documentation,
-- advertising materials, and other materials related to such
-- distribution and use acknowledge that the software was developed
-- by the University of California, Irvine. The name of the
-- University may not be used to endorse or promote products derived
-- from this software without specific prior written permission.
-- THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
-- IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
-- WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
-- Module : ayacc_separates.ada
-- Component of : ayacc
-- Version : 1.2
-- Date : 11/21/86 12:28:51
-- SCCS File : disk21~/rschm/hasee/sccs/ayacc/sccs/sxayacc_separates.ada
-- $Header: ayacc_separates.a,v 0.0 86/02/19 18:36:14 ada Exp $
-- $Log: ayacc_separates.a,v $
-- Revision 0.0 86/02/19 18:36:14 ada
--
-- These files comprise the initial version of Ayacc
-- designed and implemented by David Taback and Deepak Tolani.
-- Ayacc has been compiled and tested under the Verdix Ada compiler
-- version 4.06 on a vax 11/750 running Unix 4.2BSD.
--
-- Revision 0.1 88/03/16
-- Additional argument added to allow user to specify file extension
-- to be used for generated Ada files. -- kn
with String_Pkg; use String_Pkg;
separate (Ayacc)
procedure Initialize is
use File_Names, Options;
Input_File, Extension, Options : String_Type := Create ("");
type Switch is ( On , Off );
C_Lex_Flag,
Debug_Flag,
Summary_Flag,
Verbose_Flag : Switch;
Invalid_Command_Line : exception;
procedure Get_Arguments (File : out String_Type;
C_Lex : out Switch;
Debug : out Switch;
Summary : out Switch;
Verbose : out Switch;
Extension : out String_Type) is separate;
begin
Get_Arguments (Input_File,
C_Lex_Flag,
Debug_Flag,
Summary_Flag,
Verbose_Flag,
Extension);
New_Line;
Put_Line (" Ayacc (File => """ & Value (Input_File) & """,");
Put_Line (" C_Lex => " &
Value (Mixed (Switch'Image(C_Lex_Flag))) & ',');
Put_Line (" Debug => " &
Value (Mixed (Switch'Image(Debug_Flag))) & ',');
Put_Line (" Summary => " &
Value (Mixed (Switch'Image(Summary_Flag))) & ',');
Put_Line (" Verbose => " &
Value (Mixed (Switch'Image(Verbose_Flag))) & ",");
Put_Line (" Extension => """ & Value (Extension) & """);");
New_Line;
if C_Lex_Flag = On then
Options := Options & Create ("i");
end if;
if Debug_Flag = On then
Options := Options & Create ("d");
end if;
if Summary_Flag = On then
Options := Options & Create ("s");
end if;
if Verbose_Flag = On then
Options := Options & Create ("v");
end if;
Set_File_Names (Value (Input_File), Value(Extension));
Set_Options (Value (Options));
exception
when Invalid_Command_Line =>
raise Illegal_Argument_List;
end Initialize;
separate (Ayacc)
procedure Print_Statistics is
use Text_IO, Parse_Table, Rule_Table, Symbol_Table;
begin
if Options.Summary then
Put_Line(Rule'Image(Last_Rule - First_Rule + 1) & " Productions");
Put_Line(Grammar_Symbol'Image
(Last_Symbol(Nonterminal) - First_Symbol(Nonterminal) + 1) &
" Nonterminals");
Put_Line(Grammar_Symbol'Image
(Last_Symbol(Terminal) - First_Symbol(Terminal) + 1) &
" Terminals");
Put_Line(Integer'Image(Number_of_States) & " States");
Put_Line (Integer'Image(Shift_Reduce_Conflicts) &
" Shift/Reduce conflicts");
Put_Line (Integer'Image(Reduce_Reduce_Conflicts) &
" Reduce/Reduce conflicts");
else
if Shift_Reduce_Conflicts /= 0 then
Put_Line (Integer'Image(Shift_Reduce_Conflicts) &
" Shift/Reduce Conflicts");
end if;
if Reduce_Reduce_Conflicts /= 0 then
Put_Line (Integer'Image(Reduce_Reduce_Conflicts) &
" Reduce/Reduce Conflicts");
end if;
end if;
end Print_Statistics;
with Command_Line_Interface; use Command_Line_Interface;
with String_Pkg; use String_Pkg;
--VAX with Vms_Lib;
separate (Ayacc.Initialize)
procedure Get_Arguments (File : out String_Type;
C_Lex : out Switch;
Debug : out Switch;
Summary : out Switch;
Verbose : out Switch;
Extension : out String_Type) is
C_Lex_Argument : String_Type;
Debug_Argument : String_Type;
Summary_Argument : String_Type;
Verbose_Argument : String_Type;
Positional : Natural := 0;
-- Number of positional parameters
Total : Natural := 0;
-- Total number of parameters
Max_Parameters : constant := 6;
Incorrect_Call : exception;
function Convert_Switch is new
Convert (Parameter_Type => Switch,
Type_Name => "Switch");
procedure Put_Help_Message is
begin
New_Line;
Put_Line (" -- Ayacc: An Ada Parser Generator.");
New_Line;
Put_Line (" type Switch is (On, Off);");
New_Line;
Put_Line (" procedure Ayacc (File : in String;");
Put_Line (" C_Lex : in Switch := Off;");
Put_Line (" Debug : in Switch := Off;");
Put_Line (" Summary : in Switch := On;");
Put_Line (" Verbose : in Switch := Off;");
Put_Line (" Extension : in String := "".a"");");
New_Line;
Put_Line (" -- File Specifies the Ayacc Input Source File.");
Put_Line (" -- C_Lex Specifies the Generation of a 'C' Lex Interface.");
Put_Line (" -- Debug Specifies the Production of Debugging Output");
Put_Line (" -- By the Generated Parser.");
Put_Line (" -- Summary Specifies the Printing of Statistics About the");
Put_Line (" -- Generated Parser.");
Put_Line (" -- Verbose Specifies the Production of a Human Readable");
Put_Line (" -- Report of States in the Generated Parser.");
Put_Line (" -- Extension Specifies the file extension to be used for");
Put_Line (" generated Ada files.");
New_Line;
end Put_Help_Message;
begin
--VAX Vms_Lib.Set_Error;
Command_Line_Interface.Initialize (Tool_Name => "Ayacc");
Positional := Positional_Arg_Count;
Total := Named_Arg_Count + Positional;
if Total = 0 then
raise Incorrect_Call;
elsif Total > Max_Parameters then
Put_Line ("Ayacc: Too many parameters.");
raise Incorrect_Call;
end if;
-- Get named values
File := Named_Arg_Value ("File", "");
C_Lex_Argument := Named_Arg_Value ("C_Lex", "Off");
Debug_Argument := Named_Arg_Value ("Debug", "Off");
Summary_Argument := Named_Arg_Value ("Summary", "On");
Verbose_Argument := Named_Arg_Value ("Verbose", "Off");
Extension := Named_Arg_Value ("Extension", ".a");
-- Get any positional associations
if Positional >= 1 then
File := Positional_Arg_Value (1);
if Positional >= 2 then
C_Lex_Argument := Positional_Arg_Value (2);
if Positional >= 3 then
Debug_Argument := Positional_Arg_Value (3);
if Positional >= 4 then
Summary_Argument := Positional_Arg_Value (4);
if Positional >= 5 then
Verbose_Argument := Positional_Arg_Value (5);
if Positional = Max_Parameters then
Extension := Positional_Arg_Value (Max_Parameters);
end if;
end if;
end if;
end if;
end if;
end if;
Command_Line_Interface.Finalize;
C_Lex := Convert_Switch (Value (C_Lex_Argument));
Debug := Convert_Switch (Value (Debug_Argument));
Summary := Convert_Switch (Value (Summary_Argument));
Verbose := Convert_Switch (Value (Verbose_Argument));
exception
when Incorrect_Call | Invalid_Parameter |
Invalid_Parameter_Order | Missing_Positional_Arg |
Unreferenced_Named_Arg | Invalid_Named_Association |
Unbalanced_Parentheses =>
Put_Help_Message ;
raise Invalid_Command_Line ;
end Get_Arguments;
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- The primary authors of ayacc were David Taback and Deepak Tolani.
-- Enhancements were made by Ronald J. Schmalz.
--
-- Send requests for ayacc information to ayacc-info@ics.uci.edu
-- Send bug reports for ayacc to ayacc-bugs@ics.uci.edu
--
-- Redistribution and use in source and binary forms are permitted
-- provided that the above copyright notice and this paragraph are
-- duplicated in all such forms and that any documentation,
-- advertising materials, and other materials related to such
-- distribution and use acknowledge that the software was developed
-- by the University of California, Irvine. The name of the
-- University may not be used to endorse or promote products derived
-- from this software without specific prior written permission.
-- THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
-- IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
-- WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
--|
--| Notes: This routine contains the machine specific details of how
--| Ayacc obtains the command line arguments from the host Operating
--| System. This version assumes Verdix running on Unix machines.
--|
--| The only requirement on this subunit is that it place the string
--| of characters typed by the user on the command line into the
--| parameter "Command_Args".
--|
with A_Strings; use A_Strings;
with U_Env; use U_Env;
separate (Command_Line_Interface)
procedure Read_Command_Line (Command_Args : out Command_Line_Type) is
Unix_Command_Line : A_String := Empty;
begin
for i in Argv.all'First + 1 .. Argv.all'Last
loop
Unix_Command_Line := Unix_Command_Line & Argv (i) & " ";
end loop;
Unix_Command_Line := Pad_Right (Unix_Command_Line,
To_Length => Maximum_Command_Length);
Command_Args := Unix_Command_Line.S;
end Read_Command_Line;
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- The primary authors of ayacc were David Taback and Deepak Tolani.
-- Enhancements were made by Ronald J. Schmalz.
--
-- Send requests for ayacc information to ayacc-info@ics.uci.edu
-- Send bug reports for ayacc to ayacc-bugs@ics.uci.edu
--
-- Redistribution and use in source and binary forms are permitted
-- provided that the above copyright notice and this paragraph are
-- duplicated in all such forms and that any documentation,
-- advertising materials, and other materials related to such
-- distribution and use acknowledge that the software was developed
-- by the University of California, Irvine. The name of the
-- University may not be used to endorse or promote products derived
-- from this software without specific prior written permission.
-- THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
-- IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
-- WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
-- Module : command_line_interface.ada
-- Component of : common_library
-- Version : 1.2
-- Date : 11/21/86 16:02:24
-- SCCS File : disk21~/rschm/hasee/sccs/common_library/sccs/sxcommand_line_interface.ada
with Text_IO; use Text_IO;
with String_scanner;
----------------------------------------------------------------
Package body command_line_interface is
SCCS_ID : constant String := "@(#) command_line_interface.addisk21~/rschm/hasee/sccs/common_library, Version 1.2";
--| Provides primitives for getting at the command line arguments.
--| Overview
Package sp renames String_pkg;
Package ss renames String_scanner;
type Name_value is --| Name/Value pair
record
Name: sp.String_type; --| Name of value
Value: sp.String_type; --| Value associated with name
Was_retrieved: boolean:=FALSE; --| Flag indicating whether name-value
end record; -- association has been retrieved by tool
type Token_type is (Ada_ID,Word,Bound_to,None);
Package Token_type_IO is new Enumeration_IO(Token_type);
use Token_type_IO;
Maximum_Command_Length : constant := 1024;
subtype Command_Line_Type is String (1 .. Maximum_Command_Length);
Arg_string : Command_Line_Type; --| String obtained from operating system
N_arg_count: Argument_count; --| Count of named args
P_arg_count: Argument_count; --| Count of positional args
Rejected: boolean := FALSE;
Tool_Name : String_Type;
Named_args: array(argument_index)
of Name_value;
Positional_args: array(argument_index)
of sp.String_type;
procedure Read_Command_Line
(Command_Args : out Command_Line_Type) is separate;
--**
--| Description: Read_Command_Line is the machine dependent interface to
--| the Operating System Command Line.
--**
----------------------------------------------------------------
-- Local functions:
procedure Set_Tool_Name (To : in String) is
begin
Tool_Name := Create (To & ": ");
end Set_Tool_Name;
procedure CLI_Error (Error_Message : in String) is
begin
New_Line;
Put_Line (Value (Tool_Name) & Error_Message);
end CLI_Error;
procedure Get_token(
Scan_string : in out ss.Scanner;
Argument : in out sp.String_type;
Kind: in out Token_type
) is
Last_arg: sp.String_type;
Last_kind: Token_type;
Found: boolean;
Delimeter: sp.String_type;
Delim_string: ss.Scanner;
More_commas: boolean := FALSE;
Tail: sp.String_type;
begin
if Rejected then
Argument := Last_arg;
Kind := Last_kind;
Rejected := FALSE;
else
if ss.Is_sequence(" ,",Scan_string) then
ss.Scan_sequence(" ,",Scan_string,Found,Delimeter);
Delim_string := ss.Make_scanner(Delimeter);
loop
ss.Skip_space(Delim_string);
exit when not ss.More(Delim_string);
ss.Forward(Delim_string);
if More_commas then
CLI_Error ("Missing Positional Argument.");
raise missing_positional_arg;
end if;
More_commas := TRUE;
end loop;
end if;
if ss.Is_Ada_Id(Scan_string) then
ss.Scan_Ada_Id(Scan_string,Found,Argument);
if ss.Is_Literal("=>",Scan_string) or
ss.Is_Literal("""",Scan_string) or
ss.Is_sequence(" ,",Scan_string) or
not ss.More(Scan_string) then
Kind := Ada_ID;
else
if ss.Is_not_sequence(" ,",Scan_string) then
ss.Scan_not_sequence(" ,",Scan_string,Found,Tail);
Argument := sp."&"(Argument,Tail);
Kind := Word;
else
ss.Scan_word(Scan_string,Found,Tail);
Argument := sp."&"(Argument,Tail);
Kind := Word;
end if;
end if;
elsif ss.Is_Literal("=>",Scan_string) then
ss.Scan_Literal("=>",Scan_string,Found);
Argument := sp.Create("=>");
Kind := Bound_to;
elsif ss.Is_quoted(Scan_string) then
ss.Scan_quoted(Scan_string,Found,Argument);
Kind := Word;
elsif ss.Is_enclosed('(',')',Scan_string) then
ss.Scan_enclosed('(',')',Scan_string,Found,Argument);
Kind := Word;
elsif ss.Is_not_sequence(" ,",Scan_string) then
ss.Scan_not_sequence(" ,",Scan_string,Found,Argument);
Kind := Word;
elsif ss.Is_word(Scan_string) then
ss.Scan_word(Scan_string,Found,Argument);
Kind := Word;
else
Argument := sp.Create("");
Kind := None;
end if;
Last_kind := Kind;
Last_arg := Argument;
end if;
end Get_token;
-----------------------------------------------------------------------
procedure Save_named(
Name : in sp.String_type;
Value : in sp.String_type
) is
begin
N_arg_count := N_arg_count + 1;
Named_args(N_arg_count).Name := Name;
Named_args(N_arg_count).Value := Value;
end Save_named;
procedure Save_positional(
Value : in sp.String_type
) is
begin
if N_arg_count > 0 then
CLI_Error ("Invalid Parameter Order, " &
"Positional arguments must precede Named.");
raise invalid_parameter_order;
end if;
P_arg_count := P_arg_count + 1;
Positional_args(P_arg_count) := Value;
end Save_positional;
procedure Reject_token is
begin
Rejected := TRUE;
end Reject_token;
----------------------------------------------------------------
procedure Initialize (Tool_Name : in String) is
begin
Set_Tool_Name (To => Tool_Name);
declare
type State_type is (Have_nothing,Have_Ada_ID,Have_bound_to);
Start_Index : integer; --|
End_Index: integer; --| Indices of characters in argument string
Scan_string: ss.Scanner; --| Scanned argument string
Argument: sp.String_Type; --| Argument scanned from argument string
Kind: Token_type; --| Kind of argument- WORD, =>, Ada_ID
Old_arg: sp.String_Type; --| Previously scanned argument
Found: boolean;
State: State_type := Have_nothing;
--| State of argument in decision tree
begin
Start_Index := Arg_string'first;
End_Index := Arg_string'first;
N_arg_count := 0;
P_arg_count := 0;
-- Get the command line from the operating system
Read_Command_Line (Arg_String);
-- Remove trailing blanks and final semicolon
for i in reverse Arg_string'range loop
if Arg_string(i) /= ' ' then
if Arg_string(i) = ';' then
End_Index := i - 1;
else
End_Index := i;
end if;
exit;
end if;
end loop;
Skip_Leading_White_Space :
for i in Arg_String'First .. End_Index
loop
if Arg_String (i) /= ' ' and then
Arg_String (i) /= Ascii.HT then
Start_Index := i;
exit Skip_Leading_White_Space;
end if;
end loop Skip_Leading_White_Space;
Verify_Balanced_Parentheses :
declare
Left_Parens : Natural := 0;
Right_Parens : Natural := 0;
begin
for i in Start_Index .. End_Index
loop
if Arg_String (i) = '(' then
Left_Parens := Left_Parens + 1;
elsif Arg_String (i) = ')' then
Right_Parens := Right_Parens + 1;
end if;
end loop;
if Left_Parens /= Right_Parens then
CLI_Error ("Unbalanced Parentheses.");
raise Unbalanced_Parentheses;
end if;
end Verify_Balanced_Parentheses;
-- Convert argument string to scanner and remove enclosing parantheses
Scan_string := ss.Make_scanner(sp.Create(
Arg_string(Start_Index .. End_Index)));
if ss.Is_enclosed('(',')',Scan_string) then
ss.Mark(Scan_string);
ss.Scan_enclosed('(',')',Scan_string,Found,Argument);
ss.Skip_Space(Scan_string);
if not ss.More(Scan_string) then
ss.Destroy_Scanner(Scan_string);
Scan_string := ss.Make_scanner(Argument);
else
ss.Restore(Scan_string);
end if;
end if;
-- Parse argument string and save arguments
loop
Get_token(Scan_string,Argument,Kind);
case State is
when Have_nothing =>
case Kind is
when Ada_ID =>
Old_arg := Argument;
State := Have_Ada_ID;
when Word =>
Save_positional(Argument);
State := Have_nothing;
when Bound_to =>
State := Have_nothing;
CLI_Error ("Invalid Named Association.");
raise invalid_named_association;
when None =>
null;
end case;
when Have_Ada_ID =>
case Kind is
when Ada_ID =>
Save_positional(Old_arg);
Old_arg := Argument;
State := Have_Ada_ID;
when Word =>
Save_positional(Old_arg);
Save_positional(Argument);
State := Have_nothing;
when Bound_to =>
State := Have_bound_to;
when None =>
Save_positional(Old_arg);
end case;
when Have_bound_to =>
case Kind is
when Ada_ID | Word =>
Save_named(Old_arg,Argument);
State := Have_nothing;
when Bound_to =>
State := Have_bound_to;
CLI_Error ("Invalid Named Association.");
raise invalid_named_association;
when None =>
CLI_Error ("Invalid Named Association.");
raise invalid_named_association;
end case;
end case;
exit when Kind = None;
end loop;
end;
end Initialize;
--------------------------------------------------------------------------
function Named_arg_count --| Return number of named arguments
return Argument_count is
begin
return N_arg_count;
end;
----------------------------------------------------------------
function Positional_arg_count --| Return number of positional arguments
return Argument_count is
begin
return P_arg_count;
end;
----------------------------------------------------------------
function Positional_arg_value( --| Return an argument value
N: Argument_index --| Position of desired argument
) return string is --| Raises: no_arg
--| Effects: Return the Nth argument. If there is no argument at
--| position N, no_arg is raised.
--| N/A: modifies, errors
begin
if N > P_arg_count then
CLI_Error ("Internal Error, Argument" & Argument_Index'Image (N) &
" does not exist. Please submit an LCR.");
raise no_arg;
else
return sp.Value(Positional_args(N));
end if;
end;
----------------------------------------------------------------
function Positional_arg_value( --| Return an argument value
N: Argument_index --| Position of desired argument
) return sp.String_type is --| Raises: no_arg
--| Effects: Return the Nth argument. If there is no argument at
--| position N, no_arg is raised.
--| N/A: modifies, errors
begin
if N > P_arg_count then
CLI_Error ("Internal Error, Argument" & Argument_Index'Image (N) &
" does not exist. Please submit an LCR.");
raise no_arg;
else
return Positional_args(N);
end if;
end;
----------------------------------------------------------------
function Named_arg_value(--| Return a named argument value
Name: string;
Default: string
) return string is
--| Effects: Return the value associated with Name on the command
--| line. If there was none, return Default.
begin
for i in 1..N_arg_count
loop
if sp.Equal(sp.Upper(Named_args(i).Name),sp.Upper(sp.Create(Name))) then
Named_args(i).Was_retrieved := TRUE;
return sp.Value(Named_args(i).Value);
end if;
end loop;
return Default;
end;
function Named_arg_value(--| Return a named argument value
Name: string;
Default: string
) return String_Type is
--| Effects: Return the value associated with Name on the command
--| line. If there was none, return Default.
begin
return Create (Named_Arg_Value (Name, Default));
end Named_Arg_Value;
----------------------------------------------------------------
function Named_arg_value(--| Return a named argument value
Name: string;
Default: sp.String_type
) return sp.String_type is
--| Effects: Return the value associated with Name on the command
--| line. If there was none, return Default.
begin
for i in 1..N_arg_count
loop
if sp.Equal(sp.Upper(Named_args(i).Name),sp.Upper(sp.Create(Name))) then
Named_args(i).Was_retrieved := TRUE;
return Named_args(i).Value;
end if;
end loop;
return Default;
end;
----------------------------------------------------------------
function Arguments --| Return the entire argument string
return string is
--| Effects: Return the entire command line, except for the name
--| of the command itself.
begin
return Arg_string;
end;
----------------------------------------------------------------
function Parse_Aggregate (Aggregate_Text : in String)
return String_Lists.List is
type State_type is (Have_Nothing,
Have_Ada_ID,
Have_Bound_To);
First : Natural := Aggregate_Text'First;
Last : Natural := Aggregate_Text'Last;
Component_List : String_Lists.List := String_Lists.Create;
Argument : sp.String_Type; --| Argument scanned from argument string
Kind : Token_type; --| Kind of argument- WORD, =>, Ada_ID
Scan_string : ss.Scanner; --| Scanned argument string
Aggregate_Contents : String_Type;
Enclosed_Aggregate_Found : Boolean := False;
begin
if Aggregate_Text'Length > 0 then
Scan_String := SS.Make_Scanner (Create (Aggregate_Text (First .. Last)));
SS.Scan_Enclosed ( '(', ')',
Scan_String,
Found => Enclosed_Aggregate_Found,
Result => Aggregate_Contents,
Skip => True);
if Enclosed_Aggregate_Found then
SS.Destroy_Scanner (Scan_String);
Scan_String := SS.Make_Scanner (Aggregate_Contents);
end if;
Parse_Aggregate_String :
loop
Get_token(Scan_string, Argument, Kind);
exit Parse_Aggregate_String when Kind = None;
String_Lists.Attach (Component_List, Argument);
end loop Parse_Aggregate_String;
end if;
return Component_List;
end Parse_Aggregate;
function Parse_Aggregate
(Aggregate_Text : in String_Type)
return String_Lists.List is
begin
return Parse_Aggregate (Value (Aggregate_Text));
end Parse_Aggregate;
----------------------------------------------------------------
function Convert (Parameter_Text : in String) return Parameter_Type is
begin
return Parameter_Type'Value (Parameter_Text);
exception
when Constraint_Error =>
CLI_Error ("Invalid Parameter, """ &
Value (Mixed (Parameter_Text)) &
""" is not a legal value for type " &
Value (Mixed (Type_Name)) & '.');
raise Invalid_Parameter;
end Convert;
----------------------------------------------------------------
procedure Finalize is --| Raises: unreferenced_named_arg
begin
for i in 1..Named_arg_count loop
if Named_args(i).Was_retrieved = FALSE then
CLI_Error ("Invalid Parameter Association, " &
Value (Mixed (Named_Args (i).Name)) &
" is not a valid Formal Parameter.");
raise unreferenced_named_arg;
end if;
end loop;
end Finalize;
-------------------------------------------------------------------
end command_line_interface;
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- The primary authors of ayacc were David Taback and Deepak Tolani.
-- Enhancements were made by Ronald J. Schmalz.
--
-- Send requests for ayacc information to ayacc-info@ics.uci.edu
-- Send bug reports for ayacc to ayacc-bugs@ics.uci.edu
--
-- Redistribution and use in source and binary forms are permitted
-- provided that the above copyright notice and this paragraph are
-- duplicated in all such forms and that any documentation,
-- advertising materials, and other materials related to such
-- distribution and use acknowledge that the software was developed
-- by the University of California, Irvine. The name of the
-- University may not be used to endorse or promote products derived
-- from this software without specific prior written permission.
-- THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
-- IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
-- WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
-- Module : command_line_interface_.ada
-- Component of : common_library
-- Version : 1.2
-- Date : 11/21/86 16:03:08
-- SCCS File : disk21~/rschm/hasee/sccs/common_library/sccs/sxcommand_line_interface_.ada
with String_Lists; use String_Lists;
with String_pkg; use String_pkg;
--------------------------------------------------------------------
Package command_line_interface is
--| Provides primitives for getting at the command line arguments.
--| Overview
--| This package provides a universal and portable interface to
--| the arguments typed on a command line when a program is invoked.
--| Each command line argument is either a Word (sequence of non-blank
--| characters) or a quoted string, with embedded quotes doubled.
--|
--| Both named and positional arguments may be given on the command
--| line. However, once a named parameter is used, all the subseqent
--| parameters on the command line must be named parameters. For example,
--| the commands
--|-
--| compile abc pqr xyz library => plib
--| compile abc,pqr,unit=>xyz,library=>plib
--|+
--| have one named argument and three positional arguments. This
--| package separates the named parameters from the positional
--| parameters, ignores spaces around the "bound to" (=>) symbol, and
--| allows parameters to be separated by either spaces or commas,
--| so these command lines are indistinguishable.
--|
--| At program elaboration time, the command line string is automatically
--| obtained from the host operating system and parsed into
--| individual arguments. The following operations may then be used:
--|-
--| Named_arg_count() Returns number of named arguments entered
--| Positional_arg_count() Returns number of positional arguments
--| Positional_arg_value(N) Returns the Nth positional argument
--| Named_arg_value(Name, Dflt) Returns value of a named argument
--| Arguments() Returns the entire command line
--|+
----------------------------------------------------------------
max_args: constant := 255;
--| Maximum number of command line arguments (arbitrary).
subtype Argument_count is integer range 0..max_args;
--| For number of arguments
subtype Argument_index is Argument_count range 1..Argument_count'last;
--| Used to number the command line arguments.
no_arg: exception;
--| Raised when request made for nonexistent argument
missing_positional_arg: exception;
--| Raised when command line is missing positional argument (A,,B)
invalid_named_association: exception;
--| Raised when command line is missing named argument value (output=> ,A,B)
unreferenced_named_arg: exception;
--| Raised when not all named parameters have been retrieved
invalid_parameter_order: exception;
--| Raised when a positional parameter occurs after a named parameter
-- in the command line
--Invalid_Aggregate : exception;
--| Raised when an aggregate does not begin and end with parentheses
-- in Parse_Aggregate.
Unbalanced_Parentheses : exception;
--| Raised when the number of left paren's does not match the number
--| of right paren's.
Invalid_Parameter : exception;
--| Raised when the conversion of a string to a parameter type is not
--| possible.
----------------------------------------------------------------
procedure Initialize (Tool_Name : in String);
--| Initializes command_line_interface
--| N/A: modifies, errors, raises
---------------------------------------------------------------------
function Named_arg_count --| Return number of named arguments
return Argument_count;
--| N/A: modifies, errors, raises
function Positional_arg_count --| Return number of positional arguments
return Argument_count;
--| N/A: modifies, errors, raises
----------------------------------------------------------------
function Positional_arg_value( --| Return an argument value
N: Argument_index --| Position of desired argument
) return string; --| Raises: no_arg
--| Effects: Return the Nth argument. If there is no argument at
--| position N, no_arg is raised.
--| N/A: modifies, errors
function Positional_arg_value( --| Return an argument value
N: Argument_index --| Position of desired argument
) return String_type; --| Raises: no_arg
--| Effects: Return the Nth argument. If there is no argument at
--| position N, no_arg is raised.
--| N/A: modifies, errors
--------------------------------------------------------------------
function Named_arg_value(--| Return a named argument value
Name: string;
Default: string
) return string;
--| Effects: Return the value associated with Name on the command
--| line. If there was none, return Default.
--| N/A: modifies, errors
function Named_arg_value(--| Return a named argument value
Name: string;
Default: string
) return String_Type;
--| Effects: Return the value associated with Name on the command
--| line. If there was none, return Default.
--| N/A: modifies, errors
function Named_arg_value(--| Return a named argument value
Name: string;
Default: String_type
) return String_type;
--| Effects: Return the value associated with Name on the command
--| line. If there was none, return Default.
--| N/A: modifies, errors
----------------------------------------------------------------
function Arguments --| Return the entire argument string
return string;
--| Effects: Return the entire command line, except for the name
--| of the command itself.
--| N/A: modifies, errors, raises
----------------------------------------------------------------
function Parse_Aggregate (Aggregate_Text : in String_Type)
return String_Lists.List;
function Parse_Aggregate (Aggregate_Text : in String)
return String_Lists.List;
--| Effects: Returns components of Aggregate_Text as a String_List.
--| Raises : Invalid_Aggregate
----------------------------------------------------------------
generic
type Parameter_Type is (<>);
Type_Name : in String;
function Convert (Parameter_Text : in String) return Parameter_Type;
--| Raises: Invalid_Parameter
----------------------------------------------------------------
procedure Finalize ; --| Raises: unrecognized parameters
--| Effects: If not all named parameters have been retrieved
--| unrecognized parameters is raised.
--| N/A: modifies, errors
end command_line_interface;
----------------------------------------------------------------
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- The primary authors of ayacc were David Taback and Deepak Tolani.
-- Enhancements were made by Ronald J. Schmalz.
--
-- Send requests for ayacc information to ayacc-info@ics.uci.edu
-- Send bug reports for ayacc to ayacc-bugs@ics.uci.edu
--
-- Redistribution and use in source and binary forms are permitted
-- provided that the above copyright notice and this paragraph are
-- duplicated in all such forms and that any documentation,
-- advertising materials, and other materials related to such
-- distribution and use acknowledge that the software was developed
-- by the University of California, Irvine. The name of the
-- University may not be used to endorse or promote products derived
-- from this software without specific prior written permission.
-- THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
-- IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
-- WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
-- Module : file_names.ada
-- Component of : ayacc
-- Version : 1.2
-- Date : 11/21/86 12:29:16
-- SCCS File : disk21~/rschm/hasee/sccs/ayacc/sccs/sxfile_names.ada
-- $Header: file_names.a,v 0.1 86/04/01 15:04:19 ada Exp $
-- $Log: file_names.a,v $
-- Revision 0,2 88/03/16
-- Set file names modified to include a file extension parameter.
-- Revision 0.1 86/04/01 15:04:19 ada
-- This version fixes some minor bugs with empty grammars
-- and $$ expansion. It also uses vads5.1b enhancements
-- such as pragma inline.
--
--
-- Revision 0.0 86/02/19 18:36:22 ada
--
-- These files comprise the initial version of Ayacc
-- designed and implemented by David Taback and Deepak Tolani.
-- Ayacc has been compiled and tested under the Verdix Ada compiler
-- version 4.06 on a vax 11/750 running Unix 4.2BSD.
--
-- The collection of all file names used by Ayacc --
package File_Names is
procedure Set_File_Names(Input_File, Extension: in String);
-- Sets the initial value of the file names
-- according to the INPUT_FILE.
function Get_Source_File_Name return String;
function Get_Out_File_Name return String;
function Get_Verbose_File_Name return String;
function Get_Template_File_Name return String;
function Get_Actions_File_Name return String;
function Get_Shift_Reduce_File_Name return String;
function Get_Goto_File_Name return String;
function Get_Tokens_File_Name return String;
function Get_C_Lex_File_Name return String;
function Get_Include_File_Name return String;
--RJS ==========================================
function C_Lex_Unit_Name return String;
function Goto_Tables_Unit_Name return String;
function Shift_Reduce_Tables_Unit_Name return String;
function Tokens_Unit_Name return String;
--RJS ==========================================
Illegal_File_Name: exception;
-- Raised if the file name does not end with ".y"
end File_Names;
with STR_Pack;
use STR_Pack;
with String_Pkg;
package body File_Names is
SCCS_ID : constant String := "@(#) file_names.ada, Version 1.2";
Rcs_ID : constant String := "$Header: file_names.a,v 0.1 86/04/01 15:04:19 ada Exp $";
Max_Name_Length : constant := 50;
Source_File_Name : STR(Max_Name_Length);
Out_File_Name : STR(Max_Name_Length);
Verbose_File_Name : STR(Max_Name_Length);
Template_File_Name : STR(Max_Name_Length);
Actions_File_Name : STR(Max_Name_Length);
Shift_Reduce_File_Name : STR(Max_Name_Length);
Goto_File_Name : STR(Max_Name_Length);
Tokens_File_Name : STR(Max_Name_Length);
C_Lex_File_Name : STR(Max_Name_Length);
Include_File_Name : STR(Max_Name_Length);
--RJS ==========================================
function End_of_Unit_Name (Name : in String) return Natural is
Dot_Position : Natural := Name'Last;
begin
while Dot_Position >= Name'First and then
Name (Dot_Position) /= '.'
loop
Dot_Position := Dot_Position - 1;
end loop;
return Dot_Position - 1;
end End_of_Unit_Name;
function Get_Unit_Name (Filename : in String) return String is
Filename_Without_Extension : constant String :=
Filename (Filename'First .. End_of_Unit_Name (Filename));
End_of_Directory : Natural := Filename_Without_Extension'Last;
function Character_Is_Part_of_Unit_Name (Ch : in Character) return Boolean is
begin
return Ch in 'A' .. 'Z' or else
Ch in 'a' .. 'z' or else
Ch = '_';
end Character_Is_Part_of_Unit_Name;
use String_Pkg;
begin
while End_of_Directory >= Filename_Without_Extension'First and then
Character_Is_Part_of_Unit_Name (
Filename_Without_Extension (End_of_Directory))
loop
End_of_Directory := End_of_Directory - 1;
end loop;
return Value (Mixed (Filename_Without_Extension (End_of_Directory + 1 ..
Filename_Without_Extension'Last)));
end Get_Unit_Name;
function C_Lex_Unit_Name return String is
Filename : constant String := Value_of (Upper_Case (C_Lex_File_Name));
begin
return Get_Unit_Name (Filename);
end C_Lex_Unit_Name;
function Goto_Tables_Unit_Name return String is
Filename : constant String := Value_of (Upper_Case (Goto_File_Name));
begin
return Get_Unit_Name (Filename);
end Goto_Tables_Unit_Name;
function Shift_Reduce_Tables_Unit_Name return String is
Filename : constant String := Value_of (Upper_Case (Shift_Reduce_File_Name));
begin
return Get_Unit_Name (Filename);
end Shift_Reduce_Tables_Unit_Name;
function Tokens_Unit_Name return String is
Filename : constant String := Value_of (Upper_Case (Tokens_File_Name));
begin
return Get_Unit_Name (Filename);
end Tokens_Unit_Name;
--RJS ==========================================
function Get_Source_File_Name return String is
begin
return Value_of(Source_File_Name);
end;
function Get_Out_File_Name return String is
begin
return Value_of(Out_File_Name);
end;
function Get_Verbose_File_Name return String is
begin
return Value_of(Verbose_File_Name);
end;
function Get_Template_File_Name return String is
begin
return Value_of(Template_File_Name);
end;
function Get_Actions_File_Name return String is
begin
return Value_of(Actions_File_Name);
end;
function Get_Shift_Reduce_File_Name return String is
begin
return Value_of(Shift_Reduce_File_Name);
end;
function Get_Goto_File_Name return String is
begin
return Value_of(Goto_File_Name);
end;
function Get_Tokens_File_Name return String is
begin
return Value_of(Tokens_File_Name);
end;
function Get_C_Lex_File_Name return String is
begin
return Value_of(C_Lex_File_Name);
end;
function Get_Include_File_Name return String is
begin
return Value_of(Include_File_Name);
end;
procedure Set_File_Names(Input_File, Extension: in String) is
Base: STR(Max_Name_Length);
begin
if Input_File'Length < 3 or else
(Input_File(Input_File'Last) /= 'y' and then
Input_File(Input_File'Last) /= 'Y') or else
Input_File(Input_File'Last - 1) /= '.'
then
raise Illegal_File_Name;
end if;
Assign(Input_File(Input_File'First..Input_File'Last-2), To => Base);
Assign(Input_File, To => Source_File_Name);
Assign(Base, To => Out_File_Name);
Append(Extension, To => Out_File_Name);
Assign(Base, To => Verbose_File_Name);
Append(".verbose", To => Verbose_File_Name);
Assign(Base, To => Tokens_File_Name);
Append("_tokens" & Extension, To => Tokens_File_Name);
Assign("yyparse.template", To => Template_File_Name);
Assign(Base, To => Actions_File_Name);
Append(".accs", To => Actions_File_Name);
Assign(Base, To => Shift_Reduce_File_Name);
Append("_shift_reduce" & Extension, To => Shift_Reduce_File_Name);
Assign(Base, To => Goto_File_Name);
Append("_goto" & Extension, To => Goto_File_Name);
Assign(Base, To => C_Lex_File_Name);
Append("_c_lex" & Extension, To => C_Lex_File_Name);
Assign(Base, To => Include_File_Name);
Append(".h", To => Include_File_Name);
end Set_File_Names;
end File_Names;
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- The primary authors of ayacc were David Taback and Deepak Tolani.
-- Enhancements were made by Ronald J. Schmalz.
--
-- Send requests for ayacc information to ayacc-info@ics.uci.edu
-- Send bug reports for ayacc to ayacc-bugs@ics.uci.edu
--
-- Redistribution and use in source and binary forms are permitted
-- provided that the above copyright notice and this paragraph are
-- duplicated in all such forms and that any documentation,
-- advertising materials, and other materials related to such
-- distribution and use acknowledge that the software was developed
-- by the University of California, Irvine. The name of the
-- University may not be used to endorse or promote products derived
-- from this software without specific prior written permission.
-- THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
-- IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
-- WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
-- Module : goto_file.ada
-- Component of : ayacc
-- Version : 1.2
-- Date : 11/21/86 12:29:33
-- SCCS File : disk21~/rschm/hasee/sccs/ayacc/sccs/sxgoto_file.ada
-- $Header: goto_file.a,v 0.1 86/04/01 15:04:27 ada Exp $
-- $Log: goto_file.a,v $
-- Revision 0.1 86/04/01 15:04:27 ada
-- This version fixes some minor bugs with empty grammars
-- and $$ expansion. It also uses vads5.1b enhancements
-- such as pragma inline.
--
--
-- Revision 0.0 86/02/19 18:36:31 ada
--
-- These files comprise the initial version of Ayacc
-- designed and implemented by David Taback and Deepak Tolani.
-- Ayacc has been compiled and tested under the Verdix Ada compiler
-- version 4.06 on a vax 11/750 running Unix 4.2BSD.
--
package Goto_File is
procedure Open_Write;
procedure Close_Write;
procedure Write(S: in String);
procedure Write_Line(S: in String);
procedure Write(C: in Character);
end Goto_File;
with Text_IO, Rule_Table, Symbol_Table, File_Names;
use Text_IO, Rule_Table, Symbol_Table, File_Names;
package body Goto_File is
SCCS_ID : constant String := "@(#) goto_file.ada, Version 1.2";
Rcs_ID : constant String := "$Header: goto_file.a,v 0.1 86/04/01 15:04:27 ada Exp $";
The_File : File_Type;
procedure Open_Write is
begin
Create(The_File, Out_File, Get_Goto_File_Name);
Write_Line("package " & Goto_Tables_Unit_Name & " is");
Write_Line("");
Write_Line(" type Small_Integer is range -32_000 .. 32_000;");
Write_Line("");
Write_Line(" type Goto_Entry is record");
Write_Line(" Nonterm : Small_Integer;");
Write_Line(" Newstate : Small_Integer;");
Write_Line(" end record;");
Write_Line("");
Write_Line(" --pragma suppress(index_check);");
Write_Line("");
Write_Line(" subtype Row is Integer range -1 .. Integer'Last;");
Write_Line("");
Write_Line(" type Goto_Parse_Table is array (Row range <>) of " &
"Goto_Entry;");
Write_Line("");
Write_Line(" Goto_Matrix : constant Goto_Parse_Table :=");
Write_Line(" ((-1,-1) -- Dummy Entry.");
end Open_Write;
procedure Close_Write is
begin
Write_Line("");
Write_Line("subtype Rule is Natural;");
Write_Line("subtype Nonterminal is Integer;");
Write_Line("");
-- Write the rule length array --
Write( " Rule_Length : array (Rule range " & Rule'Image(First_Rule) &
" .. " & Rule'Image(Last_Rule) & ") of Natural := (");
for R in First_Rule..Last_Rule loop
Write( Natural'Image(Length_of(R)));
if R = Last_Rule then
Write_Line( ");");
elsif R mod 8 = 0 then
Write_Line( ",");
else
Write( ',');
end if;
end loop;
-- Write the lefth hand side array
Write(" Get_LHS_Rule: array (Rule range " &
Rule'Image(First_Rule) & " .. " &
Rule'Image(Last_Rule) & ") of Nonterminal := (");
for R in First_Rule..Last_Rule loop
if R = Last_Rule then
Write_Line( Grammar_Symbol'Image(Get_LHS(R)) & ");");
elsif R mod 8 = 0 then
Write_Line( Grammar_Symbol'Image(Get_LHS(R)) & ',');
else
Write(Grammar_Symbol'Image(Get_LHS(R)) & ',');
end if;
end loop;
Write_Line("end " & Goto_Tables_Unit_Name & ";");
Close(The_File);
end Close_Write;
procedure Write(S: in String) is
begin
Put(The_File, S);
end Write;
procedure Write_Line(S: in String) is
begin
Put_Line(The_File, S);
end Write_Line;
procedure Write(C: in Character) is
begin
Put(The_File, C);
end Write;
end Goto_File;
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- The primary authors of ayacc were David Taback and Deepak Tolani.
-- Enhancements were made by Ronald J. Schmalz.
--
-- Send requests for ayacc information to ayacc-info@ics.uci.edu
-- Send bug reports for ayacc to ayacc-bugs@ics.uci.edu
--
-- Redistribution and use in source and binary forms are permitted
-- provided that the above copyright notice and this paragraph are
-- duplicated in all such forms and that any documentation,
-- advertising materials, and other materials related to such
-- distribution and use acknowledge that the software was developed
-- by the University of California, Irvine. The name of the
-- University may not be used to endorse or promote products derived
-- from this software without specific prior written permission.
-- THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
-- IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
-- WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
-- Module : lalr_symbol_info.ada
-- Component of : ayacc
-- Version : 1.2
-- Date : 11/21/86 12:29:48
-- SCCS File : disk21~/rschm/hasee/sccs/ayacc/sccs/sxlalr_symbol_info.ada
-- $Header: lalr_symbol_info.a,v 0.1 86/04/01 15:04:35 ada Exp $
-- $Log: lalr_symbol_info.a,v $
-- Revision 0.1 86/04/01 15:04:35 ada
-- This version fixes some minor bugs with empty grammars
-- and $$ expansion. It also uses vads5.1b enhancements
-- such as pragma inline.
--
--
-- Revision 0.0 86/02/19 18:36:38 ada
--
-- These files comprise the initial version of Ayacc
-- designed and implemented by David Taback and Deepak Tolani.
-- Ayacc has been compiled and tested under the Verdix Ada compiler
-- version 4.06 on a vax 11/750 running Unix 4.2BSD.
--
-- --
-- Authors : David Taback , Deepak Tolani --
-- Copyright : 1987, University of California Irvine --
-- --
-- If you --
-- modify the source code or if you have any suggestions or questions --
-- regarding ayacc, we would like to hear from you. Our mailing --
-- addresses are : --
-- taback@icsc.uci.edu --
-- tolani@icsc.uci.edu --
-- --
with LR0_Machine, Ragged, Rule_Table, Symbol_Table, Symbol_Info, Set_Pack,
Stack_Pack;
use LR0_Machine, Rule_Table, Symbol_Table, Symbol_Info;
with Text_IO; use Text_IO;
package LALR_Symbol_Info is
procedure Make_LALR_Sets;
procedure Get_LA(State_ID : Parse_State;
Item_ID : Item;
Look_Aheads : in out Grammar_Symbol_Set);
end LALR_Symbol_Info;
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- The primary authors of ayacc were David Taback and Deepak Tolani.
-- Enhancements were made by Ronald J. Schmalz.
--
-- Send requests for ayacc information to ayacc-info@ics.uci.edu
-- Send bug reports for ayacc to ayacc-bugs@ics.uci.edu
--
-- Redistribution and use in source and binary forms are permitted
-- provided that the above copyright notice and this paragraph are
-- duplicated in all such forms and that any documentation,
-- advertising materials, and other materials related to such
-- distribution and use acknowledge that the software was developed
-- by the University of California, Irvine. The name of the
-- University may not be used to endorse or promote products derived
-- from this software without specific prior written permission.
-- THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
-- IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
-- WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
-- Module : lalr_symbol_info_body.ada
-- Component of : ayacc
-- Version : 1.2
-- Date : 11/21/86 12:30:08
-- SCCS File : disk21~/rschm/hasee/sccs/ayacc/sccs/sxlalr_symbol_info_body.ada
-- $Header: lalr_symbol_info_body.a,v 0.1 86/04/01 15:04:40 ada Exp $
-- $Log: lalr_symbol_info_body.a,v $
-- Revision 0.1 86/04/01 15:04:40 ada
-- This version fixes some minor bugs with empty grammars
-- and $$ expansion. It also uses vads5.1b enhancements
-- such as pragma inline.
--
--
-- Revision 0.0 86/02/19 18:36:47 ada
--
-- These files comprise the initial version of Ayacc
-- designed and implemented by David Taback and Deepak Tolani.
-- Ayacc has been compiled and tested under the Verdix Ada compiler
-- version 4.06 on a vax 11/750 running Unix 4.2BSD.
--
package body LALR_Symbol_Info is
SCCS_ID : constant String := "@(#) lalr_symbol_info_body.adadisk21~/rschm/hasee/sccs/ayacc, Version 1.2";
package Relation is
procedure Make_Reads_Relation;
procedure Make_Includes_Relation;
procedure Reads (LHS : Transition; RHS : in out Transition_Set);
procedure Includes(LHS : Transition; RHS : in out Transition_Set);
procedure Free_Includes;
end Relation;
package body Relation is
SCCS_ID : constant String := "@(#) lalr_symbol_info_body.adadisk21~/rschm/hasee/sccs/ayacc, Version 1.2";
package Includes_Relation is
new Ragged(Parse_State, Grammar_Symbol, Transition_Set,
Transition_Set_Pack.Make_Null);
procedure Make_Reads_Relation is
begin
-- Don't need to do anything. Get READS from the LR0 machine
null;
end Make_Reads_Relation;
-- Implements Algorithm D1 in Park's paper
-- "A New Analysis of LALR Formalisms" Park et al.
-- ACM Transactions on Programming Languages and Systems,
-- Vol 7,January 85.
use Includes_Relation, Item_Set_Pack,
Parse_State_Set_Pack, Transition_Set_Pack;
procedure Make_Includes_Relation is
Preds : Parse_State_Set;
Pred_Loop : Parse_State_Iterator;
Temp : Transition;
A , B : Grammar_Symbol;
R : Parse_State;
I : Item;
Items : Item_Set;
Item_Index : Item_Iterator;
begin
Make_Array(First_Parse_State,Last_Parse_State);
for Q in First_Parse_State .. Last_Parse_State loop
-- Loop over all items [B ->B1 . A B2] in state Q
-- Where A is a nonterminal and the string B2 is nullable.
Get_Kernel(Q, Items);
Closure(Items);
Initialize(Item_Index, Items);
while More(Item_Index) loop
Next(Item_Index,I);
-- Is the item of the form [B ->B1 . A B2] ?
if I.Dot_Position = Length_of(I.Rule_ID) then
goto Continue; -- Nothing to the right of dot
elsif I.Dot_Position + 1 < Get_Null_Pos(I.Rule_ID) then
goto Continue; -- B2 is not nullable
end if;
A := Get_RHS(I.Rule_ID, I.Dot_Position + 1);
B := Get_LHS(I.Rule_ID);
if Is_Terminal(A) then
goto Continue; -- A is not a nonterminal
end if;
-- for all states R in PRED(Q,B1) (Q,A) INCLUDES (R,B)
Make_Null(Preds);
Get_Pred_Set(Q,I,Preds);
Initialize(Pred_Loop, Preds);
while More(Pred_Loop) loop
Next(Pred_Loop, R);
Temp.State_ID := R;
Temp.Symbol := B;
Insert(Temp, Into => Includes_Relation.Lval(Q,A).Value);
end loop;
<<Continue>> null;
end loop;
end loop;
-- Free
Make_Null(Preds);
Make_Null(Items);
end Make_Includes_Relation;
procedure Free_Includes is
begin
Includes_Relation.Free_Array;
end Free_Includes;
use Grammar_Symbol_Set_Pack, Transition_Set_Pack;
procedure Reads (LHS : Transition; RHS : in out Transition_Set) is
Temp : Transition;
Gotos : Grammar_Symbol_Set;
Index : Grammar_Symbol_Iterator;
begin
Make_Null(RHS);
Temp.State_ID := Get_Goto(LHS.State_ID, LHS.Symbol);
Get_Transition_Symbols(Temp.State_ID, Nonterminals, Gotos);
Initialize(Index, Gotos);
while More(Index) loop
Next(Index, Temp.Symbol);
if Is_Nullable(Temp.Symbol) then
Insert(Temp, Into => RHS);
end if;
end loop;
-- Free
Make_Null(Gotos);
end Reads;
use Includes_Relation, Transition_Set_Pack;
procedure Includes (LHS : Transition; RHS : in out Transition_Set) is
begin
-- Free
Make_Null(RHS);
-- Could use fassign but dangerous
Assign(RHS, Includes_Relation.Lval(LHS.State_ID,LHS.Symbol).Value);
end Includes;
end Relation;
--------------------------------------------------------------------------
use Relation;
package LALR_Sets_Pack is
procedure Make_Dr_Sets;
procedure Make_Read_Sets;
procedure Make_Follow_Sets;
procedure Follow(
Trans : Transition;
Follow_Set: in out Grammar_Symbol_Set);
procedure Union_Follow_Sets(
Trans : Transition;
Follow_Set : in out Grammar_Symbol_Set);
end LALR_Sets_Pack;
package body LALR_Sets_Pack is
SCCS_ID : constant String := "@(#) lalr_symbol_info_body.adadisk21~/rschm/hasee/sccs/ayacc, Version 1.2";
-- The DR, Read, and Follow sets are all stored in the same data
-- structure in package lalr_sets.
type Relation_Type is (Use_Reads, Use_Includes);
package LALR_Sets is new
Ragged(Parse_State, Grammar_Symbol,
Grammar_Symbol_Set, Grammar_Symbol_Set_Pack.Make_Null);
use LALR_Sets, Grammar_Symbol_Set_Pack, Transition_Set_Pack;
procedure Make_Dr_Sets is
Trans : Transition;
-- gotos : transition_set;
Goto_Index : Nt_Transition_Iterator;
Term_Sym : Grammar_Symbol;
Terms : Grammar_Symbol_Set;
Term_Index : Grammar_Symbol_Iterator;
begin
-- Make storage to hold the DR sets.
LALR_Sets.Make_Array(First_Parse_State, Last_Parse_State);
-- DR(P,Symbol) = { x is a terminal|P -Symbol-> Next_State -x->}
for P in First_Parse_State..Last_Parse_State loop
-- Get all transitions (Symbol,Next_State) out of state P
-- get_transitions(P, nonterminals, gotos);
Initialize(Goto_Index, P);
while More(Goto_Index) loop
Next(Goto_Index, Trans);
Get_Transition_Symbols(Trans.State_ID, Terminals, Terms);
Initialize(Term_Index, Terms);
while More(Term_Index) loop
Next(Term_Index, Term_Sym);
Insert(Term_Sym,
Into => LALR_Sets.Lval(P,Trans.Symbol).Value);
end loop;
end loop;
end loop;
-- make_null(gotos);
Make_Null(Terms);
end Make_Dr_Sets;
procedure Initialize_N(X: in out Integer) is
begin
X := 0;
end Initialize_N;
procedure Digraph(R : Relation_Type) is
package N is new Ragged(Parse_State, Grammar_Symbol, Integer,
Initialize_N);
package Transition_Stack is new Stack_Pack(Transition);
use Transition_Stack, Transition_Set_Pack;
Trans_Stack : Stack;
Symbol : Grammar_Symbol;
Gotos : Grammar_Symbol_Set;
Goto_Index : Grammar_Symbol_Iterator;
Trans : Transition;
procedure Traverse(X: Transition) is
Infinity : constant Integer := Integer'Last;
Depth : Integer;
Minimum : Integer;
Y, Top : Transition;
RHS_Set : Transition_Iterator;
Related : Transition_Set;
begin
Push(Trans_Stack,X);
Depth := Depth_of_Stack(Trans_Stack);
N.Lval(X.State_ID,X.Symbol).Value := Depth;
-- Should take a procedure parameter instead of a key
if R = Use_Reads then
Reads(X, Related);
else
Includes(X, Related);
end if;
Initialize(RHS_Set, Related);
while More(RHS_Set) loop
Next(RHS_Set, Y);
if N.Lval(Y.State_ID, Y.Symbol).Value = 0 then
Traverse(Y);
end if;
Minimum := N.Rval(Y.State_ID, Y.Symbol).Value;
if Minimum < N.Rval(X.State_ID, X.Symbol).Value then
N.Lval(X.State_ID, X.Symbol).Value := Minimum;
end if;
Insert(LALR_Sets.Lval(Y.State_ID,Y.Symbol).Value,
Into => LALR_Sets.Lval(X.State_ID,X.Symbol).Value);
end loop;
if N.Rval(X.State_ID, X.Symbol).Value = Depth then
loop
Top := Top_Value(Trans_Stack);
N.Lval(Top.State_ID,Top.Symbol).Value:= Infinity;
Assign(LALR_Sets.Lval(Top.State_ID, Top.Symbol).Value,
LALR_Sets.Rval(X.State_ID, X.Symbol).Value);
Pop(Trans_Stack, Top);
exit when Top = X;
end loop;
end if;
-- Free
Make_Null(Related);
exception
when Value_Range_Error =>
Put_Line("Ayacc: Value Range Error in Traverse");
raise;
when Stack_Underflow =>
Put_Line("Ayacc: Stack Underflow in Traverse");
raise;
when others =>
Put_Line("Ayacc: Unexpected Error in Traverse");
raise;
end Traverse;
begin -- digraph
Make_Stack(Trans_Stack);
N.Make_Array(First_Parse_State, Last_Parse_State);
-- Call traverse(X) for all unexamined nonterminal transitions X
for State in First_Parse_State .. Last_Parse_State loop
Get_Transition_Symbols(State, Nonterminals, Gotos);
Initialize(Goto_Index, Gotos);
while More(Goto_Index) loop
Next(Goto_Index, Symbol);
if N.Lval(State, Symbol).Value = 0 then
Trans.State_ID := State;
Trans.Symbol := Symbol;
Traverse(Trans);
end if;
end loop;
end loop;
Free_Stack(Trans_Stack);
N.Free_Array;
-- Free
Make_Null(Gotos);
exception
when Value_Range_Error =>
Put_Line("Ayacc: Value Range Error in Digraph");
raise;
when Stack_Underflow =>
Put_Line("Ayacc: Stack Underflow in Digraph");
raise;
when others =>
Put_Line("Ayacc: Unexpected Error in Digraph");
raise;
end Digraph;
procedure Make_Read_Sets is
begin
Digraph(Use_Reads);
end Make_Read_Sets;
procedure Make_Follow_Sets is
begin
Digraph(Use_Includes);
Free_Includes;
end Make_Follow_Sets;
procedure Follow(
Trans : Transition;
Follow_Set : in out Grammar_Symbol_Set) is
begin
Make_Null(Follow_Set);
Assign(Follow_Set,
LALR_Sets.Lval(Trans.State_ID,Trans.Symbol).Value);
-- used to rval
end Follow;
procedure Union_Follow_Sets(
Trans : Transition;
Follow_Set: in out Grammar_Symbol_Set) is
begin
Insert(LALR_Sets.Rval(Trans.State_ID,Trans.Symbol).Value,
Into => Follow_Set);
end Union_Follow_Sets;
end LALR_Sets_Pack;
--------------------------------------------------------------------------
use Relation, LALR_Sets_Pack;
procedure Make_LALR_Sets is
begin
Make_Dr_Sets;
Make_Reads_Relation;
Make_Read_Sets;
Make_Includes_Relation;
Make_Follow_Sets;
end Make_LALR_Sets;
--------------------------------------------------------------------------
use Grammar_Symbol_Set_Pack, Parse_State_Set_Pack;
procedure Get_LA(State_ID : Parse_State;
Item_ID : Item;
Look_Aheads : in out Grammar_Symbol_Set) is
Predecessors : Parse_State_Set;
Pred_Loop : Parse_State_Iterator;
Temp : Transition;
begin
Make_Null(Look_Aheads);
Temp.Symbol := Get_LHS(Item_ID.Rule_ID);
Make_Null(Predecessors);
Get_Pred_Set(State_ID, Item_ID ,Predecessors);
Initialize(Pred_Loop, Predecessors);
while More(Pred_Loop) loop
Next(Pred_Loop, Temp.State_ID);
Union_Follow_Sets(Temp, Look_Aheads);
end loop;
-- Free
Make_Null(Predecessors);
end Get_LA;
end LALR_Symbol_Info;
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- The primary authors of ayacc were David Taback and Deepak Tolani.
-- Enhancements were made by Ronald J. Schmalz.
--
-- Send requests for ayacc information to ayacc-info@ics.uci.edu
-- Send bug reports for ayacc to ayacc-bugs@ics.uci.edu
--
-- Redistribution and use in source and binary forms are permitted
-- provided that the above copyright notice and this paragraph are
-- duplicated in all such forms and that any documentation,
-- advertising materials, and other materials related to such
-- distribution and use acknowledge that the software was developed
-- by the University of California, Irvine. The name of the
-- University may not be used to endorse or promote products derived
-- from this software without specific prior written permission.
-- THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
-- IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
-- WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
-- Module : lexical_analyzer.ada
-- Component of : ayacc
-- Version : 1.2
-- Date : 11/21/86 12:30:26
-- SCCS File : disk21~/rschm/hasee/sccs/ayacc/sccs/sxlexical_analyzer.ada
-- $Header: lexical_analyzer.a,v 0.1 86/04/01 15:05:14 ada Exp $
-- $Log: lexical_analyzer.a,v $
-- Revision 0.1 86/04/01 15:05:14 ada
-- This version fixes some minor bugs with empty grammars
-- and $$ expansion. It also uses vads5.1b enhancements
-- such as pragma inline.
--
--
-- Revision 0.0 86/02/19 18:36:57 ada
--
-- These files comprise the initial version of Ayacc
-- designed and implemented by David Taback and Deepak Tolani.
-- Ayacc has been compiled and tested under the Verdix Ada compiler
-- version 4.06 on a vax 11/750 running Unix 4.2BSD.
--
with Source_File;
package Lexical_Analyzer is
function Get_Lexeme_Text return String; -- Scanned text.
type Ayacc_Token is
(Token, Start,
Left, Right, Nonassoc, Prec,
With_Clause, Use_Clause,
Identifier, Character_Literal,
Comma, Colon, Semicolon, Vertical_Bar, Left_Brace,
Mark, Eof_Token);
function Get_Token return Ayacc_Token;
function Line_Number return Natural; -- Current line of source file
procedure Handle_Action(Rule, Rule_Length : Integer);
procedure Print_Context_Lines renames Source_File.Print_Context_Lines;
procedure Dump_Declarations;
Illegal_Token : exception;
end Lexical_Analyzer;
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- The primary authors of ayacc were David Taback and Deepak Tolani.
-- Enhancements were made by Ronald J. Schmalz.
--
-- Send requests for ayacc information to ayacc-info@ics.uci.edu
-- Send bug reports for ayacc to ayacc-bugs@ics.uci.edu
--
-- Redistribution and use in source and binary forms are permitted
-- provided that the above copyright notice and this paragraph are
-- duplicated in all such forms and that any documentation,
-- advertising materials, and other materials related to such
-- distribution and use acknowledge that the software was developed
-- by the University of California, Irvine. The name of the
-- University may not be used to endorse or promote products derived
-- from this software without specific prior written permission.
-- THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
-- IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
-- WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
-- Module : lexical_analyzer_body.ada
-- Component of : ayacc
-- Version : 1.2
-- Date : 11/21/86 12:30:42
-- SCCS File : disk21~/rschm/hasee/sccs/ayacc/sccs/sxlexical_analyzer_body.ada
-- $Header: lexical_analyzer_body.a,v 0.1 86/04/01 15:05:27 ada Exp $
-- $Log: lexical_analyzer_body.a,v $
-- Revision 0.1 86/04/01 15:05:27 ada
-- This version fixes some minor bugs with empty grammars
-- and $$ expansion. It also uses vads5.1b enhancements
-- such as pragma inline.
--
--
-- Revision 0.0 86/02/19 18:37:05 ada
--
-- These files comprise the initial version of Ayacc
-- designed and implemented by David Taback and Deepak Tolani.
-- Ayacc has been compiled and tested under the Verdix Ada compiler
-- version 4.06 on a vax 11/750 running Unix 4.2BSD.
--
with Actions_File, Source_File, STR_Pack, Tokens_File, Text_IO;
use Actions_File, Source_File, STR_Pack, Tokens_File, Text_IO;
package body Lexical_Analyzer is
SCCS_ID : constant String := "@(#) lexical_analyzer_body.adadisk21~/rschm/hasee/sccs/ayacc, Version 1.2";
Rcs_ID : constant String := "$Header: lexical_analyzer_body.a,v 0.1 86/04/01 15:05:27 ada Exp $";
Max_Lexeme_Length : constant := 80;
Current_Line_Number: Natural := 1;
Lexeme_Text : STR(Max_Lexeme_Length);
function Get_Lexeme_Text return String is
begin
return Value_of(Lexeme_Text);
end Get_Lexeme_Text;
function Line_Number return Natural is
begin
return Source_Line_Number;
end Line_Number;
procedure Skip_Comment is
Ch: Character;
begin
loop
Get_Char(Ch);
if Ch = Eof then
Unget_Char(Ch);
exit;
elsif Ch = Eoln then
Current_Line_Number := Current_Line_Number + 1;
exit;
end if;
end loop;
end Skip_Comment;
function Get_Token return Ayacc_Token is
Ch: Character;
begin
loop
Assign("", To => Lexeme_Text);
loop
Get_Char(Ch);
if Ch = Eoln then
Current_Line_Number := Current_Line_Number + 1;
end if;
exit when Ch /= ' ' and then
Ch /= Eoln and then
Ch /= Ascii.Ht;
end loop;
case Ch is
when '-' =>
Get_Char(Ch);
if Ch = '-' then
Skip_Comment;
else
raise Illegal_Token;
end if;
when ':' =>
Append(Ch, To => Lexeme_Text);
return Colon;
when ';' =>
Append(Ch, To => Lexeme_Text);
return Semicolon;
when ',' =>
Append(Ch, To => Lexeme_Text);
return Comma;
when '%' =>
Append(Ch, To => Lexeme_Text);
if Peek_Next_Char = '%' then
Get_Char(Ch);
Append(Ch, To => Lexeme_Text);
return Mark;
else
loop
Get_Char(Ch);
if Ch not in 'A'..'Z' and then
Ch not in 'a'..'z' then
Unget_Char(Ch);
exit;
end if;
Append(Ch, To => Lexeme_Text);
end loop;
Upper_Case(Lexeme_Text);
if Value_of(Lexeme_Text) = "%TOKEN" then
return Token;
elsif Value_of(Lexeme_Text) = "%START" then
return Start;
elsif Value_of(Lexeme_Text) = "%LEFT" then
return Left;
elsif Value_of(Lexeme_Text) = "%RIGHT" then
return Right;
elsif Value_of(Lexeme_Text) = "%NONASSOC" then
return Nonassoc;
elsif Value_of(Lexeme_Text) = "%PREC" then
return Prec;
elsif Value_of (Lexeme_Text) = "%WITH" then
return With_Clause;
elsif Value_of (Lexeme_Text) = "%USE" then
return Use_Clause;
else
raise Illegal_Token;
end if;
end if;
when '|' =>
Append(Ch, To => Lexeme_Text);
return Vertical_Bar;
when '{' =>
Append(Ch, To => Lexeme_Text);
return Left_Brace;
when Eof =>
return Eof_Token;
when ''' =>
Append(Ch, To => Lexeme_Text);
Get_Char(Ch);
if Ch /= Eof and Ch /= Eoln then
Append(Ch, To => Lexeme_Text);
Get_Char(Ch);
if Ch /= ''' then
raise Illegal_Token;
else
Append(Ch, To => Lexeme_Text);
end if;
return Character_Literal;
end if;
when 'A'..'Z' | 'a'..'z' | '.' | '_' =>
Append(Ch, To => Lexeme_Text);
loop
Get_Char(Ch);
if Ch in 'a'..'z' or else
Ch in 'A'..'Z' or else
Ch in '0'..'9' or else
Ch = '.' or else
Ch = '_'
then
Append(Ch, To => Lexeme_Text);
else
Unget_Char(Ch);
exit;
end if;
end loop;
Upper_Case(Lexeme_Text);
return Identifier;
when others =>
raise Illegal_Token;
end case;
end loop;
end Get_Token;
procedure Handle_Action(Rule, Rule_Length : Integer) is
Char : Character;
Base : Integer;
begin
Actions_File.Writeln;
Actions_File.Write("when " & Integer'Image(Rule) & " =>");
Actions_File.Writeln;
Actions_File.Write("--#line " & Integer'Image(Current_Line_Number));
Actions_File.Writeln;
loop
Get_Char(Char);
if Char = '-' and then Peek_Next_Char = '-' then
loop
Actions_File.Write(Char);
Get_Char(Char);
exit when Char = Eoln;
end loop;
end if;
case Char is
when '"' =>
Actions_File.Write(Char);
loop
Get_Char(Char);
Actions_File.Write(Char);
exit when Char = '"';
end loop;
-- handle special case '"' where there is no matching ".
when ''' =>
Actions_File.Write(Char);
if Peek_Next_Char= '"' then
Get_Char(Char);
if Peek_Next_Char = ''' then
Actions_File.Write(Char); -- '"'
Get_Char(Char); -- '''
Actions_File.Write(Char);
else
UnGet_Char(Char); -- '"'
end if;
end if;
when '$' =>
Actions_File.Writeln;
Get_Char(Char);
if Char = '$' then
Actions_File.Write("yyval");
elsif Char in '0'..'9' then
Base := Character'Pos(Char) - Character'Pos('0');
while Peek_Next_Char in '0'..'9' loop
Get_Char(Char);
Base := Base * 10 +
Character'Pos(Char) - Character'Pos('0');
end loop;
if Base > Rule_Length then
Put_Line("Ayacc: Illegal use of $"&Integer'Image(Base));
raise Illegal_Token;
end if;
Base := Base - Rule_Length;
if Base = 0 then
Actions_File.Write("yy.value_stack(yy.tos)");
else
Actions_File.Write("yy.value_stack(yy.tos" &
Integer'Image(Base) & ")");
end if;
else
Put_Line("Ayacc: Illegal symbol following $");
raise Illegal_Token;
end if;
when Eoln =>
Actions_File.Writeln;
Current_Line_Number := Current_Line_Number + 1;
when '}' =>
exit;
when others =>
Actions_File.Write(Char);
end case;
end loop;
Actions_File.Writeln;
end Handle_Action;
procedure Dump_Declarations is
Ch : Character;
Text : STR(Source_File.Maximum_Line_Length);
begin
Assign("", To => Text);
loop
Get_Char(Ch);
exit when Ch = '}' ;
case Ch is
when '-' => Append(Ch, To => Text);
if Peek_Next_Char = '-' then
loop
Get_Char(Ch);
Append(Ch, To => Text);
exit when Peek_Next_Char = Eoln or
Peek_Next_Char = Eof;
end loop;
end if;
when '"' => Append(Ch, To => Text);
loop
Get_Char(Ch);
if Ch = Eoln or Ch = Eof then
raise Illegal_Token;
end if;
Append(Ch, To => Text);
exit when Ch = '"';
end loop;
when Eoln => Tokens_File.Writeln(Value_of(Text));
Assign("", To => Text);
Current_Line_Number := Current_Line_Number + 1;
when Eof => exit;
when others => Append(Ch, To => Text);
end case;
end loop;
Tokens_File.Writeln(Value_of(Text));
end Dump_Declarations;
end Lexical_Analyzer;
with Unchecked_Deallocation;
package body Lists is
procedure Free is
new Unchecked_Deallocation (Element_Type, Element_Pointer);
--------------------------------------------------------------------------
procedure Attach (List1 : in out List;
List2 : in List) is
Endoflist1 : Element_Pointer;
--| Attach List2 to List1.
--| If List1 is null return List2
--| If List1 equals List2 then raise CircularList
--| Otherwise get the pointer to the last element of List1 and change
--| its Next field to be List2.
begin
if List1.Head = null then
List1 := List2;
elsif List1 = List2 then
raise Circularlist;
else
Endoflist1 := List1.Tail;
Endoflist1.Next := List2.Head;
List1.Tail := List2.Tail;
end if;
end Attach;
--------------------------------------------------------------------------
procedure Attach (L : in out List;
Element : in Itemtype) is
Old_Tail, New_Element : Element_Pointer;
--| Create a list containing Element and attach it to the end of L
begin
New_Element := new Element_Type'(Item => Element, Next => null);
if L.Head = null then
L.Head := New_Element;
L.Tail := New_Element;
else
Old_Tail := L.Tail;
Old_Tail.Next := New_Element;
L.Tail := New_Element;
end if;
end Attach;
--------------------------------------------------------------------------
function Attach (Element1 : in Itemtype;
Element2 : in Itemtype) return List is
Newlist : List;
--| Create a new list containing the information in Element1 and
--| attach Element2 to that list.
begin
Newlist.Head := new Element_Type'(Item => Element1, Next => null);
Newlist.Tail := NewList.Head;
Attach (Newlist, Element2);
return Newlist;
end Attach;
--------------------------------------------------------------------------
procedure Attach (Element : in Itemtype;
L : in out List) is
--| Create a new cell whose information is Element and whose Next
--| field is the list L. This prepends Element to the List L.
Old_Head, New_Head : Element_Pointer;
begin
if L.Head = null then
L.Head := new Element_Type'(Item => Element, Next => null);
L.Tail := L.Head;
else
Old_Head := L.Head;
New_Head := new Element_Type'(Item => Element, Next => Old_Head);
L.Head := New_Head;
end if;
end Attach;
--------------------------------------------------------------------------
function Attach (List1 : in List;
List2 : in List) return List is
--| Attach List2 to List1.
--| If List1 is null return List2
--| If List1 equals List2 then raise CircularList
--| Otherwise get the pointer to the last element of List1 and change
--| its Next field to be List2.
End_Of_List1 : Element_Pointer;
New_List : List;
begin
if List1.Head = null then
return List2;
elsif List1 = List2 then
raise Circularlist;
else
End_Of_List1 := List1.Tail;
End_Of_List1.Next := List2.Head;
New_List.Head := List1.Head;
New_List.Tail := List2.Tail;
return New_List;
end if;
end Attach;
-------------------------------------------------------------------------
function Attach (L : in List;
Element : in Itemtype) return List is
New_Element : Element_Pointer;
New_List : List;
End_Of_List : Element_Pointer;
--| Create a list called New_List and attach it to the end of L.
--| If L is null return New_List
--| Otherwise get the last element in L and make its Next field
--| New_List.
begin
New_Element := new Element_Type'(Item => Element, Next => null);
if L.Head = null then
New_List := (Head => New_Element, Tail => New_Element);
else
End_Of_List := L.Tail;
End_Of_List.Next := New_Element;
New_List := (Head => L.Head, Tail => New_Element);
end if;
return New_List;
end Attach;
--------------------------------------------------------------------------
function Attach (Element : in Itemtype;
L : in List) return List is
New_Element : Element_Pointer;
begin
if L.Head = null then
New_Element := new Element_Type'(Item => Element, Next => null);
return (Head => New_Element, Tail => New_Element);
else
New_Element := new Element_Type'(Item => Element, Next => L.Head);
return (Head => New_Element, Tail => L.Tail);
end if;
end Attach;
--------------------------------------------------------------------------
function Copy (L : in List) return List is
--| If L is null return null
--| Otherwise recursively copy the list by first copying the information
--| at the head of the list and then making the Next field point to
--| a copy of the tail of the list.
Current_Element : Element_Pointer := L.Head;
New_List : List := (Head => null, Tail => null);
begin
while Current_Element /= null loop
Attach (New_List, Current_Element.Item);
Current_Element := Current_Element.Next;
end loop;
return New_List;
end Copy;
--------------------------------------------------------------------------
--generic
-- with function Copy (I : in Itemtype) return Itemtype;
function Copydeep (L : in List) return List is
--| If L is null then return null.
--| Otherwise copy the first element of the list into the head of the
--| new list and copy the tail of the list recursively using CopyDeep.
Current_Element : Element_Pointer := L.Head;
New_List : List := (Head => null, Tail => null);
begin
while Current_Element /= null loop
Attach (New_List, Copy (Current_Element.Item));
Current_Element := Current_Element.next;
end loop;
return New_List;
end Copydeep;
--------------------------------------------------------------------------
function Create return List is
--| Return the empty list.
begin
return (Head => null, Tail => null);
end Create;
--------------------------------------------------------------------------
procedure Deletehead (L : in out List) is
New_Head : Element_Pointer;
--| Remove the element of the head of the list and return it to the heap.
--| If L is null EmptyList.
--| Otherwise save the Next field of the first element, remove the first
--| element and then assign to L the Next field of the first element.
begin
if L.Head = null then
raise Emptylist;
else
New_Head := L.Head.Next;
Free (L.Head);
L.Head := New_Head;
end if;
end Deletehead;
--------------------------------------------------------------------------
procedure Deleteitem (L : in out List;
Element : in Itemtype) is
--| Remove the first element in the list with the value Element.
--| If the first element of the list is equal to element then
--| remove it. Otherwise, recurse on the tail of the list.
Current_Element, Previous_Element : Element_Pointer;
begin
if L.Head = null then
raise Itemnotpresent;
elsif Equal (L.Head.Item, Element) then
Deletehead (L);
else
Current_Element := L.Head.Next;
Previous_Element := L.Head;
while Current_Element /= null and then
not Equal (Current_Element.Item, Element) loop
Previous_Element := Current_Element;
Current_Element := Current_Element.Next;
end loop;
if Current_Element = null then
raise Itemnotpresent;
else
if Current_Element = L.Tail then
L.Tail := Previous_Element;
end if;
Previous_Element.Next := Current_Element.Next;
Free (Current_Element);
end if;
end if;
end Deleteitem;
--------------------------------------------------------------------------
procedure Deleteitems (L : in out List;
Element : in Itemtype) is
Delete_List_Is_Empty : Boolean := True;
New_List_Is_Empty : Boolean := True;
Old_Tail : Element_Pointer;
Current_Element : Element_Pointer := L.Head;
New_List, Delete_List : List;
procedure Append (Element : in out Element_Pointer;
To_List : in out List) is
begin
if To_List.Head = null then
To_List.Head := Element;
To_List.Tail := Element;
else
Old_Tail := To_List.Tail;
To_List.Tail := Element;
Old_Tail.Next := To_List.Tail;
end if;
end Append;
begin
while Current_Element /= null loop
if Equal (Current_Element.Item, Element) then
Append (Element => Current_Element,
To_List => Delete_List);
Delete_List_Is_Empty := False;
else
Append (Element => Current_Element,
To_List => New_List);
New_List_Is_Empty := False;
end if;
Current_Element := Current_Element.Next;
end loop;
if Delete_List_Is_Empty then
raise Itemnotpresent;
else
Delete_List.Tail.Next := null;
Destroy (Delete_List);
end if;
if not New_List_Is_Empty then
New_List.Tail.Next := null;
end if;
L := New_List;
end Deleteitems;
--------------------------------------------------------------------------
procedure Destroy (L : in out List) is
Current_Element : Element_Pointer := L.Head;
Element_To_Delete : Element_Pointer;
--| Walk down the list removing all the elements and set the list to
--| the empty list.
begin
if L.Head /= null then
while Current_Element /= null loop
Element_To_Delete := Current_Element;
Current_Element := Current_Element.Next;
Free (Element_To_Delete);
end loop;
L := (Head => null, Tail => null);
end if;
end Destroy;
--------------------------------------------------------------------------
function Firstvalue (L : in List) return Itemtype is
--| Return the first value in the list.
begin
if L.Head = null then
raise Emptylist;
else
return L.Head.Item;
end if;
end Firstvalue;
--------------------------------------------------------------------------
function Isinlist (L : in List;
Element : in Itemtype) return Boolean is
Current_Element : Element_Pointer := L.Head;
--| Check if Element is in L. If it is return true otherwise return false.
begin
while Current_Element /= null and then
not Equal (Current_Element.Item, Element) loop
Current_Element := Current_Element.Next;
end loop;
return Current_Element /= null;
end Isinlist;
--------------------------------------------------------------------------
function Isempty (L : in List) return Boolean is
--| Is the list L empty.
begin
return L.Head = null;
end Isempty;
--------------------------------------------------------------------------
function Lastvalue (L : in List) return Itemtype is
--| Return the value of the last element of the list. Get the pointer
--| to the last element of L and then return its information.
begin
if L.Head = null then
raise Emptylist;
else
return L.Tail.Item;
end if;
end Lastvalue;
--------------------------------------------------------------------------
function Length (L : in List) return Integer is
--| Recursively compute the length of L. The length of a list is
--| 0 if it is null or 1 + the length of the tail.
Current_Element : Element_Pointer := L.Head;
List_Length : Natural := 0;
begin
while Current_Element /= null loop
List_Length := List_Length + 1;
Current_Element := Current_Element.Next;
end loop;
return List_Length;
end Length;
--------------------------------------------------------------------------
function Makelistiter (L : in List) return Listiter is
--| Start an iteration operation on the list L. Do a type conversion
--| from List to ListIter.
begin
return Listiter (L);
end Makelistiter;
--------------------------------------------------------------------------
function More (L : in Listiter) return Boolean is
--| This is a test to see whether an iteration is complete.
begin
return L.Head /= null;
end More;
--------------------------------------------------------------------------
procedure Next (Place : in out Listiter;
Info : out Itemtype) is
--| This procedure gets the information at the current place in the List
--| and moves the ListIter to the next postion in the list.
--| If we are at the end of a list then exception NoMore is raised.
Next_Element : Element_Pointer := Place.Head;
begin
if Next_Element = null then
raise Nomore;
else
Info := Next_Element.Item;
Place.Head := Next_Element.Next;
end if;
end Next;
--------------------------------------------------------------------------
procedure Replacehead (L : in out List;
Info : in Itemtype) is
--| This procedure replaces the information at the head of a list
--| with the given information. If the list is empty the exception
--| EmptyList is raised.
begin
if L.Head = null then
raise Emptylist;
else
L.Head.Item := Info;
end if;
end Replacehead;
--------------------------------------------------------------------------
procedure Replacetail (L : in out List;
Newtail : in List) is
List_Head_Item : Itemtype;
--| This destroys the tail of a list and replaces the tail with
--| NewTail. If L is empty EmptyList is raised.
begin
if L.Head = null then
raise Emptylist;
else
List_Head_Item := L.Head.Item;
Destroy (L);
L := Attach (List_Head_Item, Newtail);
end if;
end Replacetail;
--------------------------------------------------------------------------
function Tail (L : in List) return List is
--| This returns the list which is the tail of L. If L is null Empty
--| List is raised.
begin
if L.Head = null then
raise Emptylist;
else
return (Head => L.Head.Next, Tail => L.Tail);
end if;
end Tail;
--------------------------------------------------------------------------
function Equal (List1 : in List;
List2 : in List) return Boolean is
Placeinlist1 : Element_Pointer := List1.Head;
Placeinlist2 : Element_Pointer := List2.Head;
Contents1 : Itemtype;
Contents2 : Itemtype;
--| This function tests to see if two lists are equal. Two lists
--| are equal if for all the elements of List1 the corresponding
--| element of List2 has the same value. Thus if the 1st elements
--| are equal and the second elements are equal and so up to n.
--| Thus a necessary condition for two lists to be equal is that
--| they have the same number of elements.
--| This function walks over the two list and checks that the
--| corresponding elements are equal. As soon as we reach
--| the end of a list (PlaceInList = null) we fall out of the loop.
--| If both PlaceInList1 and PlaceInList2 are null after exiting the loop
--| then the lists are equal. If they both are not null the lists aren't
--| equal. Note that equality on elements is based on a user supplied
--| function Equal which is used to test for item equality.
begin
while (Placeinlist1 /= null) and then (Placeinlist2 /= null) loop
if not Equal (Placeinlist1.Item, Placeinlist2.Item) then
return False;
end if;
Placeinlist1 := Placeinlist1.Next;
Placeinlist2 := Placeinlist2.Next;
end loop;
return ((Placeinlist1 = null) and then (Placeinlist2 = null));
end Equal;
end Lists;
generic
type Itemtype is private; --| This is the data being manipulated.
with function Equal (X, Y : in Itemtype) return Boolean is "=";
--| This allows the user to define
--| equality on ItemType. For instance
--| if ItemType is an abstract type
--| then equality is defined in terms of
--| the abstract type. If this function
--| is not provided equality defaults to
--| =.
package Lists is
--| This package provides singly linked lists with elements of type
--| ItemType, where ItemType is specified by a generic parameter.
--| Overview
--| When this package is instantiated, it provides a linked list type for
--| lists of objects of type ItemType, which can be any desired type. A
--| complete set of operations for manipulation, and releasing
--| those lists is also provided. For instance, to make lists of strings,
--| all that is necessary is:
--|
--| type StringType is string(1..10);
--|
--| package Str_List is new Lists(StringType); use Str_List;
--|
--| L:List;
--| S:StringType;
--|
--| Then to add a string S, to the list L, all that is necessary is
--|
--| L := Create;
--| Attach(S,L);
--|
--|
--| This package provides basic list operations.
--|
--| Attach append an object to an object, an object to a list,
--| or a list to an object, or a list to a list.
--| Copy copy a list using := on elements
--| CopyDeep copy a list by copying the elements using a copy
--| operation provided by the user
--| Create Creates an empty list
--| DeleteHead removes the head of a list
--| DeleteItem delete the first occurrence of an element from a list
--| DeleteItems delete all occurrences of an element from a list
--| Destroy remove a list
--| Equal are two lists equal
--| FirstValue get the information from the first element of a list
--| IsInList determines whether a given element is in a given list
--| IsEmpty returns true if the list is empty
--| LastValue return the last value of a list
--| Length Returns the length of a list
--| MakeListIter prepares for an iteration over a list
--| More are there any more items in the list
--| Next get the next item in a list
--| ReplaceHead replace the information at the head of the list
--| ReplaceTail replace the tail of a list with a new list
--| Tail get the tail of a list
--|
--| N/A: Effects, Requires, Modifies, and Raises.
--| Notes
--| Programmer Buddy Altus
--| Types
--| -----
type List is private;
type Listiter is private;
--| Exceptions
--| ----------
Circularlist : exception; --| Raised if an attemp is made to
--| create a circular list. This
--| results when a list is attempted
--| to be attached to itself.
Emptylist : exception; --| Raised if an attemp is made to
--| manipulate an empty list.
Itemnotpresent : exception; --| Raised if an attempt is made to
--| remove an element from a list in
--| which it does not exist.
Nomore : exception; --| Raised if an attemp is made to
--| get the next element from a list
--| after iteration is complete.
--| Operations
--| ----------
----------------------------------------------------------------------------
procedure Attach ( --| appends List2 to List1
List1 : in out List; --| The list being appended to.
List2 : in List --| The list being appended.
);
--| Raises
--| CircularList
--| Effects
--| Appends List1 to List2. This makes the next field of the last element
--| of List1 refer to List2. This can possibly change the value of List1
--| if List1 is an empty list. This causes sharing of lists. Thus if
--| user Destroys List1 then List2 will be a dangling reference.
--| This procedure raises CircularList if List1 equals List2. If it is
--| necessary to Attach a list to itself first make a copy of the list and
--| attach the copy.
--| Modifies
--| Changes the next field of the last element in List1 to be List2.
-------------------------------------------------------------------------------
function Attach ( --| Creates a new list containing the two
--| Elements.
Element1 : in Itemtype;
--| This will be first element in list.
Element2 : in Itemtype
--| This will be second element in list.
) return List;
--| Effects
--| This creates a list containing the two elements in the order
--| specified.
-------------------------------------------------------------------------------
procedure Attach ( --| List L is appended with Element.
L : in out List; --| List being appended to.
Element : in Itemtype
--| This will be last element in l ist.
);
--| Effects
--| Appends Element onto the end of the list L. If L is empty then this
--| may change the value of L.
--|
--| Modifies
--| This appends List L with Element by changing the next field in List.
--------------------------------------------------------------------------------
procedure Attach ( --| Makes Element first item in list L.
Element : in Itemtype;
--| This will be the first element in list.
L : in out List --| The List which Element is being
--| prepended to.
);
--| Effects
--| This prepends list L with Element.
--|
--| Modifies
--| This modifies the list L.
--------------------------------------------------------------------------
function Attach ( --| attaches two lists
List1 : in List; --| first list
List2 : in List --| second list
) return List;
--| Raises
--| CircularList
--| Effects
--| This returns a list which is List1 attached to List2. If it is desired
--| to make List1 be the new attached list the following ada code should be
--| used.
--|
--| List1 := Attach (List1, List2);
--| This procedure raises CircularList if List1 equals List2. If it is
--| necessary to Attach a list to itself first make a copy of the list and
--| attach the copy.
-------------------------------------------------------------------------
function Attach ( --| prepends an element onto a list
Element : in Itemtype; --| element being prepended to list
L : in List --| List which element is being added
--| to
) return List;
--| Effects
--| Returns a new list which is headed by Element and followed by L.
------------------------------------------------------------------------
function Attach ( --| Adds an element to the end of a list
L : in List;
--| The list which element is being added to.
Element : in Itemtype
--| The element being added to the end of
--| the list.
) return List;
--| Effects
--| Returns a new list which is L followed by Element.
--------------------------------------------------------------------------
function Copy ( --| returns a copy of list1
L : in List --| list being copied
) return List;
--| Effects
--| Returns a copy of L.
--------------------------------------------------------------------------
generic
with function Copy (I : in Itemtype) return Itemtype;
function Copydeep ( --| returns a copy of list using a user supplied
--| copy function. This is helpful if the type
--| of a list is an abstract data type.
L : in List --| List being copied.
) return List;
--| Effects
--| This produces a new list whose elements have been duplicated using
--| the Copy function provided by the user.
------------------------------------------------------------------------------
function Create --| Returns an empty List
return List;
------------------------------------------------------------------------------
procedure Deletehead ( --| Remove the head element from a list.
L : in out List --| The list whose head is being removed.
);
--| Raises
--| EmptyList
--|
--| Effects
--| This will return the space occupied by the first element in the list
--| to the heap. If sharing exists between lists this procedure
--| could leave a dangling reference. If L is empty EmptyList will be
--| raised.
------------------------------------------------------------------------------
procedure Deleteitem ( --| remove the first occurrence of Element
--| from L
L : in out List;
--| list element is being removed from
Element : in Itemtype --| element being removed
);
--| Raises
--| ItemNotPresent
--| Effects
--| Removes the first element of the list equal to Element. If there is
--| not an element equal to Element than ItemNotPresent is raised.
--| Modifies
--| This operation is destructive, it returns the storage occupied by
--| the elements being deleted.
------------------------------------------------------------------------------
procedure Deleteitems ( --| remove all occurrences of Element
--| from L.
L : in out List;
--| The List element is being removed from
Element : in Itemtype --| element being removed
);
--| Raises
--| ItemNotPresent
--|
--| Effects
--| This procedure walks down the list L and removes all elements of the
--| list equal to Element. If there are not any elements equal to Element
--| then raise ItemNotPresent.
--| Modifies
--| This operation is destructive the storage occupied by the items
--| removed is returned.
------------------------------------------------------------------------------
procedure Destroy ( --| removes the list
L : in out List --| the list being removed
);
--| Effects
--| This returns to the heap all the storage that a list occupies. Keep in
--| mind if there exists sharing between lists then this operation can leave
--| dangling references.
------------------------------------------------------------------------------
function Firstvalue ( --| returns the contents of the first record of the
--| list
L : in List --| the list whose first element is being
--| returned
) return Itemtype;
--| Raises
--| EmptyList
--|
--| Effects
--| This returns the Item in the first position in the list. If the list
--| is empty EmptyList is raised.
-------------------------------------------------------------------------------
function Isempty ( --| Checks if a list is empty.
L : in List --| List being checked.
) return Boolean;
-- Pragma Inline (Isempty);
--------------------------------------------------------------------------
function Isinlist ( --| Checks if element is an element of
--| list.
L : in List; --| list being scanned for element
Element : in Itemtype --| element being searched for
) return Boolean;
--| Effects
--| Walks down the list L looking for an element whose value is Element.
------------------------------------------------------------------------------
function Lastvalue ( --| Returns the contents of the last record of
--| the list.
L : in List --| The list whose first element is being
--| returned.
) return Itemtype;
--| Raises
--| EmptyList
--|
--| Effects
--| Returns the last element in a list. If the list is empty EmptyList is
--| raised.
------------------------------------------------------------------------------
function Length ( --| count the number of elements on a list
L : in List --| list whose length is being computed
) return Integer;
------------------------------------------------------------------------------
function Makelistiter ( --| Sets a variable to point to the head
--| of the list. This will be used to
--| prepare for iteration over a list.
L : in List --| The list being iterated over.
) return Listiter;
--| This prepares a user for iteration operation over a list. The iterater is
--| an operation which returns successive elements of the list on successive
--| calls to the iterator. There needs to be a mechanism which marks the
--| position in the list, so on successive calls to the Next operation the
--| next item in the list can be returned. This is the function of the
--| MakeListIter and the type ListIter. MakeIter just sets the Iter to the
--| the beginning of the list. On subsequent calls to Next the Iter
--| is updated with each call.
-----------------------------------------------------------------------------
function More ( --| Returns true if there are more elements in
--| the and false if there aren't any more
--| the in the list.
L : in Listiter --| List being checked for elements.
) return Boolean;
-- Pragma Inline (More);
------------------------------------------------------------------------------
procedure Next ( --| This is the iterator operation. Given
--| a ListIter in the list it returns the
--| current item and updates the ListIter.
--| If ListIter is at the end of the list,
--| More returns false otherwise it
--| returns true.
Place : in out Listiter;
--| The Iter which marks the position in
--| the list.
Info : out Itemtype --| The element being returned.
);
--| The iterators subprograms MakeListIter, More, and Next should be used
--| in the following way:
--|
--| L: List;
--| Place: ListIter;
--| Info: SomeType;
--|
--|
--| Place := MakeListIter(L);
--|
--| while ( More(Place) ) loop
--| Next(Place, Info);
--| process each element of list L;
--| end loop;
----------------------------------------------------------------------------
procedure Replacehead ( --| Replace the Item at the head of the list
--| with the parameter Item.
L : in out List; --| The list being modified.
Info : in Itemtype --| The information being entered.
);
--| Raises
--| EmptyList
--| Effects
--| Replaces the information in the first element in the list. Raises
--| EmptyList if the list is empty.
------------------------------------------------------------------------------
procedure Replacetail ( --| Replace the Tail of a list
--| with a new list.
L : in out List; --| List whose Tail is replaced.
Newtail : in List --| The list which will become the
--| tail of Oldlist.
);
--| Raises
--| EmptyList
--|
--| Effects
--| Replaces the tail of a list with a new list. If the list whose tail
--| is being replaced is null EmptyList is raised.
-------------------------------------------------------------------------------
function Tail ( --| returns the tail of a list L
L : in List --| the list whose tail is being returned
) return List;
--| Raises
--| EmptyList
--|
--| Effects
--| Returns a list which is the tail of the list L. Raises EmptyList if
--| L is empty. If L only has one element then Tail returns the Empty
--| list.
------------------------------------------------------------------------------
function Equal ( --| compares list1 and list2 for equality
List1 : in List; --| first list
List2 : in List --| second list
) return Boolean;
--| Effects
--| Returns true if for all elements of List1 the corresponding element
--| of List2 has the same value. This function uses the Equal operation
--| provided by the user. If one is not provided then = is used.
------------------------------------------------------------------------------
private
type Element_Type;
type Element_Pointer is access Element_Type;
-- type List is access element_type;
type List is
record
Head : Element_Pointer;
Tail : Element_Pointer;
end record;
type Element_Type is
record
Item : Itemtype;
Next : Element_Pointer;
end record;
type Listiter is new List; --| This prevents Lists being assigned to
--| iterators and vice versa
end Lists;
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- The primary authors of ayacc were David Taback and Deepak Tolani.
-- Enhancements were made by Ronald J. Schmalz.
--
-- Send requests for ayacc information to ayacc-info@ics.uci.edu
-- Send bug reports for ayacc to ayacc-bugs@ics.uci.edu
--
-- Redistribution and use in source and binary forms are permitted
-- provided that the above copyright notice and this paragraph are
-- duplicated in all such forms and that any documentation,
-- advertising materials, and other materials related to such
-- distribution and use acknowledge that the software was developed
-- by the University of California, Irvine. The name of the
-- University may not be used to endorse or promote products derived
-- from this software without specific prior written permission.
-- THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
-- IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
-- WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
-- Module : lr0_machine.ada
-- Component of : ayacc
-- Version : 1.2
-- Date : 11/21/86 12:30:58
-- SCCS File : disk21~/rschm/hasee/sccs/ayacc/sccs/sxlr0_machine.ada
-- $Header: lr0_machine.a,v 0.1 86/04/01 15:06:19 ada Exp $
-- $Log: lr0_machine.a,v $
-- Revision 0.1 86/04/01 15:06:19 ada
-- This version fixes some minor bugs with empty grammars
-- and $$ expansion. It also uses vads5.1b enhancements
-- such as pragma inline.
--
--
-- Revision 0.0 86/02/19 18:37:14 ada
--
-- These files comprise the initial version of Ayacc
-- designed and implemented by David Taback and Deepak Tolani.
-- Ayacc has been compiled and tested under the Verdix Ada compiler
-- version 4.06 on a vax 11/750 running Unix 4.2BSD.
--
with Rule_Table, Symbol_Table, Set_Pack;
use Rule_Table, Symbol_Table;
package LR0_Machine is
type Parse_State is range -1..5_000;
Null_Parse_State : constant Parse_State := -1;
type Item is
record
Rule_ID : Rule;
Dot_Position : Natural;
end record;
type Transition is
record
Symbol : Grammar_Symbol;
State_ID : Parse_State;
end record;
function "<" (Item_1, Item_2 : Item) return Boolean;
function "<" (Trans_1, Trans_2 : Transition) return Boolean;
package Parse_State_Set_Pack is new Set_Pack(Parse_State, "<");
package Item_Set_Pack is new Set_Pack(Item, "<");
package Transition_Set_Pack is new Set_Pack(Transition, "<");
package Grammar_Symbol_Set_Pack is new Set_Pack(Grammar_Symbol, "<");
subtype Parse_State_Set is Parse_State_Set_Pack.Set;
subtype Item_Set is Item_Set_Pack.Set;
subtype Transition_Set is Transition_Set_Pack.Set;
subtype Grammar_Symbol_Set is Grammar_Symbol_Set_Pack.Set;
subtype Parse_State_Iterator is Parse_State_Set_Pack.Set_Iterator;
subtype Item_Iterator is Item_Set_Pack.Set_Iterator;
subtype Transition_Iterator is Transition_Set_Pack.Set_Iterator;
subtype Grammar_Symbol_Iterator is Grammar_Symbol_Set_Pack.Set_Iterator;
procedure LR0_Initialize; -- must be called first.
function First_Parse_State return Parse_State;
function Last_Parse_State return Parse_State;
function Get_Goto
(State_ID : Parse_State;
Sym : Grammar_Symbol) return Parse_State;
-- Returns the predecessor states of STATE_ID and the item I.
-- Must be called with PRED_SET empty!
procedure Get_Pred_Set
(State_ID : in Parse_State;
I : in Item;
Pred_Set : in out Parse_State_Set);
type Transition_Type is (Terminals, Nonterminals, Grammar_Symbols);
procedure Get_Transitions
(State_ID : in Parse_State;
Kind : in Transition_Type;
Set_1 : in out Transition_Set);
procedure Get_Transition_Symbols
(State_ID : in Parse_State;
Kind : in Transition_Type;
Set_1 : in out Grammar_Symbol_Set);
procedure Get_Kernel
(State_ID : in Parse_State;
Set_1 : in out Item_Set);
procedure Closure (Set_1 : in out Item_Set);
--
-- The following routines allow the user to iterate over the
-- items in the kernel of a particular state.
--
type Kernel_Iterator is limited private;
procedure Initialize
(Iterator : in out Kernel_Iterator;
State_ID : in Parse_State);
function More(Iterator : Kernel_Iterator) return Boolean;
procedure Next(Iterator : in out Kernel_Iterator; I : out Item);
--
-- The following routines allow the user to iterate over the
-- nonterminal transitions of a particular state
--
type Nt_Transition_Iterator is limited private;
procedure Initialize
(Iterator : in out Nt_Transition_Iterator;
State_ID : in Parse_State);
function More (Iterator : Nt_Transition_Iterator) return Boolean;
procedure Next
(Iterator : in out Nt_Transition_Iterator;
Trans : out Transition);
-- The following routines allow iteration over the Terminal transitions
-- of a particular state.
type T_Transition_Iterator is limited private; -- For Terminals
procedure Initialize
(Iterator : in out T_Transition_Iterator;
State_ID : in Parse_State);
function More (Iterator : T_Transition_Iterator) return Boolean;
procedure Next
(Iterator : in out T_Transition_Iterator;
Trans : out Transition);
To_Many_States : exception;
No_More_Iterations : exception;
State_Out_of_Bounds : exception;
--RJS pragma inline(more); --DEC Ada Bug: , next);
private
type Item_Array_Index is range 0..5_000; -- An arbitrarily big number
type Item_Array;
type Item_Array_Pointer is access Item_Array;
type Kernel_Iterator is
record
Kernel : Item_Array_Pointer;
Curser : Item_Array_Index;
end record;
type Transition_Array;
type Transition_Array_Pointer is access Transition_Array;
type Nt_Transition_Iterator is
record
Nonterm_Trans : Transition_Array_Pointer;
Curser : Integer; -- Use a derived type instead ???
end record;
type T_Transition_Iterator is
record
Term_Trans : Transition_Array_Pointer;
Curser : Integer;
end record;
end LR0_Machine;
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- The primary authors of ayacc were David Taback and Deepak Tolani.
-- Enhancements were made by Ronald J. Schmalz.
--
-- Send requests for ayacc information to ayacc-info@ics.uci.edu
-- Send bug reports for ayacc to ayacc-bugs@ics.uci.edu
--
-- Redistribution and use in source and binary forms are permitted
-- provided that the above copyright notice and this paragraph are
-- duplicated in all such forms and that any documentation,
-- advertising materials, and other materials related to such
-- distribution and use acknowledge that the software was developed
-- by the University of California, Irvine. The name of the
-- University may not be used to endorse or promote products derived
-- from this software without specific prior written permission.
-- THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
-- IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
-- WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
-- Module : lr0_machine_body.ada
-- Component of : ayacc
-- Version : 1.2
-- Date : 11/21/86 12:31:19
-- SCCS File : disk21~/rschm/hasee/sccs/ayacc/sccs/sxlr0_machine_body.ada
-- $Header: lr0_machine_body.a,v 0.1 86/04/01 15:06:56 ada Exp $
-- $Log: lr0_machine_body.a,v $
-- Revision 0.1 86/04/01 15:06:56 ada
-- This version fixes some minor bugs with empty grammars
-- and $$ expansion. It also uses vads5.1b enhancements
-- such as pragma inline.
--
--
-- Revision 0.0 86/02/19 18:37:23 ada
--
-- These files comprise the initial version of Ayacc
-- designed and implemented by David Taback and Deepak Tolani.
-- Ayacc has been compiled and tested under the Verdix Ada compiler
-- version 4.06 on a vax 11/750 running Unix 4.2BSD.
--
with Symbol_Info, Text_IO;
use Text_IO;
package body LR0_Machine is
SCCS_ID : constant String := "@(#) lr0_machine_body.ada, Version 1.2";
use Parse_State_Set_Pack;
use Item_Set_Pack;
use Grammar_Symbol_Set_Pack;
use Transition_Set_Pack;
type Item_Array is array (Item_Array_Index range <>) of Item;
-- The type declarations for storing the nonterminal transitions of
-- the DFA in the states.
type Transition_Array is
array(Integer range <>) of Transition;
-- Note: terminal_goto is not yet used.
type State is
record
Nonterminal_Goto : Transition_Array_Pointer := null;
--& terminal_goto : transition_array_pointer := null;
Kernel : Item_Array_Pointer := null;
Preds : Parse_State_Set;
end record;
type State_Array is array (Parse_State range <>) of State;
type State_Array_Pointer is access State_Array;
--& Due to a bug in the Verdix 4.06 compiler, we cannot have the
--& 'terminal_goto' declaration in type state. (Everything will compile,
--& but when it is run we get a bus error.)
--& The following declarations are used to get around the Verdix bug.
type State_2 is
record
Terminal_Goto : Transition_Array_Pointer := null;
end record;
type State_Array_2 is array(Parse_State range <>) of State_2;
type State_Array_Pointer_2 is access State_Array_2;
State_Info_2 : State_Array_Pointer_2;
--& End of Verdix bug fix.
First_State : constant Parse_State := 0;
Last_State : Parse_State;
Max_State : Parse_State; -- estimated max
State_Info : State_Array_Pointer := null;
-- The pointer to array of state information.
Estimated_Number_of_States : Integer;
-- --
-- The following arrays are used for looking up a state given --
-- the transition symbol. TERMINAL_GOTOS holds the states that --
-- have terminal transitions into them, NONTERMINAL_GOTOS holds --
-- states that have nonterminal transitions into them and --
-- OVERFLOW_GOTOS holds the overflow from the previous arrays. --
-- --
type Goto_Array is array (Grammar_Symbol range <>) of Parse_State;
type Overflow_Array is array (Parse_State range<>) of Parse_State;
type Goto_Array_Pointer is access Goto_Array;
type Overflow_Array_Pointer is access Overflow_Array;
Terminal_Gotos : Goto_Array_Pointer;
Nonterminal_Gotos : Goto_Array_Pointer;
Overflow_Gotos : Overflow_Array_Pointer;
-- This array is used to store the items generated by get_closure
-- and closure.
-- It is also declared to work around a VADS 5.1b bug for arrays whose
-- bounds are set when the procedure is called (the memory is not
-- dealocated when the procedure is exited).
Closure_Items : Item_Array_Pointer;
type Boolean_Array is array(Grammar_Symbol range <>) of Boolean;
type Boolean_Array_Pointer is access Boolean_Array;
Examined_Symbols : Boolean_Array_Pointer;
------------------------------------------------------------------------------
function Find_State
(Kernel_Set : Item_Set;
Trans_Sym : Grammar_Symbol) return Parse_State;
function "<" (Item_1, Item_2: Item) return Boolean is
begin
if Item_1.Rule_ID = Item_2.Rule_ID then
return Item_1.Dot_Position < Item_2.Dot_Position;
else
return Item_1.Rule_ID < Item_2.Rule_ID;
end if;
end "<";
function "<" (Trans_1, Trans_2: Transition) return Boolean is
begin
if Trans_1.Symbol = Trans_2.Symbol then
return Trans_1.State_ID < Trans_2.State_ID;
else
return Trans_1.Symbol < Trans_2.Symbol;
end if;
end "<";
procedure Get_Closure
(State_ID : in Parse_State;
Closure_Items : in Item_Array_Pointer;
Last : out Item_Array_Index);
procedure Make_LR0_States is
Goto_Set : Item_Set;
Current_State : Parse_State;
Goto_State : Parse_State;
Gotos : Transition_Array_Pointer;
Nt_Trans : Transition;
Nt_Trans_Set : Transition_Set;
Nt_Trans_Iter : Transition_Iterator;
T_Trans : Transition;
T_Trans_Set : Transition_Set;
T_Trans_Iter : Transition_Iterator;
I : Item;
Sym : Grammar_Symbol;
Last : Item_Array_Index; -- The last item in closure_items.
Kernel : Item_Array_Pointer;
Did_Goto :
array(First_Symbol(Nonterminal)..Last_Symbol(Terminal)) of
Boolean; -- did_goto(sym) = True if computed goto for sym.
begin
Current_State := 0;
Generate_States:
loop
--& VADS version 4.06 corrupts memory on the following statement
--& did_goto := (others => false);
--& Therefore, we do it the hard way.
for S in Did_Goto'range loop
Did_Goto(S) := False;
end loop;
--& End bug hack.
Make_Null(Nt_Trans_Set);
Make_Null(T_Trans_Set);
Get_Closure(Current_State, Closure_Items, Last);
-- generate goto's for current state --
-- This is somewhat hacked but...
-- For simplicity, the kernel Items are appended to
-- the end of the CLOSURE_ITEMS array so that the
-- reflexive transitive closure of the state is in closure_items.
-- (GET_CLOSURE only puts the transitive closure
-- into closure_items).
-- This assumes that CLOSURE_ITEMS is large enough to hold the
-- closure + kernel. This assumtion should hold for all
-- but contrived grammars (I hope).
Kernel := State_Info(Current_State).Kernel;
for Item_Index in Kernel.all'range loop
Last := Last + 1;
Closure_Items(Last) := Kernel(Item_Index);
end loop;
for Item_Index in 1..Last loop
I := Closure_Items(Item_Index);
if I.Dot_Position < Length_of(I.Rule_ID) then
Sym := Get_RHS(I.Rule_ID, I.Dot_Position + 1);
-- generate goto on SYM if not done yet.
if not Did_Goto(Sym) then
Did_Goto(Sym) := True;
-- get the items in goto of sym
Make_Null(Goto_Set);
I.Dot_Position := I.Dot_Position + 1;
Insert(I, Into => Goto_Set);
for J in Item_Index+1..Last loop
I := Closure_Items(J);
if I.Dot_Position < Length_of(I.Rule_ID) then
I.Dot_Position := I.Dot_Position + 1;
if Get_RHS(I.Rule_ID, I.Dot_Position) = Sym
then
Insert(I, Into => Goto_Set);
end if;
end if;
end loop;
Goto_State := Find_State(Goto_Set, Sym);
Make_Null(Goto_Set);
if Is_Nonterminal(Sym) then
Nt_Trans := (Symbol => Sym, State_ID => Goto_State);
Insert(Nt_Trans, Into => Nt_Trans_Set);
else -- terminal transition
T_Trans := (Symbol => Sym, State_ID => Goto_State);
Insert(T_Trans, Into => T_Trans_Set);
end if;
Insert(Current_State,
Into => State_Info(Goto_State).Preds);
end if;
end if;
end loop;
-- at this point, all the goto's for the current
-- state have been generated.
State_Info(Current_State).Nonterminal_Goto :=
new Transition_Array(1..Size_of(Nt_Trans_Set));
Gotos := State_Info(Current_State).Nonterminal_Goto;
Initialize(Nt_Trans_Iter, Nt_Trans_Set);
for S in 1..Size_of(Nt_Trans_Set) loop
Next(Nt_Trans_Iter, Nt_Trans);
Gotos(S) := Nt_Trans;
end loop;
State_Info_2(Current_State).Terminal_Goto :=
new Transition_Array(1..Size_of(T_Trans_Set));
Gotos := State_Info_2(Current_State).Terminal_Goto;
Initialize(T_Trans_Iter, T_Trans_Set);
for S in 1..Size_of(T_Trans_Set) loop
Next(T_Trans_Iter, T_Trans);
Gotos(S) := T_Trans;
end loop;
Make_Null(Nt_Trans_Set);
Make_Null(T_Trans_Set);
Current_State := Current_State + 1;
exit Generate_States when Current_State > Last_State;
end loop Generate_States;
end Make_LR0_States;
-- This procedure allocates the arrays for computing the LR(0) states.
-- The number of states is not known at this point, so it is
-- estimated using a formula taken from
--
-- Purdom, P. W.: "The Size of LALR(1) Parsers," BIT, VOL. 14,
-- No. 3, July 1974, pp.326-337
--
-- The formula is
-- Number of states = 0.5949 * C + 0.02
--
-- where C is the number of rules plus the total number of symbols on
-- the right hand side. We round this figures a little...
procedure LR0_Initialize is
C : Integer := 0;
First_Item: constant Item := (Rule_ID => First_Rule, Dot_Position => 0);
begin
-- estimate the number of states --
for R in First_Rule..Last_Rule loop
C := C + 1 + Length_of(R);
end loop;
Estimated_Number_of_States :=
Integer(0.6 * Float(C) + 1.0);
-- Increase the estimate by 25% just in case --
Max_State := 2 + Parse_State(1.25 * Float(Estimated_Number_of_States));
if Max_State < 100 then
Max_State := 100;
end if;
-- Initialize the state array --
State_Info := new State_Array(0..Max_State);
State_Info(First_State).Kernel := new Item_Array(1..1);
State_Info(First_State).Kernel(1) := First_Item;
Make_Null(State_Info(First_State).Preds);
--& Hack state_info_2
State_Info_2 := new State_Array_2(0..Max_State);
Last_State := 0;
-- set up the goto arrays --
Terminal_Gotos := new Goto_Array
(First_Symbol(Terminal)..Last_Symbol(Terminal));
Nonterminal_Gotos := new Goto_Array
(First_Symbol(Nonterminal)..Last_Symbol(Nonterminal));
Overflow_Gotos := new Overflow_Array(First_State..Max_State);
-- Initialize them to the null_parse_state --
--& more Verdix BUGS
--& terminal_gotos.all :=
--& (terminal_gotos.all'range => null_parse_state);
--&
--& nonterminal_gotos.all :=
--& (nonterminal_gotos.all'range => null_parse_state);
--& Start Verdix bug fix
for I in Terminal_Gotos.all'range loop
Terminal_Gotos(I) := Null_Parse_State;
end loop;
for I in Nonterminal_Gotos.all'range loop
Nonterminal_Gotos(I) := Null_Parse_State;
end loop;
--& End Verdix Bug fix
-- initialize closure_items to the size of the maximum closure
-- i. e. the number of rules in the grammar.
-- Hack: The size is increased by 15 to hold any kernel that
-- might be appended to closure_items. It is hoped
-- that no kernel is greater that 15. If a kernel is greater
-- than 15, it is hoped that #rules+15 > transitive closure
-- of any state.
Closure_Items := new Item_Array
(1..Item_Array_Index(Last_Rule-First_Rule+1+15));
Examined_Symbols := new Boolean_Array
(First_Symbol(Nonterminal)..Last_Symbol(Nonterminal));
Make_LR0_States;
end LR0_Initialize;
function First_Parse_State return Parse_State is
begin
return First_State; -- a constant;
end First_Parse_State;
function Last_Parse_State return Parse_State is
begin
return Last_State;
end Last_Parse_State;
procedure Get_Closure
(State_ID : in Parse_State;
Closure_Items : in Item_Array_Pointer;
Last : out Item_Array_Index) is
---
use Symbol_Info;
Sym : Grammar_Symbol;
Iterator : Item_Iterator;
Temp_Item : Item;
New_Item : Item;
Index : Yield_Index;
Last_Index : Yield_Index;
Closure_Index : Item_Array_Index; -- for looping thru Closure_Items
Next_Free : Item_Array_Index; -- next free in closure_items
Kernel_Ptr : Item_Array_Pointer; -- points to kernel
begin
-- examined_symbols := (others => false);
for I in Examined_Symbols.all'range loop
Examined_Symbols(I) := False;
end loop;
New_Item.Dot_Position := 0; -- Used to add closure items.
Next_Free := 1;
-- first add all the items directly derivable from kernel to closure.
Kernel_Ptr := State_Info(State_ID).Kernel;
for T in Kernel_Ptr.all'range loop
Temp_Item := Kernel_Ptr(T);
if Temp_Item.Dot_Position < Length_of(Temp_Item.Rule_ID) then
Sym := Get_RHS(Temp_Item.Rule_ID, Temp_Item.Dot_Position+1);
if Is_Nonterminal(Sym) and then not Examined_Symbols(Sym) then
Examined_Symbols(Sym) := True;
for I in Nonterminal_Yield_Index(Sym)..
Nonterminal_Yield_Index(Sym+1) - 1
loop
New_Item.Rule_ID := Nonterminal_Yield(I);
Closure_Items(Next_Free) := New_Item;
Next_Free := Next_Free + 1;
end loop;
end if;
end if;
end loop;
-- Now compute the closure of the items in Closure_Items.
Closure_Index := 1;
while Closure_Index < Next_Free loop
Temp_Item := Closure_Items(Closure_Index);
if Temp_Item.Dot_Position < Length_of(Temp_Item.Rule_ID) then
Sym := Get_RHS(Temp_Item.Rule_ID, Temp_Item.Dot_Position+1);
if Is_Nonterminal(Sym) and then not Examined_Symbols(Sym) then
Examined_Symbols(Sym) := True;
for I in Nonterminal_Yield_Index(Sym)..
Nonterminal_Yield_Index(Sym+1) - 1
loop
New_Item.Rule_ID := Nonterminal_Yield(I);
Closure_Items(Next_Free) := New_Item;
Next_Free := Next_Free + 1;
end loop;
end if;
end if;
Closure_Index := Closure_Index + 1;
end loop;
Last := Next_Free - 1;
end Get_Closure;
procedure Closure(Set_1: in out Item_Set) is
use Symbol_Info;
Next_Free : Item_Array_Index; -- index of next free in Closure_Items
Sym : Grammar_Symbol;
Iterator : Item_Iterator;
Temp_Item : Item;
New_Item : Item;
Index : Yield_Index;
Last_Index : Yield_Index;
Closure_Index : Item_Array_Index; -- for looping thru Closure_Items
begin
Next_Free := 1;
-- examined_symbols := (others => false);
for I in Examined_Symbols.all'range loop
Examined_Symbols(I) := False;
end loop;
New_Item.Dot_Position := 0; -- Used to add closure items.
-- first add all the items directly derivable from set_1 to closure.
Initialize(Iterator, Set_1);
while More(Iterator) loop
Next(Iterator, Temp_Item);
if Temp_Item.Dot_Position < Length_of(Temp_Item.Rule_ID) then
Sym := Get_RHS(Temp_Item.Rule_ID, Temp_Item.Dot_Position+1);
if Is_Nonterminal(Sym) and then not Examined_Symbols(Sym) then
Examined_Symbols(Sym) := True;
for I in Nonterminal_Yield_Index(Sym)..
Nonterminal_Yield_Index(Sym+1) - 1
loop
New_Item.Rule_ID := Nonterminal_Yield(I);
Closure_Items(Next_Free) := New_Item;
Next_Free := Next_Free + 1;
end loop;
end if;
end if;
end loop;
-- Now comput the closure of the items in Closure_Items.
Closure_Index := 1;
while Closure_Index < Next_Free loop
Temp_Item := Closure_Items(Closure_Index);
if Temp_Item.Dot_Position < Length_of(Temp_Item.Rule_ID) then
Sym := Get_RHS(Temp_Item.Rule_ID, Temp_Item.Dot_Position+1);
if Is_Nonterminal(Sym) and then not Examined_Symbols(Sym) then
Examined_Symbols(Sym) := True;
for I in Nonterminal_Yield_Index(Sym)..
Nonterminal_Yield_Index(Sym+1) - 1
loop
New_Item.Rule_ID := Nonterminal_Yield(I);
Closure_Items(Next_Free) := New_Item;
Next_Free := Next_Free + 1;
end loop;
end if;
end if;
Closure_Index := Closure_Index + 1;
end loop;
-- Now add all the closure items to set_1.
for I in 1..Next_Free-1 loop
Insert(Closure_Items(I), Into => Set_1);
end loop;
end Closure;
function Find_State(Kernel_Set : Item_Set;
Trans_Sym : Grammar_Symbol) return Parse_State is
Last : constant Item_Array_Index :=
Item_Array_Index(Size_of(Kernel_Set));
Temp_Item : Item;
Iterator : Item_Set_Pack.Set_Iterator;
Kernel : Item_Array(1..Last);
S : Parse_State;
begin
if Last = 0 then
Put_Line("Ayacc: Possible Error in Find_State.");
return Null_Parse_State;
end if;
-- Copy kernel_set into the array KERNEL to compare it
-- to exiting states.
Initialize(Iterator, Kernel_Set);
for I in 1..Last loop -- last = # of items in kernel_set
Next(Iterator, Kernel(I));
end loop;
-- Look for state in existing states --
if Is_Terminal(Trans_Sym) then
S := Terminal_Gotos(Trans_Sym);
else
S := Nonterminal_Gotos(Trans_Sym);
end if;
while S /= Null_Parse_State loop
-- Uncomment the following 3 lines of code when you
-- you use a bug free compiler.
--&if kernel = state_info(S).kernel.all then
--&return S;
--&end if;
-- The following code is to fix a bug in the Verdix compiler
-- remove it when you use a bug free compiler.
if Kernel'Last /= State_Info(S).Kernel.all'Last then
goto Continue;
end if;
for J in Kernel'range loop
if Kernel(J).Rule_ID /= State_Info(S).Kernel(J).Rule_ID
or else
Kernel(J).Dot_Position /=
State_Info(S).Kernel(J).Dot_Position
then
goto Continue;
end if;
end loop;
return S;
-- The end of verdix compiler bug fix.
<<Continue>>
S := Overflow_Gotos(S);
end loop;
-- Didn't find state, create a new state. --
Last_State := Last_State + 1;
State_Info(Last_State).Kernel := new Item_Array(1..Last);
State_Info(Last_State).Kernel.all := Kernel;
Make_Null(State_Info(Last_State).Preds);
-- Save state number in list of transitions on symbol Trans_Sym.
if Is_Terminal(Trans_Sym) then
Overflow_Gotos(Last_State) := Terminal_Gotos(Trans_Sym);
Terminal_Gotos(Trans_Sym) := Last_State;
else
Overflow_Gotos(Last_State) := Nonterminal_Gotos(Trans_Sym);
Nonterminal_Gotos(Trans_Sym) := Last_State;
end if;
return Last_State;
end Find_State;
function Get_Goto(State_ID : Parse_State;
Sym : Grammar_Symbol) return Parse_State is
Gotos : Transition_Array_Pointer;
begin
Gotos := State_Info(State_ID).Nonterminal_Goto;
for S in Gotos.all'range loop
if Sym = Gotos(S).Symbol then
return Gotos(S).State_ID;
end if;
end loop;
Put_Line("Ayacc: Possible Error in Get_Goto.");
return Null_Parse_State;
end Get_Goto;
procedure Get_Pred_Set
(State_ID : in Parse_State;
I : in Item;
Pred_Set : in out Parse_State_Set) is
----
New_Item : Item;
Temp_Item : Item;
Iterator : Parse_State_Iterator;
Pred_State : Parse_State;
begin
if I.Dot_Position = 0 then
Insert(State_ID, Into => Pred_Set);
else
Temp_Item := State_Info(State_ID).Kernel(1);
if Get_RHS(Temp_Item.Rule_ID, Temp_Item.Dot_Position) =
Get_RHS(I.Rule_ID, I.Dot_Position)
then
New_Item := (I.Rule_ID, I.Dot_Position - 1);
Initialize(Iterator, State_Info(State_ID).Preds);
while More(Iterator) loop
Next(Iterator, Pred_State);
Get_Pred_Set(Pred_State, New_Item, Pred_Set);
end loop;
end if;
end if;
end Get_Pred_Set;
procedure Get_Transitions
(State_ID : in Parse_State;
Kind : in Transition_Type;
Set_1 : in out Transition_Set) is
Gotos : Transition_Array_Pointer;
begin
Make_Null(Set_1);
if Kind = Terminals or else Kind = Grammar_Symbols then
Gotos := State_Info_2(State_ID).Terminal_Goto;
for S in reverse Gotos.all'range loop
Insert(Gotos(S), Into => Set_1);
end loop;
end if;
if Kind /= Terminals then
Gotos := State_Info(State_ID).Nonterminal_Goto;
for S in reverse Gotos.all'range loop
Insert(Gotos(S), Into => Set_1);
end loop;
return;
end if;
end Get_Transitions;
procedure Get_Transition_Symbols
(State_ID : in Parse_State;
Kind : in Transition_Type;
Set_1 : in out Grammar_Symbol_Set) is
Gotos : Transition_Array_Pointer;
begin
Make_Null(Set_1);
if Kind = Terminals or else Kind = Grammar_Symbols then
Gotos := State_Info_2(State_ID).Terminal_Goto;
for S in reverse Gotos.all'range loop
Insert(Gotos(S).Symbol, Into => Set_1);
end loop;
end if;
if Kind = Terminals then return; end if;
if Kind = Nonterminals or else Kind = Grammar_Symbols then
Gotos := State_Info(State_ID).Nonterminal_Goto;
for S in reverse Gotos.all'range loop
Insert(Gotos(S).Symbol, Into => Set_1);
end loop;
end if;
end Get_Transition_Symbols;
procedure Get_Kernel
(State_ID : in Parse_State;
Set_1 : in out Item_Set) is
begin
Make_Null(Set_1);
for I in State_Info(State_ID).Kernel.all'range loop
Insert(State_Info(State_ID).Kernel(I), Into => Set_1);
end loop;
end Get_Kernel;
procedure Initialize(Iterator : in out Kernel_Iterator;
State_ID : in Parse_State) is
begin
if State_ID in First_State..Last_State then
Iterator.Kernel := State_Info(State_ID).Kernel;
Iterator.Curser := 1;
else
raise State_Out_of_Bounds;
end if;
end Initialize;
function More(Iterator: Kernel_Iterator) return Boolean is
begin
return Iterator.Curser <= Iterator.Kernel.all'Last;
end More;
procedure Next(Iterator: in out Kernel_Iterator; I : out Item) is
begin
I := Iterator.Kernel(Iterator.Curser);
Iterator.Curser := Iterator.Curser + 1;
end Next;
procedure Initialize
(Iterator : in out Nt_Transition_Iterator;
State_ID : in Parse_State) is
begin
if State_ID in First_State..Last_State then
Iterator.Nonterm_Trans := State_Info(State_ID).Nonterminal_Goto;
Iterator.Curser := 1;
else
raise State_Out_of_Bounds;
end if;
end Initialize;
function More(Iterator : Nt_Transition_Iterator) return Boolean is
begin
return Iterator.Curser <= Iterator.Nonterm_Trans.all'Last;
end More;
procedure Next
(Iterator: in out Nt_Transition_Iterator;
Trans : out Transition) is
begin
Trans := Iterator.Nonterm_Trans(Iterator.Curser);
Iterator.Curser := Iterator.Curser + 1;
end Next;
-----------------------------------------------------
-- terminal interator stuff.
procedure Initialize
(Iterator : in out T_Transition_Iterator;
State_ID : in Parse_State) is
begin
if State_ID in First_State..Last_State then
Iterator.Term_Trans := State_Info_2(State_ID).Terminal_Goto;
Iterator.Curser := 1;
else
raise State_Out_of_Bounds;
end if;
end Initialize;
function More(Iterator : T_Transition_Iterator) return Boolean is
begin
return Iterator.Curser <= Iterator.Term_Trans.all'Last;
end More;
procedure Next
(Iterator: in out T_Transition_Iterator;
Trans : out Transition) is
begin
Trans := Iterator.Term_Trans(Iterator.Curser);
Iterator.Curser := Iterator.Curser + 1;
end Next;
end LR0_Machine;
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- The primary authors of ayacc were David Taback and Deepak Tolani.
-- Enhancements were made by Ronald J. Schmalz.
--
-- Send requests for ayacc information to ayacc-info@ics.uci.edu
-- Send bug reports for ayacc to ayacc-bugs@ics.uci.edu
--
-- Redistribution and use in source and binary forms are permitted
-- provided that the above copyright notice and this paragraph are
-- duplicated in all such forms and that any documentation,
-- advertising materials, and other materials related to such
-- distribution and use acknowledge that the software was developed
-- by the University of California, Irvine. The name of the
-- University may not be used to endorse or promote products derived
-- from this software without specific prior written permission.
-- THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
-- IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
-- WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
-- Module : options.ada
-- Component of : ayacc
-- Version : 1.2
-- Date : 11/21/86 12:31:39
-- SCCS File : disk21~/rschm/hasee/sccs/ayacc/sccs/sxoptions.ada
-- $Header: options.a,v 0.1 86/04/01 15:08:15 ada Exp $
-- $Log: options.a,v $
-- Revision 0.1 86/04/01 15:08:15 ada
-- This version fixes some minor bugs with empty grammars
-- and $$ expansion. It also uses vads5.1b enhancements
-- such as pragma inline.
--
--
-- Revision 0.0 86/02/19 18:37:34 ada
--
-- These files comprise the initial version of Ayacc
-- designed and implemented by David Taback and Deepak Tolani.
-- Ayacc has been compiled and tested under the Verdix Ada compiler
-- version 4.06 on a vax 11/750 running Unix 4.2BSD.
--
package Options is
procedure Set_Options(S: in String);
-- SET_OPTIONS sets the debug and verbose flags according
-- the the string S.
-- If S contains the characters 'v' or 'V', the verbose
-- option is set.
-- If S contains the charactars 'c' or 'C', the vebose conflicts
-- option is set.
-- If S contains the characters 'd' or 'D', the debug
-- option is set.
-- If S contains the characters 's' or 'S', the summary option
-- is set.
function Verbose return Boolean;
-- Returns TRUE if the verbose file is to be created.
function Verbose_Conflict return Boolean;
-- Returns TRUE if only the states involved in conflicts
-- are to printed.
function Debug return Boolean;
-- Returns TRUE if the YYPARSE procedure should generate
-- debugging output.
function Summary return Boolean;
-- Returns TRUE if a summary of statistics of the generated
-- parser should be printed.
function Interface_to_C return Boolean;
function Loud return Boolean;
-- Returns TRUE if Ayacc should output useless and annoying information
-- while it is running.
Illegal_Option: exception;
end Options;
package body Options is
SCCS_ID : constant String := "@(#) options.ada, Version 1.2";
Rcs_ID : constant String := "$Header: options.a,v 0.1 86/04/01 15:08:15 ada Exp $";
Verbose_Option : Boolean := False;
Verbose_Conflict_Option : Boolean := False;
Debug_Option : Boolean := False;
Interface_to_C_Option : Boolean := False;
Summary_Option : Boolean := False;
Loud_Option : Boolean := False;
procedure Set_Options(S: in String) is
begin
for I in S'First..S'Last loop
case S(I) is
when 'v' | 'V' =>
Verbose_Option := True;
when 'c' | 'C' =>
Verbose_Conflict_Option := True;
when 'd' | 'D' =>
Debug_Option := True;
when 'i' | 'I' =>
Interface_to_C_Option := True;
when 's' | 'S' =>
Summary_Option := True;
when 'l' | 'L' =>
Loud_Option := True;
when others =>
raise Illegal_Option;
end case;
end loop;
end Set_Options;
function Verbose return Boolean is
begin
return Verbose_Option;
end;
function Verbose_Conflict return Boolean is
begin
return Verbose_Conflict_Option;
end;
function Debug return Boolean is
begin
return Debug_Option;
end;
function Interface_to_C return Boolean is
begin
return Interface_to_C_Option;
end;
function Summary return Boolean is
begin
return Summary_Option;
end;
function Loud return Boolean is
begin
return Loud_Option;
end;
end Options;
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- The primary authors of ayacc were David Taback and Deepak Tolani.
-- Enhancements were made by Ronald J. Schmalz.
--
-- Send requests for ayacc information to ayacc-info@ics.uci.edu
-- Send bug reports for ayacc to ayacc-bugs@ics.uci.edu
--
-- Redistribution and use in source and binary forms are permitted
-- provided that the above copyright notice and this paragraph are
-- duplicated in all such forms and that any documentation,
-- advertising materials, and other materials related to such
-- distribution and use acknowledge that the software was developed
-- by the University of California, Irvine. The name of the
-- University may not be used to endorse or promote products derived
-- from this software without specific prior written permission.
-- THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
-- IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
-- WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
-- Module : output_file.ada
-- Component of : ayacc
-- Version : 1.2
-- Date : 11/21/86 12:31:54
-- SCCS File : disk21~/rschm/hasee/sccs/ayacc/sccs/sxoutput_file.ada
-- $Header: output_file.a,v 0.1 86/04/01 15:08:21 ada Exp $
-- $Log: output_file.a,v $
-- Revision 0.1 86/04/01 15:08:21 ada
-- This version fixes some minor bugs with empty grammars
-- and $$ expansion. It also uses vads5.1b enhancements
-- such as pragma inline.
--
--
-- Revision 0.0 86/02/19 18:37:42 ada
--
-- These files comprise the initial version of Ayacc
-- designed and implemented by David Taback and Deepak Tolani.
-- Ayacc has been compiled and tested under the Verdix Ada compiler
-- version 4.06 on a vax 11/750 running Unix 4.2BSD.
--
-- Creates the parser
package Output_File is
procedure Make_Output_File;
end Output_File;
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- The primary authors of ayacc were David Taback and Deepak Tolani.
-- Enhancements were made by Ronald J. Schmalz.
--
-- Send requests for ayacc information to ayacc-info@ics.uci.edu
-- Send bug reports for ayacc to ayacc-bugs@ics.uci.edu
--
-- Redistribution and use in source and binary forms are permitted
-- provided that the above copyright notice and this paragraph are
-- duplicated in all such forms and that any documentation,
-- advertising materials, and other materials related to such
-- distribution and use acknowledge that the software was developed
-- by the University of California, Irvine. The name of the
-- University may not be used to endorse or promote products derived
-- from this software without specific prior written permission.
-- THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
-- IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
-- WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
-- Module : output_file_body.ada
-- Component of : ayacc
-- Version : 1.2
-- Date : 11/21/86 12:32:10
-- SCCS File : disk21~/rschm/hasee/sccs/ayacc/sccs/sxoutput_file_body.ada
-- $Header: output_file_body.a,v 0.1 86/04/01 15:08:26 ada Exp $
-- $Log: output_file_body.a,v $
-- Revision 0.1 86/04/01 15:08:26 ada
-- This version fixes some minor bugs with empty grammars
-- and $$ expansion. It also uses vads5.1b enhancements
-- such as pragma inline.
--
--
-- Revision 0.0 86/02/19 18:37:50 ada
--
-- These files comprise the initial version of Ayacc
-- designed and implemented by David Taback and Deepak Tolani.
-- Ayacc has been compiled and tested under the Verdix Ada compiler
-- version 4.06 on a vax 11/750 running Unix 4.2BSD.
--
with Actions_File, File_Names, Lexical_Analyzer, Options, Parse_Table,
Parse_Template_File, Source_File, Text_IO;
use Actions_File, File_Names, Lexical_Analyzer, Options, Parse_Table,
Parse_Template_File, Source_File, Text_IO;
package body Output_File is
SCCS_ID : constant String := "@(#) output_file_body.ada, Version 1.2";
Outfile : File_Type;
procedure Open is
begin
Create(Outfile, Out_File, Get_Out_File_Name);
end Open;
procedure Close is
begin
Close(Outfile);
end Close;
-- Make the parser body section by reading the source --
-- and template files and merging them appropriately --
procedure Make_Output_File is
Text : String(1..260);
Length : Natural;
I : Integer;
begin
Open; -- Open the output file.
-- Read the first part of the source file up to '##'
-- or to end of file.
while not Source_File.Is_End_of_File loop
Source_File.Read_Line(Text, Length);
if Length > 1 then
I := 1;
while (I < Length - 1 and then Text(I) = ' ') loop
I := I + 1;
end loop;
if Text(I..I+1) = "##" then
exit;
end if;
end if;
Put_Line(Outfile, Text(1..Length));
end loop;
Parse_Template_File.Open;
-- Copy the header from the parse template
loop
Parse_Template_File.Read(Text,Length);
if Length > 1 and then Text(1..2) = "%%" then
exit;
else
Put_Line(Outfile, Text(1..Length));
end if;
end loop;
Put_Line (Outfile, " package yy_goto_tables renames");
Put_Line (Outfile, " " & Goto_Tables_Unit_Name & ';');
Put_Line (Outfile, " package yy_shift_reduce_tables renames");
Put_Line (Outfile, " " & Shift_Reduce_Tables_Unit_Name & ';');
Put_Line (Outfile, " package yy_tokens renames");
Put_Line (Outfile, " " & Tokens_Unit_Name & ';');
-- Copy the first half of the parse template
loop
Parse_Template_File.Read(Text,Length);
if Length > 1 and then Text(1..2) = "%%" then
exit;
else
Put_Line(Outfile, Text(1..Length));
end if;
end loop;
-- Copy declarations and procedures needed in the parse template
Put_Line (Outfile," DEBUG : constant boolean := " &
Boolean'Image (Options.Debug) & ';');
-- Consume Template Up To User Action Routines.
loop
Parse_Template_File.Read(Text,Length);
if Length > 1 and then Text(1..2) = "%%" then
exit;
else
Put_Line(Outfile, Text(1..Length));
end if;
end loop;
Actions_File.Open(Actions_File.Read_File);
loop
exit when Actions_File.Is_End_of_File;
Actions_File.Read_Line(Text,Length);
Put_Line(Outfile, Text(1..Length));
end loop;
Actions_File.Delete;
-- Finish writing the template file
loop
exit when Parse_Template_File.Is_End_of_File;
Parse_Template_File.Read(Text,Length);
Put_Line(Outfile, Text(1..Length));
end loop;
Parse_Template_File.Close;
-- Copy rest of input file after ##
while not Source_File.Is_End_of_File loop
Source_File.Read_Line(Text, Length);
Put_Line(Outfile, Text(1..Length));
end loop;
Close;
end Make_Output_File;
end Output_File;
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- The primary authors of ayacc were David Taback and Deepak Tolani.
-- Enhancements were made by Ronald J. Schmalz.
--
-- Send requests for ayacc information to ayacc-info@ics.uci.edu
-- Send bug reports for ayacc to ayacc-bugs@ics.uci.edu
--
-- Redistribution and use in source and binary forms are permitted
-- provided that the above copyright notice and this paragraph are
-- duplicated in all such forms and that any documentation,
-- advertising materials, and other materials related to such
-- distribution and use acknowledge that the software was developed
-- by the University of California, Irvine. The name of the
-- University may not be used to endorse or promote products derived
-- from this software without specific prior written permission.
-- THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
-- IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
-- WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
-- Module : parse_table.ada
-- Component of : ayacc
-- Version : 1.2
-- Date : 11/21/86 12:32:58
-- SCCS File : disk21~/rschm/hasee/sccs/ayacc/sccs/sxparse_table.ada
-- $Header: parse_table.a,v 0.1 86/04/01 15:08:33 ada Exp $
-- $Log: parse_table.a,v $
-- Revision 0.1 86/04/01 15:08:33 ada
-- This version fixes some minor bugs with empty grammars
-- and $$ expansion. It also uses vads5.1b enhancements
-- such as pragma inline.
--
--
-- Revision 0.0 86/02/19 18:37:58 ada
--
-- These files comprise the initial version of Ayacc
-- designed and implemented by David Taback and Deepak Tolani.
-- Ayacc has been compiled and tested under the Verdix Ada compiler
-- version 4.06 on a vax 11/750 running Unix 4.2BSD.
--
-- This package build the shift reduce table and the goto table and
-- writes it to the shift_reduce_file, and goto_file. If the verbose option
-- is set, the states generated and their coresponding actions are written
-- to the verobose_file.
-- The parse table produced is an LALR(1) parse table.
-- The number of conflicts resulting from the grammar
-- can be determinied by calling the funciton REDUCE_REDUCE_CONFLICTS and
-- SHIFT_REDUCE_CONFLICTS, after calling MAKE_PARSE_TABLE.
package Parse_Table is
procedure Make_Parse_Table;
-- These functions must be called AFTER Make_parse_Table
function Shift_Reduce_Conflicts return Natural;
function Reduce_Reduce_Conflicts return Natural;
function Number_of_States return Natural;
function Size_of_Goto_Table return Natural;
function Size_of_Action_Table return Natural;
end Parse_Table;
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- The primary authors of ayacc were David Taback and Deepak Tolani.
-- Enhancements were made by Ronald J. Schmalz.
--
-- Send requests for ayacc information to ayacc-info@ics.uci.edu
-- Send bug reports for ayacc to ayacc-bugs@ics.uci.edu
--
-- Redistribution and use in source and binary forms are permitted
-- provided that the above copyright notice and this paragraph are
-- duplicated in all such forms and that any documentation,
-- advertising materials, and other materials related to such
-- distribution and use acknowledge that the software was developed
-- by the University of California, Irvine. The name of the
-- University may not be used to endorse or promote products derived
-- from this software without specific prior written permission.
-- THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
-- IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
-- WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
-- Module : parse_table_body.ada
-- Component of : ayacc
-- Version : 1.2
-- Date : 11/21/86 12:33:16
-- SCCS File : disk21~/rschm/hasee/sccs/ayacc/sccs/sxparse_table_body.ada
-- $Header: parse_table_body.a,v 0.1 86/04/01 15:08:38 ada Exp $
-- $Log: parse_table_body.a,v $
-- Revision 0.1 86/04/01 15:08:38 ada
-- This version fixes some minor bugs with empty grammars
-- and $$ expansion. It also uses vads5.1b enhancements
-- such as pragma inline.
--
--
-- Revision 0.0 86/02/19 18:39:53 ada
--
-- These files comprise the initial version of Ayacc
-- designed and implemented by David Taback and Deepak Tolani.
-- Ayacc has been compiled and tested under the Verdix Ada compiler
-- version 4.06 on a vax 11/750 running Unix 4.2BSD.
--
with LALR_Symbol_Info, LR0_Machine, Symbol_Table, Rule_Table,
Text_IO, Symbol_Info, Verbose_File, Options, Goto_File,
Shift_Reduce_File;
use LALR_Symbol_Info, LR0_Machine, Symbol_Table, Rule_Table,
Text_IO, Symbol_Info, Options;
package body Parse_Table is
SCCS_ID : constant String := "@(#) parse_table_body.ada, Version 1.2";
Rcs_ID : constant String := "$Header: parse_table_body.a,v 0.1 86/04/01 15:08:38 ada Exp $";
Show_Verbose : Boolean; -- Set to options.verbose
--
-- The following declarations are for the "action" table.
--
type Action_Type is (Undefined, Error, Shift, Reduce, Accept_Input);
-- UNDEFINED and ERROR are the same accept you cannot replace
-- ERROR entries by a default reduction.
type Action_Table_Entry(Action : Action_Type := Undefined) is
record
case Action is
when Shift =>
State_ID : Parse_State;
when Reduce =>
Rule_ID : Rule;
when Accept_Input | Error | Undefined =>
null;
end case;
end record;
type Action_Table_Array is
array(Grammar_Symbol range <>) of Action_Table_Entry;
type Action_Table_Array_Pointer is access Action_Table_Array;
Action_Table_Row : Action_Table_Array_Pointer;
Default_Action : Action_Table_Entry;
--
-- The following declarations are for the "goto" table
--
type Goto_Table_Array is
array(Grammar_Symbol range <>) of Parse_State;
type Goto_Table_Array_Pointer is access Goto_Table_Array;
Goto_Table_Row : Goto_Table_Array_Pointer;
--
type Goto_Offset_Array is array(Parse_State range <>) of Integer;
type Goto_Offset_Array_Pointer is access Goto_Offset_Array;
Goto_Offset : Goto_Offset_Array_Pointer;
type Action_Offset_Array is array(Parse_State range <>) of Integer;
type Action_Offset_Array_Pointer is access Action_Offset_Array;
Action_Offset : Action_Offset_Array_Pointer;
--
Error_Code : constant := -1000; -- generated parser must use these
Accept_Code : constant := -1001;
Num_of_Goto_Entries : Integer := 0;
Num_of_Action_Entries : Integer := 0;
Num_Shift_Reduce_Conflicts : Natural := 0;
Num_Reduce_Reduce_Conflicts : Natural := 0;
function Shift_Reduce_Conflicts return Natural is
begin
return Num_Shift_Reduce_Conflicts;
end;
function Reduce_Reduce_Conflicts return Natural is
begin
return Num_Reduce_Reduce_Conflicts;
end;
function Number_of_States return Natural is
begin
return Natural(LR0_Machine.Last_Parse_State + 1);
end;
function Size_of_Goto_Table return Natural is
begin
return Num_of_Goto_Entries;
end;
function Size_of_Action_Table return Natural is
begin
return Num_of_Action_Entries;
end;
procedure Print_Goto_Row_Verbose is
begin
for Sym in Goto_Table_Row.all'range loop
if Goto_Table_Row(Sym) /= Null_Parse_State then
Verbose_File.Write(Ascii.Ht);
Verbose_File.Print_Grammar_Symbol(Sym);
Verbose_File.Write(" " & Ascii.Ht);
Verbose_File.Write_Line
("goto " & Parse_State'Image(Goto_Table_Row(Sym)));
end if;
end loop;
end Print_Goto_Row_Verbose;
procedure Print_Goto_Row(State: in Parse_State) is
S: Parse_State;
begin
Goto_Offset(State) := Num_of_Goto_Entries;
Goto_File.Write_Line
("-- State " & Parse_State'Image(State));
for I in Goto_Table_Row.all'range loop
S := Goto_Table_Row(I);
if S /= -1 then
Goto_File.Write(",");
Goto_File.Write("(" & Grammar_Symbol'Image(I) & "," &
Parse_State'Image(S) & ")" );
Num_of_Goto_Entries := Num_of_Goto_Entries + 1;
if Num_of_Goto_Entries mod 4 = 0 then
Goto_File.Write_Line("");
end if;
end if;
end loop;
Goto_File.Write_Line("");
end Print_Goto_Row;
-----------------------------------------------------------------------
procedure Print_Action_Row(State: in Parse_State) is
Temp : Action_Table_Entry;
X : Integer;
Default : Integer;
function Get_Default_Entry return Integer is
begin
for I in Action_Table_Row.all'range loop
if Action_Table_Row(I).Action = Reduce then
return -Integer(Action_Table_Row(I).Rule_ID);
end if;
end loop;
return Error_Code;
end Get_Default_Entry;
begin
Action_Offset(State) := Num_of_Action_Entries;
Shift_Reduce_File.Write_Line
("-- state " & Parse_State'Image(State));
Default := Get_Default_Entry;
for I in Action_Table_Row.all'range loop
Temp := Action_Table_Row(I);
case Temp.Action is
when Undefined =>
X := Default;
when Shift =>
X := Integer(Temp.State_ID);
when Reduce =>
X := - Integer(Temp.Rule_ID);
when Accept_Input =>
X := Accept_Code;
when Error =>
X := Error_Code;
end case;
if X /= Default then
Shift_Reduce_File.Write(",");
Shift_Reduce_File.Write("(" & Grammar_Symbol'Image(I) & ",");
Shift_Reduce_File.Write(Integer'Image(X) & ")" );
Num_of_Action_Entries := Num_of_Action_Entries + 1;
if Num_of_Action_Entries mod 4 = 0 then
Shift_Reduce_File.Write_Line("");
end if;
if Show_Verbose then
Verbose_File.Write(" " & Ascii.Ht);
Verbose_File.Print_Grammar_Symbol(I);
Verbose_File.Write(" " & Ascii.Ht);
if X = Accept_Code then
Verbose_File.Write_Line("accept");
elsif X = Error_Code then
Verbose_File.Write_Line("error");
elsif X > 0 then -- SHIFT
Verbose_File.Write_Line("shift " & Integer'Image(X));
else -- REDUCE
Verbose_File.Write_Line("reduce " & Integer'Image(-X));
end if;
end if;
end if;
end loop;
if Show_Verbose then
Verbose_File.Write(" " & Ascii.Ht);
Verbose_File.Write("default " & Ascii.Ht);
if Default = Accept_Code then
Verbose_File.Write_Line("accept");
elsif Default = Error_Code then
Verbose_File.Write_Line("error");
else -- reduce. never shift
Verbose_File.Write_Line("reduce " & Integer'Image(-Default));
end if;
end if;
Shift_Reduce_File.Write(",");
Shift_Reduce_File.Write("(" & Grammar_Symbol'Image(-1) & ",");
Shift_Reduce_File.Write(Integer'Image(Default) & ")" );
Num_of_Action_Entries := Num_of_Action_Entries + 1;
if Num_of_Action_Entries mod 4 = 0 then
Shift_Reduce_File.Write_Line("");
end if;
Shift_Reduce_File.Write_Line("");
end Print_Action_Row;
-----------------------------------------------------------------------
procedure Init_Table_Files is
begin
Goto_Offset := new Goto_Offset_Array
(First_Parse_State..Last_Parse_State);
Action_Offset := new Action_Offset_Array
(First_Parse_State..Last_Parse_State);
Goto_File.Open_Write;
Shift_Reduce_File.Open_Write;
end Init_Table_Files;
procedure Finish_Table_Files is
begin
Goto_File.Write_Line(");");
Goto_File.Write_Line("-- The offset vector");
Goto_File.Write("GOTO_OFFSET : array (0..");
Goto_File.Write(Parse_State'Image(Goto_Offset.all'Last) & ')');
Goto_File.Write_Line(" of Integer :=");
Goto_File.Write("(");
for I in Goto_Offset.all'First .. Goto_Offset.all'Last-1 loop
Goto_File.Write(Integer'Image(Goto_Offset(I)) & ",");
if I mod 10 = 0 then Goto_File.Write_Line(""); end if;
end loop;
Goto_File.Write
(Integer'Image(Goto_Offset(Goto_Offset.all'Last)));
Goto_File.Write_Line(");");
Goto_File.Close_Write;
Shift_Reduce_File.Write_Line(");");
Shift_Reduce_File.Write_Line("-- The offset vector");
Shift_Reduce_File.Write("SHIFT_REDUCE_OFFSET : array (0..");
Shift_Reduce_File.Write
(Parse_State'Image(Action_Offset.all'Last) & ')');
Shift_Reduce_File.Write_Line(" of Integer :=");
Shift_Reduce_File.Write("(");
for I in Action_Offset.all'First..Action_Offset.all'Last-1
loop
Shift_Reduce_File.Write
(Integer'Image(Action_Offset(I)) & ",");
if I mod 10 = 0 then Shift_Reduce_File.Write_Line(""); end if;
end loop;
Shift_Reduce_File.Write
(Integer'Image(Action_Offset(Action_Offset.all'Last)));
Shift_Reduce_File.Write_Line(");");
Shift_Reduce_File.Close_Write;
end Finish_Table_Files;
procedure Compute_Parse_Table is
use Transition_Set_Pack;
use Item_Set_Pack;
use Grammar_Symbol_Set_Pack;
Trans : Transition;
Nonterm_Iter : Nt_Transition_Iterator;
Term_Iter : T_Transition_Iterator;
Item_Set_1 : Item_Set;
Item_Iter : Item_Iterator;
Temp_Item : Item;
Lookahead_Set : Grammar_Symbol_Set;
Sym_Iter : Grammar_Symbol_Iterator;
Sym : Grammar_Symbol;
-- these variables are used for resolving conflicts
Sym_Prec : Precedence;
Rule_Prec : Precedence;
Sym_Assoc : Associativity;
-- recduce by r or action in action_table_row(sym);
procedure Report_Conflict(R: Rule; Sym : in Grammar_Symbol) is
begin
if Show_Verbose then
Verbose_File.Write("*** Conflict on input ");
Verbose_File.Print_Grammar_Symbol(Sym);
Verbose_File.Write_Line;
Verbose_File.Write(Ascii.Ht);
Verbose_File.Write("Reduce " & Rule'Image(R));
Verbose_File.Write(Ascii.Ht);
Verbose_File.Write("or");
Verbose_File.Write(Ascii.Ht);
end if;
case Action_Table_Row(Sym).Action is
when Shift =>
Num_Shift_Reduce_Conflicts :=
Num_Shift_Reduce_Conflicts + 1;
if Show_Verbose then
Verbose_File.Write("Shift ");
Verbose_File.Write_Line
(Parse_State'Image(Action_Table_Row(Sym).State_ID));
end if;
when Reduce =>
Num_Reduce_Reduce_Conflicts :=
Num_Reduce_Reduce_Conflicts + 1;
if Show_Verbose then
Verbose_File.Write("Reduce ");
Verbose_File.Write_Line
(Rule'Image(Action_Table_Row(Sym).Rule_ID));
end if;
when Accept_Input =>
if Show_Verbose then
Verbose_File.Write("Accept???"); -- won't happen
end if;
Put_Line("Ayacc: Internal Error in Report Conflict!");
when Error =>
if Show_Verbose then
Verbose_File.Write_Line("Error???"); -- won't happen
end if;
Put_Line("Ayacc: Internal Error in Report Conflict!");
when Undefined =>
Put_Line("Ayacc: Internal Error in Report Conflict!");
end case;
if Show_Verbose then
Verbose_File.Write_Line;
end if;
end;
begin
Action_Table_Row := new Action_Table_Array
(First_Symbol(Terminal)..Last_Symbol(Terminal));
Goto_Table_Row := new Goto_Table_Array
(First_Symbol(Nonterminal)..Last_Symbol(Nonterminal));
Init_Table_Files;
for S in First_Parse_State..Last_Parse_State loop
--& The verdix compiler apparently ALOCATES more memory for the following
--& assignments. We commented them out and replaced these statements by
--& the for loops
--& action_table_row.all :=
--& (action_table_row.all'range => (action => undefined));
--& goto_table_row.all :=
--& (goto_table_row.all'range => null_parse_state);
for I in Action_Table_Row.all'range loop
Action_Table_Row(I) := (Action => Undefined);
end loop;
for I in Goto_Table_Row.all'range loop
Goto_Table_Row(I) := Null_Parse_State;
end loop;
Make_Null(Item_Set_1);
Get_Kernel(S, Item_Set_1);
if Show_Verbose then
Verbose_File.Write_Line("------------------");
Verbose_File.Write_Line("State " & Parse_State'Image(S));
Verbose_File.Write_Line;
Verbose_File.Write_Line("Kernel");
Verbose_File.Print_Item_Set(Item_Set_1);
end if;
Closure(Item_Set_1);
if Show_Verbose then
Verbose_File.Write_Line;
Verbose_File.Write_Line("Closure");
Verbose_File.Print_Item_Set(Item_Set_1);
Verbose_File.Write_Line;
Verbose_File.Write_Line;
end if;
-- Make Shift Entries --
Initialize(Term_Iter, S);
while More(Term_Iter) loop
Next(Term_Iter, Trans);
if Trans.Symbol = End_Symbol then
Action_Table_Row(Trans.Symbol) :=
(Action => Accept_Input);
else
Action_Table_Row(Trans.Symbol) :=
(Action => Shift, State_ID => Trans.State_ID);
end if;
end loop;
-- Make Goto Entries --
Initialize(Nonterm_Iter, S);
while More(Nonterm_Iter) loop
Next(Nonterm_Iter, Trans);
Goto_Table_Row(Trans.Symbol) := Trans.State_ID;
end loop;
-- Make Reduce Entries ----
Initialize(Item_Iter, Item_Set_1);
-- check for degenerate reduce --
if Size_of(Item_Set_1) = 1 then
Next(Item_Iter, Temp_Item);
if Temp_Item.Dot_Position = Length_of(Temp_Item.Rule_ID)
and then Temp_Item.Rule_ID /= First_Rule
then
Action_Table_Row(First_Symbol(Terminal)) :=
(Action => Reduce,
Rule_ID => Temp_Item.Rule_ID);
end if;
goto Continue_Loop;
end if;
-- The following is really messy. It used to be ok before
-- we added precedence. Some day we should rewrite it.
while More(Item_Iter) loop
Next(Item_Iter, Temp_Item);
if Temp_Item.Dot_Position = Length_of(Temp_Item.Rule_ID)
and then Temp_Item.Rule_ID /= First_Rule
then
Make_Null(Lookahead_Set);
Get_LA(S, Temp_Item, Lookahead_Set);
Initialize(Sym_Iter, Lookahead_Set);
while More(Sym_Iter) loop
Next(Sym_Iter, Sym);
case Action_Table_Row(Sym).Action is
when Undefined =>
Action_Table_Row(Sym) :=
(Action => Reduce,
Rule_ID => Temp_Item.Rule_ID);
when Shift =>
Sym_Prec :=
Get_Precedence(Sym);
Rule_Prec :=
Get_Rule_Precedence(Temp_Item.Rule_ID);
if Sym_Prec = 0 or else Rule_Prec = 0 then
Report_Conflict(Temp_Item.Rule_ID, Sym);
elsif Rule_Prec > Sym_Prec then
Action_Table_Row(Sym) :=
(Action => Reduce,
Rule_ID => Temp_Item.Rule_ID);
elsif Sym_Prec > Rule_Prec then
null; -- already ok
else
Sym_Assoc :=
Get_Associativity(Sym);
if Sym_Assoc = Left_Associative then
Action_Table_Row(Sym) :=
(Action => Reduce,
Rule_ID => Temp_Item.Rule_ID);
elsif Sym_Assoc = Right_Associative then
null;
elsif Sym_Assoc = Nonassociative then
Action_Table_Row(Sym) :=
(Action => Error);
else
Put_Line("Ayacc: Possible Error in " &
"Conflict Resolution.");
end if;
end if;
when Reduce =>
Report_Conflict(Temp_Item.Rule_ID, Sym);
when Error =>
Put_Line("Ayacc: Internal Error in Conflict!!!");
Put_Line("Ayacc: Use Verbose Option!");
Report_Conflict(Temp_Item.Rule_ID, Sym);
when Accept_Input =>
Put_Line("Ayacc: Internal Error in Conflict!!!");
Put_Line("Ayacc: Use Verbose Option!");
Report_Conflict(Temp_Item.Rule_ID, Sym);
end case;
end loop;
end if;
end loop;
<<Continue_Loop>>
if Show_Verbose then
Print_Goto_Row_Verbose;
end if;
Print_Goto_Row(S);
Print_Action_Row(S);
end loop;
Finish_Table_Files;
end Compute_Parse_Table;
procedure Make_Parse_Table is
begin
Show_Verbose := Options.Verbose;
if Show_Verbose then
Verbose_File.Open;
end if;
Symbol_Info.Initialize;
if Options.Loud then
Put_Line("Ayacc: Making LR(0) Machine.");
end if;
LR0_Machine.LR0_Initialize;
if Options.Loud then
Put_Line("Ayacc: Making Follow Sets.");
end if;
Make_LALR_Sets;
if Options.Loud then
Put_Line("Ayacc: Making Parse Table.");
end if;
Compute_Parse_Table;
if Show_Verbose then
Verbose_File.Close;
end if;
end Make_Parse_Table;
end Parse_Table;
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- The primary authors of ayacc were David Taback and Deepak Tolani.
-- Enhancements were made by Ronald J. Schmalz.
--
-- Send requests for ayacc information to ayacc-info@ics.uci.edu
-- Send bug reports for ayacc to ayacc-bugs@ics.uci.edu
--
-- Redistribution and use in source and binary forms are permitted
-- provided that the above copyright notice and this paragraph are
-- duplicated in all such forms and that any documentation,
-- advertising materials, and other materials related to such
-- distribution and use acknowledge that the software was developed
-- by the University of California, Irvine. The name of the
-- University may not be used to endorse or promote products derived
-- from this software without specific prior written permission.
-- THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
-- IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
-- WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
-- Module : parse_template_file.ada
-- Component of : ayacc
-- Version : 1.2
-- Date : 11/21/86 12:33:32
-- SCCS File : disk21~/rschm/hasee/sccs/ayacc/sccs/sxparse_template_file.ada
-- $Header: parse_template_file.a,v 0.1 86/04/01 15:09:47 ada Exp $
-- $Log: parse_template_file.a,v $
-- Revision 0.1 86/04/01 15:09:47 ada
-- This version fixes some minor bugs with empty grammars
-- and $$ expansion. It also uses vads5.1b enhancements
-- such as pragma inline.
--
--
-- Revision 0.0 86/02/19 18:40:09 ada
--
-- These files comprise the initial version of Ayacc
-- designed and implemented by David Taback and Deepak Tolani.
-- Ayacc has been compiled and tested under the Verdix Ada compiler
-- version 4.06 on a vax 11/750 running Unix 4.2BSD.
--
with Text_IO, File_Names;
use Text_IO, File_Names;
with String_Pkg; use String_Pkg;
package body Parse_Template_File is
SCCS_ID : constant String := "@(#) parse_template_file.ada, Version 1.2";
Rcs_ID : constant String := "$Header: parse_template_file.a,v 0.1 86/04/01 15:09:47 ada Exp $";
File_Pointer : Natural := 0;
type File_Data is array (Positive range <>) of String_Type;
-- Verdix 5.2 Compiler Bug will not accept aggregate size as implied constraint
-->> YYParse_Template_File : File_Data :=
-- Verdix 5.2 Compiler Bug
YYParse_Template_File : File_Data (1 .. 262) :=
( -- Start of File Contents
Create ("procedure YYParse is"),
Create (""),
Create (" -- Rename User Defined Packages to Internal Names."),
Create ("%%"),
Create (""),
Create (" use yy_tokens, yy_goto_tables, yy_shift_reduce_tables;"),
Create (""),
Create (" procedure yyerrok;"),
Create (" procedure yyclearin;"),
Create (""),
Create (" package yy is"),
Create (""),
Create (" -- the size of the value and state stacks"),
Create (" stack_size : constant Natural := 300;"),
Create (""),
Create (" -- subtype rule is natural;"),
Create (" subtype parse_state is natural;"),
Create (" -- subtype nonterminal is integer;"),
Create (""),
Create (" -- encryption constants"),
Create (" default : constant := -1;"),
Create (" first_shift_entry : constant := 0;"),
Create (" accept_code : constant := -1001;"),
Create (" error_code : constant := -1000;"),
Create (""),
Create (" -- stack data used by the parser"),
Create (" tos : natural := 0;"),
Create (" value_stack : array(0..stack_size) of yy_tokens.yystype;"),
Create (" state_stack : array(0..stack_size) of parse_state;"),
Create (""),
Create (" -- current input symbol and action the parser is on"),
Create (" action : integer;"),
Create (" rule_id : rule;"),
Create (" input_symbol : yy_tokens.token;"),
Create (""),
Create (""),
Create (" -- error recovery flag"),
Create (" error_flag : natural := 0;"),
Create (" -- indicates 3 - (number of valid shifts after an error occurs)"),
Create (""),
Create (" look_ahead : boolean := true;"),
Create (" index : integer;"),
Create (""),
Create (" -- Is Debugging option on or off"),
Create ("%%"),
Create (""),
Create (" end yy;"),
Create (""),
Create (""),
Create (" function goto_state"),
Create (" (state : yy.parse_state;"),
Create (" sym : nonterminal) return yy.parse_state;"),
Create (""),
Create (" function parse_action"),
Create (" (state : yy.parse_state;"),
Create (" t : yy_tokens.token) return integer;"),
Create (""),
Create (" pragma inline(goto_state, parse_action);"),
Create (""),
Create (""),
Create (" function goto_state(state : yy.parse_state;"),
Create (" sym : nonterminal) return yy.parse_state is"),
Create (" index : integer;"),
Create (" begin"),
Create (" index := goto_offset(state);"),
Create (" while integer(goto_matrix(index).nonterm) /= sym loop"),
Create (" index := index + 1;"),
Create (" end loop;"),
Create (" return integer(goto_matrix(index).newstate);"),
Create (" end goto_state;"),
Create (""),
Create (""),
Create (" function parse_action(state : yy.parse_state;"),
Create (" t : yy_tokens.token) return integer is"),
Create (" index : integer;"),
Create (" tok_pos : integer;"),
Create (" default : constant integer := -1;"),
Create (" begin"),
Create (" tok_pos := yy_tokens.token'pos(t);"),
Create (" index := shift_reduce_offset(state);"),
Create (" while integer(shift_reduce_matrix(index).t) /= tok_pos and then"),
Create (" integer(shift_reduce_matrix(index).t) /= default"),
Create (" loop"),
Create (" index := index + 1;"),
Create (" end loop;"),
Create (" return integer(shift_reduce_matrix(index).act);"),
Create (" end parse_action;"),
Create (""),
Create ("-- error recovery stuff"),
Create (""),
Create (" procedure handle_error is"),
Create (" temp_action : integer;"),
Create (" begin"),
Create (""),
Create (" if yy.error_flag = 3 then -- no shift yet, clobber input."),
Create (" if yy.debug then"),
Create (" put_line(""Ayacc.YYParse: Error Recovery Clobbers "" &"),
Create (" yy_tokens.token'image(yy.input_symbol));"),
Create (" end if;"),
Create (" if yy.input_symbol = yy_tokens.end_of_input then -- don't discard,"),
Create (" if yy.debug then"),
Create (" put_line(""Ayacc.YYParse: Can't discard END_OF_INPUT, quiting..."");"),
Create (" end if;"),
Create (" raise yy_tokens.syntax_error;"),
Create (" end if;"),
Create (""),
Create (" yy.look_ahead := true; -- get next token"),
Create (" return; -- and try again..."),
Create (" end if;"),
Create (""),
Create (" if yy.error_flag = 0 then -- brand new error"),
Create (" yyerror(""Syntax Error"");"),
Create (" end if;"),
Create (""),
Create (" yy.error_flag := 3;"),
Create (""),
Create (" -- find state on stack where error is a valid shift --"),
Create (""),
Create (" if yy.debug then"),
Create (" put_line(""Ayacc.YYParse: Looking for state with error as valid shift"");"),
Create (" end if;"),
Create (""),
Create (" loop"),
Create (" if yy.debug then"),
Create (" put_line(""Ayacc.YYParse: Examining State "" &"),
Create (" yy.parse_state'image(yy.state_stack(yy.tos)));"),
Create (" end if;"),
Create (" temp_action := parse_action(yy.state_stack(yy.tos), error);"),
Create (""),
Create (" if temp_action >= yy.first_shift_entry then"),
Create (" yy.tos := yy.tos + 1;"),
Create (" yy.state_stack(yy.tos) := temp_action;"),
Create (" exit;"),
Create (" end if;"),
Create (""),
Create (" Decrement_Stack_Pointer :"),
Create (" begin"),
Create (" yy.tos := yy.tos - 1;"),
Create (" exception"),
Create (" when Constraint_Error =>"),
Create (" yy.tos := 0;"),
Create (" end Decrement_Stack_Pointer;"),
Create (""),
Create (" if yy.tos = 0 then"),
Create (" if yy.debug then"),
Create (" put_line(""Ayacc.YYParse: Error recovery popped entire stack, aborting..."");"),
Create (" end if;"),
Create (" raise yy_tokens.syntax_error;"),
Create (" end if;"),
Create (" end loop;"),
Create (""),
Create (" if yy.debug then"),
Create (" put_line(""Ayacc.YYParse: Shifted error token in state "" &"),
Create (" yy.parse_state'image(yy.state_stack(yy.tos)));"),
Create (" end if;"),
Create (""),
Create (" end handle_error;"),
Create (""),
Create (" -- print debugging information for a shift operation"),
Create (" procedure shift_debug(state_id: yy.parse_state; lexeme: yy_tokens.token) is"),
Create (" begin"),
Create (" put_line(""Ayacc.YYParse: Shift ""& yy.parse_state'image(state_id)&"" on input symbol ""&"),
Create (" yy_tokens.token'image(lexeme) );"),
Create (" end;"),
Create (""),
Create (" -- print debugging information for a reduce operation"),
Create (" procedure reduce_debug(rule_id: rule; state_id: yy.parse_state) is"),
Create (" begin"),
Create (" put_line(""Ayacc.YYParse: Reduce by rule ""&rule'image(rule_id)&"" goto state ""&"),
Create (" yy.parse_state'image(state_id));"),
Create (" end;"),
Create (""),
Create (" -- make the parser believe that 3 valid shifts have occured."),
Create (" -- used for error recovery."),
Create (" procedure yyerrok is"),
Create (" begin"),
Create (" yy.error_flag := 0;"),
Create (" end yyerrok;"),
Create (""),
Create (" -- called to clear input symbol that caused an error."),
Create (" procedure yyclearin is"),
Create (" begin"),
Create (" -- yy.input_symbol := yylex;"),
Create (" yy.look_ahead := true;"),
Create (" end yyclearin;"),
Create (""),
Create (""),
Create ("begin"),
Create (" -- initialize by pushing state 0 and getting the first input symbol"),
Create (" yy.state_stack(yy.tos) := 0;"),
Create (""),
Create (" loop"),
Create (""),
Create (" yy.index := shift_reduce_offset(yy.state_stack(yy.tos));"),
Create (" if integer(shift_reduce_matrix(yy.index).t) = yy.default then"),
Create (" yy.action := integer(shift_reduce_matrix(yy.index).act);"),
Create (" else"),
Create (" if yy.look_ahead then"),
Create (" yy.look_ahead := false;"),
Create (" yy.input_symbol := yylex;"),
Create (" end if;"),
Create (" yy.action :="),
Create (" parse_action(yy.state_stack(yy.tos), yy.input_symbol);"),
Create (" end if;"),
Create (""),
Create (" if yy.action >= yy.first_shift_entry then -- SHIFT"),
Create (""),
Create (" if yy.debug then"),
Create (" shift_debug(yy.action, yy.input_symbol);"),
Create (" end if;"),
Create (""),
Create (" -- Enter new state"),
Create (" yy.tos := yy.tos + 1;"),
Create (" yy.state_stack(yy.tos) := yy.action;"),
Create (" yy.value_stack(yy.tos) := yylval;"),
Create (""),
Create (" if yy.error_flag > 0 then -- indicate a valid shift"),
Create (" yy.error_flag := yy.error_flag - 1;"),
Create (" end if;"),
Create (""),
Create (" -- Advance lookahead"),
Create (" yy.look_ahead := true;"),
Create (""),
Create (" elsif yy.action = yy.error_code then -- ERROR"),
Create (" handle_error;"),
Create (""),
Create (" elsif yy.action = yy.accept_code then"),
Create (" if yy.debug then"),
Create (" put_line(""Ayacc.YYParse: Accepting Grammar..."");"),
Create (" end if;"),
Create (" exit;"),
Create (""),
Create (" else -- Reduce Action"),
Create (""),
Create (" -- Convert action into a rule"),
Create (" yy.rule_id := -1 * yy.action;"),
Create (""),
Create (" -- Execute User Action"),
Create (" -- user_action(yy.rule_id);"),
Create (" case yy.rule_id is"),
Create ("%%"),
Create (""),
Create (" when others => null;"),
Create (" end case;"),
Create (""),
Create (" -- Pop RHS states and goto next state"),
Create (" yy.tos := yy.tos - rule_length(yy.rule_id) + 1;"),
Create (" yy.state_stack(yy.tos) := goto_state(yy.state_stack(yy.tos-1) ,"),
Create (" get_lhs_rule(yy.rule_id));"),
Create (""),
Create (" yy.value_stack(yy.tos) := yyval;"),
Create (""),
Create (" if yy.debug then"),
Create (" reduce_debug(yy.rule_id,"),
Create (" goto_state(yy.state_stack(yy.tos - 1),"),
Create (" get_lhs_rule(yy.rule_id)));"),
Create (" end if;"),
Create (""),
Create (" end if;"),
Create (" end loop;"),
Create (""),
Create ("end yyparse;") ); -- End of File Contents
procedure Open is
begin
File_Pointer := YYParse_Template_File'First;
end Open;
procedure Close is
begin
File_Pointer := 0;
end Close;
procedure Read (S: out String; Length : out Integer) is
Next_Line : constant String :=
String_Pkg.Value (YYParse_Template_File (File_Pointer));
begin
S := Next_Line & (1 .. S'Length - Next_Line'Length => ' ');
Length := Next_Line'Length;
File_Pointer := File_Pointer + 1;
exception
when Constraint_Error =>
if Is_End_of_File then
raise End_Error;
else
raise Status_Error;
end if;
end;
function Is_End_of_File return Boolean is
begin
return File_Pointer = (YYParse_Template_File'Last + 1);
end Is_End_of_File;
end Parse_Template_File;
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- The primary authors of ayacc were David Taback and Deepak Tolani.
-- Enhancements were made by Ronald J. Schmalz.
--
-- Send requests for ayacc information to ayacc-info@ics.uci.edu
-- Send bug reports for ayacc to ayacc-bugs@ics.uci.edu
--
-- Redistribution and use in source and binary forms are permitted
-- provided that the above copyright notice and this paragraph are
-- duplicated in all such forms and that any documentation,
-- advertising materials, and other materials related to such
-- distribution and use acknowledge that the software was developed
-- by the University of California, Irvine. The name of the
-- University may not be used to endorse or promote products derived
-- from this software without specific prior written permission.
-- THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
-- IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
-- WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
-- Module : parse_template_file_.ada
-- Component of : ayacc
-- Version : 1.2
-- Date : 11/21/86 12:33:46
-- SCCS File : disk21~/rschm/hasee/sccs/ayacc/sccs/sxparse_template_file_.ada
-- $Header: parse_template_file.a,v 0.1 86/04/01 15:09:47 ada Exp $
-- $Log: parse_template_file.a,v $
-- Revision 0.1 86/04/01 15:09:47 ada
-- This version fixes some minor bugs with empty grammars
-- and $$ expansion. It also uses vads5.1b enhancements
-- such as pragma inline.
--
--
-- Revision 0.0 86/02/19 18:40:09 ada
--
-- These files comprise the initial version of Ayacc
-- designed and implemented by David Taback and Deepak Tolani.
-- Ayacc has been compiled and tested under the Verdix Ada compiler
-- version 4.06 on a vax 11/750 running Unix 4.2BSD.
--
package Parse_Template_File is
Eof : constant Character := Ascii.Nul;
procedure Open;
procedure Read (S: out String; Length : out Integer);
procedure Close;
function Is_End_of_File return Boolean;
end Parse_Template_File;
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- The primary authors of ayacc were David Taback and Deepak Tolani.
-- Enhancements were made by Ronald J. Schmalz.
--
-- Send requests for ayacc information to ayacc-info@ics.uci.edu
-- Send bug reports for ayacc to ayacc-bugs@ics.uci.edu
--
-- Redistribution and use in source and binary forms are permitted
-- provided that the above copyright notice and this paragraph are
-- duplicated in all such forms and that any documentation,
-- advertising materials, and other materials related to such
-- distribution and use acknowledge that the software was developed
-- by the University of California, Irvine. The name of the
-- University may not be used to endorse or promote products derived
-- from this software without specific prior written permission.
-- THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
-- IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
-- WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
-- Module : parser.ada
-- Component of : ayacc
-- Version : 1.2
-- Date : 11/21/86 12:32:26
-- SCCS File : disk21~/rschm/hasee/sccs/ayacc/sccs/sxparser.ada
-- $Header: parser.a,v 0.1 86/04/01 15:10:10 ada Exp $
-- $Log: parser.a,v $
-- Revision 0.1 86/04/01 15:10:10 ada
-- This version fixes some minor bugs with empty grammars
-- and $$ expansion. It also uses vads5.1b enhancements
-- such as pragma inline.
--
--
-- Revision 0.0 86/02/19 18:40:20 ada
--
-- These files comprise the initial version of Ayacc
-- designed and implemented by David Taback and Deepak Tolani.
-- Ayacc has been compiled and tested under the Verdix Ada compiler
-- version 4.06 on a vax 11/750 running Unix 4.2BSD.
--
-- --
-- The parser for the user source file --
-- --
package Parser is
-- Parse the declarations section
procedure Parse_Declarations;
-- Parse the rules section
procedure Parse_Rules;
-- Self-explanatory
Syntax_Error : exception;
end;
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- The primary authors of ayacc were David Taback and Deepak Tolani.
-- Enhancements were made by Ronald J. Schmalz.
--
-- Send requests for ayacc information to ayacc-info@ics.uci.edu
-- Send bug reports for ayacc to ayacc-bugs@ics.uci.edu
--
-- Redistribution and use in source and binary forms are permitted
-- provided that the above copyright notice and this paragraph are
-- duplicated in all such forms and that any documentation,
-- advertising materials, and other materials related to such
-- distribution and use acknowledge that the software was developed
-- by the University of California, Irvine. The name of the
-- University may not be used to endorse or promote products derived
-- from this software without specific prior written permission.
-- THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
-- IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
-- WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
-- Module : parser_body.ada
-- Component of : ayacc
-- Version : 1.2
-- Date : 11/21/86 12:32:43
-- SCCS File : disk21~/rschm/hasee/sccs/ayacc/sccs/sxparser_body.ada
-- $Header: parser_body.a,v 0.1 86/04/01 15:10:24 ada Exp $
-- $Log: parser_body.a,v $
-- Revision 0.1 86/04/01 15:10:24 ada
-- This version fixes some minor bugs with empty grammars
-- and $$ expansion. It also uses vads5.1b enhancements
-- such as pragma inline.
--
--
-- Revision 0.0 86/02/19 18:40:31 ada
--
-- These files comprise the initial version of Ayacc
-- designed and implemented by David Taback and Deepak Tolani.
-- Ayacc has been compiled and tested under the Verdix Ada compiler
-- version 4.06 on a vax 11/750 running Unix 4.2BSD.
--
-- --
-- The body of the parser for the specification file --
-- --
with Text_IO; use Text_IO;
with Lexical_Analyzer; use Lexical_Analyzer;
with STR_Pack; use STR_Pack;
with Symbol_Table; use Symbol_Table;
with Rule_Table; use Rule_Table;
with Actions_File; use Actions_File;
with Tokens_File; use Tokens_File;
with String_Pkg;
package body Parser is
SCCS_ID : constant String := "@(#) parser_body.ada, Version 1.2";
Found_Error : Boolean := False;
Start_Defined : Boolean := False;
procedure Nonfatal_Error(Message: in String) is
begin
Print_Context_Lines;
--RJS Put_Line("--- " & Message);
New_Line;
Put_Line ("Ayacc: " & Message);
Found_Error := True;
end Nonfatal_Error;
procedure Fatal_Error(Message: in String) is
begin
Print_Context_Lines;
--RJS Put_Line("--- " & Message);
New_Line;
Put_Line ("Ayacc: " & Message);
raise Syntax_Error;
end Fatal_Error;
procedure Augment_Grammar(Users_Start_Symbol : in Grammar_Symbol) is
-- Inserts S' -> S $end as a rule in the rule table.
Start_Sym : Grammar_Symbol;
Augmented_Rule : Rule;
begin
Start_Defined := True;
Augmented_Rule := Make_Rule(Start_Symbol);
Append_RHS(Augmented_Rule, Users_Start_Symbol);
Append_RHS(Augmented_Rule, End_Symbol);
end Augment_Grammar;
-- --
-- A recursive descent parser for the rules in the --
-- grammar. --
procedure Parse_Rules is
T : Ayacc_Token;
Current_Rule : Rule;
LHS : Grammar_Symbol;
-- --
-- Gets an action from the file and writes it to --
-- the actions file. --
-- --
-- --
-- Parses a sequence of Symbols --
-- --
procedure Symbols is
ID : Grammar_Symbol;
Got_Action : Boolean := False;
Precedence_Level : Precedence;
begin
loop
T := Get_Token;
exit when T = Vertical_Bar or T = Semicolon or T = Prec;
-- Do we have an action in the middle of a rule?
if Got_Action then
Got_Action := T = Left_Brace;
Handle_Nested_Rule(Current_Rule);
end if;
case T is
-- Update the current rule
when Character_Literal =>
ID := Insert_Terminal(Get_Lexeme_Text);
Append_RHS(Current_Rule, ID);
-- Update the current rule and add to symbol table
when Identifier =>
ID := Insert_Identifier(Get_Lexeme_Text);
Append_RHS(Current_Rule, ID);
-- Got an action
when Left_Brace =>
Handle_Action(Integer(Current_Rule),
Integer(Length_of(Current_Rule)));
Got_Action := True;
when others =>
Fatal_Error("Unexpected symbol");
end case;
end loop;
if T = Prec then
if Got_Action then
Fatal_Error("%prec cannot be preceded by an action");
raise Syntax_Error;
end if;
T := Get_Token;
if T /= Identifier and T /= Character_Literal then
Fatal_Error("Expecting a terminal after %prec");
end if;
ID := Insert_Identifier(Get_Lexeme_Text);
if Is_Nonterminal(ID) then
Fatal_Error("Expecting a terminal after %prec");
end if;
Precedence_Level := Get_Precedence(ID);
if Precedence_Level = 0 then
Fatal_Error("Terminal following %prec has no precedence");
else
Set_Rule_Precedence(Current_Rule, Precedence_Level);
end if;
T := Get_Token;
case T is
when Left_Brace =>
Handle_Action(Integer(Current_Rule),
Integer(Length_of(Current_Rule)));
T := Get_Token;
when Semicolon | Vertical_Bar =>
null;
when others =>
Fatal_Error("Illegal token following %prec");
end case;
end if;
end Symbols;
-- --
-- Parse an ayacc grammar rule --
-- --
procedure Rule is
begin
T := Get_Token;
if T /= Colon then
Fatal_Error("Expecting a colon after the LHS of the rule");
else
Current_Rule := Make_Rule(LHS);
Symbols;
end if;
while (T = Vertical_Bar) loop
-- Make a new rule with the current LHS grammar symbol
Current_Rule := Make_Rule(LHS);
Symbols;
end loop;
if T /= Semicolon then
Fatal_Error("Expecting a semicolon");
end if;
end Rule;
-- --
-- Parse a sequence of grammar rules --
-- --
procedure Rules is
begin
T := Get_Token;
if T = Identifier then
-- Make the left hand side of the rule
LHS := Insert_Identifier(Get_Lexeme_Text);
if Is_Terminal(LHS) then
Fatal_Error("Terminals cannot be on the LHS of a rule");
end if;
if not Start_Defined then
Augment_Grammar(LHS);
end if;
Rule;
Rules;
elsif T /= Mark then
Fatal_Error("Expecting next section");
end if;
end Rules;
begin -- parse_rules
Actions_File.Initialize;
Rules;
Actions_File.Finish;
-- Check for empty grammars. If the grammar is empty then
-- create a rule S -> $end.
if not Start_Defined then
Append_RHS(Make_Rule(Start_Symbol), End_Symbol);
end if;
exception
when Illegal_Token =>
Fatal_Error("illegal token");
end Parse_Rules;
-- --
-- Parse the declarations section of the source --
-- --
procedure Parse_Declarations is
Precedence_Level : Precedence := 0;
Next_Token : Ayacc_Token;
ID : Grammar_Symbol;
procedure Parse_Start_Symbol is
Users_Start_Symbol : Grammar_Symbol;
begin
if Start_Defined then
Fatal_Error("The start symbol has been defined already.");
end if;
if Next_Token /= Identifier then
if Next_Token = Lexical_Analyzer.Eof_Token then
Fatal_Error("Unexpected end of file before first '%%'");
else
Fatal_Error("Expecting identifier");
end if;
end if;
Users_Start_Symbol := Insert_Identifier(Get_Lexeme_Text);
if Is_Nonterminal(Users_Start_Symbol) then
Augment_Grammar(Users_Start_Symbol);
else
Fatal_Error("Attempt to define terminal as start_symbol");
end if;
Next_Token := Get_Token;
end Parse_Start_Symbol;
procedure Parse_Token_List(Precedence_Value : in Precedence;
Associativity_Value : in Associativity) is
Temp_Sym : Grammar_Symbol;
begin
loop
if Next_Token /= Identifier and then
Next_Token /= Character_Literal then
if Next_Token = Lexical_Analyzer.Eof_Token then
Fatal_Error("Unexpected end of file before first '%%'");
else
Fatal_Error("Expecting token declaration");
end if;
end if;
Temp_Sym := Insert_Terminal(Get_Lexeme_Text,
Precedence_Value,
Associativity_Value);
Next_Token := Get_Token;
if Next_Token = Comma then
Next_Token := Get_Token;
elsif Next_Token = Semicolon then
Next_Token := Get_Token;
exit;
elsif Next_Token /= Identifier and then
Next_Token /= Character_Literal then
exit;
end if;
end loop;
exception
when Illegal_Entry =>
-- I think only trying to insert the "start symbol"
-- in a token list will cause this exception
Fatal_Error("Illegal symbol as token");
end Parse_Token_List;
procedure Parse_Package_Name_List(Context_Clause : in Ayacc_Token) is
use String_Pkg;
begin
if Tokens_Package_Header_Has_Been_Generated then
Fatal_Error ("Context Clause Specifications May Not " &
"Appear After Ada Declarations.");
else
case Context_Clause is
when With_Clause =>
Tokens_File.Write ("with ");
when Use_Clause =>
Tokens_File.Write ("use ");
when others =>
Fatal_Error ("Illegal Context Clause Specification");
end case;
loop
if Next_Token /= Identifier then
if Next_Token = Lexical_Analyzer.Eof_Token then
Fatal_Error("Unexpected end of file before first '%%'");
else
Fatal_Error("Expecting Package Name");
end if;
end if;
Tokens_File.Write (' ' & Value (Mixed (Get_Lexeme_Text)));
Next_Token := Get_Token;
if Next_Token = Comma then
Next_Token := Get_Token;
Tokens_File.Write (",");
elsif Next_Token = Semicolon then
Next_Token := Get_Token;
Tokens_File.Writeln (";");
exit;
elsif Next_Token /= Identifier then
Tokens_File.Writeln (";");
exit;
else
Tokens_File.Write (",");
end if;
end loop;
end if;
end Parse_Package_Name_List;
begin
Next_Token := Get_Token;
loop
case Next_Token is
when Start =>
Next_Token := Get_Token;
Parse_Start_Symbol;
if Next_Token = Semicolon then
Next_Token := Get_Token;
end if;
when Token =>
Next_Token := Get_Token;
Parse_Token_List(0, Undefined);
when Nonassoc =>
Next_Token := Get_Token;
Precedence_Level := Precedence_Level + 1;
Parse_Token_List(Precedence_Level, Nonassociative);
when Right =>
Next_Token := Get_Token;
Precedence_Level := Precedence_Level + 1;
Parse_Token_List(Precedence_Level, Right_Associative);
when Left =>
Next_Token := Get_Token;
Precedence_Level := Precedence_Level + 1;
Parse_Token_List(Precedence_Level, Left_Associative);
when Mark =>
exit;
when Lexical_Analyzer.Eof_Token =>
Fatal_Error("Unexpected end of file before first %%");
when Left_Brace =>
Start_Tokens_Package;
Dump_Declarations; -- to the TOKENS file.
Next_Token := Get_Token;
when With_Clause =>
Next_Token := Get_Token;
Parse_Package_Name_List (With_Clause);
when Use_Clause =>
Next_Token := Get_Token;
Parse_Package_Name_List (Use_Clause);
when others =>
Fatal_Error("Unexpected symbol");
end case;
end loop;
exception
when Illegal_Token =>
Fatal_Error("Bad symbol");
when Redefined_Precedence_Error =>
Fatal_Error("Attempt to redefine precedence");
end Parse_Declarations;
end Parser;
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- The primary authors of ayacc were David Taback and Deepak Tolani.
-- Enhancements were made by Ronald J. Schmalz.
--
-- Send requests for ayacc information to ayacc-info@ics.uci.edu
-- Send bug reports for ayacc to ayacc-bugs@ics.uci.edu
--
-- Redistribution and use in source and binary forms are permitted
-- provided that the above copyright notice and this paragraph are
-- duplicated in all such forms and that any documentation,
-- advertising materials, and other materials related to such
-- distribution and use acknowledge that the software was developed
-- by the University of California, Irvine. The name of the
-- University may not be used to endorse or promote products derived
-- from this software without specific prior written permission.
-- THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
-- IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
-- WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
-- Module : ragged.ada
-- Component of : ayacc
-- Version : 1.2
-- Date : 11/21/86 12:34:00
-- SCCS File : disk21~/rschm/hasee/sccs/ayacc/sccs/sxragged.ada
-- $Header: ragged.a,v 0.1 86/04/01 15:11:22 ada Exp $
-- $Log: ragged.a,v $
-- Revision 0.1 86/04/01 15:11:22 ada
-- This version fixes some minor bugs with empty grammars
-- and $$ expansion. It also uses vads5.1b enhancements
-- such as pragma inline.
--
--
-- Revision 0.0 86/02/19 18:40:45 ada
--
-- These files comprise the initial version of Ayacc
-- designed and implemented by David Taback and Deepak Tolani.
-- Ayacc has been compiled and tested under the Verdix Ada compiler
-- version 4.06 on a vax 11/750 running Unix 4.2BSD.
--
-- Remeber to get rid of rval as soon as all bugs have been eliminated
-- from routines that use this package.
generic
type Row_Index is (<>);
type Col_Index is (<>);
type Item is limited private;
with procedure Null_Value(Value : in out Item);
package Ragged is
-- Cell and index should be private but for efficency and for subtle
-- problems that arise when type item is implemeted as a limited private
-- in an external package, cell and index are kept visible.
type Cell;
type Index is access Cell;
pragma Controlled(Index);
type Hidden_Type is limited private;
type Cell is
record
Value : Item;
Hidden : Hidden_Type;
end record;
-- Use for retrieving the value of array(x,y). Raises value range
-- error if no such location has been allocated yet.
-- eg: value := rval(x,y).value;
function Rval(X: Row_Index; Y: Col_Index) return Index;
-- Use for setting a value in array(x,y). Allocates new storage
-- if the location does not exist yet. Can also use it if you
-- require a preinitialization value
-- eg: lval(x,y).value := value;
-- if lval(x,y).value = 0 then ...
function Lval(X: Row_Index; Y: Col_Index) return Index;
procedure Make_Array(Lower, Upper: Row_Index);
procedure Initialize(Iterator : out Index; Row : Row_Index);
procedure Next(Iterator : in out Index);
procedure Free_Array;
Value_Range_Error : exception;
private
type Hidden_Type is
record
Column : Col_Index;
Next : Index;
end record;
end Ragged;
with Unchecked_Deallocation;
package body Ragged is
SCCS_ID : constant String := "@(#) ragged.ada, Version 1.2";
-- The ragged array is implemented as a vector indexed by row
-- of linked lists of (column,value) pairs in sorted order.
type Cells is array( Row_Index range<> ) of Index;
type Cells_Ptr is access Cells;
pragma Controlled(Cells_Ptr);
Vector : Cells_Ptr;
procedure Make_Array(Lower, Upper: Row_Index) is
begin
Vector := new Cells(Lower..Upper);
for I in Vector.all'range loop
Vector(I) := null;
end loop;
end Make_Array;
function New_Cell(Column : Col_Index; Next : Index) return Index is
Temp : Index;
begin
Temp := new Cell;
Temp.Hidden.Column := Column;
Temp.Hidden.Next := Next;
-- Will this work or do I need to null_value vector ?
Null_Value(Temp.Value);
return Temp;
end New_Cell;
function Lval(X: Row_Index; Y: Col_Index) return Index is
Ptr, Last : Index;
begin
-- If a new cell is created its value field is uninitialized.
-- Add to the beginning of the list ?
if Vector(X) = null or else Vector(X).Hidden.Column > Y then
Ptr := Vector(X);
Vector(X) := New_Cell(Y,Ptr);
return Vector(X);
end if;
-- Add in the middle of the list ?
Ptr := Vector(X);
while Ptr /= null loop
if Ptr.Hidden.Column = Y then
return Ptr;
elsif Ptr.Hidden.Column > Y then
Last.Hidden.Next := New_Cell(Y,Ptr);
return Last.Hidden.Next;
end if;
Last := Ptr;
Ptr := Ptr.Hidden.Next;
end loop;
-- Add at the end of the list
Last.Hidden.Next := New_Cell(Y,null);
return Last.Hidden.Next;
end Lval;
function Rval(X: Row_Index; Y: Col_Index) return Index is
Ptr : Index;
begin
Ptr := Vector(X);
while Ptr /= null and then Ptr.Hidden.Column < Y loop
Ptr := Ptr.Hidden.Next;
end loop;
if Ptr = null or else Ptr.Hidden.Column > Y then
raise Value_Range_Error;
else -- ptr.hidden.column = y
return Ptr;
end if;
end Rval;
procedure Initialize(Iterator : out Index; Row : Row_Index) is
begin
Iterator := Vector(Row);
end;
procedure Next(Iterator : in out Index) is
begin
Iterator := Iterator.Hidden.Next;
end;
-- procedure free(i: index);
-- pragma interface(c,free);
procedure Free is new Unchecked_Deallocation(Cell, Index);
procedure Free is new Unchecked_Deallocation(Cells, Cells_Ptr);
procedure Free_Array is
Traverse : Index;
begin
for I in Vector.all'range loop
while Vector(I) /= null loop
Traverse := Vector(I);
Vector(I) := Vector(I).Hidden.Next;
Null_Value(Traverse.Value); -- free value if its a ptr
Free(Traverse);
end loop;
end loop;
Free(Vector);
end Free_Array;
end Ragged;
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- The primary authors of ayacc were David Taback and Deepak Tolani.
-- Enhancements were made by Ronald J. Schmalz.
--
-- Send requests for ayacc information to ayacc-info@ics.uci.edu
-- Send bug reports for ayacc to ayacc-bugs@ics.uci.edu
--
-- Redistribution and use in source and binary forms are permitted
-- provided that the above copyright notice and this paragraph are
-- duplicated in all such forms and that any documentation,
-- advertising materials, and other materials related to such
-- distribution and use acknowledge that the software was developed
-- by the University of California, Irvine. The name of the
-- University may not be used to endorse or promote products derived
-- from this software without specific prior written permission.
-- THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
-- IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
-- WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
-- Module : rule_table.ada
-- Component of : ayacc
-- Version : 1.2
-- Date : 11/21/86 12:34:14
-- SCCS File : disk21~/rschm/hasee/sccs/ayacc/sccs/sxrule_table.ada
-- $Header: rule_table.a,v 0.1 86/04/01 15:11:37 ada Exp $
-- $Log: rule_table.a,v $
-- Revision 0.1 86/04/01 15:11:37 ada
-- This version fixes some minor bugs with empty grammars
-- and $$ expansion. It also uses vads5.1b enhancements
-- such as pragma inline.
--
--
-- Revision 0.0 86/02/19 18:40:56 ada
--
-- These files comprise the initial version of Ayacc
-- designed and implemented by David Taback and Deepak Tolani.
-- Ayacc has been compiled and tested under the Verdix Ada compiler
-- version 4.06 on a vax 11/750 running Unix 4.2BSD.
--
with Symbol_Table;
use Symbol_Table;
package Rule_Table is
-- This package is used to store and access the rules
-- of the input grammar.
Max_Rules : constant := 1_000; -- An arbitrary upper bound.
type Rule is range 0..Max_Rules - 1;
function Make_Rule(LHS: Grammar_Symbol) return Rule;
procedure Append_RHS(R: in Rule; RHS: in Grammar_Symbol);
function Get_LHS (R: Rule) return Grammar_Symbol;
function Get_RHS (R: Rule; Position: Positive) return Grammar_Symbol;
function Get_Null_Pos (R: Rule) return Natural;
function Get_Rule_Precedence (R: Rule) return Precedence;
function Length_of(R: Rule) return Natural;
function First_Rule return Rule;
function Last_Rule return Rule;
function Number_of_Rules return Natural;
procedure Set_Rule_Precedence (R: in Rule; Prec: in Precedence);
procedure Set_Null_Pos (R: in Rule; Position: in Natural);
procedure Handle_Nested_Rule (Current_Rule : in out Rule);
--RJS pragma inline(get_lhs, get_null_pos, get_rule_precedence, length_of);
--& pragma inline(first_rule, last_rule);
end Rule_Table;
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- The primary authors of ayacc were David Taback and Deepak Tolani.
-- Enhancements were made by Ronald J. Schmalz.
--
-- Send requests for ayacc information to ayacc-info@ics.uci.edu
-- Send bug reports for ayacc to ayacc-bugs@ics.uci.edu
--
-- Redistribution and use in source and binary forms are permitted
-- provided that the above copyright notice and this paragraph are
-- duplicated in all such forms and that any documentation,
-- advertising materials, and other materials related to such
-- distribution and use acknowledge that the software was developed
-- by the University of California, Irvine. The name of the
-- University may not be used to endorse or promote products derived
-- from this software without specific prior written permission.
-- THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
-- IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
-- WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
-- Module : rule_table_body.ada
-- Component of : ayacc
-- Version : 1.2
-- Date : 11/21/86 12:34:28
-- SCCS File : disk21~/rschm/hasee/sccs/ayacc/sccs/sxrule_table_body.ada
-- $Header: rule_table_body.a,v 0.1 86/04/01 15:11:44 ada Exp $
-- $Log: rule_table_body.a,v $
-- Revision 0.1 86/04/01 15:11:44 ada
-- This version fixes some minor bugs with empty grammars
-- and $$ expansion. It also uses vads5.1b enhancements
-- such as pragma inline.
--
--
-- Revision 0.0 86/02/19 18:41:08 ada
--
-- These files comprise the initial version of Ayacc
-- designed and implemented by David Taback and Deepak Tolani.
-- Ayacc has been compiled and tested under the Verdix Ada compiler
-- version 4.06 on a vax 11/750 running Unix 4.2BSD.
--
package body Rule_Table is
SCCS_ID : constant String := "@(#) rule_table_body.ada, Version 1.2";
Rcs_ID : constant String := "$Header: rule_table_body.a,v 0.1 86/04/01 15:11:44 ada Exp $";
-- Rules are implemented as an array of linked lists
Number_of_Nested_Rules : Integer := 0;
type RHS_Element;
type RHS_Pointer is access RHS_Element;
type RHS_Element is
record
RHS_Symbol: Grammar_Symbol;
Next : RHS_Pointer;
end record;
type Rule_Entry is
record
LHS_Symbol : Grammar_Symbol;
RHS : RHS_Pointer;
Length : Natural;
Null_Pos : Natural;
Prec : Precedence;
end record;
Rule_List: array(Rule) of Rule_Entry;
Next_Free_Rule: Rule := 0;
function Get_Rule_Precedence(R : Rule) return Precedence is
begin
return Rule_List(R).Prec;
end Get_Rule_Precedence;
function Make_Rule(LHS: Grammar_Symbol) return Rule is
R : Rule := Next_Free_Rule;
begin
Rule_List(R) :=
(LHS, RHS => null, Length => 0, Null_Pos => 0, Prec => 0);
Next_Free_Rule := Next_Free_Rule + 1;
return R;
end Make_Rule;
procedure Append_RHS(R: in Rule; RHS: in Grammar_Symbol) is
Temp_Pointer: RHS_Pointer;
begin
if Is_Terminal(RHS) then
Rule_List(R).Prec := Get_Precedence(RHS);
end if;
if Rule_List(R).RHS = null then
Rule_List(R).RHS := new RHS_Element'(RHS, null);
else
Temp_Pointer := Rule_List(R).RHS;
while Temp_Pointer.Next /= null loop
Temp_Pointer := Temp_Pointer.Next;
end loop;
Temp_Pointer.Next := new RHS_Element'(RHS, null);
end if;
Rule_List(R).Length := Rule_List(R).Length + 1;
end Append_RHS;
function Get_LHS(R: Rule) return Grammar_Symbol is
begin
return Rule_List(R).LHS_Symbol;
end Get_LHS;
function Get_Null_Pos(R: Rule) return Natural is
begin
return Rule_List(R).Null_Pos;
end Get_Null_Pos;
procedure Set_Null_Pos(R : in Rule; Position: in Natural) is
begin
Rule_List(R).Null_Pos := Position;
end Set_Null_Pos;
function Get_RHS(R: Rule; Position: Positive) return Grammar_Symbol is
Temp_Pointer: RHS_Pointer;
begin
Temp_Pointer := Rule_List(R).RHS;
for I in 2..Position loop
Temp_Pointer := Temp_Pointer.Next;
end loop;
return Temp_Pointer.RHS_Symbol;
end Get_RHS;
function Length_of(R: Rule) return Natural is
begin
return Rule_List(R).Length;
end Length_of;
function First_Rule return Rule is
begin
return 0;
end First_Rule;
function Last_Rule return Rule is
begin
return Next_Free_Rule - 1;
end Last_Rule;
function Number_of_Rules return Natural is
begin
return Natural(Next_Free_Rule) - 1;
end Number_of_Rules;
procedure Handle_Nested_Rule(Current_Rule : in out Rule) is
Temp : Rule_Entry;
LHS : Grammar_Symbol;
New_Rule : Rule;
begin
-- Make a new rule prefixed by $$N
Number_of_Nested_Rules := Number_of_Nested_Rules + 1;
LHS := Insert_Identifier("$$" & Integer'Image(Number_of_Nested_Rules));
New_Rule := Make_Rule(LHS);
Append_RHS(Current_Rule,LHS);
-- Exchange the rule positions of the new rule and the current rule
-- by swapping contents and exchanging the rule positions
Temp := Rule_List(Current_Rule);
Rule_List(Current_Rule) := Rule_List(New_Rule);
Rule_List(New_Rule) := Temp;
Current_Rule := New_Rule;
end Handle_Nested_Rule;
procedure Set_Rule_Precedence(R: in Rule; Prec: in Precedence) is
begin
Rule_List(R).Prec := Prec;
end Set_Rule_Precedence;
end Rule_Table;
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- The primary authors of ayacc were David Taback and Deepak Tolani.
-- Enhancements were made by Ronald J. Schmalz.
--
-- Send requests for ayacc information to ayacc-info@ics.uci.edu
-- Send bug reports for ayacc to ayacc-bugs@ics.uci.edu
--
-- Redistribution and use in source and binary forms are permitted
-- provided that the above copyright notice and this paragraph are
-- duplicated in all such forms and that any documentation,
-- advertising materials, and other materials related to such
-- distribution and use acknowledge that the software was developed
-- by the University of California, Irvine. The name of the
-- University may not be used to endorse or promote products derived
-- from this software without specific prior written permission.
-- THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
-- IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
-- WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
-- Module : set_pack.ada
-- Component of : ayacc
-- Version : 1.2
-- Date : 11/21/86 12:34:47
-- SCCS File : disk21~/rschm/hasee/sccs/ayacc/sccs/sxset_pack.ada
-- $Header: set_pack.a,v 0.1 86/04/01 15:11:51 ada Exp $
-- $Log: set_pack.a,v $
-- Revision 0.1 86/04/01 15:11:51 ada
-- This version fixes some minor bugs with empty grammars
-- and $$ expansion. It also uses vads5.1b enhancements
-- such as pragma inline.
--
--
-- Revision 0.0 86/02/19 18:41:22 ada
--
-- These files comprise the initial version of Ayacc
-- designed and implemented by David Taback and Deepak Tolani.
-- Ayacc has been compiled and tested under the Verdix Ada compiler
-- version 4.06 on a vax 11/750 running Unix 4.2BSD.
--
-- Uses the predefined equality operator "=" on variables of type Universe
generic
type Universe is private;
with function "<" (Element_1, Element_2: Universe) return Boolean;
package Set_Pack is
type Set is limited private;
procedure Make_Null (Set_1: in out Set);
procedure Insert (Element : in Universe; Into : in out Set);
procedure Insert (Set_1 : in Set; Into : in out Set);
procedure Delete (Element : in Universe; From : in out Set);
procedure Assign (Object : in out Set; Value : in Set);
-- Nulls value !
procedure Fassign(Object : in out Set; Value : in out Set);
function Is_Member (Element: Universe; Of_Set: Set) return Boolean;
function Is_Empty (Set_1: Set) return Boolean;
function Size_of (Set_1: Set) return Natural;
function "=" (Set_1 : Set; Set_2 : Set) return Boolean;
type Set_Iterator is limited private;
procedure Initialize (Iterator : in out Set_Iterator; Using : in Set);
function More (Iterator: Set_Iterator) return Boolean;
procedure Next (Iterator: in out Set_Iterator; Element: out Universe);
No_More_Elements : exception;
-- raised if you call NEXT when MORE is false.
--RJS
pragma inline(is_empty, size_of, more, next);
private
type Cell;
type Link is access Cell;
type Set is
record
Size : Natural;
Head : Link := null;
end record;
type Set_Iterator is new Link;
end Set_Pack;
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- The primary authors of ayacc were David Taback and Deepak Tolani.
-- Enhancements were made by Ronald J. Schmalz.
--
-- Send requests for ayacc information to ayacc-info@ics.uci.edu
-- Send bug reports for ayacc to ayacc-bugs@ics.uci.edu
--
-- Redistribution and use in source and binary forms are permitted
-- provided that the above copyright notice and this paragraph are
-- duplicated in all such forms and that any documentation,
-- advertising materials, and other materials related to such
-- distribution and use acknowledge that the software was developed
-- by the University of California, Irvine. The name of the
-- University may not be used to endorse or promote products derived
-- from this software without specific prior written permission.
-- THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
-- IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
-- WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
-- Module : set_pack_body.ada
-- Component of : ayacc
-- Version : 1.2
-- Date : 11/21/86 12:35:14
-- SCCS File : disk21~/rschm/hasee/sccs/ayacc/sccs/sxset_pack_body.ada
-- $Header: set_pack_body.a,v 0.1 86/04/01 15:11:59 ada Exp $
-- $Log: set_pack_body.a,v $
-- Revision 0.1 86/04/01 15:11:59 ada
-- This version fixes some minor bugs with empty grammars
-- and $$ expansion. It also uses vads5.1b enhancements
-- such as pragma inline.
--
--
-- Revision 0.0 86/02/19 18:41:30 ada
--
-- These files comprise the initial version of Ayacc
-- designed and implemented by David Taback and Deepak Tolani.
-- Ayacc has been compiled and tested under the Verdix Ada compiler
-- version 4.06 on a vax 11/750 running Unix 4.2BSD.
--
package body Set_Pack is
SCCS_ID : constant String := "@(#) set_pack_body.ada, Version 1.2";
Rcs_ID : constant String := "$Header: set_pack_body.a,v 0.1 86/04/01 15:11:59 ada Exp $";
type Cell is
record
Value : Universe;
Next : Link;
end record;
Extras : Link; -- For garbage collection.
function Get_Node return Link;
--RJS pragma inline(get_node);
function Get_Node return Link is
Temp_Link : Link;
begin
if Extras = null then
return new Cell;
else
Temp_Link := Extras;
Extras := Extras.Next;
Temp_Link.Next := null;
return Temp_Link;
end if;
end Get_Node;
procedure Make_Null (Set_1: in out Set) is
Temp_Link : Link;
begin
if Set_1.Head = null then
Set_1.Size := 0;
return;
end if;
-- Find tail of set_1 --
Temp_Link := Set_1.Head;
while Temp_Link.Next /= null loop
Temp_Link := Temp_Link.Next;
end loop;
-- Add set_1 elements to the extras stack --
Temp_Link.Next := Extras;
Extras := Set_1.Head;
Set_1 := (Size => 0, Head => null);
end Make_Null;
procedure Assign (Object : in out Set; Value : in Set) is
Temp_1, Temp_2: Link;
begin
if Object = Value then
return;
else
Make_Null(Object);
end if;
if Value.Head = null then
return;
end if;
Object.Head := Get_Node;
Object.Head.Value := Value.Head.Value;
Object.Head.Next := null;
Temp_1 := Object.Head;
Temp_2 := Value.Head.Next;
while Temp_2 /= null loop
Temp_1.Next := Get_Node;
Temp_1.Next.all := (Value => Temp_2.Value, Next => null);
Temp_1 := Temp_1.Next;
Temp_2 := Temp_2.Next;
end loop;
Temp_1.Next := null;
Object.Size := Value.Size;
end Assign;
procedure Insert (Element : in Universe; Into : in out Set) is
Temp_Link : Link;
Temp_Link_2 : Link;
begin
if Into.Head = null or else Element < Into.Head.Value then
Temp_Link := Get_Node;
Temp_Link.all := (Value => Element, Next => Into.Head);
Into.Head := Temp_Link;
Into.Size := Into.Size + 1;
return;
end if;
if Into.Head.Value = Element then
return;
end if;
Temp_Link := Into.Head;
while Temp_Link.Next /= null loop
if Element = Temp_Link.Next.Value then -- Already in the list.
return;
elsif Element < Temp_Link.Next.Value then
exit; -- Found place to insert.
else
Temp_Link := Temp_Link.Next;
end if;
end loop;
-- insert element --
Temp_Link_2 := Get_Node;
Temp_Link_2.Next := Temp_Link.Next;
Temp_Link_2.Value := Element;
Temp_Link.Next := Temp_Link_2;
Into.Size := Into.Size + 1;
end Insert;
procedure Insert (Set_1 : in Set; Into : in out Set) is
Temp, Trav1, Trav2 : Link;
begin
if Set_1.Head = null then
return;
elsif Set_1.Head = Into.Head then
return;
elsif Into.Head = null then
Assign(Into, Set_1);
return;
end if;
if Set_1.Head.Value < Into.Head.Value then
Temp := Into.Head;
Into.Head := Get_Node;
Into.Head.all := (Set_1.Head.Value, Temp);
Trav1 := Set_1.Head.Next;
Into.Size := Into.Size + 1;
elsif Set_1.Head.Value = Into.Head.Value then
Trav1 := Set_1.Head.Next;
else
Trav1 := Set_1.Head;
end if;
Trav2 := Into.Head;
while Trav1 /= null loop
while Trav2.Next /= null and then
Trav2.Next.Value < Trav1.Value loop
Trav2 := Trav2.Next;
end loop;
if Trav2.Next = null then
while Trav1 /= null loop
Trav2.Next := Get_Node;
Trav2.Next.all := (Trav1.Value, null);
Trav1 := Trav1.Next;
Trav2 := Trav2.Next;
Into.Size := Into.Size + 1;
end loop;
return;
end if;
if Trav2.Next.Value /= Trav1.Value then
Temp := Trav2.Next;
Trav2.Next := Get_Node;
Trav2.Next.all := (Trav1.Value, Temp);
Trav2 := Trav2.Next;
Into.Size := Into.Size + 1;
end if;
Trav1 := Trav1.Next;
end loop;
end Insert;
procedure Delete (Element : in Universe; From : in out Set) is
Temp_Link : Link;
T : Link;
begin
if From.Head = null then
return;
elsif Element < From.Head.Value then
return;
elsif Element = From.Head.Value then
Temp_Link := From.Head;
From.Head := From.Head.Next;
From.Size := From.Size - 1;
Temp_Link.Next := Extras;
Extras := Temp_Link;
return;
end if;
Temp_Link := From.Head;
while Temp_Link.Next /= null and then
Temp_Link.Next.Value < Element
loop
Temp_Link := Temp_Link.Next;
end loop;
if Temp_Link.Next /= null and then
Temp_Link.Next.Value = Element
then
T := Temp_Link.Next;
Temp_Link.Next := Temp_Link.Next.Next;
T.Next := Extras;
Extras := T;
From.Size := From.Size - 1;
end if;
end Delete;
procedure Fassign (Object : in out Set; Value : in out Set) is
begin
-- Free the contents of OBJECT first.
Object := Value;
Value := (Head => null, Size => 0);
end Fassign;
function Is_Member (Element: Universe; Of_Set: Set) return Boolean is
Temp_Link : Link;
begin
Temp_Link := Of_Set.Head;
while Temp_Link /= null and then Temp_Link.Value < Element loop
Temp_Link := Temp_Link.Next;
end loop;
return Temp_Link /= null and then Temp_Link.Value = Element;
end Is_Member;
function Is_Empty (Set_1: Set) return Boolean is
begin
return Set_1.Head = null;
end Is_Empty;
function Size_of (Set_1: Set) return Natural is
begin
return Set_1.Size;
end Size_of;
function "=" (Set_1 : Set; Set_2 : Set) return Boolean is
Link_1, Link_2: Link;
begin
if Set_1.Size /= Set_2.Size then
return False;
end if;
Link_1 := Set_1.Head;
Link_2 := Set_2.Head;
while Link_1 /= null and then Link_2 /= null loop
if Link_1.Value /= Link_2.Value then
exit;
end if;
Link_1 := Link_1.Next;
Link_2 := Link_2.Next;
end loop;
return Link_1 = Link_2; -- True if both equal to null
end "=";
procedure Initialize (Iterator : in out Set_Iterator; Using : in Set) is
begin
Iterator := Set_Iterator(Using.Head);
end Initialize;
function More (Iterator: Set_Iterator) return Boolean is
begin
return Iterator /= null;
end More;
procedure Next (Iterator: in out Set_Iterator; Element: out Universe) is
begin
Element := Iterator.Value;
Iterator := Set_Iterator(Iterator.Next);
exception
when Constraint_Error =>
raise No_More_Elements;
end Next;
end Set_Pack;
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- The primary authors of ayacc were David Taback and Deepak Tolani.
-- Enhancements were made by Ronald J. Schmalz.
--
-- Send requests for ayacc information to ayacc-info@ics.uci.edu
-- Send bug reports for ayacc to ayacc-bugs@ics.uci.edu
--
-- Redistribution and use in source and binary forms are permitted
-- provided that the above copyright notice and this paragraph are
-- duplicated in all such forms and that any documentation,
-- advertising materials, and other materials related to such
-- distribution and use acknowledge that the software was developed
-- by the University of California, Irvine. The name of the
-- University may not be used to endorse or promote products derived
-- from this software without specific prior written permission.
-- THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
-- IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
-- WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
-- Module : shift_reduce_file.ada
-- Component of : ayacc
-- Version : 1.2
-- Date : 11/21/86 12:35:35
-- SCCS File : disk21~/rschm/hasee/sccs/ayacc/sccs/sxshift_reduce_file.ada
-- $Header: shift_reduce_file.a,v 0.1 86/04/01 15:12:13 ada Exp $
-- $Log: shift_reduce_file.a,v $
-- Revision 0.1 86/04/01 15:12:13 ada
-- This version fixes some minor bugs with empty grammars
-- and $$ expansion. It also uses vads5.1b enhancements
-- such as pragma inline.
--
--
-- Revision 0.0 86/02/19 18:41:42 ada
--
-- These files comprise the initial version of Ayacc
-- designed and implemented by David Taback and Deepak Tolani.
-- Ayacc has been compiled and tested under the Verdix Ada compiler
-- version 4.06 on a vax 11/750 running Unix 4.2BSD.
--
package Shift_Reduce_File is
procedure Open_Write;
procedure Write(S: in String);
procedure Write_Line(S: in String);
procedure Write(C: in Character);
procedure Close_Write;
end Shift_Reduce_File;
with Text_IO, File_Names;
use Text_IO, File_Names;
package body Shift_Reduce_File is
SCCS_ID : constant String := "@(#) shift_reduce_file.ada, Version 1.2";
Rcs_ID : constant String := "$Header: shift_reduce_file.a,v 0.1 86/04/01 15:12:13 ada Exp $";
The_File : File_Type;
procedure Open_Write is
begin
Create(The_File, Out_File, Get_Shift_Reduce_File_Name);
Write_Line("package " & Shift_Reduce_Tables_Unit_Name & " is");
Write_Line("");
Write_Line(" type Small_Integer is range -32_000 .. 32_000;");
Write_Line("");
Write_Line(" type Shift_Reduce_Entry is record");
Write_Line(" T : Small_Integer;");
Write_Line(" Act : Small_Integer;");
Write_Line(" end record;");
Write_Line(" pragma Pack(Shift_Reduce_Entry);");
Write_Line("");
Write_Line(" subtype Row is Integer range -1 .. Integer'Last;");
Write_Line("");
Write_Line(" --pragma suppress(index_check);");
Write_Line("");
Write_Line(" type Shift_Reduce_Array is array " &
"(Row range <>) of Shift_Reduce_Entry;");
Write_Line("");
Write_Line(" Shift_Reduce_Matrix : constant Shift_Reduce_Array :=");
Write_Line(" ( (-1,-1) -- Dummy Entry");
New_Line(The_File);
end Open_Write;
procedure Close_Read is
begin
Delete(The_File);
end Close_Read;
procedure Close_Write is
begin
Write_Line("end " & Shift_Reduce_Tables_Unit_Name & ";");
Close(The_File);
end Close_Write;
procedure Write(S: in String) is
begin
Put(The_File, S) ;
end;
procedure Write_Line(S: in String) is
begin
Put_Line(The_File, S);
end Write_Line;
procedure Write(C: in Character) is
begin
Put(The_File,C);
end;
end Shift_Reduce_File;
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- The primary authors of ayacc were David Taback and Deepak Tolani.
-- Enhancements were made by Ronald J. Schmalz.
--
-- Send requests for ayacc information to ayacc-info@ics.uci.edu
-- Send bug reports for ayacc to ayacc-bugs@ics.uci.edu
--
-- Redistribution and use in source and binary forms are permitted
-- provided that the above copyright notice and this paragraph are
-- duplicated in all such forms and that any documentation,
-- advertising materials, and other materials related to such
-- distribution and use acknowledge that the software was developed
-- by the University of California, Irvine. The name of the
-- University may not be used to endorse or promote products derived
-- from this software without specific prior written permission.
-- THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
-- IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
-- WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
-- Module : source_file.ada
-- Component of : ayacc
-- Version : 1.2
-- Date : 11/21/86 12:35:54
-- SCCS File : disk21~/rschm/hasee/sccs/ayacc/sccs/sxsource_file.ada
-- $Header: source_file.a,v 0.1 86/04/01 15:12:23 ada Exp $
-- $Log: source_file.a,v $
-- Revision 0.1 86/04/01 15:12:23 ada
-- This version fixes some minor bugs with empty grammars
-- and $$ expansion. It also uses vads5.1b enhancements
-- such as pragma inline.
--
--
-- Revision 0.0 86/02/19 18:41:53 ada
--
-- These files comprise the initial version of Ayacc
-- designed and implemented by David Taback and Deepak Tolani.
-- Ayacc has been compiled and tested under the Verdix Ada compiler
-- version 4.06 on a vax 11/750 running Unix 4.2BSD.
--
package Source_File is
--. This package provides input from the source file to the lexical
--. analyzer.
--. UNGET will work to unget up to one character. You can unget more
--. characters until you try to unget an EOLN where the exception
--. PUSHBACK_ERROR is raised.
--. The next character in the input stream
--. can be looked at using PEEK_NEXT_CHAR without affecting the input
--. stream.
procedure Open;
procedure Close;
procedure Get_Char (Ch: out Character);
procedure Unget_Char (Ch: in Character);
function Peek_Next_Char return Character;
function Is_End_of_File return Boolean;
function Source_Line_Number return Natural;
--RJS: Added to make internal Ayacc buffers consistent with
-- source line length. ----v
function Maximum_Line_Length return Natural;
Eof : constant Character := Ascii.Nul;
Eoln : constant Character := Ascii.Lf;
procedure Print_Context_Lines;
--. Prints the previous line followed by the current line
--. followed by a pointer to the position of the source file.
--. Intended for printing error messages.
procedure Read_Line(Source_Line: out String; Last: out Natural);
--. Used to dump the contents of the
--. source file one line at a time. It is intended to be be used
--. to dump the Ada section code (after the third %%) of the
--. source file.
Pushback_Error : exception;
end Source_File;
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- The primary authors of ayacc were David Taback and Deepak Tolani.
-- Enhancements were made by Ronald J. Schmalz.
--
-- Send requests for ayacc information to ayacc-info@ics.uci.edu
-- Send bug reports for ayacc to ayacc-bugs@ics.uci.edu
--
-- Redistribution and use in source and binary forms are permitted
-- provided that the above copyright notice and this paragraph are
-- duplicated in all such forms and that any documentation,
-- advertising materials, and other materials related to such
-- distribution and use acknowledge that the software was developed
-- by the University of California, Irvine. The name of the
-- University may not be used to endorse or promote products derived
-- from this software without specific prior written permission.
-- THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
-- IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
-- WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
-- Module : source_file_body.ada
-- Component of : ayacc
-- Version : 1.2
-- Date : 11/21/86 12:36:09
-- SCCS File : disk21~/rschm/hasee/sccs/ayacc/sccs/sxsource_file_body.ada
-- $Header: source_file_body.a,v 0.1 86/04/01 15:12:32 ada Exp $
-- $Log: source_file_body.a,v $
-- Revision 0.1 86/04/01 15:12:32 ada
-- This version fixes some minor bugs with empty grammars
-- and $$ expansion. It also uses vads5.1b enhancements
-- such as pragma inline.
--
--
-- Revision 0.0 86/02/19 18:42:02 ada
--
-- These files comprise the initial version of Ayacc
-- designed and implemented by David Taback and Deepak Tolani.
-- Ayacc has been compiled and tested under the Verdix Ada compiler
-- version 4.06 on a vax 11/750 running Unix 4.2BSD.
--
with Text_IO, File_Names;
use Text_IO;
package body Source_File is
SCCS_ID : constant String := "@(#) source_file_body.ada, Version 1.2";
Rcs_ID : constant String := "$Header: source_file_body.a,v 0.1 86/04/01 15:12:32 ada Exp $";
Input_File : File_Type;
Max_Line_Length : constant := 260;
type Long_STR is
record
Name : String(1..Max_Line_Length);
Length : Natural := 0;
end record;
Current_Line : Long_STR;
Previous_Line : Long_STR;
Column_Number : Natural; -- column number of current_line.
Line_Number : Natural;
Get_New_Line : Boolean := True;
End_of_Source_File : Boolean := False;
procedure Open is
use File_Names;
begin
Open(Input_File, In_File, Get_Source_File_Name);
Current_Line := ((others => ' '), 0);
Previous_Line := ((others => ' '), 0);
Column_Number := 1;
Line_Number := 0;
exception
when Name_Error | Use_Error =>
Put_Line("Ayacc: Error Opening """ & Get_Source_File_Name & """.");
raise;
end Open;
procedure Close is
begin
Close(Input_File);
end Close;
function Is_End_of_File return Boolean is
begin
return End_of_File(Input_File);
end Is_End_of_File;
function Source_Line_Number return Natural is
begin
return Line_Number;
end Source_Line_Number;
function Maximum_Line_Length return Natural is
begin
return Max_Line_Length;
end Maximum_Line_Length;
procedure Get_Char(Ch: out Character) is
begin
if Get_New_Line then
Previous_Line := Current_Line;
Get_Line(Input_File, Current_Line.Name, Current_Line.Length);
Get_New_Line := False;
Column_Number := 1;
Line_Number := Line_Number + 1;
end if;
if Column_Number > Current_Line.Length then
if End_of_File(Input_File) then
Ch := Eof;
End_of_Source_File := True;
return;
end if;
Ch := Eoln;
Get_New_Line := True;
else
Ch := Current_Line.Name(Column_Number);
Column_Number := Column_Number + 1;
end if;
end Get_Char;
-- Note: You can't correctly peek at next character if the last character
-- read is a EOLN. It is assumed that the lexical analyzer won't
-- call this function in that case.
function Peek_Next_Char return Character is
begin
if Column_Number > Current_Line.Length then
if End_of_File(Input_File) then
return Eof;
else
return Eoln;
end if;
end if;
return Current_Line.Name(Column_Number);
end Peek_Next_Char;
procedure Unget_Char(Ch : in Character) is
begin
if Get_New_Line then
Get_New_Line := False;
elsif End_of_Source_File then
End_of_Source_File := False;
elsif Column_Number = 1 then
Put_Line("Ayacc: Error in Unget_Char, Attempt to 'unget' an EOLN");
raise Pushback_Error;
else
Column_Number := Column_Number - 1;
end if;
end Unget_Char;
procedure Print_Context_Lines is
Ptr_Location : Integer := 0;
begin
-- Print previous line followed by current line --
Put(Integer'Image(Line_Number-1) & Ascii.Ht);
Put_Line(Previous_Line.Name(1..Previous_Line.Length));
Put(Integer'Image(Line_Number) & Ascii.Ht);
Put_Line(Current_Line.Name(1..Current_Line.Length));
-- Correct for any tab characters so that the pointer will
-- point to the proper location on the source line.
for I in 1..Column_Number - 1 loop
if Current_Line.Name(I) = Ascii.Ht then -- Adjust for tab.
Ptr_Location := (((Ptr_Location / 8) + 1) * 8);
else
Ptr_Location := Ptr_Location + 1;
end if;
end loop;
Put(Ascii.Ht);
for I in 1..Ptr_Location - 1 loop
Put('-');
end loop;
Put('^');
end Print_Context_Lines;
procedure Read_Line(Source_Line: out String; Last: out Natural) is
begin
Get_Line(Input_File, Source_Line, Last);
Line_Number := Line_Number + 1;
end Read_Line;
end Source_File;
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- The primary authors of ayacc were David Taback and Deepak Tolani.
-- Enhancements were made by Ronald J. Schmalz.
--
-- Send requests for ayacc information to ayacc-info@ics.uci.edu
-- Send bug reports for ayacc to ayacc-bugs@ics.uci.edu
--
-- Redistribution and use in source and binary forms are permitted
-- provided that the above copyright notice and this paragraph are
-- duplicated in all such forms and that any documentation,
-- advertising materials, and other materials related to such
-- distribution and use acknowledge that the software was developed
-- by the University of California, Irvine. The name of the
-- University may not be used to endorse or promote products derived
-- from this software without specific prior written permission.
-- THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
-- IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
-- WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
-- Module : stack.ada
-- Component of : ayacc
-- Version : 1.2
-- Date : 11/21/86 12:36:24
-- SCCS File : disk21~/rschm/hasee/sccs/ayacc/sccs/sxstack.ada
-- $Header: stack.a,v 0.1 86/04/01 15:12:46 ada Exp $
-- $Log: stack.a,v $
-- Revision 0.1 86/04/01 15:12:46 ada
-- This version fixes some minor bugs with empty grammars
-- and $$ expansion. It also uses vads5.1b enhancements
-- such as pragma inline.
--
--
-- Revision 0.0 86/02/19 18:42:12 ada
--
-- These files comprise the initial version of Ayacc
-- designed and implemented by David Taback and Deepak Tolani.
-- Ayacc has been compiled and tested under the Verdix Ada compiler
-- version 4.06 on a vax 11/750 running Unix 4.2BSD.
--
-- --
-- Authors : David Taback , Deepak Tolani --
-- Copyright : 1987, University of California Irvine --
-- --
-- If you --
-- modify the source code or if you have any suggestions or questions --
-- regarding ayacc, we would like to hear from you. Our mailing --
-- addresses are : --
-- taback@icsc.uci.edu --
-- tolani@icsc.uci.edu --
-- --
generic
type Element is private;
package Stack_Pack is
type Stack is limited private;
Stack_Underflow : exception;
function Top_Value (S: in Stack) return Element;
function Depth_of_Stack (S: in Stack) return Natural;
procedure Make_Stack(S: out Stack);
procedure Push(S: in out Stack; Value: in Element);
procedure Pop (S: in out Stack; Value: out Element);
procedure Free_Stack(S: in out Stack);
private
type Node;
type Link is access Node;
pragma Controlled(Link);
type Stack is
record
Tos : Natural;
Top : Link;
Extras : Link;
end record;
end Stack_Pack;
with Unchecked_Deallocation;
package body Stack_Pack is
SCCS_ID : constant String := "@(#) stack.ada, Version 1.2";
type Node is
record
Datum : Element;
Next : Link;
end record;
function Top_Value (S: in Stack) return Element is
begin
if S.Top = null then
raise Stack_Underflow;
else
return S.Top.Datum;
end if;
end Top_Value;
function Depth_of_Stack (S: in Stack) return Natural is
begin
return S.Tos;
end Depth_of_Stack;
procedure Make_Stack(S: out Stack) is
begin
S := (Tos => 0, Top | Extras => null);
end Make_Stack;
procedure Push(S: in out Stack; Value: in Element) is
New_Node : Link;
begin
S.Tos := S.Tos + 1;
if S.Extras = null then
New_Node := new Node;
else
New_Node := S.Extras;
S.Extras := S.Extras.Next;
end if;
New_Node.all := (Datum => Value, Next => S.Top);
S.Top := New_Node;
end Push;
procedure Pop (S: in out Stack; Value: out Element) is
Temp : Link;
begin
if S.Tos = 0 then
raise Stack_Underflow;
end if;
Value := S.Top.Datum;
Temp := S.Top.Next;
S.Top.Next := S.Extras;
S.Extras := S.Top;
S.Top := Temp;
S.Tos := S.Tos - 1;
end Pop;
procedure Free is new Unchecked_Deallocation(Node, Link);
-- procedure free(x : link);
-- pragma interface(c , free);
procedure Free_List(List: in out Link) is
Temp : Link;
begin
Temp := List;
while Temp /= null loop
List := List.Next;
Free(Temp);
Temp := List;
end loop;
end Free_List;
procedure Free_Stack(S: in out Stack) is
begin
Free_List(S.Top);
Free_List(S.Extras);
end Free_Stack;
end Stack_Pack;
-- Module : stack_pkg.ada
-- Component of : common_library
-- Version : 1.2
-- Date : 11/21/86 16:32:31
-- SCCS File : disk21~/rschm/hasee/sccs/common_library/sccs/sxstack_pkg.ada
-- $Source: /nosc/work/abstractions/stack/RCS/stack.bdy,v $
-- $Revision: 1.3 $ -- $Date: 85/02/01 10:19:36 $ -- $Author: ron $
-- $Source: /nosc/work/abstractions/stack/RCS/stack.bdy,v $
-- $Revision: 1.3 $ -- $Date: 85/02/01 10:19:36 $ -- $Author: ron $
with unchecked_deallocation;
package body stack_pkg is
SCCS_ID : constant String := "@(#) stack_pkg.ada, Version 1.2";
--| Overview:
--| Implementation scheme is totally described by the statements of the
--| representation invariants and abstraction function that appears in
--| the package specification. The implementation is so trivial that
--| further documentation is unnecessary.
use elem_list_pkg;
-- Constructors:
function create
return stack is
begin
return new stack_rec'(size => 0, elts => create);
end create;
procedure push(s: in out stack;
e: elem_type) is
begin
s.size := s.size + 1;
s.elts := attach(e, s.elts);
exception
when constraint_error =>
raise uninitialized_stack;
end push;
procedure pop(s: in out stack) is
begin
DeleteHead(s.elts);
s.size := s.size - 1;
exception
when EmptyList =>
raise empty_stack;
when constraint_error =>
raise uninitialized_stack;
end pop;
procedure pop(s: in out stack;
e: out elem_type) is
begin
e := FirstValue(s.elts);
DeleteHead(s.elts);
s.size := s.size - 1;
exception
when EmptyList =>
raise empty_stack;
when constraint_error =>
raise uninitialized_stack;
end pop;
function copy(s: stack)
return stack is
begin
if s = null then raise uninitialized_stack; end if;
return new stack_rec'(size => s.size,
elts => copy(s.elts));
end;
-- Queries:
function top(s: stack)
return elem_type is
begin
return FirstValue(s.elts);
exception
when EmptyList =>
raise empty_stack;
when constraint_error =>
raise uninitialized_stack;
end top;
function size(s: stack)
return natural is
begin
return s.size;
exception
when constraint_error =>
raise uninitialized_stack;
end size;
function is_empty(s: stack)
return boolean is
begin
return s.size = 0;
exception
when constraint_error =>
raise uninitialized_stack;
end is_empty;
-- Heap Management:
procedure destroy(s: in out stack) is
procedure free_stack is
new unchecked_deallocation(stack_rec, stack);
begin
destroy(s.elts);
free_stack(s);
exception
when constraint_error => -- stack is null
return;
end destroy;
end stack_pkg;
-- Module : stack_pkg_.ada
-- Component of : common_library
-- Version : 1.2
-- Date : 11/21/86 16:33:02
-- SCCS File : disk21~/rschm/hasee/sccs/common_library/sccs/sxstack_pkg_.ada
-- $Source: /nosc/work/abstractions/stack/RCS/stack.spc,v $
-- $Revision: 1.5 $ -- $Date: 85/02/01 09:57:17 $ -- $Author: ron $
-- $Source: /nosc/work/abstractions/stack/RCS/stack.spc,v $
-- $Revision: 1.5 $ -- $Date: 85/02/01 09:57:17 $ -- $Author: ron $
with lists; --| Implementation uses lists. (private)
generic
type elem_type is private; --| Component element type.
package stack_pkg is
--| Overview:
--| This package provides the stack abstract data type. Element type is
--| a generic formal parameter to the package. There are no explicit
--| bounds on the number of objects that can be pushed onto a given stack.
--| All standard stack operations are provided.
--|
--| The following is a complete list of operations, written in the order
--| in which they appear in the spec. Overloaded subprograms are followed
--| by (n), where n is the number of subprograms of that name.
--|
--| Constructors:
--| create
--| push
--| pop (2)
--| copy
--| Query Operations:
--| top
--| size
--| is_empty
--| Heap Management:
--| destroy
--| Notes:
--| Programmer: Ron Kownacki
type stack is private; --| The stack abstract data type.
-- Exceptions:
uninitialized_stack: exception;
--| Raised on attempt to manipulate an uninitialized stack object.
--| The initialization operations are create and copy.
empty_stack: exception;
--| Raised by some operations when empty.
-- Constructors:
function create
return stack;
--| Effects:
--| Return the empty stack.
procedure push(s: in out stack;
e: elem_type);
--| Raises: uninitialized_stack
--| Effects:
--| Push e onto the top of s.
--| Raises uninitialized_stack iff s has not been initialized.
procedure pop(s: in out stack);
--| Raises: empty_stack, uninitialized_stack
--| Effects:
--| Pops the top element from s, and throws it away.
--| Raises empty_stack iff s is empty.
--| Raises uninitialized_stack iff s has not been initialized.
procedure pop(s: in out stack;
e: out elem_type);
--| Raises: empty_stack, uninitialized_stack
--| Effects:
--| Pops the top element from s, returns it as the e parameter.
--| Raises empty_stack iff s is empty.
--| Raises uninitialized_stack iff s has not been initialized.
function copy(s: stack)
return stack;
--| Raises: uninitialized_stack
--| Return a copy of s.
--| Stack assignment and passing stacks as subprogram parameters
--| result in the sharing of a single stack value by two stack
--| objects; changes to one will be visible through the others.
--| copy can be used to prevent this sharing.
--| Raises uninitialized_stack iff s has not been initialized.
-- Queries:
function top(s: stack)
return elem_type;
--| Raises: empty_stack, uninitialized_stack
--| Effects:
--| Return the element on the top of s. Raises empty_stack iff s is
--| empty.
--| Raises uninitialized_stack iff s has not been initialized.
function size(s: stack)
return natural;
--| Raises: uninitialized_stack
--| Effects:
--| Return the current number of elements in s.
--| Raises uninitialized_stack iff s has not been initialized.
function is_empty(s: stack)
return boolean;
--| Raises: uninitialized_stack
--| Effects:
--| Return true iff s is empty.
--| Raises uninitialized_stack iff s has not been initialized.
-- Heap Management:
procedure destroy(s: in out stack);
--| Effects:
--| Return the space consumed by s to the heap. No effect if s is
--| uninitialized. In any case, leaves s in uninitialized state.
private
package elem_list_pkg is new lists(elem_type);
subtype elem_list is elem_list_pkg.list;
type stack_rec is
record
size: natural := 0;
elts: elem_list := elem_list_pkg.create;
end record;
type stack is access stack_rec;
--| Let an instance of the representation type, r, be denoted by the
--| pair, <size, elts>. Dot selection is used to refer to these
--| components.
--|
--| Representation Invariants:
--| r /= null
--| elem_list_pkg.length(r.elts) = r.size.
--|
--| Abstraction Function:
--| A(<size, elem_list_pkg.create>) = stack_pkg.create.
--| A(<size, elem_list_pkg.attach(e, l)>) = push(A(<size, l>), e).
end stack_pkg;
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- The primary authors of ayacc were David Taback and Deepak Tolani.
-- Enhancements were made by Ronald J. Schmalz.
--
-- Send requests for ayacc information to ayacc-info@ics.uci.edu
-- Send bug reports for ayacc to ayacc-bugs@ics.uci.edu
--
-- Redistribution and use in source and binary forms are permitted
-- provided that the above copyright notice and this paragraph are
-- duplicated in all such forms and that any documentation,
-- advertising materials, and other materials related to such
-- distribution and use acknowledge that the software was developed
-- by the University of California, Irvine. The name of the
-- University may not be used to endorse or promote products derived
-- from this software without specific prior written permission.
-- THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
-- IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
-- WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
-- Module : str_pack.ada
-- Component of : ayacc
-- Version : 1.2
-- Date : 11/21/86 12:36:46
-- SCCS File : disk21~/rschm/hasee/sccs/ayacc/sccs/sxstr_pack.ada
-- $Header: str_pack.a,v 0.1 86/04/01 15:13:01 ada Exp $
-- $Log: str_pack.a,v $
-- Revision 0.1 86/04/01 15:13:01 ada
-- This version fixes some minor bugs with empty grammars
-- and $$ expansion. It also uses vads5.1b enhancements
-- such as pragma inline.
--
--
-- Revision 0.0 86/02/19 18:42:23 ada
--
-- These files comprise the initial version of Ayacc
-- designed and implemented by David Taback and Deepak Tolani.
-- Ayacc has been compiled and tested under the Verdix Ada compiler
-- version 4.06 on a vax 11/750 running Unix 4.2BSD.
--
package STR_Pack is
-- This package contains the type declarations and procedures
-- for the minimal string minipulation needed by ayacc.
Maximum : constant := 1024; --RJS 120;
subtype Index is Integer range 0 .. Maximum;
type STR(Maximum_Length : Index) is limited private;
function Length_of (S: STR) return Integer;
function Value_of (S: STR) return String;
function Is_Empty (S: STR) return Boolean;
procedure Assign (Value: in STR; To: in out STR);
procedure Assign (Value: in String; To: in out STR);
procedure Assign (Value: in Character; To: in out STR);
procedure Append (Tail: in Character; To: in out STR);
procedure Append (Tail: in String; To: in out STR);
procedure Append (Tail: in STR; To: in out STR);
procedure Upper_Case(S: in out STR);
procedure Lower_Case(S: in out STR);
function Upper_Case (S : in STR) return STR;
function Lower_Case (S : in STR) return STR;
--RJS
pragma inline (length_of, --RJS value_of,
is_empty,
append);
private
type STR(Maximum_Length : Index) is
record
Name : String(1..Maximum_Length);
Length : Index := 0;
end record;
end STR_Pack;
package body STR_Pack is
SCCS_ID : constant String := "@(#) str_pack.ada, Version 1.2";
Rcs_ID : constant String := "$Header: str_pack.a,v 0.1 86/04/01 15:13:01 ada Exp $";
function Upper_Case (S : in STR) return STR is
Upper_STR : STR (S.Name'Length) := S;
begin
for I in 1..S.Length loop
if S.Name(I) in 'a'..'z' then
Upper_STR.Name(I) := Character'Val(Character'Pos(S.Name(I)) -
Character'Pos('a') + Character'Pos('A'));
end if;
end loop;
return Upper_STR;
end Upper_Case;
function Lower_Case (S : in STR) return STR is
Lower_STR : STR (S.Name'Length) := S;
begin
for I in 1..S.Length loop
if S.Name(I) in 'A'..'Z' then
Lower_STR.Name(I) := Character'Val(Character'Pos(S.Name(I)) -
Character'Pos('A') + Character'Pos('a'));
end if;
end loop;
return Lower_STR;
end Lower_Case;
procedure Upper_Case(S: in out STR) is
begin
S := Upper_Case (S);
end Upper_Case;
procedure Lower_Case(S: in out STR) is
begin
S := Lower_Case (S);
end Lower_Case;
procedure Assign (Value: in STR; To: in out STR) is
begin
To := Value;
end Assign;
procedure Assign (Value: in String; To: in out STR) is
begin
To.Name(1..Value'Length) := Value;
To.Length := Value'Length;
end Assign;
procedure Assign (Value: in Character; To: in out STR) is
begin
To.Name(1) := Value;
To.Length := 1;
end Assign;
procedure Append (Tail: in STR; To: in out STR) is
F, L : Natural;
begin
F := To.Length + 1;
L := F + Tail.Length - 1;
To.Name(F..L) := Tail.Name(1..Tail.Length);
To.Length := L;
end Append;
procedure Append (Tail: in String; To: in out STR) is
F, L: Natural;
begin
F := To.Length + 1;
L := F + Tail'Length - 1;
To.Name(F .. L) := Tail;
To.Length := L;
end Append;
procedure Append (Tail: in Character; To: in out STR) is
begin
To.Length := To.Length + 1;
To.Name(To.Length) := Tail;
end Append;
function Length_of(S: STR) return Integer is
begin
return S.Length;
end Length_of;
function Value_of(S: STR) return String is
begin
return S.Name(1..S.Length);
end Value_of;
function Is_Empty(S: STR) return Boolean is
begin
return S.Length = 0;
end Is_Empty;
end STR_Pack;
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- The primary authors of ayacc were David Taback and Deepak Tolani.
-- Enhancements were made by Ronald J. Schmalz.
--
-- Send requests for ayacc information to ayacc-info@ics.uci.edu
-- Send bug reports for ayacc to ayacc-bugs@ics.uci.edu
--
-- Redistribution and use in source and binary forms are permitted
-- provided that the above copyright notice and this paragraph are
-- duplicated in all such forms and that any documentation,
-- advertising materials, and other materials related to such
-- distribution and use acknowledge that the software was developed
-- by the University of California, Irvine. The name of the
-- University may not be used to endorse or promote products derived
-- from this software without specific prior written permission.
-- THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
-- IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
-- WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
-- Module : str_pack.ada
-- Component of : ayacc
-- Version : 1.2
-- Date : 11/21/86 12:36:46
-- SCCS File : disk21~/rschm/hasee/sccs/ayacc/sccs/sxstr_pack.ada
-- $Header: str_pack.a,v 0.1 86/04/01 15:13:01 ada Exp $
-- $Log: str_pack.a,v $
-- Revision 0.1 86/04/01 15:13:01 ada
-- This version fixes some minor bugs with empty grammars
-- and $$ expansion. It also uses vads5.1b enhancements
-- such as pragma inline.
--
--
-- Revision 0.0 86/02/19 18:42:23 ada
--
-- These files comprise the initial version of Ayacc
-- designed and implemented by David Taback and Deepak Tolani.
-- Ayacc has been compiled and tested under the Verdix Ada compiler
-- version 4.06 on a vax 11/750 running Unix 4.2BSD.
--
package STR_Pack is
-- This package contains the type declarations and procedures
-- for the minimal string minipulation needed by ayacc.
-- COMPILER BUG :
-- maximun discriminat value. note that the discriminant is ignored
-- in this implementation to work around a bug in VADS 5.41
Maximum : constant := 1024; --RJS 120;
-- COMPILER BUG :
-- estimated 'safe' constant. note that a constraint error may
-- result if a string length exceeds this limit. in particular,
-- command line strings in package command_line_interface.a have
-- a maximum length of 1024. WATCH OUT. it is ASSUMED that
-- no command lines will exceed 512.
Vads_5_41_Maximum : constant := 512;
subtype Index is Integer range 0 .. Maximum;
type STR(Maximum_Length : Index) is limited private;
function Length_of (S: STR) return Integer;
function Value_of (S: STR) return String;
function Is_Empty (S: STR) return Boolean;
procedure Assign (Value: in STR; To: in out STR);
procedure Assign (Value: in String; To: in out STR);
procedure Assign (Value: in Character; To: in out STR);
procedure Append (Tail: in Character; To: in out STR);
procedure Append (Tail: in String; To: in out STR);
procedure Append (Tail: in STR; To: in out STR);
procedure Upper_Case(S: in out STR);
procedure Lower_Case(S: in out STR);
function Upper_Case (S : in STR) return STR;
function Lower_Case (S : in STR) return STR;
--RJS
pragma inline (length_of, --RJS value_of,
is_empty,
append);
private
type STR(Maximum_Length : Index) is
record
-- COMPILER BUG :
-- must make upper bound of string independent
-- of discriminant due to a compiler error in
-- VADS 5.41
--Name : String(1..Maximum_Length);
Name : String(1..Vads_5_41_Maximum);
Length : Index := 0;
end record;
end STR_Pack;
package body STR_Pack is
SCCS_ID : constant String := "@(#) str_pack.ada, Version 1.2";
Rcs_ID : constant String := "$Header: str_pack.a,v 0.1 86/04/01 15:13:01 ada Exp $";
function Upper_Case (S : in STR) return STR is
-- COMPILER BUG :
-- the discriminant and the string length may not
-- correspond
--Upper_STR : STR (S.Name'Length) := S;
Upper_STR : STR (S.Maximum_Length) := S;
begin
for I in 1..S.Length loop
if S.Name(I) in 'a'..'z' then
Upper_STR.Name(I) := Character'Val(Character'Pos(S.Name(I)) -
Character'Pos('a') + Character'Pos('A'));
end if;
end loop;
return Upper_STR;
end Upper_Case;
function Lower_Case (S : in STR) return STR is
-- COMPILER BUG :
-- the discriminant and the string length may not
-- correspond
--Lower_STR : STR (S.Name'Length) := S;
Lower_STR : STR (S.Maximum_Length) := S;
begin
for I in 1..S.Length loop
if S.Name(I) in 'A'..'Z' then
Lower_STR.Name(I) := Character'Val(Character'Pos(S.Name(I)) -
Character'Pos('A') + Character'Pos('a'));
end if;
end loop;
return Lower_STR;
end Lower_Case;
procedure Upper_Case(S: in out STR) is
begin
S := Upper_Case (S);
end Upper_Case;
procedure Lower_Case(S: in out STR) is
begin
S := Lower_Case (S);
end Lower_Case;
procedure Assign (Value: in STR; To: in out STR) is
begin
To := Value;
end Assign;
procedure Assign (Value: in String; To: in out STR) is
begin
To.Name(1..Value'Length) := Value;
To.Length := Value'Length;
end Assign;
procedure Assign (Value: in Character; To: in out STR) is
begin
To.Name(1) := Value;
To.Length := 1;
end Assign;
procedure Append (Tail: in STR; To: in out STR) is
F, L : Natural;
begin
F := To.Length + 1;
L := F + Tail.Length - 1;
To.Name(F..L) := Tail.Name(1..Tail.Length);
To.Length := L;
end Append;
procedure Append (Tail: in String; To: in out STR) is
F, L: Natural;
begin
F := To.Length + 1;
L := F + Tail'Length - 1;
To.Name(F .. L) := Tail;
To.Length := L;
end Append;
procedure Append (Tail: in Character; To: in out STR) is
begin
To.Length := To.Length + 1;
To.Name(To.Length) := Tail;
end Append;
function Length_of(S: STR) return Integer is
begin
return S.Length;
end Length_of;
function Value_of(S: STR) return String is
begin
return S.Name(1..S.Length);
end Value_of;
function Is_Empty(S: STR) return Boolean is
begin
return S.Length = 0;
end Is_Empty;
end STR_Pack;
-- Module : string_lists.ada
-- Component of : common_library
-- Version : 1.2
-- Date : 11/21/86 16:34:39
-- SCCS File : disk21~/rschm/hasee/sccs/common_library/sccs/sxstring_lists.ada
with String_Pkg;
with Lists;
package String_Lists is new Lists(String_Pkg.String_Type, String_Pkg.Equal);
-- Module : string_pkg.ada
-- Component of : common_library
-- Version : 1.2
-- Date : 11/21/86 16:35:20
-- SCCS File : disk21~/rschm/hasee/sccs/common_library/sccs/sxstring_pkg.ada
-- $Source: /nosc/work/abstractions/string/RCS/string.bdy,v $
-- $Revision: 1.3 $ -- $Date: 85/02/01 10:58:51 $ -- $Author: ron $
-- $Source: /nosc/work/abstractions/string/RCS/string.bdy,v $
-- $Revision: 1.3 $ -- $Date: 85/02/01 10:58:51 $ -- $Author: ron $
with unchecked_deallocation;
with lists, stack_pkg;
package body string_pkg is
SCCS_ID : constant String := "@(#) string_pkg.ada, Version 1.2";
--| Overview:
--| The implementation for most operations is fairly straightforward.
--| The interesting aspects involve the allocation and deallocation of
--| heap space. This is done as follows:
--|
--| 1. A stack of accesses to lists of string_type values is set up
--| so that the top of the stack always refers to a list of values
--| that were allocated since the last invocation of mark.
--| The stack is called scopes, referring to the dynamic scopes
--| defined by the invocations of mark and release.
--| There is an implicit invocation of mark when the
--| package body is elaborated; this is implemented with an explicit
--| invocation in the package initialization code.
--|
--| 2. At each invocation of mark, a pointer to an empty list
--| is pushed onto the stack.
--|
--| 3. At each invocation of release, all of the values in the
--| list referred to by the pointer at the top of the stack are
--| returned to the heap. Then the list, and the pointer to it,
--| are returned to the heap. Finally, the stack is popped.
package string_list_pkg is new lists(string_type);
subtype string_list is string_list_pkg.list;
type string_list_ptr is access string_list;
package scope_stack_pkg is new stack_pkg(string_list_ptr);
subtype scope_stack is scope_stack_pkg.stack;
use string_list_pkg;
use scope_stack_pkg;
scopes: scope_stack; -- See package body overview.
-- Utility functions/procedures:
function enter(s: string_type)
return string_type;
--| Raises: illegal_alloc
--| Effects:
--| Stores s, the address of s.all, in current scope list (top(scopes)),
--| and returns s. Useful for functions that create and return new
--| string_type values.
--| Raises illegal_alloc if the scopes stack is empty.
function match_string(s1, s2: string; start: positive := 1)
return natural;
--| Raises: no_match
--| Effects:
--| Returns the minimum index, i, in s1'range such that
--| s1(i..i + s2'length - 1) = s2. Returns 0 if no such index.
--| Requires:
--| s1'first = 1.
-- Constructors:
function Empty_String return String_Type is
begin
return Create ("");
end Empty_String;
function create(s: string)
return string_type is
subtype constr_str is string(1..s'length);
dec_s: constr_str := s;
begin
return enter(new constr_str'(dec_s));
-- DECada bug; above code (and decl of dec_s) replaces the following:
-- return enter(new constr_str'(s));
end create;
function "&"(s1, s2: string_type)
return string_type is
begin
if is_empty(s1) then return enter(make_persistent(s2)); end if;
if is_empty(s2) then return enter(make_persistent(s1)); end if;
return create(s1.all & s2.all);
end "&";
function "&"(s1: string_type; s2: string)
return string_type is
begin
if s1 = null then return create(s2); end if;
return create(s1.all & s2);
end "&";
function "&"(s1: string; s2: string_type)
return string_type is
begin
if s2 = null then return create(s1); end if;
return create(s1 & s2.all);
end "&";
function substr(s: string_type; i: positive; len: natural)
return string_type is
begin
if len = 0 then return null; end if;
return create(s(i..(i + len - 1)));
exception
when constraint_error => -- on array fetch or null deref
raise bounds;
end substr;
function splice(s: string_type; i: positive; len: natural)
return string_type is
begin
if len = 0 then return enter(make_persistent(s)); end if;
if i + len - 1 > length(s) then raise bounds; end if;
return create(s(1..(i - 1)) & s((i + len)..length(s)));
end splice;
function insert(s1, s2: string_type; i: positive)
return string_type is
begin
if i > length(s1) then raise bounds; end if;
if is_empty(s2) then return create(s1.all); end if;
return create(s1(1..(i - 1)) & s2.all & s1(i..s1'last));
end insert;
function insert(s1: string_type; s2: string; i: positive)
return string_type is
begin
if i > length(s1) then raise bounds; end if;
return create(s1(1..(i - 1)) & s2 & s1(i..s1'last));
end insert;
function insert(s1: string; s2: string_type; i: positive)
return string_type is
begin
if not (i in s1'range) then raise bounds; end if;
if s2 = null then return create(s1); end if;
return create(s1(s1'first..(i - 1)) & s2.all & s1(i..s1'last));
end insert;
procedure lc(c: in out character) is
begin
if ('A' <= c) and then (c <= 'Z') then
c := character'val(character'pos(c) - character'pos('A')
+ character'pos('a'));
end if;
end lc;
procedure uc(c: in out character) is
begin
if ('a' <= c) and then (c <= 'z') then
c := character'val(character'pos(c) - character'pos('a')
+ character'pos('A'));
end if;
end uc;
function lower(s: string)
return string_type is
s2: string_type := create(s);
begin
for i in s2'range loop
lc(s2(i));
end loop;
return s2;
end lower;
function lower(s: string_type)
return string_type is
begin
if s = null then return null; end if;
return lower(s.all);
end lower;
function Mixed (S: String) return String_Type is
Mixed_String : String_Type := Create (S);
begin
if Mixed_String'Length /= 0 then
UC (Mixed_String(Mixed_String'First));
for i in Mixed_String'First + 1 .. Mixed_String'Last
loop
if Mixed_String(i-1) = '_' then
UC (Mixed_String(i));
else
LC (Mixed_String(i));
end if;
end loop;
return Mixed_String;
else
return Empty_String;
end if;
end Mixed;
function Mixed (S : String_Type) return String_Type is
begin
if s = null then
return Empty_String;
else
return Mixed (S.all);
end if;
end Mixed;
function upper(s: string)
return string_type is
s2: string_type := create(s);
begin
for i in s2'range loop
uc(s2(i));
end loop;
return s2;
end upper;
function upper(s: string_type)
return string_type is
begin
if s = null then return null; end if;
return upper(s.all);
end upper;
-- Heap Management:
function make_persistent(s: string_type)
return string_type is
subtype constr_str is string(1..length(s));
begin
if s = null or else s.all = "" then return null;
else return new constr_str'(s.all);
end if;
end make_persistent;
function make_persistent(s: string)
return string_type is
subtype constr_str is string(1..s'length);
begin
if s = "" then return null;
else return new constr_str'(s); end if;
end make_persistent;
procedure real_flush is new unchecked_deallocation(string,
string_type);
--| Effect:
--| Return space used by argument to heap. Does nothing if null.
--| Notes:
--| This procedure is actually the body for the flush procedure,
--| but a generic instantiation cannot be used as a body for another
--| procedure. You tell me why.
procedure flush(s: in out string_type) is
begin
if s /= null then real_flush(s); end if;
-- Actually, the if isn't needed; however, DECada compiler chokes
-- on deallocation of null.
end flush;
procedure mark is
begin
push(scopes, new string_list'(create));
end mark;
procedure release is
procedure flush_list_ptr is
new unchecked_deallocation(string_list, string_list_ptr);
iter: string_list_pkg.ListIter;
top_list: string_list_ptr;
s: string_type;
begin
pop(scopes, top_list);
iter := MakeListIter(top_list.all);
while more(iter) loop
next(iter, s);
flush(s); -- real_flush is bad, DECada bug
-- real_flush(s);
end loop;
destroy(top_list.all);
flush_list_ptr(top_list);
exception
when empty_stack =>
raise illegal_dealloc;
end release;
-- Queries:
function is_empty(s: string_type)
return boolean is
begin
return (s = null) or else (s.all = "");
end is_empty;
function length(s: string_type)
return natural is
begin
if s = null then return 0; end if;
return(s.all'length);
end length;
function value(s: string_type)
return string is
subtype null_range is positive range 1..0;
subtype null_string is string(null_range);
begin
if s = null then return null_string'(""); end if;
return s.all;
end value;
function fetch(s: string_type; i: positive)
return character is
begin
if is_empty(s) or else (not (i in s'range)) then raise bounds; end if;
return s(i);
end fetch;
function equal(s1, s2: string_type)
return boolean is
begin
if is_empty(s1) then return is_empty(s2); end if;
return (s2 /= null) and then (s1.all = s2.all);
-- The above code replaces the following. (DECada buggy)
-- return s1.all = s2.all;
-- exception
-- when constraint_error => -- s is null
-- return is_empty(s1) and is_empty(s2);
end equal;
function equal(s1: string_type; s2: string)
return boolean is
begin
if s1 = null then return s2 = ""; end if;
return s1.all = s2;
end equal;
function equal(s1: string; s2: string_type)
return boolean is
begin
if s2 = null then return s1 = ""; end if;
return s1 = s2.all;
end equal;
--|========================================================================
function Equivalent (Left, Right : in String_Type) return Boolean is
begin
return Equal (Upper (Left), Upper (Right));
end Equivalent;
function Equivalent (Left : in String;
Right : in String_Type) return Boolean is
begin
return Equivalent (Create (Left), Right);
end Equivalent;
function Equivalent (Left : in String_Type;
Right : in String) return Boolean is
begin
return Equivalent (Left, Create (Right));
end Equivalent;
--|========================================================================
function "<" (s1: string_type; s2: string_type)
return boolean is
begin
if is_empty(s1) then
return (not is_empty(s2));
else
return (s1.all < s2);
end if;
-- Got rid of the following code: (Think that DECada is buggy)
--return s1.all < s2.all;
--exception
--when constraint_error => -- on null deref
--return (not is_empty(s2));
-- one of them must be empty
end "<";
function "<"(s1: string_type; s2: string)
return boolean is
begin
if s1 = null then return s2 /= ""; end if;
return s1.all < s2;
end "<";
function "<"(s1: string; s2: string_type)
return boolean is
begin
if s2 = null then return false; end if;
return s1 < s2.all;
end "<";
function "<="(s1: string_type; s2: string_type)
return boolean is
begin
if is_empty(s1) then return true; end if;
return (s1.all <= s2);
-- Replaces the following: (I think DECada is buggy)
--return s1.all <= s2.all;
--exception
--when constraint_error => -- on null deref
--return is_empty(s1); -- one must be empty, so s1<=s2 iff s1 = ""
end "<=";
function "<="(s1: string_type; s2: string)
return boolean is
begin
if s1 = null then return true; end if;
return s1.all <= s2;
end "<=";
function "<="(s1: string; s2: string_type)
return boolean is
begin
if s2 = null then return s1 = ""; end if;
return s1 <= s2.all;
end "<=";
function match_c(s: string_type; c: character; start: positive := 1)
return natural is
begin
if s = null then return 0; end if;
for i in start..s.all'last loop
if s(i) = c then
return i;
end if;
end loop;
return 0;
end match_c;
function match_not_c(s: string_type; c: character; start: positive := 1)
return natural is
begin
if s = null then return 0; end if;
for i in start..s.all'last loop
if s(i) /= c then
return i;
end if;
end loop;
return 0;
end match_not_c;
function match_s(s1, s2: string_type; start: positive := 1)
return natural is
begin
if (s1 = null) or else (s2 = null) then return 0; end if;
return match_string(s1.all, s2.all, start);
end match_s;
function match_s(s1: string_type; s2: string; start: positive := 1)
return natural is
begin
if s1 = null then return 0; end if;
return match_string(s1.all, s2, start);
end match_s;
function match_any(s, any: string_type; start: positive := 1)
return natural is
begin
if any = null then raise any_empty; end if;
return match_any(s, any.all, start);
end match_any;
function match_any(s: string_type; any: string; start: positive := 1)
return natural is
begin
if any = "" then raise any_empty; end if;
if s = null then return 0; end if;
for i in start..s.all'last loop
for j in any'range loop
if s(i) = any(j) then
return i;
end if;
end loop;
end loop;
return 0;
end match_any;
function match_none(s, none: string_type; start: positive := 1)
return natural is
begin
if is_empty(s) then return 0; end if;
if is_empty(none) then return 1; end if;
return match_none(s, none.all, start);
end match_none;
function match_none(s: string_type; none: string; start: positive := 1)
return natural is
found: boolean;
begin
if is_empty(s) then return 0; end if;
for i in start..s.all'last loop
found := true;
for j in none'range loop
if s(i) = none(j) then
found := false;
exit;
end if;
end loop;
if found then return i; end if;
end loop;
return 0;
end match_none;
-- Utilities:
function enter(s: string_type)
return string_type is
begin
-- ATTACHING TO THE END OF THE LIST IS ENTIRELY TOO SLOW AND UNNECESSARY
-- top(scopes).all := attach(top(scopes).all, s);
top(scopes).all := attach(s, top(scopes).all);
return s;
exception
when empty_stack =>
raise illegal_alloc;
end enter;
function match_string(s1, s2: string; start: positive := 1)
return natural is
offset: natural;
begin
offset := s2'length - 1;
for i in start..(s1'last - offset) loop
if s1(i..(i + offset)) = s2 then
return i;
end if;
end loop;
return 0;
exception when constraint_error => -- on offset := s2'length (= 0)
return 0;
end match_string;
begin -- Initialize the scopes stack with an implicit mark.
scopes := create;
mark;
end string_pkg;
-- Module : string_pkg_.ada
-- Component of : common_library
-- Version : 1.2
-- Date : 11/21/86 16:35:52
-- SCCS File : disk21~/rschm/hasee/sccs/common_library/sccs/sxstring_pkg_.ada
-- $Source: /nosc/work/abstractions/string/RCS/string.spc,v $
-- $Revision: 1.1 $ -- $Date: 85/01/10 17:51:46 $ -- $Author: ron $
-- $Source: /nosc/work/abstractions/string/RCS/string.spc,v $
-- $Revision: 1.1 $ -- $Date: 85/01/10 17:51:46 $ -- $Author: ron $
package string_pkg is
--| Overview:
--| Package string_pkg exports an abstract data type, string_type. A
--| string_type value is a sequence of characters. The values have arbitrary
--| length. For a value, s, with length, l, the individual characters are
--| numbered from 1 to l. These values are immutable; characters cannot be
--| replaced or appended in a destructive fashion.
--|
--| In the documentation for this package, we are careful to distinguish
--| between string_type objects, which are Ada objects in the usual sense,
--| and string_type values, the members of this data abstraction as described
--| above. A string_type value is said to be associated with, or bound to,
--| a string_type object after an assignment (:=) operation.
--|
--| The operations provided in this package fall into three categories:
--|
--| 1. Constructors: These functions typically take one or more string_type
--| objects as arguments. They work with the values associated with
--| these objects, and return new string_type values according to
--| specification. By a slight abuse of language, we will sometimes
--| coerce from string_type objects to values for ease in description.
--|
--| 2. Heap Management:
--| These operations (make_persistent, flush, mark, release) control the
--| management of heap space. Because string_type values are
--| allocated on the heap, and the type is not limited, it is necessary
--| for a user to assume some responsibility for garbage collection.
--| String_type is not limited because of the convenience of
--| the assignment operation, and the usefulness of being able to
--| instantiate generic units that contain private type formals.
--| ** Important: To use this package properly, it is necessary to read
--| the descriptions of the operations in this section.
--|
--| 3. Queries: These functions return information about the values
--| that are associated with the argument objects. The same conventions
--| for description of operations used in (1) is adopted.
--|
--| A note about design decisions... The decision to not make the type
--| limited causes two operations to be carried over from the representation.
--| These are the assignment operation, :=, and the "equality" operator, "=".
--| See the discussion at the beginning of the Heap Management section for a
--| discussion of :=.
--| See the spec for the first of the equal functions for a discussion of "=".
--|
--| The following is a complete list of operations, written in the order
--| in which they appear in the spec. Overloaded subprograms are followed
--| by (n), where n is the number of subprograms of that name.
--|
--| 1. Constructors:
--| Empty_String
--| create
--| "&" (3)
--| substr
--| splice
--| insert (3)
--| lower (2)
--| upper (2)
--| mixed (2)
--| 2. Heap Management:
--| make_persistent (2)
--| flush
--| mark, release
--| 3. Queries:
--| is_empty
--| length
--| value
--| fetch
--| equal (3)
--| equivalent (3)
--| "<" (3),
--| "<=" (3)
--| match_c
--| match_not_c
--| match_s (2)
--| match_any (2)
--| match_none (2)
--| Notes:
--| Programmer: Ron Kownacki
type string_type is private;
bounds: exception; --| Raised on index out of bounds.
any_empty: exception; --| Raised on incorrect use of match_any.
illegal_alloc: exception; --| Raised by value creating operations.
illegal_dealloc: exception; --| Raised by release.
-- Constructors:
function Empty_String return String_Type;
--| Raises: Illegal_Alloc
--| Effects: returns String_Pkg.Create ("");
pragma Inline (Empty_String);
function create(s: string)
return string_type;
--| Raises: illegal_alloc
--| Effects:
--| Return a value consisting of the sequence of characters in s.
--| Sometimes useful for array or record aggregates.
--| Raises illegal_alloc if string space has been improperly
--| released. (See procedures mark/release.)
function "&"(s1, s2: string_type)
return string_type;
--| Raises: illegal_alloc
--| Effects:
--| Return the concatenation of s1 and s2.
--| Raises illegal_alloc if string space has been improperly
--| released. (See procedures mark/release.)
function "&"(s1: string_type; s2: string)
return string_type;
--| Raises: illegal_alloc
--| Effects:
--| Return the concatenation of s1 and create(s2).
--| Raises illegal_alloc if string space has been improperly
--| released. (See procedures mark/release.)
function "&"(s1: string; s2: string_type)
return string_type;
--| Raises: illegal_alloc
--| Effects:
--| Return the concatenation of create(s1) and s2.
--| Raises illegal_alloc if string space has been improperly
--| released. (See procedures mark/release.)
function substr(s: string_type; i: positive; len: natural)
return string_type;
--| Raises: bounds, illegal_alloc
--| Effects:
--| Return the substring, of specified length, that occurs in s at
--| position i. If len = 0, then returns the empty value.
--| Otherwise, raises bounds if either i or (i + len - 1)
--| is not in 1..length(s).
--| Raises illegal_alloc if string space has been improperly
--| released. (See procedures mark/release.)
function splice(s: string_type; i: positive; len: natural)
return string_type;
--| Raises: bounds, illegal_alloc
--| Effects:
--| Let s be the string, abc, where a, b and c are substrings. If
--| substr(s, i, length(b)) = b, for some i in 1..length(s), then
--| splice(s, i, length(b)) = ac.
--| Returns a value equal to s if len = 0. Otherwise, raises bounds if
--| either i or (i + len - 1) is not in 1..length(s).
--| Raises illegal_alloc if string space has been improperly
--| released. (See procedures mark/release.)
function insert(s1, s2: string_type; i: positive)
return string_type;
--| Raises: bounds, illegal_alloc
--| Effects:
--| Return substr(s1, 1, i - 1) & s2 &
--| substr(s1, i, length(s1) - i + 1).
--| equal(splice(insert(s1, s2, i), i, length(s2)), s1) holds if no
--| exception is raised by insert.
--| Raises bounds if is_empty(s1) or else i is not in 1..length(s1).
--| Raises illegal_alloc if string space has been improperly
--| released. (See procedures mark/release.)
function insert(s1: string_type; s2: string; i: positive)
return string_type;
--| Raises: bounds, illegal_alloc
--| Effects:
--| Return substr(s1, 1, i - 1) & s2 &
--| substr(s1, i, length(s1) - i + 1).
--| equal(splice(insert(s1, s2, i), i, length(s2)), s1) holds if no
--| exception is raised by insert.
--| Raises bounds if is_empty(s1) or else i is not in 1..length(s1).
--| Raises illegal_alloc if string space has been improperly
--| released. (See procedures mark/release.)
function insert(s1: string; s2: string_type; i: positive)
return string_type;
--| Raises: bounds, illegal_alloc
--| Effects:
--| Return s1(s1'first..i - 1) & s2 &
--| s1(i..length(s1) - i + 1).
--| equal(splice(insert(s1, s2, i), i, length(s2)), s1) holds if no
--| exception is raised by insert.
--| Raises bounds if i is not in s'range.
--| Raises illegal_alloc if string space has been improperly
--| released. (See procedures mark/release.)
function lower(s: string)
return string_type;
--| Raises: illegal_alloc
--| Effects:
--| Return a value that contains exactly those characters in s with
--| the exception that all upper case characters are replaced by their
--| lower case counterparts.
--| Raises illegal_alloc if string space has been improperly
--| released. (See procedures mark/release.)
function lower(s: string_type)
return string_type;
--| Raises: illegal_alloc
--| Effects:
--| Return a value that is a copy of s with the exception that all
--| upper case characters are replaced by their lower case counterparts.
--| Raises illegal_alloc if string space has been improperly
--| released. (See procedures mark/release.)
function upper(s: string)
return string_type;
--| Raises: illegal_alloc
--| Effects:
--| Return a value that contains exactly those characters in s with
--| the exception that all lower case characters are replaced by their
--| upper case counterparts.
--| Raises illegal_alloc if string space has been improperly
--| released. (See procedures mark/release.)
function upper(s: string_type)
return string_type;
--| Raises: illegal_alloc
--| Effects:
--| Return a value that is a copy of s with the exception that all
--| lower case characters are replaced by their upper case counterparts.
--| Raises illegal_alloc if string space has been improperly
--| released. (See procedures mark/release.)
function Mixed (S: String)
return String_Type;
--| Raises: Illegal_Alloc
--| Effects:
--| Return a value that contains exactly those characters in s with
--| the exception that all upper case characters are replaced by their
--| lower case counterparts with the exception of the first character and
--| each character following an underscore which are forced to upper case.
--| Raises illegal_alloc if string space has been improperly
--| released. (See procedures mark/release.)
function Mixed (S: String_Type)
return String_Type;
--| Raises: Illegal_Alloc
--| Effects:
--| Return a value that contains exactly those characters in s with
--| the exception that all upper case characters are replaced by their
--| lower case counterparts with the exception of the first character and
--| each character following an underscore which are forced to upper case.
--| Raises illegal_alloc if string space has been improperly
--| released. (See procedures mark/release.)
-- Heap Management (including object/value binding):
--
-- Two forms of heap management are provided. The general scheme is to "mark"
-- the current state of heap usage, and to "release" in order to reclaim all
-- space that has been used since the last mark. However, this alone is
-- insufficient because it is frequently desirable for objects to remain
-- associated with values for longer periods of time, and this may come into
-- conflict with the need to clean up after a period of "string hacking."
-- To deal with this problem, we introduce the notions of "persistent" and
-- "nonpersistent" values.
--
-- The nonpersistent values are those that are generated by the constructors
-- in the previous section. These are claimed by the release procedure.
-- Persistent values are generated by the two make_persistent functions
-- described below. These values must be disposed of individually by means of
-- the flush procedure.
--
-- This allows a description of the meaning of the ":=" operation. For a
-- statement of the form, s := expr, where expr is a string_type expression,
-- the result is that the value denoted/created by expr becomes bound to the
-- the object, s. Assignment in no way affects the persistence of the value.
-- If expr happens to be an object, then the value associated with it will be
-- shared. Ideally, this sharing would not be visible, since values are
-- immutable. However, the sharing may be visible because of the memory
-- management, as described below. Programs which depend on such sharing are
-- erroneous.
function make_persistent(s: string_type)
return string_type;
--| Effects:
--| Returns a persistent value, v, containing exactly those characters in
--| value(s). The value v will not be claimed by any subsequent release.
--| Only an invocation of flush will claim v. After such a claiming
--| invocation of flush, the use (other than :=) of any other object to
--| which v was bound is erroneous, and program_error may be raised for
--| such a use.
function make_persistent(s: string)
return string_type;
--| Effects:
--| Returns a persistent value, v, containing exactly those chars in s.
--| The value v will not be claimed by any subsequent release.
--| Only an invocation of flush will reclaim v. After such a claiming
--| invocation of flush, the use (other than :=) of any other object to
--| which v was bound is erroneous, and program_error may be raised for
--| such a use.
procedure flush(s: in out string_type);
--| Effects:
--| Return heap space used by the value associated with s, if any, to
--| the heap. s becomes associated with the empty value. After an
--| invocation of flush claims the value, v, then any use (other than :=)
--| of an object to which v was bound is erroneous, and program_error
--| may be raised for such a use.
--|
--| This operation should be used only for persistent values. The mark
--| and release operations are used to deallocate space consumed by other
--| values. For example, flushing a nonpersistent value implies that a
--| release that tries to claim this value will be erroneous, and
--| program_error may be raised for such a use.
procedure mark;
--| Effects:
--| Marks the current state of heap usage for use by release.
--| An implicit mark is performed at the beginning of program execution.
procedure release;
--| Raises: illegal_dealloc
--| Effects:
--| Releases all heap space used by nonpersistent values that have been
--| allocated since the last mark. The values that are claimed include
--| those bound to objects as well as those produced and discarded during
--| the course of general "string hacking." If an invocation of release
--| claims a value, v, then any subsequent use (other than :=) of any
--| other object to which v is bound is erroneous, and program_error may
--| be raised for such a use.
--|
--| Raises illegal_dealloc if the invocation of release does not balance
--| an invocation of mark. It is permissible to match the implicit
--| initial invocation of mark. However, subsequent invocations of
--| constructors will raise the illegal_alloc exception until an
--| additional mark is performed. (Anyway, there is no good reason to
--| do this.) In any case, a number of releases matching the number of
--| currently active marks is implicitly performed at the end of program
--| execution.
--|
--| Good citizens generally perform their own marks and releases
--| explicitly. Extensive string hacking without cleaning up will
--| cause your program to run very slowly, since the heap manager will
--| be forced to look hard for chunks of space to allocate.
-- Queries:
function is_empty(s: string_type)
return boolean;
--| Effects:
--| Return true iff s is the empty sequence of characters.
function length(s: string_type)
return natural;
--| Effects:
--| Return number of characters in s.
function value(s: string_type)
return string;
--| Effects:
--| Return a string, s2, that contains the same characters that s
--| contains. The properties, s2'first = 1 and s2'last = length(s),
--| are satisfied. This implies that, for a given string, s3,
--| value(create(s3))'first may not equal s3'first, even though
--| value(create(s3)) = s3 holds. Thus, "content equality" applies
--| although the string objects may be distinguished by the use of
--| the array attributes.
function fetch(s: string_type; i: positive)
return character;
--| Raises: bounds
--| Effects:
--| Return the ith character in s. Characters are numbered from
--| 1 to length(s). Raises bounds if i not in 1..length(s).
function equal(s1, s2: string_type)
return boolean;
--| Effects:
--| Value equality relation; return true iff length(s1) = length(s2)
--| and, for all i in 1..length(s1), fetch(s1, i) = fetch(s2, i).
--| The "=" operation is carried over from the representation.
--| It allows one to distinguish among the heap addresses of
--| string_type values. Even "equal" values may not be "=", although
--| s1 = s2 implies equal(s1, s2).
--| There is no reason to use "=".
function equal(s1: string_type; s2: string)
return boolean;
--| Effects:
--| Return equal(s1, create(s2)).
function equal(s1: string; s2: string_type)
return boolean;
--| Effects:
--| Return equal(create(s1), s2).
--|===========================================================================
--| Overview: Equivalent is the Case Insensitive version of Equal
function Equivalent (Left, Right : in String_Type) return Boolean;
function Equivalent (Left : in String;
Right : in String_Type) return Boolean;
function Equivalent (Left : in String_Type;
Right : in String) return Boolean;
--|===========================================================================
function "<"(s1: string_type; s2: string_type)
return boolean;
--| Effects:
--| Lexicographic comparison; return value(s1) < value(s2).
function "<"(s1: string_type; s2: string)
return boolean;
--| Effects:
--| Lexicographic comparison; return value(s1) < s2.
function "<"(s1: string; s2: string_type)
return boolean;
--| Effects:
--| Lexicographic comparison; return s1 < value(s2).
function "<="(s1: string_type; s2: string_type)
return boolean;
--| Effects:
--| Lexicographic comparison; return value(s1) <= value(s2).
function "<="(s1: string_type; s2: string)
return boolean;
--| Effects:
--| Lexicographic comparison; return value(s1) <= s2.
function "<="(s1: string; s2: string_type)
return boolean;
--| Effects:
--| Lexicographic comparison; return s1 <= value(s2).
function match_c(s: string_type; c: character; start: positive := 1)
return natural;
--| Raises: no_match
--| Effects:
--| Return the minimum index, i in start..length(s), such that
--| fetch(s, i) = c. Returns 0 if no such i exists,
--| including the case where is_empty(s).
function match_not_c(s: string_type; c: character; start: positive := 1)
return natural;
--| Raises: no_match
--| Effects:
--| Return the minimum index, i in start..length(s), such that
--| fetch(s, i) /= c. Returns 0 if no such i exists,
--| including the case where is_empty(s).
function match_s(s1, s2: string_type; start: positive := 1)
return natural;
--| Raises: no_match.
--| Effects:
--| Return the minimum index, i, in start..length(s1), such that,
--| for all j in 1..length(s2), fetch(s2, j) = fetch(s1, i + j - 1).
--| This is the position of the substring, s2, in s1.
--| Returns 0 if no such i exists, including the cases
--| where is_empty(s1) or is_empty(s2).
--| Note that equal(substr(s1, match_s(s1, s2, i), length(s2)), s2)
--| holds, providing that match_s does not raise an exception.
function match_s(s1: string_type; s2: string; start: positive := 1)
return natural;
--| Raises: no_match.
--| Effects:
--| Return the minimum index, i, in start..length(s1), such that,
--| for all j in s2'range, s2(j) = fetch(s1, i + j - 1).
--| This is the position of the substring, s2, in s1.
--| Returns 0 if no such i exists, including the cases
--| where is_empty(s1) or s2 = "".
--| Note that equal(substr(s1, match_s(s1, s2, i), s2'length), s2)
--| holds, providing that match_s does not raise an exception.
function match_any(s, any: string_type; start: positive := 1)
return natural;
--| Raises: no_match, any_empty
--| Effects:
--| Return the minimum index, i in start..length(s), such that
--| fetch(s, i) = fetch(any, j), for some j in 1..length(any).
--| Raises any_empty if is_empty(any).
--| Otherwise, returns 0 if no such i exists, including the case
--| where is_empty(s).
function match_any(s: string_type; any: string; start: positive := 1)
return natural;
--| Raises: no_match, any_empty
--| Effects:
--| Return the minimum index, i, in start..length(s), such that
--| fetch(s, i) = any(j), for some j in any'range.
--| Raises any_empty if any = "".
--| Otherwise, returns 0 if no such i exists, including the case
--| where is_empty(s).
function match_none(s, none: string_type; start: positive := 1)
return natural;
--| Raises: no_match
--| Effects:
--| Return the minimum index, i in start..length(s), such that
--| fetch(s, i) /= fetch(none, j) for each j in 1..length(none).
--| If (not is_empty(s)) and is_empty(none), then i is 1.
--| Returns 0 if no such i exists, including the case
--| where is_empty(s).
function match_none(s: string_type; none: string; start: positive := 1)
return natural;
--| Raises: no_match.
--| Effects:
--| Return the minimum index, i in start..length(s), such that
--| fetch(s, i) /= none(j) for each j in none'range.
--| If not is_empty(s) and none = "", then i is 1.
--| Returns 0 if no such i exists, including the case
--| where is_empty(s).
private
type string_type is access string;
--| Abstract data type, string_type, is a constant sequence of chars
--| of arbitrary length. Representation type is access string.
--| It is important to distinguish between an object of the rep type
--| and its value; for an object, r, val(r) denotes the value.
--|
--| Representation Invariant: I: rep --> boolean
--| I(r: rep) = (val(r) = null) or else
--| (val(r).all'first = 1 &
--| val(r).all'last >= 0 &
--| (for all r2, val(r) = val(r2) /= null => r is r2))
--|
--| Abstraction Function: A: rep --> string_type
--| A(r: rep) = if r = null then
--| the empty sequence
--| elsif r'last = 0 then
--| the empty sequence
--| else
--| the sequence consisting of r(1),...,r(r'last).
end string_pkg;
-- Module : string_scanner.ada
-- Component of : common_library
-- Version : 1.2
-- Date : 11/21/86 16:36:26
-- SCCS File : disk21~/rschm/hasee/sccs/common_library/sccs/sxstring_scanner.ada
with String_Pkg; use String_Pkg;
with Unchecked_Deallocation;
package body String_Scanner is
SCCS_ID : constant String := "@(#) string_scanner.ada, Version 1.2";
White_Space : constant string := " " & ASCII.HT;
Number_1 : constant string := "0123456789";
Number : constant string := Number_1 & "_";
Quote : constant string := """";
Ada_Id_1 : constant string := "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz";
Ada_Id : constant string := Ada_Id_1 & Number;
procedure Free_Scanner is
new Unchecked_Deallocation(Scan_Record, Scanner);
pragma Page;
function Is_Valid(
T : in Scanner
) return boolean is
begin
return T /= null;
end Is_Valid;
function Make_Scanner(
S : in String_Type
) return Scanner is
T : Scanner := new Scan_Record;
begin
T.text := String_Pkg.Make_Persistent(S);
return T;
end Make_Scanner;
----------------------------------------------------------------
procedure Destroy_Scanner(
T : in out Scanner
) is
begin
if Is_Valid(T) then
String_Pkg.Flush(T.text);
Free_Scanner(T);
end if;
end Destroy_Scanner;
----------------------------------------------------------------
function More(
T : in Scanner
) return boolean is
begin
if Is_Valid(T) then
if T.index > String_Pkg.Length(T.text) then
return false;
else
return true;
end if;
else
return false;
end if;
end More;
----------------------------------------------------------------
function Get(
T : in Scanner
) return character is
begin
if not More(T) then
raise Out_Of_Bounds;
end if;
return String_Pkg.Fetch(T.text, T.index);
end Get;
----------------------------------------------------------------
procedure Forward(
T : in Scanner
) is
begin
if Is_Valid(T) then
if String_Pkg.Length(T.text) >= T.index then
T.index := T.index + 1;
end if;
end if;
end Forward;
----------------------------------------------------------------
procedure Backward(
T : in Scanner
) is
begin
if Is_Valid(T) then
if T.index > 1 then
T.index := T.index - 1;
end if;
end if;
end Backward;
----------------------------------------------------------------
procedure Next(
T : in Scanner;
C : out character
) is
begin
C := Get(T);
Forward(T);
end Next;
----------------------------------------------------------------
function Position(
T : in Scanner
) return positive is
begin
if not More(T) then
raise Out_Of_Bounds;
end if;
return T.index;
end Position;
----------------------------------------------------------------
function Get_String(
T : in Scanner
) return String_Type is
begin
if Is_Valid(T) then
return String_Pkg.Make_Persistent(T.text);
else
return String_Pkg.Make_Persistent("");
end if;
end Get_String;
----------------------------------------------------------------
function Get_Remainder(
T : in Scanner
) return String_Type is
S_Str : String_Type;
begin
if More(T) then
String_Pkg.Mark;
S_Str := String_Pkg.Make_Persistent(
String_Pkg.Substr(T.text,
T.index,
String_Pkg.Length(T.text) - T.index + 1));
String_Pkg.Release;
else
S_Str := String_Pkg.Make_Persistent("");
end if;
return S_Str;
end Get_Remainder;
----------------------------------------------------------------
procedure Mark(
T : in Scanner
) is
begin
if Is_Valid(T) then
if T.mark /= 0 then
raise Scanner_Already_Marked;
else
T.mark := T.index;
end if;
end if;
end Mark;
----------------------------------------------------------------
procedure Restore(
T : in Scanner
) is
begin
if Is_Valid(T) then
if T.mark /= 0 then
T.index := T.mark;
T.mark := 0;
end if;
end if;
end Restore;
pragma Page;
function Is_Any(
T : in Scanner;
Q : in string
) return boolean is
N : natural;
begin
if not More(T) then
return false;
end if;
String_Pkg.Mark;
N := String_Pkg.Match_Any(T.text, Q, T.index);
if N /= T.index then
N := 0;
end if;
String_Pkg.Release;
return N /= 0;
end Is_Any;
pragma Page;
procedure Scan_Any(
T : in Scanner;
Q : in string;
Found : out boolean;
Result : in out String_Type
) is
S_Str : String_Type;
N : natural;
begin
if Is_Any(T, Q) then
N := String_Pkg.Match_None(T.text, Q, T.index);
if N = 0 then
N := String_Pkg.Length(T.text) + 1;
end if;
Result := Result & String_Pkg.Substr(T.text, T.index, N - T.index);
T.index := N;
Found := true;
else
Found := false;
end if;
end Scan_Any;
pragma Page;
function Quoted_String(
T : in Scanner
) return integer is
Count : integer := 0;
I : positive;
N : natural;
begin
if not Is_Valid(T) then
return Count;
end if;
I := T.index;
while Is_Any(T, """") loop
T.index := T.index + 1;
if not More(T) then
T.index := I;
return 0;
end if;
String_Pkg.Mark;
N := String_Pkg.Match_Any(T.text, """", T.index);
String_Pkg.Release;
if N = 0 then
T.index := I;
return 0;
end if;
T.index := N + 1;
end loop;
Count := T.index - I;
T.index := I;
return Count;
end Quoted_String;
pragma Page;
function Enclosed_String(
B : in character;
E : in character;
T : in Scanner
) return natural is
Count : natural := 1;
I : positive;
Inx_B : natural;
Inx_E : natural;
Depth : natural := 1;
begin
if not Is_Any(T, B & "") then
return 0;
end if;
I := T.index;
Forward(T);
while Depth /= 0 loop
if not More(T) then
T.index := I;
return 0;
end if;
String_Pkg.Mark;
Inx_B := String_Pkg.Match_Any(T.text, B & "", T.index);
Inx_E := String_Pkg.Match_Any(T.text, E & "", T.index);
String_Pkg.Release;
if Inx_E = 0 then
T.index := I;
return 0;
end if;
if Inx_B /= 0 and then Inx_B < Inx_E then
Depth := Depth + 1;
else
Inx_B := Inx_E;
Depth := Depth - 1;
end if;
T.index := Inx_B + 1;
end loop;
Count := T.index - I;
T.index := I;
return Count;
end Enclosed_String;
pragma Page;
function Is_Word(
T : in Scanner
) return boolean is
begin
if not More(T) then
return false;
else
return not Is_Any(T, White_Space);
end if;
end Is_Word;
----------------------------------------------------------------
procedure Scan_Word(
T : in Scanner;
Found : out boolean;
Result : out String_Type;
Skip : in boolean := false
) is
S_Str : String_Type;
N : natural;
begin
if Skip then
Skip_Space(T);
end if;
if Is_Word(T) then
String_Pkg.Mark;
N := String_Pkg.Match_Any(T.text, White_Space, T.index);
if N = 0 then
N := String_Pkg.Length(T.text) + 1;
end if;
Result := String_Pkg.Make_Persistent
(String_Pkg.Substr(T.text, T.index, N - T.index));
T.index := N;
Found := true;
String_Pkg.Release;
else
Found := false;
end if;
return;
end Scan_Word;
pragma Page;
function Is_Number(
T : in Scanner
) return boolean is
begin
return Is_Any(T, Number_1);
end Is_Number;
----------------------------------------------------------------
procedure Scan_Number(
T : in Scanner;
Found : out boolean;
Result : out String_Type;
Skip : in boolean := false
) is
C : character;
S_Str : String_Type;
begin
if Skip then
Skip_Space(T);
end if;
if not Is_Number(T) then
Found := false;
return;
end if;
String_Pkg.Mark;
while Is_Number(T) loop
Scan_Any(T, Number_1, Found, S_Str);
if More(T) then
C := Get(T);
if C = '_' then
Forward(T);
if Is_Number(T) then
S_Str := S_Str & "_";
else
Backward(T);
end if;
end if;
end if;
end loop;
Result := String_Pkg.Make_Persistent(S_Str);
String_Pkg.Release;
end Scan_Number;
----------------------------------------------------------------
procedure Scan_Number(
T : in Scanner;
Found : out boolean;
Result : out integer;
Skip : in boolean := false
) is
F : boolean;
S_Str : String_Type;
begin
Scan_Number(T, F, S_Str, Skip);
if F then
Result := integer'value(String_Pkg.Value(S_Str));
end if;
Found := F;
end Scan_Number;
pragma Page;
function Is_Signed_Number(
T : in Scanner
) return boolean is
I : positive;
C : character;
F : boolean;
begin
if More(T) then
I := T.index;
C := Get(T);
if C = '+' or C = '-' then
T.index := T.index + 1;
end if;
F := Is_Any(T, Number_1);
T.index := I;
return F;
else
return false;
end if;
end Is_Signed_Number;
----------------------------------------------------------------
procedure Scan_Signed_Number(
T : in Scanner;
Found : out boolean;
Result : out String_Type;
Skip : in boolean := false
) is
C : character;
S_Str : String_Type;
begin
if Skip then
Skip_Space(T);
end if;
if Is_Signed_Number(T) then
C := Get(T);
if C = '+' or C = '-' then
Forward(T);
end if;
Scan_Number(T, Found, S_Str);
String_Pkg.Mark;
if C = '+' or C = '-' then
Result := String_Pkg.Make_Persistent(("" & C) & S_Str);
else
Result := String_Pkg.Make_Persistent(S_Str);
end if;
String_Pkg.Release;
String_Pkg.Flush(S_Str);
else
Found := false;
end if;
end Scan_Signed_Number;
----------------------------------------------------------------
procedure Scan_Signed_Number(
T : in Scanner;
Found : out boolean;
Result : out integer;
Skip : in boolean := false
) is
F : boolean;
S_Str : String_Type;
begin
Scan_Signed_Number(T, F, S_Str, Skip);
if F then
Result := integer'value(String_Pkg.Value(S_Str));
end if;
Found := F;
end Scan_Signed_Number;
pragma Page;
function Is_Space(
T : in Scanner
) return boolean is
begin
return Is_Any(T, White_Space);
end Is_Space;
----------------------------------------------------------------
procedure Scan_Space(
T : in Scanner;
Found : out boolean;
Result : out String_Type
) is
S_Str : String_Type;
begin
String_Pkg.Mark;
Scan_Any(T, White_Space, Found, S_Str);
Result := String_Pkg.Make_Persistent(S_Str);
String_Pkg.Release;
end Scan_Space;
----------------------------------------------------------------
procedure Skip_Space(
T : in Scanner
) is
S_Str : String_Type;
Found : boolean;
begin
String_Pkg.Mark;
Scan_Any(T, White_Space, Found, S_Str);
String_Pkg.Release;
end Skip_Space;
pragma Page;
function Is_Ada_Id(
T : in Scanner
) return boolean is
begin
return Is_Any(T, Ada_Id_1);
end Is_Ada_Id;
----------------------------------------------------------------
procedure Scan_Ada_Id(
T : in Scanner;
Found : out boolean;
Result : out String_Type;
Skip : in boolean := false
) is
C : character;
F : boolean;
S_Str : String_Type;
begin
if Skip then
Skip_Space(T);
end if;
if Is_Ada_Id(T) then
String_Pkg.Mark;
Next(T, C);
Scan_Any(T, Ada_Id, F, S_Str);
Result := String_Pkg.Make_Persistent(("" & C) & S_Str);
Found := true;
String_Pkg.Release;
else
Found := false;
end if;
end Scan_Ada_Id;
pragma Page;
function Is_Quoted(
T : in Scanner
) return boolean is
begin
if Quoted_String(T) = 0 then
return false;
else
return true;
end if;
end Is_Quoted;
----------------------------------------------------------------
procedure Scan_Quoted(
T : in Scanner;
Found : out boolean;
Result : out String_Type;
Skip : in boolean := false
) is
Count : integer;
begin
if Skip then
Skip_Space(T);
end if;
Count := Quoted_String(T);
if Count /= 0 then
Count := Count - 2;
T.index := T.index + 1;
if Count /= 0 then
String_Pkg.Mark;
Result := String_Pkg.Make_Persistent
(String_Pkg.Substr(T.text, T.index, positive(Count)));
String_Pkg.Release;
else
Result := String_Pkg.Make_Persistent("");
end if;
T.index := T.index + Count + 1;
Found := true;
else
Found := false;
end if;
end Scan_Quoted;
pragma Page;
function Is_Enclosed(
B : in character;
E : in character;
T : in Scanner
) return boolean is
begin
if Enclosed_String(B, E, T) = 0 then
return false;
else
return true;
end if;
end Is_Enclosed;
----------------------------------------------------------------
procedure Scan_Enclosed(
B : in character;
E : in character;
T : in Scanner;
Found : out boolean;
Result : out String_Type;
Skip : in boolean := false
) is
Count : natural;
begin
if Skip then
Skip_Space(T);
end if;
Count := Enclosed_String(B, E, T);
if Count /= 0 then
Count := Count - 2;
T.index := T.index + 1;
if Count /= 0 then
String_Pkg.Mark;
Result := String_Pkg.Make_Persistent(String_Pkg.Substr(T.text, T.index, positive(Count)));
String_Pkg.Release;
else
Result := String_Pkg.Make_Persistent("");
end if;
T.index := T.index + Count + 1;
Found := true;
else
Found := false;
end if;
end Scan_Enclosed;
pragma Page;
function Is_Sequence(
Chars : in String_Type;
T : in Scanner
) return boolean is
begin
return Is_Any(T, String_Pkg.Value(Chars));
end Is_Sequence;
----------------------------------------------------------------
function Is_Sequence(
Chars : in string;
T : in Scanner
) return boolean is
begin
return Is_Any(T, Chars);
end Is_Sequence;
----------------------------------------------------------------
procedure Scan_Sequence(
Chars : in String_Type;
T : in Scanner;
Found : out boolean;
Result : out String_Type;
Skip : in boolean := false
) is
I : positive;
Count : integer := 0;
begin
if Skip then
Skip_Space(T);
end if;
if not Is_Valid(T) then
Found := false;
return;
end if;
I := T.index;
while Is_Any(T, Value(Chars)) loop
Forward(T);
Count := Count + 1;
end loop;
if Count /= 0 then
String_Pkg.Mark;
Result := String_Pkg.Make_Persistent
(String_Pkg.Substr(T.text, I, positive(Count)));
Found := true;
String_Pkg.Release;
else
Found := false;
end if;
end Scan_Sequence;
----------------------------------------------------------------
procedure Scan_Sequence(
Chars : in string;
T : in Scanner;
Found : out boolean;
Result : out String_Type;
Skip : in boolean := false
) is
begin
String_Pkg.Mark;
Scan_Sequence(String_Pkg.Create(Chars), T, Found, Result, Skip);
String_Pkg.Release;
end Scan_Sequence;
pragma Page;
function Is_Not_Sequence(
Chars : in String_Type;
T : in Scanner
) return boolean is
N : natural;
begin
if not Is_Valid(T) then
return false;
end if;
String_Pkg.Mark;
N := String_Pkg.Match_Any(T.text, Chars, T.index);
if N = T.index then
N := 0;
end if;
String_Pkg.Release;
return N /= 0;
end Is_Not_Sequence;
----------------------------------------------------------------
function Is_Not_Sequence(
Chars : in string;
T : in Scanner
) return boolean is
begin
return Is_Not_Sequence(String_Pkg.Create(Chars), T);
end Is_Not_Sequence;
----------------------------------------------------------------
procedure Scan_Not_Sequence(
Chars : in string;
T : in Scanner;
Found : out boolean;
Result : out String_Type;
Skip : in boolean := false
) is
N : natural;
begin
if Skip then
Skip_Space(T);
end if;
if Is_Not_Sequence(Chars, T) then
String_Pkg.Mark;
N := String_Pkg.Match_Any(T.text, Chars, T.index);
Result := String_Pkg.Make_Persistent
(String_Pkg.Substr(T.text, T.index, N - T.index));
T.index := N;
Found := true;
String_Pkg.Release;
else
Found := false;
end if;
end Scan_Not_Sequence;
----------------------------------------------------------------
procedure Scan_Not_Sequence(
Chars : in String_Type;
T : in Scanner;
Found : out boolean;
Result : out String_Type;
Skip : in boolean := false
) is
begin
Scan_Not_Sequence(String_Pkg.Value(Chars), T, Found, Result, Skip);
end Scan_Not_Sequence;
pragma Page;
function Is_Literal(
Chars : in String_Type;
T : in Scanner
) return boolean is
N : natural;
begin
if not Is_Valid(T) then
return false;
end if;
String_Pkg.Mark;
N := String_Pkg.Match_S(T.text, Chars, T.index);
if N /= T.index then
N := 0;
end if;
String_Pkg.Release;
return N /= 0;
end Is_Literal;
----------------------------------------------------------------
function Is_Literal(
Chars : in string;
T : in Scanner
) return boolean is
Found : boolean;
begin
String_Pkg.Mark;
Found := Is_Literal(String_Pkg.Create(Chars), T);
String_Pkg.Release;
return Found;
end Is_Literal;
----------------------------------------------------------------
procedure Scan_Literal(
Chars : in String_Type;
T : in Scanner;
Found : out boolean;
Skip : in boolean := false
) is
begin
if Skip then
Skip_Space(T);
end if;
if Is_Literal(Chars, T) then
T.index := T.index + String_Pkg.Length(Chars);
Found := true;
else
Found := false;
end if;
end Scan_Literal;
----------------------------------------------------------------
procedure Scan_Literal(
Chars : in string;
T : in Scanner;
Found : out boolean;
Skip : in boolean := false
) is
begin
String_Pkg.Mark;
Scan_Literal(String_Pkg.Create(Chars), T, Found, Skip);
String_Pkg.Release;
end Scan_Literal;
pragma Page;
function Is_Not_Literal(
Chars : in string;
T : in Scanner
) return boolean is
N : natural;
begin
if not Is_Valid(T) then
return false;
end if;
String_Pkg.Mark;
N := String_Pkg.Match_S(T.text, Chars, T.index);
if N = T.index then
N := 0;
end if;
String_Pkg.Release;
return N /= 0;
end Is_Not_Literal;
----------------------------------------------------------------
function Is_Not_Literal(
Chars : in String_Type;
T : in Scanner
) return boolean is
begin
if not More(T) then
return false;
end if;
return Is_Not_Literal(String_Pkg.Value(Chars), T);
end Is_Not_Literal;
----------------------------------------------------------------
procedure Scan_Not_Literal(
Chars : in string;
T : in Scanner;
Found : out boolean;
Result : out String_Type;
Skip : in boolean := false
) is
N : natural;
begin
if Skip then
Skip_Space(T);
end if;
if Is_Not_Literal(Chars, T) then
String_Pkg.Mark;
N := String_Pkg.Match_S(T.text, Chars, T.index);
Result := String_Pkg.Make_Persistent(String_Pkg.Substr(T.text, T.index, N - T.index));
T.index := N;
Found := true;
String_Pkg.Release;
else
Found := false;
return;
end if;
end Scan_Not_Literal;
----------------------------------------------------------------
procedure Scan_Not_Literal(
Chars : in String_Type;
T : in Scanner;
Found : out boolean;
Result : out String_Type;
Skip : in boolean := false
) is
begin
Scan_Not_Literal(String_Pkg.Value(Chars), T, Found, Result, Skip);
end Scan_Not_Literal;
end String_Scanner;
pragma Page;
-- Module : string_scanner_.ada
-- Component of : common_library
-- Version : 1.2
-- Date : 11/21/86 16:37:08
-- SCCS File : disk21~/rschm/hasee/sccs/common_library/sccs/sxstring_scanner_.ada
with String_Pkg; use String_Pkg;
package String_Scanner is
--| Functions for scanning tokens from strings.
pragma Page;
--| Overview
--| This package provides a set of functions used to scan tokens from
--| strings. After the function make_Scanner is called to convert a string
--| into a string Scanner, the following functions may be called to scan
--| various tokens from the string:
--|-
--| Make_Scanner Given a string returns a Scanner
--| Destroy_Scanner Free storage used by Scanner
--| More Return TRUE iff unscanned characters remain
--| Forward Bump the Scanner
--| Backward Bump back the Scanner
--| Get Return character
--| Next Return character and bump the Scanner
--| Get_String Return String_Type in Scanner
--| Get_Remainder Return String_Type in Scanner from current Index
--| Mark Mark the current Index for Restore
--| Restore Restore the previously marked Index
--| Position Return the current position of the Scanner
--| Is_Word Return TRUE iff Scanner is at a non-blank character
--| Scan_Word Return sequence of non blank characters
--| Is_Number Return TRUE iff Scanner is at a digit
--| Scan_Number (2) Return sequence of decimal digits
--| Is_Signed_Number Return TRUE iff Scanner is at a digit or sign
--| Scan_Signed_Number (2)
--| sequence of decimal digits with optional sign (+/-)
--| Is_Space Return TRUE iff Scanner is at a space or tab
--| Scan_Space Return sequence of spaces or tabs
--| Skip_Space Advance Scanner past white space
--| Is_Ada_Id Return TRUE iff Scanner is at first character of ada id
--| Scan_Ada_Id Scan an Ada identifier
--| Is_Quoted Return TRUE iff Scanner is at a double quote
--| Scan_Quoted Scan quoted string, embedded quotes doubled
--| Is_Enclosed Return TRUE iff Scanner is at an enclosing character
--| Scan_Enclosed Scan enclosed string, embedded enclosing character doubled
--| Is_Sequence Return TRUE iff Scanner is at some character in sequence
--| Scan_Sequence Scan user specified sequence of chars
--| Is_Not_Sequence Return TRUE iff Scanner is not at the characters in sequence
--| Scan_Not_Sequence Scan string up to but not including a given sequence of chars
--| Is_Literal Return TRUE iff Scanner is at literal
--| Scan_Literal Scan user specified literal
--| Is_Not_Literal Return TRUE iff Scanner is not a given literal
--| Scan_Not_Literal Scan string up to but not including a given literal
--|+
----------------------------------------------------------------
Out_Of_Bounds : exception; --| Raised when a operation is attempted on a
--| Scanner that has passed the end
Scanner_Already_Marked : exception;
--| Raised when a Mark is attemped on a Scanner
--| that has already been marked
----------------------------------------------------------------
type Scanner is private; --| Scanner type
----------------------------------------------------------------
pragma Page;
function Make_Scanner( --| Construct a Scanner from S.
S : in String_Type --| String to be scanned.
) return Scanner;
--| Effects: Construct a Scanner from S.
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
procedure Destroy_Scanner( --| Free Scanner storage
T : in out Scanner --| Scanner to be freed
);
--| Effects: Free space occupied by the Scanner.
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
function More( --| Check if Scanner is exhausted
T : in Scanner --| Scanner to check
) return boolean;
--| Effects: Return TRUE iff additional characters remain to be scanned.
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
procedure Forward( --| Bump scanner
T : in Scanner --| Scanner
);
--| Effects: Update the scanner position.
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
procedure Backward( --| Bump back scanner
T : in Scanner --| Scanner
);
--| Effects: Update the scanner position.
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
function Get( --| Return character
T : in Scanner --| Scanner to check
) return character;
--| Raises: Out_Of_Bounds
--| Effects: Return character at the current Scanner position.
--| The scanner position remains unchanged.
--| N/A: Modifies, Errors
----------------------------------------------------------------
procedure Next( --| Return character and bump scanner
T : in Scanner; --| Scanner to check
C : out character --| Character to be returned
);
--| Raises: Out_Of_Bounds
--| Effects: Return character at the current Scanner position and update
--| the position.
--| N/A: Modifies, Errors
----------------------------------------------------------------
function Position( --| Return current Scanner position
T : in Scanner --| Scanner to check
) return positive;
--| Raises: Out_Of_Bounds
--| Effects: Return a positive integer indicating the current Scanner position,
--| N/A: Modifies, Errors
----------------------------------------------------------------
function Get_String( --| Return contents of Scanner
T : in Scanner --| Scanner
) return String_Type;
--| Effects: Return a String_Type corresponding to the contents of the Scanner
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
function Get_Remainder( --| Return contents of Scanner from index
T : in Scanner
) return String_Type;
--| Effects: Return a String_Type starting at the current index of the Scanner
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
procedure Mark(
T : in Scanner
);
--| Raises: Scanner_Already_Marked
--| Effects: Mark the current index for possible future use
--| N/A: Modifies, Errors
----------------------------------------------------------------
procedure Restore(
T : in Scanner
);
--| Effects: Restore the index to the previously marked value
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
pragma Page;
function Is_Word( --| Check if Scanner is at the start of a word.
T : in Scanner --| Scanner to check
) return boolean;
--| Effects: Return TRUE iff Scanner is at the start of a word.
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
procedure Scan_word( --| Scan sequence of non blank characters
T : in Scanner; --| String to be scanned
Found : out boolean; --| TRUE iff a word found
Result : out String_Type;--| Word scanned from string
Skip : in boolean := false
--| Skip white spaces before scan
);
--| Effects: Scan T for a sequence of non blank
--| characters. If at least one is found, return Found => TRUE,
--| Result => <the characters>.
--| Otherwise return Found => FALSE and Result is unpredictable.
--| N/A: Raises, Modifies, Errors
pragma Page;
function Is_Number( --| Return TRUE iff Scanner is at a decimal digit
T : in Scanner --| The string being scanned
) return boolean;
--| Effects: Return TRUE iff Scan_Number would return a non-null string.
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
procedure Scan_Number( --| Scan sequence of digits
T : in Scanner; --| String to be scanned
Found : out boolean; --| TRUE iff one or more digits found
Result : out String_Type;--| Number scanned from string
Skip : in boolean := false
--| Skip white spaces before scan
);
--| Effects: Scan T for a sequence of digits.
--| If at least one is found, return Found => TRUE, Result => <the digits>.
--| Otherwise return Found => FALSE and Result is unpredictable.
--| Modifies: Raises, Modifies, Errors
----------------------------------------------------------------
procedure Scan_Number( --| Scan sequence of digits
T : in Scanner; --| String to be scanned
Found : out boolean; --| TRUE iff one or more digits found
Result : out integer; --| Number scanned from string
Skip : in boolean := false
--| Skip white spaces before scan
);
--| Effects: Scan T for a sequence of digits.
--| If at least one is found, return Found => TRUE, Result => <the digits>.
--| Otherwise return Found => FALSE and Result is unpredictable.
--| Modifies: Raises, Modifies, Errors
pragma Page;
function Is_Signed_Number( --| Check if Scanner is at a decimal digit or
--| sign (+/-)
T : in Scanner --| The string being scanned
) return boolean;
--| Effects: Return TRUE iff Scan_Signed_Number would return a non-null
--| string.
--| N/A: Raises, Modifies, Errors
----------------------------------------------------------------
procedure Scan_Signed_Number( --| Scan signed sequence of digits
T : in Scanner; --| String to be scanned
Found : out boolean; --| TRUE iff one or more digits found
Result : out String_Type;--| Number scanned from string
Skip : in boolean := false
--| Skip white spaces before scan
);
--| Effects: Scan T for a sequence of digits preceeded with optional sign.
--| If at least one digit is found, return Found => TRUE,
--| Result => <the digits>.
--| Otherwise return Found => FALSE and Result is unpredictable.
--| Modifies: Raises, Modifies, Errors
----------------------------------------------------------------
procedure Scan_Signed_Number( --| Scan signed sequence of digits
T : in Scanner; --| String to be scanned
Found : out boolean; --| TRUE iff one or more digits found
Result : out integer; --| Number scanned from string
Skip : in boolean := false
--| Skip white spaces before scan
);
--| Effects: Scan T for a sequence of digits preceeded with optional sign.
--| If at least one digit is found, return Found => TRUE,
--| Result => <the digits>.
--| Otherwise return Found => FALSE and Result is unpredictable.
--| Modifies: Raises, Modifies, Errors
pragma Page;
function Is_Space( --| Check if T is at a space or tab
T : in Scanner --| The string being scanned
) return boolean;
--| Effects: Return TRUE iff Scan_Space would return a non-null string.
--| Modifies: Raises, Modifies, Errors
----------------------------------------------------------------
procedure Scan_Space( --| Scan sequence of white space characters
T : in Scanner; --| String to be scanned
Found : out boolean; --| TRUE iff space found
Result : out String_Type --| Spaces scanned from string
);
--| Effects: Scan T past all white space (spaces
--| and tabs. If at least one is found, return Found => TRUE,
--| Result => <the characters>.
--| Otherwise return Found => FALSE and Result is unpredictable.
--| Modifies: Raises, Modifies, Errors
----------------------------------------------------------------
procedure Skip_Space( --| Skip white space
T : in Scanner --| String to be scanned
);
--| Effects: Scan T past all white space (spaces and tabs).
--| Modifies: Raises, Modifies, Errors
pragma Page;
function Is_Ada_Id( --| Check if T is at an Ada identifier
T : in Scanner --| The string being scanned
) return boolean;
--| Effects: Return TRUE iff Scan_Ada_Id would return a non-null string.
--| Modifies: Raises, Modifies, Errors
----------------------------------------------------------------
procedure Scan_Ada_Id( --| Scan Ada identifier
T : in Scanner; --| String to be scanned
Found : out boolean; --| TRUE iff an Ada identifier found
Result : out String_Type;--| Identifier scanned from string
Skip : in boolean := false
--| Skip white spaces before scan
);
--| Effects: Scan T for a valid Ada identifier.
--| If one is found, return Found => TRUE, Result => <the characters>.
--| Otherwise return Found => FALSE and Result is unpredictable.
--| Modifies: Raises, Modifies, Errors
pragma Page;
function Is_Quoted( --| Check if T is at a double quote
T : in Scanner --| The string being scanned
) return boolean;
--| Effects: Return TRUE iff T is at a quoted string (eg. ... "Hello" ...).
--| Modifies: Raises, Modifies, Errors
----------------------------------------------------------------
procedure Scan_Quoted( --| Scan a quoted string
T : in Scanner; --| String to be scanned
Found : out boolean; --| TRUE iff a quoted string found
Result : out String_Type;--| Quoted string scanned from string
Skip : in boolean := false
--| Skip white spaces before scan
);
--| Effects: Scan at T for an opening quote
--| followed by a sequence of characters and ending with a closing
--| quote. If successful, return Found => TRUE, Result => <the characters>.
--| Otherwise return Found => FALSE and Result is unpredictable.
--| A pair of quotes within the quoted string is converted to a single quote.
--| The outer quotes are stripped.
--| Modifies: Raises, Modifies, Errors
pragma Page;
function Is_Enclosed( --| Check if T is at an enclosing character
B : in character; --| Enclosing open character
E : in character; --| Enclosing close character
T : in Scanner --| The string being scanned
) return boolean;
--| Effects: Return TRUE iff T as encosed by B and E (eg. ... [ABC] ...).
--| Modifies: Raises, Modifies, Errors
----------------------------------------------------------------
procedure Scan_Enclosed( --| Scan an enclosed string
B : in character; --| Enclosing open character
E : in character; --| Enclosing close character
T : in Scanner; --| String to be scanned
Found : out boolean; --| TRUE iff a quoted string found
Result : out String_Type;--| Quoted string scanned from string
Skip : in boolean := false
--| Skip white spaces before scan
);
--| Effects: Scan at T for an enclosing character
--| followed by a sequence of characters and ending with an enclosing character.
--| If successful, return Found => TRUE, Result => <the characters>.
--| Otherwise return Found => FALSE and Result is unpredictable.
--| The enclosing characters are stripped.
--| Modifies: Raises, Modifies, Errors
pragma Page;
function Is_Sequence( --| Check if T is at some sequence characters
Chars : in String_Type; --| Characters to be scanned
T : in Scanner --| The string being scanned
) return boolean;
--| Effects: Return TRUE iff T is at some character of Chars.
--| Modifies: Raises, Modifies, Errors
----------------------------------------------------------------
function Is_Sequence( --| Check if T is at some sequence characters
Chars : in string; --| Characters to be scanned
T : in Scanner --| The string being scanned
) return boolean;
--| Effects: Return TRUE iff T is at some character of Chars.
--| Modifies: Raises, Modifies, Errors
----------------------------------------------------------------
procedure Scan_Sequence( --| Scan arbitrary sequence of characters
Chars : in String_Type;--| Characters that should be scanned
T : in Scanner; --| String to be scanned
Found : out boolean; --| TRUE iff a sequence found
Result : out String_Type;--| Sequence scanned from string
Skip : in boolean := false
--| Skip white spaces before scan
);
--| Effects: Scan T for a sequence of characters C such that C appears in
--| Char. If at least one is found, return Found => TRUE,
--| Result => <the characters>.
--| Otherwise return Found => FALSE and Result is unpredictable.
--| Modifies: Raises, Modifies, Errors
--| Notes:
--| Scan_Sequence("0123456789", S, Index, Found, Result)
--| is equivalent to Scan_Number(S, Index, Found, Result)
--| but is less efficient.
----------------------------------------------------------------
procedure Scan_Sequence( --| Scan arbitrary sequence of characters
Chars : in string; --| Characters that should be scanned
T : in Scanner; --| String to be scanned
Found : out boolean; --| TRUE iff a sequence found
Result : out String_Type;--| Sequence scanned from string
Skip : in boolean := false
--| Skip white spaces before scan
);
--| Effects: Scan T for a sequence of characters C such that C appears in
--| Char. If at least one is found, return Found => TRUE,
--| Result => <the characters>.
--| Otherwise return Found => FALSE and Result is unpredictable.
--| Modifies: Raises, Modifies, Errors
--| Notes:
--| Scan_Sequence("0123456789", S, Index, Found, Result)
--| is equivalent to Scan_Number(S, Index, Found, Result)
--| but is less efficient.
pragma Page;
function Is_Not_Sequence( --| Check if T is not at some seuqnce of character
Chars : in String_Type; --| Characters to be scanned
T : in Scanner --| The string being scanned
) return boolean;
--| Effects: Return TRUE iff T is not at some character of Chars.
--| Modifies: Raises, Modifies, Errors
----------------------------------------------------------------
function Is_Not_Sequence( --| Check if T is at some sequence of characters
Chars : in string; --| Characters to be scanned
T : in Scanner --| The string being scanned
) return boolean;
--| Effects: Return TRUE iff T is not at some character of Chars.
--| Modifies: Raises, Modifies, Errors
----------------------------------------------------------------
procedure Scan_Not_Sequence( --| Scan arbitrary sequence of characters
Chars : in String_Type;--| Characters that should be scanned
T : in Scanner; --| String to be scanned
Found : out boolean; --| TRUE iff a sequence found
Result : out String_Type;--| Sequence scanned from string
Skip : in boolean := false
--| Skip white spaces before scan
);
--| Effects: Scan T for a sequence of characters C such that C does not appear
--| in Chars. If at least one such C is found, return Found => TRUE,
--| Result => <the characters>.
--| Otherwise return Found => FALSE and Result is unpredictable.
--| Modifies: Raises, Modifies, Errors
----------------------------------------------------------------
procedure Scan_Not_Sequence( --| Scan arbitrary sequence of characters
Chars : in string; --| Characters that should be scanned
T : in Scanner; --| String to be scanned
Found : out boolean; --| TRUE iff a sequence found
Result : out String_Type;--| Sequence scanned from string
Skip : in boolean := false
--| Skip white spaces before scan
);
--| Effects: Scan T for a sequence of characters C such that C does not appear
--| in Chars. If at least one such C is found, return Found => TRUE,
--| Result => <the characters>.
--| Otherwise return Found => FALSE and Result is unpredictable.
--| Modifies: Raises, Modifies, Errors
pragma Page;
function Is_Literal( --| Check if T is at literal Chars
Chars : in String_Type; --| Characters to be scanned
T : in Scanner --| The string being scanned
) return boolean;
--| Effects: Return TRUE iff T is at literal Chars.
--| Modifies: Raises, Modifies, Errors
----------------------------------------------------------------
function Is_Literal( --| Check if T is at literal Chars
Chars : in string; --| Characters to be scanned
T : in Scanner --| The string being scanned
) return boolean;
--| Effects: Return TRUE iff T is at literal Chars.
--| Modifies: Raises, Modifies, Errors
----------------------------------------------------------------
procedure Scan_Literal( --| Scan arbitrary literal
Chars : in String_Type;--| Literal that should be scanned
T : in Scanner; --| String to be scanned
Found : out boolean; --| TRUE iff a sequence found
Skip : in boolean := false
--| Skip white spaces before scan
);
--| Effects: Scan T for a litral Chars such that Char matches the sequence
--| of characters in T. If found, return Found => TRUE,
--| Otherwise return Found => FALSE
--| Modifies: Raises, Modifies, Errors
----------------------------------------------------------------
procedure Scan_Literal( --| Scan arbitrary literal
Chars : in string; --| Literal that should be scanned
T : in Scanner; --| String to be scanned
Found : out boolean; --| TRUE iff a sequence found
Skip : in boolean := false
--| Skip white spaces before scan
);
--| Effects: Scan T for a litral Chars such that Char matches the sequence
--| of characters in T. If found, return Found => TRUE,
--| Otherwise return Found => FALSE
--| Modifies: Raises, Modifies, Errors
pragma Page;
function Is_Not_Literal( --| Check if T is not at literal Chars
Chars : in string; --| Characters to be scanned
T : in Scanner --| The string being scanned
) return boolean;
--| Effects: Return TRUE iff T is not at literal Chars
--| Modifies: Raises, Modifies, Errors
----------------------------------------------------------------
function Is_Not_Literal( --| Check if T is not at literal Chars
Chars : in String_Type; --| Characters to be scanned
T : in Scanner --| The string being scanned
) return boolean;
--| Effects: Return TRUE iff T is not at literal Chars
--| Modifies: Raises, Modifies, Errors
----------------------------------------------------------------
procedure Scan_Not_Literal( --| Scan arbitrary literal
Chars : in string; --| Literal that should be scanned
T : in Scanner; --| String to be scanned
Found : out boolean; --| TRUE iff a sequence found
Result : out String_Type;--| String up to literal
Skip : in boolean := false
--| Skip white spaces before scan
);
--| Effects: Scan T for a litral Chars such that Char does not match the
--| sequence of characters in T. If found, return Found => TRUE,
--| Otherwise return Found => FALSE
--| Modifies: Raises, Modifies, Errors
----------------------------------------------------------------
procedure Scan_Not_Literal( --| Scan arbitrary literal
Chars : in String_Type;--| Literal that should be scanned
T : in Scanner; --| String to be scanned
Found : out boolean; --| TRUE iff a sequence found
Result : out String_Type;--| String up to literal
Skip : in boolean := false
--| Skip white spaces before scan
);
--| Effects: Scan T for a litral Chars such that Char does not match the
--| sequence of characters in T. If found, return Found => TRUE,
--| Otherwise return Found => FALSE
--| Modifies: Raises, Modifies, Errors
pragma Page;
private
pragma List(off);
type Scan_Record is
record
text : String_Type; --| Copy of string being scanned
index : positive := 1; --| Current position of Scanner
mark : natural := 0; --| Mark
end record;
type Scanner is access Scan_Record;
pragma List(on);
end String_Scanner;
pragma Page;
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- The primary authors of ayacc were David Taback and Deepak Tolani.
-- Enhancements were made by Ronald J. Schmalz.
--
-- Send requests for ayacc information to ayacc-info@ics.uci.edu
-- Send bug reports for ayacc to ayacc-bugs@ics.uci.edu
--
-- Redistribution and use in source and binary forms are permitted
-- provided that the above copyright notice and this paragraph are
-- duplicated in all such forms and that any documentation,
-- advertising materials, and other materials related to such
-- distribution and use acknowledge that the software was developed
-- by the University of California, Irvine. The name of the
-- University may not be used to endorse or promote products derived
-- from this software without specific prior written permission.
-- THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
-- IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
-- WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
-- Module : symbol_info.ada
-- Component of : ayacc
-- Version : 1.2
-- Date : 11/21/86 12:37:08
-- SCCS File : disk21~/rschm/hasee/sccs/ayacc/sccs/sxsymbol_info.ada
-- $Header: symbol_info.a,v 0.1 86/04/01 15:13:15 ada Exp $
-- $Log: symbol_info.a,v $
-- Revision 0.1 86/04/01 15:13:15 ada
-- This version fixes some minor bugs with empty grammars
-- and $$ expansion. It also uses vads5.1b enhancements
-- such as pragma inline.
--
--
-- Revision 0.0 86/02/19 18:42:36 ada
--
-- These files comprise the initial version of Ayacc
-- designed and implemented by David Taback and Deepak Tolani.
-- Ayacc has been compiled and tested under the Verdix Ada compiler
-- version 4.06 on a vax 11/750 running Unix 4.2BSD.
--
with Symbol_Table, Rule_Table;
use Symbol_Table, Rule_Table;
package Symbol_Info is
--
-- The following array declarations are used to compute the
-- the rules that have a particular symbol on the left hand
-- side. NONTERMINAL_YIELD contains the rules and
-- NONTERMINAL_YIELD_OFFSET contains the offset into the first array
-- indexed by a particular nonterminal. The user of this package
-- should not attempt to alter the contents of these arrays. They
-- are visible in the spec only for efficiency reasons.
--
type Yield_Index is new Integer;
type Rule_Array is array (Yield_Index range <>) of Rule;
type Offset_Array is array (Grammar_Symbol range <>) of Yield_Index;
type Rule_Array_Pointer is access Rule_Array;
type Offset_Array_Pointer is access Offset_Array;
Nonterminal_Yield : Rule_Array_Pointer;
Nonterminal_Yield_Index : Offset_Array_Pointer;
---
procedure Initialize;
function Is_Nullable(Sym: Grammar_Symbol) return Boolean;
Undefined_Nonterminal : exception;
-- raised if a nonterminal doesn't appear on left hand side of
-- any rule.
--RJS pragma inline(is_nullable);
end Symbol_Info;
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- The primary authors of ayacc were David Taback and Deepak Tolani.
-- Enhancements were made by Ronald J. Schmalz.
--
-- Send requests for ayacc information to ayacc-info@ics.uci.edu
-- Send bug reports for ayacc to ayacc-bugs@ics.uci.edu
--
-- Redistribution and use in source and binary forms are permitted
-- provided that the above copyright notice and this paragraph are
-- duplicated in all such forms and that any documentation,
-- advertising materials, and other materials related to such
-- distribution and use acknowledge that the software was developed
-- by the University of California, Irvine. The name of the
-- University may not be used to endorse or promote products derived
-- from this software without specific prior written permission.
-- THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
-- IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
-- WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
-- Module : symbol_info_body.ada
-- Component of : ayacc
-- Version : 1.2
-- Date : 11/21/86 12:37:23
-- SCCS File : disk21~/rschm/hasee/sccs/ayacc/sccs/sxsymbol_info_body.ada
-- $Header: symbol_info_body.a,v 0.1 86/04/01 15:13:25 ada Exp $
-- $Log: symbol_info_body.a,v $
-- Revision 0.1 86/04/01 15:13:25 ada
-- This version fixes some minor bugs with empty grammars
-- and $$ expansion. It also uses vads5.1b enhancements
-- such as pragma inline.
--
--
-- Revision 0.0 86/02/19 18:46:56 ada
--
-- These files comprise the initial version of Ayacc
-- designed and implemented by David Taback and Deepak Tolani.
-- Ayacc has been compiled and tested under the Verdix Ada compiler
-- version 4.06 on a vax 11/750 running Unix 4.2BSD.
--
with Text_IO;
package body Symbol_Info is
SCCS_ID : constant String := "@(#) symbol_info_body.ada, Version 1.2";
Rcs_ID : constant String := "$Header: symbol_info_body.a,v 0.1 86/04/01 15:13:25 ada Exp $";
type Nullables_Array is array (Grammar_Symbol range <>) of Boolean;
type Nullables_Array_Pointer is access Nullables_Array;
Nullables : Nullables_Array_Pointer;
--
-- initializes the elements of the array pointed to by
-- NULLABLES to false if they cannot derive the empty
-- string and TRUE if they can derive the empty string.
--
procedure Find_Nullables is
Sym_Position : Natural;
Nonterminal_Sym : Grammar_Symbol;
RHS_Sym : Grammar_Symbol;
No_More_Added : Boolean;
Rule_Length : Natural;
begin
--& Verdix 4.06 bug
--& nullables.all := (nullables.all'range => false);
--& bug fix
for S in Nullables.all'range loop
Nullables(S) := False;
end loop;
--& end bug fix
-- First determine the symbols that are trivially nullable.
for R in First_Rule..Last_Rule loop
if Length_of(R) = 0 then
Nullables(Get_LHS(R)) := True;
end if;
end loop;
loop
No_More_Added := True;
for R in First_Rule..Last_Rule loop
Nonterminal_Sym := Get_LHS(R);
if not Nullables(Nonterminal_Sym) then
Sym_Position := 1;
Rule_Length := Length_of(R);
while Sym_Position <= Rule_Length loop
RHS_Sym := Get_RHS(R, Sym_Position);
exit when Is_Terminal(RHS_Sym) or else
not Nullables(RHS_Sym);
Sym_Position := Sym_Position + 1;
end loop;
if Sym_Position > Rule_Length then
Nullables(Nonterminal_Sym) := True;
No_More_Added := False;
end if;
end if;
end loop;
exit when No_More_Added;
end loop;
end Find_Nullables;
function Is_Nullable(Sym: Grammar_Symbol) return Boolean is
begin
return Nullables(Sym);
end Is_Nullable;
procedure Make_Rules_Null_Position is
Null_Position : Integer;
RHS_Sym : Grammar_Symbol;
begin
for R in First_Rule..Last_Rule loop
Null_Position := Length_of(R);
while Null_Position /= 0 loop
RHS_Sym := Get_RHS(R, Null_Position);
if Is_Terminal(RHS_Sym) or else not Nullables(RHS_Sym) then
exit;
end if;
Null_Position := Null_Position - 1;
end loop;
Set_Null_Pos(R, Null_Position);
end loop;
end Make_Rules_Null_Position;
procedure Find_Rule_Yields is
use Text_IO; -- To report undefined nonterminals
Found_Undefined_Nonterminal: Boolean := False;
Current_Index : Yield_Index;
begin
-- First initialize the arrays to the correct size --
Nonterminal_Yield := new Rule_Array
(Yield_Index(First_Rule)..Yield_Index(Last_Rule));
Nonterminal_Yield_Index := new Offset_Array
(First_Symbol(Nonterminal)..Last_Symbol(Nonterminal) + 1);
Current_Index := Yield_Index(First_Rule);
for Sym in First_Symbol(Nonterminal)..Last_Symbol(Nonterminal) loop
Nonterminal_Yield_Index(Sym) := Current_Index;
for R in First_Rule..Last_Rule loop
if Get_LHS(R) = Sym then
Nonterminal_Yield(Current_Index) := R;
Current_Index := Current_Index + 1;
end if;
end loop;
if Nonterminal_Yield_Index(Sym) = Current_Index then
Found_Undefined_Nonterminal := True;
Put_Line ("Ayacc: Nonterminal " & Get_Symbol_Name(Sym) &
" does not appear on the " &
"left hand side of any rule.");
end if;
end loop;
Nonterminal_Yield_Index(Last_Symbol(Nonterminal) + 1) := Current_Index;
-- So you can easily determine the end of the list in loops
-- bye comparing the index to the index of sym+1.
if Found_Undefined_Nonterminal then
raise Undefined_Nonterminal;
end if;
end Find_Rule_Yields;
-- First detect nonterminals that can't be derived from the start symbol.
-- Then detect nonterminals that don't derive any token string.
--
-- NOTE: We should use Digraph to do this stuff when we
-- have time to put it in.
procedure Check_Grammar is
use Text_IO; -- to report errors
type Nonterminal_Array is array (Grammar_Symbol range <>) of Boolean;
Ok : Nonterminal_Array
(First_Symbol(Nonterminal)..Last_Symbol(Nonterminal));
More : Boolean;
I : Natural;
Rule_Length : Natural;
Found_Error : Boolean := False;
RHS_Sym, LHS_Sym: Grammar_Symbol;
Bad_Grammar : exception; -- Move this somewhere else!!!
begin
-- check if each nonterminal is deriveable from the start symbol --
-- To be added! We should use digraph for this
-- check if each nonterminal can derive a terminal string. --
--& Verdix 4.06 bug
--& ok := (ok'range => false);
--& bug fix
for S in Ok'range loop
Ok(S) := False;
end loop;
--& end bug fix
More := True;
while More loop
More := False;
for R in First_Rule..Last_Rule loop
LHS_Sym := Get_LHS(R);
if not Ok(LHS_Sym) then
I := 1;
Rule_Length := Length_of(R);
while I <= Rule_Length loop
RHS_Sym := Get_RHS(R, I);
if Is_Nonterminal(RHS_Sym) and then
not Ok(RHS_Sym)
then
exit;
end if;
I := I + 1;
end loop;
if I > Rule_Length then -- nonterminal can derive terminals
Ok(LHS_Sym) := True;
More := True;
end if;
end if;
end loop;
end loop;
for J in Ok'range loop
if not Ok(J) then
Put_Line ("Ayacc: Nonterminal " & Get_Symbol_Name(J) &
" does not derive a terminal string");
Found_Error := True;
end if;
end loop;
if Found_Error then
raise Bad_Grammar;
end if;
end Check_Grammar;
procedure Initialize is
begin
Nullables := new Nullables_Array
(First_Symbol(Nonterminal) .. Last_Symbol(Nonterminal));
Find_Rule_Yields;
Check_Grammar;
Find_Nullables;
Make_Rules_Null_Position;
end Initialize;
end Symbol_Info;
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- The primary authors of ayacc were David Taback and Deepak Tolani.
-- Enhancements were made by Ronald J. Schmalz.
--
-- Send requests for ayacc information to ayacc-info@ics.uci.edu
-- Send bug reports for ayacc to ayacc-bugs@ics.uci.edu
--
-- Redistribution and use in source and binary forms are permitted
-- provided that the above copyright notice and this paragraph are
-- duplicated in all such forms and that any documentation,
-- advertising materials, and other materials related to such
-- distribution and use acknowledge that the software was developed
-- by the University of California, Irvine. The name of the
-- University may not be used to endorse or promote products derived
-- from this software without specific prior written permission.
-- THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
-- IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
-- WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
-- Module : symbol_table.ada
-- Component of : ayacc
-- Version : 1.2
-- Date : 11/21/86 12:37:38
-- SCCS File : disk21~/rschm/hasee/sccs/ayacc/sccs/sxsymbol_table.ada
-- $Header: symbol_table.a,v 0.1 86/04/01 15:13:41 ada Exp $
-- $Log: symbol_table.a,v $
-- Revision 0.1 86/04/01 15:13:41 ada
-- This version fixes some minor bugs with empty grammars
-- and $$ expansion. It also uses vads5.1b enhancements
-- such as pragma inline.
--
--
-- Revision 0.0 86/02/19 18:47:05 ada
--
-- These files comprise the initial version of Ayacc
-- designed and implemented by David Taback and Deepak Tolani.
-- Ayacc has been compiled and tested under the Verdix Ada compiler
-- version 4.06 on a vax 11/750 running Unix 4.2BSD.
--
package Symbol_Table is
type Symbol_Type is (Start, Nonterminal, Terminal);
type Grammar_Symbol is range -5_000..5_000;
type Precedence is range 0..5_000;
type Associativity is (Left_Associative, Right_Associative,
Nonassociative, Undefined);
function Insert_Identifier(Name: in String) return Grammar_Symbol;
function Insert_Terminal (Name: String;
Prec: Precedence := 0;
Assoc: Associativity := Undefined)
return Grammar_Symbol;
function Get_Associativity(ID: Grammar_Symbol) return Associativity;
function Get_Precedence (ID: Grammar_Symbol) return Precedence;
function Get_Symbol_Name (ID: Grammar_Symbol) return String;
function First_Symbol (Kind: Symbol_Type) return Grammar_Symbol;
function Last_Symbol (Kind: Symbol_Type) return Grammar_Symbol;
function Start_Symbol return Grammar_Symbol;
function End_Symbol return Grammar_Symbol;
function Is_Terminal (ID: Grammar_Symbol) return Boolean;
function Is_Nonterminal (ID: Grammar_Symbol) return Boolean;
Illegal_Entry, Redefined_Precedence_Error : exception;
--RJS pragma inline(is_terminal, is_nonterminal);
end Symbol_Table;
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- The primary authors of ayacc were David Taback and Deepak Tolani.
-- Enhancements were made by Ronald J. Schmalz.
--
-- Send requests for ayacc information to ayacc-info@ics.uci.edu
-- Send bug reports for ayacc to ayacc-bugs@ics.uci.edu
--
-- Redistribution and use in source and binary forms are permitted
-- provided that the above copyright notice and this paragraph are
-- duplicated in all such forms and that any documentation,
-- advertising materials, and other materials related to such
-- distribution and use acknowledge that the software was developed
-- by the University of California, Irvine. The name of the
-- University may not be used to endorse or promote products derived
-- from this software without specific prior written permission.
-- THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
-- IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
-- WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
-- Module : symbol_table_body.ada
-- Component of : ayacc
-- Version : 1.2
-- Date : 11/21/86 12:37:53
-- SCCS File : disk21~/rschm/hasee/sccs/ayacc/sccs/sxsymbol_table_body.ada
-- $Header: symbol_table_body.a,v 0.1 86/04/01 15:13:55 ada Exp $
-- $Log: symbol_table_body.a,v $
-- Revision 0.1 86/04/01 15:13:55 ada
-- This version fixes some minor bugs with empty grammars
-- and $$ expansion. It also uses vads5.1b enhancements
-- such as pragma inline.
--
--
-- Revision 0.0 86/02/19 18:54:02 ada
--
-- These files comprise the initial version of Ayacc
-- designed and implemented by David Taback and Deepak Tolani.
-- Ayacc has been compiled and tested under the Verdix Ada compiler
-- version 4.06 on a vax 11/750 running Unix 4.2BSD.
--
package body Symbol_Table is
SCCS_ID : constant String := "@(#) symbol_table_body.ada, Version 1.2";
Next_Free_Terminal : Grammar_Symbol := 0;
Next_Free_Nonterminal : Grammar_Symbol := -1;
Start_Symbol_Pos, End_Symbol_Pos : Grammar_Symbol;
type String_Pointer is access String;
type Table_Entry(ID : Grammar_Symbol);
type Entry_Pointer is access Table_Entry;
type Table_Entry(ID :Grammar_Symbol) is
record
Name : String_Pointer;
Next : Entry_Pointer;
case ID is
when 0..Grammar_Symbol'Last => -- Terminal
Prec : Precedence;
Assoc : Associativity;
when others => -- Nonterminal
null;
end case;
end record;
Hash_Table_Size : constant := 613; -- A large prime number
type Hash_Index is range 0..Hash_Table_Size-1;
Hash_Table : array(Hash_Index) of Entry_Pointer;
--
-- Create a 'dynamic' array for looking up an entry
-- for a given grammar_symbol.
--
Block_Size : constant Grammar_Symbol := 100;
type Lookup_Array is
array(Grammar_Symbol range 0..Block_Size-1) of Entry_Pointer;
type Block;
type Block_Pointer is access Block;
type Block is
record
Lookup : Lookup_Array;
Next : Block_Pointer := null;
end record;
-- have separate blocks for terminals and nonterminals.
Terminal_Blocks, Nonterminal_Blocks : Block_Pointer := new Block;
procedure Make_Lookup_Table_Entry
(ID : in Grammar_Symbol;
Entry_Ptr : in Entry_Pointer) is
ID_Block : Block_Pointer;
Block_Number : Integer;
begin
if ID >= 0 then
ID_Block := Terminal_Blocks;
else
ID_Block := Nonterminal_Blocks;
end if;
Block_Number := Integer (abs ID / Block_Size);
for I in 1..Block_Number loop
if ID_Block.Next = null then
ID_Block.Next := new Block;
end if;
ID_Block := ID_Block.Next;
end loop;
ID_Block.Lookup((abs ID) mod Block_Size) := Entry_Ptr;
end Make_Lookup_Table_Entry;
function Get_Lookup_Table_Entry(ID: Grammar_Symbol) return Entry_Pointer is
ID_Block : Block_Pointer;
begin
if ID >= 0 then
ID_Block := Terminal_Blocks;
else
ID_Block := Nonterminal_Blocks;
end if;
for I in 1.. abs ID / Block_Size loop
ID_Block := ID_Block.Next;
end loop;
return ID_Block.Lookup((abs ID) mod Block_Size);
end Get_Lookup_Table_Entry;
-- some day someone should put in a good hash function.
function Hash_Value (S : String) return Hash_Index is
H : Integer;
Mid : Integer;
begin
Mid := (S'First + S'Last) / 2;
H := ((Character'Pos(S(S'First)) +
Character'Pos(S(Mid)) +
Character'Pos(S(S'Last)))
* S'Length * 16 ) mod Hash_Table_Size;
return Hash_Index(H);
end Hash_Value;
function Insert_Identifier (Name: in String) return Grammar_Symbol is
Index : Hash_Index;
Entry_Ptr : Entry_Pointer;
begin
Index := Hash_Value(Name);
Entry_Ptr := Hash_Table(Index);
if Entry_Ptr = null then
Entry_Ptr := new Table_Entry(Next_Free_Nonterminal);
Entry_Ptr.Name := new String(1..Name'Length);
Entry_Ptr.Name.all := Name;
Hash_Table(Index) := Entry_Ptr;
Make_Lookup_Table_Entry(Next_Free_Nonterminal, Entry_Ptr);
Next_Free_Nonterminal := Next_Free_Nonterminal - 1;
else
loop
if Entry_Ptr.Name.all = Name then
return Entry_Ptr.ID;
end if;
if Entry_Ptr.Next = null then
exit;
end if;
Entry_Ptr := Entry_Ptr.Next;
end loop;
Entry_Ptr.Next := new Table_Entry(Next_Free_Nonterminal);
Entry_Ptr := Entry_Ptr.Next;
Entry_Ptr.Name := new String(1..Name'Length);
Entry_Ptr.Name.all := Name;
Make_Lookup_Table_Entry(Next_Free_Nonterminal, Entry_Ptr);
Next_Free_Nonterminal := Next_Free_Nonterminal - 1;
end if;
return Next_Free_Nonterminal + 1;
end Insert_Identifier;
function Insert_Terminal
(Name : String;
Prec : Precedence := 0;
Assoc : Associativity := Undefined) return Grammar_Symbol is
Index : Hash_Index;
Entry_Ptr : Entry_Pointer;
begin
Index := Hash_Value(Name);
Entry_Ptr := Hash_Table(Index);
if Entry_Ptr = null then
Entry_Ptr := new Table_Entry(Next_Free_Terminal);
Entry_Ptr.Name := new String(1..Name'Length);
Entry_Ptr.Name.all := Name;
Entry_Ptr.Assoc := Assoc;
Entry_Ptr.Prec := Prec;
Hash_Table(Index) := Entry_Ptr;
Make_Lookup_Table_Entry(Next_Free_Terminal, Entry_Ptr);
Next_Free_Terminal := Next_Free_Terminal + 1;
else
loop
if Entry_Ptr.Name.all = Name then
if Entry_Ptr.ID < 0 then -- Look out for nonterminals
raise Illegal_Entry;
end if;
if Prec /= 0 then
if Entry_Ptr.Prec /= 0 then
raise Redefined_Precedence_Error;
end if;
Entry_Ptr.Prec := Prec;
Entry_Ptr.Assoc := Assoc;
end if;
return Entry_Ptr.ID;
end if;
if Entry_Ptr.Next = null then
exit;
end if;
Entry_Ptr := Entry_Ptr.Next;
end loop;
Entry_Ptr.Next := new Table_Entry(Next_Free_Terminal);
Entry_Ptr := Entry_Ptr.Next;
Entry_Ptr.Name := new String(1..Name'Length);
Entry_Ptr.Name.all := Name;
Entry_Ptr.Assoc := Assoc;
Entry_Ptr.Prec := Prec;
Make_Lookup_Table_Entry(Next_Free_Terminal, Entry_Ptr);
Next_Free_Terminal := Next_Free_Terminal + 1;
end if;
return Next_Free_Terminal - 1;
end Insert_Terminal;
function Get_Associativity (ID: Grammar_Symbol) return Associativity is
begin
return Get_Lookup_Table_Entry(ID).Assoc;
end;
function Get_Precedence (ID: Grammar_Symbol) return Precedence is
begin
return Get_Lookup_Table_Entry(ID).Prec;
end;
function Get_Symbol_Name (ID: Grammar_Symbol) return String is
begin
return Get_Lookup_Table_Entry(ID).Name.all;
end;
function First_Symbol (Kind: Symbol_Type) return Grammar_Symbol is
begin
if Kind = Terminal then
return 0;
else
return Next_Free_Nonterminal + 1;
end if;
end;
function Last_Symbol (Kind: Symbol_Type) return Grammar_Symbol is
begin
if Kind = Terminal then
return Next_Free_Terminal - 1;
else
return -1;
end if;
end;
function First_Terminal return Grammar_Symbol is
begin
return 0;
end;
function Last_Terminal return Grammar_Symbol is
begin
return Next_Free_Terminal - 1;
end;
function Start_Symbol return Grammar_Symbol is
begin
return Start_Symbol_Pos;
end;
function End_Symbol return Grammar_Symbol is
begin
return End_Symbol_Pos;
end;
function Is_Terminal (ID: Grammar_Symbol) return Boolean is
begin
return ID >= 0;
end;
function Is_Nonterminal (ID: Grammar_Symbol) return Boolean is
begin
return ID < 0;
end;
begin
End_Symbol_Pos := Insert_Terminal("END_OF_INPUT");
Start_Symbol_Pos := Insert_Identifier("$accept");
-- declare a dummy symbol to insert the "error" token.
declare
Dummy_Sym : Grammar_Symbol;
begin
Dummy_Sym := Insert_Terminal("ERROR");
end;
end Symbol_Table;
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- The primary authors of ayacc were David Taback and Deepak Tolani.
-- Enhancements were made by Ronald J. Schmalz.
--
-- Send requests for ayacc information to ayacc-info@ics.uci.edu
-- Send bug reports for ayacc to ayacc-bugs@ics.uci.edu
--
-- Redistribution and use in source and binary forms are permitted
-- provided that the above copyright notice and this paragraph are
-- duplicated in all such forms and that any documentation,
-- advertising materials, and other materials related to such
-- distribution and use acknowledge that the software was developed
-- by the University of California, Irvine. The name of the
-- University may not be used to endorse or promote products derived
-- from this software without specific prior written permission.
-- THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
-- IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
-- WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
-- Module : tokens_file.ada
-- Component of : ayacc
-- Version : 1.2
-- Date : 11/21/86 12:38:10
-- SCCS File : disk21~/rschm/hasee/sccs/ayacc/sccs/sxtokens_file.ada
-- $Header: tokens_file.a,v 0.1 86/04/01 15:14:22 ada Exp $
-- $Log: tokens_file.a,v $
-- Revision 0.1 86/04/01 15:14:22 ada
-- This version fixes some minor bugs with empty grammars
-- and $$ expansion. It also uses vads5.1b enhancements
-- such as pragma inline.
--
--
-- Revision 0.0 86/02/19 18:54:11 ada
--
-- These files comprise the initial version of Ayacc
-- designed and implemented by David Taback and Deepak Tolani.
-- Ayacc has been compiled and tested under the Verdix Ada compiler
-- version 4.06 on a vax 11/750 running Unix 4.2BSD.
--
package Tokens_File is
procedure Open;
procedure Start_Tokens_Package;
function Tokens_Package_Header_Has_Been_Generated return Boolean;
--| Returns: True iff Start_Tokens_Package has been called.
procedure Complete_Tokens_Package;
procedure Make_C_Lex_Package; -- yylex that interfaces to C!!!
-- Creates the #define also!!
procedure Close;
procedure Write (S : in String);
procedure Writeln(S: in String);
end Tokens_File;
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- The primary authors of ayacc were David Taback and Deepak Tolani.
-- Enhancements were made by Ronald J. Schmalz.
--
-- Send requests for ayacc information to ayacc-info@ics.uci.edu
-- Send bug reports for ayacc to ayacc-bugs@ics.uci.edu
--
-- Redistribution and use in source and binary forms are permitted
-- provided that the above copyright notice and this paragraph are
-- duplicated in all such forms and that any documentation,
-- advertising materials, and other materials related to such
-- distribution and use acknowledge that the software was developed
-- by the University of California, Irvine. The name of the
-- University may not be used to endorse or promote products derived
-- from this software without specific prior written permission.
-- THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
-- IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
-- WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
-- Module : tokens_file_body.ada
-- Component of : ayacc
-- Version : 1.2
-- Date : 11/21/86 12:38:23
-- SCCS File : disk21~/rschm/hasee/sccs/ayacc/sccs/sxtokens_file_body.ada
-- $Header: tokens_file_body.a,v 0.1 86/04/01 15:14:29 ada Exp $
-- $Log: tokens_file_body.a,v $
-- Revision 0.1 86/04/01 15:14:29 ada
-- This version fixes some minor bugs with empty grammars
-- and $$ expansion. It also uses vads5.1b enhancements
-- such as pragma inline.
--
--
-- Revision 0.0 86/02/19 18:54:19 ada
--
-- These files comprise the initial version of Ayacc
-- designed and implemented by David Taback and Deepak Tolani.
-- Ayacc has been compiled and tested under the Verdix Ada compiler
-- version 4.06 on a vax 11/750 running Unix 4.2BSD.
--
with File_Names, Source_File, Symbol_Table, Text_IO;
with String_Pkg;
package body Tokens_File is
SCCS_ID : constant String := "@(#) tokens_file_body.ada, Version 1.2";
Rcs_ID : constant String := "$Header: tokens_file_body.a,v 0.1 86/04/01 15:14:29 ada Exp $";
Package_Header_Generated : Boolean := False;
T_File: Text_IO.File_Type;
procedure Open is
use Text_IO;
begin
Create(T_File, Out_File, File_Names.Get_Tokens_File_Name);
end Open;
function Tokens_Package_Header_Has_Been_Generated return Boolean is
begin
return Package_Header_Generated;
end Tokens_Package_Header_Has_Been_Generated;
procedure Start_Tokens_Package is
begin
if not Package_Header_Generated then
Writeln("package " & File_Names.Tokens_Unit_Name & " is");
Writeln("");
Package_Header_Generated := True;
end if;
end Start_Tokens_Package;
procedure Close is
use Text_IO;
begin
Close(T_File);
end Close;
procedure Write(S: in String) is
use Text_IO;
begin
Put(T_File,S);
end Write;
procedure Writeln(S: in String) is
use Text_IO;
begin
Put_Line(T_File,S);
end Writeln;
procedure Complete_Tokens_Package is
Tokens_On_Line: Natural := 1;
use String_Pkg;
use Symbol_Table;
begin
if not Package_Header_Generated then
Start_Tokens_Package;
end if;
Writeln(" YYLVal, YYVal : YYSType; ");
Writeln(" type Token is");
Write(" (");
for I in First_Symbol(Terminal)..Last_Symbol(Terminal)-1 loop
if Tokens_On_Line = 4 then
Write(Value (Mixed (Get_Symbol_Name(I))));
Writeln(",");
Write(" ");
Tokens_On_Line := 1;
else
Write(Value (Mixed (Get_Symbol_Name(I))));
Write(", ");
end if;
Tokens_On_Line := Tokens_On_Line + 1;
end loop;
Write(Value (Mixed (Get_Symbol_Name(Last_Symbol(Terminal)))));
Writeln(" );");
Writeln("");
Writeln(" Syntax_Error : exception;");
Writeln("");
Writeln("end " & File_Names.Tokens_Unit_Name & ";");
end Complete_Tokens_Package;
procedure Make_C_Lex_Package is
use Symbol_Table, Text_IO;
The_Define_File : File_Type;
The_Ada_File : File_Type;
type Symbol_Rec is
record
Name : String(1..Source_File.Maximum_Line_Length);
Length : Natural;
end record;
Sym_Name : Symbol_Rec;
function Convert(S : String) return Symbol_Rec is
Result : Symbol_Rec;
begin
Result.Name(1..S'Length) := S;
Result.Length := S'Length;
return Result;
end;
begin
Create(The_Ada_File, Out_File, File_Names.Get_C_Lex_File_Name);
Put_Line(The_Ada_File, "with " & File_Names.Tokens_Unit_Name &
"; use " & File_Names.Tokens_Unit_Name & ";");
Put_Line(The_Ada_File, "package " & File_Names.C_Lex_Unit_Name & " is");
Put_Line(The_Ada_File, " function YYLex return Token;");
Put_Line(The_Ada_File, "end " & File_Names.C_Lex_Unit_Name & ";");
New_Line(The_Ada_File);
New_Line(The_Ada_File);
Put_Line(The_Ada_File, "package body " & File_Names.C_Lex_Unit_Name & " is");
New_Line(The_Ada_File);
Put_Line(The_Ada_File, " function Get_Token return Integer;");
New_Line(The_Ada_File);
Put_Line(The_Ada_File, " pragma Interface(C, Get_Token);");
New_Line(The_Ada_File);
Put_Line(The_Ada_File, " type Table is array(0..255) of Token;");
Put_Line(The_Ada_File, " Literals : constant Table := Table'(");
Put_Line(The_Ada_File, " 0 => End_of_Input,");
Create(The_Define_File, Out_File, File_Names.Get_Include_File_Name);
Put_Line(The_Define_File, "/* C_Lex Token Definition for type " &
File_Names.Tokens_Unit_Name & ".Token; */");
New_Line (The_Define_File);
for I in First_Symbol(Terminal)..Last_Symbol(Terminal) loop
Sym_Name := Convert(Get_Symbol_Name(I));
if Sym_Name.Name(1) /= ''' then
Put(The_Define_File,"#define ");
Put(The_Define_File, Sym_Name.Name(1..Sym_Name.Length));
Put_Line(The_Define_File, " " & Grammar_Symbol'Image(I + 256));
else
Put(The_Ada_File, " " &
Integer'Image(Character'Pos(Sym_Name.Name(2))) & " => ");
Put(The_Ada_File, Sym_Name.Name(1..Sym_Name.Length) & ',');
New_Line(The_Ada_File);
end if;
end loop;
Put_Line(The_Ada_File, " others => Error); ");
New_Line(The_Ada_File);
Put_Line(The_Ada_File, " function YYLex return Token is");
Put_Line(The_Ada_File, " Token_Value : Integer;");
Put_Line(The_Ada_File, " begin");
Put_Line(The_Ada_File, " Token_Value := Get_Token;");
Put_Line(The_Ada_File, " if Token_Value > 255 then");
Put_Line(The_Ada_File, " return Token'Val(Token_Value-256);");
Put_Line(The_Ada_File, " else ");
Put_Line(The_Ada_File, " return Literals(Token_Value); ");
Put_Line(The_Ada_File, " end if; ");
Put_Line(The_Ada_File, " end YYLex; ");
Put_Line(The_Ada_File, "end " & File_Names.C_Lex_Unit_Name & ";");
Close(The_Ada_File);
Close(The_Define_File);
end;
end Tokens_File;
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- The primary authors of ayacc were David Taback and Deepak Tolani.
-- Enhancements were made by Ronald J. Schmalz.
--
-- Send requests for ayacc information to ayacc-info@ics.uci.edu
-- Send bug reports for ayacc to ayacc-bugs@ics.uci.edu
--
-- Redistribution and use in source and binary forms are permitted
-- provided that the above copyright notice and this paragraph are
-- duplicated in all such forms and that any documentation,
-- advertising materials, and other materials related to such
-- distribution and use acknowledge that the software was developed
-- by the University of California, Irvine. The name of the
-- University may not be used to endorse or promote products derived
-- from this software without specific prior written permission.
-- THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
-- IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
-- WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
-- Module : verbose_file.ada
-- Component of : ayacc
-- Version : 1.2
-- Date : 11/21/86 12:38:37
-- SCCS File : disk21~/rschm/hasee/sccs/ayacc/sccs/sxverbose_file.ada
-- $Header: verbose_file.a,v 0.1 86/04/01 15:14:39 ada Exp $
-- $Log: verbose_file.a,v $
-- Revision 0.1 86/04/01 15:14:39 ada
-- This version fixes some minor bugs with empty grammars
-- and $$ expansion. It also uses vads5.1b enhancements
-- such as pragma inline.
--
--
-- Revision 0.0 86/02/19 18:54:29 ada
--
-- These files comprise the initial version of Ayacc
-- designed and implemented by David Taback and Deepak Tolani.
-- Ayacc has been compiled and tested under the Verdix Ada compiler
-- version 4.06 on a vax 11/750 running Unix 4.2BSD.
--
with Symbol_Table, Rule_Table, LR0_Machine;
use Symbol_Table, Rule_Table, LR0_Machine;
package Verbose_File is
procedure Open;
procedure Close;
procedure Write (Ch : in Character);
procedure Write (S : in String);
procedure Write_Line (S : in String := "");
procedure Print_Item (Item_1 : in Item);
procedure Print_Item_Set (Set_1 : in Item_Set);
procedure Print_Grammar_Symbol (Sym: in Grammar_Symbol);
procedure Print_Rule (R : in Rule);
end Verbose_File;
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- The primary authors of ayacc were David Taback and Deepak Tolani.
-- Enhancements were made by Ronald J. Schmalz.
--
-- Send requests for ayacc information to ayacc-info@ics.uci.edu
-- Send bug reports for ayacc to ayacc-bugs@ics.uci.edu
--
-- Redistribution and use in source and binary forms are permitted
-- provided that the above copyright notice and this paragraph are
-- duplicated in all such forms and that any documentation,
-- advertising materials, and other materials related to such
-- distribution and use acknowledge that the software was developed
-- by the University of California, Irvine. The name of the
-- University may not be used to endorse or promote products derived
-- from this software without specific prior written permission.
-- THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
-- IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
-- WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
-- Module : verbose_file_body.ada
-- Component of : ayacc
-- Version : 1.2
-- Date : 11/21/86 12:38:50
-- SCCS File : disk21~/rschm/hasee/sccs/ayacc/sccs/sxverbose_file_body.ada
-- $Header: verbose_file_body.a,v 0.1 86/04/01 15:14:46 ada Exp $
-- $Log: verbose_file_body.a,v $
-- Revision 0.1 86/04/01 15:14:46 ada
-- This version fixes some minor bugs with empty grammars
-- and $$ expansion. It also uses vads5.1b enhancements
-- such as pragma inline.
--
--
-- Revision 0.0 86/02/19 18:54:37 ada
--
-- These files comprise the initial version of Ayacc
-- designed and implemented by David Taback and Deepak Tolani.
-- Ayacc has been compiled and tested under the Verdix Ada compiler
-- version 4.06 on a vax 11/750 running Unix 4.2BSD.
--
with Text_IO, File_Names;
use Text_IO;
package body Verbose_File is
SCCS_ID : constant String := "@(#) verbose_file_body.ada, Version 1.2";
Rcs_ID : constant String := "$Header: verbose_file_body.a,v 0.1 86/04/01 15:14:46 ada Exp $";
V_File : File_Type; -- The verbose file
procedure Open is
use File_Names;
begin
Create(V_File, Out_File, Get_Verbose_File_Name);
end Open;
procedure Close is
begin
Close(V_File);
end Close;
procedure Write(Ch : in Character) is
begin
Put(V_File, Ch);
end Write;
procedure Write(S : in String) is
begin
Put(V_File, S);
end Write;
procedure Write_Line(S : in String := "") is
begin
Put_Line(V_File, S);
end Write_Line;
procedure Print_Grammar_Symbol(Sym: in Grammar_Symbol) is
begin
Put(V_File, Get_Symbol_Name(Sym));
end;
procedure Print_Item(Item_1 : in Item) is
begin
Put(V_File, "(" & Rule'Image(Item_1.Rule_ID) & ") ");
Put(V_File, Get_Symbol_Name(Get_LHS(Item_1.Rule_ID)) & Ascii.Ht & ": ");
if Item_1.Dot_Position = 0 then
Put(V_File, "_ ");
end if;
for I in 1..Length_of(Item_1.Rule_ID) loop
Put(V_File, Get_Symbol_Name(Get_RHS(Item_1.Rule_ID, I)));
Put(V_File, " ");
if I = Item_1.Dot_Position then
Put(V_File, "_ ");
end if;
end loop;
end Print_Item;
procedure Print_Item_Set(Set_1: in Item_Set) is
use Item_Set_Pack;
Iterator : Item_Iterator;
Temp_Item : Item;
begin
Initialize(Iterator, Set_1);
while More(Iterator) loop
Next(Iterator, Temp_Item);
Print_Item(Temp_Item);
New_Line(V_File);
end loop;
end Print_Item_Set;
procedure Print_Rule(R : in Rule) is
begin
Put(V_File, "(" & Rule'Image(R) & ") ");
Put(V_File, Get_Symbol_Name(Get_LHS(R)) & Ascii.Ht & ": ");
for I in 1..Length_of(R) loop
Put(V_File, Get_Symbol_Name(Get_RHS(R, I)));
Put(V_File, " ");
end loop;
end Print_Rule;
end Verbose_File;