DataMuseum.dk

Presents historical artifacts from the history of:

Rational R1000/400 Tapes

This is an automatic "excavation" of a thematic subset of
artifacts from Datamuseum.dk's BitArchive.

See our Wiki for more about Rational R1000/400 Tapes

Excavated with: AutoArchaeologist - Free & Open Source Software.


top - download
Index: ┃ T

⟦82b7c0832⟧ TextFile

    Length: 410339 (0x642e3)
    Types: TextFile
    Names: »TOUT«

Derivation

└─⟦a7d1ea751⟧ Bits:30000550 8mm tape, Rational 1000, !users!projects 94_04_11
    └─ ⟦129cab021⟧ »DATA« 
        └─⟦this⟧ 
└─⟦2f6cfab89⟧ Bits:30000547 8mm tape, Rational 1000, !projects 94-01-04
    └─ ⟦d65440be7⟧ »DATA« 
        └─⟦this⟧ 

TextFile

-- 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;