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

⟦5603bcf64⟧ TextFile

    Length: 367029 (0x599b5)
    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


-- TITLE aflex - main program
--
-- AUTHOR: John Self (UCI)
-- DESCRIPTION main subprogram of aflex, calls the major routines in order
-- $Header: /co/ua/self/arcadia/aflex/ada/src/RCS/aflex.a,v 1.11 90/10/15 20:00:40 self Exp Locker: self $ 
--*************************************************************************** 
--                              aflex
--                          version 1.1c
--***************************************************************************
--
--                            Arcadia Project
--               Department of Information and Computer Science
--                        University of California
--                        Irvine, California 92717
--
--    Send requests for aflex information to alex-info@ics.uci.edu
--
--    Send bug reports for aflex to alex-bugs@ics.uci.edu
--
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- This software was developed by John Self of the Arcadia project
-- at the University of California, Irvine.
--
-- 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.
--
--    This program is based on the flex program written by Vern Paxson.
--
--    The following is the copyright notice from flex, from which aflex is
--    derived.
--	Copyright (c) 1989 The Regents of the University of California.
--	All rights reserved.
--
--	This code is derived from software contributed to Berkeley by
--	Vern Paxson.
--
--      The United States Government has rights in this work pursuant to
--	contract no. DE-AC03-76SF00098 between the United States Department of
--	Energy and the University of California.
--
--	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, Berkeley.  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 MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
--
--***************************************************************************

with MAIN_BODY, DFA, GEN, MISC_DEFS, TEXT_IO, MISC; 
with TSTRING, TEMPLATE_MANAGER, EXTERNAL_FILE_MANAGER; use MISC_DEFS, TEXT_IO, 
  TSTRING, EXTERNAL_FILE_MANAGER; 
function AFLEX return INTEGER is 
	copyright : constant string :=
    "@(#) Copyright (c) 1990 Regents of the University of California.";
    	copyright2 : constant string :=
    "All rights reserved.";
begin
  MAIN_BODY.AFLEXINIT; 

  MAIN_BODY.READIN; 

  if (SYNTAXERROR) then 
    MAIN_BODY.AFLEXEND(1); 
  end if; 

  if (PERFORMANCE_REPORT) then 
    if (INTERACTIVE) then 
      TEXT_IO.PUT_LINE(STANDARD_ERROR, 
        "-I (interactive) entails a minor performance penalty"); 
    end if; 


  end if; 

  if (VARIABLE_TRAILING_CONTEXT_RULES) then 
    MISC.AFLEXERROR("can't handle variable trailing context rules"); 
  end if; 

  -- convert the ndfa to a dfa
  DFA.NTOD; 

  -- generate the Ada state transition tables from the DFA
  GEN.MAKE_TABLES; 

  TEMPLATE_MANAGER.GENERATE_IO_FILE; 
  TEMPLATE_MANAGER.GENERATE_DFA_FILE; 
  MAIN_BODY.AFLEXEND(0); 
  return 0; 
exception
  when MAIN_BODY.AFLEX_TERMINATE => 
    return MAIN_BODY.TERMINATION_STATUS; 
end AFLEX; 
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- This software was developed by John Self of the Arcadia project
-- at the University of California, Irvine.
--
-- 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.

-- TITLE  scanner parser interface
-- AUTHOR: John Self (UCI)
-- DESCRIPTION causes parser to call augmented version of YYLex.
-- $Header: /co/ua/self/arcadia/aflex/ada/src/RCS/aflex_scanner.a,v 1.3 90/01/12 15:19:33 self Exp Locker: self $ 

with PARSE_TOKENS, SCANNER; use PARSE_TOKENS, SCANNER; 

package AFLEX_SCANNER is 
  function YYLEX return TOKEN; 
end AFLEX_SCANNER; 

with PARSE_TOKENS, SCANNER; use PARSE_TOKENS, SCANNER; 

package body AFLEX_SCANNER is 
  function YYLEX return TOKEN is 
  begin
    return SCANNER.GET_TOKEN; 
  end YYLEX; 

end AFLEX_SCANNER; 
-- A lexical scanner generated by aflex
with text_io; use text_io;
with ascan_dfa; use ascan_dfa; 
with ascan_io; use ascan_io; 
--# line 1 "ascan.l"
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- This software was developed by John Self of the Arcadia project
-- at the University of California, Irvine.
--
-- 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.
-- TITLE scanner specification file
-- AUTHOR: John Self (UCI)
-- DESCRIPTION regular expressions and actions matching tokens
--             that aflex expects to find in its input.
-- NOTES input to aflex (NOT alex.)  It uses exclusive start conditions
--       and case insensitive scanner generation available only in aflex
--       (or flex if you use C.)
--       generate scanner using the command 'aflex -is ascan.l'
-- $Header: /dc/uc/self/arcadia/aflex/ada/src/RCS/ascan.l,v 1.19 1991/12/03 23:08:24 self Exp self $ 
--# line 44 "ascan.l"


with misc_defs, misc, sym, parse_tokens, int_io;
with tstring, ascan_dfa, ascan_io, external_file_manager;
use misc_defs, parse_tokens, tstring;
use ascan_dfa, ascan_io, external_file_manager;

package scanner is
    call_yylex : boolean := false;
    function get_token return Token;
end scanner;

package body scanner is

beglin : boolean := false;
i, bracelevel: integer;

function get_token return Token is
    toktype : Token;
    didadef, indented_code : boolean;
    cclval : integer;
    nmdefptr : vstring;
    nmdef, tmpbuf : vstring;

procedure ACTION_ECHO is
begin
    text_io.put( temp_action_file, yytext(1..YYLength) );
end ACTION_ECHO;

procedure MARK_END_OF_PROLOG is
begin
     text_io.put( temp_action_file, "%%%% end of prolog" );
     text_io.new_line( temp_action_file );
end MARK_END_OF_PROLOG;

procedure PUT_BACK_STRING(str : vstring; start : integer) is
begin
	for i in reverse start+1..tstring.len(str) loop
	    unput( CHAR(str,i) );
	end loop;
end PUT_BACK_STRING;

function check_yylex_here return boolean is
begin
	return ( (yytext'length >= 2) and then
			((yytext(1) = '#') and (yytext(2) = '#')));
end check_yylex_here;

function YYLex return Token is
subtype short is integer range -32768..32767;
    yy_act : integer;
    yy_c : short;

-- returned upon end-of-file
YY_END_TOK : constant integer := 0;
YY_END_OF_BUFFER : constant := 82;
subtype yy_state_type is integer;
yy_current_state : yy_state_type;
INITIAL : constant := 0;
SECT2 : constant := 1;
SECT2PROLOG : constant := 2;
SECT3 : constant := 3;
PICKUPDEF : constant := 4;
SC : constant := 5;
CARETISBOL : constant := 6;
NUM : constant := 7;
QUOTE : constant := 8;
FIRSTCCL : constant := 9;
CCL : constant := 10;
ACTION : constant := 11;
RECOVER : constant := 12;
BRACEERROR : constant := 13;
ACTION_STRING : constant := 14;
yy_accept : constant array(0..206) of short :=
    (   0,
        0,    0,    0,    0,    0,    0,   80,   80,    0,    0,
        0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
        0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
       82,   13,    6,   12,   10,    1,   11,   13,   13,   13,
        9,   39,   31,   32,   25,   39,   38,   23,   39,   39,
       39,   31,   21,   39,   39,   24,   81,   19,   80,   80,
       15,   14,   16,   45,   81,   41,   42,   44,   46,   60,
       61,   58,   57,   59,   47,   49,   48,   47,   53,   52,
       53,   53,   55,   55,   55,   56,   66,   71,   70,   72,
       66,   72,   67,   64,   65,   81,   17,   63,   62,   73,

       75,   76,   77,    6,   12,   10,    1,   11,    0,    0,
        2,    0,    7,    4,    5,    0,    9,   31,   32,    0,
       28,    0,    0,    0,   78,   78,   27,   26,   27,    0,
       31,   21,    0,    0,   35,    0,    0,   19,   18,   80,
       80,   15,   14,   43,   44,   57,   79,   79,   50,   51,
       54,   66,    0,   69,    0,   66,   67,    0,   17,   73,
       74,    0,    7,    0,    0,    3,    0,   29,    0,   36,
        0,   78,   27,   27,   37,    0,    0,    0,   35,    0,
       30,   79,   66,   68,    0,    0,    8,    0,    0,    0,
        0,    0,    0,    0,    0,    0,    0,   22,    0,   22,

        0,   22,    4,    0,   34,    0
    ) ;

yy_ec : constant array(CHARACTER'FIRST..CHARACTER'LAST) of short :=
    (   0,
        1,    1,    1,    1,    1,    1,    1,    1,    2,    3,
        1,    4,    1,    1,    1,    1,    1,    1,    1,    1,
        1,    1,    1,    1,    1,    1,    1,    1,    1,    1,
        1,    5,    1,    6,    7,    8,    9,    1,   10,   11,
       11,   11,   11,   12,   13,   11,   14,   15,   15,   15,
       15,   15,   15,   15,   15,   15,   15,    1,    1,   16,
        1,   17,   11,    1,   23,   22,   22,   22,   24,   25,
       22,   22,   22,   22,   22,   22,   22,   22,   26,   22,
       22,   27,   28,   29,   22,   22,   22,   30,   22,   22,
       18,   19,   20,   21,   22,    1,   23,   22,   22,   22,

       24,   25,   22,   22,   22,   22,   22,   22,   22,   22,
       26,   22,   22,   27,   28,   29,   22,   22,   22,   30,
       22,   22,   31,   32,   33,    1,    1
    ) ;

yy_meta : constant array(0..33) of short :=
    (   0,
        1,    2,    3,    2,    2,    4,    1,    1,    1,    5,
        1,    1,    6,    5,    7,    1,    1,    1,    8,    9,
        1,   10,   10,   10,   10,   10,   10,   10,   10,   10,
        5,   11,   12
    ) ;

yy_base : constant array(0..254) of short :=
    (   0,
        0,   29,   58,   89,  503,  499,  498,  305,    4,    8,
      119,  147,  286,  285,   32,   34,   65,   67,   93,   96,
      110,  113,  177,    0,  302,  301,   12,   15,   82,  121,
      303,  880,   76,  880,    0,   37,  880,  299,   11,  288,
        0,  880,   11,  880,  880,   14,  880,  284,  280,  283,
      196,  225,  880,  288,  283,  880,  292,    0,  291,  880,
        0,  133,  880,  880,  880,  880,  272,    0,  880,  880,
      880,  880,  277,  880,  880,  880,  880,  276,  880,  880,
      274,  275,  880,    0,  272,  880,    0,  880,  880,  109,
      273,  880,    0,  880,  880,  282,  880,  880,  880,    0,

      880,  880,    0,  149,  880,    0,  152,  880,  271,  280,
      880,  272,    0,  247,  880,  263,    0,   72,  880,  262,
      880,  240,   63,  119,  880,  248,    0,  880,  245,  249,
      277,  880,  248,  153,    0,  256,  253,    0,  880,  252,
      880,    0,  156,  880,    0,  239,  880,  238,  880,  880,
      880,    0,  221,  880,    0,  309,    0,  249,  880,    0,
      880,  248,    0,  227,  246,  880,  245,  880,  221,  880,
      148,  231,    0,    0,  880,  232,  229,  230,    0,  241,
      880,  226,    0,  880,  236,  234,  880,  209,  210,  197,
      231,  212,  159,  128,  108,  194,  115,  880,  108,  880,

       84,  880,  880,    4,  880,  880,  342,  354,  366,  378,
      390,  402,  414,  426,  438,  450,  462,  474,  486,  493,
      502,  508,  520,  527,  536,  547,  559,  571,  583,  595,
      607,  619,  631,  638,  648,  660,  672,  684,  695,  702,
      712,  724,  736,  748,  760,  772,  784,  795,  807,  819,
      831,  843,  855,  867
    ) ;

yy_def : constant array(0..254) of short :=
    (   0,
      207,  207,  208,  208,  209,  209,  210,  210,  211,  211,
      212,  212,  213,  213,  214,  214,  215,  215,  216,  216,
      217,  217,  206,   23,  218,  218,  213,  213,  219,  219,
      206,  206,  206,  206,  220,  221,  206,  222,  223,  206,
      224,  206,  225,  206,  206,  206,  206,  206,  226,  227,
      228,  229,  206,  206,  206,  206,  230,  231,  232,  206,
      233,  206,  206,  206,  206,  206,  206,  234,  206,  206,
      206,  206,  206,  206,  206,  206,  206,  227,  206,  206,
      235,  236,  206,  237,  227,  206,  238,  206,  206,  239,
      238,  206,  240,  206,  206,  241,  206,  206,  206,  242,

      206,  206,  243,  206,  206,  220,  221,  206,  206,  222,
      206,  206,  244,  206,  206,  245,  224,  225,  206,  246,
      206,  206,  226,  226,  206,  206,  247,  206,  247,  206,
      229,  206,  206,  246,  248,  249,  230,  231,  206,  232,
      206,  233,  206,  206,  234,  206,  206,  206,  206,  206,
      206,  238,  239,  206,  239,  206,  240,  241,  206,  242,
      206,  250,  244,  206,  245,  206,  246,  206,  206,  206,
      226,  206,  247,  129,  206,  206,  249,  246,  248,  249,
      206,  206,  156,  206,  251,  250,  206,  206,  206,  226,
      252,  253,  254,  206,  206,  226,  252,  206,  253,  206,

      254,  206,  206,  206,  206,    0,  206,  206,  206,  206,
      206,  206,  206,  206,  206,  206,  206,  206,  206,  206,
      206,  206,  206,  206,  206,  206,  206,  206,  206,  206,
      206,  206,  206,  206,  206,  206,  206,  206,  206,  206,
      206,  206,  206,  206,  206,  206,  206,  206,  206,  206,
      206,  206,  206,  206
    ) ;

yy_nxt : constant array(0..913) of short :=
    (   0,
      206,   33,   34,   33,   33,   62,   63,   62,   62,   62,
       63,   62,   62,  119,   98,  121,  121,   98,  121,  113,
      205,   35,   35,   35,   35,   35,   35,   35,   35,   35,
       36,   37,   36,   36,   71,   38,   71,   39,  114,  108,
      115,   40,  120,   72,   99,   72,   73,   99,   73,  109,
       41,   41,   41,   41,   41,   41,   41,   41,   41,   43,
       44,   43,   43,   45,   74,   46,   74,   76,   47,   76,
       77,   47,   77,   48,  119,   49,   50,  104,  105,  104,
      104,  124,  170,   78,  101,   78,  202,  102,   51,   47,
       52,   53,   52,   52,   45,   65,   46,   54,   65,   47,

      103,   55,   47,  120,   48,   80,   49,   50,   80,   56,
      200,   81,   65,   82,   81,   65,   82,  198,  154,   51,
       47,   65,   84,  101,  204,   84,  102,  155,   85,   86,
       66,   85,   86,  171,  143,   67,  143,  143,  123,  103,
       68,   68,   68,   68,   68,   68,   68,   68,   68,   65,
      104,  105,  104,  104,  108,  168,  203,  143,   66,  143,
      143,  202,  190,   67,  109,  178,  124,  170,   68,   68,
       68,   68,   68,   68,   68,   68,   68,   87,   87,   88,
       87,   87,   89,   87,   87,   87,   90,   87,   87,   91,
       92,   87,   87,   87,   87,   87,   87,   87,   93,   93,

       93,   93,   93,   93,   93,   93,   93,   94,   87,   95,
      128,  196,  124,  170,  200,  124,  170,  129,  129,  129,
      129,  129,  129,  129,  129,  129,  131,  132,  131,  131,
      154,  181,  168,  198,  195,  194,  187,  133,  184,  155,
      147,  192,  193,  181,  191,  125,  189,  168,  166,  188,
      187,  159,  182,  146,  141,  138,  134,  174,  181,  174,
      177,  176,  172,  169,  168,  166,  174,  174,  174,  174,
      174,  174,  174,  174,  174,  164,  162,  175,  131,  132,
      131,  131,  111,  116,  159,  156,  126,  150,  148,  133,
      126,  146,  144,  141,  138,  136,  135,  126,  124,  122,

      116,  111,  206,   97,   97,   69,   69,   60,  134,  183,
      183,  184,  183,  183,  185,  183,  183,  183,  185,  183,
      183,  183,  185,  183,  183,  183,  183,  183,  183,  183,
      185,  185,  185,  185,  185,  185,  185,  185,  185,  185,
      183,  185,   32,   32,   32,   32,   32,   32,   32,   32,
       32,   32,   32,   32,   42,   42,   42,   42,   42,   42,
       42,   42,   42,   42,   42,   42,   57,   57,   57,   57,
       57,   57,   57,   57,   57,   57,   57,   57,   59,   59,
       59,   59,   59,   59,   59,   59,   59,   59,   59,   59,
       61,   61,   61,   61,   61,   61,   61,   61,   61,   61,

       61,   61,   64,   64,   64,   64,   64,   64,   64,   64,
       64,   64,   64,   64,   65,   65,   65,   65,   65,   65,
       65,   65,   65,   65,   65,   65,   70,   70,   70,   70,
       70,   70,   70,   70,   70,   70,   70,   70,   75,   75,
       75,   75,   75,   75,   75,   75,   75,   75,   75,   75,
       79,   79,   79,   79,   79,   79,   79,   79,   79,   79,
       79,   79,   83,   83,   83,   83,   83,   83,   83,   83,
       83,   83,   83,   83,   96,   96,   96,   96,   96,   96,
       96,   96,   96,   96,   96,   96,  100,  100,  100,  100,
      100,  100,  100,  100,  100,  100,  100,  100,  106,  106,

       60,   58,  106,  107,  107,   58,  206,  107,  110,  110,
      110,  110,  110,  110,  110,  110,  110,  110,  110,  110,
      112,  112,  112,  112,  112,  112,  112,  112,  112,  112,
      112,  112,  117,  117,  206,  206,  117,  118,  118,  206,
      206,  206,  206,  206,  206,  206,  118,  123,  123,  206,
      123,  123,  123,  123,  123,  206,  123,  123,  123,  125,
      125,  206,  125,  125,  125,  125,  125,  125,  125,  125,
      125,  127,  127,  206,  127,  127,  127,  127,  127,  127,
      127,  127,  127,  130,  130,  130,  130,  130,  130,  130,
      130,  130,  130,  130,  130,  137,  137,  137,  137,  137,

      137,  137,  137,  137,  137,  137,  137,  139,  206,  206,
      139,  139,  139,  139,  139,  139,  139,  139,  139,  140,
      140,  140,  140,  140,  140,  140,  140,  140,  140,  140,
      140,  142,  142,  206,  142,  142,  142,  142,  142,  142,
      142,  142,  142,  145,  145,  206,  206,  145,  147,  147,
      206,  147,  147,  147,  147,  147,  147,  147,  147,  147,
      149,  149,  206,  149,  149,  149,  149,  149,  149,  149,
      149,  149,  151,  151,  206,  151,  151,  151,  151,  151,
      206,  151,  151,  151,  152,  152,  206,  206,  206,  152,
      152,  152,  152,  206,  152,  153,  153,  206,  153,  153,

      153,  153,  153,  153,  153,  153,  153,  157,  157,  206,
      206,  157,  158,  158,  158,  158,  158,  158,  158,  158,
      158,  158,  158,  158,  160,  160,  206,  206,  160,  160,
      160,  206,  160,  160,  160,  160,  161,  161,  206,  161,
      161,  161,  161,  161,  161,  161,  161,  161,  163,  163,
      206,  163,  163,  163,  163,  163,  163,  163,  163,  163,
      165,  165,  165,  165,  165,  165,  165,  165,  165,  165,
      165,  165,  167,  167,  167,  167,  167,  167,  167,  167,
      167,  167,  167,  167,  173,  173,  206,  173,  173,  173,
      173,  173,  173,  173,  173,  179,  179,  206,  179,  179,

      179,  179,  179,  179,  179,  179,  179,  180,  180,  180,
      180,  180,  180,  180,  180,  180,  180,  180,  180,  186,
      186,  186,  186,  186,  186,  186,  186,  186,  186,  186,
      186,  185,  185,  185,  185,  185,  185,  185,  185,  185,
      185,  185,  185,  197,  197,  197,  197,  197,  197,  197,
      197,  197,  197,  197,  197,  199,  199,  199,  199,  199,
      199,  199,  199,  199,  199,  199,  199,  201,  201,  201,
      201,  201,  201,  201,  201,  201,  201,  201,  201,   31,
      206,  206,  206,  206,  206,  206,  206,  206,  206,  206,
      206,  206,  206,  206,  206,  206,  206,  206,  206,  206,

      206,  206,  206,  206,  206,  206,  206,  206,  206,  206,
      206,  206,  206
    ) ;

yy_chk : constant array(0..913) of short :=
    (   0,
        0,    1,    1,    1,    1,    9,    9,    9,    9,   10,
       10,   10,   10,   43,   27,   46,   46,   28,   46,   39,
      204,    1,    1,    1,    1,    1,    1,    1,    1,    1,
        2,    2,    2,    2,   15,    2,   16,    2,   39,   36,
       39,    2,   43,   15,   27,   16,   15,   28,   16,   36,
        2,    2,    2,    2,    2,    2,    2,    2,    2,    3,
        3,    3,    3,    3,   15,    3,   16,   17,    3,   18,
       17,    3,   18,    3,  118,    3,    3,   33,   33,   33,
       33,  123,  123,   17,   29,   18,  201,   29,    3,    3,
        4,    4,    4,    4,    4,   19,    4,    4,   20,    4,

       29,    4,    4,  118,    4,   19,    4,    4,   20,    4,
      199,   19,   21,   19,   20,   22,   20,  197,   90,    4,
        4,   11,   21,   30,  195,   22,   30,   90,   21,   21,
       11,   22,   22,  124,   62,   11,   62,   62,  124,   30,
       11,   11,   11,   11,   11,   11,   11,   11,   11,   12,
      104,  104,  104,  104,  107,  134,  194,  143,   12,  143,
      143,  193,  171,   12,  107,  134,  171,  171,   12,   12,
       12,   12,   12,   12,   12,   12,   12,   23,   23,   23,
       23,   23,   23,   23,   23,   23,   23,   23,   23,   23,
       23,   23,   23,   23,   23,   23,   23,   23,   23,   23,

       23,   23,   23,   23,   23,   23,   23,   23,   23,   23,
       51,  190,  196,  196,  192,  190,  190,   51,   51,   51,
       51,   51,   51,   51,   51,   51,   52,   52,   52,   52,
      153,  177,  178,  191,  189,  188,  186,   52,  185,  153,
      182,  177,  178,  180,  176,  172,  169,  167,  165,  164,
      162,  158,  148,  146,  140,  137,   52,  129,  136,  129,
      133,  130,  126,  122,  120,  116,  129,  129,  129,  129,
      129,  129,  129,  129,  129,  114,  112,  129,  131,  131,
      131,  131,  110,  109,   96,   91,   85,   82,   81,  131,
       78,   73,   67,   59,   57,   55,   54,   50,   49,   48,

       40,   38,   31,   26,   25,   14,   13,    8,  131,  156,
      156,  156,  156,  156,  156,  156,  156,  156,  156,  156,
      156,  156,  156,  156,  156,  156,  156,  156,  156,  156,
      156,  156,  156,  156,  156,  156,  156,  156,  156,  156,
      156,  156,  207,  207,  207,  207,  207,  207,  207,  207,
      207,  207,  207,  207,  208,  208,  208,  208,  208,  208,
      208,  208,  208,  208,  208,  208,  209,  209,  209,  209,
      209,  209,  209,  209,  209,  209,  209,  209,  210,  210,
      210,  210,  210,  210,  210,  210,  210,  210,  210,  210,
      211,  211,  211,  211,  211,  211,  211,  211,  211,  211,

      211,  211,  212,  212,  212,  212,  212,  212,  212,  212,
      212,  212,  212,  212,  213,  213,  213,  213,  213,  213,
      213,  213,  213,  213,  213,  213,  214,  214,  214,  214,
      214,  214,  214,  214,  214,  214,  214,  214,  215,  215,
      215,  215,  215,  215,  215,  215,  215,  215,  215,  215,
      216,  216,  216,  216,  216,  216,  216,  216,  216,  216,
      216,  216,  217,  217,  217,  217,  217,  217,  217,  217,
      217,  217,  217,  217,  218,  218,  218,  218,  218,  218,
      218,  218,  218,  218,  218,  218,  219,  219,  219,  219,
      219,  219,  219,  219,  219,  219,  219,  219,  220,  220,

        7,    6,  220,  221,  221,    5,    0,  221,  222,  222,
      222,  222,  222,  222,  222,  222,  222,  222,  222,  222,
      223,  223,  223,  223,  223,  223,  223,  223,  223,  223,
      223,  223,  224,  224,    0,    0,  224,  225,  225,    0,
        0,    0,    0,    0,    0,    0,  225,  226,  226,    0,
      226,  226,  226,  226,  226,    0,  226,  226,  226,  227,
      227,    0,  227,  227,  227,  227,  227,  227,  227,  227,
      227,  228,  228,    0,  228,  228,  228,  228,  228,  228,
      228,  228,  228,  229,  229,  229,  229,  229,  229,  229,
      229,  229,  229,  229,  229,  230,  230,  230,  230,  230,

      230,  230,  230,  230,  230,  230,  230,  231,    0,    0,
      231,  231,  231,  231,  231,  231,  231,  231,  231,  232,
      232,  232,  232,  232,  232,  232,  232,  232,  232,  232,
      232,  233,  233,    0,  233,  233,  233,  233,  233,  233,
      233,  233,  233,  234,  234,    0,    0,  234,  235,  235,
        0,  235,  235,  235,  235,  235,  235,  235,  235,  235,
      236,  236,    0,  236,  236,  236,  236,  236,  236,  236,
      236,  236,  237,  237,    0,  237,  237,  237,  237,  237,
        0,  237,  237,  237,  238,  238,    0,    0,    0,  238,
      238,  238,  238,    0,  238,  239,  239,    0,  239,  239,

      239,  239,  239,  239,  239,  239,  239,  240,  240,    0,
        0,  240,  241,  241,  241,  241,  241,  241,  241,  241,
      241,  241,  241,  241,  242,  242,    0,    0,  242,  242,
      242,    0,  242,  242,  242,  242,  243,  243,    0,  243,
      243,  243,  243,  243,  243,  243,  243,  243,  244,  244,
        0,  244,  244,  244,  244,  244,  244,  244,  244,  244,
      245,  245,  245,  245,  245,  245,  245,  245,  245,  245,
      245,  245,  246,  246,  246,  246,  246,  246,  246,  246,
      246,  246,  246,  246,  247,  247,    0,  247,  247,  247,
      247,  247,  247,  247,  247,  248,  248,    0,  248,  248,

      248,  248,  248,  248,  248,  248,  248,  249,  249,  249,
      249,  249,  249,  249,  249,  249,  249,  249,  249,  250,
      250,  250,  250,  250,  250,  250,  250,  250,  250,  250,
      250,  251,  251,  251,  251,  251,  251,  251,  251,  251,
      251,  251,  251,  252,  252,  252,  252,  252,  252,  252,
      252,  252,  252,  252,  252,  253,  253,  253,  253,  253,
      253,  253,  253,  253,  253,  253,  253,  254,  254,  254,
      254,  254,  254,  254,  254,  254,  254,  254,  254,  206,
      206,  206,  206,  206,  206,  206,  206,  206,  206,  206,
      206,  206,  206,  206,  206,  206,  206,  206,  206,  206,

      206,  206,  206,  206,  206,  206,  206,  206,  206,  206,
      206,  206,  206
    ) ;


-- copy whatever the last rule matched to the standard output

procedure ECHO is
begin
    text_io.put( yytext );
end ECHO;

-- enter a start condition.
-- Using procedure requires a () after the ENTER, but makes everything
-- much neater.

procedure ENTER( state : integer ) is
begin
     yy_start := 1 + 2 * state;
end ENTER;

-- action number for EOF rule of a given start state
function YY_STATE_EOF(state : integer) return integer is
begin
     return YY_END_OF_BUFFER + state + 1;
end YY_STATE_EOF;

-- return all but the first 'n' matched characters back to the input stream
procedure yyless(n : integer) is
begin
        yy_ch_buf(yy_cp) := yy_hold_char; -- undo effects of setting up yytext
        yy_cp := yy_bp + n;
        yy_c_buf_p := yy_cp;
        YY_DO_BEFORE_ACTION; -- set up yytext again
end yyless;

-- redefine this if you have something you want each time.
procedure YY_USER_ACTION is
begin
        null;
end;

-- yy_get_previous_state - get the state just before the EOB char was reached

function yy_get_previous_state return yy_state_type is
    yy_current_state : yy_state_type;
    yy_c : short;
    yy_bp : integer := yytext_ptr;
begin
    yy_current_state := yy_start;
    if ( yy_ch_buf(yy_bp-1) = ASCII.LF ) then
	yy_current_state := yy_current_state + 1;
    end if;

    for yy_cp in yytext_ptr..yy_c_buf_p - 1 loop
	yy_c := yy_ec(yy_ch_buf(yy_cp));
	if ( yy_accept(yy_current_state) /= 0 ) then
	    yy_last_accepting_state := yy_current_state;
	    yy_last_accepting_cpos := yy_cp;
	end if;
	while ( yy_chk(yy_base(yy_current_state) + yy_c) /= yy_current_state ) loop
	    yy_current_state := yy_def(yy_current_state);
	    if ( yy_current_state >= 207 ) then
		yy_c := yy_meta(yy_c);
	    end if;
	end loop;
	yy_current_state := yy_nxt(yy_base(yy_current_state) + yy_c);
    end loop;

    return yy_current_state;
end yy_get_previous_state;

procedure yyrestart( input_file : file_type ) is
begin
   set_input(input_file);
   yy_init := true;
end yyrestart;

begin -- of YYLex
<<new_file>>
        -- this is where we enter upon encountering an end-of-file and
        -- yywrap() indicating that we should continue processing

    if ( yy_init ) then
        if ( yy_start = 0 ) then
            yy_start := 1;      -- first start state
        end if;

        -- we put in the '\n' and start reading from [1] so that an
        -- initial match-at-newline will be true.

        yy_ch_buf(0) := ASCII.LF;
        yy_n_chars := 1;

        -- we always need two end-of-buffer characters.  The first causes
        -- a transition to the end-of-buffer state.  The second causes
        -- a jam in that state.

        yy_ch_buf(yy_n_chars) := YY_END_OF_BUFFER_CHAR;
        yy_ch_buf(yy_n_chars + 1) := YY_END_OF_BUFFER_CHAR;

        yy_eof_has_been_seen := false;

        yytext_ptr := 1;
        yy_c_buf_p := yytext_ptr;
        yy_hold_char := yy_ch_buf(yy_c_buf_p);
        yy_init := false;
    end if; -- yy_init

    loop                -- loops until end-of-file is reached
        yy_cp := yy_c_buf_p;

        -- support of yytext
        yy_ch_buf(yy_cp) := yy_hold_char;

        -- yy_bp points to the position in yy_ch_buf of the start of the
        -- current run.
	yy_bp := yy_cp;
	yy_current_state := yy_start;
	if ( yy_ch_buf(yy_bp-1) = ASCII.LF ) then
	    yy_current_state := yy_current_state + 1;
	end if;
	loop
		yy_c := yy_ec(yy_ch_buf(yy_cp));
		if ( yy_accept(yy_current_state) /= 0 ) then
		    yy_last_accepting_state := yy_current_state;
		    yy_last_accepting_cpos := yy_cp;
		end if;
		while ( yy_chk(yy_base(yy_current_state) + yy_c) /= yy_current_state ) loop
		    yy_current_state := yy_def(yy_current_state);
		    if ( yy_current_state >= 207 ) then
			yy_c := yy_meta(yy_c);
		    end if;
		end loop;
		yy_current_state := yy_nxt(yy_base(yy_current_state) + yy_c);
	    yy_cp := yy_cp + 1;
if ( yy_current_state = 206 ) then
    exit;
end if;
	end loop;
	yy_cp := yy_last_accepting_cpos;
	yy_current_state := yy_last_accepting_state;

<<next_action>>
	    yy_act := yy_accept(yy_current_state);
            YY_DO_BEFORE_ACTION;
            YY_USER_ACTION;

        if aflex_debug then  -- output acceptance info. for (-d) debug mode
            text_io.put( Standard_Error, "--accepting rule #" );
            text_io.put( Standard_Error, INTEGER'IMAGE(yy_act) );
            text_io.put_line( Standard_Error, "(""" & yytext & """)");
        end if;

<<do_action>>   -- this label is used only to access EOF actions
            case yy_act is
		when 0 => -- must backtrack
		-- undo the effects of YY_DO_BEFORE_ACTION
		yy_ch_buf(yy_cp) := yy_hold_char;
		yy_cp := yy_last_accepting_cpos;
		yy_current_state := yy_last_accepting_state;
		goto next_action;



when 1 => 
--# line 46 "ascan.l"
 indented_code := true; 

when 2 => 
--# line 47 "ascan.l"
 linenum := linenum + 1; ECHO;
				-- treat as a comment;
			

when 3 => 
--# line 50 "ascan.l"
 linenum := linenum + 1; ECHO; 

when 4 => 
--# line 51 "ascan.l"
 return ( SCDECL ); 

when 5 => 
--# line 52 "ascan.l"
 return ( XSCDECL ); 

when 6 => 
--# line 54 "ascan.l"
 return ( WHITESPACE ); 

when 7 => 
--# line 56 "ascan.l"

			sectnum := 2;
			misc.line_directive_out;
			ENTER(SECT2PROLOG);
			return ( SECTEND );
			

when 8 => 
--# line 63 "ascan.l"

			text_io.put( Standard_Error, "old-style lex command at line " );
			int_io.put( Standard_Error, linenum );
			text_io.put( Standard_Error, "ignored:" );
			text_io.new_line( Standard_Error );
			text_io.put( Standard_Error, ASCII.HT );
			text_io.put( Standard_Error, yytext(1..YYLength) );
			linenum := linenum + 1;
			

when 9 => 
--# line 73 "ascan.l"

			nmstr := vstr(yytext(1..YYLength));
			didadef := false;
			ENTER(PICKUPDEF);
			

when 10 => 
--# line 79 "ascan.l"
 nmstr := vstr(yytext(1..YYLength));
			  return NAME;
			

when 11 => 
--# line 82 "ascan.l"
 linenum := linenum + 1;
			  -- allows blank lines in section 1;
			

when 12 => 
--# line 85 "ascan.l"
 linenum := linenum + 1; return Newline; 

when 13 => 
--# line 86 "ascan.l"
 misc.synerr( "illegal character" );ENTER(RECOVER);

when 14 => 
--# line 88 "ascan.l"
 null;
			  -- separates name and definition;
			

when 15 => 
--# line 92 "ascan.l"

			nmdef := vstr(yytext(1..YYLength));

			i := tstring.len( nmdef );
			while ( i >= tstring.first ) loop
			    if ( (CHAR(nmdef,i) /= ' ') and
				 (CHAR(nmdef,i) /= ASCII.HT) ) then
				exit;
			    end if;
			    i := i - 1;
			end loop;

                        sym.ndinstal( nmstr,
				tstring.slice(nmdef, tstring.first, i) );
			didadef := true;
			

when 16 => 
--# line 109 "ascan.l"

			if ( not didadef ) then
			    misc.synerr( "incomplete name definition" );
			end if;
			ENTER(0);
			linenum := linenum + 1;
			

when 17 => 
--# line 117 "ascan.l"
 linenum := linenum + 1;
			  ENTER(0);
			  nmstr := vstr(yytext(1..YYLength));
			  return NAME;
			

when 18 => 
yy_ch_buf(yy_cp) := yy_hold_char; -- undo effects of setting up yytext
yy_cp := yy_cp - 1;
yy_c_buf_p := yy_cp;
YY_DO_BEFORE_ACTION; -- set up yytext again
--# line 123 "ascan.l"

			linenum := linenum + 1;
			ACTION_ECHO;
			MARK_END_OF_PROLOG;
			ENTER(SECT2);
			

when 19 => 
--# line 130 "ascan.l"
 linenum := linenum + 1; ACTION_ECHO; 

when YY_END_OF_BUFFER +SECT2PROLOG + 1 
 =>
--# line 132 "ascan.l"
 MARK_END_OF_PROLOG;
			  return End_Of_Input;
			

when 21 => 
--# line 136 "ascan.l"
 linenum := linenum + 1;
			  -- allow blank lines in sect2;

			-- this rule matches indented lines which
			-- are not comments.
when 22 => 
--# line 141 "ascan.l"

			misc.synerr("indented code found outside of action");
			linenum := linenum + 1;
			

when 23 => 
--# line 146 "ascan.l"
 ENTER(SC); return ( '<' ); 

when 24 => 
--# line 147 "ascan.l"
 return ( '^' );  

when 25 => 
--# line 148 "ascan.l"
 ENTER(QUOTE); return ( '"' ); 

when 26 => 
yy_ch_buf(yy_cp) := yy_hold_char; -- undo effects of setting up yytext
 yy_cp := yy_bp + 1;
yy_c_buf_p := yy_cp;
YY_DO_BEFORE_ACTION; -- set up yytext again
--# line 149 "ascan.l"
 ENTER(NUM); return ( '{' ); 

when 27 => 
--# line 150 "ascan.l"
 ENTER(BRACEERROR); 

when 28 => 
yy_ch_buf(yy_cp) := yy_hold_char; -- undo effects of setting up yytext
 yy_cp := yy_bp + 1;
yy_c_buf_p := yy_cp;
YY_DO_BEFORE_ACTION; -- set up yytext again
--# line 151 "ascan.l"
 return ( '$' ); 

when 29 => 
--# line 153 "ascan.l"
 continued_action := true;
			  linenum := linenum + 1;
			  return Newline;
			

when 30 => 
--# line 158 "ascan.l"
 linenum := linenum + 1; ACTION_ECHO; 

when 31 => 
--# line 160 "ascan.l"

			-- this rule is separate from the one below because
			-- otherwise we get variable trailing context, so
			-- we can't build the scanner using -f,F

			bracelevel := 0;
			continued_action := false;
			ENTER(ACTION);
			return Newline;
			

when 32 => 
yy_ch_buf(yy_cp) := yy_hold_char; -- undo effects of setting up yytext
yy_cp := yy_cp - 1;
yy_c_buf_p := yy_cp;
YY_DO_BEFORE_ACTION; -- set up yytext again
--# line 171 "ascan.l"

			bracelevel := 0;
			continued_action := false;
			ENTER(ACTION);
			return Newline;
			

when 33 => 
--# line 178 "ascan.l"
 linenum := linenum + 1; return Newline; 

when 34 => 
--# line 180 "ascan.l"
 return ( EOF_OP ); 

when 35 => 
--# line 182 "ascan.l"

			sectnum := 3;
			ENTER(SECT3);
			return ( End_Of_Input );
			-- to stop the parser
			

when 36 => 
--# line 189 "ascan.l"


			nmstr := vstr(yytext(1..YYLength));

			-- check to see if we've already encountered this ccl
                        cclval := sym.ccllookup( nmstr );
			if ( cclval /= 0 ) then
			    yylval := cclval;
			    cclreuse := cclreuse + 1;
			    return ( PREVCCL );
			else
			    -- we fudge a bit.  We know that this ccl will
			    -- soon be numbered as lastccl + 1 by cclinit
			    sym.cclinstal( nmstr, lastccl + 1 );

			    -- push back everything but the leading bracket
			    -- so the ccl can be rescanned

			    PUT_BACK_STRING(nmstr, 1);

			    ENTER(FIRSTCCL);
			    return ( '[' );
			end if;
			

when 37 => 
--# line 214 "ascan.l"

			nmstr := vstr(yytext(1..YYLength));
			-- chop leading and trailing brace
			tmpbuf := slice(vstr(yytext(1..YYLength)),
								2, YYLength-1);

			nmdefptr := sym.ndlookup( tmpbuf );
			if ( nmdefptr = NUL ) then
			    misc.synerr( "undefined {name}" );
			else
			    -- push back name surrounded by ()'s
			    unput(')');
			    PUT_BACK_STRING(nmdefptr, 0);
			    unput('(');
			end if;
			

when 38 => 
--# line 231 "ascan.l"
 tmpbuf := vstr(yytext(1..YYLength));
			  case tstring.CHAR(tmpbuf,1) is
				when '/' => return '/';
				when '|' => return '|';
				when '*' => return '*';
				when '+' => return '+';
				when '?' => return '?';
				when '.' => return '.';
				when '(' => return '(';
				when ')' => return ')';
				when others =>
					misc.aflexerror("error in aflex case");
			  end case;
			

when 39 => 
--# line 245 "ascan.l"
 tmpbuf := vstr(yytext(1..YYLength));
			  yylval := CHARACTER'POS(CHAR(tmpbuf,1));
			  return CHAR;
			

when 40 => 
--# line 249 "ascan.l"
 linenum := linenum + 1; return Newline; 

when 41 => 
--# line 252 "ascan.l"
 return ( ',' ); 

when 42 => 
--# line 253 "ascan.l"
 ENTER(SECT2); return ( '>' ); 

when 43 => 
yy_ch_buf(yy_cp) := yy_hold_char; -- undo effects of setting up yytext
 yy_cp := yy_bp + 1;
yy_c_buf_p := yy_cp;
YY_DO_BEFORE_ACTION; -- set up yytext again
--# line 254 "ascan.l"
 ENTER(CARETISBOL); return ( '>' ); 

when 44 => 
--# line 255 "ascan.l"
 nmstr := vstr(yytext(1..YYLength));
			  return NAME;
			

when 45 => 
--# line 258 "ascan.l"
 misc.synerr( "bad start condition name" ); 

when 46 => 
--# line 260 "ascan.l"
 ENTER(SECT2); return ( '^' ); 

when 47 => 
--# line 263 "ascan.l"
 tmpbuf := vstr(yytext(1..YYLength));
			  yylval := CHARACTER'POS(CHAR(tmpbuf,1));
			  return CHAR;
			

when 48 => 
--# line 267 "ascan.l"
 ENTER(SECT2); return ( '"' ); 

when 49 => 
--# line 269 "ascan.l"

			misc.synerr( "missing quote" );
			ENTER(SECT2);
			linenum := linenum + 1;
			return ( '"' );
			

when 50 => 
yy_ch_buf(yy_cp) := yy_hold_char; -- undo effects of setting up yytext
 yy_cp := yy_bp + 1;
yy_c_buf_p := yy_cp;
YY_DO_BEFORE_ACTION; -- set up yytext again
--# line 277 "ascan.l"
 ENTER(CCL); return ( '^' ); 

when 51 => 
yy_ch_buf(yy_cp) := yy_hold_char; -- undo effects of setting up yytext
 yy_cp := yy_bp + 1;
yy_c_buf_p := yy_cp;
YY_DO_BEFORE_ACTION; -- set up yytext again
--# line 278 "ascan.l"
 return ( '^' ); 

when 52 => 
--# line 279 "ascan.l"
 ENTER(CCL); yylval := CHARACTER'POS('-'); return ( CHAR ); 

when 53 => 
--# line 280 "ascan.l"
 ENTER(CCL);
			  tmpbuf := vstr(yytext(1..YYLength));
			  yylval := CHARACTER'POS(CHAR(tmpbuf,1));
			  return CHAR;
			

when 54 => 
yy_ch_buf(yy_cp) := yy_hold_char; -- undo effects of setting up yytext
 yy_cp := yy_bp + 1;
yy_c_buf_p := yy_cp;
YY_DO_BEFORE_ACTION; -- set up yytext again
--# line 286 "ascan.l"
 return ( '-' ); 

when 55 => 
--# line 287 "ascan.l"
 tmpbuf := vstr(yytext(1..YYLength));
			  yylval := CHARACTER'POS(CHAR(tmpbuf,1));
			  return CHAR;
			

when 56 => 
--# line 291 "ascan.l"
 ENTER(SECT2); return ( ']' ); 

when 57 => 
--# line 294 "ascan.l"

			yylval := misc.myctoi( vstr(yytext(1..YYLength)) );
			return ( NUMBER );
			

when 58 => 
--# line 299 "ascan.l"
 return ( ',' ); 

when 59 => 
--# line 300 "ascan.l"
 ENTER(SECT2); return ( '}' ); 

when 60 => 
--# line 302 "ascan.l"

			misc.synerr( "bad character inside {}'s" );
			ENTER(SECT2);
			return ( '}' );
			

when 61 => 
--# line 308 "ascan.l"

			misc.synerr( "missing }" );
			ENTER(SECT2);
			linenum := linenum + 1;
			return ( '}' );
			

when 62 => 
--# line 316 "ascan.l"
 misc.synerr( "bad name in {}'s" ); ENTER(SECT2); 

when 63 => 
--# line 317 "ascan.l"
 misc.synerr( "missing }" );
			  linenum := linenum + 1;
			  ENTER(SECT2);
			

when 64 => 
--# line 322 "ascan.l"
 bracelevel := bracelevel + 1; 

when 65 => 
--# line 323 "ascan.l"
 bracelevel := bracelevel - 1; 

when 66 => 
--# line 324 "ascan.l"
 ACTION_ECHO; 

when 67 => 
--# line 325 "ascan.l"
 ACTION_ECHO; 

when 68 => 
--# line 326 "ascan.l"
 linenum := linenum + 1; ACTION_ECHO; 

when 69 => 
--# line 327 "ascan.l"
 ACTION_ECHO;
				  -- character constant;
			

when 70 => 
--# line 331 "ascan.l"
 ACTION_ECHO; ENTER(ACTION_STRING); 

when 71 => 
--# line 333 "ascan.l"

			linenum := linenum + 1;
			ACTION_ECHO;
			if ( bracelevel = 0 ) then
			    text_io.new_line ( temp_action_file );
			    ENTER(SECT2);
	                end if;
			

when 72 => 
--# line 341 "ascan.l"
 ACTION_ECHO; 

when 73 => 
--# line 343 "ascan.l"
 ACTION_ECHO; 

when 74 => 
--# line 344 "ascan.l"
 ACTION_ECHO; 

when 75 => 
--# line 345 "ascan.l"
 linenum := linenum + 1; ACTION_ECHO; 

when 76 => 
--# line 346 "ascan.l"
 ACTION_ECHO; ENTER(ACTION); 

when 77 => 
--# line 347 "ascan.l"
 ACTION_ECHO; 

when 78 => 
--# line 350 "ascan.l"

			yylval := CHARACTER'POS(misc.myesc( vstr(yytext(1..YYLength)) ));
			return ( CHAR );
			

when 79 => 
--# line 355 "ascan.l"

			yylval := CHARACTER'POS(misc.myesc( vstr(yytext(1..YYLength)) ));
			ENTER(CCL);
			return ( CHAR );
			

when 80 => 
--# line 362 "ascan.l"
 if ( check_yylex_here ) then
				return End_Of_Input;
			  else
				ECHO;
			  end if;
			

when 81 => 
--# line 368 "ascan.l"
raise AFLEX_SCANNER_JAMMED;
when YY_END_OF_BUFFER + INITIAL + 1 |
YY_END_OF_BUFFER + SECT2 + 1 |
YY_END_OF_BUFFER + SECT3 + 1 |
YY_END_OF_BUFFER + PICKUPDEF + 1 |
YY_END_OF_BUFFER + SC + 1 |
YY_END_OF_BUFFER + CARETISBOL + 1 |
YY_END_OF_BUFFER + NUM + 1 |
YY_END_OF_BUFFER + QUOTE + 1 |
YY_END_OF_BUFFER + FIRSTCCL + 1 |
YY_END_OF_BUFFER + CCL + 1 |
YY_END_OF_BUFFER + ACTION + 1 |
YY_END_OF_BUFFER + RECOVER + 1 |
YY_END_OF_BUFFER + BRACEERROR + 1 |
YY_END_OF_BUFFER + ACTION_STRING + 1 => 
    return End_Of_Input;
                when YY_END_OF_BUFFER =>
                    -- undo the effects of YY_DO_BEFORE_ACTION
                    yy_ch_buf(yy_cp) := yy_hold_char;

                    yytext_ptr := yy_bp;

                    case yy_get_next_buffer is
                        when EOB_ACT_END_OF_FILE =>
                            begin
                            if ( yywrap ) then
                                -- note: because we've taken care in
                                -- yy_get_next_buffer() to have set up yytext,
                                -- we can now set up yy_c_buf_p so that if some
                                -- total hoser (like aflex itself) wants
                                -- to call the scanner after we return the
                                -- End_Of_Input, it'll still work - another
                                -- End_Of_Input will get returned.

                                yy_c_buf_p := yytext_ptr;

                                yy_act := YY_STATE_EOF((yy_start - 1) / 2);

                                goto do_action;
                            else
                                --  start processing a new file
                                yy_init := true;
                                goto new_file;
                            end if;
                            end;
                        when EOB_ACT_RESTART_SCAN =>
                            yy_c_buf_p := yytext_ptr;
                            yy_hold_char := yy_ch_buf(yy_c_buf_p);
                        when EOB_ACT_LAST_MATCH =>
                            yy_c_buf_p := yy_n_chars;
                            yy_current_state := yy_get_previous_state;

                            yy_cp := yy_c_buf_p;
                            yy_bp := yytext_ptr;
                            goto next_action;
                        when others => null;
                        end case; -- case yy_get_next_buffer()
                when others =>
                    text_io.put( "action # " );
                    text_io.put( INTEGER'IMAGE(yy_act) );
                    text_io.new_line;
                    raise AFLEX_INTERNAL_ERROR;
            end case; -- case (yy_act)
        end loop; -- end of loop waiting for end of file
end YYLex;
--# line 368 "ascan.l"
begin
    if (call_yylex) then
    	toktype := YYLex;
    	call_yylex := false;
    	return toktype;
    end if;

    if ( eofseen ) then
	toktype := End_Of_Input;
    else
	toktype := YYLex;
    end if;
-- this tracing code allows easy tracing of aflex runs
if (trace) then
text_io.new_line(Standard_Error);
text_io.put(Standard_Error, "toktype = :" );
text_io.put(Standard_Error, Token'image(toktype));
text_io.put_line(Standard_Error, ":" );
end if;

    if ( toktype = End_Of_Input ) then
	eofseen := true;

	if ( sectnum = 1 ) then
	    misc.synerr(  "unexpected EOF" );
	    sectnum := 2;
	    toktype := SECTEND;
	else
	    if ( sectnum = 2 ) then
	    	sectnum := 3;
	    	toktype := SECTEND;
	    end if;
    	end if;
    end if;
    
    if ( trace ) then
	if ( beglin ) then
	    int_io.put( Standard_Error, num_rules + 1 );
	    text_io.put( Standard_Error, ASCII.HT );
	    beglin := false;
    	end if;

	case toktype is
	    when '<' | '>'|'^'|'$'|'"'|'['|']'|'{'|'}'|'|'|'('|
    	    	 ')'|'-'|'/'|'?'|'.'|'*'|'+'|',' =>
		text_io.put( Standard_Error, Token'image(toktype) );

	    when NEWLINE =>
		text_io.new_line(Standard_Error);
		if ( sectnum = 2 ) then
		    beglin := true;
    	    	end if;

	    when SCDECL =>
		text_io.put( Standard_Error, "%s" );

	    when XSCDECL =>
   		text_io.put( Standard_Error, "%x" );

	    when WHITESPACE =>
       		text_io.put( Standard_Error, " " );

	    when SECTEND =>
       		text_io.put_line( Standard_Error, "%%" );	   

		-- we set beglin to be true so we'll start
		-- writing out numbers as we echo rules.  aflexscan() has
		-- already assigned sectnum

		if ( sectnum = 2 ) then
		    beglin := true;
    	    	end if;

	    when NAME =>
		text_io.put( Standard_Error, ''' );
		text_io.put( Standard_Error, YYText);
		text_io.put( Standard_Error, ''' );

	    when CHAR =>
	    	if ( (yylval < CHARACTER'POS(' ')) or
		     (yylval = CHARACTER'POS(ASCII.DEL)) ) then
		    text_io.put( Standard_Error, '\' );
		    int_io.put( Standard_Error, yylval );
    		    text_io.put( Standard_Error, '\' );
		else
		    text_io.put( Standard_Error, Token'image(toktype) );
    	    	end if;

	    when NUMBER =>
    	    	int_io.put( Standard_Error, yylval );

	    when PREVCCL =>
		text_io.put( Standard_Error, '[' );
   	    	int_io.put( Standard_Error, yylval );
		text_io.put( Standard_Error, ']' );		

    	    when End_Of_Input =>
    	    	text_io.put( Standard_Error, "End Marker" );

	    when others =>
	    	text_io.put( Standard_Error, "Something weird:" );
		text_io.put_line( Standard_Error, Token'image(toktype));
    	end case;
    end if;
	    
    return toktype;

end get_token;
end scanner;
package ascan_dfa is
aflex_debug : boolean := false;
yytext_ptr : integer; -- points to start of yytext in buffer

-- yy_ch_buf has to be 2 characters longer than YY_BUF_SIZE because we need
-- to put in 2 end-of-buffer characters (this is explained where it is
-- done) at the end of yy_ch_buf
YY_READ_BUF_SIZE : constant integer :=  8192;
YY_BUF_SIZE : constant integer := YY_READ_BUF_SIZE * 2; -- size of input buffer
type unbounded_character_array is array(integer range <>) of character;
subtype ch_buf_type is unbounded_character_array(0..YY_BUF_SIZE + 1);
yy_ch_buf : ch_buf_type;
yy_cp, yy_bp : integer;

-- yy_hold_char holds the character lost when yytext is formed
yy_hold_char : character;
yy_c_buf_p : integer;   -- points to current character in buffer

function YYText return string;
function YYLength return integer;
procedure YY_DO_BEFORE_ACTION;
--These variables are needed between calls to YYLex.
yy_init : boolean := true; -- do we need to initialize YYLex?
yy_start : integer := 0; -- current start state number
subtype yy_state_type is integer;
yy_last_accepting_state : yy_state_type;
yy_last_accepting_cpos : integer;
end ascan_dfa;

with ascan_dfa; use ascan_dfa; 
package body ascan_dfa is
function YYText return string is
    i : integer;
    str_loc : integer := 1;
    buffer : string(1..1024);
    EMPTY_STRING : constant string := "";
begin
    -- find end of buffer
    i := yytext_ptr;
    while ( yy_ch_buf(i) /= ASCII.NUL ) loop
    buffer(str_loc ) := yy_ch_buf(i);
        i := i + 1;
    str_loc := str_loc + 1;
    end loop;
--    return yy_ch_buf(yytext_ptr.. i - 1);

    if (str_loc < 2) then
        return EMPTY_STRING;
    else
      return buffer(1..str_loc-1);
    end if;

end;

-- returns the length of the matched text
function YYLength return integer is
begin
    return yy_cp - yy_bp;
end YYLength;

-- done after the current pattern has been matched and before the
-- corresponding action - sets up yytext

procedure YY_DO_BEFORE_ACTION is
begin
    yytext_ptr := yy_bp;
    yy_hold_char := yy_ch_buf(yy_cp);
    yy_ch_buf(yy_cp) := ASCII.NUL;
    yy_c_buf_p := yy_cp;
end YY_DO_BEFORE_ACTION;

end ascan_dfa;
with ascan_dfa; use ascan_dfa; 
with text_io; use text_io;

package ascan_io is
NULL_IN_INPUT : exception;
AFLEX_INTERNAL_ERROR : exception;
UNEXPECTED_LAST_MATCH : exception;
PUSHBACK_OVERFLOW : exception;
AFLEX_SCANNER_JAMMED : exception;
type eob_action_type is ( EOB_ACT_RESTART_SCAN,
                          EOB_ACT_END_OF_FILE,
                          EOB_ACT_LAST_MATCH );
YY_END_OF_BUFFER_CHAR :  constant character:=  ASCII.NUL;
yy_n_chars : integer;       -- number of characters read into yy_ch_buf

-- true when we've seen an EOF for the current input file
yy_eof_has_been_seen : boolean;

procedure YY_INPUT(buf: out unbounded_character_array; result: out integer; max_size: in integer);
function yy_get_next_buffer return eob_action_type;
procedure yyunput( c : character; yy_bp: in out integer );
procedure unput(c : character);
function input return character;
procedure output(c : character);
function yywrap return boolean;
procedure Open_Input(fname : in String);
procedure Close_Input;
procedure Create_Output(fname : in String := "");
procedure Close_Output;
end ascan_io;

package body ascan_io is
-- gets input and stuffs it into 'buf'.  number of characters read, or YY_NULL,
-- is returned in 'result'.

procedure YY_INPUT(buf: out unbounded_character_array; result: out integer; max_size: in integer) is
    c : character;
    i : integer := 1;
    loc : integer := buf'first;
begin
    while ( i <= max_size ) loop
    if (end_of_line) then -- Ada ate our newline, put it back on the end.
            buf(loc) := ASCII.LF;
            skip_line(1);
        else
            get(buf(loc));
    end if; 
    
        loc := loc + 1;
    i := i + 1;
    end loop;
    
    result := i - 1; 
    exception
        when END_ERROR => result := i - 1;
    -- when we hit EOF we need to set yy_eof_has_been_seen
    yy_eof_has_been_seen := true;
end YY_INPUT;

-- yy_get_next_buffer - try to read in new buffer
--
-- returns a code representing an action
--     EOB_ACT_LAST_MATCH - 
--     EOB_ACT_RESTART_SCAN - restart the scanner
--     EOB_ACT_END_OF_FILE - end of file

function yy_get_next_buffer return eob_action_type is
    dest : integer := 0;
    source : integer := yytext_ptr - 1; -- copy prev. char, too
    number_to_move : integer;
    ret_val : eob_action_type;
    num_to_read : integer;
begin    
    if ( yy_c_buf_p > yy_n_chars + 1 ) then
        raise NULL_IN_INPUT;
    end if;

    -- try to read more data

    -- first move last chars to start of buffer
    number_to_move := yy_c_buf_p - yytext_ptr;

    for i in 0..number_to_move - 1 loop
        yy_ch_buf(dest) := yy_ch_buf(source);
    dest := dest + 1;
    source := source + 1;
    end loop;
        
    if ( yy_eof_has_been_seen ) then
    -- don't do the read, it's not guaranteed to return an EOF,
    -- just force an EOF

    yy_n_chars := 0;
    else
    num_to_read := YY_BUF_SIZE - number_to_move - 1;

    if ( num_to_read > YY_READ_BUF_SIZE ) then
        num_to_read := YY_READ_BUF_SIZE;
        end if;

    -- read in more data
    YY_INPUT( yy_ch_buf(number_to_move..yy_ch_buf'last), yy_n_chars, num_to_read );
    end if;
    if ( yy_n_chars = 0 ) then
    if ( number_to_move = 1 ) then
        ret_val := EOB_ACT_END_OF_FILE;
    else
        ret_val := EOB_ACT_LAST_MATCH;
        end if;

    yy_eof_has_been_seen := true;
    else
    ret_val := EOB_ACT_RESTART_SCAN;
    end if;
    
    yy_n_chars := yy_n_chars + number_to_move;
    yy_ch_buf(yy_n_chars) := YY_END_OF_BUFFER_CHAR;
    yy_ch_buf(yy_n_chars + 1) := YY_END_OF_BUFFER_CHAR;

    -- yytext begins at the second character in
    -- yy_ch_buf; the first character is the one which
    -- preceded it before reading in the latest buffer;
    -- it needs to be kept around in case it's a
    -- newline, so yy_get_previous_state() will have
    -- with '^' rules active

    yytext_ptr := 1;

    return ret_val;
end yy_get_next_buffer;

procedure yyunput( c : character; yy_bp: in out integer ) is
    number_to_move : integer;
    dest : integer;
    source : integer;
    tmp_yy_cp : integer;
begin
    tmp_yy_cp := yy_c_buf_p;
    yy_ch_buf(tmp_yy_cp) := yy_hold_char; -- undo effects of setting up yytext

    if ( tmp_yy_cp < 2 ) then
    -- need to shift things up to make room
    number_to_move := yy_n_chars + 2; -- +2 for EOB chars
    dest := YY_BUF_SIZE + 2;
    source := number_to_move;

    while ( source > 0 ) loop
        dest := dest - 1;
        source := source - 1;
            yy_ch_buf(dest) := yy_ch_buf(source);
    end loop;

    tmp_yy_cp := tmp_yy_cp + dest - source;
    yy_bp := yy_bp + dest - source;
    yy_n_chars := YY_BUF_SIZE;

    if ( tmp_yy_cp < 2 ) then
        raise PUSHBACK_OVERFLOW;
    end if;
    end if;

    if ( tmp_yy_cp > yy_bp and then yy_ch_buf(tmp_yy_cp-1) = ASCII.LF ) then
    yy_ch_buf(tmp_yy_cp-2) := ASCII.LF;
    end if;

    tmp_yy_cp := tmp_yy_cp - 1;
    yy_ch_buf(tmp_yy_cp) := c;

--  Note:  this code is the text of YY_DO_BEFORE_ACTION, only
--         here we get different yy_cp and yy_bp's
    yytext_ptr := yy_bp;
    yy_hold_char := yy_ch_buf(tmp_yy_cp);
    yy_ch_buf(tmp_yy_cp) := ASCII.NUL;
    yy_c_buf_p := tmp_yy_cp;
end yyunput;

procedure unput(c : character) is
begin
     yyunput( c, yy_bp );
end unput;

function input return character is
    c : character;
    yy_cp : integer := yy_c_buf_p;
begin
    yy_ch_buf(yy_cp) := yy_hold_char;

    if ( yy_ch_buf(yy_c_buf_p) = YY_END_OF_BUFFER_CHAR ) then
    -- need more input
    yytext_ptr := yy_c_buf_p;
    yy_c_buf_p := yy_c_buf_p + 1;

    case yy_get_next_buffer is
        -- this code, unfortunately, is somewhat redundant with
        -- that above

        when EOB_ACT_END_OF_FILE =>
        if ( yywrap ) then
            yy_c_buf_p := yytext_ptr;
            return ASCII.NUL;
        end if;

        yy_ch_buf(0) := ASCII.LF;
        yy_n_chars := 1;
        yy_ch_buf(yy_n_chars) := YY_END_OF_BUFFER_CHAR;
        yy_ch_buf(yy_n_chars + 1) := YY_END_OF_BUFFER_CHAR;
        yy_eof_has_been_seen := false;
        yy_c_buf_p := 1;
        yytext_ptr := yy_c_buf_p;
        yy_hold_char := yy_ch_buf(yy_c_buf_p);

        return ( input );
        when EOB_ACT_RESTART_SCAN =>
        yy_c_buf_p := yytext_ptr;

        when EOB_ACT_LAST_MATCH =>
        raise UNEXPECTED_LAST_MATCH;
        when others => null;
        end case;
    end if;

    c := yy_ch_buf(yy_c_buf_p);
    yy_c_buf_p := yy_c_buf_p + 1;
    yy_hold_char := yy_ch_buf(yy_c_buf_p);

    return c;
end input;

procedure output(c : character) is
begin
    text_io.put(c);
end output;

-- default yywrap function - always treat EOF as an EOF
function yywrap return boolean is
begin
    return true;
end yywrap;

procedure Open_Input(fname : in String) is
    f : file_type;
begin
    yy_init := true;
    open(f, in_file, fname);
    set_input(f);
end Open_Input;

procedure Create_Output(fname : in String := "") is
    f : file_type;
begin
    if (fname /= "") then
        create(f, out_file, fname);
        set_output(f);
    end if;
end Create_Output;

procedure Close_Input is
begin
    null;
end Close_Input;

procedure Close_Output is
begin
    null;
end Close_Output;

end ascan_io;
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- This software was developed by John Self of the Arcadia project
-- at the University of California, Irvine.
--
-- 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.

-- TITLE character classes routines
-- AUTHOR: John Self (UCI)
-- DESCRIPTION routines for character classes like [abc]
-- $Header: /co/ua/self/arcadia/aflex/ada/src/RCS/cclB.a,v 1.5 90/01/12 15:19:40 self Exp Locker: self $ 

with MISC_DEFS, TEXT_IO, MISC, TSTRING; use MISC_DEFS, TEXT_IO; 
package body CCL is 

-- ccladd - add a single character to a ccl
  procedure CCLADD(CCLP : in INTEGER; 
                   CH   : in CHARACTER) is 
    IND, LEN, NEWPOS : INTEGER; 
  begin
    LEN := CCLLEN(CCLP); 
    IND := CCLMAP(CCLP); 

    -- check to see if the character is already in the ccl
    for I in 0 .. LEN - 1 loop
      if (CCLTBL(IND + I) = CH) then 
        return; 
      end if; 
    end loop; 

    NEWPOS := IND + LEN; 

    if (NEWPOS >= CURRENT_MAX_CCL_TBL_SIZE) then 
      CURRENT_MAX_CCL_TBL_SIZE := CURRENT_MAX_CCL_TBL_SIZE + 
        MAX_CCL_TBL_SIZE_INCREMENT; 

      NUM_REALLOCS := NUM_REALLOCS + 1; 

      REALLOCATE_CHARACTER_ARRAY(CCLTBL, CURRENT_MAX_CCL_TBL_SIZE); 
    end if; 

    CCLLEN(CCLP) := LEN + 1; 
    CCLTBL(NEWPOS) := CH; 

  end CCLADD; 

  -- cclinit - make an empty ccl

  function CCLINIT return INTEGER is 
  begin
    LASTCCL := LASTCCL + 1; 
    if (LASTCCL >= CURRENT_MAXCCLS) then 
      CURRENT_MAXCCLS := CURRENT_MAXCCLS + MAX_CCLS_INCREMENT; 

      NUM_REALLOCS := NUM_REALLOCS + 1; 

      REALLOCATE_INTEGER_ARRAY(CCLMAP, CURRENT_MAXCCLS); 
      REALLOCATE_INTEGER_ARRAY(CCLLEN, CURRENT_MAXCCLS); 
      REALLOCATE_INTEGER_ARRAY(CCLNG, CURRENT_MAXCCLS); 
    end if; 

    if (LASTCCL = 1) then 

      -- we're making the first ccl
      CCLMAP(LASTCCL) := 0; 

    else 

      -- the new pointer is just past the end of the last ccl.  Since
      -- the cclmap points to the \first/ character of a ccl, adding the
      -- length of the ccl to the cclmap pointer will produce a cursor
      -- to the first free space
      CCLMAP(LASTCCL) := CCLMAP(LASTCCL - 1) + CCLLEN(LASTCCL - 1); 
    end if; 

    CCLLEN(LASTCCL) := 0; 
    CCLNG(LASTCCL) := 0; 

    -- ccl's start out life un-negated
    return LASTCCL; 
  end CCLINIT; 

  -- cclnegate - negate a ccl

  procedure CCLNEGATE(CCLP : in INTEGER) is 
  begin
    CCLNG(CCLP) := 1; 
  end CCLNEGATE; 

  -- list_character_set - list the members of a set of characters in CCL form
  --
  -- writes to the given file a character-class representation of those
  -- characters present in the given set.  A character is present if it
  -- has a non-zero value in the set array.

  procedure LIST_CHARACTER_SET(F    : in FILE_TYPE; 
                               CSET : in C_SIZE_BOOL_ARRAY) is 
    I, START_CHAR : INTEGER; 
  begin
    TEXT_IO.PUT(F, '['); 

    I := 1; 
    while (I <= CSIZE) loop
      if (CSET(I)) then 
        START_CHAR := I; 

        TEXT_IO.PUT(F, ' '); 

        TSTRING.PUT(F, MISC.READABLE_FORM(CHARACTER'VAL(I))); 

        I := I + 1; 
        while ((I <= CSIZE) and then (CSET(I))) loop
          I := I + 1; 
        end loop; 

        if (I - 1 > START_CHAR) then 

          -- this was a run
          TEXT_IO.PUT(F, "-"); 
          TSTRING.PUT(MISC.READABLE_FORM(CHARACTER'VAL(I - 1))); 
        end if; 

        TEXT_IO.PUT(F, ' '); 
      end if; 
      I := I + 1; 
    end loop; 

    TEXT_IO.PUT(F, ']'); 
  end LIST_CHARACTER_SET; 
end CCL; 
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- This software was developed by John Self of the Arcadia project
-- at the University of California, Irvine.
--
-- 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.

-- TITLE character classes routines
-- AUTHOR: John Self (UCI)
-- DESCRIPTION routines for character classes like [abc]
-- $Header: /co/ua/self/arcadia/aflex/ada/src/RCS/cclS.a,v 1.3 90/01/12 15:19:43 self Exp Locker: self $ 

with MISC_DEFS, TEXT_IO; use MISC_DEFS, TEXT_IO; 
package CCL is 
  procedure CCLADD(CCLP : in INTEGER; 
                   CH   : in CHARACTER); 
  function CCLINIT return INTEGER; 
  procedure CCLNEGATE(CCLP : in INTEGER); 
  procedure LIST_CHARACTER_SET(F    : in FILE_TYPE; 
                               CSET : in C_SIZE_BOOL_ARRAY); 
end CCL; 
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- This software was developed by John Self of the Arcadia project
-- at the University of California, Irvine.
--
-- 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.

-- TITLE command line interface
-- AUTHOR: John Self (UCI)
-- DESCRIPTION command line interface body for use with the VERDIX VADS system.
-- NOTES this file is system dependent
-- $Header: /co/ua/self/arcadia/aflex/ada/src/RCS/command_lineB.a,v 1.3 90/01/12 15:19:44 self Exp Locker: self $ 

with TSTRING; use TSTRING; 
with A_STRINGS; use A_STRINGS; 
with COMMAND_LINE; 
package body COMMAND_LINE_INTERFACE is 
  procedure INITIALIZE_COMMAND_LINE is 
  begin
    for I in 0 .. COMMAND_LINE.ARGC - 1 loop
      ARGV(I) := VSTR(COMMAND_LINE.ARGV(I).S); 
    end loop; 
    ARGC := COMMAND_LINE.ARGC; 
  end INITIALIZE_COMMAND_LINE; 
end COMMAND_LINE_INTERFACE; 
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- This software was developed by John Self of the Arcadia project
-- at the University of California, Irvine.
--
-- 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.

-- TITLE command line interface
-- AUTHOR: John Self (UCI)
-- DESCRIPTION command line interface body for use with the VERDIX VADS system.
-- NOTES this file is system dependent
-- $Header: /co/ua/self/arcadia/aflex/ada/src/RCS/command_lineS.a,v 1.3 90/01/12 15:19:46 self Exp Locker: self $ 

with TSTRING; use TSTRING; 
package COMMAND_LINE_INTERFACE is 
  MAX_NUMBER_ARGS : INTEGER := 32; 
  type COMMAND_VECTOR is array(0 .. MAX_NUMBER_ARGS) of VSTRING; 
  procedure INITIALIZE_COMMAND_LINE; 
  ARGV : COMMAND_VECTOR; 
  ARGC : INTEGER; 
end COMMAND_LINE_INTERFACE; 
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- This software was developed by John Self of the Arcadia project
-- at the University of California, Irvine.
--
-- 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.

-- TITLE DFA construction routines
-- AUTHOR: John Self (UCI)
-- DESCRIPTION converts non-deterministic finite automatons to finite ones.
-- $Header: /co/ua/self/arcadia/aflex/ada/src/RCS/dfaB.a,v 1.18 90/01/12 15:19:48 self Exp Locker: self $ 

with DFA, INT_IO, MISC_DEFS, TEXT_IO, MISC, TBLCMP, CCL, EXTERNAL_FILE_MANAGER; 
with ECS, NFA, TSTRING, GEN, SKELETON_MANAGER; use MISC_DEFS, 
  EXTERNAL_FILE_MANAGER; 

package body DFA is 
  use TSTRING; 
  -- check_for_backtracking - check a DFA state for backtracking
  --
  -- ds is the number of the state to check and state[) is its out-transitions,
  -- indexed by equivalence class, and state_rules[) is the set of rules
  -- associated with this state

  DID_STK_INIT : BOOLEAN := FALSE; 
  STK          : INT_PTR; 

  procedure CHECK_FOR_BACKTRACKING(DS    : in INTEGER; 
                                   STATE : in UNBOUNDED_INT_ARRAY) is 
    use MISC_DEFS; 
  begin
    if (DFAACC(DS).DFAACC_STATE = 0) then 

      -- state is non-accepting
      NUM_BACKTRACKING := NUM_BACKTRACKING + 1; 

      if (BACKTRACK_REPORT) then 
        TEXT_IO.PUT(BACKTRACK_FILE, "State #"); 
        INT_IO.PUT(BACKTRACK_FILE, DS, 1); 
        TEXT_IO.PUT(BACKTRACK_FILE, "is non-accepting -"); 
        TEXT_IO.NEW_LINE(BACKTRACK_FILE); 

        -- identify the state
        DUMP_ASSOCIATED_RULES(BACKTRACK_FILE, DS); 

        -- now identify it further using the out- and jam-transitions
        DUMP_TRANSITIONS(BACKTRACK_FILE, STATE); 
        TEXT_IO.NEW_LINE(BACKTRACK_FILE); 
      end if; 
    end if; 
  end CHECK_FOR_BACKTRACKING; 


  -- check_trailing_context - check to see if NFA state set constitutes
  --                          "dangerous" trailing context
  --
  -- NOTES
  --    Trailing context is "dangerous" if both the head and the trailing
  --  part are of variable size \and/ there's a DFA state which contains
  --  both an accepting state for the head part of the rule and NFA states
  --  which occur after the beginning of the trailing context.
  --  When such a rule is matched, it's impossible to tell if having been
  --  in the DFA state indicates the beginning of the trailing context
  --  or further-along scanning of the pattern.  In these cases, a warning
  --  message is issued.
  --
  --    nfa_states[1 .. num_states) is the list of NFA states in the DFA.
  --    accset[1 .. nacc) is the list of accepting numbers for the DFA state.

  procedure CHECK_TRAILING_CONTEXT(NFA_STATES : in INT_PTR; 
                                   NUM_STATES : in INTEGER; 
                                   ACCSET     : in INT_PTR; 
                                   NACC       : in INTEGER) is 
    NS, AR              : INTEGER; 
    STATE_VAR, TYPE_VAR : STATE_ENUM; 

    use MISC_DEFS, MISC, TEXT_IO; 
  begin
    for I in 1 .. NUM_STATES loop
      NS := NFA_STATES(I); 
      TYPE_VAR := STATE_TYPE(NS); 
      AR := ASSOC_RULE(NS); 

      if ((TYPE_VAR = STATE_NORMAL) or (RULE_TYPE(AR) /= RULE_VARIABLE)) then 
        null; 

      -- do nothing
      else 
        if (TYPE_VAR = STATE_TRAILING_CONTEXT) then 

          -- potential trouble.  Scan set of accepting numbers for
          -- the one marking the end of the "head".  We assume that
          -- this looping will be fairly cheap since it's rare that
          -- an accepting number set is large.
          for J in 1 .. NACC loop
            if (CHECK_YY_TRAILING_HEAD_MASK(ACCSET(J)) /= 0) then 
              TEXT_IO.PUT(STANDARD_ERROR, 
                "aflex: Dangerous trailing context in rule at line "); 
              INT_IO.PUT(STANDARD_ERROR, RULE_LINENUM(AR), 1); 
              TEXT_IO.NEW_LINE(STANDARD_ERROR); 
              return; 
            end if; 
          end loop; 
        end if; 
      end if; 
    end loop; 
  end CHECK_TRAILING_CONTEXT; 


  -- dump_associated_rules - list the rules associated with a DFA state
  --
  -- goes through the set of NFA states associated with the DFA and
  -- extracts the first MAX_ASSOC_RULES unique rules, sorts them,
  -- and writes a report to the given file

  procedure DUMP_ASSOCIATED_RULES(F  : in FILE_TYPE; 
                                  DS : in INTEGER) is 
    J                    : INTEGER; 
    NUM_ASSOCIATED_RULES : INTEGER := 0; 
    RULE_SET             : INT_PTR; 
    SIZE, RULE_NUM       : INTEGER; 
  begin
    RULE_SET := new UNBOUNDED_INT_ARRAY(0 .. MAX_ASSOC_RULES + 1); 
    SIZE := DFASIZ(DS); 

    for I in 1 .. SIZE loop
      RULE_NUM := RULE_LINENUM(ASSOC_RULE(DSS(DS)(I))); 

      J := 1; 
      while (J <= NUM_ASSOCIATED_RULES) loop
        if (RULE_NUM = RULE_SET(J)) then 
          exit; 
        end if; 
        J := J + 1; 
      end loop; 
      if (J > NUM_ASSOCIATED_RULES) then 

        --new rule
        if (NUM_ASSOCIATED_RULES < MAX_ASSOC_RULES) then 
          NUM_ASSOCIATED_RULES := NUM_ASSOCIATED_RULES + 1; 
          RULE_SET(NUM_ASSOCIATED_RULES) := RULE_NUM; 
        end if; 
      end if; 
    end loop; 

    MISC.BUBBLE(RULE_SET, NUM_ASSOCIATED_RULES); 

    TEXT_IO.PUT(F, " associated rules:"); 

    for I in 1 .. NUM_ASSOCIATED_RULES loop
      if (I mod 8 = 1) then 
        TEXT_IO.NEW_LINE(F); 
      end if; 

      TEXT_IO.PUT(F, ASCII.HT); 
      INT_IO.PUT(F, RULE_SET(I), 1); 
    end loop; 

    TEXT_IO.NEW_LINE(F); 
  exception
    when STORAGE_ERROR => 
      MISC.AFLEXFATAL("dynamic memory failure in dump_associated_rules()"); 
  end DUMP_ASSOCIATED_RULES; 


  -- dump_transitions - list the transitions associated with a DFA state
  --
  -- goes through the set of out-transitions and lists them in human-readable
  -- form (i.e., not as equivalence classes); also lists jam transitions
  -- (i.e., all those which are not out-transitions, plus EOF).  The dump
  -- is done to the given file.

  procedure DUMP_TRANSITIONS(F     : in FILE_TYPE; 
                             STATE : in UNBOUNDED_INT_ARRAY) is 
    EC           : INTEGER; 
    OUT_CHAR_SET : C_SIZE_BOOL_ARRAY; 
  begin
    for I in 1 .. CSIZE loop
      EC := ECGROUP(I); 

      if (EC < 0) then 
        EC :=  -EC; 
      end if; 

      OUT_CHAR_SET(I) := (STATE(EC) /= 0); 
    end loop; 

    TEXT_IO.PUT(F, " out-transitions: "); 

    CCL.LIST_CHARACTER_SET(F, OUT_CHAR_SET); 

    -- now invert the members of the set to get the jam transitions
    for I in 1 .. CSIZE loop
      OUT_CHAR_SET(I) := not OUT_CHAR_SET(I); 
    end loop; 

    TEXT_IO.NEW_LINE(F); 
    TEXT_IO.PUT(F, "jam-transitions: EOF "); 

    CCL.LIST_CHARACTER_SET(F, OUT_CHAR_SET); 

    TEXT_IO.NEW_LINE(F); 
  end DUMP_TRANSITIONS; 


  -- epsclosure - construct the epsilon closure of a set of ndfa states
  --
  -- NOTES
  --    the epsilon closure is the set of all states reachable by an arbitrary
  --  number of epsilon transitions which themselves do not have epsilon
  --  transitions going out, unioned with the set of states which have non-null
  --  accepting numbers.  t is an array of size numstates of nfa state numbers.
--  Upon return, t holds the epsilon closure and numstates is updated.  accset
  --  holds a list of the accepting numbers, and the size of accset is given
  --  by nacc.  t may be subjected to reallocation if it is not large enough
  --  to hold the epsilon closure.
  --
  --    hashval is the hash value for the dfa corresponding to the state set

  procedure EPSCLOSURE(T                  : in out INT_PTR; 
                       NS_ADDR            : in out INTEGER; 
                       ACCSET             : in out INT_PTR; 
                       NACC_ADDR, HV_ADDR : out INTEGER; 
                       RESULT             : out INT_PTR) is 
    NS, TSP                                      : INTEGER; 
    NUMSTATES, NACC, HASHVAL, TRANSSYM, NFACCNUM : INTEGER; 
    STKEND                                       : INTEGER; 
    STKPOS                                       : INTEGER; 
    procedure MARK_STATE(STATE : in INTEGER) is 
    begin
      TRANS1(STATE) := TRANS1(STATE) - MARKER_DIFFERENCE; 
    end MARK_STATE; 
    pragma INLINE(MARK_STATE); 

    function IS_MARKED(STATE : in INTEGER) return BOOLEAN is 
    begin
      return TRANS1(STATE) < 0; 
    end IS_MARKED; 
    pragma INLINE(IS_MARKED); 

    procedure UNMARK_STATE(STATE : in INTEGER) is 
    begin
      TRANS1(STATE) := TRANS1(STATE) + MARKER_DIFFERENCE; 
    end UNMARK_STATE; 
    pragma INLINE(UNMARK_STATE); 


    procedure CHECK_ACCEPT(STATE : in INTEGER) is 
    begin
      NFACCNUM := ACCPTNUM(STATE); 
      if (NFACCNUM /= NIL) then 
        NACC := NACC + 1; 
        ACCSET(NACC) := NFACCNUM; 
      end if; 
    end CHECK_ACCEPT; 
    pragma INLINE(CHECK_ACCEPT); 

    procedure DO_REALLOCATION is 
    begin
      CURRENT_MAX_DFA_SIZE := CURRENT_MAX_DFA_SIZE + MAX_DFA_SIZE_INCREMENT; 
      NUM_REALLOCS := NUM_REALLOCS + 1; 
      REALLOCATE_INTEGER_ARRAY(T, CURRENT_MAX_DFA_SIZE); 
      REALLOCATE_INTEGER_ARRAY(STK, CURRENT_MAX_DFA_SIZE); 
    end DO_REALLOCATION; 
    pragma INLINE(DO_REALLOCATION); 


    procedure PUT_ON_STACK(STATE : in INTEGER) is 
    begin
      STKEND := STKEND + 1; 
      if (STKEND >= CURRENT_MAX_DFA_SIZE) then 
        DO_REALLOCATION; 
      end if; 
      STK(STKEND) := STATE; 
      MARK_STATE(STATE); 
    end PUT_ON_STACK; 
    pragma INLINE(PUT_ON_STACK); 

    procedure ADD_STATE(STATE : in INTEGER) is 
    begin
      NUMSTATES := NUMSTATES + 1; 
      if (NUMSTATES >= CURRENT_MAX_DFA_SIZE) then 
        DO_REALLOCATION; 
      end if; 
      T(NUMSTATES) := STATE; 
      HASHVAL := HASHVAL + STATE; 
    end ADD_STATE; 
    pragma INLINE(ADD_STATE); 

    procedure STACK_STATE(STATE : in INTEGER) is 
    begin
      PUT_ON_STACK(STATE); 
      CHECK_ACCEPT(STATE); 
      if ((NFACCNUM /= NIL) or (TRANSCHAR(STATE) /= SYM_EPSILON)) then 
        ADD_STATE(STATE); 
      end if; 
    end STACK_STATE; 
    pragma INLINE(STACK_STATE); 

  begin
    NUMSTATES := NS_ADDR; 
    if (not DID_STK_INIT) then 
      STK := ALLOCATE_INTEGER_ARRAY(CURRENT_MAX_DFA_SIZE); 
      DID_STK_INIT := TRUE; 
    end if; 

    NACC := 0; 
    STKEND := 0; 
    HASHVAL := 0; 

    for NSTATE in 1 .. NUMSTATES loop
      NS := T(NSTATE); 

      -- the state could be marked if we've already pushed it onto
      -- the stack
      if (not IS_MARKED(NS)) then 
        PUT_ON_STACK(NS); 
        null; 
      end if; 

      CHECK_ACCEPT(NS); 
      HASHVAL := HASHVAL + NS; 
    end loop; 


    STKPOS := 1; 
    while (STKPOS <= STKEND) loop
      NS := STK(STKPOS); 
      TRANSSYM := TRANSCHAR(NS); 

      if (TRANSSYM = SYM_EPSILON) then 
        TSP := TRANS1(NS) + MARKER_DIFFERENCE; 

        if (TSP /= NO_TRANSITION) then 
          if (not IS_MARKED(TSP)) then 
            STACK_STATE(TSP); 
          end if; 

          TSP := TRANS2(NS); 

          if (TSP /= NO_TRANSITION) then 
            if (not IS_MARKED(TSP)) then 
              STACK_STATE(TSP); 
            end if; 
          end if; 
        end if; 
      end if; 
      STKPOS := STKPOS + 1; 
    end loop; 

    -- clear out "visit" markers
    for CHK_STKPOS in 1 .. STKEND loop
      if (IS_MARKED(STK(CHK_STKPOS))) then 
        UNMARK_STATE(STK(CHK_STKPOS)); 
      else 
        MISC.AFLEXFATAL("consistency check failed in epsclosure()"); 
      end if; 
    end loop; 

    NS_ADDR := NUMSTATES; 
    HV_ADDR := HASHVAL; 
    NACC_ADDR := NACC; 

    RESULT := T; 
  end EPSCLOSURE; 


  -- increase_max_dfas - increase the maximum number of DFAs

  procedure INCREASE_MAX_DFAS is 
  begin
    CURRENT_MAX_DFAS := CURRENT_MAX_DFAS + MAX_DFAS_INCREMENT; 

    NUM_REALLOCS := NUM_REALLOCS + 1; 

    REALLOCATE_INTEGER_ARRAY(BASE, CURRENT_MAX_DFAS); 
    REALLOCATE_INTEGER_ARRAY(DEF, CURRENT_MAX_DFAS); 
    REALLOCATE_INTEGER_ARRAY(DFASIZ, CURRENT_MAX_DFAS); 
    REALLOCATE_INTEGER_ARRAY(ACCSIZ, CURRENT_MAX_DFAS); 
    REALLOCATE_INTEGER_ARRAY(DHASH, CURRENT_MAX_DFAS); 
    REALLOCATE_INT_PTR_ARRAY(DSS, CURRENT_MAX_DFAS); 
    REALLOCATE_DFAACC_UNION(DFAACC, CURRENT_MAX_DFAS); 
  end INCREASE_MAX_DFAS; 


  -- ntod - convert an ndfa to a dfa
  --
  --  creates the dfa corresponding to the ndfa we've constructed.  the
  --  dfa starts out in state #1.

  procedure NTOD is 

    ACCSET                                             : INT_PTR; 
    DS, NACC, NEWDS                                    : INTEGER; 
    DUPLIST, TARGFREQ, TARGSTATE, STATE                : C_SIZE_ARRAY; 
    SYMLIST                                            : C_SIZE_BOOL_ARRAY; 
    HASHVAL, NUMSTATES, DSIZE                          : INTEGER; 
    NSET, DSET                                         : INT_PTR; 
    TARGPTR, TOTALTRANS, I, J, COMSTATE, COMFREQ, TARG : INTEGER; 
    NUM_START_STATES, TODO_HEAD, TODO_NEXT             : INTEGER; 
    SNSRESULT                                          : BOOLEAN; 
    FULL_TABLE_TEMP_FILE                               : FILE_TYPE; 
    BUF                                                : VSTRING; 
    NUM_NXT_STATES                                     : INTEGER; 
    use TEXT_IO; 

    -- this is so find_table_space(...) will know where to start looking in
    -- chk/nxt for unused records for space to put in the state
  begin
    ACCSET := ALLOCATE_INTEGER_ARRAY(NUM_RULES + 1); 
    NSET := ALLOCATE_INTEGER_ARRAY(CURRENT_MAX_DFA_SIZE); 

    -- the "todo" queue is represented by the head, which is the DFA
    -- state currently being processed, and the "next", which is the
    -- next DFA state number available (not in use).  We depend on the
    -- fact that snstods() returns DFA's \in increasing order/, and thus
    -- need only know the bounds of the dfas to be processed.
    TODO_HEAD := 0; 
    TODO_NEXT := 0; 

    for CNT in 0 .. CSIZE loop
      DUPLIST(CNT) := NIL; 
      SYMLIST(CNT) := FALSE; 
    end loop; 

    for CNT in 0 .. NUM_RULES loop
      ACCSET(CNT) := NIL; 
    end loop; 

    if (TRACE) then 
      NFA.DUMPNFA(SCSET(1)); 
      TEXT_IO.NEW_LINE(STANDARD_ERROR); 
      TEXT_IO.NEW_LINE(STANDARD_ERROR); 
      TEXT_IO.PUT(STANDARD_ERROR, "DFA Dump:"); 
      TEXT_IO.NEW_LINE(STANDARD_ERROR); 
      TEXT_IO.NEW_LINE(STANDARD_ERROR); 
    end if; 

    TBLCMP.INITTBL; 

    if (FULLTBL) then 
      GEN.DO_SECT3_OUT; 

      -- output user code up to ##
      SKELETON_MANAGER.SKELOUT; 

      -- declare it "short" because it's a real long-shot that that
      -- won't be large enough
      begin -- make a temporary file to write yy_nxt array into
        CREATE(FULL_TABLE_TEMP_FILE, OUT_FILE); 
      exception
        when USE_ERROR | NAME_ERROR => 
          MISC.AFLEXFATAL("can't create temporary file"); 
      end; 

      NUM_NXT_STATES := 1; 
      TEXT_IO.PUT(FULL_TABLE_TEMP_FILE, "( "); 
      -- generate 0 entries for state #0
      for CNT in 0 .. NUMECS loop
        MISC.MK2DATA(FULL_TABLE_TEMP_FILE, 0); 
      end loop; 

      TEXT_IO.PUT(FULL_TABLE_TEMP_FILE, " )"); 
      -- force extra blank line next dataflush()
      DATALINE := NUMDATALINES; 
    end if; 

    -- create the first states

    NUM_START_STATES := LASTSC*2; 

    for CNT in 1 .. NUM_START_STATES loop
      NUMSTATES := 1; 

      -- for each start condition, make one state for the case when
      -- we're at the beginning of the line (the '%' operator) and
      -- one for the case when we're not

      if (CNT mod 2 = 1) then 
        NSET(NUMSTATES) := SCSET((CNT/2) + 1); 
      else 
        NSET(NUMSTATES) := NFA.MKBRANCH(SCBOL(CNT/2), SCSET(CNT/2)); 
      end if; 

      DFA.EPSCLOSURE(NSET, NUMSTATES, ACCSET, NACC, HASHVAL, NSET); 

      SNSTODS(NSET, NUMSTATES, ACCSET, NACC, HASHVAL, DS, SNSRESULT); 
      if (SNSRESULT) then 
        NUMAS := NUMAS + NACC; 
        TOTNST := TOTNST + NUMSTATES; 
        TODO_NEXT := TODO_NEXT + 1; 

        if (VARIABLE_TRAILING_CONTEXT_RULES and (NACC > 0)) then 
          CHECK_TRAILING_CONTEXT(NSET, NUMSTATES, ACCSET, NACC); 
        end if; 
      end if; 
    end loop; 

    SNSTODS(NSET, 0, ACCSET, 0, 0, END_OF_BUFFER_STATE, SNSRESULT); 
    if (not SNSRESULT) then 
      MISC.AFLEXFATAL("could not create unique end-of-buffer state"); 
    end if; 
    NUMAS := NUMAS + 1; 
    NUM_START_STATES := NUM_START_STATES + 1; 
    TODO_NEXT := TODO_NEXT + 1; 

    while (TODO_HEAD < TODO_NEXT) loop
      NUM_NXT_STATES := NUM_NXT_STATES + 1; 
      TARGPTR := 0; 
      TOTALTRANS := 0; 

      for STATE_CNT in 1 .. NUMECS loop
        STATE(STATE_CNT) := 0; 
      end loop; 

      TODO_HEAD := TODO_HEAD + 1; 
      DS := TODO_HEAD; 

      DSET := DSS(DS); 
      DSIZE := DFASIZ(DS); 

      if (TRACE) then 
        TEXT_IO.PUT(STANDARD_ERROR, "state # "); 
        INT_IO.PUT(STANDARD_ERROR, DS, 1); 
        TEXT_IO.PUT_LINE(STANDARD_ERROR, ":"); 
      end if; 

      SYMPARTITION(DSET, DSIZE, SYMLIST, DUPLIST); 

      for SYM in 1 .. NUMECS loop
        if (SYMLIST(SYM)) then 
          SYMLIST(SYM) := FALSE; 

          if (DUPLIST(SYM) = NIL) then 
          -- symbol has unique out-transitions
            NUMSTATES := SYMFOLLOWSET(DSET, DSIZE, SYM, NSET); 
            DFA.EPSCLOSURE(NSET, NUMSTATES, ACCSET, NACC, HASHVAL, NSET); 

            SNSTODS(NSET, NUMSTATES, ACCSET, NACC, HASHVAL, NEWDS, SNSRESULT); 
            if (SNSRESULT) then 
              TOTNST := TOTNST + NUMSTATES; 
              TODO_NEXT := TODO_NEXT + 1; 
              NUMAS := NUMAS + NACC; 

              if (VARIABLE_TRAILING_CONTEXT_RULES and (NACC > 0)) then 
                CHECK_TRAILING_CONTEXT(NSET, NUMSTATES, ACCSET, NACC); 
              end if; 
            end if; 

            STATE(SYM) := NEWDS; 

            if (TRACE) then 
              TEXT_IO.PUT(STANDARD_ERROR, ASCII.HT); 
              INT_IO.PUT(STANDARD_ERROR, SYM, 1); 
              TEXT_IO.PUT(STANDARD_ERROR, ASCII.HT); 
              INT_IO.PUT(STANDARD_ERROR, NEWDS, 1); 
              TEXT_IO.NEW_LINE(STANDARD_ERROR); 
            end if; 

            TARGPTR := TARGPTR + 1; 
            TARGFREQ(TARGPTR) := 1; 
            TARGSTATE(TARGPTR) := NEWDS; 
            NUMUNIQ := NUMUNIQ + 1; 
          else 
          -- sym's equivalence class has the same transitions
          -- as duplist(sym)'s equivalence class

            TARG := STATE(DUPLIST(SYM)); 
            STATE(SYM) := TARG; 
            if (TRACE) then 
              TEXT_IO.PUT(STANDARD_ERROR, ASCII.HT); 
              INT_IO.PUT(STANDARD_ERROR, SYM, 1); 
              TEXT_IO.PUT(STANDARD_ERROR, ASCII.HT); 
              INT_IO.PUT(STANDARD_ERROR, TARG, 1); 
              TEXT_IO.NEW_LINE(STANDARD_ERROR); 
            end if; 

            -- update frequency count for destination state

            I := 1; 

            while (TARGSTATE(I) /= TARG) loop
              I := I + 1; 
            end loop; 

            TARGFREQ(I) := TARGFREQ(I) + 1; 
            NUMDUP := NUMDUP + 1; 
          end if; 

          TOTALTRANS := TOTALTRANS + 1; 
          DUPLIST(SYM) := NIL; 
        end if; 
      end loop; 

      NUMSNPAIRS := NUMSNPAIRS + TOTALTRANS; 

      if (CASEINS and not USEECS) then 
        I := CHARACTER'POS('A'); 
        J := CHARACTER'POS('a'); 
        while (I < CHARACTER'POS('Z')) loop
          STATE(I) := STATE(J); 
          I := I + 1; 
          J := J + 1; 
        end loop; 
      end if; 

      if (DS > NUM_START_STATES) then 
        CHECK_FOR_BACKTRACKING(DS, STATE); 
      end if; 

      if (FULLTBL) then 
      -- supply array's 0-element
        TEXT_IO.PUT(FULL_TABLE_TEMP_FILE, ","); 
        MISC.DATAFLUSH(FULL_TABLE_TEMP_FILE); 
        TEXT_IO.PUT(FULL_TABLE_TEMP_FILE, "( "); 
        if (DS = END_OF_BUFFER_STATE) then 
          MISC.MK2DATA(FULL_TABLE_TEMP_FILE,  -END_OF_BUFFER_STATE); 
        else 
          MISC.MK2DATA(FULL_TABLE_TEMP_FILE, END_OF_BUFFER_STATE); 
        end if; 

        for CNT in 1 .. NUMECS loop
        -- jams are marked by negative of state number
          if ((STATE(CNT) /= 0)) then 
            MISC.MK2DATA(FULL_TABLE_TEMP_FILE, STATE(CNT)); 
          else 
            MISC.MK2DATA(FULL_TABLE_TEMP_FILE,  -DS); 
          end if; 
        end loop; 

        TEXT_IO.PUT(FULL_TABLE_TEMP_FILE, " )"); 
        -- force extra blank line next dataflush()
        DATALINE := NUMDATALINES; 
      else 
        if (DS = END_OF_BUFFER_STATE) then 
        -- special case this state to make sure it does what it's
        -- supposed to, i.e., jam on end-of-buffer
          TBLCMP.STACK1(DS, 0, 0, JAMSTATE_CONST); 
        else  -- normal, compressed state
        -- determine which destination state is the most common, and
        -- how many transitions to it there are
          COMFREQ := 0; 
          COMSTATE := 0; 

          for CNT in 1 .. TARGPTR loop
            if (TARGFREQ(CNT) > COMFREQ) then 
              COMFREQ := TARGFREQ(CNT); 
              COMSTATE := TARGSTATE(CNT); 
            end if; 
          end loop; 

          TBLCMP.BLDTBL(STATE, DS, TOTALTRANS, COMSTATE, COMFREQ); 
        end if; 
      end if; 
    end loop; 

    if (FULLTBL) then 
      TEXT_IO.PUT("yy_nxt : constant array(0.."); 
      INT_IO.PUT(NUM_NXT_STATES - 1, 1); 
      TEXT_IO.PUT_LINE(" , character'first..character'last) of short :="); 
      TEXT_IO.PUT_LINE("   ("); 

      RESET(FULL_TABLE_TEMP_FILE, IN_FILE); 
      while (not END_OF_FILE(FULL_TABLE_TEMP_FILE)) loop
        TSTRING.GET_LINE(FULL_TABLE_TEMP_FILE, BUF); 
        TSTRING.PUT_LINE(BUF); 
      end loop; 
      DELETE(FULL_TABLE_TEMP_FILE); 

      MISC.DATAEND; 
    else 
      TBLCMP.CMPTMPS;  -- create compressed template entries

      -- create tables for all the states with only one out-transition
      while (ONESP > 0) loop
        TBLCMP.MK1TBL(ONESTATE(ONESP), ONESYM(ONESP), ONENEXT(ONESP), ONEDEF(
          ONESP)); 
        ONESP := ONESP - 1; 
      end loop; 

      TBLCMP.MKDEFTBL; 
    end if; 
  end NTOD; 

  -- snstods - converts a set of ndfa states into a dfa state
  --
  -- on return, the dfa state number is in newds.
  procedure SNSTODS(SNS           : in INT_PTR; 
                    NUMSTATES     : in INTEGER; 
                    ACCSET        : in INT_PTR; 
                    NACC, HASHVAL : in INTEGER; 
                    NEWDS_ADDR    : out INTEGER; 
                    RESULT        : out BOOLEAN) is 
    DIDSORT : BOOLEAN := FALSE; 
    J       : INTEGER; 
    NEWDS   : INTEGER; 
    OLDSNS  : INT_PTR; 
  begin
    for I in 1 .. LASTDFA loop
      if (HASHVAL = DHASH(I)) then 
        if (NUMSTATES = DFASIZ(I)) then 
          OLDSNS := DSS(I); 

          if (not DIDSORT) then 
          -- we sort the states in sns so we can compare it to
          -- oldsns quickly.  we use bubble because there probably
          -- aren't very many states

            MISC.BUBBLE(SNS, NUMSTATES); 
            DIDSORT := TRUE; 
          end if; 

          J := 1; 
          while (J <= NUMSTATES) loop
            if (SNS(J) /= OLDSNS(J)) then 
              exit; 
            end if; 
            J := J + 1; 
          end loop; 

          if (J > NUMSTATES) then 
            DFAEQL := DFAEQL + 1; 
            NEWDS_ADDR := I; 
            RESULT := FALSE; 
            return; 
          end if; 

          HSHCOL := HSHCOL + 1; 
        else 
          HSHSAVE := HSHSAVE + 1; 
        end if; 
      end if; 
    end loop; 
    -- make a new dfa

    LASTDFA := LASTDFA + 1; 
    if (LASTDFA >= CURRENT_MAX_DFAS) then 
      INCREASE_MAX_DFAS; 
    end if; 

    NEWDS := LASTDFA; 

    DSS(NEWDS) := new UNBOUNDED_INT_ARRAY(0 .. NUMSTATES + 1); 

    -- if we haven't already sorted the states in sns, we do so now, so that
    -- future comparisons with it can be made quickly

    if (not DIDSORT) then 
      MISC.BUBBLE(SNS, NUMSTATES); 
    end if; 

    for I in 1 .. NUMSTATES loop
      DSS(NEWDS)(I) := SNS(I); 
    end loop; 

    DFASIZ(NEWDS) := NUMSTATES; 
    DHASH(NEWDS) := HASHVAL; 

    if (NACC = 0) then 
      DFAACC(NEWDS).DFAACC_STATE := 0; 
      ACCSIZ(NEWDS) := 0; 
    else 
    -- find lowest numbered rule so the disambiguating rule will work
      J := NUM_RULES + 1; 

      for I in 1 .. NACC loop
        if (ACCSET(I) < J) then 
          J := ACCSET(I); 
        end if; 
      end loop; 

      DFAACC(NEWDS).DFAACC_STATE := J; 
    end if; 

    NEWDS_ADDR := NEWDS; 
    RESULT := TRUE; 
    return; 

  exception
    when STORAGE_ERROR => 
      MISC.AFLEXFATAL("dynamic memory failure in snstods()"); 
  end SNSTODS; 

  -- symfollowset - follow the symbol transitions one step
  function SYMFOLLOWSET(DS              : in INT_PTR; 
                        DSIZE, TRANSSYM : in INTEGER; 
                        NSET            : in INT_PTR) return INTEGER is 
    NS, TSP, SYM, LENCCL, CH, NUMSTATES, CCLLIST : INTEGER; 
  begin
    NUMSTATES := 0; 

    for I in 1 .. DSIZE loop
    -- for each nfa state ns in the state set of ds
      NS := DS(I); 
      SYM := TRANSCHAR(NS); 
      TSP := TRANS1(NS); 

      if (SYM < 0) then 
      -- it's a character class
        SYM :=  -SYM; 
        CCLLIST := CCLMAP(SYM); 
        LENCCL := CCLLEN(SYM); 

        if (CCLNG(SYM) /= 0) then 
          for J in 0 .. LENCCL - 1 loop
          -- loop through negated character class
            CH := CHARACTER'POS(CCLTBL(CCLLIST + J)); 

            if (CH > TRANSSYM) then 
              exit;  -- transsym isn't in negated ccl
            else 
              if (CH = TRANSSYM) then 
                goto BOTTOM;  -- next 2
              end if; 
            end if; 
          end loop; 

          -- didn't find transsym in ccl
          NUMSTATES := NUMSTATES + 1; 
          NSET(NUMSTATES) := TSP; 
        else 
          for J in 0 .. LENCCL - 1 loop
            CH := CHARACTER'POS(CCLTBL(CCLLIST + J)); 

            if (CH > TRANSSYM) then 
              exit; 
            else 
              if (CH = TRANSSYM) then 
                NUMSTATES := NUMSTATES + 1; 
                NSET(NUMSTATES) := TSP; 
                exit; 
              end if; 
            end if; 
          end loop; 
        end if; 
      else 
        if ((SYM >= CHARACTER'POS('A')) and (SYM <= CHARACTER'POS('Z')) and 
          CASEINS) then 
          MISC.AFLEXFATAL("consistency check failed in symfollowset"); 
        else 
          if (SYM = SYM_EPSILON) then 
            null;  -- do nothing
          else 
            if (ECGROUP(SYM) = TRANSSYM) then 
              NUMSTATES := NUMSTATES + 1; 
              NSET(NUMSTATES) := TSP; 
            end if; 
          end if; 
        end if; 
      end if; 

      <<BOTTOM>> null; 
    end loop; 
    return NUMSTATES; 
  end SYMFOLLOWSET; 

  -- sympartition - partition characters with same out-transitions
  procedure SYMPARTITION(DS        : in INT_PTR; 
                         NUMSTATES : in INTEGER; 
                         SYMLIST   : in out C_SIZE_BOOL_ARRAY; 
                         DUPLIST   : in out C_SIZE_ARRAY) is 
    TCH, J, NS, LENCCL, CCLP, ICH : INTEGER; 
    DUPFWD                        : C_SIZE_ARRAY; 

  -- partitioning is done by creating equivalence classes for those
  -- characters which have out-transitions from the given state.  Thus
  -- we are really creating equivalence classes of equivalence classes.
  begin
    for I in 1 .. NUMECS loop
    -- initialize equivalence class list
      DUPLIST(I) := I - 1; 
      DUPFWD(I) := I + 1; 
    end loop; 

    DUPLIST(1) := NIL; 
    DUPFWD(NUMECS) := NIL; 
    DUPFWD(0) := 0; 

    for I in 1 .. NUMSTATES loop
      NS := DS(I); 
      TCH := TRANSCHAR(NS); 

      if (TCH /= SYM_EPSILON) then 
        if ((TCH <  -LASTCCL) or (TCH > CSIZE)) then 
          MISC.AFLEXFATAL("bad transition character detected in sympartition()")
            ; 
        end if; 

        if (TCH > 0) then 
        -- character transition
          ECS.MKECHAR(ECGROUP(TCH), DUPFWD, DUPLIST); 
          SYMLIST(ECGROUP(TCH)) := TRUE; 
        else 
        -- character class
          TCH :=  -TCH; 

          LENCCL := CCLLEN(TCH); 
          CCLP := CCLMAP(TCH); 
          ECS.MKECCL(CCLTBL(CCLP .. CCLP + LENCCL), LENCCL, DUPFWD, DUPLIST, 
            NUMECS); 

          if (CCLNG(TCH) /= 0) then 
            J := 0; 

            for K in 0 .. LENCCL - 1 loop
              ICH := CHARACTER'POS(CCLTBL(CCLP + K)); 

              J := J + 1; 
              while (J < ICH) loop
                SYMLIST(J) := TRUE; 
                J := J + 1; 
              end loop; 
            end loop; 

            J := J + 1; 
            while (J <= NUMECS) loop
              SYMLIST(J) := TRUE; 
              J := J + 1; 
            end loop; 
          else 
            for K in 0 .. LENCCL - 1 loop
              ICH := CHARACTER'POS(CCLTBL(CCLP + K)); 
              SYMLIST(ICH) := TRUE; 
            end loop; 
          end if; 
        end if; 
      end if; 
    end loop; 
  end SYMPARTITION; 
end DFA; 
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- This software was developed by John Self of the Arcadia project
-- at the University of California, Irvine.
--
-- 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.

-- TITLE DFA construction routines
-- AUTHOR: John Self (UCI)
-- DESCRIPTION converts non-deterministic finite automatons to finite ones.
-- $Header: /co/ua/self/arcadia/aflex/ada/src/RCS/dfaS.a,v 1.4 90/01/12 15:19:52 self Exp Locker: self $ 

with MISC_DEFS; 
with TEXT_IO; 
package DFA is 
  use MISC_DEFS, TEXT_IO; 
  procedure CHECK_FOR_BACKTRACKING(DS    : in INTEGER; 
                                   STATE : in UNBOUNDED_INT_ARRAY); 
  procedure CHECK_TRAILING_CONTEXT(NFA_STATES : in INT_PTR; 
                                   NUM_STATES : in INTEGER; 
                                   ACCSET     : in INT_PTR; 
                                   NACC       : in INTEGER); 

  procedure DUMP_ASSOCIATED_RULES(F  : in FILE_TYPE; 
                                  DS : in INTEGER); 

  procedure DUMP_TRANSITIONS(F     : in FILE_TYPE; 
                             STATE : in UNBOUNDED_INT_ARRAY); 

  procedure EPSCLOSURE(T                  : in out INT_PTR; 
                       NS_ADDR            : in out INTEGER; 
                       ACCSET             : in out INT_PTR; 
                       NACC_ADDR, HV_ADDR : out INTEGER; 
                       RESULT             : out INT_PTR); 

  procedure INCREASE_MAX_DFAS; 

  procedure NTOD; 

  procedure SNSTODS(SNS           : in INT_PTR; 
                    NUMSTATES     : in INTEGER; 
                    ACCSET        : in INT_PTR; 
                    NACC, HASHVAL : in INTEGER; 
                    NEWDS_ADDR    : out INTEGER; 
                    RESULT        : out BOOLEAN); 

  function SYMFOLLOWSET(DS              : in INT_PTR; 
                        DSIZE, TRANSSYM : in INTEGER; 
                        NSET            : in INT_PTR) return INTEGER; 

  procedure SYMPARTITION(DS        : in INT_PTR; 
                         NUMSTATES : in INTEGER; 
                         SYMLIST   : in out C_SIZE_BOOL_ARRAY; 
                         DUPLIST   : in out C_SIZE_ARRAY); 
end DFA; 
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- This software was developed by John Self of the Arcadia project
-- at the University of California, Irvine.
--
-- 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.

-- TITLE equivalence class
-- AUTHOR: John Self (UCI)
-- DESCRIPTION finds equivalence classes so DFA will be smaller
-- $Header: /co/ua/self/arcadia/aflex/ada/src/RCS/ecsB.a,v 1.7 90/01/12 15:19:54 self Exp Locker: self $ 

with MISC_DEFS; 
with MISC; use MISC_DEFS; 
package body ECS is 

-- ccl2ecl - convert character classes to set of equivalence classes

  procedure CCL2ECL is 
    use MISC_DEFS; 
    ICH, NEWLEN, CCLP, CCLMEC : INTEGER; 
  begin
    for I in 1 .. LASTCCL loop

      -- we loop through each character class, and for each character
      -- in the class, add the character's equivalence class to the
      -- new "character" class we are creating.  Thus when we are all
      -- done, character classes will really consist of collections
      -- of equivalence classes
      NEWLEN := 0; 
      CCLP := CCLMAP(I); 

      for CCLS in 0 .. CCLLEN(I) - 1 loop
        ICH := CHARACTER'POS(CCLTBL(CCLP + CCLS)); 
        CCLMEC := ECGROUP(ICH); 
        if (CCLMEC > 0) then 
          CCLTBL(CCLP + NEWLEN) := CHARACTER'VAL(CCLMEC); 
          NEWLEN := NEWLEN + 1; 
        end if; 
      end loop; 

      CCLLEN(I) := NEWLEN; 
    end loop; 
  end CCL2ECL; 


  -- cre8ecs - associate equivalence class numbers with class members
  --  fwd is the forward linked-list of equivalence class members.  bck
  --  is the backward linked-list, and num is the number of class members.
  --  Returned is the number of classes.

  procedure CRE8ECS(FWD, BCK : in out C_SIZE_ARRAY; 
                    NUM      : in INTEGER; 
                    RESULT   : out INTEGER) is 
    J, NUMCL : INTEGER; 
  begin
    NUMCL := 0; 

    -- create equivalence class numbers.  From now on, abs( bck(x) )
    -- is the equivalence class number for object x.  If bck(x)
    -- is positive, then x is the representative of its equivalence
    -- class.
    for I in 1 .. NUM loop
      if (BCK(I) = NIL) then 
        NUMCL := NUMCL + 1; 
        BCK(I) := NUMCL; 
        J := FWD(I); 
        while (J /= NIL) loop
          BCK(J) :=  -NUMCL; 
          J := FWD(J); 
        end loop; 
      end if; 
    end loop; 
    RESULT := NUMCL; 
    return; 
  end CRE8ECS; 


  -- mkeccl - update equivalence classes based on character class xtions
  -- where ccls contains the elements of the character class, lenccl is the
  -- number of elements in the ccl, fwd is the forward link-list of equivalent
  -- characters, bck is the backward link-list, and llsiz size of the link-list

  procedure MKECCL(CCLS     : in out CHAR_ARRAY; 
                   LENCCL   : in INTEGER; 
                   FWD, BCK : in out UNBOUNDED_INT_ARRAY; 
                   LLSIZ    : in INTEGER) is 
    use MISC_DEFS, MISC; 
    CCLP, OLDEC, NEWEC, CCLM, I, J : INTEGER; 
    PROC_ARRAY                     : BOOLEAN_PTR; 
  begin

    -- note that it doesn't matter whether or not the character class is
    -- negated.  The same results will be obtained in either case.
    CCLP := CCLS'FIRST; 

    -- this array tells whether or not a character class has been processed.
    PROC_ARRAY := new BOOLEAN_ARRAY(CCLS'FIRST .. CCLS'LAST); 
    for CCL_INDEX in CCLS'FIRST .. CCLS'LAST loop
      PROC_ARRAY(CCL_INDEX) := FALSE; 
    end loop; 

    while (CCLP < LENCCL + CCLS'FIRST) loop
      CCLM := CHARACTER'POS(CCLS(CCLP)); 
      OLDEC := BCK(CCLM); 
      NEWEC := CCLM; 

      J := CCLP + 1; 

      I := FWD(CCLM); 
      while ((I /= NIL) and (I <= LLSIZ)) loop

        -- look for the symbol in the character class
        while ((J < LENCCL + CCLS'FIRST) and ((CCLS(J) <= CHARACTER'VAL(I)) or 
          PROC_ARRAY(J))) loop
          if (CCLS(J) = CHARACTER'VAL(I)) then 

            -- we found an old companion of cclm in the ccl.
            -- link it into the new equivalence class and flag it as
            -- having been processed
            BCK(I) := NEWEC; 
            FWD(NEWEC) := I; 
            NEWEC := I; 
            PROC_ARRAY(J) := TRUE; 

            -- set flag so we don't reprocess

            -- get next equivalence class member
            -- continue 2
            goto NEXT_PT; 
          end if; 
          J := J + 1; 
        end loop; 

        -- symbol isn't in character class.  Put it in the old equivalence
        -- class
        BCK(I) := OLDEC; 

        if (OLDEC /= NIL) then 
          FWD(OLDEC) := I; 
        end if; 

        OLDEC := I; 
        <<NEXT_PT>> I := FWD(I); 
      end loop; 

      if ((BCK(CCLM) /= NIL) or (OLDEC /= BCK(CCLM))) then 
        BCK(CCLM) := NIL; 
        FWD(OLDEC) := NIL; 
      end if; 

      FWD(NEWEC) := NIL; 

      -- find next ccl member to process
      CCLP := CCLP + 1; 

      while ((CCLP < LENCCL + CCLS'FIRST) and PROC_ARRAY(CCLP)) loop

        -- reset "doesn't need processing" flag
        PROC_ARRAY(CCLP) := FALSE; 
        CCLP := CCLP + 1; 
      end loop; 
    end loop; 
  exception
    when STORAGE_ERROR => 
      MISC.AFLEXFATAL("dynamic memory failure in mkeccl()"); 
  end MKECCL; 


  -- mkechar - create equivalence class for single character

  procedure MKECHAR(TCH      : in INTEGER; 
                    FWD, BCK : in out C_SIZE_ARRAY) is 
  begin

    -- if until now the character has been a proper subset of
    -- an equivalence class, break it away to create a new ec
    if (FWD(TCH) /= NIL) then 
      BCK(FWD(TCH)) := BCK(TCH); 
    end if; 

    if (BCK(TCH) /= NIL) then 
      FWD(BCK(TCH)) := FWD(TCH); 
    end if; 

    FWD(TCH) := NIL; 
    BCK(TCH) := NIL; 
  end MKECHAR; 

end ECS; 
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- This software was developed by John Self of the Arcadia project
-- at the University of California, Irvine.
--
-- 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.

-- TITLE equivalence class
-- AUTHOR: John Self (UCI)
-- DESCRIPTION finds equivalence classes so DFA will be smaller
-- $Header: /co/ua/self/arcadia/aflex/ada/src/RCS/ecsS.a,v 1.4 90/01/12 15:19:57 self Exp Locker: self $ 

with MISC_DEFS; use MISC_DEFS; 
package ECS is 
  procedure CCL2ECL; 
  procedure CRE8ECS(FWD, BCK : in out C_SIZE_ARRAY; 
                    NUM      : in INTEGER; 
                    RESULT   : out INTEGER); 
  procedure MKECCL(CCLS     : in out CHAR_ARRAY; 
                   LENCCL   : in INTEGER; 
                   FWD, BCK : in out UNBOUNDED_INT_ARRAY; 
                   LLSIZ    : in INTEGER); 
  procedure MKECHAR(TCH      : in INTEGER; 
                    FWD, BCK : in out C_SIZE_ARRAY); 
end ECS; 
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- This software was developed by John Self of the Arcadia project
-- at the University of California, Irvine.
--
-- 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.

-- TITLE external_file_manager
-- AUTHOR: John Self (UCI)
-- DESCRIPTION opens external files for other functions
-- NOTES This package opens external files, and thus may be system dependent
--       because of limitations on file names.
--       This version is for the VADS 5.5 Ada development system.
-- $Header: /co/ua/self/arcadia/aflex/ada/src/RCS/file_managerB.a,v 1.5 90/01/12 15:19:58 self Exp Locker: self $ 

with MISC_DEFS, TSTRING, TEXT_IO, MISC; use MISC_DEFS, TSTRING, TEXT_IO, MISC; 

package body EXTERNAL_FILE_MANAGER is 

-- FIX comment about compiler dependent

  subtype SUFFIX_TYPE is STRING(1 .. 1); 

  function ADA_SUFFIX return SUFFIX_TYPE is 
  begin
    return "a"; 
  end ADA_SUFFIX; 

  procedure GET_IO_FILE(F : in out FILE_TYPE) is 
  begin
    if (LEN(INFILENAME) /= 0) then 
      CREATE(F, OUT_FILE, STR(MISC.BASENAME) & "_io." & ADA_SUFFIX); 
    else 
      CREATE(F, OUT_FILE, "aflex_yy_io." & ADA_SUFFIX); 
    end if; 
  exception
    when USE_ERROR | NAME_ERROR => 
      MISC.AFLEXFATAL("could not create IO package file"); 
  end GET_IO_FILE; 

  procedure GET_DFA_FILE(F : in out FILE_TYPE) is 
  begin
    if (LEN(INFILENAME) /= 0) then 
      CREATE(F, OUT_FILE, STR(MISC.BASENAME) & "_dfa." & ADA_SUFFIX); 
    else 
      CREATE(F, OUT_FILE, "aflex_yy_dfa." & ADA_SUFFIX); 
    end if; 
  exception
    when USE_ERROR | NAME_ERROR => 
      MISC.AFLEXFATAL("could not create DFA package file"); 
  end GET_DFA_FILE; 

  procedure GET_SCANNER_FILE(F : in out FILE_TYPE) is 
    OUTFILE_NAME : VSTRING; 
  begin
    if (LEN(INFILENAME) /= 0) then 

      -- give out infile + ada_suffix
      OUTFILE_NAME := MISC.BASENAME & "." & ADA_SUFFIX; 
    else 
      OUTFILE_NAME := VSTR("aflex_yy." & ADA_SUFFIX); 
    end if; 

    CREATE(F, OUT_FILE, STR(OUTFILE_NAME)); 
    SET_OUTPUT(F); 
  exception
    when NAME_ERROR | USE_ERROR => 
      MISC.AFLEXFATAL("can't create scanner file " & OUTFILE_NAME); 
  end GET_SCANNER_FILE; 

  procedure GET_BACKTRACK_FILE(F : in out FILE_TYPE) is 
  begin
    CREATE(F, OUT_FILE, "aflex.backtrack"); 
  exception
    when USE_ERROR | NAME_ERROR => 
      MISC.AFLEXFATAL("could not create backtrack file"); 
  end GET_BACKTRACK_FILE; 

  procedure INITIALIZE_FILES is 
  begin
    null; 

  -- doesn't need to do anything on Verdix
  end INITIALIZE_FILES; 

end EXTERNAL_FILE_MANAGER; 
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- This software was developed by John Self of the Arcadia project
-- at the University of California, Irvine.
--
-- 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.

-- TITLE external_file_manager
-- AUTHOR: John Self (UCI)
-- DESCRIPTION opens external files for other functions
-- NOTES This package opens external files, and thus may be system dependent
--       because of limitations on file names.
--       This version is for the VADS 5.5 Ada development system.
-- $Header: /co/ua/self/arcadia/aflex/ada/src/RCS/file_managerS.a,v 1.4 90/01/12 15:20:00 self Exp Locker: self $ 

with TEXT_IO; use TEXT_IO; 
package EXTERNAL_FILE_MANAGER is 
  procedure GET_IO_FILE(F : in out FILE_TYPE); 
  procedure GET_DFA_FILE(F : in out FILE_TYPE); 
  procedure GET_SCANNER_FILE(F : in out FILE_TYPE); 
  procedure GET_BACKTRACK_FILE(F : in out FILE_TYPE); 
  procedure INITIALIZE_FILES; 
end EXTERNAL_FILE_MANAGER; 
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- This software was developed by John Self of the Arcadia project
-- at the University of California, Irvine.
--
-- 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.

-- TITLE file strings
-- AUTHOR: John Self (UCI)
-- DESCRIPTION used to store lines in the template files
-- NOTES if lines in a template exceed 128 characters we are in trouble
-- $Header: /co/ua/self/arcadia/aflex/ada/src/RCS/file_strings.a,v 1.3 90/01/12 15:20:02 self Exp Locker: self $ 

with VSTRINGS; 
package FILE_STRING is 
  new VSTRINGS(128); 
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- This software was developed by John Self of the Arcadia project
-- at the University of California, Irvine.
--
-- 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.

-- TITLE scanner generation
-- AUTHOR: John Self (UCI)
-- DESCRIPTION
-- NOTES does actual generation (writing) of output aflex scanners
-- $Header: /dc/uc/self/arcadia/aflex/ada/src/RCS/genB.a,v 1.25 1992/10/02 23:08:41 self Exp self $ 

with MISC_DEFS, TEXT_IO, MISC, INT_IO, TSTRING, PARSE_TOKENS; 
with SCANNER, SKELETON_MANAGER, EXTERNAL_FILE_MANAGER; use MISC_DEFS, TEXT_IO, 
  TSTRING, PARSE_TOKENS, EXTERNAL_FILE_MANAGER; 

package body GEN is 
  INDENT_LEVEL : INTEGER := 0;  -- each level is 4 spaces

  MAX_SHORT    : constant INTEGER := 32767; 
  procedure INDENT_UP is 
  begin
    INDENT_LEVEL := INDENT_LEVEL + 1; 
  end INDENT_UP; 
  pragma INLINE(INDENT_UP); 
  procedure INDENT_DOWN is 
  begin
    INDENT_LEVEL := INDENT_LEVEL - 1; 
  end INDENT_DOWN; 
  pragma INLINE(INDENT_DOWN); 

  procedure SET_INDENT(INDENT_VAL : in INTEGER) is 
  begin
    INDENT_LEVEL := INDENT_VAL; 
  end SET_INDENT; 


  -- indent to the current level

  procedure DO_INDENT is 
    I : INTEGER := INDENT_LEVEL*4; 
  begin
    while (I >= 8) loop
      TEXT_IO.PUT(ASCII.HT); 
      I := I - 8; 
    end loop; 

    while (I > 0) loop
      TEXT_IO.PUT(' '); 
      I := I - 1; 
    end loop; 
  end DO_INDENT; 

  -- generate the code to keep backtracking information

  procedure GEN_BACKTRACKING is 
  begin
    if (NUM_BACKTRACKING = 0) then 
      return; 
    end if; 

    INDENT_PUTS("if ( yy_accept(yy_current_state) /= 0 ) then"); 

    INDENT_UP; 
    INDENT_PUTS("yy_last_accepting_state := yy_current_state;"); 
    INDENT_PUTS("yy_last_accepting_cpos := yy_cp;"); 
    INDENT_DOWN; 
    INDENT_PUTS("end if;"); 
  end GEN_BACKTRACKING; 

  -- generate the code to perform the backtrack

  procedure GEN_BT_ACTION is 
  begin
    if (NUM_BACKTRACKING = 0) then 
      return; 
    end if; 

    SET_INDENT(4); 

    INDENT_PUTS("when 0 => -- must backtrack"); 
    INDENT_PUTS("-- undo the effects of YY_DO_BEFORE_ACTION"); 
    INDENT_PUTS("yy_ch_buf(yy_cp) := yy_hold_char;"); 

    if (FULLTBL) then 
      INDENT_PUTS("yy_cp := yy_last_accepting_cpos + 1;"); 
    else 

      -- backtracking info for compressed tables is taken \after/
      -- yy_cp has been incremented for the next state
      INDENT_PUTS("yy_cp := yy_last_accepting_cpos;"); 
    end if; 

    INDENT_PUTS("yy_current_state := yy_last_accepting_state;"); 
    INDENT_PUTS("goto next_action;"); 
    TEXT_IO.NEW_LINE; 

    SET_INDENT(0); 
  end GEN_BT_ACTION; 

  -- generate equivalence-class table

  procedure GENECS is 
    I       : INTEGER; 
    NUMROWS : INTEGER; 
    use TEXT_IO; 
  begin
    TEXT_IO.PUT("yy_ec : constant array(CHARACTER'FIRST.."); 
    TEXT_IO.PUT_LINE("CHARACTER'LAST) of short :="); 
    TEXT_IO.PUT_LINE("    (   0,"); 

    for CHAR_COUNT in 1 .. CSIZE loop
      if (CASEINS and ((CHAR_COUNT >= CHARACTER'POS('A')) and (CHAR_COUNT <= 
        CHARACTER'POS('Z')))) then 
        ECGROUP(CHAR_COUNT) := ECGROUP(MISC.CLOWER(CHAR_COUNT)); 
      end if; 

      ECGROUP(CHAR_COUNT) := abs(ECGROUP(CHAR_COUNT)); 
      MISC.MKDATA(ECGROUP(CHAR_COUNT)); 
    end loop; 

    MISC.DATAEND; 

    if (TRACE) then 
      TEXT_IO.NEW_LINE(STANDARD_ERROR); 
      TEXT_IO.NEW_LINE(STANDARD_ERROR); 
      TEXT_IO.PUT(STANDARD_ERROR, "Equivalence Classes:"); 
      TEXT_IO.NEW_LINE(STANDARD_ERROR); 
      TEXT_IO.NEW_LINE(STANDARD_ERROR); 
      NUMROWS := (CSIZE + 1)/8; 

      for J in 1 .. NUMROWS loop
        I := J; 
        while (I <= CSIZE) loop
          TSTRING.PUT(STANDARD_ERROR, MISC.READABLE_FORM(CHARACTER'VAL(I))); 
          TEXT_IO.PUT(STANDARD_ERROR, " = "); 
          INT_IO.PUT(STANDARD_ERROR, ECGROUP(I), 1); 
          TEXT_IO.PUT(STANDARD_ERROR, "   "); 
          I := I + NUMROWS; 
        end loop; 
        TEXT_IO.NEW_LINE(STANDARD_ERROR); 
      end loop; 
    end if; 
  end GENECS; 

  -- generate the code to find the action number

  procedure GEN_FIND_ACTION is 
  begin
    INDENT_PUTS("yy_act := yy_accept(yy_current_state);"); 
  end GEN_FIND_ACTION; 

  -- genftbl - generates full transition table

  procedure GENFTBL is 
    END_OF_BUFFER_ACTION : INTEGER := NUM_RULES + 1; 
    -- *everything* is done in terms of arrays starting at 1, so provide
    -- a null entry for the zero element of all C arrays
    use TEXT_IO; 
  begin
    TEXT_IO.PUT("yy_accept : constant array(0.."); 
    INT_IO.PUT(LASTDFA, 1); 
    TEXT_IO.PUT_LINE(") of short :="); 
    TEXT_IO.PUT_LINE("    (   0,"); 

    DFAACC(END_OF_BUFFER_STATE).DFAACC_STATE := END_OF_BUFFER_ACTION; 

    for I in 1 .. LASTDFA loop
      declare
        ANUM : INTEGER := DFAACC(I).DFAACC_STATE; 
      begin
        MISC.MKDATA(ANUM); 

        if (TRACE and (ANUM /= 0)) then 
          TEXT_IO.PUT(STANDARD_ERROR, "state # "); 
          INT_IO.PUT(STANDARD_ERROR, I, 1); 
          TEXT_IO.PUT(STANDARD_ERROR, " accepts: ["); 
          INT_IO.PUT(STANDARD_ERROR, ANUM, 1); 
          TEXT_IO.PUT(STANDARD_ERROR, "]"); 
          TEXT_IO.NEW_LINE(STANDARD_ERROR); 
        end if; 
      end; 
    end loop; 

    MISC.DATAEND; 

    if (USEECS) then 
      GENECS; 
    end if; 

  -- don't have to dump the actual full table entries - they were created
  -- on-the-fly
  end GENFTBL; 

  -- generate the code to find the next compressed-table state

  procedure GEN_NEXT_COMPRESSED_STATE is 
  begin
    if (USEECS) then 
      INDENT_PUTS("yy_c := yy_ec(yy_ch_buf(yy_cp));"); 
    else 
      INDENT_PUTS("yy_c := yy_ch_buf(yy_cp);"); 
    end if; 

    -- save the backtracking info \before/ computing the next state
    -- because we always compute one more state than needed - we
    -- always proceed until we reach a jam state
    GEN_BACKTRACKING; 

    INDENT_PUTS(
      "while ( yy_chk(yy_base(yy_current_state) + yy_c) /= yy_current_state ) loop"
      ); 
    INDENT_UP; 
    INDENT_PUTS("yy_current_state := yy_def(yy_current_state);"); 

    if (USEMECS) then 

      -- we've arrange it so that templates are never chained
      -- to one another.  This means we can afford make a
      -- very simple test to see if we need to convert to
      -- yy_c's meta-equivalence class without worrying
      -- about erroneously looking up the meta-equivalence
      -- class twice
      DO_INDENT; 

      -- lastdfa + 2 is the beginning of the templates
      TEXT_IO.PUT("if ( yy_current_state >= "); 
      INT_IO.PUT(LASTDFA + 2, 1); 
      TEXT_IO.PUT_LINE(" ) then"); 

      INDENT_UP; 
      INDENT_PUTS("yy_c := yy_meta(yy_c);"); 
      INDENT_DOWN; 
      INDENT_PUTS("end if;"); 
    end if; 

    INDENT_DOWN; 
    INDENT_PUTS("end loop;"); 

    INDENT_PUTS("yy_current_state := yy_nxt(yy_base(yy_current_state) + yy_c);")
      ; 
    INDENT_DOWN; 
  end GEN_NEXT_COMPRESSED_STATE; 

  -- generate the code to find the next match

  procedure GEN_NEXT_MATCH is 
  -- note - changes in here should be reflected in get_next_state
  begin
    if (FULLTBL) then 
      INDENT_PUTS(
        "yy_current_state := yy_nxt(yy_current_state, yy_ch_buf(yy_cp));"); 
      INDENT_PUTS("while ( yy_current_state > 0 ) loop"); 
      INDENT_UP; 
      INDENT_PUTS("yy_cp := yy_cp + 1;"); 
      INDENT_PUTS(
        "yy_current_state := yy_nxt(yy_current_state, yy_ch_buf(yy_cp));"); 
      INDENT_DOWN; 
      INDENT_PUTS("end loop;"); 

      if (NUM_BACKTRACKING > 0) then 
        GEN_BACKTRACKING; 
        TEXT_IO.NEW_LINE; 
      end if; 

      TEXT_IO.NEW_LINE; 
      INDENT_PUTS("yy_current_state := -yy_current_state;"); 
    else 

      -- compressed
      INDENT_PUTS("loop"); 

      INDENT_UP; 

      GEN_NEXT_STATE; 

      INDENT_PUTS("yy_cp := yy_cp + 1;"); 

      if (INTERACTIVE) then
        TEXT_IO.PUT("if ( yy_base(yy_current_state) = ");
        INT_IO.PUT(JAMBASE, 1);
      else
        TEXT_IO.PUT("if ( yy_current_state = "); 
        INT_IO.PUT(JAMSTATE, 1); 
      end if;
      
      TEXT_IO.PUT_LINE(" ) then"); 
      TEXT_IO.PUT_LINE("    exit;"); 
      TEXT_IO.PUT_LINE("end if;"); 

      INDENT_DOWN; 

      DO_INDENT; 

      TEXT_IO.PUT_LINE("end loop;"); 

      if (not INTERACTIVE) then
        INDENT_PUTS("yy_cp := yy_last_accepting_cpos;"); 
        INDENT_PUTS("yy_current_state := yy_last_accepting_state;"); 
      end if;
    end if; 
  end GEN_NEXT_MATCH; 

  -- generate the code to find the next state

  procedure GEN_NEXT_STATE is 
  -- note - changes in here should be reflected in get_next_match
  begin
    INDENT_UP; 
    if (FULLTBL) then 
      INDENT_PUTS("yy_current_state := yy_nxt(yy_current_state,"); 
      INDENT_PUTS("                    yy_ch_buf(yy_cp));"); 
      GEN_BACKTRACKING; 
    else 
      GEN_NEXT_COMPRESSED_STATE; 
    end if; 
  end GEN_NEXT_STATE; 

  -- generate the code to find the start state

  procedure GEN_START_STATE is 
  begin
    INDENT_PUTS("yy_current_state := yy_start;"); 

    if (BOL_NEEDED) then 
      INDENT_PUTS("if ( yy_ch_buf(yy_bp-1) = ASCII.LF ) then"); 
      INDENT_UP; 
      INDENT_PUTS("yy_current_state := yy_current_state + 1;"); 
      INDENT_DOWN; 
      INDENT_PUTS("end if;"); 
    end if; 

  end GEN_START_STATE; 

  -- gentabs - generate data statements for the transition tables

  procedure GENTABS is 
    I, J, K, NACC, TOTAL_STATES : INTEGER; 
    ACCSET, ACC_ARRAY           : INT_PTR; 
    ACCNUM                      : INTEGER; 
    END_OF_BUFFER_ACTION        : INTEGER := NUM_RULES + 1; 
    -- *everything* is done in terms of arrays starting at 1, so provide
    -- a null entry for the zero element of all C arrays

    C_LONG_DECL                 : STRING(1 .. 44) := 
      "static const long int %s[%d] =\n    {   0,\n"; 
    C_SHORT_DECL                : STRING(1 .. 45) := 
      "static const short int %s[%d] =\n    {   0,\n"; 
    C_CHAR_DECL                 : STRING(1 .. 40) := 
      "static const char %s[%d] =\n    {   0,\n"; 
  begin
    ACC_ARRAY := ALLOCATE_INTEGER_ARRAY(CURRENT_MAX_DFAS); 
    NUMMT := 0; 

    -- the compressed table format jams by entering the "jam state",
    -- losing information about the previous state in the process.
    -- In order to recover the previous state, we effectively need
    -- to keep backtracking information.
    NUM_BACKTRACKING := NUM_BACKTRACKING + 1; 

    DFAACC(END_OF_BUFFER_STATE).DFAACC_STATE := END_OF_BUFFER_ACTION; 

    for CNT in 1 .. LASTDFA loop
      ACC_ARRAY(CNT) := DFAACC(CNT).DFAACC_STATE; 
    end loop; 


    ACC_ARRAY(LASTDFA + 1) := 0; 

    -- add accepting number for the jam state

    -- spit out ALIST array, dumping the accepting numbers.

    -- "lastdfa + 2" is the size of ALIST; includes room for arrays
    -- beginning at 0 and for "jam" state
    K := LASTDFA + 2; 

    TEXT_IO.PUT("yy_accept : constant array(0.."); 
    INT_IO.PUT(K - 1, 1); 
    TEXT_IO.PUT_LINE(") of short :="); 
    TEXT_IO.PUT_LINE("    (   0,"); 
    for CNT in 1 .. LASTDFA loop
      MISC.MKDATA(ACC_ARRAY(CNT)); 

      if (TRACE and (ACC_ARRAY(CNT) /= 0)) then 
        TEXT_IO.PUT(STANDARD_ERROR, "state # "); 
        INT_IO.PUT(STANDARD_ERROR, CNT, 1); 
        TEXT_IO.PUT(STANDARD_ERROR, " accepts: ["); 
        INT_IO.PUT(STANDARD_ERROR, ACC_ARRAY(CNT), 1); 
        TEXT_IO.PUT(STANDARD_ERROR, ']'); 
        TEXT_IO.NEW_LINE(STANDARD_ERROR); 
      end if; 
    end loop; 

    -- add entry for "jam" state
    MISC.MKDATA(ACC_ARRAY(LASTDFA + 1)); 

    MISC.DATAEND; 

    if (USEECS) then 
      GENECS; 
    end if; 

    if (USEMECS) then 

      -- write out meta-equivalence classes (used to index templates with)
      if (TRACE) then 
        TEXT_IO.NEW_LINE(STANDARD_ERROR); 
        TEXT_IO.NEW_LINE(STANDARD_ERROR); 
        TEXT_IO.PUT_LINE(STANDARD_ERROR, "Meta-Equivalence Classes:"); 
      end if; 

      TEXT_IO.PUT("yy_meta : constant array(0.."); 
      INT_IO.PUT(NUMECS, 1); 
      TEXT_IO.PUT_LINE(") of short :="); 
      TEXT_IO.PUT_LINE("    (   0,"); 
      for CNT in 1 .. NUMECS loop
        if (TRACE) then 
          INT_IO.PUT(STANDARD_ERROR, CNT, 1); 
          TEXT_IO.PUT(STANDARD_ERROR, " = "); 
          INT_IO.PUT(STANDARD_ERROR, abs(TECBCK(CNT)), 1); 
          TEXT_IO.NEW_LINE(STANDARD_ERROR); 
        end if; 
        MISC.MKDATA(abs(TECBCK(CNT))); 
      end loop; 

      MISC.DATAEND; 
    end if; 

    TOTAL_STATES := LASTDFA + NUMTEMPS; 

    TEXT_IO.PUT("yy_base : constant array(0.."); 
    INT_IO.PUT(TOTAL_STATES, 1); 
    if (TBLEND > MAX_SHORT) then 
      TEXT_IO.PUT_LINE(") of integer :="); 
    else 
      TEXT_IO.PUT_LINE(") of short :="); 
    end if; 
    TEXT_IO.PUT_LINE("    (   0,"); 

    for CNT in 1 .. LASTDFA loop
      declare
        D : INTEGER := DEF(CNT); 
      begin
        if (BASE(CNT) = JAMSTATE_CONST) then 
          BASE(CNT) := JAMBASE; 
        end if; 

        if (D = JAMSTATE_CONST) then 
          DEF(CNT) := JAMSTATE; 
        else 
          if (D < 0) then 

            -- template reference
            TMPUSES := TMPUSES + 1; 
            DEF(CNT) := LASTDFA - D + 1; 
          end if; 
        end if; 
        MISC.MKDATA(BASE(CNT)); 
      end; 
    end loop; 

    -- generate jam state's base index
    I := LASTDFA + 1; 
    MISC.MKDATA(BASE(I)); 

    -- skip jam state
    I := I + 1; 

    for CNT in I .. TOTAL_STATES loop
      MISC.MKDATA(BASE(CNT)); 
      DEF(CNT) := JAMSTATE; 
    end loop; 

    MISC.DATAEND; 

    TEXT_IO.PUT("yy_def : constant array(0.."); 
    INT_IO.PUT(TOTAL_STATES, 1); 
    if (TBLEND > MAX_SHORT) then 
      TEXT_IO.PUT_LINE(") of integer :="); 
    else 
      TEXT_IO.PUT_LINE(") of short :="); 
    end if; 
    TEXT_IO.PUT_LINE("    (   0,"); 

    for CNT in 1 .. TOTAL_STATES loop
      MISC.MKDATA(DEF(CNT)); 
    end loop; 

    MISC.DATAEND; 
    TEXT_IO.PUT("yy_nxt : constant array(0.."); 
    INT_IO.PUT(TBLEND, 1); 
    if (LASTDFA > MAX_SHORT) then 
      TEXT_IO.PUT_LINE(") of integer :="); 
    else 
      TEXT_IO.PUT_LINE(") of short :="); 
    end if; 
    TEXT_IO.PUT_LINE("    (   0,"); 

    for CNT in 1 .. TBLEND loop
      if ((NXT(CNT) = 0) or (CHK(CNT) = 0)) then 
        NXT(CNT) := JAMSTATE; 

      -- new state is the JAM state
      end if; 
      MISC.MKDATA(NXT(CNT)); 
    end loop; 

    MISC.DATAEND; 

    TEXT_IO.PUT("yy_chk : constant array(0.."); 
    INT_IO.PUT(TBLEND, 1); 
    if (LASTDFA > MAX_SHORT) then 
      TEXT_IO.PUT_LINE(") of integer :="); 
    else 
      TEXT_IO.PUT_LINE(") of short :="); 
    end if; 
    TEXT_IO.PUT_LINE("    (   0,"); 

    for CNT in 1 .. TBLEND loop
      if (CHK(CNT) = 0) then 
        NUMMT := NUMMT + 1; 
      end if; 

      MISC.MKDATA(CHK(CNT)); 
    end loop; 

    MISC.DATAEND; 
  exception
    when STORAGE_ERROR => 
      MISC.AFLEXFATAL("dynamic memory failure in gentabs()"); 
  end GENTABS; 

  -- write out a string at the current indentation level, adding a final
  -- newline

  procedure INDENT_PUTS(STR : in STRING) is 
  begin
    DO_INDENT; 
    TEXT_IO.PUT_LINE(STR); 
  end INDENT_PUTS; 

  -- do_sect3_out - dumps section 3.

  procedure DO_SECT3_OUT is 
    GARBAGE : TOKEN; 
  begin
    SCANNER.CALL_YYLEX := TRUE; 
    GARBAGE := SCANNER.GET_TOKEN; 
  end DO_SECT3_OUT; 

  -- make_tables - generate transition tables
  --
  --
  -- Generates transition tables and finishes generating output file

  procedure MAKE_TABLES is 
    DID_EOF_RULE      : BOOLEAN := FALSE; 
    TRANS_OFFSET_TYPE : STRING(1 .. 7); 
    TOTAL_TABLE_SIZE  : INTEGER := TBLEND + NUMECS + 1; 
    BUF               : VSTRING; 
  begin
    if (not FULLTBL) then 

      -- if we used full tables this is already output
      DO_SECT3_OUT; 

      -- intent of this call is to get everything up to ##
      SKELETON_MANAGER.SKELOUT; 

    -- output YYLex code up to part about tables.
    end if; 

    TEXT_IO.PUT("YY_END_OF_BUFFER : constant := "); 
    INT_IO.PUT(NUM_RULES + 1, 1); 
    TEXT_IO.PUT_LINE(";"); 

    INDENT_PUTS("subtype yy_state_type is integer;"); 
    INDENT_PUTS("yy_current_state : yy_state_type;"); 

    -- now output the constants for the various start conditions
    RESET(DEF_FILE, IN_FILE); 

    while (not TEXT_IO.END_OF_FILE(DEF_FILE)) loop
      TSTRING.GET_LINE(DEF_FILE, BUF); 
      TSTRING.PUT_LINE(BUF); 
    end loop; 

    if (FULLTBL) then 
      GENFTBL; 
    else 
      GENTABS; 
    end if; 

    RESET(TEMP_ACTION_FILE, IN_FILE); 

    -- generate code for yy_get_previous_state
    SET_INDENT(1); 
    SKELETON_MANAGER.SKELOUT; 

    if (BOL_NEEDED) then 
      INDENT_PUTS("yy_bp : integer := yytext_ptr;"); 
    end if; 
    SKELETON_MANAGER.SKELOUT; 

    GEN_START_STATE; 
    SKELETON_MANAGER.SKELOUT; 
    GEN_NEXT_STATE; 
    SKELETON_MANAGER.SKELOUT; 

    SET_INDENT(2); 

    INDENT_PUTS("yy_bp := yy_cp;"); 

    GEN_START_STATE; 
    GEN_NEXT_MATCH; 

    SKELETON_MANAGER.SKELOUT; 

    SET_INDENT(3); 
    GEN_FIND_ACTION; 

    SET_INDENT(1); 
    SKELETON_MANAGER.SKELOUT; 

    INDENT_UP; 
    GEN_BT_ACTION; 

    MISC.ACTION_OUT; 
    MISC.ACTION_OUT; 

    -- generate cases for any missing EOF rules
    for I in 1 .. LASTSC loop
      if (not SCEOF(I)) then 
        DO_INDENT; 
        if (not DID_EOF_RULE) then 
          TEXT_IO.PUT("when "); 
        else 
          TEXT_IO.PUT_LINE("|"); 
        end if; 
        TEXT_IO.PUT("YY_END_OF_BUFFER + "); 
        TSTRING.PUT(SCNAME(I)); 
        TEXT_IO.PUT(" + 1 "); 
        DID_EOF_RULE := TRUE; 
      end if; 
    end loop; 
    if (DID_EOF_RULE) then 
      TEXT_IO.PUT_LINE("=> "); 
    end if; 

    if (DID_EOF_RULE) then 
      INDENT_UP; 
      INDENT_PUTS("return End_Of_Input;"); 
      INDENT_DOWN; 
    end if; 

    SKELETON_MANAGER.SKELOUT; 

    -- copy remainder of input to output
    MISC.LINE_DIRECTIVE_OUT; 
    DO_SECT3_OUT; 

  -- copy remainder of input, after ##, to the scanner file.
  end MAKE_TABLES; 

end GEN; 
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- This software was developed by John Self of the Arcadia project
-- at the University of California, Irvine.
--
-- 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.

-- TITLE scanner generation
-- AUTHOR: John Self (UCI)
-- DESCRIPTION
-- NOTES does actual generation (writing) of output aflex scanners
-- $Header: /co/ua/self/arcadia/aflex/ada/src/RCS/genS.a,v 1.4 90/01/12 15:20:07 self Exp Locker: self $ 

with MISC_DEFS; use MISC_DEFS; 
package GEN is 
  procedure DO_INDENT; 
  procedure GEN_BACKTRACKING; 
  procedure GEN_BT_ACTION; 
  procedure GEN_FIND_ACTION; 
  procedure GEN_NEXT_COMPRESSED_STATE; 
  procedure GEN_NEXT_MATCH; 
  procedure GEN_NEXT_STATE; 
  procedure GEN_START_STATE; 
  procedure GENECS; 
  procedure GENFTBL; 
  procedure INDENT_PUTS(STR : in STRING); 
  procedure GENTABS; 
  procedure INDENT_DOWN; 
  procedure INDENT_UP; 
  procedure SET_INDENT(INDENT_VAL : in INTEGER); 
  procedure MAKE_TABLES; 
  procedure DO_SECT3_OUT; 
end GEN; 
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- This software was developed by John Self of the Arcadia project
-- at the University of California, Irvine.
--
-- 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.

-- TITLE integer IO
-- AUTHOR: John Self (UCI)
-- DESCRIPTION instantiation of integer IO generic for integers
-- $Header: /co/ua/self/arcadia/aflex/ada/src/RCS/int_io.a,v 1.3 90/01/12 15:20:09 self Exp Locker: self $ 

with TEXT_IO; 
package INT_IO is 
  new TEXT_IO.INTEGER_IO(INTEGER); 
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- This software was developed by John Self of the Arcadia project
-- at the University of California, Irvine.
--
-- 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.

-- TITLE main body
-- AUTHOR: John Self (UCI)
-- DESCRIPTION driver routines for aflex.  Calls drivers for all
-- high level routines from other packages.
-- $Header: /dc/uc/self/arcadia/aflex/ada/src/RCS/mainB.a,v 1.24 1991/07/22 18:06:53 self Exp self $ 

with MISC_DEFS, MISC, COMMAND_LINE_INTERFACE, DFA, ECS, GEN, TEXT_IO, PARSER; 
with MAIN_BODY, TSTRING, PARSE_TOKENS, SKELETON_MANAGER, EXTERNAL_FILE_MANAGER; 
with EXTERNAL_FILE_MANAGER, INT_IO; use MISC_DEFS, COMMAND_LINE_INTERFACE, 
  TSTRING, EXTERNAL_FILE_MANAGER; 

package body MAIN_BODY is 
  OUTFILE_CREATED    : BOOLEAN := FALSE; 
  AFLEX_VERSION      : CONSTANT STRING := "1.1d"; 
  STARTTIME, ENDTIME : VSTRING; 

  -- aflexend - terminate aflex
  --
  -- note
  --    This routine does not return.

  procedure AFLEXEND(STATUS : in INTEGER) is 
    use TEXT_IO; 
    TBLSIZ : INTEGER; 
  begin
    TERMINATION_STATUS := STATUS; 

    -- we'll return this value of the OS.
    if (IS_OPEN(SKELFILE)) then 
      CLOSE(SKELFILE); 
    end if; 

    if (IS_OPEN(TEMP_ACTION_FILE)) then 
      DELETE(TEMP_ACTION_FILE); 
    end if; 

    if (IS_OPEN(DEF_FILE)) then 
      DELETE(DEF_FILE); 
    end if; 

    if (BACKTRACK_REPORT) then 
      if (NUM_BACKTRACKING = 0) then 
        TEXT_IO.PUT_LINE(BACKTRACK_FILE, "No backtracking."); 
      else 
        if (FULLTBL) then 
          INT_IO.PUT(BACKTRACK_FILE, NUM_BACKTRACKING, 0); 
          TEXT_IO.PUT_LINE(BACKTRACK_FILE, 
            " backtracking (non-accepting) states."); 
        else 
          TEXT_IO.PUT_LINE(BACKTRACK_FILE, "Compressed tables always backtrack."
            ); 
        end if; 
      end if; 

      CLOSE(BACKTRACK_FILE); 
    end if; 

    if (PRINTSTATS) then 
      ENDTIME := MISC.AFLEX_GETTIME; 

      TEXT_IO.PUT_LINE(STANDARD_ERROR, "aflex version " & AFLEX_VERSION & 
        " usage statistics:"); 

      TSTRING.PUT_LINE(STANDARD_ERROR, "  started at " & STARTTIME & 
        ", finished at " & ENDTIME); 
      TEXT_IO.PUT(STANDARD_ERROR, "  "); 
      INT_IO.PUT(STANDARD_ERROR, LASTNFA, 0); 
      TEXT_IO.PUT(STANDARD_ERROR, '/'); 
      INT_IO.PUT(STANDARD_ERROR, CURRENT_MNS, 0); 
      TEXT_IO.PUT_LINE(STANDARD_ERROR, "  NFA states"); 

      TEXT_IO.PUT(STANDARD_ERROR, "  "); 
      INT_IO.PUT(STANDARD_ERROR, LASTDFA, 0); 
      TEXT_IO.PUT(STANDARD_ERROR, '/'); 
      INT_IO.PUT(STANDARD_ERROR, CURRENT_MAX_DFAS, 0); 
      TEXT_IO.PUT(STANDARD_ERROR, " DFA states ("); 
      INT_IO.PUT(STANDARD_ERROR, TOTNST, 0); 
      TEXT_IO.PUT(STANDARD_ERROR, "  words)"); 

      TEXT_IO.PUT(STANDARD_ERROR, "  "); 
      INT_IO.PUT(STANDARD_ERROR, NUM_RULES - 1, 0); 

      -- - 1 for def. rule
      TEXT_IO.PUT_LINE(STANDARD_ERROR, "  rules"); 

      if (NUM_BACKTRACKING = 0) then 
        TEXT_IO.PUT_LINE(STANDARD_ERROR, "  No backtracking"); 
      else 
        if (FULLTBL) then 
          TEXT_IO.PUT(STANDARD_ERROR, "  "); 
          INT_IO.PUT(STANDARD_ERROR, NUM_BACKTRACKING, 0); 
          TEXT_IO.PUT_LINE(STANDARD_ERROR, 
            "  backtracking (non-accepting) states"); 
        else 
          TEXT_IO.PUT_LINE(STANDARD_ERROR, " compressed tables always backtrack"
            ); 
        end if; 
      end if; 

      if (BOL_NEEDED) then 
        TEXT_IO.PUT_LINE(STANDARD_ERROR, "  Beginning-of-line patterns used"); 
      end if; 

      TEXT_IO.PUT(STANDARD_ERROR, "  "); 
      INT_IO.PUT(STANDARD_ERROR, LASTSC, 0); 
      TEXT_IO.PUT(STANDARD_ERROR, '/'); 
      INT_IO.PUT(STANDARD_ERROR, CURRENT_MAX_SCS, 0); 
      TEXT_IO.PUT_LINE(STANDARD_ERROR, " start conditions"); 

      TEXT_IO.PUT(STANDARD_ERROR, "  "); 
      INT_IO.PUT(STANDARD_ERROR, NUMEPS, 0); 
      TEXT_IO.PUT(STANDARD_ERROR, " epsilon states, "); 
      INT_IO.PUT(STANDARD_ERROR, EPS2, 0); 
      TEXT_IO.PUT_LINE(STANDARD_ERROR, "  double epsilon states"); 

      if (LASTCCL = 0) then 
        TEXT_IO.PUT_LINE(STANDARD_ERROR, "  no character classes"); 
      else 
        TEXT_IO.PUT(STANDARD_ERROR, "  "); 
        INT_IO.PUT(STANDARD_ERROR, LASTCCL, 0); 
        TEXT_IO.PUT(STANDARD_ERROR, '/'); 
        INT_IO.PUT(STANDARD_ERROR, CURRENT_MAXCCLS, 0); 
        TEXT_IO.PUT(STANDARD_ERROR, " character classes needed "); 
        INT_IO.PUT(STANDARD_ERROR, CCLMAP(LASTCCL) + CCLLEN(LASTCCL), 0); 
        TEXT_IO.PUT(STANDARD_ERROR, '/'); 
        INT_IO.PUT(STANDARD_ERROR, CURRENT_MAX_CCL_TBL_SIZE, 0); 
        TEXT_IO.PUT(STANDARD_ERROR, " words of storage, "); 
        INT_IO.PUT(STANDARD_ERROR, CCLREUSE, 0); 
        TEXT_IO.PUT_LINE(STANDARD_ERROR, "reused"); 
      end if; 

      TEXT_IO.PUT(STANDARD_ERROR, "  "); 
      INT_IO.PUT(STANDARD_ERROR, NUMSNPAIRS, 0); 
      TEXT_IO.PUT_LINE(STANDARD_ERROR, " state/nextstate pairs created"); 

      TEXT_IO.PUT(STANDARD_ERROR, "  "); 
      INT_IO.PUT(STANDARD_ERROR, NUMUNIQ, 0); 
      TEXT_IO.PUT(STANDARD_ERROR, '/'); 
      INT_IO.PUT(STANDARD_ERROR, NUMDUP, 0); 
      TEXT_IO.PUT_LINE(STANDARD_ERROR, " unique/duplicate transitions"); 

      if (FULLTBL) then 
        TBLSIZ := LASTDFA*NUMECS; 
        TEXT_IO.PUT(STANDARD_ERROR, "  "); 
        INT_IO.PUT(STANDARD_ERROR, TBLSIZ, 0); 
        TEXT_IO.PUT_LINE(STANDARD_ERROR, " table entries"); 
      else 
        TBLSIZ := 2*(LASTDFA + NUMTEMPS) + 2*TBLEND; 

        TEXT_IO.PUT(STANDARD_ERROR, "  "); 
        INT_IO.PUT(STANDARD_ERROR, LASTDFA + NUMTEMPS, 0); 
        TEXT_IO.PUT(STANDARD_ERROR, '/'); 
        INT_IO.PUT(STANDARD_ERROR, CURRENT_MAX_DFAS, 0); 
        TEXT_IO.PUT_LINE(STANDARD_ERROR, " base-def entries created"); 

        TEXT_IO.PUT(STANDARD_ERROR, "  "); 
        INT_IO.PUT(STANDARD_ERROR, TBLEND, 0); 
        TEXT_IO.PUT(STANDARD_ERROR, '/'); 
        INT_IO.PUT(STANDARD_ERROR, CURRENT_MAX_XPAIRS, 0); 
        TEXT_IO.PUT(STANDARD_ERROR, " (peak "); 
        INT_IO.PUT(STANDARD_ERROR, PEAKPAIRS, 0); 
        TEXT_IO.PUT_LINE(STANDARD_ERROR, ") nxt-chk entries created"); 

        TEXT_IO.PUT(STANDARD_ERROR, "  "); 
        INT_IO.PUT(STANDARD_ERROR, NUMTEMPS*NUMMECS, 0); 
        TEXT_IO.PUT(STANDARD_ERROR, '/'); 
        INT_IO.PUT(STANDARD_ERROR, CURRENT_MAX_TEMPLATE_XPAIRS, 0); 
        TEXT_IO.PUT(STANDARD_ERROR, " (peak "); 
        INT_IO.PUT(STANDARD_ERROR, NUMTEMPS*NUMECS, 0); 
        TEXT_IO.PUT_LINE(STANDARD_ERROR, ") template nxt-chk entries created"); 

        TEXT_IO.PUT(STANDARD_ERROR, "  "); 
        INT_IO.PUT(STANDARD_ERROR, NUMMT, 0); 
        TEXT_IO.PUT_LINE(STANDARD_ERROR, " empty table entries"); 
        TEXT_IO.PUT(STANDARD_ERROR, "  "); 
        INT_IO.PUT(STANDARD_ERROR, NUMPROTS, 0); 
        TEXT_IO.PUT_LINE(STANDARD_ERROR, " protos created"); 
        TEXT_IO.PUT(STANDARD_ERROR, "  "); 
        INT_IO.PUT(STANDARD_ERROR, NUMTEMPS, 0); 
        TEXT_IO.PUT(STANDARD_ERROR, " templates created, "); 
        INT_IO.PUT(STANDARD_ERROR, TMPUSES, 0); 
        TEXT_IO.PUT_LINE(STANDARD_ERROR, "uses"); 
      end if; 

      if (USEECS) then 
        TBLSIZ := TBLSIZ + CSIZE; 
        TEXT_IO.PUT_LINE(STANDARD_ERROR, "  "); 
        INT_IO.PUT(STANDARD_ERROR, NUMECS, 0); 
        TEXT_IO.PUT(STANDARD_ERROR, '/'); 
        INT_IO.PUT(STANDARD_ERROR, CSIZE, 0); 
        TEXT_IO.PUT_LINE(STANDARD_ERROR, " equivalence classes created"); 
      end if; 

      if (USEMECS) then 
        TBLSIZ := TBLSIZ + NUMECS; 
        TEXT_IO.PUT(STANDARD_ERROR, "  "); 
        INT_IO.PUT(STANDARD_ERROR, NUMMECS, 0); 
        TEXT_IO.PUT(STANDARD_ERROR, '/'); 
        INT_IO.PUT(STANDARD_ERROR, CSIZE, 0); 
        TEXT_IO.PUT_LINE(STANDARD_ERROR, " meta-equivalence classes created"); 
      end if; 

      TEXT_IO.PUT(STANDARD_ERROR, "  "); 
      INT_IO.PUT(STANDARD_ERROR, HSHCOL, 0); 
      TEXT_IO.PUT(STANDARD_ERROR, " ("); 
      INT_IO.PUT(STANDARD_ERROR, HSHSAVE, 0); 
      TEXT_IO.PUT_LINE(STANDARD_ERROR, " saved) hash collisions, "); 
      INT_IO.PUT(STANDARD_ERROR, DFAEQL, 0); 
      TEXT_IO.PUT_LINE(STANDARD_ERROR, " DFAs equal"); 

      TEXT_IO.PUT(STANDARD_ERROR, "  "); 
      INT_IO.PUT(STANDARD_ERROR, NUM_REALLOCS, 0); 
      TEXT_IO.PUT_LINE(STANDARD_ERROR, " sets of reallocations needed"); 
      TEXT_IO.PUT(STANDARD_ERROR, "  "); 
      INT_IO.PUT(STANDARD_ERROR, TBLSIZ, 0); 
      TEXT_IO.PUT_LINE(STANDARD_ERROR, " total table entries needed"); 
    end if; 

    if (STATUS /= 0) then 
      raise AFLEX_TERMINATE; 
    end if; 
  end AFLEXEND; 

  -- aflexinit - initialize aflex

  procedure AFLEXINIT is 
    use TEXT_IO, TSTRING; 
    SAWCMPFLAG, USE_STDOUT : BOOLEAN; 
    OUTPUT_FILE            : FILE_TYPE; 
    INPUT_FILE             : FILE_TYPE; 
    I                      : INTEGER; 
    ARG_CNT                : INTEGER; 
    FLAG_POS               : INTEGER; 
    ARG                    : VSTRING; 
    SKELNAME               : VSTRING; 
    SKELNAME_USED          : BOOLEAN := FALSE; 
  begin
    PRINTSTATS := FALSE; 
    SYNTAXERROR := FALSE; 
    TRACE := FALSE; 
    SPPRDFLT := FALSE; 
    INTERACTIVE := FALSE; 
    CASEINS := FALSE; 
    BACKTRACK_REPORT := FALSE; 
    PERFORMANCE_REPORT := FALSE; 
    DDEBUG := FALSE; 
    FULLTBL := FALSE; 
    CONTINUED_ACTION := FALSE; 
    GEN_LINE_DIRS := TRUE; 
    USEMECS := TRUE; 
    USEECS := TRUE; 

    SAWCMPFLAG := FALSE; 
    USE_STDOUT := FALSE; 

    -- read flags
    COMMAND_LINE_INTERFACE.INITIALIZE_COMMAND_LINE; 

    -- load up argv
    EXTERNAL_FILE_MANAGER.INITIALIZE_FILES; 

    -- do external files setup

    -- loop through the list of arguments
    ARG_CNT := 1; 
    while (ARG_CNT <= ARGC - 1) loop
      if ((CHAR(ARGV(ARG_CNT), 1) /= '-') or (LEN(ARGV(ARG_CNT)) < 2)) then 
        exit; 
      end if; 

      -- loop through the flags in this argument.
      ARG := ARGV(ARG_CNT); 
      FLAG_POS := 2; 
      while (FLAG_POS <= LEN(ARG)) loop
        case CHAR(ARG, FLAG_POS) is 
          when 'b' => 
            BACKTRACK_REPORT := TRUE; 
          when 'd' => 
            DDEBUG := TRUE; 
          when 'f' => 
            USEECS := FALSE; 
            USEMECS := FALSE; 
            FULLTBL := TRUE; 
          when 'I' => 
            INTERACTIVE := TRUE; 
          when 'i' => 
            CASEINS := TRUE; 
          when 'L' => 
            GEN_LINE_DIRS := FALSE; 
          when 'p' => 
            PERFORMANCE_REPORT := TRUE; 
          when 'S' => 
            if (FLAG_POS /= 2) then 
              MISC.AFLEXERROR("-S flag must be given separately"); 
            end if; 
            SKELNAME := SLICE(ARG, FLAG_POS + 1, LEN(ARG)); 
            SKELNAME_USED := TRUE; 
            goto GET_NEXT_ARG; 
          when 's' => 
            SPPRDFLT := TRUE; 
          when 't' => 
            USE_STDOUT := TRUE; 
          when 'T' => 
            TRACE := TRUE; 
          when 'v' => 
            PRINTSTATS := TRUE; 
          when others => 
            MISC.AFLEXERROR("unknown flag " & CHAR(ARG, FLAG_POS)); 
        end case; 
        FLAG_POS := FLAG_POS + 1; 
      end loop; 
      <<GET_NEXT_ARG>> ARG_CNT := ARG_CNT + 1; 

    -- go on to next argument from list.
    end loop; 

    if (FULLTBL and USEMECS) then 
      MISC.AFLEXERROR("full table and -cm don't make sense together"); 
    end if; 

    if (FULLTBL and INTERACTIVE) then 
      MISC.AFLEXERROR("full table and -I are (currently) incompatible"); 
    end if; 

    if (ARG_CNT < ARGC) then 
      begin
        if (ARG_CNT - ARGC > 1) then 
          MISC.AFLEXERROR("extraneous argument(s) given"); 
        end if; 

        -- Tell aflex where to read input from.
        INFILENAME := ARGV(ARG_CNT); 
        OPEN(INPUT_FILE, IN_FILE, STR(ARGV(ARG_CNT))); 
        SET_INPUT(INPUT_FILE); 
      exception
        when NAME_ERROR => 
          MISC.AFLEXFATAL("can't open " & INFILENAME); 
      end; 
    end if; 

    if (not USE_STDOUT) then 
      EXTERNAL_FILE_MANAGER.GET_SCANNER_FILE(OUTPUT_FILE); 
      OUTFILE_CREATED := TRUE; 
    end if; 

    if (BACKTRACK_REPORT) then 
      EXTERNAL_FILE_MANAGER.GET_BACKTRACK_FILE(BACKTRACK_FILE); 
    end if; 

    LASTCCL := 0; 
    LASTSC := 0; 


    --initialize the statistics
    STARTTIME := MISC.AFLEX_GETTIME; 

    begin

      -- open the skeleton file
      if (SKELNAME_USED) then 
        OPEN(SKELFILE, IN_FILE, STR(SKELNAME)); 
        SKELETON_MANAGER.SET_EXTERNAL_SKELETON; 
      end if; 
    exception
      when USE_ERROR | NAME_ERROR => 
        MISC.AFLEXFATAL("couldn't open skeleton file " & SKELNAME); 
    end; 

    -- without a third argument create make an anonymous temp file.
    begin
      CREATE(TEMP_ACTION_FILE, OUT_FILE); 
      CREATE(DEF_FILE, OUT_FILE); 
    exception
      when USE_ERROR | NAME_ERROR => 
        MISC.AFLEXFATAL("can't create temporary file"); 
    end; 

    LASTDFA := 0; 
    LASTNFA := 0; 
    NUM_RULES := 0; 
    NUMAS := 0; 
    NUMSNPAIRS := 0; 
    TMPUSES := 0; 
    NUMECS := 0; 
    NUMEPS := 0; 
    EPS2 := 0; 
    NUM_REALLOCS := 0; 
    HSHCOL := 0; 
    DFAEQL := 0; 
    TOTNST := 0; 
    NUMUNIQ := 0; 
    NUMDUP := 0; 
    HSHSAVE := 0; 
    EOFSEEN := FALSE; 
    DATAPOS := 0; 
    DATALINE := 0; 
    NUM_BACKTRACKING := 0; 
    ONESP := 0; 
    NUMPROTS := 0; 
    VARIABLE_TRAILING_CONTEXT_RULES := FALSE; 
    BOL_NEEDED := FALSE; 

    LINENUM := 1; 
    SECTNUM := 1; 
    FIRSTPROT := NIL; 

    -- used in mkprot() so that the first proto goes in slot 1
    -- of the proto queue

    LASTPROT := 1; 

    if (USEECS) then 
    -- set up doubly-linked equivalence classes
      ECGROUP(1) := NIL; 

      for CNT in 2 .. CSIZE loop
        ECGROUP(CNT) := CNT - 1; 
        NEXTECM(CNT - 1) := CNT; 
      end loop; 

      NEXTECM(CSIZE) := NIL; 
    else 
    -- put everything in its own equivalence class
      for CNT in 1 .. CSIZE loop
        ECGROUP(CNT) := CNT; 
        NEXTECM(CNT) := BAD_SUBSCRIPT;  -- to catch errors
      end loop; 
    end if; 

    SET_UP_INITIAL_ALLOCATIONS; 


  end AFLEXINIT; 

  -- readin - read in the rules section of the input file(s)
  procedure READIN is 
  begin
    SKELETON_MANAGER.SKELOUT; 
    TEXT_IO.PUT("with " & TSTRING.STR(MISC.BASENAME) & "_dfa" & "; "); 
    TEXT_IO.PUT_LINE("use " & TSTRING.STR(MISC.BASENAME) & "_dfa" & "; "); 
    TEXT_IO.PUT("with " & TSTRING.STR(MISC.BASENAME) & "_io" & "; "); 
    TEXT_IO.PUT_LINE("use " & TSTRING.STR(MISC.BASENAME) & "_io" & "; "); 
    MISC.LINE_DIRECTIVE_OUT; 

    PARSER.YYPARSE; 

    if (USEECS) then 
      ECS.CRE8ECS(NEXTECM, ECGROUP, CSIZE, NUMECS); 
      ECS.CCL2ECL; 
    else 
      NUMECS := CSIZE; 
    end if; 
  exception
    when PARSE_TOKENS.SYNTAX_ERROR => 
      MISC.AFLEXERROR("fatal parse error at line " & INTEGER'IMAGE(LINENUM)); 
      MAIN_BODY.AFLEXEND(1); 
  end READIN; 

  -- set_up_initial_allocations - allocate memory for internal tables
  procedure SET_UP_INITIAL_ALLOCATIONS is 
  begin
    CURRENT_MNS := INITIAL_MNS; 
    FIRSTST := ALLOCATE_INTEGER_ARRAY(CURRENT_MNS); 
    LASTST := ALLOCATE_INTEGER_ARRAY(CURRENT_MNS); 
    FINALST := ALLOCATE_INTEGER_ARRAY(CURRENT_MNS); 
    TRANSCHAR := ALLOCATE_INTEGER_ARRAY(CURRENT_MNS); 
    TRANS1 := ALLOCATE_INTEGER_ARRAY(CURRENT_MNS); 
    TRANS2 := ALLOCATE_INTEGER_ARRAY(CURRENT_MNS); 
    ACCPTNUM := ALLOCATE_INTEGER_ARRAY(CURRENT_MNS); 
    ASSOC_RULE := ALLOCATE_INTEGER_ARRAY(CURRENT_MNS); 
    STATE_TYPE := ALLOCATE_STATE_ENUM_ARRAY(CURRENT_MNS); 

    CURRENT_MAX_RULES := INITIAL_MAX_RULES; 
    RULE_TYPE := ALLOCATE_RULE_ENUM_ARRAY(CURRENT_MAX_RULES); 
    RULE_LINENUM := ALLOCATE_INTEGER_ARRAY(CURRENT_MAX_RULES); 

    CURRENT_MAX_SCS := INITIAL_MAX_SCS; 
    SCSET := ALLOCATE_INTEGER_ARRAY(CURRENT_MAX_SCS); 
    SCBOL := ALLOCATE_INTEGER_ARRAY(CURRENT_MAX_SCS); 
    SCXCLU := ALLOCATE_BOOLEAN_ARRAY(CURRENT_MAX_SCS); 
    SCEOF := ALLOCATE_BOOLEAN_ARRAY(CURRENT_MAX_SCS); 
    SCNAME := ALLOCATE_VSTRING_ARRAY(CURRENT_MAX_SCS); 
    ACTVSC := ALLOCATE_INTEGER_ARRAY(CURRENT_MAX_SCS); 

    CURRENT_MAXCCLS := INITIAL_MAX_CCLS; 
    CCLMAP := ALLOCATE_INTEGER_ARRAY(CURRENT_MAXCCLS); 
    CCLLEN := ALLOCATE_INTEGER_ARRAY(CURRENT_MAXCCLS); 
    CCLNG := ALLOCATE_INTEGER_ARRAY(CURRENT_MAXCCLS); 

    CURRENT_MAX_CCL_TBL_SIZE := INITIAL_MAX_CCL_TBL_SIZE; 
    CCLTBL := ALLOCATE_CHARACTER_ARRAY(CURRENT_MAX_CCL_TBL_SIZE); 

    CURRENT_MAX_DFA_SIZE := INITIAL_MAX_DFA_SIZE; 

    CURRENT_MAX_XPAIRS := INITIAL_MAX_XPAIRS; 
    NXT := ALLOCATE_INTEGER_ARRAY(CURRENT_MAX_XPAIRS); 
    CHK := ALLOCATE_INTEGER_ARRAY(CURRENT_MAX_XPAIRS); 

    CURRENT_MAX_TEMPLATE_XPAIRS := INITIAL_MAX_TEMPLATE_XPAIRS; 
    TNXT := ALLOCATE_INTEGER_ARRAY(CURRENT_MAX_TEMPLATE_XPAIRS); 

    CURRENT_MAX_DFAS := INITIAL_MAX_DFAS; 
    BASE := ALLOCATE_INTEGER_ARRAY(CURRENT_MAX_DFAS); 
    DEF := ALLOCATE_INTEGER_ARRAY(CURRENT_MAX_DFAS); 
    DFASIZ := ALLOCATE_INTEGER_ARRAY(CURRENT_MAX_DFAS); 
    ACCSIZ := ALLOCATE_INTEGER_ARRAY(CURRENT_MAX_DFAS); 
    DHASH := ALLOCATE_INTEGER_ARRAY(CURRENT_MAX_DFAS); 
    DSS := ALLOCATE_INT_PTR_ARRAY(CURRENT_MAX_DFAS); 
    DFAACC := ALLOCATE_DFAACC_UNION(CURRENT_MAX_DFAS); 
  end SET_UP_INITIAL_ALLOCATIONS; 
end MAIN_BODY; 
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- This software was developed by John Self of the Arcadia project
-- at the University of California, Irvine.
--
-- 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.

-- TITLE main body
-- AUTHOR: John Self (UCI)
-- DESCRIPTION driver routines for aflex.  Calls drivers for all
-- high level routines from other packages.
-- $Header: /co/ua/self/arcadia/aflex/ada/src/RCS/mainS.a,v 1.5 90/01/12 15:20:14 self Exp Locker: self $ 

-- aflex - tool to generate fast lexical analyzers
package MAIN_BODY is 
  procedure AFLEXEND(STATUS : in INTEGER); 
  procedure AFLEXINIT; 
  procedure READIN; 
  procedure SET_UP_INITIAL_ALLOCATIONS; 
  AFLEX_TERMINATE    : exception; 
  TERMINATION_STATUS : INTEGER; 
end MAIN_BODY; 
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- This software was developed by John Self of the Arcadia project
-- at the University of California, Irvine.
--
-- 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.

-- TITLE  miscellaneous aflex routines
-- AUTHOR: John Self (UCI)
-- DESCRIPTION
-- NOTES contains functions used in various places throughout aflex.
-- $Header: /dc/uc/self/arcadia/aflex/ada/src/RCS/miscB.a,v 1.22 1991/07/01 21:30:37 self Exp self $ 

with MISC_DEFS, TSTRING, TEXT_IO, MISC, MAIN_BODY; 
with INT_IO, CALENDAR, EXTERNAL_FILE_MANAGER; use MISC, MISC_DEFS, TEXT_IO, 
  EXTERNAL_FILE_MANAGER; 

package body MISC is 
  use TSTRING; 
  -- action_out - write the actions from the temporary file to lex.yy.c

  procedure ACTION_OUT is 
    BUF : VSTRING; 
  begin
    while (not TEXT_IO.END_OF_FILE(TEMP_ACTION_FILE)) loop
      TSTRING.GET_LINE(TEMP_ACTION_FILE, BUF); 
      if ((TSTRING.LEN(BUF) >= 2) and then ((CHAR(BUF, 1) = '%') and (CHAR(BUF, 
        2) = '%'))) then 
        exit; 
      else 
        TSTRING.PUT_LINE(BUF); 
      end if; 
    end loop; 
  end ACTION_OUT; 

  -- bubble - bubble sort an integer array in increasing order
  --
  -- description
  --   sorts the first n elements of array v and replaces them in
  --   increasing order.
  --
  -- passed
  --   v - the array to be sorted
  --   n - the number of elements of 'v' to be sorted

  procedure BUBBLE(V : in INT_PTR; 
                   N : in INTEGER) is 
    K : INTEGER; 
  begin
    for I in reverse 2 .. N loop
      for J in 1 .. I - 1 loop
        if (V(J) > V(J + 1)) then 

          -- compare
          K := V(J); 

          -- exchange
          V(J) := V(J + 1); 
          V(J + 1) := K; 
        end if; 
      end loop; 
    end loop; 
  end BUBBLE; 


  -- clower - replace upper-case letter to lower-case

  function CLOWER(C : in INTEGER) return INTEGER is 
  begin
    if (ISUPPER(CHARACTER'VAL(C))) then 
      return TOLOWER(C); 
    else 
      return C; 
    end if; 
  end CLOWER; 


  -- cshell - shell sort a character array in increasing order
  --
  -- description
  --   does a shell sort of the first n elements of array v.
  --
  -- passed
  --   v - array to be sorted
  --   n - number of elements of v to be sorted

  procedure CSHELL(V : in out CHAR_ARRAY; 
                   N : in INTEGER) is 
    GAP, J, JG  : INTEGER; 
    K           : CHARACTER; 
    LOWER_BOUND : INTEGER := V'FIRST; 
  begin
    GAP := N/2; 
    while GAP > 0 loop
      for I in GAP .. N - 1 loop
        J := I - GAP; 
        while (J >= 0) loop
          JG := J + GAP; 

          if (V(J + LOWER_BOUND) <= V(JG + LOWER_BOUND)) then 
            exit; 
          end if; 

          K := V(J + LOWER_BOUND); 
          V(J + LOWER_BOUND) := V(JG + LOWER_BOUND); 
          V(JG + LOWER_BOUND) := K; 
          J := J - GAP; 
        end loop; 
      end loop; 
      GAP := GAP/2; 
    end loop; 
  end CSHELL; 


  -- dataend - finish up a block of data declarations

  procedure DATAEND is 
  begin
    if (DATAPOS > 0) then 
      DATAFLUSH; 

      -- add terminator for initialization
      TEXT_IO.PUT_LINE("    ) ;"); 
      TEXT_IO.NEW_LINE; 

      DATALINE := 0; 
    end if; 
  end DATAEND; 


  -- dataflush - flush generated data statements

  procedure DATAFLUSH(FILE : in FILE_TYPE) is 
  begin
    TEXT_IO.NEW_LINE(FILE); 
    DATALINE := DATALINE + 1; 
    if (DATALINE >= NUMDATALINES) then 

      -- put out a blank line so that the table is grouped into
      -- large blocks that enable the user to find elements easily
      TEXT_IO.NEW_LINE(FILE); 
      DATALINE := 0; 
    end if; 

    -- reset the number of characters written on the current line
    DATAPOS := 0; 
  end DATAFLUSH; 

  procedure DATAFLUSH is 
  begin
    DATAFLUSH(CURRENT_OUTPUT); 
  end DATAFLUSH; 
  -- aflex_gettime - return current time

  function AFLEX_GETTIME return VSTRING is 
    use TSTRING, CALENDAR; 
    CURRENT_TIME                                            : TIME; 
    CURRENT_YEAR                                            : YEAR_NUMBER; 
    CURRENT_MONTH                                           : MONTH_NUMBER; 
    CURRENT_DAY                                             : DAY_NUMBER; 
    CURRENT_SECONDS                                         : DAY_DURATION; 
    MONTH_STRING, HOUR_STRING, MINUTE_STRING, SECOND_STRING : VSTRING; 
    HOUR, MINUTE, SECOND                                    : INTEGER; 
    SECONDS_PER_HOUR                                        : constant 
      DAY_DURATION := 3600.0; 
  begin
    CURRENT_TIME := CLOCK; 
    SPLIT(CURRENT_TIME, CURRENT_YEAR, CURRENT_MONTH, CURRENT_DAY, 
      CURRENT_SECONDS); 
    case CURRENT_MONTH is 
      when 1 => 
        MONTH_STRING := VSTR("Jan"); 
      when 2 => 
        MONTH_STRING := VSTR("Feb"); 
      when 3 => 
        MONTH_STRING := VSTR("Mar"); 
      when 4 => 
        MONTH_STRING := VSTR("Apr"); 
      when 5 => 
        MONTH_STRING := VSTR("May"); 
      when 6 => 
        MONTH_STRING := VSTR("Jun"); 
      when 7 => 
        MONTH_STRING := VSTR("Jul"); 
      when 8 => 
        MONTH_STRING := VSTR("Aug"); 
      when 9 => 
        MONTH_STRING := VSTR("Sep"); 
      when 10 => 
        MONTH_STRING := VSTR("Oct"); 
      when 11 => 
        MONTH_STRING := VSTR("Nov"); 
      when 12 => 
        MONTH_STRING := VSTR("Dec"); 
    end case; 

    HOUR := INTEGER(CURRENT_SECONDS)/INTEGER(SECONDS_PER_HOUR);
    MINUTE := INTEGER((CURRENT_SECONDS - (HOUR*SECONDS_PER_HOUR))/60); 
    SECOND := INTEGER(CURRENT_SECONDS - HOUR*SECONDS_PER_HOUR - MINUTE*60.0); 

    if (HOUR >= 10) then 
      HOUR_STRING := VSTR(INTEGER'IMAGE(HOUR)); 
    else 
      HOUR_STRING := VSTR("0" & INTEGER'IMAGE(HOUR)); 
    end if; 

    if (MINUTE >= 10) then 
      MINUTE_STRING := VSTR(INTEGER'IMAGE(MINUTE)(2 .. INTEGER'IMAGE(MINUTE)'
        LENGTH)); 
    else 
      MINUTE_STRING := VSTR("0" & INTEGER'IMAGE(MINUTE)(2 .. INTEGER'IMAGE(
        MINUTE)'LENGTH)); 
    end if; 

    if (SECOND >= 10) then 
      SECOND_STRING := VSTR(INTEGER'IMAGE(SECOND)(2 .. INTEGER'IMAGE(SECOND)'
        LENGTH)); 
    else 
      SECOND_STRING := VSTR("0" & INTEGER'IMAGE(SECOND)(2 .. INTEGER'IMAGE(
        SECOND)'LENGTH)); 
    end if; 

    return MONTH_STRING & VSTR(INTEGER'IMAGE(CURRENT_DAY)) & HOUR_STRING & ":"
      & MINUTE_STRING & ":" & SECOND_STRING & INTEGER'IMAGE(CURRENT_YEAR); 
  end AFLEX_GETTIME; 

  -- aflexerror - report an error message and terminate
  -- overloaded function, one for vstring, one for string.
  procedure AFLEXERROR(MSG : in VSTRING) is 
    use TEXT_IO; 
  begin
    TSTRING.PUT(STANDARD_ERROR, "aflex: " & MSG); 
    TEXT_IO.NEW_LINE(STANDARD_ERROR); 
    MAIN_BODY.AFLEXEND(1); 
  end AFLEXERROR; 

  procedure AFLEXERROR(MSG : in STRING) is 
    use TEXT_IO; 
  begin
    TEXT_IO.PUT(STANDARD_ERROR, "aflex: " & MSG); 
    TEXT_IO.NEW_LINE(STANDARD_ERROR); 
    MAIN_BODY.AFLEXEND(1); 
  end AFLEXERROR; 

  -- aflexfatal - report a fatal error message and terminate
  -- overloaded function, one for vstring, one for string.
  procedure AFLEXFATAL(MSG : in VSTRING) is 
    use TEXT_IO; 
  begin
    TSTRING.PUT(STANDARD_ERROR, "aflex: fatal internal error " & MSG); 
    TEXT_IO.NEW_LINE(STANDARD_ERROR); 
    MAIN_BODY.AFLEXEND(1); 
  end AFLEXFATAL; 

  procedure AFLEXFATAL(MSG : in STRING) is 
    use TEXT_IO; 
  begin
    TEXT_IO.PUT(STANDARD_ERROR, "aflex: fatal internal error " & MSG); 
    TEXT_IO.NEW_LINE(STANDARD_ERROR); 
    MAIN_BODY.AFLEXEND(1); 
  end AFLEXFATAL; 

  -- basename - find the basename of a file
  function BASENAME return VSTRING is 
    END_CHAR_POS : INTEGER := LEN(INFILENAME);
    START_CHAR_POS : INTEGER;
  begin
    if (END_CHAR_POS = 0) then 
      -- if reading standard input give everything this name
      return VSTR("aflex_yy"); 
    end if; 
    
    -- find out where the end of the basename is    
    while ((END_CHAR_POS >= 1) and then
           (CHAR(INFILENAME, END_CHAR_POS) /= '.')) loop
      END_CHAR_POS := END_CHAR_POS - 1; 
    end loop; 

    -- find out where the beginning of the basename is    
    START_CHAR_POS := END_CHAR_POS; -- start at the end of the basename
    while ((START_CHAR_POS > 1) and then
           (CHAR(INFILENAME, START_CHAR_POS) /= '/')) loop
    	START_CHAR_POS := START_CHAR_POS - 1; 
    end loop; 

    if (CHAR(INFILENAME, START_CHAR_POS) = '/') then
    	START_CHAR_POS := START_CHAR_POS + 1;
    end if;
    
    if (END_CHAR_POS >= 1) then 
      return SLICE(INFILENAME, START_CHAR_POS,  END_CHAR_POS - 1); 
    else 
      return INFILENAME; 
    end if; 
  end BASENAME; 

  -- line_directive_out - spit out a "# line" statement

  procedure LINE_DIRECTIVE_OUT(OUTPUT_FILE_NAME : in FILE_TYPE) is 
  begin
    if (GEN_LINE_DIRS) then 
      TEXT_IO.PUT(OUTPUT_FILE_NAME, "--# line "); 
      INT_IO.PUT(OUTPUT_FILE_NAME, LINENUM, 1); 
      TEXT_IO.PUT(OUTPUT_FILE_NAME, " """); 
      TSTRING.PUT(OUTPUT_FILE_NAME, INFILENAME); 
      TEXT_IO.PUT_LINE(OUTPUT_FILE_NAME, """"); 
    end if; 
  end LINE_DIRECTIVE_OUT; 


  procedure LINE_DIRECTIVE_OUT is 
  begin
    if (GEN_LINE_DIRS) then 
      TEXT_IO.PUT("--# line "); 
      INT_IO.PUT(LINENUM, 1); 
      TEXT_IO.PUT(" """); 
      TSTRING.PUT(INFILENAME); 
      TEXT_IO.PUT_LINE(""""); 
    end if; 
  end LINE_DIRECTIVE_OUT; 

  -- all_upper - returns true if a string is all upper-case
  function ALL_UPPER(STR : in VSTRING) return BOOLEAN is 
  begin
    for I in 1 .. LEN(STR) loop
      if (not ((CHAR(STR, I) >= 'A') and (CHAR(STR, I) <= 'Z'))) then 
        return FALSE; 
      end if; 
    end loop; 
    return TRUE; 
  end ALL_UPPER; 

  -- all_lower - returns true if a string is all lower-case
  function ALL_LOWER(STR : in VSTRING) return BOOLEAN is 
  begin
    for I in 1 .. LEN(STR) loop
      if (not ((CHAR(STR, I) >= 'a') and (CHAR(STR, I) <= 'z'))) then 
        return FALSE; 
      end if; 
    end loop; 
    return TRUE; 
  end ALL_LOWER; 

  -- mk2data - generate a data statement for a two-dimensional array
  --
  --  generates a data statement initializing the current 2-D array to "value"

  procedure MK2DATA(FILE  : in FILE_TYPE; 
                    VALUE : in INTEGER) is 
  begin

    if (DATAPOS >= NUMDATAITEMS) then 
      TEXT_IO.PUT(FILE, ','); 
      DATAFLUSH(FILE); 
    end if; 

    if (DATAPOS = 0) then 

      -- indent
      TEXT_IO.PUT(FILE, "    "); 
    else 
      TEXT_IO.PUT(FILE, ','); 
    end if; 

    DATAPOS := DATAPOS + 1; 

    INT_IO.PUT(FILE, VALUE, 5); 
  end MK2DATA; 

  procedure MK2DATA(VALUE : in INTEGER) is 
  begin
    MK2DATA(CURRENT_OUTPUT, VALUE); 
  end MK2DATA; 

  --
  --  generates a data statement initializing the current array element to
  --  "value"

  procedure MKDATA(VALUE : in INTEGER) is 
  begin
    if (DATAPOS >= NUMDATAITEMS) then 
      TEXT_IO.PUT(','); 
      DATAFLUSH; 
    end if; 

    if (DATAPOS = 0) then 

      -- indent
      TEXT_IO.PUT("    "); 
    else 
      TEXT_IO.PUT(','); 
    end if; 

    DATAPOS := DATAPOS + 1; 

    INT_IO.PUT(VALUE, 5); 
  end MKDATA; 


  -- myctoi - return the integer represented by a string of digits

  function MYCTOI(NUM_ARRAY : in VSTRING) return INTEGER is 
    TOTAL : INTEGER := 0; 
    CNT   : INTEGER := TSTRING.FIRST; 
  begin
    while (CNT <= TSTRING.LEN(NUM_ARRAY)) loop
      TOTAL := TOTAL*10; 
      TOTAL := TOTAL + CHARACTER'POS(CHAR(NUM_ARRAY, CNT)) - CHARACTER'POS('0')
        ; 
      CNT := CNT + 1; 
    end loop; 
    return TOTAL; 
  end MYCTOI; 


  -- myesc - return character corresponding to escape sequence

  function MYESC(ARR : in VSTRING) return CHARACTER is 
    use TEXT_IO; 
  begin
    case (CHAR(ARR, TSTRING.FIRST + 1)) is 
      when 'a' => 
        return ASCII.BEL; 
      when 'b' => 
        return ASCII.BS; 
      when 'f' => 
        return ASCII.FF; 
      when 'n' => 
        return ASCII.LF; 
      when 'r' => 
        return ASCII.CR; 
      when 't' => 
        return ASCII.HT; 
      when 'v' => 
        return ASCII.VT; 

      when '0' | '1' | '2' | '3' | '4' | '5' | '6' | '7' | '8' | '9' => 

        -- \<octal>
        declare
          C, ESC_CHAR : CHARACTER; 
          SPTR        : INTEGER := TSTRING.FIRST + 1; 
        begin
          ESC_CHAR := OTOI(TSTRING.SLICE(ARR, TSTRING.FIRST + 1, TSTRING.LEN(ARR
            ))); 
          if (ESC_CHAR = ASCII.NUL) then 
            MISC.SYNERR("escape sequence for null not allowed"); 
            return ASCII.SOH; 
          end if; 

          return ESC_CHAR; 
        end; 
      when others => 
        return CHAR(ARR, TSTRING.FIRST + 1); 
    end case; 
  end MYESC; 


  -- otoi - convert an octal digit string to an integer value

  function OTOI(STR : in VSTRING) return CHARACTER is 
    TOTAL : INTEGER := 0; 
    CNT   : INTEGER := TSTRING.FIRST; 
  begin
    while (CNT <= TSTRING.LEN(STR)) loop
      TOTAL := TOTAL*8; 
      TOTAL := TOTAL + CHARACTER'POS(CHAR(STR, CNT)) - CHARACTER'POS('0'); 
      CNT := CNT + 1; 
    end loop; 
    return CHARACTER'VAL(TOTAL); 
  end OTOI; 


  -- readable_form - return the the human-readable form of a character
  --
  -- The returned string is in static storage.

  function READABLE_FORM(C : in CHARACTER) return VSTRING is 
  begin
    if ((CHARACTER'POS(C) >= 0 and CHARACTER'POS(C) < 32) or (C = ASCII.DEL))
      then 
      case C is 
        when ASCII.LF => 
          return (VSTR("\n")); 

        -- Newline
        when ASCII.HT => 
          return (VSTR("\t")); 

        -- Horizontal Tab
        when ASCII.FF => 
          return (VSTR("\f")); 

        -- Form Feed
        when ASCII.CR => 
          return (VSTR("\r")); 

        -- Carriage Return
        when ASCII.BS => 
          return (VSTR("\b")); 

        -- Backspace
        when others => 
          return VSTR("\" & INTEGER'IMAGE(CHARACTER'POS(C))); 
      end case; 
    elsif (C = ' ') then 
      return VSTR("' '"); 
    else 
      return VSTR(C); 
    end if; 
  end READABLE_FORM; 

  -- transition_struct_out - output a yy_trans_info structure
  --
  -- outputs the yy_trans_info structure with the two elements, element_v and
  -- element_n.  Formats the output with spaces and carriage returns.

  procedure TRANSITION_STRUCT_OUT(ELEMENT_V, ELEMENT_N : in INTEGER) is 
  begin
    INT_IO.PUT(ELEMENT_V, 7); 
    TEXT_IO.PUT(", "); 
    INT_IO.PUT(ELEMENT_N, 5); 
    TEXT_IO.PUT(","); 
    DATAPOS := DATAPOS + TRANS_STRUCT_PRINT_LENGTH; 

    if (DATAPOS >= 75) then 
      TEXT_IO.NEW_LINE; 

      DATALINE := DATALINE + 1; 
      if (DATALINE mod 10 = 0) then 
        TEXT_IO.NEW_LINE; 
      end if; 

      DATAPOS := 0; 
    end if; 
  end TRANSITION_STRUCT_OUT; 

  function SET_YY_TRAILING_HEAD_MASK(SRC : in INTEGER) return INTEGER is 
  begin
    if (CHECK_YY_TRAILING_HEAD_MASK(SRC) = 0) then 
      return SRC + YY_TRAILING_HEAD_MASK; 
    else 
      return SRC; 
    end if; 
  end SET_YY_TRAILING_HEAD_MASK; 

  function CHECK_YY_TRAILING_HEAD_MASK(SRC : in INTEGER) return INTEGER is 
  begin
    if (SRC >= YY_TRAILING_HEAD_MASK) then 
      return YY_TRAILING_HEAD_MASK; 
    else 
      return 0; 
    end if; 
  end CHECK_YY_TRAILING_HEAD_MASK; 

  function SET_YY_TRAILING_MASK(SRC : in INTEGER) return INTEGER is 
  begin
    if (CHECK_YY_TRAILING_MASK(SRC) = 0) then 
      return SRC + YY_TRAILING_MASK; 
    else 
      return SRC; 
    end if; 
  end SET_YY_TRAILING_MASK; 

  function CHECK_YY_TRAILING_MASK(SRC : in INTEGER) return INTEGER is 
  begin

-- this test is whether both bits are on, or whether onlyy TRAIL_MASK is set
    if ((SRC >= YY_TRAILING_HEAD_MASK + YY_TRAILING_MASK) or ((
      CHECK_YY_TRAILING_HEAD_MASK(SRC) = 0) and (SRC >= YY_TRAILING_MASK)))
      then 
      return YY_TRAILING_MASK; 
    else 
      return 0; 
    end if; 
  end CHECK_YY_TRAILING_MASK; 

  function ISLOWER(C : in CHARACTER) return BOOLEAN is 
  begin
    return (C in 'a' .. 'z'); 
  end ISLOWER; 


  function ISUPPER(C : in CHARACTER) return BOOLEAN is 
  begin
    return (C in 'A' .. 'Z'); 
  end ISUPPER; 

  function ISDIGIT(C : in CHARACTER) return BOOLEAN is 
  begin
    return (C in '0' .. '9'); 
  end ISDIGIT; 

  function TOLOWER(C : in INTEGER) return INTEGER is 
  begin
    return C - CHARACTER'POS('A') + CHARACTER'POS('a'); 
  end TOLOWER; 

  procedure SYNERR(STR : in STRING) is 
    use TEXT_IO; 
  begin
    SYNTAXERROR := TRUE; 
    TEXT_IO.PUT(STANDARD_ERROR, "Syntax error at line "); 
    INT_IO.PUT(STANDARD_ERROR, LINENUM); 
    TEXT_IO.PUT(STANDARD_ERROR, STR); 
    TEXT_IO.NEW_LINE(STANDARD_ERROR); 
  end SYNERR; 

end MISC; 
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- This software was developed by John Self of the Arcadia project
-- at the University of California, Irvine.
--
-- 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.

-- TITLE  miscellaneous aflex routines
-- AUTHOR: John Self (UCI)
-- DESCRIPTION
-- NOTES contains functions used in various places throughout aflex.
-- $Header: /co/ua/self/arcadia/aflex/ada/src/RCS/miscS.a,v 1.9 90/01/12 15:20:19 self Exp Locker: self $ 

with MISC_DEFS, TSTRING, TEXT_IO; 
package MISC is 
  use MISC_DEFS; 
  use TSTRING; 
  use TEXT_IO; 
  procedure ACTION_OUT; 
  procedure BUBBLE(V : in INT_PTR; 
                   N : in INTEGER); 
  function CLOWER(C : in INTEGER) return INTEGER; 
  procedure CSHELL(V : in out CHAR_ARRAY; 
                   N : in INTEGER); 
  procedure DATAEND; 
  procedure DATAFLUSH; 
  procedure DATAFLUSH(FILE : in FILE_TYPE); 
  function AFLEX_GETTIME return VSTRING; 
  procedure AFLEXERROR(MSG : in VSTRING); 
  procedure AFLEXERROR(MSG : in STRING); 
  function ALL_UPPER(STR : in VSTRING) return BOOLEAN; 
  function ALL_LOWER(STR : in VSTRING) return BOOLEAN; 
  procedure AFLEXFATAL(MSG : in VSTRING); 
  procedure AFLEXFATAL(MSG : in STRING); 
  procedure LINE_DIRECTIVE_OUT; 
  procedure LINE_DIRECTIVE_OUT(OUTPUT_FILE_NAME : in FILE_TYPE); 
  procedure MK2DATA(VALUE : in INTEGER); 
  procedure MK2DATA(FILE  : in FILE_TYPE; 
                    VALUE : in INTEGER); 
  procedure MKDATA(VALUE : in INTEGER); 
  function MYCTOI(NUM_ARRAY : in VSTRING) return INTEGER; 
  function MYESC(ARR : in VSTRING) return CHARACTER; 
  function OTOI(STR : in VSTRING) return CHARACTER; 
  function READABLE_FORM(C : in CHARACTER) return VSTRING; 
  procedure SYNERR(STR : in STRING); 
  procedure TRANSITION_STRUCT_OUT(ELEMENT_V, ELEMENT_N : in INTEGER); 
  function SET_YY_TRAILING_HEAD_MASK(SRC : in INTEGER) return INTEGER; 
  function CHECK_YY_TRAILING_HEAD_MASK(SRC : in INTEGER) return INTEGER; 
  function SET_YY_TRAILING_MASK(SRC : in INTEGER) return INTEGER; 
  function CHECK_YY_TRAILING_MASK(SRC : in INTEGER) return INTEGER; 
  function ISLOWER(C : in CHARACTER) return BOOLEAN; 
  function ISUPPER(C : in CHARACTER) return BOOLEAN; 
  function ISDIGIT(C : in CHARACTER) return BOOLEAN; 
  function TOLOWER(C : in INTEGER) return INTEGER; 
  function BASENAME return VSTRING; 
end MISC; 
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- This software was developed by John Self of the Arcadia project
-- at the University of California, Irvine.
--
-- 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.

-- TITLE miscellaneous definitions
-- AUTHOR: John Self (UCI)
-- DESCRIPTION contains all global variables used in aflex.
--             also some subprograms which are commonly used.
-- NOTES The real purpose of this file is to contain all miscellaneous
--       items (functions, MACROS, variables definitions) which were at the
--       top level of flex.
-- $Header: /co/ua/self/arcadia/aflex/ada/src/RCS/misc_defsB.a,v 1.5 90/01/12 15:20:21 self Exp Locker: self $ 

package body MISC_DEFS is 

-- returns true if an nfa state has an epsilon out-transition slot
-- that can be used.  This definition is currently not used.

  function FREE_EPSILON(STATE : in INTEGER) return BOOLEAN is 
  begin
    return ((TRANSCHAR(STATE) = SYM_EPSILON) and (TRANS2(STATE) = NO_TRANSITION)
      and (FINALST(STATE) /= STATE)); 
  end FREE_EPSILON; 

  -- returns true if an nfa state has an epsilon out-transition character
  -- and both slots are free

  function SUPER_FREE_EPSILON(STATE : in INTEGER) return BOOLEAN is 
  begin
    return ((TRANSCHAR(STATE) = SYM_EPSILON) and (TRANS1(STATE) = NO_TRANSITION)
      ); 
  end SUPER_FREE_EPSILON; 

  function ALLOCATE_INTEGER_ARRAY(SIZE : in INTEGER) return INT_PTR is 
  begin
    return new UNBOUNDED_INT_ARRAY(0 .. SIZE); 
  end ALLOCATE_INTEGER_ARRAY; 

  procedure REALLOCATE_INTEGER_ARRAY(ARR  : in out INT_PTR; 
                                     SIZE : in INTEGER) is 
    NEW_ARR : INT_PTR; 
  begin
    NEW_ARR := ALLOCATE_INTEGER_ARRAY(SIZE); 
    NEW_ARR(0 .. ARR'LAST) := ARR(0 .. ARR'LAST); 
    ARR := NEW_ARR; 
  end REALLOCATE_INTEGER_ARRAY; 

  procedure REALLOCATE_STATE_ENUM_ARRAY(ARR  : in out STATE_ENUM_PTR; 
                                        SIZE : in INTEGER) is 
    NEW_ARR : STATE_ENUM_PTR; 
  begin
    NEW_ARR := ALLOCATE_STATE_ENUM_ARRAY(SIZE); 
    NEW_ARR(0 .. ARR'LAST) := ARR(0 .. ARR'LAST); 
    ARR := NEW_ARR; 
  end REALLOCATE_STATE_ENUM_ARRAY; 

  procedure REALLOCATE_RULE_ENUM_ARRAY(ARR  : in out RULE_ENUM_PTR; 
                                       SIZE : in INTEGER) is 
    NEW_ARR : RULE_ENUM_PTR; 
  begin
    NEW_ARR := ALLOCATE_RULE_ENUM_ARRAY(SIZE); 
    NEW_ARR(0 .. ARR'LAST) := ARR(0 .. ARR'LAST); 
    ARR := NEW_ARR; 
  end REALLOCATE_RULE_ENUM_ARRAY; 

  function ALLOCATE_INT_PTR_ARRAY(SIZE : in INTEGER) return INT_STAR_PTR is 
  begin
    return new UNBOUNDED_INT_STAR_ARRAY(0 .. SIZE); 
  end ALLOCATE_INT_PTR_ARRAY; 

  function ALLOCATE_RULE_ENUM_ARRAY(SIZE : in INTEGER) return RULE_ENUM_PTR is 
  begin
    return new UNBOUNDED_RULE_ENUM_ARRAY(0 .. SIZE); 
  end ALLOCATE_RULE_ENUM_ARRAY; 

  function ALLOCATE_STATE_ENUM_ARRAY(SIZE : in INTEGER) return STATE_ENUM_PTR
    is 
  begin
    return new UNBOUNDED_STATE_ENUM_ARRAY(0 .. SIZE); 
  end ALLOCATE_STATE_ENUM_ARRAY; 

  function ALLOCATE_BOOLEAN_ARRAY(SIZE : in INTEGER) return BOOLEAN_PTR is 
  begin
    return new BOOLEAN_ARRAY(0 .. SIZE); 
  end ALLOCATE_BOOLEAN_ARRAY; 

  function ALLOCATE_VSTRING_ARRAY(SIZE : in INTEGER) return VSTRING_PTR is 
  begin
    return new UNBOUNDED_VSTRING_ARRAY(0 .. SIZE); 
  end ALLOCATE_VSTRING_ARRAY; 

  function ALLOCATE_DFAACC_UNION(SIZE : in INTEGER) return DFAACC_PTR is 
  begin
    return new UNBOUNDED_DFAACC_ARRAY(0 .. SIZE); 
  end ALLOCATE_DFAACC_UNION; 

  procedure REALLOCATE_INT_PTR_ARRAY(ARR  : in out INT_STAR_PTR; 
                                     SIZE : in INTEGER) is 
    NEW_ARR : INT_STAR_PTR; 
  begin
    NEW_ARR := ALLOCATE_INT_PTR_ARRAY(SIZE); 
    NEW_ARR(0 .. ARR'LAST) := ARR(0 .. ARR'LAST); 
    ARR := NEW_ARR; 
  end REALLOCATE_INT_PTR_ARRAY; 

  procedure REALLOCATE_CHARACTER_ARRAY(ARR  : in out CHAR_PTR; 
                                       SIZE : in INTEGER) is 
    NEW_ARR : CHAR_PTR; 
  begin
    NEW_ARR := ALLOCATE_CHARACTER_ARRAY(SIZE); 
    NEW_ARR(0 .. ARR'LAST) := ARR(0 .. ARR'LAST); 
    ARR := NEW_ARR; 
  end REALLOCATE_CHARACTER_ARRAY; 

  procedure REALLOCATE_VSTRING_ARRAY(ARR  : in out VSTRING_PTR; 
                                     SIZE : in INTEGER) is 
    NEW_ARR : VSTRING_PTR; 
  begin
    NEW_ARR := ALLOCATE_VSTRING_ARRAY(SIZE); 
    NEW_ARR(0 .. ARR'LAST) := ARR(0 .. ARR'LAST); 
    ARR := NEW_ARR; 
  end REALLOCATE_VSTRING_ARRAY; 

  function ALLOCATE_CHARACTER_ARRAY(SIZE : in INTEGER) return CHAR_PTR is 
  begin
    return new CHAR_ARRAY(0 .. SIZE); 
  end ALLOCATE_CHARACTER_ARRAY; 

  procedure REALLOCATE_DFAACC_UNION(ARR  : in out DFAACC_PTR; 
                                    SIZE : in INTEGER) is 
    NEW_ARR : DFAACC_PTR; 
  begin
    NEW_ARR := ALLOCATE_DFAACC_UNION(SIZE); 
    NEW_ARR(0 .. ARR'LAST) := ARR(0 .. ARR'LAST); 
    ARR := NEW_ARR; 
  end REALLOCATE_DFAACC_UNION; 

  procedure REALLOCATE_BOOLEAN_ARRAY(ARR  : in out BOOLEAN_PTR; 
                                     SIZE : in INTEGER) is 
    NEW_ARR : BOOLEAN_PTR; 
  begin
    NEW_ARR := ALLOCATE_BOOLEAN_ARRAY(SIZE); 
    NEW_ARR(0 .. ARR'LAST) := ARR(0 .. ARR'LAST); 
    ARR := NEW_ARR; 
  end REALLOCATE_BOOLEAN_ARRAY; 

  function MAX(X, Y : in INTEGER) return INTEGER is 
  begin
    if (X > Y) then 
      return X; 
    else 
      return Y; 
    end if; 
  end MAX; 

  function MIN(X, Y : in INTEGER) return INTEGER is 
  begin
    if (X < Y) then 
      return X; 
    else 
      return Y; 
    end if; 
  end MIN; 

end MISC_DEFS; 
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- This software was developed by John Self of the Arcadia project
-- at the University of California, Irvine.
--
-- 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.

-- TITLE miscellaneous definitions
-- AUTHOR: John Self (UCI)
-- DESCRIPTION contains all global variables used in aflex.
--             also some subprograms which are commonly used.
-- NOTES The real purpose of this file is to contain all miscellaneous
--       items (functions, MACROS, variables definitions) which were at the
--       top level of flex.
-- $Header: /co/ua/self/arcadia/alex/ada/RCS/misc_defsS.a,v 1.8 90/01/04 13:39:
-- 33 self Exp Locker: self $ 

with TEXT_IO, TSTRING;
use TEXT_IO, TSTRING;

package MISC_DEFS is

  -- various definitions that were in parse.y
  PAT, SCNUM, EPS, HEADCNT, TRAILCNT, ANYCCL, LASTCHAR, ACTVP, RULELEN : INTEGER
    ;
  TRLCONTXT, XCLUFLG, CCLSORTED, VARLENGTH, VARIABLE_TRAIL_RULE : BOOLEAN;

  MADEANY : BOOLEAN := FALSE;  -- whether we've made the '.' character class 
  PREVIOUS_CONTINUED_ACTION : BOOLEAN; -- whether the previous rule's action wa
                                       -- s '|'

  -- maximum line length we'll have to deal with 
  MAXLINE : constant INTEGER := 1024;

  -- These typees are needed for the various allocators.
  type UNBOUNDED_INT_ARRAY is array ( INTEGER range <> ) of INTEGER;
  type INT_PTR is access UNBOUNDED_INT_ARRAY;
  type INT_STAR is access INTEGER;
  type UNBOUNDED_INT_STAR_ARRAY is array ( INTEGER range <> ) of INT_PTR;
  type INT_STAR_PTR is access UNBOUNDED_INT_STAR_ARRAY;
  type UNBOUNDED_VSTRING_ARRAY is array ( INTEGER range <> ) of VSTRING;
  type VSTRING_PTR is access UNBOUNDED_VSTRING_ARRAY;
  type BOOLEAN_ARRAY is array ( INTEGER range <> ) of BOOLEAN;
  type BOOLEAN_PTR is access BOOLEAN_ARRAY;
  type CHAR_ARRAY is array ( INTEGER range <> ) of CHARACTER;
  type CHAR_PTR is access CHAR_ARRAY;

  -- different types of states; values are useful as masks, as well, for
  -- routines like check_trailing_context()

  type STATE_ENUM is (STATE_NORMAL, STATE_TRAILING_CONTEXT);

  type UNBOUNDED_STATE_ENUM_ARRAY is array ( INTEGER range <> ) of STATE_ENUM;
  type STATE_ENUM_PTR is access UNBOUNDED_STATE_ENUM_ARRAY;

  -- different types of rules
  type RULE_ENUM is (RULE_NORMAL, RULE_VARIABLE);

  type UNBOUNDED_RULE_ENUM_ARRAY is array ( INTEGER range <> ) of RULE_ENUM;
  type RULE_ENUM_PTR is access UNBOUNDED_RULE_ENUM_ARRAY;

  type DFAACC_TYPE is
    record
      DFAACC_SET : INT_PTR;
      DFAACC_STATE : INTEGER;
    end record;

  type UNBOUNDED_DFAACC_ARRAY is array ( INTEGER range <> ) of DFAACC_TYPE;
  type DFAACC_PTR is access UNBOUNDED_DFAACC_ARRAY;

  -- maximum size of file name 

  FILENAMESIZE : constant INTEGER := 1024;

  function MIN (X, Y : in INTEGER) return INTEGER;
  function MAX (X, Y : in INTEGER) return INTEGER;

  -- special chk[] values marking the slots taking by end-of-buffer and action
  -- numbers

  EOB_POSITION : constant INTEGER := - 1;
  ACTION_POSITION : constant INTEGER := - 2;

  -- number of data items per line for -f output
  NUMDATAITEMS : constant INTEGER := 10;

  -- number of lines of data in -f output before inserting a blank line for
  -- readability.

  NUMDATALINES : constant INTEGER := 10;

  -- transition_struct_out() definitions
  TRANS_STRUCT_PRINT_LENGTH : constant INTEGER := 15;

  -- returns true if an nfa state has an epsilon out-transition slot
  -- that can be used.  This definition is currently not used.

  function FREE_EPSILON ( STATE : in INTEGER) return BOOLEAN;

  -- returns true if an nfa state has an epsilon out-transition character
  -- and both slots are free

  function SUPER_FREE_EPSILON (STATE : in INTEGER) return BOOLEAN;

  -- maximum number of NFA states that can comprise a DFA state.  It's real
  -- big because if there's a lot of rules, the initial state will have a
  -- huge epsilon closure.

  INITIAL_MAX_DFA_SIZE : constant INTEGER := 750;
  MAX_DFA_SIZE_INCREMENT : constant INTEGER := 750;

  -- a note on the following masks.  They are used to mark accepting numbers
  -- as being special.  As such, they implicitly limit the number of accepting
  -- numbers (i.e., rules) because if there are too many rules the rule numbers
  -- will overload the mask bits.  Fortunately, this limit is \large/ (0x2000 ==
  -- 8192) so unlikely to actually cause any problems.  A check is made in
  -- new_rule() to ensure that this limit is not reached.

  -- mask to mark a trailing context accepting number
  -- #define YY_TRAILING_MASK 0x2000
  YY_TRAILING_MASK : constant INTEGER := 16#2000#;


  -- mask to mark the accepting number of the "head" of a trailing context rule
  -- #define YY_TRAILING_HEAD_MASK 0x4000
  YY_TRAILING_HEAD_MASK : constant INTEGER := 16#4000#;

  -- maximum number of rules, as outlined in the above note
  MAX_RULE : constant INTEGER := YY_TRAILING_MASK - 1;


  -- NIL must be 0.  If not, its special meaning when making equivalence classes
  -- (it marks the representative of a given e.c.) will be unidentifiable

  NIL : constant INTEGER := 0;

  JAM : constant INTEGER := - 1; -- to mark a missing DFA transition 
  NO_TRANSITION : constant INTEGER := NIL;
  UNIQUE : constant INTEGER := - 1; -- marks a symbol as an e.c. representative
  INFINITY : constant INTEGER := - 1; -- for x{5,} constructions

  -- size of input alphabet - should be size of ASCII set
  CSIZE : constant INTEGER := 127;

  INITIAL_MAX_CCLS : constant INTEGER := 100; -- max number of unique character
                                              --  classes
  MAX_CCLS_INCREMENT : constant INTEGER := 100;

  -- size of table holding members of character classes
  INITIAL_MAX_CCL_TBL_SIZE : constant INTEGER := 500;
  MAX_CCL_TBL_SIZE_INCREMENT : constant INTEGER := 250;
  INITIAL_MAX_RULES : constant INTEGER := 100;
  -- default maximum number of rules
  MAX_RULES_INCREMENT : constant INTEGER := 100;

  INITIAL_MNS : constant INTEGER := 2000; -- default maximum number of nfa stat
                                          -- es
  MNS_INCREMENT : constant INTEGER := 1000; -- amount to bump above by if it's 
                                            -- not enough

  INITIAL_MAX_DFAS : constant INTEGER := 1000; -- default maximum number of dfa
                                               --  states
  MAX_DFAS_INCREMENT : constant INTEGER := 1000;

  JAMSTATE_CONST : constant INTEGER := - 32766; -- marks a reference to the sta
                                                -- te that always jams

  -- enough so that if it's subtracted from an NFA state number, the result
  -- is guaranteed to be negative

  MARKER_DIFFERENCE : constant INTEGER := 32000;
  MAXIMUM_MNS : constant INTEGER := 31999;

  -- maximum number of nxt/chk pairs for non-templates
  INITIAL_MAX_XPAIRS : constant INTEGER := 2000;
  MAX_XPAIRS_INCREMENT : constant INTEGER := 2000;

  -- maximum number of nxt/chk pairs needed for templates
  INITIAL_MAX_TEMPLATE_XPAIRS : constant INTEGER := 2500;
  MAX_TEMPLATE_XPAIRS_INCREMENT : constant INTEGER := 2500;

  SYM_EPSILON : constant INTEGER := 0; -- to mark transitions on the symbol eps
                                       -- ilon

  INITIAL_MAX_SCS : constant INTEGER := 40; -- maximum number of start conditio
                                            -- ns
  MAX_SCS_INCREMENT : constant INTEGER := 40; -- amount to bump by if it's not 
                                              -- enough

  ONE_STACK_SIZE : constant INTEGER := 500; -- stack of states with only one ou
                                            -- t-transition
  SAME_TRANS : constant INTEGER := - 1; -- transition is the same as "default" 
                                        -- entry for state

  -- the following percentages are used to tune table compression:
  --
  -- the percentage the number of out-transitions a state must be of the
  -- number of equivalence classes in order to be considered for table
  -- compaction by using protos

  PROTO_SIZE_PERCENTAGE : constant INTEGER := 15;

  -- the percentage the number of homogeneous out-transitions of a state
  -- must be of the number of total out-transitions of the state in order
  -- that the state's transition table is first compared with a potential 
  -- template of the most common out-transition instead of with the first
  --proto in the proto queue

  CHECK_COM_PERCENTAGE : constant INTEGER := 50;

  -- the percentage the number of differences between a state's transition
  -- table and the proto it was first compared with must be of the total
  -- number of out-transitions of the state in order to keep the first
  -- proto as a good match and not search any further

  FIRST_MATCH_DIFF_PERCENTAGE : constant INTEGER := 10;

  -- the percentage the number of differences between a state's transition
  -- table and the most similar proto must be of the state's total number
  -- of out-transitions to use the proto as an acceptable close match

  ACCEPTABLE_DIFF_PERCENTAGE : constant INTEGER := 50;

  -- the percentage the number of homogeneous out-transitions of a state
  -- must be of the number of total out-transitions of the state in order
  -- to consider making a template from the state

  TEMPLATE_SAME_PERCENTAGE : constant INTEGER := 60;

  -- the percentage the number of differences between a state's transition
  -- table and the most similar proto must be of the state's total number
  -- of out-transitions to create a new proto from the state

  NEW_PROTO_DIFF_PERCENTAGE : constant INTEGER := 20;

  -- the percentage the total number of out-transitions of a state must be
  -- of the number of equivalence classes in order to consider trying to
  -- fit the transition table into "holes" inside the nxt/chk table.

  INTERIOR_FIT_PERCENTAGE : constant INTEGER := 15;

  -- size of region set aside to cache the complete transition table of
  -- protos on the proto queue to enable quick comparisons

  PROT_SAVE_SIZE : constant INTEGER := 2000;

  MSP : constant INTEGER := 50; -- maximum number of saved protos (protos on th
                                -- e proto queue)

  -- maximum number of out-transitions a state can have that we'll rummage
  -- around through the interior of the internal fast table looking for a
  -- spot for it

  MAX_XTIONS_FULL_INTERIOR_FIT : constant INTEGER := 4;

  -- maximum number of rules which will be reported as being associated
  -- with a DFA state

  MAX_ASSOC_RULES : constant INTEGER := 100;

  -- number that, if used to subscript an array, has a good chance of producing
  -- an error; should be small enough to fit into a short

  BAD_SUBSCRIPT : constant INTEGER := - 32767;

  -- Declarations for global variables.

  -- variables for symbol tables:
  -- sctbl - start-condition symbol table
  -- ndtbl - name-definition symbol table
  -- ccltab - character class text symbol table

  type HASH_ENTRY;
  type HASH_LINK is access HASH_ENTRY;
  type HASH_ENTRY is
    record
      PREV, NEXT : HASH_LINK;
      NAME, STR_VAL : VSTRING;
      INT_VAL : INTEGER;
    end record;

  type HASH_TABLE is array ( INTEGER range <> ) of HASH_LINK;

  NAME_TABLE_HASH_SIZE : constant INTEGER := 101;
  START_COND_HASH_SIZE : constant INTEGER := 101;
  CCL_HASH_SIZE : constant INTEGER := 101;

  subtype NDTBL_TYPE is HASH_TABLE (0 .. NAME_TABLE_HASH_SIZE - 1);
  NDTBL : NDTBL_TYPE;
  subtype SCTBL_TYPE is HASH_TABLE (0 .. START_COND_HASH_SIZE - 1);
  SCTBL : SCTBL_TYPE;
  subtype CCLTAB_TYPE is HASH_TABLE (0 .. CCL_HASH_SIZE);
  CCLTAB : CCLTAB_TYPE;

  -- variables for flags:
  -- printstats - if true (-v), dump statistics
  -- syntaxerror - true if a syntax error has been found
  -- eofseen - true if we've seen an eof in the input file
  -- ddebug - if true (-d), make a "debug" scanner
  -- trace - if true (-T), trace processing
  -- spprdflt - if true (-s), suppress the default rule
  -- interactive - if true (-I), generate an interactive scanner
  -- caseins - if true (-i), generate a case-insensitive scanner
  -- useecs - if true (-ce flag), use equivalence classes
  -- fulltbl - if true (-cf flag), don't compress the DFA state table
  -- usemecs - if true (-cm flag), use meta-equivalence classes
  -- gen_line_dirs - if true (i.e., no -L flag), generate #line directives
  -- performance_report - if true (i.e., -p flag), generate a report relating
  --   to scanner performance
  -- backtrack_report - if true (i.e., -b flag), generate "lex.backtrack" file
  --   listing backtracking states
  -- continued_action - true if this rule's action is to "fall through" to
  --                    the next rule's action (i.e., the '|' action)

  PRINTSTATS, DDEBUG, SPPRDFLT,
  INTERACTIVE, CASEINS, USEECS, FULLTBL, USEMECS,
  GEN_LINE_DIRS, PERFORMANCE_REPORT, BACKTRACK_REPORT,
  TRACE, EOFSEEN, CONTINUED_ACTION : BOOLEAN;

  SYNTAXERROR : BOOLEAN;

  -- variables used in the aflex input routines:
  -- datapos - characters on current output line
  -- dataline - number of contiguous lines of data in current data
  --    statement.  Used to generate readable -f output
  -- skelfile - the skeleton file
  -- yyin - input file
  -- temp_action_file - temporary file to hold actions
  -- backtrack_file - file to summarize backtracking states to
  -- infilename - name of input file
  -- linenum - current input line number

  DATAPOS, DATALINE, LINENUM : INTEGER;

  SKELFILE, YYIN, TEMP_ACTION_FILE, BACKTRACK_FILE, DEF_FILE : FILE_TYPE;
  INFILENAME : VSTRING;

  -- variables for stack of states having only one out-transition:
  -- onestate - state number
  -- onesym - transition symbol
  -- onenext - target state
  -- onedef - default base entry
  -- onesp - stack pointer

  ONESTATE, ONESYM, ONENEXT, ONEDEF : array (0 .. ONE_STACK_SIZE - 1) of INTEGER
    ;
  ONESP : INTEGER;


  -- variables for nfa machine data:
  -- current_mns - current maximum on number of NFA states
  -- num_rules - number of the last accepting state; also is number of
  --             rules created so far
  -- current_max_rules - current maximum number of rules
  -- lastnfa - last nfa state number created
  -- firstst - physically the first state of a fragment
  -- lastst - last physical state of fragment
  -- finalst - last logical state of fragment
  -- transchar - transition character
  -- trans1 - transition state
  -- trans2 - 2nd transition state for epsilons
  -- accptnum - accepting number
  -- assoc_rule - rule associated with this NFA state (or 0 if none)
  -- state_type - a STATE_xxx type identifying whether the state is part
  --              of a normal rule, the leading state in a trailing context
  --              rule (i.e., the state which marks the transition from
  --              recognizing the text-to-be-matched to the beginning of
  --              the trailing context), or a subsequent state in a trailing
  --              context rule
  -- rule_type - a RULE_xxx type identifying whether this a a ho-hum
  --             normal rule or one which has variable head & trailing
  --             context
  -- rule_linenum - line number associated with rule

  CURRENT_MNS, NUM_RULES, CURRENT_MAX_RULES, LASTNFA : INTEGER;
  FIRSTST, LASTST, FINALST, TRANSCHAR, TRANS1, TRANS2 : INT_PTR;
  ACCPTNUM, ASSOC_RULE, RULE_LINENUM : INT_PTR;
  RULE_TYPE : RULE_ENUM_PTR;
  STATE_TYPE : STATE_ENUM_PTR;

  -- global holding current type of state we're making

  CURRENT_STATE_ENUM : STATE_ENUM;

  -- true if the input rules include a rule with both variable-length head
  -- and trailing context, false otherwise

  VARIABLE_TRAILING_CONTEXT_RULES : BOOLEAN;


  -- variables for protos:
  -- numtemps - number of templates created
  -- numprots - number of protos created
  -- protprev - backlink to a more-recently used proto
  -- protnext - forward link to a less-recently used proto
  -- prottbl - base/def table entry for proto
  -- protcomst - common state of proto
  -- firstprot - number of the most recently used proto
  -- lastprot - number of the least recently used proto
  -- protsave contains the entire state array for protos

  NUMTEMPS, NUMPROTS, FIRSTPROT, LASTPROT : INTEGER;
  PROTPREV, PROTNEXT, PROTTBL, PROTCOMST : array (0 .. MSP - 1) of INTEGER;
  PROTSAVE : array (0 .. PROT_SAVE_SIZE - 1) of INTEGER;


  -- variables for managing equivalence classes:
  -- numecs - number of equivalence classes
  -- nextecm - forward link of Equivalence Class members
  -- ecgroup - class number or backward link of EC members
  -- nummecs - number of meta-equivalence classes (used to compress
  --   templates)
  -- tecfwd - forward link of meta-equivalence classes members
  -- * tecbck - backward link of MEC's

  NUMECS, NUMMECS : INTEGER;
  subtype C_SIZE_ARRAY is UNBOUNDED_INT_ARRAY (0 .. CSIZE);
  type C_SIZE_BOOL_ARRAY is array (0 .. CSIZE) of BOOLEAN;
  NEXTECM, ECGROUP, TECFWD, TECBCK : C_SIZE_ARRAY;


  -- variables for start conditions:
  -- lastsc - last start condition created
  -- current_max_scs - current limit on number of start conditions
  -- scset - set of rules active in start condition
  -- scbol - set of rules active only at the beginning of line in a s.c.
  -- scxclu - true if start condition is exclusive
  -- sceof - true if start condition has EOF rule
  -- scname - start condition name
  -- actvsc - stack of active start conditions for the current rule

  LASTSC, CURRENT_MAX_SCS : INTEGER;
  SCSET, SCBOL : INT_PTR;
  SCXCLU, SCEOF : BOOLEAN_PTR;
  ACTVSC : INT_PTR;
  SCNAME : VSTRING_PTR;


  -- variables for dfa machine data:
  -- current_max_dfa_size - current maximum number of NFA states in DFA
  -- current_max_xpairs - current maximum number of non-template xtion pairs
  -- current_max_template_xpairs - current maximum number of template pairs
  -- current_max_dfas - current maximum number DFA states
  -- lastdfa - last dfa state number created
  -- nxt - state to enter upon reading character
  -- chk - check value to see if "nxt" applies
  -- tnxt - internal nxt table for templates
  -- base - offset into "nxt" for given state
  -- def - where to go if "chk" disallows "nxt" entry
  -- tblend - last "nxt/chk" table entry being used
  -- firstfree - first empty entry in "nxt/chk" table
  -- dss - nfa state set for each dfa
  -- dfasiz - size of nfa state set for each dfa
  -- dfaacc - accepting set for each dfa state (or accepting number, if
  --    -r is not given)
  -- accsiz - size of accepting set for each dfa state
  -- dhash - dfa state hash value
  -- numas - number of DFA accepting states created; note that this
  --    is not necessarily the same value as num_rules, which is the analogous
  --    value for the NFA
  -- numsnpairs - number of state/nextstate transition pairs
  -- jambase - position in base/def where the default jam table starts
  -- jamstate - state number corresponding to "jam" state
  -- end_of_buffer_state - end-of-buffer dfa state number

  CURRENT_MAX_DFA_SIZE, CURRENT_MAX_XPAIRS : INTEGER;
  CURRENT_MAX_TEMPLATE_XPAIRS, CURRENT_MAX_DFAS : INTEGER;
  LASTDFA, LASTTEMP : INTEGER;
  NXT, CHK, TNXT : INT_PTR;
  BASE, DEF , DFASIZ : INT_PTR;
  TBLEND, FIRSTFREE : INTEGER;
  DSS : INT_STAR_PTR;
  DFAACC : DFAACC_PTR;

  -- type declaration for dfaacc_type moved above

  ACCSIZ, DHASH : INT_PTR;
  END_OF_BUFFER_STATE, NUMSNPAIRS, JAMBASE, JAMSTATE, NUMAS : INTEGER;

  -- variables for ccl information:
  -- lastccl - ccl index of the last created ccl
  -- current_maxccls - current limit on the maximum number of unique ccl's
  -- cclmap - maps a ccl index to its set pointer
  -- ccllen - gives the length of a ccl
  -- cclng - true for a given ccl if the ccl is negated
  -- cclreuse - counts how many times a ccl is re-used
  -- current_max_ccl_tbl_size - current limit on number of characters needed
  --	to represent the unique ccl's
  -- ccltbl - holds the characters in each ccl - indexed by cclmap

  CURRENT_MAX_CCL_TBL_SIZE, LASTCCL, CURRENT_MAXCCLS, CCLREUSE : INTEGER;
  CCLMAP, CCLLEN, CCLNG : INT_PTR;

  CCLTBL : CHAR_PTR;


  -- variables for miscellaneous information:
  -- starttime - real-time when we started
  -- endtime - real-time when we ended
  -- nmstr - last NAME scanned by the scanner
  -- sectnum - section number currently being parsed
  -- nummt - number of empty nxt/chk table entries
  -- hshcol - number of hash collisions detected by snstods
  -- dfaeql - number of times a newly created dfa was equal to an old one
  -- numeps - number of epsilon NFA states created
  -- eps2 - number of epsilon states which have 2 out-transitions
  -- num_reallocs - number of times it was necessary to realloc() a group
  --		  of arrays
  -- tmpuses - number of DFA states that chain to templates
  -- totnst - total number of NFA states used to make DFA states
  -- peakpairs - peak number of transition pairs we had to store internally
  -- numuniq - number of unique transitions
  -- numdup - number of duplicate transitions
  -- hshsave - number of hash collisions saved by checking number of states
  -- num_backtracking - number of DFA states requiring back-tracking
  -- bol_needed - whether scanner needs beginning-of-line recognition

  NMSTR : VSTRING;
  SECTNUM, NUMMT, HSHCOL, DFAEQL, NUMEPS, EPS2, NUM_REALLOCS : INTEGER;
  TMPUSES, TOTNST, PEAKPAIRS, NUMUNIQ, NUMDUP, HSHSAVE : INTEGER;
  NUM_BACKTRACKING : INTEGER;
  BOL_NEEDED : BOOLEAN;

  function ALLOCATE_INTEGER_ARRAY (SIZE : in INTEGER) return INT_PTR;

  function ALLOCATE_INT_PTR_ARRAY (SIZE : in INTEGER) return INT_STAR_PTR;



  function ALLOCATE_VSTRING_ARRAY (SIZE : in INTEGER) return VSTRING_PTR;

  function ALLOCATE_DFAACC_UNION (SIZE : in INTEGER) return DFAACC_PTR;

  function  ALLOCATE_CHARACTER_ARRAY (SIZE : in INTEGER) return CHAR_PTR;

  function ALLOCATE_RULE_ENUM_ARRAY (SIZE : in INTEGER) return RULE_ENUM_PTR;

  function ALLOCATE_STATE_ENUM_ARRAY (SIZE : in INTEGER) return STATE_ENUM_PTR;

  function ALLOCATE_BOOLEAN_ARRAY (SIZE : in INTEGER) return BOOLEAN_PTR;

  procedure REALLOCATE_INTEGER_ARRAY (ARR : in out INT_PTR;
       SIZE : in INTEGER);

  procedure REALLOCATE_INT_PTR_ARRAY (ARR : in out INT_STAR_PTR;
       SIZE : in INTEGER);

  procedure REALLOCATE_VSTRING_ARRAY (ARR : in out VSTRING_PTR;
        SIZE : in INTEGER);

  procedure REALLOCATE_DFAACC_UNION (ARR : in out DFAACC_PTR;
      SIZE : in INTEGER);

  procedure REALLOCATE_CHARACTER_ARRAY (ARR : in out CHAR_PTR;
       SIZE : in INTEGER);

  procedure REALLOCATE_RULE_ENUM_ARRAY (ARR : in out RULE_ENUM_PTR;
       SIZE : in INTEGER);

  procedure REALLOCATE_STATE_ENUM_ARRAY (ARR : in out STATE_ENUM_PTR;
       SIZE : in INTEGER);

  procedure REALLOCATE_BOOLEAN_ARRAY (ARR : in out BOOLEAN_PTR;
       SIZE : in INTEGER);

end MISC_DEFS;
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- This software was developed by John Self of the Arcadia project
-- at the University of California, Irvine.
--
-- 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.

-- TITLE NFA construction routines
-- AUTHOR: John Self (UCI)
-- DESCRIPTION builds the NFA.
-- NOTES this file mirrors flex as closely as possible.
-- $Header: /co/ua/self/arcadia/aflex/ada/src/RCS/nfaB.a,v 1.6 90/01/12 15:20:27 self Exp Locker: self $ 

with MISC_DEFS, NFA, MISC, ECS; 
with TSTRING, INT_IO, TEXT_IO, EXTERNAL_FILE_MANAGER; use MISC_DEFS, TSTRING, 
  EXTERNAL_FILE_MANAGER; 

package body NFA is 

-- add_accept - add an accepting state to a machine
--
-- accepting_number becomes mach's accepting number.

  procedure ADD_ACCEPT(MACH             : in out INTEGER; 
                       ACCEPTING_NUMBER : in INTEGER) is 
  -- hang the accepting number off an epsilon state.  if it is associated
  -- with a state that has a non-epsilon out-transition, then the state
  -- will accept BEFORE it makes that transition, i.e., one character
  -- too soon
    ASTATE : INTEGER; 
  begin
    if (TRANSCHAR(FINALST(MACH)) = SYM_EPSILON) then 
      ACCPTNUM(FINALST(MACH)) := ACCEPTING_NUMBER; 
    else 
      ASTATE := MKSTATE(SYM_EPSILON); 
      ACCPTNUM(ASTATE) := ACCEPTING_NUMBER; 
      MACH := LINK_MACHINES(MACH, ASTATE); 
    end if; 
  end ADD_ACCEPT; 


  -- copysingl - make a given number of copies of a singleton machine
  --
  --     newsng - a new singleton composed of num copies of singl
  --     singl  - a singleton machine
  --     num    - the number of copies of singl to be present in newsng

  function COPYSINGL(SINGL, NUM : in INTEGER) return INTEGER is 
    COPY : INTEGER; 
  begin
    COPY := MKSTATE(SYM_EPSILON); 

    for I in 1 .. NUM loop
      COPY := LINK_MACHINES(COPY, DUPMACHINE(SINGL)); 
    end loop; 

    return COPY; 
  end COPYSINGL; 


  -- dumpnfa - debugging routine to write out an nfa

  procedure DUMPNFA(STATE1 : in INTEGER) is 
    SYM, TSP1, TSP2, ANUM : INTEGER; 
    use TEXT_IO; 
  begin
    TEXT_IO.NEW_LINE(STANDARD_ERROR); 
    TEXT_IO.NEW_LINE(STANDARD_ERROR); 
    TEXT_IO.PUT(STANDARD_ERROR, 
      "********** beginning dump of nfa with start state "); 
    INT_IO.PUT(STANDARD_ERROR, STATE1, 0); 
    TEXT_IO.NEW_LINE(STANDARD_ERROR); 

    -- we probably should loop starting at firstst[state1] and going to
    -- lastst[state1], but they're not maintained properly when we "or"
    -- all of the rules together.  So we use our knowledge that the machine
    -- starts at state 1 and ends at lastnfa.
    for NS in 1 .. LASTNFA loop
      TEXT_IO.PUT(STANDARD_ERROR, "state # "); 
      INT_IO.PUT(STANDARD_ERROR, NS, 4); 
      TEXT_IO.PUT(ASCII.HT); 
      SYM := TRANSCHAR(NS); 
      TSP1 := TRANS1(NS); 
      TSP2 := TRANS2(NS); 
      ANUM := ACCPTNUM(NS); 

      INT_IO.PUT(STANDARD_ERROR, SYM, 5); 
      TEXT_IO.PUT(STANDARD_ERROR, ":    "); 
      INT_IO.PUT(STANDARD_ERROR, TSP1, 4); 
      TEXT_IO.PUT(STANDARD_ERROR, ","); 
      INT_IO.PUT(STANDARD_ERROR, TSP2, 4); 
      if (ANUM /= NIL) then 
        TEXT_IO.PUT(STANDARD_ERROR, "  ["); 
        INT_IO.PUT(STANDARD_ERROR, ANUM, 0); 
        TEXT_IO.PUT(STANDARD_ERROR, "]"); 
      end if; 
      TEXT_IO.NEW_LINE(STANDARD_ERROR); 
    end loop; 

    TEXT_IO.PUT(STANDARD_ERROR, "********** end of dump"); 
    TEXT_IO.NEW_LINE(STANDARD_ERROR); 
  end DUMPNFA; 

  -- dupmachine - make a duplicate of a given machine
  --
  --     copy - holds duplicate of mach
  --     mach - machine to be duplicated
  --
  -- note that the copy of mach is NOT an exact duplicate; rather, all the
  -- transition states values are adjusted so that the copy is self-contained,
  -- as the original should have been.
  --
  -- also note that the original MUST be contiguous, with its low and high
  -- states accessible by the arrays firstst and lastst

  function DUPMACHINE(MACH : in INTEGER) return INTEGER is 
    INIT, STATE_OFFSET : INTEGER; 
    STATE              : INTEGER := 0; 
    LAST               : INTEGER := LASTST(MACH); 
    I                  : INTEGER; 
  begin
    I := FIRSTST(MACH); 
    while (I <= LAST) loop
      STATE := MKSTATE(TRANSCHAR(I)); 

      if (TRANS1(I) /= NO_TRANSITION) then 
        MKXTION(FINALST(STATE), TRANS1(I) + STATE - I); 

        if ((TRANSCHAR(I) = SYM_EPSILON) and (TRANS2(I) /= NO_TRANSITION)) then 
          MKXTION(FINALST(STATE), TRANS2(I) + STATE - I); 
        end if; 
      end if; 

      ACCPTNUM(STATE) := ACCPTNUM(I); 
      I := I + 1; 
    end loop; 

    if (STATE = 0) then 
      MISC.AFLEXFATAL("empty machine in dupmachine()"); 
    end if; 

    STATE_OFFSET := STATE - I + 1; 

    INIT := MACH + STATE_OFFSET; 
    FIRSTST(INIT) := FIRSTST(MACH) + STATE_OFFSET; 
    FINALST(INIT) := FINALST(MACH) + STATE_OFFSET; 
    LASTST(INIT) := LASTST(MACH) + STATE_OFFSET; 

    return INIT; 
  end DUPMACHINE; 

  -- finish_rule - finish up the processing for a rule
  --
  -- An accepting number is added to the given machine.  If variable_trail_rule
  -- is true then the rule has trailing context and both the head and trail
  -- are variable size.  Otherwise if headcnt or trailcnt is non-zero then
  -- the machine recognizes a pattern with trailing context and headcnt is
  -- the number of characters in the matched part of the pattern, or zero
  -- if the matched part has variable length.  trailcnt is the number of
  -- trailing context characters in the pattern, or zero if the trailing
  -- context has variable length.

  procedure FINISH_RULE(MACH                : in INTEGER; 
                        VARIABLE_TRAIL_RULE : in BOOLEAN; 
                        HEADCNT, TRAILCNT   : in INTEGER) is 
    P_MACH : INTEGER; 
    use TEXT_IO; 
  begin
    P_MACH := MACH; 
    ADD_ACCEPT(P_MACH, NUM_RULES); 

    -- we did this in new_rule(), but it often gets the wrong
    -- number because we do it before we start parsing the current rule
    RULE_LINENUM(NUM_RULES) := LINENUM; 

    TEXT_IO.PUT(TEMP_ACTION_FILE, "when "); 
    INT_IO.PUT(TEMP_ACTION_FILE, NUM_RULES, 1); 
    TEXT_IO.PUT_LINE(TEMP_ACTION_FILE, " => "); 

    if (VARIABLE_TRAIL_RULE) then 
      RULE_TYPE(NUM_RULES) := RULE_VARIABLE; 

      if (PERFORMANCE_REPORT) then 
        TEXT_IO.PUT(STANDARD_ERROR, "Variable trailing context rule at line "); 
        INT_IO.PUT(STANDARD_ERROR, RULE_LINENUM(NUM_RULES), 1); 
        TEXT_IO.NEW_LINE(STANDARD_ERROR); 
      end if; 

      VARIABLE_TRAILING_CONTEXT_RULES := TRUE; 
    else 
      RULE_TYPE(NUM_RULES) := RULE_NORMAL; 

      if ((HEADCNT > 0) or (TRAILCNT > 0)) then 

        -- do trailing context magic to not match the trailing characters
        TEXT_IO.PUT_LINE(TEMP_ACTION_FILE, 
          "yy_ch_buf(yy_cp) := yy_hold_char; -- undo effects of setting up yytext"
          ); 

        if (HEADCNT > 0) then 
          TEXT_IO.PUT(TEMP_ACTION_FILE, " yy_cp := yy_bp + "); 
          INT_IO.PUT(TEMP_ACTION_FILE, HEADCNT, 1); 
          TEXT_IO.PUT_LINE(TEMP_ACTION_FILE, ";"); 
        else 
          TEXT_IO.PUT(TEMP_ACTION_FILE, "yy_cp := yy_cp - "); 
          INT_IO.PUT(TEMP_ACTION_FILE, TRAILCNT, 1); 
          TEXT_IO.PUT_LINE(TEMP_ACTION_FILE, ";"); 
        end if; 

        TEXT_IO.PUT_LINE(TEMP_ACTION_FILE, "yy_c_buf_p := yy_cp;"); 
        TEXT_IO.PUT_LINE(TEMP_ACTION_FILE, 
          "YY_DO_BEFORE_ACTION; -- set up yytext again"); 
      end if; 
    end if; 

    MISC.LINE_DIRECTIVE_OUT(TEMP_ACTION_FILE); 
  end FINISH_RULE; 

  -- link_machines - connect two machines together
  --
  --     new    - a machine constructed by connecting first to last
  --     first  - the machine whose successor is to be last
  --     last   - the machine whose predecessor is to be first
  --
  -- note: this routine concatenates the machine first with the machine
  --  last to produce a machine new which will pattern-match first first
  --  and then last, and will fail if either of the sub-patterns fails.
  --  FIRST is set to new by the operation.  last is unmolested.

  function LINK_MACHINES(FIRST, LAST : in INTEGER) return INTEGER is 
  begin
    if (FIRST = NIL) then 
      return LAST; 
    else 
      if (LAST = NIL) then 
        return FIRST; 
      else 
        MKXTION(FINALST(FIRST), LAST); 
        FINALST(FIRST) := FINALST(LAST); 
        LASTST(FIRST) := MAX(LASTST(FIRST), LASTST(LAST)); 
        FIRSTST(FIRST) := MIN(FIRSTST(FIRST), FIRSTST(LAST)); 
        return (FIRST); 
      end if; 
    end if; 
  end LINK_MACHINES; 


  -- mark_beginning_as_normal - mark each "beginning" state in a machine
--                            as being a "normal" (i.e., not trailing context-
  --                            associated) states
  --
  -- The "beginning" states are the epsilon closure of the first state

  procedure MARK_BEGINNING_AS_NORMAL(MACH : in INTEGER) is 
  begin
    case (STATE_TYPE(MACH)) is 
      when STATE_NORMAL => 

        -- oh, we've already visited here
        return; 

      when STATE_TRAILING_CONTEXT => 
        STATE_TYPE(MACH) := STATE_NORMAL; 

        if (TRANSCHAR(MACH) = SYM_EPSILON) then 
          if (TRANS1(MACH) /= NO_TRANSITION) then 
            MARK_BEGINNING_AS_NORMAL(TRANS1(MACH)); 
          end if; 

          if (TRANS2(MACH) /= NO_TRANSITION) then 
            MARK_BEGINNING_AS_NORMAL(TRANS2(MACH)); 
          end if; 
        end if; 
      when others => 
        MISC.AFLEXERROR("bad state type in mark_beginning_as_normal()"); 
    end case; 
  end MARK_BEGINNING_AS_NORMAL; 

  -- mkbranch - make a machine that branches to two machines
  --
  --     branch - a machine which matches either first's pattern or second's
--     first, second - machines whose patterns are to be or'ed (the | operator)
  --
  -- note that first and second are NEITHER destroyed by the operation.  Also,
  -- the resulting machine CANNOT be used with any other "mk" operation except
  -- more mkbranch's.  Compare with mkor()
  function MKBRANCH(FIRST, SECOND : in INTEGER) return INTEGER is 
    EPS : INTEGER; 
  begin
    if (FIRST = NO_TRANSITION) then 
      return SECOND; 
    else 
      if (SECOND = NO_TRANSITION) then 
        return FIRST; 
      end if; 
    end if; 

    EPS := MKSTATE(SYM_EPSILON); 

    MKXTION(EPS, FIRST); 
    MKXTION(EPS, SECOND); 

    return EPS; 
  end MKBRANCH; 


  -- mkclos - convert a machine into a closure
  --
  --     new - a new state which matches the closure of "state"

  function MKCLOS(STATE : in INTEGER) return INTEGER is 
  begin
    return NFA.MKOPT(MKPOSCL(STATE)); 
  end MKCLOS; 


  -- mkopt - make a machine optional
  --
  --     new  - a machine which optionally matches whatever mach matched
  --     mach - the machine to make optional
  --
  -- notes:
  --     1. mach must be the last machine created
  --     2. mach is destroyed by the call

  function MKOPT(MACH : in INTEGER) return INTEGER is 
    EPS    : INTEGER; 
    RESULT : INTEGER; 
  begin
    RESULT := MACH; 
    if (not SUPER_FREE_EPSILON(FINALST(RESULT))) then 
      EPS := NFA.MKSTATE(SYM_EPSILON); 
      RESULT := NFA.LINK_MACHINES(RESULT, EPS); 
    end if; 

    -- can't skimp on the following if FREE_EPSILON(mach) is true because
    -- some state interior to "mach" might point back to the beginning
    -- for a closure
    EPS := NFA.MKSTATE(SYM_EPSILON); 
    RESULT := NFA.LINK_MACHINES(EPS, RESULT); 

    NFA.MKXTION(RESULT, FINALST(RESULT)); 

    return RESULT; 
  end MKOPT; 


  -- mkor - make a machine that matches either one of two machines
  --
  --     new - a machine which matches either first's pattern or second's
--     first, second - machines whose patterns are to be or'ed (the | operator)
  --
  -- note that first and second are both destroyed by the operation
  -- the code is rather convoluted because an attempt is made to minimize
  -- the number of epsilon states needed

  function MKOR(FIRST, SECOND : in INTEGER) return INTEGER is 
    EPS, OREND : INTEGER; 
    P_FIRST    : INTEGER; 
  begin
    P_FIRST := FIRST; 
    if (P_FIRST = NIL) then 
      return SECOND; 
    else 
      if (SECOND = NIL) then 
        return P_FIRST; 
      else 

        -- see comment in mkopt() about why we can't use the first state
        -- of "first" or "second" if they satisfy "FREE_EPSILON"
        EPS := MKSTATE(SYM_EPSILON); 

        P_FIRST := LINK_MACHINES(EPS, P_FIRST); 

        MKXTION(P_FIRST, SECOND); 

        if ((SUPER_FREE_EPSILON(FINALST(P_FIRST))) and (ACCPTNUM(FINALST(P_FIRST
          )) = NIL)) then 
          OREND := FINALST(P_FIRST); 
          MKXTION(FINALST(SECOND), OREND); 
        else 
          if ((SUPER_FREE_EPSILON(FINALST(SECOND))) and (ACCPTNUM(FINALST(SECOND
            )) = NIL)) then 
            OREND := FINALST(SECOND); 
            MKXTION(FINALST(P_FIRST), OREND); 
          else 
            EPS := MKSTATE(SYM_EPSILON); 
            P_FIRST := LINK_MACHINES(P_FIRST, EPS); 
            OREND := FINALST(P_FIRST); 

            MKXTION(FINALST(SECOND), OREND); 
          end if; 
        end if; 
      end if; 
    end if; 

    FINALST(P_FIRST) := OREND; 
    return P_FIRST; 
  end MKOR; 


  -- mkposcl - convert a machine into a positive closure
  --
  --    new - a machine matching the positive closure of "state"

  function MKPOSCL(STATE : in INTEGER) return INTEGER is 
    EPS : INTEGER; 
  begin
    if (SUPER_FREE_EPSILON(FINALST(STATE))) then 
      MKXTION(FINALST(STATE), STATE); 
      return (STATE); 
    else 
      EPS := MKSTATE(SYM_EPSILON); 
      MKXTION(EPS, STATE); 
      return (LINK_MACHINES(STATE, EPS)); 
    end if; 
  end MKPOSCL; 

  -- mkrep - make a replicated machine
  --
  --    new - a machine that matches whatever "mach" matched from "lb"
  --          number of times to "ub" number of times
  --
  -- note
--   if "ub" is INFINITY then "new" matches "lb" or more occurrences of "mach"

  function MKREP(MACH, LB, UB : in INTEGER) return INTEGER is 
    BASE_MACH, TAIL, COPY : INTEGER; 
    P_MACH                : INTEGER; 
  begin
    P_MACH := MACH; 
    BASE_MACH := COPYSINGL(P_MACH, LB - 1); 

    if (UB = INFINITY) then 
      COPY := DUPMACHINE(P_MACH); 
      P_MACH := LINK_MACHINES(P_MACH, LINK_MACHINES(BASE_MACH, MKCLOS(COPY))); 
    else 
      TAIL := MKSTATE(SYM_EPSILON); 

      for I in LB .. UB - 1 loop
        COPY := DUPMACHINE(P_MACH); 
        TAIL := MKOPT(LINK_MACHINES(COPY, TAIL)); 
      end loop; 

      P_MACH := LINK_MACHINES(P_MACH, LINK_MACHINES(BASE_MACH, TAIL)); 
    end if; 

    return P_MACH; 
  end MKREP; 

  -- mkstate - create a state with a transition on a given symbol
  --
  --     state - a new state matching sym
  --     sym   - the symbol the new state is to have an out-transition on
  --
  -- note that this routine makes new states in ascending order through the
  -- state array (and increments LASTNFA accordingly).  The routine DUPMACHINE
  -- relies on machines being made in ascending order and that they are
  -- CONTIGUOUS.  Change it and you will have to rewrite DUPMACHINE (kludge
  -- that it admittedly is)

  function MKSTATE(SYM : in INTEGER) return INTEGER is 
  begin
    LASTNFA := LASTNFA + 1; 
    if (LASTNFA >= CURRENT_MNS) then 
      CURRENT_MNS := CURRENT_MNS + MNS_INCREMENT; 
      if (CURRENT_MNS >= MAXIMUM_MNS) then 
        MISC.AFLEXERROR("input rules are too complicated (>= " & INTEGER'IMAGE(
          CURRENT_MNS) & " NFA states) )"); 
      end if; 

      NUM_REALLOCS := NUM_REALLOCS + 1; 

      REALLOCATE_INTEGER_ARRAY(FIRSTST, CURRENT_MNS); 
      REALLOCATE_INTEGER_ARRAY(LASTST, CURRENT_MNS); 
      REALLOCATE_INTEGER_ARRAY(FINALST, CURRENT_MNS); 
      REALLOCATE_INTEGER_ARRAY(TRANSCHAR, CURRENT_MNS); 
      REALLOCATE_INTEGER_ARRAY(TRANS1, CURRENT_MNS); 
      REALLOCATE_INTEGER_ARRAY(TRANS2, CURRENT_MNS); 
      REALLOCATE_INTEGER_ARRAY(ACCPTNUM, CURRENT_MNS); 
      REALLOCATE_INTEGER_ARRAY(ASSOC_RULE, CURRENT_MNS); 
      REALLOCATE_STATE_ENUM_ARRAY(STATE_TYPE, CURRENT_MNS); 
    end if; 

    FIRSTST(LASTNFA) := LASTNFA; 
    FINALST(LASTNFA) := LASTNFA; 
    LASTST(LASTNFA) := LASTNFA; 
    TRANSCHAR(LASTNFA) := SYM; 
    TRANS1(LASTNFA) := NO_TRANSITION; 
    TRANS2(LASTNFA) := NO_TRANSITION; 
    ACCPTNUM(LASTNFA) := NIL; 
    ASSOC_RULE(LASTNFA) := NUM_RULES; 
    STATE_TYPE(LASTNFA) := CURRENT_STATE_ENUM; 

    -- fix up equivalence classes base on this transition.  Note that any
    -- character which has its own transition gets its own equivalence class.
    -- Thus only characters which are only in character classes have a chance
    -- at being in the same equivalence class.  E.g. "a|b" puts 'a' and 'b'
    -- into two different equivalence classes.  "[ab]" puts them in the same
    -- equivalence class (barring other differences elsewhere in the input).
    if (SYM < 0) then 

      -- we don't have to update the equivalence classes since that was
      -- already done when the ccl was created for the first time
      null; 
    else 
      if (SYM = SYM_EPSILON) then 
        NUMEPS := NUMEPS + 1; 
      else 
        if (USEECS) then 
          ECS.MKECHAR(SYM, NEXTECM, ECGROUP); 
        end if; 
      end if; 
    end if; 

    return LASTNFA; 
  end MKSTATE; 

  -- mkxtion - make a transition from one state to another
  --
  --     statefrom - the state from which the transition is to be made
  --     stateto   - the state to which the transition is to be made

  procedure MKXTION(STATEFROM, STATETO : in INTEGER) is 
  begin
    if (TRANS1(STATEFROM) = NO_TRANSITION) then 
      TRANS1(STATEFROM) := STATETO; 
    else 
      if ((TRANSCHAR(STATEFROM) /= SYM_EPSILON) or (TRANS2(STATEFROM) /= 
        NO_TRANSITION)) then 
        MISC.AFLEXFATAL("found too many transitions in mkxtion()"); 
      else 

        -- second out-transition for an epsilon state
        EPS2 := EPS2 + 1; 
        TRANS2(STATEFROM) := STATETO; 
      end if; 
    end if; 
  end MKXTION; 

  -- new_rule - initialize for a new rule
  --
  -- the global num_rules is incremented and the any corresponding dynamic
  -- arrays (such as rule_type()) are grown as needed.

  procedure NEW_RULE is 
  begin
    NUM_RULES := NUM_RULES + 1; 
    if (NUM_RULES >= CURRENT_MAX_RULES) then 
      NUM_REALLOCS := NUM_REALLOCS + 1; 
      CURRENT_MAX_RULES := CURRENT_MAX_RULES + MAX_RULES_INCREMENT; 
      REALLOCATE_RULE_ENUM_ARRAY(RULE_TYPE, CURRENT_MAX_RULES); 
      REALLOCATE_INTEGER_ARRAY(RULE_LINENUM, CURRENT_MAX_RULES); 
    end if; 

    if (NUM_RULES > MAX_RULE) then 
      MISC.AFLEXERROR("too many rules  (> " & INTEGER'IMAGE(MAX_RULE) & ")!"); 
    end if; 

    RULE_LINENUM(NUM_RULES) := LINENUM; 
  end NEW_RULE; 

end NFA; 
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- This software was developed by John Self of the Arcadia project
-- at the University of California, Irvine.
--
-- 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.

-- TITLE NFA construction routines
-- AUTHOR: John Self (UCI)
-- DESCRIPTION builds the NFA.
-- NOTES this file mirrors flex as closely as possible.
-- $Header: /co/ua/self/arcadia/aflex/ada/src/RCS/nfaS.a,v 1.4 90/01/12 15:20:30 self Exp Locker: self $ 

package NFA is 
  procedure ADD_ACCEPT(MACH             : in out INTEGER; 
                       ACCEPTING_NUMBER : in INTEGER); 
  function COPYSINGL(SINGL, NUM : in INTEGER) return INTEGER; 
  procedure DUMPNFA(STATE1 : in INTEGER); 
  function DUPMACHINE(MACH : in INTEGER) return INTEGER; 
  procedure FINISH_RULE(MACH                : in INTEGER; 
                        VARIABLE_TRAIL_RULE : in BOOLEAN; 
                        HEADCNT, TRAILCNT   : in INTEGER); 
  function LINK_MACHINES(FIRST, LAST : in INTEGER) return INTEGER; 
  procedure MARK_BEGINNING_AS_NORMAL(MACH : in INTEGER); 
  function MKBRANCH(FIRST, SECOND : in INTEGER) return INTEGER; 
  function MKCLOS(STATE : in INTEGER) return INTEGER; 
  function MKOPT(MACH : in INTEGER) return INTEGER; 
  function MKOR(FIRST, SECOND : in INTEGER) return INTEGER; 
  function MKPOSCL(STATE : in INTEGER) return INTEGER; 
  function MKREP(MACH, LB, UB : in INTEGER) return INTEGER; 
  function MKSTATE(SYM : in INTEGER) return INTEGER; 
  procedure MKXTION(STATEFROM, STATETO : in INTEGER); 
  procedure NEW_RULE; 
end NFA; 

with Parse_Tokens, Parse_Goto, Parse_Shift_Reduce, Text_IO, scanner;
with NFA, ccl, misc, misc_defs, sym, ecs, aflex_scanner;
with tstring, int_io, main_body, text_io, external_file_manager;
use aflex_scanner, external_file_manager;

package parser is
  procedure build_eof_action;
  procedure yyerror(msg: string);
  procedure YYParse;
  def_rule:integer;
end parser;

package body parser is
-- build_eof_action - build the "<<EOF>>" action for the active start
--                    conditions

use text_io, misc_defs;
procedure build_eof_action is
begin
    text_io.put( temp_action_file, "when " );
    for i in 1..actvp loop
	if ( sceof(actvsc(i)) ) then
	    text_io.put( Standard_Error,
		"multiple <<EOF>> rules for start condition ");
	    tstring.put( Standard_Error, scname(actvsc(i)));
	    main_body.aflexend(1);
	else
	    sceof(actvsc(i)) := true;
	    text_io.put( temp_action_file, "YY_END_OF_BUFFER +" );
	    tstring.put( temp_action_file,  scname(actvsc(i)) );
	    text_io.put_line( temp_action_file, " + 1 " );
	    if (i /= actvp) then
	        text_io.put_line( temp_action_file, " |" );
	    else
	        text_io.put_line( temp_action_file, " =>" );
	    end if;
        end if;
    end loop;
    misc.line_directive_out( temp_action_file );
end build_eof_action;

--  yyerror - eat up an error message from the parser
-- 
--  synopsis
--     char msg[];
--     yyerror( msg );

procedure yyerror( msg : string ) is
begin
null;
end yyerror;

use  Parse_Goto, Parse_Shift_Reduce, Text_IO, misc_defs, tstring;
procedure YYParse is

   -- Rename User Defined Packages to Internal Names.
    package yy_goto_tables         renames
      Parse_Goto;
    package yy_shift_reduce_tables renames
      Parse_Shift_Reduce;
    package yy_tokens              renames
      Parse_Tokens;

   use yy_tokens, yy_goto_tables, yy_shift_reduce_tables;

   procedure yyerrok;
   procedure yyclearin;

   package yy is

       -- the size of the value and state stacks
       stack_size : constant Natural := 300;

       -- subtype rule         is natural;
       subtype parse_state  is natural;
       -- subtype nonterminal  is integer;

       -- encryption constants
       default           : constant := -1;
       first_shift_entry : constant :=  0;
       accept_code       : constant := -1001;
       error_code        : constant := -1000;

       -- stack data used by the parser
       tos                : natural := 0;
       value_stack        : array(0..stack_size) of yy_tokens.yystype;
       state_stack        : array(0..stack_size) of parse_state;

       -- current input symbol and action the parser is on
       action             : integer;
       rule_id            : rule;
       input_symbol       : yy_tokens.token;


       -- error recovery flag
       error_flag : natural := 0;
          -- indicates  3 - (number of valid shifts after an error occurs)

       look_ahead : boolean := true;
       index      : integer;

       -- Is Debugging option on or off
        DEBUG : constant boolean := FALSE;

    end yy;


    function goto_state
      (state : yy.parse_state;
       sym   : nonterminal) return yy.parse_state;

    function parse_action
      (state : yy.parse_state;
       t     : yy_tokens.token) return integer;

    pragma inline(goto_state, parse_action);


    function goto_state(state : yy.parse_state;
                        sym   : nonterminal) return yy.parse_state is
        index : integer;
    begin
        index := goto_offset(state);
        while  integer(goto_matrix(index).nonterm) /= sym loop
            index := index + 1;
        end loop;
        return integer(goto_matrix(index).newstate);
    end goto_state;


    function parse_action(state : yy.parse_state;
                          t     : yy_tokens.token) return integer is
        index      : integer;
        tok_pos    : integer;
        default    : constant integer := -1;
    begin
        tok_pos := yy_tokens.token'pos(t);
        index   := shift_reduce_offset(state);
        while integer(shift_reduce_matrix(index).t) /= tok_pos and then
              integer(shift_reduce_matrix(index).t) /= default
        loop
            index := index + 1;
        end loop;
        return integer(shift_reduce_matrix(index).act);
    end parse_action;

-- error recovery stuff

    procedure handle_error is
      temp_action : integer;
    begin

      if yy.error_flag = 3 then -- no shift yet, clobber input.
      if yy.debug then
          put_line("Ayacc.YYParse: Error Recovery Clobbers " &
                   yy_tokens.token'image(yy.input_symbol));
      end if;
        if yy.input_symbol = yy_tokens.end_of_input then  -- don't discard,
        if yy.debug then
            put_line("Ayacc.YYParse: Can't discard END_OF_INPUT, quiting...");
        end if;
        raise yy_tokens.syntax_error;
        end if;

            yy.look_ahead := true;   -- get next token
        return;                  -- and try again...
    end if;

    if yy.error_flag = 0 then -- brand new error
        yyerror("Syntax Error");
    end if;

    yy.error_flag := 3;

    -- find state on stack where error is a valid shift --

    if yy.debug then
        put_line("Ayacc.YYParse: Looking for state with error as valid shift");
    end if;

    loop
        if yy.debug then
        put_line("Ayacc.YYParse: Examining State " &
              yy.parse_state'image(yy.state_stack(yy.tos)));
        end if;
        temp_action := parse_action(yy.state_stack(yy.tos), error);

            if temp_action >= yy.first_shift_entry then
                yy.tos := yy.tos + 1;
                yy.state_stack(yy.tos) := temp_action;
                exit;
            end if;

        Decrement_Stack_Pointer :
        begin
          yy.tos := yy.tos - 1;
        exception
          when Constraint_Error =>
            yy.tos := 0;
        end Decrement_Stack_Pointer;

        if yy.tos = 0 then
          if yy.debug then
            put_line("Ayacc.YYParse: Error recovery popped entire stack, aborting...");
          end if;
          raise yy_tokens.syntax_error;
        end if;
    end loop;

    if yy.debug then
        put_line("Ayacc.YYParse: Shifted error token in state " &
              yy.parse_state'image(yy.state_stack(yy.tos)));
    end if;

    end handle_error;

   -- print debugging information for a shift operation
   procedure shift_debug(state_id: yy.parse_state; lexeme: yy_tokens.token) is
   begin
       put_line("Ayacc.YYParse: Shift "& yy.parse_state'image(state_id)&" on input symbol "&
               yy_tokens.token'image(lexeme) );
   end;

   -- print debugging information for a reduce operation
   procedure reduce_debug(rule_id: rule; state_id: yy.parse_state) is
   begin
       put_line("Ayacc.YYParse: Reduce by rule "&rule'image(rule_id)&" goto state "&
               yy.parse_state'image(state_id));
   end;

   -- make the parser believe that 3 valid shifts have occured.
   -- used for error recovery.
   procedure yyerrok is
   begin
       yy.error_flag := 0;
   end yyerrok;

   -- called to clear input symbol that caused an error.
   procedure yyclearin is
   begin
       -- yy.input_symbol := yylex;
       yy.look_ahead := true;
   end yyclearin;


begin
    -- initialize by pushing state 0 and getting the first input symbol
    yy.state_stack(yy.tos) := 0;

    loop

        yy.index := shift_reduce_offset(yy.state_stack(yy.tos));
        if integer(shift_reduce_matrix(yy.index).t) = yy.default then
            yy.action := integer(shift_reduce_matrix(yy.index).act);
        else
            if yy.look_ahead then
                yy.look_ahead   := false;
                yy.input_symbol := yylex;
            end if;
            yy.action :=
             parse_action(yy.state_stack(yy.tos), yy.input_symbol);
        end if;

        if yy.action >= yy.first_shift_entry then  -- SHIFT

            if yy.debug then
                shift_debug(yy.action, yy.input_symbol);
            end if;

            -- Enter new state
            yy.tos := yy.tos + 1;
            yy.state_stack(yy.tos) := yy.action;
            yy.value_stack(yy.tos) := yylval;

        if yy.error_flag > 0 then  -- indicate a valid shift
            yy.error_flag := yy.error_flag - 1;
        end if;

            -- Advance lookahead
            yy.look_ahead := true;

        elsif yy.action = yy.error_code then       -- ERROR
            handle_error;

        elsif yy.action = yy.accept_code then
            if yy.debug then
                put_line("Ayacc.YYParse: Accepting Grammar...");
            end if;
            exit;

        else -- Reduce Action

            -- Convert action into a rule
            yy.rule_id  := -1 * yy.action;

            -- Execute User Action
            -- user_action(yy.rule_id);
            case yy.rule_id is

when  1 =>
--#line  44
 -- add default rule

			pat := ccl.cclinit;
			ccl.cclnegate( pat );

			def_rule := nfa.mkstate( -pat );

			nfa.finish_rule( def_rule, false, 0, 0 );

			for i in 1 .. lastsc loop
			    scset(i) := nfa.mkbranch( scset(i), def_rule );
			end loop;
			
			if ( spprdflt ) then
			    text_io.put(temp_action_file,
					"raise AFLEX_SCANNER_JAMMED;");
			else
			    text_io.put( temp_action_file, "ECHO" );

			text_io.put_line( temp_action_file, ";" );
			end if;
			

when  2 =>
--#line  69

			-- initialize for processing rules

       			-- create default DFA start condition
			sym.scinstal( tstring.vstr("INITIAL"), false );
			

when  5 =>
--#line  80
 misc.synerr( "unknown error processing section 1" );

when  7 =>
--#line  87

			 -- these productions are separate from the s1object
			 -- rule because the semantics must be done before
			 -- we parse the remainder of an s1object
			

			xcluflg := false;
			

when  8 =>
--#line  97
 xcluflg := true; 

when  9 =>
--#line  101
 sym.scinstal( nmstr, xcluflg ); 

when  10 =>
--#line  104
 sym.scinstal( nmstr, xcluflg ); 

when  11 =>
--#line  107
 misc.synerr( "bad start condition list" ); 

when  14 =>
--#line  115

			-- initialize for a parse of one rule
			trlcontxt := false;
			variable_trail_rule := false;
			varlength := false;
			trailcnt := 0;
			headcnt := 0;
			rulelen := 0;
			current_state_enum := STATE_NORMAL;
			previous_continued_action := continued_action;
			nfa.new_rule;
			

when  15 =>
--#line  130

			pat := nfa.link_machines( 
yy.value_stack(yy.tos-1), 
yy.value_stack(yy.tos) );
			nfa.finish_rule( pat, variable_trail_rule,
				     headcnt, trailcnt );

			for i in 1 .. actvp loop
			    scbol(actvsc(i)) :=
				nfa.mkbranch( scbol(actvsc(i)), pat );
			end loop;	
				
			if ( not bol_needed ) then
			    bol_needed := true;

			    if ( performance_report ) then
				text_io.put( Standard_Error,
			"'^' operator results in sub-optimal performance");
			        text_io.new_line(Standard_Error);
    	    	    	    end if;
			end if;
			

when  16 =>
--#line  152

			pat := nfa.link_machines( 
yy.value_stack(yy.tos-1), 
yy.value_stack(yy.tos) );
			nfa.finish_rule( pat, variable_trail_rule,
				     headcnt, trailcnt );

			for i in 1 .. actvp loop
			    scset(actvsc(i)) := 
				nfa.mkbranch( scset(actvsc(i)), pat );
			end loop;
		        

when  17 =>
--#line  163

			pat := nfa.link_machines( 
yy.value_stack(yy.tos-1), 
yy.value_stack(yy.tos) );
			nfa.finish_rule( pat, variable_trail_rule,
				     headcnt, trailcnt );

			-- add to all non-exclusive start conditions,
			-- including the default (0) start condition

			for i in 1 .. lastsc loop
			    if ( not scxclu(i) ) then
				scbol(i) := nfa.mkbranch( scbol(i), pat );
			    end if;	
			end loop;

			if ( not bol_needed ) then
			    bol_needed := true;

			    if ( performance_report ) then
				text_io.put( Standard_Error,
			"'^' operator results in sub-optimal performance");
			        text_io.new_line(Standard_Error);
			    end if;
			end if;
    	    	    	

when  18 =>
--#line  188

			pat := nfa.link_machines( 
yy.value_stack(yy.tos-1), 
yy.value_stack(yy.tos) );
			nfa.finish_rule( pat, variable_trail_rule,
				     headcnt, trailcnt );

			for i in 1 .. lastsc loop
			    if ( not scxclu(i) ) then
				scset(i) := nfa.mkbranch( scset(i), pat );
			    end if;
			end loop;
			

when  19 =>
--#line  201
 build_eof_action; 

when  20 =>
--#line  204

			-- this EOF applies only to the INITIAL start cond.
			actvp := 1;
			actvsc(actvp) := 1;
			build_eof_action;
			

when  21 =>
--#line  212
 misc.synerr( "unrecognized rule" ); 

when  23 =>
--#line  219

			scnum := sym.sclookup( nmstr );
			if (scnum = 0 ) then
		            text_io.put( Standard_Error,
					 "undeclared start condition ");
		            tstring.put( Standard_Error, nmstr );
			    main_body.aflexend( 1 );
			else
			  actvp := actvp + 1;
			    actvsc(actvp) := scnum;
			end if;
			

when  24 =>
--#line  233

			scnum := sym.sclookup( nmstr );
			if (scnum = 0 ) then
		            text_io.put( Standard_Error,
					"undeclared start condition ");
		            tstring.put( Standard_Error,	 nmstr );
			    main_body.aflexend ( 1 );
			else
			    actvp := 1;
			    actvsc(actvp) := scnum;
			end if;
			

when  25 =>
--#line  247
 misc.synerr( "bad start condition list" ); 

when  26 =>
--#line  251

			if trlcontxt then
			    misc.synerr( "trailing context used twice" );
			    
yyval := nfa.mkstate( SYM_EPSILON );
			else
			    trlcontxt := true;

			    if ( not varlength ) then
				headcnt := rulelen;
			    end if;

			    rulelen := rulelen + 1;
			    trailcnt := 1;

			    eps := nfa.mkstate( SYM_EPSILON );
			    
yyval := nfa.link_machines( eps,
					  nfa.mkstate( CHARACTER'POS(ASCII.LF) ) );
    	    	    	end if;
			

when  27 =>
--#line  272

		        
yyval := nfa.mkstate( SYM_EPSILON );

			if ( trlcontxt ) then
			    if ( varlength and (headcnt = 0) ) then
				-- both head and trail are variable-length
				variable_trail_rule := true;
			    else
				trailcnt := rulelen;
			    end if;
    	    	    	end if;
		        

when  28 =>
--#line  287

			varlength := true;

			
yyval := nfa.mkor( 
yy.value_stack(yy.tos-2), 
yy.value_stack(yy.tos) );
			

when  29 =>
--#line  294

			if ( transchar(lastst(
yy.value_stack(yy.tos))) /= SYM_EPSILON ) then
			    -- provide final transition \now/ so it
			    -- will be marked as a trailing context
			    -- state

			    
yy.value_stack(yy.tos) := nfa.link_machines( 
yy.value_stack(yy.tos), nfa.mkstate( SYM_EPSILON ) );
			end if;

			nfa.mark_beginning_as_normal( 
yy.value_stack(yy.tos) );
			current_state_enum := STATE_NORMAL;

			if ( previous_continued_action ) then
			    -- we need to treat this as variable trailing
			    -- context so that the backup does not happen
			    -- in the action but before the action switch
			    -- statement.  If the backup happens in the
			    -- action, then the rules "falling into" this
			    -- one's action will *also* do the backup,
			    -- erroneously.

			    	if ( (not varlength) or  headcnt /= 0 ) then
				     text_io.put( Standard_Error,
                              "alex: warning - trailing context rule at line");
                                     int_io.put(Standard_Error, linenum);
				     text_io.put( Standard_Error,
                           "made variable because of preceding '|' action" );
                                     int_io.put(Standard_Error, linenum);
    	    	    	    	end if;

			    -- mark as variable
			    varlength := true;
			    headcnt := 0;
    	    	    	end if;
			
			if ( varlength and (headcnt = 0) ) then
			    -- variable trailing context rule
			    -- mark the first part of the rule as the accepting
			    -- "head" part of a trailing context rule

			    -- by the way, we didn't do this at the beginning
			    -- of this production because back then
			    -- current_state_enum was set up for a trail
			    -- rule, and add_accept() can create a new
			    -- state ...

			    nfa.add_accept( 
yy.value_stack(yy.tos-1),
    	    	    	    	   misc.set_yy_trailing_head_mask(num_rules) );
    	    	    	end if;

			
yyval := nfa.link_machines( 
yy.value_stack(yy.tos-1), 
yy.value_stack(yy.tos) );
			

when  30 =>
--#line  348
 
yyval := 
yy.value_stack(yy.tos); 

when  31 =>
--#line  353

			-- this rule is separate from the others for "re" so
			-- that the reduction will occur before the trailing
			-- series is parsed

			if ( trlcontxt ) then
			    misc.synerr( "trailing context used twice" );
			else
			    trlcontxt := true;
			end if;    

			if ( varlength ) then
			    -- we hope the trailing context is fixed-length
			    varlength := false;
			else
			    headcnt := rulelen;
			end if;    

			rulelen := 0;

			current_state_enum := STATE_TRAILING_CONTEXT;
			
yyval := 
yy.value_stack(yy.tos-1);
			

when  32 =>
--#line  379

			-- this is where concatenation of adjacent patterns
			-- gets done

			
yyval := nfa.link_machines( 
yy.value_stack(yy.tos-1), 
yy.value_stack(yy.tos) );
			

when  33 =>
--#line  387
 
yyval := 
yy.value_stack(yy.tos); 

when  34 =>
--#line  391

			varlength := true;

			
yyval := nfa.mkclos( 
yy.value_stack(yy.tos-1) );
			

when  35 =>
--#line  398

			varlength := true;

			
yyval := nfa.mkposcl( 
yy.value_stack(yy.tos-1) );
			

when  36 =>
--#line  405

			varlength := true;

			
yyval := nfa.mkopt( 
yy.value_stack(yy.tos-1) );
			

when  37 =>
--#line  412

			varlength := true;

			if ( (
yy.value_stack(yy.tos-3) > 
yy.value_stack(yy.tos-1)) or (
yy.value_stack(yy.tos-3) < 0) ) then
			    misc.synerr( "bad iteration values" );
			    
yyval := 
yy.value_stack(yy.tos-5);
			else
			    if ( 
yy.value_stack(yy.tos-3) = 0 ) then
				
yyval := nfa.mkopt( nfa.mkrep( 
yy.value_stack(yy.tos-5), 
yy.value_stack(yy.tos-3), 
yy.value_stack(yy.tos-1) ) );
			    else
				
yyval := nfa.mkrep( 
yy.value_stack(yy.tos-5), 
yy.value_stack(yy.tos-3), 
yy.value_stack(yy.tos-1) );
			    end if;
    	    	    	end if;
			

when  38 =>
--#line  428

			varlength := true;

			if ( 
yy.value_stack(yy.tos-2) <= 0 ) then
			    misc.synerr( "iteration value must be positive" );
			    
yyval := 
yy.value_stack(yy.tos-4);
			else
			    
yyval := nfa.mkrep( 
yy.value_stack(yy.tos-4), 
yy.value_stack(yy.tos-2), INFINITY );
			end if;    
			

when  39 =>
--#line  440

			-- the singleton could be something like "(foo)",
			-- in which case we have no idea what its length
			-- is, so we punt here.

			varlength := true;

			if ( 
yy.value_stack(yy.tos-1) <= 0 ) then
			    misc.synerr( "iteration value must be positive" );
			    
yyval := 
yy.value_stack(yy.tos-3);
			else
			    
yyval := nfa.link_machines( 
yy.value_stack(yy.tos-3), nfa.copysingl( 
yy.value_stack(yy.tos-3), 
yy.value_stack(yy.tos-1) - 1 ) );
			end if;    
			

when  40 =>
--#line  456

			if ( not madeany ) then
			    -- create the '.' character class
			    anyccl := ccl.cclinit;
			    ccl.ccladd( anyccl, ASCII.LF );
			    ccl.cclnegate( anyccl );

			    if ( useecs ) then
				ecs.mkeccl(
		       ccltbl(cclmap(anyccl)..cclmap(anyccl) + ccllen(anyccl)),
					ccllen(anyccl), nextecm,
					ecgroup, CSIZE );
			    end if;
			    madeany := true;
    	    	    	end if;

			rulelen := rulelen + 1;

			
yyval := nfa.mkstate( -anyccl );
			

when  41 =>
--#line  478

			if ( not cclsorted ) then
			    -- sort characters for fast searching.  We use a
			    -- shell sort since this list could be large.

--			    misc.cshell( ccltbl + cclmap($1), ccllen($1) );
		      misc.cshell( ccltbl(cclmap(
yy.value_stack(yy.tos))..cclmap(
yy.value_stack(yy.tos)) + ccllen(
yy.value_stack(yy.tos))),
				   ccllen(
yy.value_stack(yy.tos)) );
			end if;

			if ( useecs ) then
		    ecs.mkeccl( ccltbl(cclmap(
yy.value_stack(yy.tos))..cclmap(
yy.value_stack(yy.tos)) + ccllen(
yy.value_stack(yy.tos))),
				ccllen(
yy.value_stack(yy.tos)),nextecm, ecgroup, CSIZE );
			end if;
				     
			rulelen := rulelen + 1;

			
yyval := nfa.mkstate( -
yy.value_stack(yy.tos) );
			

when  42 =>
--#line  499

			rulelen := rulelen + 1;

			
yyval := nfa.mkstate( -
yy.value_stack(yy.tos) );
			

when  43 =>
--#line  506
 
yyval := 
yy.value_stack(yy.tos-1); 

when  44 =>
--#line  509
 
yyval := 
yy.value_stack(yy.tos-1); 

when  45 =>
--#line  512

			rulelen := rulelen + 1;

			if ( 
yy.value_stack(yy.tos) = CHARACTER'POS(ASCII.NUL) ) then
			    misc.synerr( "null in rule" );
			end if;    

			if ( caseins and (
yy.value_stack(yy.tos) >= CHARACTER'POS('A')) and (
yy.value_stack(yy.tos) <= CHARACTER'POS('Z')) ) then
			    
yy.value_stack(yy.tos) := misc.clower( 
yy.value_stack(yy.tos) );
			end if;

			
yyval := nfa.mkstate( 
yy.value_stack(yy.tos) );
			

when  46 =>
--#line  528
 
yyval := 
yy.value_stack(yy.tos-1); 

when  47 =>
--#line  531

			-- *Sigh* - to be compatible Unix lex, negated ccls
			-- match newlines
			ccl.cclnegate( 
yy.value_stack(yy.tos-1) );
			
yyval := 
yy.value_stack(yy.tos-1);
			

when  48 =>
--#line  540

			if ( 
yy.value_stack(yy.tos-2) > 
yy.value_stack(yy.tos) ) then
			    misc.synerr( "negative range in character class" );
			else
			    if ( caseins ) then
				if ( (
yy.value_stack(yy.tos-2) >= CHARACTER'POS('A')) and (
yy.value_stack(yy.tos-2) <= CHARACTER'POS('Z')) ) then
				    
yy.value_stack(yy.tos-2) := misc.clower( 
yy.value_stack(yy.tos-2) );
				end if;					    
				if ( (
yy.value_stack(yy.tos) >= CHARACTER'POS('A')) and (
yy.value_stack(yy.tos) <= CHARACTER'POS('Z')) ) then
				    
yy.value_stack(yy.tos) := misc.clower( 
yy.value_stack(yy.tos) );
				end if;    
    	    	    	    end if;

			    for i in 
yy.value_stack(yy.tos-2) .. 
yy.value_stack(yy.tos) loop
			        ccl.ccladd( 
yy.value_stack(yy.tos-3), CHARACTER'VAL(i) );
    	    	    	    end loop;
			    
			    -- keep track if this ccl is staying in
			    -- alphabetical order

			    cclsorted := cclsorted and (
yy.value_stack(yy.tos-2) > lastchar);
			    lastchar := 
yy.value_stack(yy.tos);
    	    	    	end if;
			
			
yyval := 
yy.value_stack(yy.tos-3);
			

when  49 =>
--#line  568

			if ( caseins ) then
			    if ( (
yy.value_stack(yy.tos) >= CHARACTER'POS('A')) and (
yy.value_stack(yy.tos) <= CHARACTER'POS('Z')) ) then
				
yy.value_stack(yy.tos) := misc.clower( 
yy.value_stack(yy.tos) );
    	    	    	    end if;
			end if;    
			ccl.ccladd( 
yy.value_stack(yy.tos-1), CHARACTER'VAL(
yy.value_stack(yy.tos)) );
			cclsorted := cclsorted and (
yy.value_stack(yy.tos) > lastchar);
			lastchar := 
yy.value_stack(yy.tos);
			
yyval := 
yy.value_stack(yy.tos-1);
			

when  50 =>
--#line  581

			cclsorted := true;
			lastchar := 0;
			
yyval := ccl.cclinit;
			

when  51 =>
--#line  589

			if ( caseins ) then
			    if ( (
yy.value_stack(yy.tos) >= CHARACTER'POS('A')) and (
yy.value_stack(yy.tos) <= CHARACTER'POS('Z')) ) then
				
yy.value_stack(yy.tos) := misc.clower( 
yy.value_stack(yy.tos) );
			    end if;
			end if;    

			rulelen := rulelen + 1;

			
yyval := nfa.link_machines( 
yy.value_stack(yy.tos-1), nfa.mkstate( 
yy.value_stack(yy.tos) ) );
			

when  52 =>
--#line  602
 
yyval := nfa.mkstate( SYM_EPSILON ); 

                when others => null;
            end case;

            -- Pop RHS states and goto next state
            yy.tos      := yy.tos - rule_length(yy.rule_id) + 1;
            yy.state_stack(yy.tos) := goto_state(yy.state_stack(yy.tos-1) ,
                                 get_lhs_rule(yy.rule_id));

            yy.value_stack(yy.tos) := yyval;

            if yy.debug then
                reduce_debug(yy.rule_id,
                    goto_state(yy.state_stack(yy.tos - 1),
                               get_lhs_rule(yy.rule_id)));
            end if;

        end if;
    end loop;

end yyparse;
end parser;
package Parse_Goto is

    type Small_Integer is range -32_000 .. 32_000;

    type Goto_Entry is record
        Nonterm  : Small_Integer;
        Newstate : Small_Integer;
    end record;

  --pragma suppress(index_check);

    subtype Row is Integer range -1 .. Integer'Last;

    type Goto_Parse_Table is array (Row range <>) of Goto_Entry;

    Goto_Matrix : constant Goto_Parse_Table :=
       ((-1,-1)  -- Dummy Entry.
-- State  0
,(-3, 1),(-2, 2)
-- State  1
,(-4, 3)
-- State  2

-- State  3
,(-8, 10)
,(-5, 9)
-- State  4

-- State  5

-- State  6

-- State  7

-- State  8

-- State  9
,(-6, 12)
-- State  10

-- State  11

-- State  12
,(-7, 14)
-- State  13
,(-9, 15)

-- State  14
,(-18, 28),(-17, 26),(-16, 24),(-15, 25)
,(-12, 20),(-11, 18),(-10, 34)
-- State  15

-- State  16

-- State  17

-- State  18
,(-18, 28)
,(-17, 26),(-16, 24),(-15, 25),(-12, 37)

-- State  19
,(-18, 28),(-17, 26),(-16, 24),(-15, 25)
,(-12, 40)
-- State  20
,(-13, 42)
-- State  21

-- State  22

-- State  23
,(-14, 45)
-- State  24
,(-18, 28)
,(-17, 26),(-15, 48)
-- State  25
,(-18, 28),(-17, 49)

-- State  26

-- State  27

-- State  28

-- State  29

-- State  30
,(-19, 54)
-- State  31
,(-18, 28),(-17, 26),(-16, 24)
,(-15, 25),(-12, 55)
-- State  32

-- State  33
,(-20, 56)
-- State  34

-- State  35

-- State  36

-- State  37
,(-13, 60)

-- State  38
,(-18, 28),(-17, 26),(-16, 24),(-15, 25)
,(-12, 61)
-- State  39

-- State  40
,(-13, 62)
-- State  41

-- State  42

-- State  43
,(-18, 28),(-17, 26)
,(-15, 63)
-- State  44

-- State  45

-- State  46

-- State  47

-- State  48
,(-18, 28),(-17, 49)
-- State  49

-- State  50

-- State  51

-- State  52

-- State  53

-- State  54

-- State  55

-- State  56

-- State  57
,(-20, 72)

-- State  58

-- State  59

-- State  60

-- State  61
,(-13, 73)
-- State  62

-- State  63
,(-18, 28),(-17, 49)
-- State  64

-- State  65

-- State  66

-- State  67

-- State  68

-- State  69

-- State  70

-- State  71

-- State  72

-- State  73

-- State  74

-- State  75

-- State  76

-- State  77

-- State  78

-- State  79

-- State  80

-- State  81

-- State  82

);
--  The offset vector
GOTO_OFFSET : array (0.. 82) of Integer :=
( 0,
 2, 3, 3, 5, 5, 5, 5, 5, 5, 6,
 6, 6, 7, 8, 15, 15, 15, 15, 20, 25,
 26, 26, 26, 27, 30, 32, 32, 32, 32, 32,
 33, 38, 38, 39, 39, 39, 39, 40, 45, 45,
 46, 46, 46, 49, 49, 49, 49, 49, 51, 51,
 51, 51, 51, 51, 51, 51, 51, 52, 52, 52,
 52, 53, 53, 55, 55, 55, 55, 55, 55, 55,
 55, 55, 55, 55, 55, 55, 55, 55, 55, 55,
 55, 55);

subtype Rule        is Natural;
subtype Nonterminal is Integer;

   Rule_Length : array (Rule range  0 ..  52) of Natural := ( 2,
 5, 0, 5, 0, 2, 1, 1, 1,
 3, 1, 1, 4, 0, 0, 4, 3,
 3, 2, 2, 1, 1, 3, 3, 1,
 1, 1, 0, 3, 2, 1, 2, 2,
 1, 2, 2, 2, 6, 5, 4, 1,
 1, 1, 3, 3, 1, 3, 4, 4,
 2, 0, 2, 0);
   Get_LHS_Rule: array (Rule range  0 ..  52) of Nonterminal := (-1,
-2,-3,-4,-4,-4,-5,-8,-8,
-9,-9,-9,-6,-6,-7,-10,-10,
-10,-10,-10,-10,-10,-11,-14,-14,
-14,-13,-13,-12,-12,-12,-16,-15,
-15,-17,-17,-17,-17,-17,-17,-17,
-17,-17,-17,-17,-17,-18,-18,-20,
-20,-20,-19,-19);
end Parse_Goto;
package Parse_Shift_Reduce is

    type Small_Integer is range -32_000 .. 32_000;

    type Shift_Reduce_Entry is record
        T   : Small_Integer;
        Act : Small_Integer;
    end record;
    pragma Pack(Shift_Reduce_Entry);

    subtype Row is Integer range -1 .. Integer'Last;

  --pragma suppress(index_check);

    type Shift_Reduce_Array is array (Row  range <>) of Shift_Reduce_Entry;

    Shift_Reduce_Matrix : constant Shift_Reduce_Array :=
        ( (-1,-1) -- Dummy Entry

-- state  0
,(-1,-2)
-- state  1
,( 1, 4),(-1,-4)
-- state  2
,( 0,-1001)
,(-1,-1000)
-- state  3
,( 4, 6),( 5, 7),( 6, 8)
,(-1,-1000)
-- state  4
,( 11, 11),(-1,-1000)
-- state  5
,(-1,-1000)

-- state  6
,(-1,-6)
-- state  7
,(-1,-7)
-- state  8
,(-1,-8)
-- state  9
,(-1,-13)

-- state  10
,( 7, 13),(-1,-1000)
-- state  11
,(-1,-5)
-- state  12
,(-1,-14)

-- state  13
,( 1, 17),( 8, 16),(-1,-1000)
-- state  14
,( 1, 22)
,( 2, 32),( 9, 29),( 10, 21),( 12, 19)
,( 13, 23),( 24, 27),( 25, 30),( 26, 31)
,( 28, 33),(-1,-1)
-- state  15
,( 7, 36),( 11, 35)
,(-1,-1000)
-- state  16
,(-1,-10)
-- state  17
,(-1,-11)
-- state  18
,( 2, 32)
,( 9, 29),( 10, 39),( 12, 38),( 24, 27)
,( 25, 30),( 26, 31),( 28, 33),(-1,-1000)

-- state  19
,( 2, 32),( 9, 29),( 24, 27),( 25, 30)
,( 26, 31),( 28, 33),(-1,-1000)
-- state  20
,( 16, 41)
,( 17, 43),( 18, 44),(-1,-27)
-- state  21
,(-1,-20)

-- state  22
,(-1,-21)
-- state  23
,( 1, 47),( 8, 46),(-1,-1000)

-- state  24
,( 2, 32),( 9, 29),( 24, 27),( 25, 30)
,( 26, 31),( 28, 33),(-1,-1000)
-- state  25
,( 2, 32)
,( 9, 29),( 24, 27),( 25, 30),( 26, 31)
,( 28, 33),(-1,-30)
-- state  26
,( 19, 50),( 20, 51)
,( 21, 52),( 22, 53),(-1,-33)
-- state  27
,(-1,-40)

-- state  28
,(-1,-41)
-- state  29
,(-1,-42)
-- state  30
,(-1,-52)
-- state  31
,( 2, 32)
,( 9, 29),( 24, 27),( 25, 30),( 26, 31)
,( 28, 33),(-1,-1000)
-- state  32
,(-1,-45)
-- state  33
,( 12, 57)
,(-1,-50)
-- state  34
,( 11, 58),(-1,-1000)
-- state  35
,(-1,-3)

-- state  36
,( 8, 59),(-1,-1000)
-- state  37
,( 16, 41),( 17, 43)
,( 18, 44),(-1,-27)
-- state  38
,( 2, 32),( 9, 29)
,( 24, 27),( 25, 30),( 26, 31),( 28, 33)
,(-1,-1000)
-- state  39
,(-1,-19)
-- state  40
,( 16, 41),( 17, 43)
,( 18, 44),(-1,-27)
-- state  41
,(-1,-26)
-- state  42
,(-1,-18)

-- state  43
,( 2, 32),( 9, 29),( 24, 27),( 25, 30)
,( 26, 31),( 28, 33),(-1,-1000)
-- state  44
,(-1,-31)

-- state  45
,( 14, 64),( 15, 65),(-1,-1000)
-- state  46
,(-1,-24)

-- state  47
,(-1,-25)
-- state  48
,( 2, 32),( 9, 29),( 24, 27)
,( 25, 30),( 26, 31),( 28, 33),(-1,-29)

-- state  49
,( 19, 50),( 20, 51),( 21, 52),( 22, 53)
,(-1,-32)
-- state  50
,(-1,-34)
-- state  51
,(-1,-35)
-- state  52
,(-1,-36)

-- state  53
,( 3, 66),(-1,-1000)
-- state  54
,( 2, 68),( 25, 67)
,(-1,-1000)
-- state  55
,( 17, 43),( 18, 44),( 27, 69)
,(-1,-1000)
-- state  56
,( 2, 71),( 29, 70),(-1,-1000)

-- state  57
,(-1,-50)
-- state  58
,(-1,-12)
-- state  59
,(-1,-9)
-- state  60
,(-1,-16)

-- state  61
,( 16, 41),( 17, 43),( 18, 44),(-1,-27)

-- state  62
,(-1,-17)
-- state  63
,( 2, 32),( 9, 29),( 24, 27)
,( 25, 30),( 26, 31),( 28, 33),(-1,-28)

-- state  64
,(-1,-22)
-- state  65
,( 8, 74),(-1,-1000)
-- state  66
,( 15, 75)
,( 23, 76),(-1,-1000)
-- state  67
,(-1,-43)
-- state  68
,(-1,-51)

-- state  69
,(-1,-44)
-- state  70
,(-1,-46)
-- state  71
,( 30, 77),(-1,-49)

-- state  72
,( 2, 71),( 29, 78),(-1,-1000)
-- state  73
,(-1,-15)

-- state  74
,(-1,-23)
-- state  75
,( 3, 79),( 23, 80),(-1,-1000)

-- state  76
,(-1,-39)
-- state  77
,( 2, 81),(-1,-1000)
-- state  78
,(-1,-47)

-- state  79
,( 23, 82),(-1,-1000)
-- state  80
,(-1,-38)
-- state  81
,(-1,-48)

-- state  82
,(-1,-37)
);
--  The offset vector
SHIFT_REDUCE_OFFSET : array (0.. 82) of Integer :=
( 0,
 1, 3, 5, 9, 11, 12, 13, 14, 15, 16,
 18, 19, 20, 23, 34, 37, 38, 39, 48, 55,
 59, 60, 61, 64, 71, 78, 83, 84, 85, 86,
 87, 94, 95, 97, 99, 100, 102, 106, 113, 114,
 118, 119, 120, 127, 128, 131, 132, 133, 140, 145,
 146, 147, 148, 150, 153, 157, 160, 161, 162, 163,
 164, 168, 169, 176, 177, 179, 182, 183, 184, 185,
 186, 188, 191, 192, 193, 196, 197, 199, 200, 202,
 203, 204);
end Parse_Shift_Reduce;
with  Text_Io;
with  Ccl;
with  Nfa;
with  Parse_Shift_Reduce;
with  Parse_Goto;
with  Misc_Defs;
use   Misc_Defs;
with  External_File_Manager;
use   External_File_Manager;
package Parse_Tokens is


  subtype YYSType is Integer;

    YYLVal, YYVal : YYSType; 
    type Token is
        (End_Of_Input, Error, Char, Number,
         Sectend, Scdecl, Xscdecl,
         Whitespace, Name, Prevccl,
         Eof_Op, Newline, '^',
         '<', '>', ',',
         '$', '|', '/',
         '*', '+', '?',
         '{', '}', '.',
         '"', '(', ')',
         '[', ']', '-' );

    Syntax_Error : exception;

end Parse_Tokens;
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- This software was developed by John Self of the Arcadia project
-- at the University of California, Irvine.
--
-- 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.

-- TITLE skeleton manager
-- AUTHOR: John Self (UCI)
-- DESCRIPTION outputs skeleton sections when called by gen.
-- NOTES allows use of internal or external skeleton
-- $Header: /tmp_mnt/dc/uc/self/arcadia/aflex/ada/src/RCS/skeleton_managerB.a,v 1.18 1991/08/06 17:58:45 self Exp self $ 

with MISC_DEFS, TEXT_IO, FILE_STRING;
package body SKELETON_MANAGER is 
  use FILE_STRING; -- to save having to type FILE_STRING 177 times
  USE_EXTERNAL_SKELETON : BOOLEAN := FALSE; 
                                          -- are we using an external skelfile?
  CURRENT_LINE          : INTEGER := 1; 
  type FILE_ARRAY is array(POSITIVE range <>) of FILE_STRING.VSTRING; 
  SKEL_TEMPLATE : FILE_ARRAY(1 .. 177) := (
  -- START OF SKELETON
  -- START OF S1
VSTR("-- A lexical scanner generated by aflex"),
VSTR("with text_io; use text_io;"),
VSTR("%% user's code up to the double pound goes right here"),
-- BEGIN S2
VSTR("function YYLex return Token is"),
VSTR("subtype short is integer range -32768..32767;"),
VSTR("    yy_act : integer;"),
VSTR("    yy_c : short;"),
VSTR(""),
VSTR("-- returned upon end-of-file"),
VSTR("YY_END_TOK : constant integer := 0;"),
VSTR("%% tables get generated here."),
-- BEGIN S3
VSTR(""),
VSTR("-- copy whatever the last rule matched to the standard output"),
VSTR(""),
VSTR("procedure ECHO is"),
VSTR("begin"),
VSTR("    text_io.put( yytext );"),
VSTR("end ECHO;"),
VSTR(""),
VSTR("-- enter a start condition."),
VSTR("-- Using procedure requires a () after the ENTER, but makes everything"),
VSTR("-- much neater."),
VSTR(""),
VSTR("procedure ENTER( state : integer ) is"),
VSTR("begin"),
VSTR("     yy_start := 1 + 2 * state;"),
VSTR("end ENTER;"),
VSTR(""),
VSTR("-- action number for EOF rule of a given start state"),
VSTR("function YY_STATE_EOF(state : integer) return integer is"),
VSTR("begin"),
VSTR("     return YY_END_OF_BUFFER + state + 1;"),
VSTR("end YY_STATE_EOF;"),
VSTR(""),
VSTR("-- return all but the first 'n' matched characters back to the input stream"),
VSTR("procedure yyless(n : integer) is"),
VSTR("begin"),
VSTR("        yy_ch_buf(yy_cp) := yy_hold_char; -- undo effects of setting up yytext"),
VSTR("        yy_cp := yy_bp + n;"),
VSTR("        yy_c_buf_p := yy_cp;"),
VSTR("        YY_DO_BEFORE_ACTION; -- set up yytext again"),
VSTR("end yyless;"),
VSTR(""),
VSTR("-- redefine this if you have something you want each time."),
VSTR("procedure YY_USER_ACTION is"),
VSTR("begin"),
VSTR("        null;"),
VSTR("end;"),
VSTR(""),
VSTR("-- yy_get_previous_state - get the state just before the EOB char was reached"),
VSTR(""),
VSTR("function yy_get_previous_state return yy_state_type is"),
VSTR("    yy_current_state : yy_state_type;"),
VSTR("    yy_c : short;"),
VSTR("%% a local declaration of yy_bp goes here if bol_needed"),
VSTR("begin"),
VSTR("%% code to get the start state into yy_current_state goes here"), 
-- BEGIN S3A
VSTR(""),
VSTR("    for yy_cp in yytext_ptr..yy_c_buf_p - 1 loop"),
VSTR("%% code to find the next state goes here"),
-- BEGIN S4
VSTR("    end loop;"),
VSTR(""),
VSTR("    return yy_current_state;"),
VSTR("end yy_get_previous_state;"),
VSTR(""),
VSTR("procedure yyrestart( input_file : file_type ) is"),
VSTR("begin"),
VSTR("   set_input(input_file);"),
VSTR("   yy_init := true;"),
VSTR("end yyrestart;"),
VSTR(""),
VSTR("begin -- of YYLex"),
VSTR("<<new_file>>"),
VSTR("        -- this is where we enter upon encountering an end-of-file and"),
VSTR("        -- yywrap() indicating that we should continue processing"),
VSTR(""),
VSTR("    if ( yy_init ) then"),
VSTR("        if ( yy_start = 0 ) then"),
VSTR("            yy_start := 1;      -- first start state"),
VSTR("        end if;"),
VSTR(""),
VSTR("        -- we put in the '\n' and start reading from [1] so that an"),
VSTR("        -- initial match-at-newline will be true."),
VSTR(""),
VSTR("        yy_ch_buf(0) := ASCII.LF;"),
VSTR("        yy_n_chars := 1;"),
VSTR(""),
VSTR("        -- we always need two end-of-buffer characters.  The first causes"),
VSTR("        -- a transition to the end-of-buffer state.  The second causes"),
VSTR("        -- a jam in that state."),
VSTR(""),
VSTR("        yy_ch_buf(yy_n_chars) := YY_END_OF_BUFFER_CHAR;"),
VSTR("        yy_ch_buf(yy_n_chars + 1) := YY_END_OF_BUFFER_CHAR;"),
VSTR(""),
VSTR("        yy_eof_has_been_seen := false;"),
VSTR(""),
VSTR("        yytext_ptr := 1;"),
VSTR("        yy_c_buf_p := yytext_ptr;"),
VSTR("        yy_hold_char := yy_ch_buf(yy_c_buf_p);"),
VSTR("        yy_init := false;"),
VSTR("    end if; -- yy_init"),
VSTR(""),
VSTR("    loop                -- loops until end-of-file is reached"),
VSTR("        yy_cp := yy_c_buf_p;"),
VSTR(""),
VSTR("        -- support of yytext"),
VSTR("        yy_ch_buf(yy_cp) := yy_hold_char;"),
VSTR(""),
VSTR("        -- yy_bp points to the position in yy_ch_buf of the start of the"),
VSTR("        -- current run."),
VSTR("%%"),
-- BEGIN S5
VSTR(""),
VSTR("<<next_action>>"),
VSTR("%% call to gen_find_action goes here"),
-- BEGIN S6
VSTR("            YY_DO_BEFORE_ACTION;"),
VSTR("            YY_USER_ACTION;"),
VSTR(""),
VSTR("        if aflex_debug then  -- output acceptance info. for (-d) debug mode"),
VSTR("            text_io.put( Standard_Error, ""--accepting rule #"" );"),
VSTR("            text_io.put( Standard_Error, INTEGER'IMAGE(yy_act) );"),
VSTR("            text_io.put_line( Standard_Error, ""("""""" & yytext & """""")"");"),
VSTR("        end if;"),
VSTR(""),
VSTR("<<do_action>>   -- this label is used only to access EOF actions"),
VSTR("            case yy_act is"), VSTR("%% actions go here"),
-- BEGIN S7
VSTR("                when YY_END_OF_BUFFER =>"),
VSTR("                    -- undo the effects of YY_DO_BEFORE_ACTION"),
VSTR("                    yy_ch_buf(yy_cp) := yy_hold_char;"),
VSTR(""),
VSTR("                    yytext_ptr := yy_bp;"), VSTR(""),
VSTR("                    case yy_get_next_buffer is"),
VSTR("                        when EOB_ACT_END_OF_FILE =>"),
VSTR("                            begin"),
VSTR("                            if ( yywrap ) then"),
VSTR("                                -- note: because we've taken care in"),
VSTR("                                -- yy_get_next_buffer() to have set up yytext,"),
VSTR("                                -- we can now set up yy_c_buf_p so that if some"),
VSTR("                                -- total hoser (like aflex itself) wants"),
VSTR("                                -- to call the scanner after we return the"),
VSTR("                                -- End_Of_Input, it'll still work - another"),
VSTR("                                -- End_Of_Input will get returned."),
VSTR(""),
VSTR("                                yy_c_buf_p := yytext_ptr;"),
VSTR(""),
VSTR("                                yy_act := YY_STATE_EOF((yy_start - 1) / 2);"),
VSTR(""),
VSTR("                                goto do_action;"),
VSTR("                            else"),
VSTR("                                --  start processing a new file"),
VSTR("                                yy_init := true;"),
VSTR("                                goto new_file;"),
VSTR("                            end if;"),
VSTR("                            end;"),
VSTR("                        when EOB_ACT_RESTART_SCAN =>"),
VSTR("                            yy_c_buf_p := yytext_ptr;"),
VSTR("                            yy_hold_char := yy_ch_buf(yy_c_buf_p);"),
VSTR("                        when EOB_ACT_LAST_MATCH =>"),
VSTR("                            yy_c_buf_p := yy_n_chars;"),
VSTR("                            yy_current_state := yy_get_previous_state;"),
VSTR(""),
VSTR("                            yy_cp := yy_c_buf_p;"),
VSTR("                            yy_bp := yytext_ptr;"),
VSTR("                            goto next_action;"),
VSTR("                        when others => null;"),
VSTR("                        end case; -- case yy_get_next_buffer()"),
VSTR("                when others =>"),
VSTR("                    text_io.put( ""action # "" );"),
VSTR("                    text_io.put( INTEGER'IMAGE(yy_act) );"),
VSTR("                    text_io.new_line;"),
VSTR("                    raise AFLEX_INTERNAL_ERROR;"),
VSTR("            end case; -- case (yy_act)"),
VSTR("        end loop; -- end of loop waiting for end of file"),
VSTR("end YYLex;"),
VSTR("%%"),
VSTR("ERROR tried to output beyond end of skeleton file")
-- END OF SKELETON
); 

  -- set_external_skeleton
  --
  -- DESCRIPTION
  -- sets flag so we know to use an external skelfile

  procedure SET_EXTERNAL_SKELETON is 
  begin
    USE_EXTERNAL_SKELETON := TRUE; 
  end SET_EXTERNAL_SKELETON; 

  procedure GET_INTERNAL(BUFFER : in out FILE_STRING.VSTRING) is 
  begin
    BUFFER := SKEL_TEMPLATE(CURRENT_LINE); 
    CURRENT_LINE := CURRENT_LINE + 1; 
  end GET_INTERNAL; 

  procedure GET_EXTERNAL(BUFFER : in out FILE_STRING.VSTRING) is 
  begin
    FILE_STRING.GET_LINE(MISC_DEFS.SKELFILE, BUFFER); 
  end GET_EXTERNAL; 

  -- end_of_skeleton
  --
  -- DESCRIPTION
  -- returns true if there are no more lines left to output in the skeleton

  function END_OF_SKELETON return BOOLEAN is 
  begin
    if (USE_EXTERNAL_SKELETON) then 

      -- we're using an external skelfile
      return TEXT_IO.END_OF_FILE(MISC_DEFS.SKELFILE); 
    else 

      -- internal skeleton
      return CURRENT_LINE > SKEL_TEMPLATE'LAST; 
    end if; 
  end END_OF_SKELETON; 

  procedure GET_FILE_LINE(BUFFER : in out FILE_STRING.VSTRING) is 
  begin
    if (USE_EXTERNAL_SKELETON) then 
      GET_EXTERNAL(BUFFER); 
    else 
      GET_INTERNAL(BUFFER); 
    end if; 
  end GET_FILE_LINE; 

  -- skelout - write out one section of the skeleton file
  --
  -- DESCRIPTION
  --    Either outputs internal skeleton, or from a file with "%%" dividers
  --    if a skeleton file is specified by the user.
  --    Copies from skelfile to stdout until a line beginning with "%%" or
  --    EOF is found.

  procedure SKELOUT is 
    BUF      : FILE_STRING.VSTRING; 
    LINE_LEN : INTEGER; 
  begin
    while (not END_OF_SKELETON) loop
      GET_FILE_LINE(BUF); 
      if ((FILE_STRING.LEN(BUF) >= 2)
          and then ((FILE_STRING.CHAR(BUF, 1) = '%')
                     and (FILE_STRING.CHAR(BUF, 2) = '%'))) then 
        exit; 
      else 
        FILE_STRING.PUT_LINE(BUF); 
      end if; 
    end loop; 
  end SKELOUT; 

end SKELETON_MANAGER; 
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- This software was developed by John Self of the Arcadia project
-- at the University of California, Irvine.
--
-- 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.

-- TITLE skeleton manager
-- AUTHOR: John Self (UCI)
-- DESCRIPTION outputs skeleton sections when called by gen.
-- NOTES allows use of internal or external skeleton
-- $Header: /co/ua/self/arcadia/aflex/ada/src/RCS/skeleton_managerS.a,v 1.3 90/01/12 15:20:38 self Exp Locker: self $ 

with TSTRING; use TSTRING; 
package SKELETON_MANAGER is 
  procedure SKELOUT; 
  procedure SET_EXTERNAL_SKELETON; 
end SKELETON_MANAGER; 
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- This software was developed by John Self of the Arcadia project
-- at the University of California, Irvine.
--
-- 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.

-- TITLE symbol table routines
-- AUTHOR: John Self (UCI)
-- DESCRIPTION implements only a simple symbol table using open hashing
-- NOTES could be faster, but it isn't used much
-- $Header: /co/ua/self/arcadia/aflex/ada/src/RCS/symB.a,v 1.6 90/01/12 15:20:39 self Exp Locker: self $ 

with MISC_DEFS, MISC, NFA, TEXT_IO, INT_IO, TSTRING; 

package body SYM is 
  use MISC_DEFS; 
  use TSTRING; 

  -- addsym - add symbol and definitions to symbol table
  --
  -- true is returned if the symbol already exists, and the change not made.

  procedure ADDSYM(SYM, STR_DEF : in VSTRING; 
                   INT_DEF      : in INTEGER; 
                   TABLE        : in out HASH_TABLE; 
                   TABLE_SIZE   : in INTEGER; 
                   RESULT       : out BOOLEAN) is 
    HASH_VAL             : INTEGER := HASHFUNCT(SYM, TABLE_SIZE); 
    SYM_ENTRY            : HASH_LINK := TABLE(HASH_VAL); 
    NEW_ENTRY, SUCCESSOR : HASH_LINK; 
  begin
    while (SYM_ENTRY /= null) loop
      if (SYM = SYM_ENTRY.NAME) then 

        -- entry already exists
        RESULT := TRUE; 
        return; 
      end if; 

      SYM_ENTRY := SYM_ENTRY.NEXT; 
    end loop; 

    -- create new entry
    NEW_ENTRY := new HASH_ENTRY; 

    SUCCESSOR := TABLE(HASH_VAL); 
    if ((SUCCESSOR /= null)) then 
      NEW_ENTRY.NEXT := SUCCESSOR; 
      SUCCESSOR.PREV := NEW_ENTRY; 
    else 
      NEW_ENTRY.NEXT := null; 
    end if; 

    NEW_ENTRY.PREV := null; 
    NEW_ENTRY.NAME := SYM; 
    NEW_ENTRY.STR_VAL := STR_DEF; 
    NEW_ENTRY.INT_VAL := INT_DEF; 

    TABLE(HASH_VAL) := NEW_ENTRY; 

    RESULT := FALSE; 
    return; 

  exception
    when STORAGE_ERROR => 
      MISC.AFLEXFATAL("symbol table memory allocation failed"); 
  end ADDSYM; 


  -- cclinstal - save the text of a character class

  procedure CCLINSTAL(CCLTXT : in VSTRING; 
                      CCLNUM : in INTEGER) is 
  -- we don't bother checking the return status because we are not called
  -- unless the symbol is new
    DUMMY : BOOLEAN; 
  begin
    ADDSYM(CCLTXT, NUL, CCLNUM, CCLTAB, CCL_HASH_SIZE, DUMMY); 
  end CCLINSTAL; 


  -- ccllookup - lookup the number associated with character class text

  function CCLLOOKUP(CCLTXT : in VSTRING) return INTEGER is 
  begin
    return FINDSYM(CCLTXT, CCLTAB, CCL_HASH_SIZE).INT_VAL; 
  end CCLLOOKUP; 

  -- findsym - find symbol in symbol table

  function FINDSYM(SYMBOL     : in VSTRING; 
                   TABLE      : in HASH_TABLE; 
                   TABLE_SIZE : in INTEGER) return HASH_LINK is 
    SYM_ENTRY   : HASH_LINK := TABLE(HASHFUNCT(SYMBOL, TABLE_SIZE)); 
    EMPTY_ENTRY : HASH_LINK; 
  begin
    while (SYM_ENTRY /= null) loop
      if (SYMBOL = SYM_ENTRY.NAME) then 
        return SYM_ENTRY; 
      end if; 
      SYM_ENTRY := SYM_ENTRY.NEXT; 
    end loop; 
    EMPTY_ENTRY := new HASH_ENTRY; 
    EMPTY_ENTRY.all := (null, null, NUL, NUL, 0); 

    return EMPTY_ENTRY; 
  exception
    when STORAGE_ERROR => 
      MISC.AFLEXFATAL("dynamic memory failure in findsym()"); 
      return EMPTY_ENTRY; 
  end FINDSYM; 

  -- hashfunct - compute the hash value for "str" and hash size "hash_size"

  function HASHFUNCT(STR       : in VSTRING; 
                     HASH_SIZE : in INTEGER) return INTEGER is 
    HASHVAL, LOCSTR : INTEGER; 
  begin
    HASHVAL := 0; 
    LOCSTR := TSTRING.FIRST; 

    while (LOCSTR <= TSTRING.LEN(STR)) loop
      HASHVAL := ((HASHVAL*2) + CHARACTER'POS(CHAR(STR, LOCSTR))) mod HASH_SIZE
        ; 
      LOCSTR := LOCSTR + 1; 
    end loop; 

    return HASHVAL; 
  end HASHFUNCT; 


  --ndinstal - install a name definition

  procedure NDINSTAL(ND, DEF : in VSTRING) is 
    RESULT : BOOLEAN; 
  begin
    ADDSYM(ND, DEF, 0, NDTBL, NAME_TABLE_HASH_SIZE, RESULT); 
    if (RESULT) then 
      MISC.SYNERR("name defined twice"); 
    end if; 
  end NDINSTAL; 

  -- ndlookup - lookup a name definition

  function NDLOOKUP(ND : in VSTRING) return VSTRING is 
  begin
    return FINDSYM(ND, NDTBL, NAME_TABLE_HASH_SIZE).STR_VAL; 
  end NDLOOKUP; 

  -- scinstal - make a start condition
  --
  -- NOTE
  --    the start condition is Exclusive if xcluflg is true

  procedure SCINSTAL(STR     : in VSTRING; 
                     XCLUFLG : in BOOLEAN) is 
  -- bit of a hack.  We know how the default start-condition is
  -- declared, and don't put out a define for it, because it
  -- would come out as "#define 0 1"

  -- actually, this is no longer the case.  The default start-condition
  -- is now called "INITIAL".  But we keep the following for the sake
  -- of future robustness.
    RESULT : BOOLEAN; 
  begin
    if (STR /= VSTR("0")) then 
      TSTRING.PUT(DEF_FILE, STR); 
      TEXT_IO.PUT(DEF_FILE, " : constant := "); 
      INT_IO.PUT(DEF_FILE, LASTSC, 1); 
      TEXT_IO.PUT_LINE(DEF_FILE, ";"); 
    end if; 

    LASTSC := LASTSC + 1; 
    if (LASTSC >= CURRENT_MAX_SCS) then 
      CURRENT_MAX_SCS := CURRENT_MAX_SCS + MAX_SCS_INCREMENT; 

      NUM_REALLOCS := NUM_REALLOCS + 1; 

      REALLOCATE_INTEGER_ARRAY(SCSET, CURRENT_MAX_SCS); 
      REALLOCATE_INTEGER_ARRAY(SCBOL, CURRENT_MAX_SCS); 
      REALLOCATE_BOOLEAN_ARRAY(SCXCLU, CURRENT_MAX_SCS); 
      REALLOCATE_BOOLEAN_ARRAY(SCEOF, CURRENT_MAX_SCS); 
      REALLOCATE_VSTRING_ARRAY(SCNAME, CURRENT_MAX_SCS); 
      REALLOCATE_INTEGER_ARRAY(ACTVSC, CURRENT_MAX_SCS); 
    end if; 

    SCNAME(LASTSC) := STR; 

    ADDSYM(SCNAME(LASTSC), NUL, LASTSC, SCTBL, START_COND_HASH_SIZE, RESULT); 
    if (RESULT) then 
      MISC.AFLEXERROR("start condition " & STR & " declared twice"); 
    end if; 

    SCSET(LASTSC) := NFA.MKSTATE(SYM_EPSILON); 
    SCBOL(LASTSC) := NFA.MKSTATE(SYM_EPSILON); 
    SCXCLU(LASTSC) := XCLUFLG; 
    SCEOF(LASTSC) := FALSE; 
  end SCINSTAL; 


  -- sclookup - lookup the number associated with a start condition

  function SCLOOKUP(STR : in VSTRING) return INTEGER is 
  begin
    return FINDSYM(STR, SCTBL, START_COND_HASH_SIZE).INT_VAL; 
  end SCLOOKUP; 

end SYM; 
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- This software was developed by John Self of the Arcadia project
-- at the University of California, Irvine.
--
-- 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.

-- TITLE symbol table routines
-- AUTHOR: John Self (UCI)
-- DESCRIPTION implements only a simple symbol table using open hashing
-- NOTES could be faster, but it isn't used much
-- $Header: /co/ua/self/arcadia/aflex/ada/src/RCS/symS.a,v 1.4 90/01/12 15:20:42 self Exp Locker: self $ 

with TSTRING; 
with MISC_DEFS; 
package SYM is 

  use TSTRING; 
  use MISC_DEFS; 

  procedure ADDSYM(SYM, STR_DEF : in VSTRING; 
                   INT_DEF      : in INTEGER; 
                   TABLE        : in out HASH_TABLE; 
                   TABLE_SIZE   : in INTEGER; 
                   RESULT       : out BOOLEAN); 
  -- result indicates success
  procedure CCLINSTAL(CCLTXT : in VSTRING; 
                      CCLNUM : in INTEGER); 
  function CCLLOOKUP(CCLTXT : in VSTRING) return INTEGER; 
  function FINDSYM(SYMBOL     : in VSTRING; 
                   TABLE      : in HASH_TABLE; 
                   TABLE_SIZE : in INTEGER) return HASH_LINK; 

  function HASHFUNCT(STR       : in VSTRING; 
                     HASH_SIZE : in INTEGER) return INTEGER; 
  procedure NDINSTAL(ND, DEF : in VSTRING); 
  function NDLOOKUP(ND : in VSTRING) return VSTRING; 
  procedure SCINSTAL(STR     : in VSTRING; 
                     XCLUFLG : in BOOLEAN); 
  function SCLOOKUP(STR : in VSTRING) return INTEGER; 
end SYM; 
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- This software was developed by John Self of the Arcadia project
-- at the University of California, Irvine.
--
-- 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.

-- TITLE table compression routines
-- AUTHOR: John Self (UCI)
-- DESCRIPTION used for compressed tables only
-- NOTES somewhat complicated but works fast and generates efficient scanners
-- $Header: /co/ua/self/arcadia/aflex/ada/src/RCS/tblcmpB.a,v 1.8 90/01/12 15:20:43 self Exp Locker: self $ 

with DFA, ECS, MISC_DEFS; use MISC_DEFS; 
package body TBLCMP is 

-- bldtbl - build table entries for dfa state
--
-- synopsis
--   int state[numecs], statenum, totaltrans, comstate, comfreq;
--   bldtbl( state, statenum, totaltrans, comstate, comfreq );
--
-- State is the statenum'th dfa state.  It is indexed by equivalence class and
-- gives the number of the state to enter for a given equivalence class.
-- totaltrans is the total number of transitions out of the state.  Comstate
-- is that state which is the destination of the most transitions out of State.
-- Comfreq is how many transitions there are out of State to Comstate.
--
-- A note on terminology:
--    "protos" are transition tables which have a high probability of
-- either being redundant (a state processed later will have an identical
-- transition table) or nearly redundant (a state processed later will have
-- many of the same out-transitions).  A "most recently used" queue of
-- protos is kept around with the hope that most states will find a proto
-- which is similar enough to be usable, and therefore compacting the
-- output tables.
--    "templates" are a special type of proto.  If a transition table is
-- homogeneous or nearly homogeneous (all transitions go to the same
-- destination) then the odds are good that future states will also go
-- to the same destination state on basically the same character set.
-- These homogeneous states are so common when dealing with large rule
-- sets that they merit special attention.  If the transition table were
-- simply made into a proto, then (typically) each subsequent, similar
-- state will differ from the proto for two out-transitions.  One of these
-- out-transitions will be that character on which the proto does not go
-- to the common destination, and one will be that character on which the
-- state does not go to the common destination.  Templates, on the other
-- hand, go to the common state on EVERY transition character, and therefore
-- cost only one difference.

  procedure BLDTBL(STATE                                   : in 
                     UNBOUNDED_INT_ARRAY; 
                   STATENUM, TOTALTRANS, COMSTATE, COMFREQ : in INTEGER) is 
    EXTPTR : INTEGER; 
    subtype CARRAY is UNBOUNDED_INT_ARRAY(0 .. CSIZE + 1); 
    EXTRCT                 : array(0 .. 1) of CARRAY; 
    MINDIFF, MINPROT, I, D : INTEGER; 
    CHECKCOM               : BOOLEAN; 
    LOCAL_COMSTATE         : INTEGER; 
  begin

    -- If extptr is 0 then the first array of extrct holds the result of the
    -- "best difference" to date, which is those transitions which occur in
    -- "state" but not in the proto which, to date, has the fewest differences
    -- between itself and "state".  If extptr is 1 then the second array of
    -- extrct hold the best difference.  The two arrays are toggled
    -- between so that the best difference to date can be kept around and
    -- also a difference just created by checking against a candidate "best"
    -- proto.
    LOCAL_COMSTATE := COMSTATE; 
    EXTPTR := 0; 

    -- if the state has too few out-transitions, don't bother trying to
    -- compact its tables
    if ((TOTALTRANS*100) < (NUMECS*PROTO_SIZE_PERCENTAGE)) then 
      MKENTRY(STATE, NUMECS, STATENUM, JAMSTATE_CONST, TOTALTRANS); 
    else 

      -- checkcom is true if we should only check "state" against
      -- protos which have the same "comstate" value
      CHECKCOM := COMFREQ*100 > TOTALTRANS*CHECK_COM_PERCENTAGE; 

      MINPROT := FIRSTPROT; 
      MINDIFF := TOTALTRANS; 

      if (CHECKCOM) then 

        -- find first proto which has the same "comstate"
        I := FIRSTPROT; 
        while (I /= NIL) loop
          if (PROTCOMST(I) = LOCAL_COMSTATE) then 
            MINPROT := I; 
            TBLDIFF(STATE, MINPROT, EXTRCT(EXTPTR), MINDIFF); 
            exit; 
          end if; 
          I := PROTNEXT(I); 
        end loop; 
      else 

        -- since we've decided that the most common destination out
        -- of "state" does not occur with a high enough frequency,
        -- we set the "comstate" to zero, assuring that if this state
        -- is entered into the proto list, it will not be considered
        -- a template.
        LOCAL_COMSTATE := 0; 

        if (FIRSTPROT /= NIL) then 
          MINPROT := FIRSTPROT; 
          TBLDIFF(STATE, MINPROT, EXTRCT(EXTPTR), MINDIFF); 
        end if; 
      end if; 

      -- we now have the first interesting proto in "minprot".  If
      -- it matches within the tolerances set for the first proto,
      -- we don't want to bother scanning the rest of the proto list
      -- to see if we have any other reasonable matches.
      if (MINDIFF*100 > TOTALTRANS*FIRST_MATCH_DIFF_PERCENTAGE) then 

        -- not a good enough match.  Scan the rest of the protos 
        I := MINPROT; 
        while (I /= NIL) loop
          TBLDIFF(STATE, I, EXTRCT(1 - EXTPTR), D); 
          if (D < MINDIFF) then 
            EXTPTR := 1 - EXTPTR; 
            MINDIFF := D; 
            MINPROT := I; 
          end if; 
          I := PROTNEXT(I); 
        end loop; 
      end if; 

      -- check if the proto we've decided on as our best bet is close
      -- enough to the state we want to match to be usable
      if (MINDIFF*100 > TOTALTRANS*ACCEPTABLE_DIFF_PERCENTAGE) then 

        -- no good.  If the state is homogeneous enough, we make a
        -- template out of it.  Otherwise, we make a proto.
        if (COMFREQ*100 >= TOTALTRANS*TEMPLATE_SAME_PERCENTAGE) then 
          MKTEMPLATE(STATE, STATENUM, LOCAL_COMSTATE); 
        else 
          MKPROT(STATE, STATENUM, LOCAL_COMSTATE); 
          MKENTRY(STATE, NUMECS, STATENUM, JAMSTATE_CONST, TOTALTRANS); 
        end if; 
      else 

        -- use the proto
        MKENTRY(EXTRCT(EXTPTR), NUMECS, STATENUM, PROTTBL(MINPROT), MINDIFF); 

        -- if this state was sufficiently different from the proto
        -- we built it from, make it, too, a proto
        if (MINDIFF*100 >= TOTALTRANS*NEW_PROTO_DIFF_PERCENTAGE) then 
          MKPROT(STATE, STATENUM, LOCAL_COMSTATE); 
        end if; 

        -- since mkprot added a new proto to the proto queue, it's possible
        -- that "minprot" is no longer on the proto queue (if it happened
        -- to have been the last entry, it would have been bumped off).
        -- If it's not there, then the new proto took its physical place
        -- (though logically the new proto is at the beginning of the
        -- queue), so in that case the following call will do nothing.
        MV2FRONT(MINPROT); 
      end if; 
    end if; 
  end BLDTBL; 

  -- cmptmps - compress template table entries
  --
  --  template tables are compressed by using the 'template equivalence
  --  classes', which are collections of transition character equivalence
--  classes which always appear together in templates - really meta-equivalence
  --  classes.  until this point, the tables for templates have been stored
  --  up at the top end of the nxt array; they will now be compressed and have
  --  table entries made for them.

  procedure CMPTMPS is 
    TMPSTORAGE        : C_SIZE_ARRAY; 
    TOTALTRANS, TRANS : INTEGER; 
  begin
    PEAKPAIRS := NUMTEMPS*NUMECS + TBLEND; 

    if (USEMECS) then 

      -- create equivalence classes base on data gathered on template
      -- transitions
      ECS.CRE8ECS(TECFWD, TECBCK, NUMECS, NUMMECS); 
    else 
      NUMMECS := NUMECS; 
    end if; 

    if (LASTDFA + NUMTEMPS + 1 >= CURRENT_MAX_DFAS) then 
      DFA.INCREASE_MAX_DFAS; 
    end if; 

    -- loop through each template
    for I in 1 .. NUMTEMPS loop
      TOTALTRANS := 0; 

      -- number of non-jam transitions out of this template
      for J in 1 .. NUMECS loop
        TRANS := TNXT(NUMECS*I + J); 

        if (USEMECS) then 

          -- the absolute value of tecbck is the meta-equivalence class
          -- of a given equivalence class, as set up by cre8ecs
          if (TECBCK(J) > 0) then 
            TMPSTORAGE(TECBCK(J)) := TRANS; 

            if (TRANS > 0) then 
              TOTALTRANS := TOTALTRANS + 1; 
            end if; 
          end if; 
        else 
          TMPSTORAGE(J) := TRANS; 

          if (TRANS > 0) then 
            TOTALTRANS := TOTALTRANS + 1; 
          end if; 
        end if; 
      end loop; 

      -- it is assumed (in a rather subtle way) in the skeleton that
      -- if we're using meta-equivalence classes, the def[] entry for
      -- all templates is the jam template, i.e., templates never default
      -- to other non-jam table entries (e.g., another template)

      -- leave room for the jam-state after the last real state
      MKENTRY(TMPSTORAGE, NUMMECS, LASTDFA + I + 1, JAMSTATE_CONST, TOTALTRANS)
        ; 
    end loop; 
  end CMPTMPS; 

  -- expand_nxt_chk - expand the next check arrays

  procedure EXPAND_NXT_CHK is 
    OLD_MAX : INTEGER := CURRENT_MAX_XPAIRS; 
  begin
    CURRENT_MAX_XPAIRS := CURRENT_MAX_XPAIRS + MAX_XPAIRS_INCREMENT; 

    NUM_REALLOCS := NUM_REALLOCS + 1; 

    REALLOCATE_INTEGER_ARRAY(NXT, CURRENT_MAX_XPAIRS); 
    REALLOCATE_INTEGER_ARRAY(CHK, CURRENT_MAX_XPAIRS); 

    for I in OLD_MAX .. CURRENT_MAX_XPAIRS loop
      CHK(I) := 0; 
    end loop; 
  end EXPAND_NXT_CHK; 

  -- find_table_space - finds a space in the table for a state to be placed
  --
  -- State is the state to be added to the full speed transition table.
  -- Numtrans is the number of out-transitions for the state.
  --
-- find_table_space() returns the position of the start of the first block (in
  -- chk) able to accommodate the state
  --
-- In determining if a state will or will not fit, find_table_space() must take
  -- into account the fact that an end-of-buffer state will be added at [0],
  -- and an action number will be added in [-1].

  function FIND_TABLE_SPACE(STATE    : in UNBOUNDED_INT_ARRAY; 
                            NUMTRANS : in INTEGER) return INTEGER is 
  -- firstfree is the position of the first possible occurrence of two
  -- consecutive unused records in the chk and nxt arrays

    I                                              : INTEGER; 
    STATE_PTR, CHK_PTR, PTR_TO_LAST_ENTRY_IN_STATE : INT_PTR; 
    CNT, SCNT                                      : INTEGER; 
    -- if there are too many out-transitions, put the state at the end of
    -- nxt and chk
  begin
    if (NUMTRANS > MAX_XTIONS_FULL_INTERIOR_FIT) then 

      -- if table is empty, return the first available spot in chk/nxt,
      -- which should be 1
      if (TBLEND < 2) then 
        return (1); 
      end if; 

      I := TBLEND - NUMECS; 

    -- start searching for table space near the
    -- end of chk/nxt arrays
    else 
      I := FIRSTFREE; 

    -- start searching for table space from the
    -- beginning (skipping only the elements
    -- which will definitely not hold the new
    -- state)
    end if; 

    loop

      -- loops until a space is found
      if (I + NUMECS > CURRENT_MAX_XPAIRS) then 
        EXPAND_NXT_CHK; 
      end if; 

      -- loops until space for end-of-buffer and action number are found
      loop
        if (CHK(I - 1) = 0) then 

          -- check for action number space
          if (CHK(I) = 0) then 

            -- check for end-of-buffer space
            exit; 
          else 
            I := I + 2; 

          -- since i != 0, there is no use checking to
          -- see if (++i) - 1 == 0, because that's the
          -- same as i == 0, so we skip a space
          end if; 
        else 
          I := I + 1; 
        end if; 

        if (I + NUMECS > CURRENT_MAX_XPAIRS) then 
          EXPAND_NXT_CHK; 
        end if; 
      end loop; 

      -- if we started search from the beginning, store the new firstfree for
      -- the next call of find_table_space()
      if (NUMTRANS <= MAX_XTIONS_FULL_INTERIOR_FIT) then 
        FIRSTFREE := I + 1; 
      end if; 

      -- check to see if all elements in chk (and therefore nxt) that are
      -- needed for the new state have not yet been taken
      CNT := I + 1; 
      SCNT := 1; 
      while (CNT /= I + NUMECS + 1) loop
        if ((STATE(SCNT) /= 0) and (CHK(CNT) /= 0)) then 
          exit; 
        end if; 
        SCNT := SCNT + 1; 
        CNT := CNT + 1; 
      end loop; 

      if (CNT = I + NUMECS + 1) then 
        return I; 
      else 
        I := I + 1; 
      end if; 
    end loop; 
  end FIND_TABLE_SPACE; 

  -- inittbl - initialize transition tables
  --
-- Initializes "firstfree" to be one beyond the end of the table.  Initializes
  -- all "chk" entries to be zero.  Note that templates are built in their
  -- own tbase/tdef tables.  They are shifted down to be contiguous
  -- with the non-template entries during table generation.

  procedure INITTBL is 
  begin
    for I in 0 .. CURRENT_MAX_XPAIRS loop
      CHK(I) := 0; 
    end loop; 

    TBLEND := 0; 
    FIRSTFREE := TBLEND + 1; 
    NUMTEMPS := 0; 

    if (USEMECS) then 

      -- set up doubly-linked meta-equivalence classes
      -- these are sets of equivalence classes which all have identical
      -- transitions out of TEMPLATES
      TECBCK(1) := NIL; 

      for I in 2 .. NUMECS loop
        TECBCK(I) := I - 1; 
        TECFWD(I - 1) := I; 
      end loop; 

      TECFWD(NUMECS) := NIL; 
    end if; 
  end INITTBL; 

  -- mkdeftbl - make the default, "jam" table entries

  procedure MKDEFTBL is 
  begin
    JAMSTATE := LASTDFA + 1; 

    TBLEND := TBLEND + 1; 

    -- room for transition on end-of-buffer character
    if (TBLEND + NUMECS > CURRENT_MAX_XPAIRS) then 
      EXPAND_NXT_CHK; 
    end if; 

    -- add in default end-of-buffer transition
    NXT(TBLEND) := END_OF_BUFFER_STATE; 
    CHK(TBLEND) := JAMSTATE; 

    for I in 1 .. NUMECS loop
      NXT(TBLEND + I) := 0; 
      CHK(TBLEND + I) := JAMSTATE; 
    end loop; 

    JAMBASE := TBLEND; 

    BASE(JAMSTATE) := JAMBASE; 
    DEF(JAMSTATE) := 0; 

    TBLEND := TBLEND + NUMECS; 
    NUMTEMPS := NUMTEMPS + 1; 
  end MKDEFTBL; 

  -- mkentry - create base/def and nxt/chk entries for transition array
  --
  -- "state" is a transition array "numchars" characters in size, "statenum"
  -- is the offset to be used into the base/def tables, and "deflink" is the
  -- entry to put in the "def" table entry.  If "deflink" is equal to
  -- "JAMSTATE", then no attempt will be made to fit zero entries of "state"
  -- (i.e., jam entries) into the table.  It is assumed that by linking to
  -- "JAMSTATE" they will be taken care of.  In any case, entries in "state"
  -- marking transitions to "SAME_TRANS" are treated as though they will be
  -- taken care of by whereever "deflink" points.  "totaltrans" is the total
-- number of transitions out of the state.  If it is below a certain threshold,
  -- the tables are searched for an interior spot that will accommodate the
  -- state array.

  procedure MKENTRY(STATE                                   : in 
                      UNBOUNDED_INT_ARRAY; 
                    NUMCHARS, STATENUM, DEFLINK, TOTALTRANS : in INTEGER) is 
    I, MINEC, MAXEC, BASEADDR, TBLBASE, TBLLAST : INTEGER; 
  begin
    if (TOTALTRANS = 0) then 

      -- there are no out-transitions
      if (DEFLINK = JAMSTATE_CONST) then 
        BASE(STATENUM) := JAMSTATE_CONST; 
      else 
        BASE(STATENUM) := 0; 
      end if; 

      DEF(STATENUM) := DEFLINK; 
      return; 
    end if; 

    MINEC := 1; 
    while (MINEC <= NUMCHARS) loop
      if (STATE(MINEC) /= SAME_TRANS) then 
        if ((STATE(MINEC) /= 0) or (DEFLINK /= JAMSTATE_CONST)) then 
          exit; 
        end if; 
      end if; 
      MINEC := MINEC + 1; 
    end loop; 

    if (TOTALTRANS = 1) then 

      -- there's only one out-transition.  Save it for later to fill
      -- in holes in the tables.
      STACK1(STATENUM, MINEC, STATE(MINEC), DEFLINK); 
      return; 
    end if; 

    MAXEC := NUMCHARS; 
    while (MAXEC >= 1) loop
      if (STATE(MAXEC) /= SAME_TRANS) then 
        if ((STATE(MAXEC) /= 0) or (DEFLINK /= JAMSTATE_CONST)) then 
          exit; 
        end if; 
      end if; 
      MAXEC := MAXEC - 1; 
    end loop; 

    -- Whether we try to fit the state table in the middle of the table
    -- entries we have already generated, or if we just take the state
    -- table at the end of the nxt/chk tables, we must make sure that we
    -- have a valid base address (i.e., non-negative).  Note that not only are
    -- negative base addresses dangerous at run-time (because indexing the
    -- next array with one and a low-valued character might generate an
    -- array-out-of-bounds error message), but at compile-time negative
    -- base addresses denote TEMPLATES.

    -- find the first transition of state that we need to worry about.
    if (TOTALTRANS*100 <= NUMCHARS*INTERIOR_FIT_PERCENTAGE) then 

      -- attempt to squeeze it into the middle of the tabls
      BASEADDR := FIRSTFREE; 

      while (BASEADDR < MINEC) loop

        -- using baseaddr would result in a negative base address below
        -- find the next free slot
        BASEADDR := BASEADDR + 1; 
        while (CHK(BASEADDR) /= 0) loop
          BASEADDR := BASEADDR + 1; 
        end loop; 
      end loop; 

      if (BASEADDR + MAXEC - MINEC >= CURRENT_MAX_XPAIRS) then 
        EXPAND_NXT_CHK; 
      end if; 

      I := MINEC; 
      while (I <= MAXEC) loop
        if (STATE(I) /= SAME_TRANS) then 
          if ((STATE(I) /= 0) or (DEFLINK /= JAMSTATE_CONST)) then 
            if (CHK(BASEADDR + I - MINEC) /= 0) then 

              -- baseaddr unsuitable - find another
              BASEADDR := BASEADDR + 1; 
              while ((BASEADDR < CURRENT_MAX_XPAIRS) and (CHK(BASEADDR) /= 0))
                loop
                BASEADDR := BASEADDR + 1; 
              end loop; 

              if (BASEADDR + MAXEC - MINEC >= CURRENT_MAX_XPAIRS) then 
                EXPAND_NXT_CHK; 
              end if; 

              -- reset the loop counter so we'll start all
              -- over again next time it's incremented
              I := MINEC - 1; 
            end if; 
          end if; 
        end if; 
        I := I + 1; 
      end loop; 
    else 

      -- ensure that the base address we eventually generate is
      -- non-negative
      BASEADDR := MAX(TBLEND + 1, MINEC); 
    end if; 

    TBLBASE := BASEADDR - MINEC; 
    TBLLAST := TBLBASE + MAXEC; 

    if (TBLLAST >= CURRENT_MAX_XPAIRS) then 
      EXPAND_NXT_CHK; 
    end if; 

    BASE(STATENUM) := TBLBASE; 
    DEF(STATENUM) := DEFLINK; 

    for J in MINEC .. MAXEC loop
      if (STATE(J) /= SAME_TRANS) then 
        if ((STATE(J) /= 0) or (DEFLINK /= JAMSTATE_CONST)) then 
          NXT(TBLBASE + J) := STATE(J); 
          CHK(TBLBASE + J) := STATENUM; 
        end if; 
      end if; 
    end loop; 

    if (BASEADDR = FIRSTFREE) then 

      -- find next free slot in tables
      FIRSTFREE := FIRSTFREE + 1; 
      while (CHK(FIRSTFREE) /= 0) loop
        FIRSTFREE := FIRSTFREE + 1; 
      end loop; 
    end if; 

    TBLEND := MAX(TBLEND, TBLLAST); 
  end MKENTRY; 

  -- mk1tbl - create table entries for a state (or state fragment) which
  --            has only one out-transition

  procedure MK1TBL(STATE, SYM, ONENXT, ONEDEF : in INTEGER) is 
  begin
    if (FIRSTFREE < SYM) then 
      FIRSTFREE := SYM; 
    end if; 

    while (CHK(FIRSTFREE) /= 0) loop
      FIRSTFREE := FIRSTFREE + 1; 
      if (FIRSTFREE >= CURRENT_MAX_XPAIRS) then 
        EXPAND_NXT_CHK; 
      end if; 
    end loop; 

    BASE(STATE) := FIRSTFREE - SYM; 
    DEF(STATE) := ONEDEF; 
    CHK(FIRSTFREE) := STATE; 
    NXT(FIRSTFREE) := ONENXT; 

    if (FIRSTFREE > TBLEND) then 
      TBLEND := FIRSTFREE; 
      FIRSTFREE := FIRSTFREE + 1; 

      if (FIRSTFREE >= CURRENT_MAX_XPAIRS) then 
        EXPAND_NXT_CHK; 
      end if; 
    end if; 
  end MK1TBL; 

  -- mkprot - create new proto entry

  procedure MKPROT(STATE              : in UNBOUNDED_INT_ARRAY; 
                   STATENUM, COMSTATE : in INTEGER) is 
    SLOT, TBLBASE : INTEGER; 
  begin
    NUMPROTS := NUMPROTS + 1; 
    if ((NUMPROTS >= MSP) or (NUMECS*NUMPROTS >= PROT_SAVE_SIZE)) then 

      -- gotta make room for the new proto by dropping last entry in
      -- the queue
      SLOT := LASTPROT; 
      LASTPROT := PROTPREV(LASTPROT); 
      PROTNEXT(LASTPROT) := NIL; 
    else 
      SLOT := NUMPROTS; 
    end if; 

    PROTNEXT(SLOT) := FIRSTPROT; 

    if (FIRSTPROT /= NIL) then 
      PROTPREV(FIRSTPROT) := SLOT; 
    end if; 

    FIRSTPROT := SLOT; 
    PROTTBL(SLOT) := STATENUM; 
    PROTCOMST(SLOT) := COMSTATE; 

    -- copy state into save area so it can be compared with rapidly
    TBLBASE := NUMECS*(SLOT - 1); 

    for I in 1 .. NUMECS loop
      PROTSAVE(TBLBASE + I) := STATE(I + STATE'FIRST); 
    end loop; 
  end MKPROT; 

-- mktemplate - create a template entry based on a state, and connect the state
  --              to it

  procedure MKTEMPLATE(STATE              : in UNBOUNDED_INT_ARRAY; 
                       STATENUM, COMSTATE : in INTEGER) is 
    NUMDIFF, TMPBASE : INTEGER; 
    TMP              : C_SIZE_ARRAY; 
    subtype TARRAY is CHAR_ARRAY(0 .. CSIZE); 
    TRANSSET : TARRAY; 
    TSPTR    : INTEGER; 
  begin
    NUMTEMPS := NUMTEMPS + 1; 

    TSPTR := 0; 

    -- calculate where we will temporarily store the transition table
    -- of the template in the tnxt[] array.  The final transition table
    -- gets created by cmptmps()
    TMPBASE := NUMTEMPS*NUMECS; 

    if (TMPBASE + NUMECS >= CURRENT_MAX_TEMPLATE_XPAIRS) then 
      CURRENT_MAX_TEMPLATE_XPAIRS := CURRENT_MAX_TEMPLATE_XPAIRS + 
        MAX_TEMPLATE_XPAIRS_INCREMENT; 

      NUM_REALLOCS := NUM_REALLOCS + 1; 

      REALLOCATE_INTEGER_ARRAY(TNXT, CURRENT_MAX_TEMPLATE_XPAIRS); 
    end if; 

    for I in 1 .. NUMECS loop
      if (STATE(I) = 0) then 
        TNXT(TMPBASE + I) := 0; 
      else 
        TRANSSET(TSPTR) := CHARACTER'VAL(I); 
        TSPTR := TSPTR + 1; 
        TNXT(TMPBASE + I) := COMSTATE; 
      end if; 
    end loop; 

    if (USEMECS) then 
      ECS.MKECCL(TRANSSET, TSPTR, TECFWD, TECBCK, NUMECS); 
    end if; 

    MKPROT(TNXT(TMPBASE .. CURRENT_MAX_TEMPLATE_XPAIRS),  -NUMTEMPS, COMSTATE); 

    -- we rely on the fact that mkprot adds things to the beginning
    -- of the proto queue
    TBLDIFF(STATE, FIRSTPROT, TMP, NUMDIFF); 
    MKENTRY(TMP, NUMECS, STATENUM,  -NUMTEMPS, NUMDIFF); 
  end MKTEMPLATE; 

  -- mv2front - move proto queue element to front of queue

  procedure MV2FRONT(QELM : in INTEGER) is 
  begin
    if (FIRSTPROT /= QELM) then 
      if (QELM = LASTPROT) then 
        LASTPROT := PROTPREV(LASTPROT); 
      end if; 

      PROTNEXT(PROTPREV(QELM)) := PROTNEXT(QELM); 

      if (PROTNEXT(QELM) /= NIL) then 
        PROTPREV(PROTNEXT(QELM)) := PROTPREV(QELM); 
      end if; 

      PROTPREV(QELM) := NIL; 
      PROTNEXT(QELM) := FIRSTPROT; 
      PROTPREV(FIRSTPROT) := QELM; 
      FIRSTPROT := QELM; 
    end if; 
  end MV2FRONT; 

  -- place_state - place a state into full speed transition table
  --
  -- State is the statenum'th state.  It is indexed by equivalence class and
  -- gives the number of the state to enter for a given equivalence class.
  -- Transnum is the number of out-transitions for the state.

  procedure PLACE_STATE(STATE              : in UNBOUNDED_INT_ARRAY; 
                        STATENUM, TRANSNUM : in INTEGER) is 
    I        : INTEGER; 
    POSITION : INTEGER := FIND_TABLE_SPACE(STATE, TRANSNUM); 
  begin

    -- base is the table of start positions
    BASE(STATENUM) := POSITION; 

    -- put in action number marker; this non-zero number makes sure that
    -- find_table_space() knows that this position in chk/nxt is taken
    -- and should not be used for another accepting number in another state
    CHK(POSITION - 1) := 1; 

    -- put in end-of-buffer marker; this is for the same purposes as above
    CHK(POSITION) := 1; 

    -- place the state into chk and nxt
    I := 1; 
    while (I <= NUMECS) loop
      if (STATE(I) /= 0) then 
        CHK(POSITION + I) := I; 
        NXT(POSITION + I) := STATE(I); 
      end if; 
      I := I + 1; 
    end loop; 

    if (POSITION + NUMECS > TBLEND) then 
      TBLEND := POSITION + NUMECS; 
    end if; 
  end PLACE_STATE; 

  -- stack1 - save states with only one out-transition to be processed later
  --
  -- if there's room for another state one the "one-transition" stack, the
  -- state is pushed onto it, to be processed later by mk1tbl.  If there's
  -- no room, we process the sucker right now.

  procedure STACK1(STATENUM, SYM, NEXTSTATE, DEFLINK : in INTEGER) is 
  begin
    if (ONESP >= ONE_STACK_SIZE - 1) then 
      MK1TBL(STATENUM, SYM, NEXTSTATE, DEFLINK); 
    else 
      ONESP := ONESP + 1; 
      ONESTATE(ONESP) := STATENUM; 
      ONESYM(ONESP) := SYM; 
      ONENEXT(ONESP) := NEXTSTATE; 
      ONEDEF(ONESP) := DEFLINK; 
    end if; 
  end STACK1; 

  -- tbldiff - compute differences between two state tables
  --
  -- "state" is the state array which is to be extracted from the pr'th
  -- proto.  "pr" is both the number of the proto we are extracting from
  -- and an index into the save area where we can find the proto's complete
  -- state table.  Each entry in "state" which differs from the corresponding
  -- entry of "pr" will appear in "ext".
  -- Entries which are the same in both "state" and "pr" will be marked
  -- as transitions to "SAME_TRANS" in "ext".  The total number of differences
  -- between "state" and "pr" is returned as function value.  Note that this
  -- number is "numecs" minus the number of "SAME_TRANS" entries in "ext".

  procedure TBLDIFF(STATE  : in UNBOUNDED_INT_ARRAY; 
                    PR     : in INTEGER; 
                    EXT    : out UNBOUNDED_INT_ARRAY; 
                    RESULT : out INTEGER) is 
    SP      : INTEGER := 0; 
    EP      : INTEGER := 0; 
    NUMDIFF : INTEGER := 0; 
    PROTP   : INTEGER; 
  begin
    PROTP := NUMECS*(PR - 1); 

    for I in reverse 1 .. NUMECS loop
      PROTP := PROTP + 1; 
      SP := SP + 1; 
      if (PROTSAVE(PROTP) = STATE(SP)) then 
        EP := EP + 1; 
        EXT(EP) := SAME_TRANS; 
      else 
        EP := EP + 1; 
        EXT(EP) := STATE(SP); 
        NUMDIFF := NUMDIFF + 1; 
      end if; 
    end loop; 

    RESULT := NUMDIFF; 
    return; 
  end TBLDIFF; 

end TBLCMP; 
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- This software was developed by John Self of the Arcadia project
-- at the University of California, Irvine.
--
-- 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.

-- TITLE table compression routines
-- AUTHOR: John Self (UCI)
-- DESCRIPTION used for compressed tables only
-- NOTES somewhat complicated but works fast and generates efficient scanners
-- $Header: /co/ua/self/arcadia/aflex/ada/src/RCS/tblcmpS.a,v 1.3 90/01/12 15:20:47 self Exp Locker: self $ 

with MISC_DEFS; use MISC_DEFS; 

package TBLCMP is 

-- bldtbl - build table entries for dfa state

  procedure BLDTBL(STATE                                   : in 
                     UNBOUNDED_INT_ARRAY; 
                   STATENUM, TOTALTRANS, COMSTATE, COMFREQ : in INTEGER); 

  procedure CMPTMPS; 

  -- expand_nxt_chk - expand the next check arrays

  procedure EXPAND_NXT_CHK; 

  -- find_table_space - finds a space in the table for a state to be placed

  function FIND_TABLE_SPACE(STATE    : in UNBOUNDED_INT_ARRAY; 
                            NUMTRANS : in INTEGER) return INTEGER; 

  -- inittbl - initialize transition tables

  procedure INITTBL; 

  -- mkdeftbl - make the default, "jam" table entries

  procedure MKDEFTBL; 

  -- mkentry - create base/def and nxt/chk entries for transition array

  procedure MKENTRY(STATE                                   : in 
                      UNBOUNDED_INT_ARRAY; 
                    NUMCHARS, STATENUM, DEFLINK, TOTALTRANS : in INTEGER); 

  -- mk1tbl - create table entries for a state (or state fragment) which
  --            has only one out-transition

  procedure MK1TBL(STATE, SYM, ONENXT, ONEDEF : in INTEGER); 

  -- mkprot - create new proto entry

  procedure MKPROT(STATE              : in UNBOUNDED_INT_ARRAY; 
                   STATENUM, COMSTATE : in INTEGER); 

-- mktemplate - create a template entry based on a state, and connect the state
  --              to it

  procedure MKTEMPLATE(STATE              : in UNBOUNDED_INT_ARRAY; 
                       STATENUM, COMSTATE : in INTEGER); 

  -- mv2front - move proto queue element to front of queue

  procedure MV2FRONT(QELM : in INTEGER); 

  -- place_state - place a state into full speed transition table

  procedure PLACE_STATE(STATE              : in UNBOUNDED_INT_ARRAY; 
                        STATENUM, TRANSNUM : in INTEGER); 

  -- stack1 - save states with only one out-transition to be processed later

  procedure STACK1(STATENUM, SYM, NEXTSTATE, DEFLINK : in INTEGER); 

  -- tbldiff - compute differences between two state tables

  procedure TBLDIFF(STATE  : in UNBOUNDED_INT_ARRAY; 
                    PR     : in INTEGER; 
                    EXT    : out UNBOUNDED_INT_ARRAY; 
                    RESULT : out INTEGER); 

end TBLCMP; 
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- This software was developed by John Self of the Arcadia project
-- at the University of California, Irvine.
--
-- 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.

-- TITLE template manager
-- AUTHOR: John Self (UCI)
-- DESCRIPTION supports output of internalized templates for the IO and DFA
--             packages.
-- NOTES This package is quite a memory hog, and is really only useful on
--       virtual memory systems.  It could use an external file to store the
--       templates like the skeleton manager.  This would save memory at the
--       cost of a slight reduction in speed and the necessity of keeping
--       copies of the template files in a known place.
-- $Header: /co/ua/self/arcadia/aflex/ada/src/RCS/template_managerB.a,v 1.20 90/10/15 20:00:53 self Exp Locker: self $ 

with FILE_STRING, MISC_DEFS, TEXT_IO, EXTERNAL_FILE_MANAGER, MISC, TSTRING; use 
  FILE_STRING, MISC_DEFS, TEXT_IO; 
package body TEMPLATE_MANAGER is 

  type FILE_ARRAY is array(POSITIVE range <>) of VSTRING; 

  DFA_TEMPLATE     : FILE_ARRAY(1 .. 66) := (
  --DFA TEMPLATE START
VSTR("yytext_ptr : integer; -- points to start of yytext in buffer"),
VSTR(""),
VSTR("-- yy_ch_buf has to be 2 characters longer than YY_BUF_SIZE because we need"),
VSTR("-- to put in 2 end-of-buffer characters (this is explained where it is"), 
VSTR("-- done) at the end of yy_ch_buf"),
VSTR("YY_READ_BUF_SIZE : constant integer :=  8192;"),
VSTR("YY_BUF_SIZE : constant integer := YY_READ_BUF_SIZE * 2; -- size of input buffer"),
VSTR("type unbounded_character_array is array(integer range <>) of character;"),
VSTR("subtype ch_buf_type is unbounded_character_array(0..YY_BUF_SIZE + 1);"),
VSTR("yy_ch_buf : ch_buf_type;"), VSTR("yy_cp, yy_bp : integer;"),
VSTR(""),
VSTR("-- yy_hold_char holds the character lost when yytext is formed"),
VSTR("yy_hold_char : character;"),
VSTR("yy_c_buf_p : integer;   -- points to current character in buffer"),
VSTR(""),
VSTR("function YYText return string;"),
VSTR("function YYLength return integer;"),
VSTR("procedure YY_DO_BEFORE_ACTION;"),
VSTR("--These variables are needed between calls to YYLex."),
VSTR("yy_init : boolean := true; -- do we need to initialize YYLex?"),
VSTR("yy_start : integer := 0; -- current start state number"),
VSTR("subtype yy_state_type is integer;"),
VSTR("yy_last_accepting_state : yy_state_type;"),
VSTR("yy_last_accepting_cpos : integer;"), VSTR("%%"),
VSTR("function YYText return string is"),
VSTR("    i : integer;"),
VSTR("    str_loc : integer := 1;"),
VSTR("    buffer : string(1..1024);"),
VSTR("    EMPTY_STRING : constant string := """";"),
VSTR("begin"),
VSTR("    -- find end of buffer"),
VSTR("    i := yytext_ptr;"),
VSTR("    while ( yy_ch_buf(i) /= ASCII.NUL ) loop"),
VSTR("    buffer(str_loc ) := yy_ch_buf(i);"),
VSTR("        i := i + 1;"),
VSTR("    str_loc := str_loc + 1;"),
VSTR("    end loop;"),
VSTR("--    return yy_ch_buf(yytext_ptr.. i - 1);"),
VSTR(""),
VSTR("    if (str_loc < 2) then"),
VSTR("        return EMPTY_STRING;"),
VSTR("    else"),
VSTR("      return buffer(1..str_loc-1);"),
VSTR("    end if;"),
VSTR(""),
VSTR("end;"),
VSTR(""),
VSTR("-- returns the length of the matched text"),
VSTR("function YYLength return integer is"),
VSTR("begin"), VSTR("    return yy_cp - yy_bp;"),
VSTR("end YYLength;"),
VSTR(""),
VSTR("-- done after the current pattern has been matched and before the"),
VSTR("-- corresponding action - sets up yytext"),
VSTR(""),
VSTR("procedure YY_DO_BEFORE_ACTION is"),
VSTR("begin"),
VSTR("    yytext_ptr := yy_bp;"),
VSTR("    yy_hold_char := yy_ch_buf(yy_cp);"), 
VSTR("    yy_ch_buf(yy_cp) := ASCII.NUL;"),
VSTR("    yy_c_buf_p := yy_cp;"),
VSTR("end YY_DO_BEFORE_ACTION;"),
VSTR("")
--DFA TEMPLATE END
); 

  DFA_CURRENT_LINE : INTEGER := 1; 

  IO_TEMPLATE      : FILE_ARRAY(1 .. 264) := (
  --IO TEMPLATE START
VSTR("with text_io; use text_io;"),
VSTR(""),
VSTR("%%"),
VSTR("NULL_IN_INPUT : exception;"),
VSTR("AFLEX_INTERNAL_ERROR : exception;"),
VSTR("UNEXPECTED_LAST_MATCH : exception;"),
VSTR("PUSHBACK_OVERFLOW : exception;"),
VSTR("AFLEX_SCANNER_JAMMED : exception;"),
VSTR("type eob_action_type is ( EOB_ACT_RESTART_SCAN,"),
VSTR("                          EOB_ACT_END_OF_FILE,"),
VSTR("                          EOB_ACT_LAST_MATCH );"),
VSTR("YY_END_OF_BUFFER_CHAR :  constant character:=  ASCII.NUL;"),
VSTR("yy_n_chars : integer;       -- number of characters read into yy_ch_buf"),
VSTR(""),
VSTR("-- true when we've seen an EOF for the current input file"),
VSTR("yy_eof_has_been_seen : boolean;"), VSTR(""),
VSTR("procedure YY_INPUT(buf: out unbounded_character_array; result: out integer; max_size: in integer);"),
VSTR("function yy_get_next_buffer return eob_action_type;"),
VSTR("procedure yyunput( c : character; yy_bp: in out integer );"),
VSTR("procedure unput(c : character);"),
VSTR("function input return character;"),
VSTR("procedure output(c : character);"),
VSTR("function yywrap return boolean;"),
VSTR("procedure Open_Input(fname : in String);"),
VSTR("procedure Close_Input;"),
VSTR("procedure Create_Output(fname : in String := """");"),
VSTR("procedure Close_Output;"),
VSTR("%%"),
VSTR("-- gets input and stuffs it into 'buf'.  number of characters read, or YY_NULL,"),
VSTR("-- is returned in 'result'."),
VSTR(""),
VSTR("procedure YY_INPUT(buf: out unbounded_character_array; result: out integer; max_size: in integer) is"),
VSTR("    c : character;"),
VSTR("    i : integer := 1;"),
VSTR("    loc : integer := buf'first;"),
VSTR("begin"),
VSTR("    while ( i <= max_size ) loop"),
VSTR("    if (end_of_line) then -- Ada ate our newline, put it back on the end."),
VSTR("            buf(loc) := ASCII.LF;"),
VSTR("            skip_line(1);"),
VSTR("%%"),
VSTR("        else"),
VSTR("            get(buf(loc));"), 
VSTR("    end if; "),
VSTR("    "),
VSTR("        loc := loc + 1;"),
VSTR("    i := i + 1;"),
VSTR("    end loop;"),
VSTR("    "),
VSTR("    result := i - 1; "),
VSTR("    exception"),
VSTR("        when END_ERROR => result := i - 1;"),
VSTR("    -- when we hit EOF we need to set yy_eof_has_been_seen"),
VSTR("    yy_eof_has_been_seen := true;"),
VSTR("end YY_INPUT;"),
VSTR(""),
VSTR("-- yy_get_next_buffer - try to read in new buffer"),
VSTR("--"),
VSTR("-- returns a code representing an action"),
VSTR("--     EOB_ACT_LAST_MATCH - "),
VSTR("--     EOB_ACT_RESTART_SCAN - restart the scanner"),
VSTR("--     EOB_ACT_END_OF_FILE - end of file"),
VSTR(""),
VSTR("function yy_get_next_buffer return eob_action_type is"),
VSTR("    dest : integer := 0;"),
VSTR("    source : integer := yytext_ptr - 1; -- copy prev. char, too"),
VSTR("    number_to_move : integer;"),
VSTR("    ret_val : eob_action_type;"), 
VSTR("    num_to_read : integer;"),
VSTR("begin    "),
VSTR("    if ( yy_c_buf_p > yy_n_chars + 1 ) then"),
VSTR("        raise NULL_IN_INPUT;"),
VSTR("    end if;"),
VSTR(""),
VSTR("    -- try to read more data"),
VSTR(""),
VSTR("    -- first move last chars to start of buffer"),
VSTR("    number_to_move := yy_c_buf_p - yytext_ptr;"),
VSTR(""),
VSTR("    for i in 0..number_to_move - 1 loop"),
VSTR("        yy_ch_buf(dest) := yy_ch_buf(source);"),
VSTR("    dest := dest + 1;"),
VSTR("    source := source + 1;"),
VSTR("    end loop;"),
VSTR("        "),
VSTR("    if ( yy_eof_has_been_seen ) then"),
VSTR("    -- don't do the read, it's not guaranteed to return an EOF,"),
VSTR("    -- just force an EOF"),
VSTR(""),
VSTR("    yy_n_chars := 0;"),
VSTR("    else"),
VSTR("    num_to_read := YY_BUF_SIZE - number_to_move - 1;"), 
VSTR(""),
VSTR("    if ( num_to_read > YY_READ_BUF_SIZE ) then"),
VSTR("        num_to_read := YY_READ_BUF_SIZE;"),
VSTR("        end if;"),
VSTR(""),
VSTR("    -- read in more data"),
VSTR("    YY_INPUT( yy_ch_buf(number_to_move..yy_ch_buf'last), yy_n_chars, num_to_read );"),
VSTR("    end if;"),
VSTR("    if ( yy_n_chars = 0 ) then"),
VSTR("    if ( number_to_move = 1 ) then"),
VSTR("        ret_val := EOB_ACT_END_OF_FILE;"),
VSTR("    else"),
VSTR("        ret_val := EOB_ACT_LAST_MATCH;"),
VSTR("        end if;"),
VSTR(""),
VSTR("    yy_eof_has_been_seen := true;"),
VSTR("    else"),
VSTR("    ret_val := EOB_ACT_RESTART_SCAN;"),
VSTR("    end if;"),
VSTR("    "), 
VSTR("    yy_n_chars := yy_n_chars + number_to_move;"),
VSTR("    yy_ch_buf(yy_n_chars) := YY_END_OF_BUFFER_CHAR;"),
VSTR("    yy_ch_buf(yy_n_chars + 1) := YY_END_OF_BUFFER_CHAR;"),
VSTR(""),
VSTR("    -- yytext begins at the second character in"),
VSTR("    -- yy_ch_buf; the first character is the one which"),
VSTR("    -- preceded it before reading in the latest buffer;"),
VSTR("    -- it needs to be kept around in case it's a"),
VSTR("    -- newline, so yy_get_previous_state() will have"),
VSTR("    -- with '^' rules active"),
VSTR(""),
VSTR("    yytext_ptr := 1;"),
VSTR(""),
VSTR("    return ret_val;"),
VSTR("end yy_get_next_buffer;"),
VSTR(""),
VSTR("procedure yyunput( c : character; yy_bp: in out integer ) is"), 
VSTR("    number_to_move : integer;"),
VSTR("    dest : integer;"),
VSTR("    source : integer;"),
VSTR("    tmp_yy_cp : integer;"),
VSTR("begin"),
VSTR("    tmp_yy_cp := yy_c_buf_p;"),
VSTR("    yy_ch_buf(tmp_yy_cp) := yy_hold_char; -- undo effects of setting up yytext"),
VSTR(""),
VSTR("    if ( tmp_yy_cp < 2 ) then"),
VSTR("    -- need to shift things up to make room"),
VSTR("    number_to_move := yy_n_chars + 2; -- +2 for EOB chars"),
VSTR("    dest := YY_BUF_SIZE + 2;"),
VSTR("    source := number_to_move;"),
VSTR(""),
VSTR("    while ( source > 0 ) loop"),
VSTR("        dest := dest - 1;"),
VSTR("        source := source - 1;"),
VSTR("            yy_ch_buf(dest) := yy_ch_buf(source);"),
VSTR("    end loop;"),
VSTR(""),
VSTR("    tmp_yy_cp := tmp_yy_cp + dest - source;"),
VSTR("    yy_bp := yy_bp + dest - source;"),
VSTR("    yy_n_chars := YY_BUF_SIZE;"),
VSTR(""),
VSTR("    if ( tmp_yy_cp < 2 ) then"),
VSTR("        raise PUSHBACK_OVERFLOW;"),
VSTR("    end if;"),
VSTR("    end if;"),
VSTR(""),
VSTR("    if ( tmp_yy_cp > yy_bp and then yy_ch_buf(tmp_yy_cp-1) = ASCII.LF ) then"),
VSTR("    yy_ch_buf(tmp_yy_cp-2) := ASCII.LF;"),
VSTR("    end if;"),
VSTR(""),
VSTR("    tmp_yy_cp := tmp_yy_cp - 1;"),
VSTR("    yy_ch_buf(tmp_yy_cp) := c;"),
VSTR(""),
VSTR("--  Note:  this code is the text of YY_DO_BEFORE_ACTION, only"),
VSTR("--         here we get different yy_cp and yy_bp's"),
VSTR("    yytext_ptr := yy_bp;"),
VSTR("    yy_hold_char := yy_ch_buf(tmp_yy_cp);"),
VSTR("    yy_ch_buf(tmp_yy_cp) := ASCII.NUL;"),
VSTR("    yy_c_buf_p := tmp_yy_cp;"),
VSTR("end yyunput;"),
VSTR(""),
VSTR("procedure unput(c : character) is"),
VSTR("begin"),
VSTR("     yyunput( c, yy_bp );"),
VSTR("end unput;"),
VSTR(""),
VSTR("function input return character is"),
VSTR("    c : character;"),
VSTR("    yy_cp : integer := yy_c_buf_p;"),
VSTR("begin"),
VSTR("    yy_ch_buf(yy_cp) := yy_hold_char;"),
VSTR(""),
VSTR("    if ( yy_ch_buf(yy_c_buf_p) = YY_END_OF_BUFFER_CHAR ) then"),
VSTR("    -- need more input"),
VSTR("    yytext_ptr := yy_c_buf_p;"),
VSTR("    yy_c_buf_p := yy_c_buf_p + 1;"),
VSTR(""),
VSTR("    case yy_get_next_buffer is"),
VSTR("        -- this code, unfortunately, is somewhat redundant with"),
VSTR("        -- that above"),
VSTR(""),
VSTR("        when EOB_ACT_END_OF_FILE =>"),
VSTR("        if ( yywrap ) then"), 
VSTR("            yy_c_buf_p := yytext_ptr;"),
VSTR("            return ASCII.NUL;"),
VSTR("        end if;"),
VSTR(""),
VSTR("        yy_ch_buf(0) := ASCII.LF;"),
VSTR("        yy_n_chars := 1;"),
VSTR("        yy_ch_buf(yy_n_chars) := YY_END_OF_BUFFER_CHAR;"),
VSTR("        yy_ch_buf(yy_n_chars + 1) := YY_END_OF_BUFFER_CHAR;"),
VSTR("        yy_eof_has_been_seen := false;"),
VSTR("        yy_c_buf_p := 1;"),
VSTR("        yytext_ptr := yy_c_buf_p;"),
VSTR("        yy_hold_char := yy_ch_buf(yy_c_buf_p);"),
VSTR(""),
VSTR("        return ( input );"),
VSTR("        when EOB_ACT_RESTART_SCAN =>"), 
VSTR("        yy_c_buf_p := yytext_ptr;"),
VSTR(""),
VSTR("        when EOB_ACT_LAST_MATCH =>"),
VSTR("        raise UNEXPECTED_LAST_MATCH;"),
VSTR("        when others => null;"),
VSTR("        end case;"),
VSTR("    end if;"),
VSTR(""),
VSTR("    c := yy_ch_buf(yy_c_buf_p);"),
VSTR("    yy_c_buf_p := yy_c_buf_p + 1;"),
VSTR("    yy_hold_char := yy_ch_buf(yy_c_buf_p);"),
VSTR(""),
VSTR("    return c;"),
VSTR("end input;"),
VSTR(""),
VSTR("procedure output(c : character) is"),
VSTR("begin"),
VSTR("    text_io.put(c);"),
VSTR("end output;"),
VSTR(""),
VSTR("-- default yywrap function - always treat EOF as an EOF"),
VSTR("function yywrap return boolean is"),
VSTR("begin"),
VSTR("    return true;"),
VSTR("end yywrap;"),
VSTR(""),
VSTR("procedure Open_Input(fname : in String) is"),
VSTR("    f : file_type;"),
VSTR("begin"),
VSTR("    yy_init := true;"),
VSTR("    open(f, in_file, fname);"),
VSTR("    set_input(f);"),
VSTR("end Open_Input;"),
VSTR(""),
VSTR("procedure Create_Output(fname : in String := """") is"),
VSTR("    f : file_type;"),
VSTR("begin"),
VSTR("    if (fname /= """") then"),
VSTR("        create(f, out_file, fname);"),
VSTR("        set_output(f);"),
VSTR("    end if;"),
VSTR("end Create_Output;"),
VSTR(""),
VSTR("procedure Close_Input is"),
VSTR("begin"),
VSTR("    null;"),
VSTR("end Close_Input;"),
VSTR(""),
VSTR("procedure Close_Output is"),
VSTR("begin"),
VSTR("    null;"),
VSTR("end Close_Output;"),
VSTR("")
--IO TEMPLATE END
); 

  IO_CURRENT_LINE  : INTEGER := 1; 

  procedure TEMPLATE_OUT(OUTFILE          : in FILE_TYPE; 
                         CURRENT_TEMPLATE : in FILE_ARRAY; 
                         LINE_NUMBER      : in out INTEGER) is 
    BUF : VSTRING; 
  begin
    while (not (LINE_NUMBER > CURRENT_TEMPLATE'LAST)) loop
      BUF := CURRENT_TEMPLATE(LINE_NUMBER); 
      LINE_NUMBER := LINE_NUMBER + 1; 
      if ((FILE_STRING.LEN(BUF) >= 2) and then ((CHAR(BUF, 1) = '%') and (CHAR(
        BUF, 2) = '%'))) then 
        exit; 
      else 
        FILE_STRING.PUT_LINE(OUTFILE, BUF); 
      end if; 
    end loop; 
  end TEMPLATE_OUT; 

  procedure GENERATE_DFA_FILE is 
    DFA_OUT_FILE : FILE_TYPE; 
  begin
    EXTERNAL_FILE_MANAGER.GET_DFA_FILE(DFA_OUT_FILE); 
    TEXT_IO.PUT_LINE(DFA_OUT_FILE, "package " & TSTRING.STR(MISC.BASENAME) & 
      "_dfa" & " is"); 

    if (DDEBUG) then 

      -- make a scanner that output acceptance information
      TEXT_IO.PUT_LINE(DFA_OUT_FILE, "aflex_debug : boolean := true;"); 
    else 
      TEXT_IO.PUT_LINE(DFA_OUT_FILE, "aflex_debug : boolean := false;"); 
    end if; 
    TEMPLATE_OUT(DFA_OUT_FILE, DFA_TEMPLATE, DFA_CURRENT_LINE); 
    TEXT_IO.PUT_LINE(DFA_OUT_FILE, "end " & TSTRING.STR(MISC.BASENAME) & "_dfa;"
      ); 
    TEXT_IO.NEW_LINE(DFA_OUT_FILE); 
    TEXT_IO.PUT(DFA_OUT_FILE, "with " & TSTRING.STR(MISC.BASENAME) & "_dfa" & 
      "; "); 
    TEXT_IO.PUT_LINE(DFA_OUT_FILE, "use " & TSTRING.STR(MISC.BASENAME) & "_dfa"
      & "; "); 
    TEXT_IO.PUT_LINE(DFA_OUT_FILE, "package body " & TSTRING.STR(MISC.BASENAME)
      & "_dfa" & " is"); 
    TEMPLATE_OUT(DFA_OUT_FILE, DFA_TEMPLATE, DFA_CURRENT_LINE); 
    TEXT_IO.PUT_LINE(DFA_OUT_FILE, "end " & TSTRING.STR(MISC.BASENAME) & "_dfa;"
      ); 
  end GENERATE_DFA_FILE; 

  procedure GENERATE_IO_FILE is 
    IO_OUT_FILE : FILE_TYPE; 
  begin
    EXTERNAL_FILE_MANAGER.GET_IO_FILE(IO_OUT_FILE); 
    TEXT_IO.PUT(IO_OUT_FILE, "with " & TSTRING.STR(MISC.BASENAME) & "_dfa" & 
      "; "); 
    TEXT_IO.PUT_LINE(IO_OUT_FILE, "use " & TSTRING.STR(MISC.BASENAME) & "_dfa"
      & "; "); 
    TEMPLATE_OUT(IO_OUT_FILE, IO_TEMPLATE, IO_CURRENT_LINE); 
    TEXT_IO.PUT_LINE(IO_OUT_FILE, "package " & TSTRING.STR(MISC.BASENAME) & 
      "_io" & " is"); 
    TEMPLATE_OUT(IO_OUT_FILE, IO_TEMPLATE, IO_CURRENT_LINE); 
    TEXT_IO.PUT_LINE(IO_OUT_FILE, "end " & TSTRING.STR(MISC.BASENAME) & "_io;")
      ; 
    TEXT_IO.NEW_LINE(IO_OUT_FILE); 
    TEXT_IO.PUT_LINE(IO_OUT_FILE, "package body " & TSTRING.STR(MISC.BASENAME)
      & "_io" & " is"); 
    TEMPLATE_OUT(IO_OUT_FILE, IO_TEMPLATE, IO_CURRENT_LINE); 
    -- If we're generating a scanner for interactive mode we need to generate
    -- a YY_INPUT that stops at the end of each line
    if INTERACTIVE then
        TEXT_IO.PUT_LINE(IO_OUT_FILE,
	    "            i := i + 1; -- update counter, miss end of loop");
	TEXT_IO.PUT_LINE(IO_OUT_FILE,
	    "            exit; -- in interactive mode return at end of line.");
    end if;
    TEMPLATE_OUT(IO_OUT_FILE, IO_TEMPLATE, IO_CURRENT_LINE);     
    TEXT_IO.PUT_LINE(IO_OUT_FILE, "end " & TSTRING.STR(MISC.BASENAME) & "_io;")
      ; 
  end GENERATE_IO_FILE; 

end TEMPLATE_MANAGER; 
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- This software was developed by John Self of the Arcadia project
-- at the University of California, Irvine.
--
-- 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.

-- TITLE template manager
-- AUTHOR: John Self (UCI)
-- DESCRIPTION supports output of internalized templates for the IO and DFA
--             packages.
-- NOTES This package is quite a memory hog, and is really only useful on
--       virtual memory systems.  It could use an external file to store the
--       templates like the skeleton manager.  This would save memory at the
--       cost of a slight reduction in speed and the necessity of keeping
--       copies of the template files in a known place.
-- $Header: /co/ua/self/arcadia/aflex/ada/src/RCS/template_managerS.a,v 1.3 90/01/12 15:20:49 self Exp Locker: self $ 

package TEMPLATE_MANAGER is 
  procedure GENERATE_DFA_FILE; 
  procedure GENERATE_IO_FILE; 
end TEMPLATE_MANAGER; 
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- This software was developed by John Self of the Arcadia project
-- at the University of California, Irvine.
--
-- 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.

-- TITLE variable length strings
-- AUTHOR: John Self (UCI)
-- DESCRIPTION these strings are used for many functions
-- $Header: /co/ua/self/arcadia/aflex/ada/src/RCS/tstrings.a,v 1.4 90/01/12 15:20:51 self Exp Locker: self $ 

with VSTRINGS; 
package TSTRING is 
  new VSTRINGS(1024);  -- This is MAXLINE in misc_defs

-- UNIT: generic package body of VSTRINGS
--
-- FILES: vstring_body.a in publiclib
--        related file is vstring_spec.a in publiclib
--
-- PURPOSE:  An implementation of the abstract data type "variable-length
--           string."
--
-- DESCRIPTION:  This package provides a private type VSTRING.  VSTRING objects
--               are "strings" that have a length between zero and LAST, where
--               LAST is the generic parameter supplied in the package
--               instantiation.
--
--               In addition to the type VSTRING, a subtype and two constants
--               are declared.  The subtype STRINDEX is an index to a VSTRING,
--               The STRINDEX constant FIRST is an index to the first character
--               of the string, and the VSTRING constant NUL is a VSTRING of
--               length zero.  NUL is the default initial value of a VSTRING.
--
--               The following sets of functions, procedures, and operators
--               are provided as operations on the type VSTRING:
--
--               ATTRIBUTE FUNCTIONS:  LEN, MAX, STR, CHAR
--                 The attribute functions return the characteristics of
--                 a VSTRING.
--
--               COMPARISON OPERATORS: "=", "/=", "<", ">", "<=", ">="
--                 The comparison operators are the same as for the predefined
--                 type STRING.
--
--               INPUT/OUTPUT PROCEDURES: GET, GET_LINE, PUT, PUT_LINE
--                                        
--                 The input/output procedures are similar to those for the
--                 predefined type STRING, with the following exceptions:
--
--                   - GET has an optional parameter LENGTH, which indicates
--                     the number of characters to get (default is LAST).
--
--                   - GET_LINE does not have a parameter to return the length
--                     of the string (the LEN function should be used instead).
--
--               EXTRACTION FUNCTIONS: SLICE, SUBSTR, DELETE
--                 The SLICE function returns the slice of a VSTRING between
--                 two indices (equivalent to STR(X)(A .. B)).
--
--                 SUBSTR returns a substring of a VSTRING taken from a given
--                 index and extending a given length.
--
--                 The DELETE function returns the VSTRING which results from
--                 removing the slice between two indices.
--
--               EDITING FUNCTIONS: INSERT, APPEND, REPLACE
--                 The editing functions return the VSTRING which results from
--                 inserting, appending, or replacing at a given index with a
--                 VSTRING, STRING, or CHARACTER.  The index must be in the
--                 current range of the VSTRING; i.e., zero cannot be used.
--
--               CONCATENATION OPERATOR:  "&"
--                 The concatenation operator is the same as for the type
--                 STRING.  It should be used instead of APPEND when the
--                 APPEND would always be after the last character.
--
--               POSITION FUNCTIONS: INDEX, RINDEX
--                 The position functions return an index to the Nth occurrence
--                 of a VSTRING, STRING, or CHARACTER from the front or back
--                 of a VSTRING.  Zero is returned if the search is not
--                 successful.
--
--               CONVERSION FUNCTIONS AND OPERATOR: VSTR, CONVERT, "+"
--                 VSTR converts a STRING or a CHARACTER to a VSTRING.
--
--                 CONVERT is a generic function which can be instantiated to
--                 convert from any given variable-length string to another,
--                 provided the FROM type has a function equivelent to STR
--                 defined for it, and that the TO type has a function equiv-
--                 elent to VSTR defined for it.  This provides a means for
--                 converting between VSTRINGs declared in separate instant-
--                 iations of VSTRINGS.  When instantiating CONVERT for 
--                 VSTRINGs, the STR and VSTR functions are implicitly defined,
--                 provided that they have been made visible (by a use clause).
--
--                 Note:  CONVERT is NOT implicitly associated with the type 
--                 VSTRING declared in this package (since it would not be a
--                 derivable function (see RM 3.4(11))).
--
--                 Caution:  CONVERT cannot be instantiated directly with the
--                 names VSTR and STR, since the name of the subprogram being
--                 declared would hide the generic parameters with the same
--                 names (see RM 8.3(16)).  CONVERT can be instantiated with
--                 the operator "+", and any instantiation of CONVERT can
--                 subsequently be renamed VSTR or STR.
--
--                 Example:  Given two VSTRINGS instantiations X and Y:
--                   function "+" is new X.CONVERT(X.VSTRING, Y.VSTRING);
--                   function "+" is new X.CONVERT(Y.VSTRING, X.VSTRING);
--
--                   (Y.CONVERT could have been used in place of X.CONVERT)
--
--                   function VSTR(A : X.VSTRING) return Y.VSTRING renames "+";
--                   function VSTR(A : Y.VSTRING) return X.VSTRING renames "+";
--
--                 "+" is equivelent to VSTR.  It is supplied as a short-hand
--                 notation for the function.  The "+" operator cannot immed-
--                 iately follow the "&" operator; use ... & (+ ...) instead.
pragma PAGE;
\f


--  DISCUSSION:
--
--	This package implements the type "variable-length string" (vstring)
--	using generics.  The alternative approaches are to use a discriminant 
--	record in which the discriminant controls the length of a STRING inside
--	the record, or a record containing an access type which points to a
--      string, which can be deallocated and reallocated when necessary.
--
--	Advantages of this package:
--	  * The other approaches force the vstring to be a limited private 
--          type.  Thus, their vstrings cannot appear on the left side of
--          the assignment operator; ie., their vstrings cannot be given
--          initial values or values by direct assignment.  This package
--          uses a private type; therefore, these things can be done.
--         
--	  * The other approach stores the vstring in a string whose length
--	    is determined dynamically.  This package uses a fixed length 
--          string.  This difference might be reflected in faster and more
--          consistent execution times (this has NOT been verified).
--
--	Disadvantages of this package:
--	  * Different instantiations must be used to declare vstrings with
--	    different maximum lengths (this may be desirable, since
--	    CONSTRAINT_ERROR will be raised if the maximum is exceeded).
--
--	  * A second declaration is required to give the type declared by
--	    the instantiation a name other than "VSTRING."
--
--	  * The storage required for a vstring is determined by the generic
--	    parameter LAST and not the actual length of its contents.  Thus,
--          each object is allocated the maximum amount of storage, regardless
--          of its actual size.
--
--  MISCELLANEOUS:
--     Constraint checking is done explicitly in the code; thus, it cannot
--     be suppressed.  On the other hand, constraint checking is not lost
--     if pragma suppress is supplied to the compilation (-S option) 
--     (The robustness of the explicit constraint checking has NOT been 
--     determined).
--
--     Compiling with the optimizer (-O option) may significantly reduce
--     the size (and possibly execution time) of the resulting executable.
--
--     Compiling an instantiation of VSTRINGS is roughly equivelent to
--     recompiling VSTRINGS.  Since this takes a significant amount of time,
--     and the instantiation does not depend on any other library units,
--     it is STRONGLY recommended that the instantiation be compiled
--     separately, and thus done only ONCE.
--
--  USAGE: with VSTRINGS;
--         package package_name is new VSTRINGS(maximum_length);
-- .......................................................................... --
pragma PAGE;
\f


package body VSTRINGS is

  -- local declarations

  FILL_CHAR : constant CHARACTER := ASCII.NUL;

  procedure FORMAT(THE_STRING : in out VSTRING; OLDLEN : in STRINDEX := LAST) is
    -- fill the string with FILL_CHAR to null out old values

    begin -- FORMAT (Local Procedure)
      THE_STRING.VALUE(THE_STRING.LEN + 1 .. OLDLEN) := 
                                        (others => FILL_CHAR);
    end FORMAT;


  -- bodies of visible operations

  function LEN(FROM : VSTRING) return STRINDEX is

    begin -- LEN
      return(FROM.LEN);
    end LEN;


  function MAX(FROM : VSTRING) return STRINDEX is
    begin -- MAX
      return(LAST);
    end MAX;


  function STR(FROM : VSTRING) return STRING is
    begin -- STR
      return(FROM.VALUE(FIRST .. FROM.LEN));
    end STR;


  function CHAR(FROM : VSTRING; POSITION : STRINDEX := FIRST)
                 return CHARACTER is

    begin -- CHAR
      if POSITION not in FIRST .. FROM.LEN
        then raise CONSTRAINT_ERROR;
       end if;
      return(FROM.VALUE(POSITION));
    end CHAR;


  function "<" (LEFT: VSTRING; RIGHT: VSTRING) return BOOLEAN is
    begin -- "<"
      return(LEFT.VALUE < RIGHT.VALUE);
    end "<";


  function ">" (LEFT: VSTRING; RIGHT: VSTRING) return BOOLEAN is
    begin -- ">"
      return(LEFT.VALUE > RIGHT.VALUE);
    end ">";


  function "<=" (LEFT: VSTRING; RIGHT: VSTRING) return BOOLEAN is
    begin -- "<="
      return(LEFT.VALUE <= RIGHT.VALUE);
    end "<=";


  function ">=" (LEFT: VSTRING; RIGHT: VSTRING) return BOOLEAN is
    begin -- ">="
      return(LEFT.VALUE >= RIGHT.VALUE);
    end ">=";


  procedure PUT(FILE : in FILE_TYPE; ITEM : in VSTRING) is
    begin -- PUT
      PUT(FILE, ITEM.VALUE(FIRST .. ITEM.LEN));
    end PUT;

  procedure Put(ITEM : in VSTRING) is
    begin -- PUT
      PUT(ITEM.VALUE(FIRST .. ITEM.LEN));
    end PUT;


  procedure PUT_LINE(FILE : in FILE_TYPE; ITEM : in VSTRING) is
    begin -- PUT_LINE
      PUT_LINE(FILE, ITEM.VALUE(FIRST .. ITEM.LEN));
    end PUT_LINE;

  procedure PUT_LINE(ITEM : in VSTRING) is
    begin -- PUT_LINE
      PUT_LINE(ITEM.VALUE(FIRST .. ITEM.LEN));
    end PUT_LINE;


  procedure GET(FILE : in FILE_TYPE; ITEM : out VSTRING;
                LENGTH : in STRINDEX := LAST) is
    begin -- GET
      if LENGTH not in FIRST .. LAST
        then raise CONSTRAINT_ERROR;
       end if;

      ITEM := NUL;
      for INDEX in FIRST .. LENGTH loop
        GET(FILE, ITEM.VALUE(INDEX));
        ITEM.LEN := INDEX;
       end loop;
    end GET;

  procedure GET(ITEM : out VSTRING; LENGTH : in STRINDEX := LAST) is
    begin -- GET
      if LENGTH not in FIRST .. LAST
        then raise CONSTRAINT_ERROR;
       end if;

      ITEM := NUL;
      for INDEX in FIRST .. LENGTH loop
        GET(ITEM.VALUE(INDEX));
        ITEM.LEN := INDEX;
       end loop;
    end GET;


  procedure GET_LINE(FILE : in FILE_TYPE; ITEM : in out VSTRING) is

    OLDLEN : constant STRINDEX := ITEM.LEN;

    begin -- GET_LINE
      GET_LINE(FILE, ITEM.VALUE, ITEM.LEN);
      FORMAT(ITEM, OLDLEN);
    end GET_LINE;
       
  procedure GET_LINE(ITEM : in out VSTRING) is

    OLDLEN : constant STRINDEX := ITEM.LEN;

    begin -- GET_LINE
      GET_LINE(ITEM.VALUE, ITEM.LEN);
      FORMAT(ITEM, OLDLEN);
    end GET_LINE;


  function SLICE(FROM : VSTRING; FRONT, BACK : STRINDEX) return VSTRING is

    begin -- SLICE
      if ((FRONT not in FIRST .. FROM.LEN) or else 
         (BACK not in FIRST .. FROM.LEN)) and then FRONT <= BACK
        then raise CONSTRAINT_ERROR;
       end if;

      return(Vstr(FROM.VALUE(FRONT .. BACK)));
    end SLICE;


  function SUBSTR(FROM : VSTRING; START, LENGTH : STRINDEX) return VSTRING is

    begin -- SUBSTR
      if (START not in FIRST .. FROM.LEN) or else
         ((START + LENGTH - 1 not in FIRST .. FROM.LEN)
          and then (LENGTH > 0))
        then raise CONSTRAINT_ERROR;
       end if;

      return(Vstr(FROM.VALUE(START .. START + LENGTH -1)));
    end SUBSTR;


  function DELETE(FROM : VSTRING; FRONT, BACK : STRINDEX) return VSTRING is

    TEMP : VSTRING := FROM;

    begin -- DELETE
      if ((FRONT not in FIRST .. FROM.LEN) or else
         (BACK not in FIRST .. FROM.LEN)) and then FRONT <= BACK
        then raise CONSTRAINT_ERROR;
       end if;

      if FRONT > BACK then return(FROM); end if;
      TEMP.LEN := FROM.LEN - (BACK - FRONT) - 1;

      TEMP.VALUE(FRONT .. TEMP.LEN) := FROM.VALUE(BACK + 1 .. FROM.LEN);
      FORMAT(TEMP, FROM.LEN);
      return(TEMP);
    end DELETE;


  function INSERT(TARGET: VSTRING; ITEM: VSTRING;
                  POSITION : STRINDEX := FIRST) return VSTRING is

    TEMP : VSTRING;

    begin -- INSERT
      if POSITION not in FIRST .. TARGET.LEN
        then raise CONSTRAINT_ERROR;
       end if;

      if TARGET.LEN + ITEM.LEN > LAST
        then raise CONSTRAINT_ERROR;
        else TEMP.LEN := TARGET.LEN + ITEM.LEN;
       end if;

      TEMP.VALUE(FIRST .. POSITION - 1) := TARGET.VALUE(FIRST .. POSITION - 1);
      TEMP.VALUE(POSITION .. (POSITION + ITEM.LEN - 1)) :=
        ITEM.VALUE(FIRST .. ITEM.LEN);
      TEMP.VALUE((POSITION + ITEM.LEN) .. TEMP.LEN) :=
        TARGET.VALUE(POSITION .. TARGET.LEN);

      return(TEMP);
    end INSERT;

  function INSERT(TARGET: VSTRING; ITEM: STRING;
                  POSITION : STRINDEX := FIRST) return VSTRING is
    begin -- INSERT
      return INSERT(TARGET, VSTR(ITEM), POSITION);
    end INSERT;
  
  function INSERT(TARGET: VSTRING; ITEM: CHARACTER;
                  POSITION : STRINDEX := FIRST) return VSTRING is
    begin -- INSERT
      return INSERT(TARGET, VSTR(ITEM), POSITION);
    end INSERT;


  function APPEND(TARGET: VSTRING; ITEM: VSTRING; POSITION : STRINDEX)
                  return VSTRING is

    TEMP : VSTRING;
    POS : STRINDEX := POSITION;

    begin -- APPEND
      if POSITION not in FIRST .. TARGET.LEN
        then raise CONSTRAINT_ERROR;
       end if;

      if TARGET.LEN + ITEM.LEN > LAST
        then raise CONSTRAINT_ERROR;
        else TEMP.LEN := TARGET.LEN + ITEM.LEN;
       end if;

      TEMP.VALUE(FIRST .. POS) := TARGET.VALUE(FIRST .. POS);
      TEMP.VALUE(POS + 1 .. (POS + ITEM.LEN)) := ITEM.VALUE(FIRST .. ITEM.LEN);
      TEMP.VALUE((POS + ITEM.LEN + 1) .. TEMP.LEN) :=
        TARGET.VALUE(POS + 1 .. TARGET.LEN);

      return(TEMP);
    end APPEND;

  function APPEND(TARGET: VSTRING; ITEM: STRING; POSITION : STRINDEX)
                  return VSTRING is
    begin -- APPEND
      return APPEND(TARGET, VSTR(ITEM), POSITION);
    end APPEND;

  function APPEND(TARGET: VSTRING; ITEM: CHARACTER; POSITION : STRINDEX)
                  return VSTRING is
    begin -- APPEND
      return APPEND(TARGET, VSTR(ITEM), POSITION);
    end APPEND;


  function APPEND(TARGET: VSTRING; ITEM: VSTRING) return VSTRING is
    begin -- APPEND
      return(APPEND(TARGET, ITEM, TARGET.LEN));
    end APPEND;

  function APPEND(TARGET: VSTRING; ITEM: STRING) return VSTRING is
    begin -- APPEND
      return(APPEND(TARGET, VSTR(ITEM), TARGET.LEN));
    end APPEND;

  function APPEND(TARGET: VSTRING; ITEM: CHARACTER) return VSTRING is
    begin -- APPEND
      return(APPEND(TARGET, VSTR(ITEM), TARGET.LEN));
    end APPEND;


  function REPLACE(TARGET: VSTRING; ITEM: VSTRING;
                   POSITION : STRINDEX := FIRST) return VSTRING is

    TEMP : VSTRING;

    begin -- REPLACE
      if POSITION not in FIRST .. TARGET.LEN
        then raise CONSTRAINT_ERROR;
       end if;

      if POSITION + ITEM.LEN - 1 <= TARGET.LEN
        then TEMP.LEN := TARGET.LEN;
        elsif POSITION + ITEM.LEN - 1 > LAST
          then raise CONSTRAINT_ERROR;
          else TEMP.LEN := POSITION + ITEM.LEN - 1;
       end if;

      TEMP.VALUE(FIRST .. POSITION - 1) := TARGET.VALUE(FIRST .. POSITION - 1);
      TEMP.VALUE(POSITION .. (POSITION + ITEM.LEN - 1)) := 
        ITEM.VALUE(FIRST .. ITEM.LEN);
      TEMP.VALUE((POSITION + ITEM.LEN) .. TEMP.LEN) :=
        TARGET.VALUE((POSITION + ITEM.LEN) .. TARGET.LEN);

      return(TEMP);
    end REPLACE;

  function REPLACE(TARGET: VSTRING; ITEM: STRING;
                   POSITION : STRINDEX := FIRST) return VSTRING is
    begin -- REPLACE
      return REPLACE(TARGET, VSTR(ITEM), POSITION);
    end REPLACE;

  function REPLACE(TARGET: VSTRING; ITEM: CHARACTER;
                   POSITION : STRINDEX := FIRST) return VSTRING is
    begin -- REPLACE
      return REPLACE(TARGET, VSTR(ITEM), POSITION);
    end REPLACE;


  function "&"(LEFT:VSTRING; RIGHT : VSTRING) return VSTRING is

    TEMP : VSTRING;

    begin -- "&"
      if LEFT.LEN + RIGHT.LEN > LAST
        then raise CONSTRAINT_ERROR;
        else TEMP.LEN := LEFT.LEN + RIGHT.LEN;
       end if;

      TEMP.VALUE(FIRST .. TEMP.LEN) := LEFT.VALUE(FIRST .. LEFT.LEN) &
        RIGHT.VALUE(FIRST .. RIGHT.LEN);
      return(TEMP);
    end "&";

  function "&"(LEFT:VSTRING; RIGHT : STRING) return VSTRING is
    begin -- "&"
      return LEFT & VSTR(RIGHT);
    end "&";

  function "&"(LEFT:VSTRING; RIGHT : CHARACTER) return VSTRING is
    begin -- "&"
      return LEFT & VSTR(RIGHT);
    end "&";

  function "&"(LEFT : STRING; RIGHT : VSTRING) return VSTRING is
    begin -- "&"
      return VSTR(LEFT) & RIGHT;
    end "&";

  function "&"(LEFT : CHARACTER; RIGHT : VSTRING) return VSTRING is
    begin -- "&"
      return VSTR(LEFT) & RIGHT;
    end "&";


  Function INDEX(WHOLE : VSTRING; PART : VSTRING; OCCURRENCE : NATURAL := 1)
                 return STRINDEX is

    NOT_FOUND : constant NATURAL := 0;
    INDEX : NATURAL := FIRST;
    COUNT : NATURAL := 0;

    begin -- INDEX
      if PART = NUL then return(NOT_FOUND); -- by definition
        end if;

      while INDEX + PART.LEN - 1 <= WHOLE.LEN and then COUNT < OCCURRENCE loop
        if WHOLE.VALUE(INDEX .. PART.LEN + INDEX - 1) =
           PART.VALUE(1 .. PART.LEN)
          then COUNT := COUNT + 1;
         end if;
        INDEX := INDEX + 1;
       end loop;

      if COUNT = OCCURRENCE
        then return(INDEX - 1);
        else return(NOT_FOUND);
       end if;
    end INDEX;

  Function INDEX(WHOLE : VSTRING; PART : STRING; OCCURRENCE : NATURAL := 1)
                 return STRINDEX is

    begin -- Index
      return(Index(WHOLE, VSTR(PART), OCCURRENCE));
    end INDEX;


  Function INDEX(WHOLE : VSTRING; PART : CHARACTER; OCCURRENCE : NATURAL := 1)
                 return STRINDEX is

    begin -- Index
      return(Index(WHOLE, VSTR(PART), OCCURRENCE));
    end INDEX;


  function RINDEX(WHOLE: VSTRING; PART:VSTRING; OCCURRENCE:NATURAL := 1) 
                 return STRINDEX is

    NOT_FOUND : constant NATURAL := 0;
    INDEX : INTEGER := WHOLE.LEN - (PART.LEN -1);
    COUNT : NATURAL := 0;

    begin -- RINDEX
      if PART = NUL then return(NOT_FOUND); -- by definition
        end if;

      while INDEX >= FIRST and then COUNT < OCCURRENCE loop
        if WHOLE.VALUE(INDEX .. PART.LEN + INDEX - 1) =
           PART.VALUE(1 .. PART.LEN)
          then COUNT := COUNT + 1;
         end if;
        INDEX := INDEX - 1;
       end loop;

      if COUNT = OCCURRENCE
        then
          if COUNT > 0
            then return(INDEX + 1);
            else return(NOT_FOUND);
           end if;
        else return(NOT_FOUND);
       end if;
    end RINDEX;

  Function RINDEX(WHOLE : VSTRING; PART : STRING; OCCURRENCE : NATURAL := 1)
                 return STRINDEX is

    begin -- Rindex
      return(RINDEX(WHOLE, VSTR(PART), OCCURRENCE));
    end RINDEX;


  Function RINDEX(WHOLE : VSTRING; PART : CHARACTER; OCCURRENCE : NATURAL := 1)
                 return STRINDEX is

    begin -- Rindex
      return(RINDEX(WHOLE, VSTR(PART), OCCURRENCE));
    end RINDEX;


  function VSTR(FROM : CHARACTER) return VSTRING is
    
    TEMP : VSTRING;

    begin -- VSTR
      if LAST < 1
        then raise CONSTRAINT_ERROR;
        else TEMP.LEN := 1;
       end if;

      TEMP.VALUE(FIRST) := FROM;
      return(TEMP);
    end VSTR;


  function VSTR(FROM : STRING) return VSTRING is

    TEMP : VSTRING;

    begin -- VSTR
      if FROM'LENGTH > LAST
        then raise CONSTRAINT_ERROR;
        else TEMP.LEN := FROM'LENGTH;
       end if;

      TEMP.VALUE(FIRST .. FROM'LENGTH) := FROM;
      return(TEMP);
    end VSTR;

  Function "+" (FROM : STRING) return VSTRING is
    begin -- "+"
      return(VSTR(FROM));
    end "+";

  Function "+" (FROM : CHARACTER) return VSTRING is
    begin
     return(VSTR(FROM));
    end "+";


  function CONVERT(X : FROM) return TO is

    begin -- CONVERT
      return(VSTR(STR(X)));
    end CONVERT;   
end VSTRINGS;
-- .......................................................................... --
--
-- DISTRIBUTION AND COPYRIGHT:
--                                                           
-- This software is released to the Public Domain (note:
--   software released to the Public Domain is not subject
--   to copyright protection).
-- Restrictions on use or distribution:  NONE
--                                                           
-- DISCLAIMER:
--                                                           
-- This software and its documentation are provided "AS IS" and
-- without any expressed or implied warranties whatsoever.
-- No warranties as to performance, merchantability, or fitness
-- for a particular purpose exist.
--
-- Because of the diversity of conditions and hardware under
-- which this software may be used, no warranty of fitness for
-- a particular purpose is offered.  The user is advised to
-- test the software thoroughly before relying on it.  The user
-- must assume the entire risk and liability of using this
-- software.
--
-- In no event shall any person or organization of people be
-- held responsible for any direct, indirect, consequential
-- or inconsequential damages or lost profits.
-- UNIT: generic package spec of VSTRINGS
--
-- FILES: vstring_spec.a in publiclib
--        related file is vstring_body.a in publiclib
--
-- PURPOSE:  An implementation of the abstract data type "variable-length
--           string."
--
-- DESCRIPTION:  This package provides a private type VSTRING.  VSTRING objects
--               are "strings" that have a length between zero and LAST, where
--               LAST is the generic parameter supplied in the package
--               instantiation.
--
--               In addition to the type VSTRING, a subtype and two constants
--               are declared.  The subtype STRINDEX is an index to a VSTRING,
--               The STRINDEX constant FIRST is an index to the first character
--               of the string, and the VSTRING constant NUL is a VSTRING of
--               length zero.  NUL is the default initial value of a VSTRING.
--
--               The following sets of functions, procedures, and operators
--               are provided as operations on the type VSTRING:
--
--               ATTRIBUTE FUNCTIONS:  LEN, MAX, STR, CHAR
--                 The attribute functions return the characteristics of
--                 a VSTRING.
--
--               COMPARISON OPERATORS: "=", "/=", "<", ">", "<=", ">="
--                 The comparison operators are the same as for the predefined
--                 type STRING.
--
--               INPUT/OUTPUT PROCEDURES: GET, GET_LINE, PUT, PUT_LINE
--                                        
--                 The input/output procedures are similar to those for the
--                 predefined type STRING, with the following exceptions:
--
--                   - GET has an optional parameter LENGTH, which indicates
--                     the number of characters to get (default is LAST).
--
--                   - GET_LINE does not have a parameter to return the length
--                     of the string (the LEN function should be used instead).
--
--               EXTRACTION FUNCTIONS: SLICE, SUBSTR, DELETE
--                 The SLICE function returns the slice of a VSTRING between
--                 two indices (equivalent to STR(X)(A .. B)).
--
--                 SUBSTR returns a substring of a VSTRING taken from a given
--                 index and extending a given length.
--
--                 The DELETE function returns the VSTRING which results from
--                 removing the slice between two indices.
--
--               EDITING FUNCTIONS: INSERT, APPEND, REPLACE
--                 The editing functions return the VSTRING which results from
--                 inserting, appending, or replacing at a given index with a
--                 VSTRING, STRING, or CHARACTER.  The index must be in the
--                 current range of the VSTRING; i.e., zero cannot be used.
--
--               CONCATENATION OPERATOR:  "&"
--                 The concatenation operator is the same as for the type
--                 STRING.  It should be used instead of APPEND when the
--                 APPEND would always be after the last character.
--
--               POSITION FUNCTIONS: INDEX, RINDEX
--                 The position functions return an index to the Nth occurrence
--                 of a VSTRING, STRING, or CHARACTER from the front or back
--                 of a VSTRING.  Zero is returned if the search is not
--                 successful.
--
--               CONVERSION FUNCTIONS AND OPERATOR: VSTR, CONVERT, "+"
--                 VSTR converts a STRING or a CHARACTER to a VSTRING.
--
--                 CONVERT is a generic function which can be instantiated to
--                 convert from any given variable-length string to another,
--                 provided the FROM type has a function equivelent to STR
--                 defined for it, and that the TO type has a function equiv-
--                 elent to VSTR defined for it.  This provides a means for
--                 converting between VSTRINGs declared in separate instant-
--                 iations of VSTRINGS.  When instantiating CONVERT for 
--                 VSTRINGs, the STR and VSTR functions are implicitly defined,
--                 provided that they have been made visible (by a use clause).
--
--                 Note:  CONVERT is NOT implicitly associated with the type 
--                 VSTRING declared in this package (since it would not be a
--                 derivable function (see RM 3.4(11))).
--
--                 Caution:  CONVERT cannot be instantiated directly with the
--                 names VSTR and STR, since the name of the subprogram being
--                 declared would hide the generic parameters with the same
--                 names (see RM 8.3(16)).  CONVERT can be instantiated with
--                 the operator "+", and any instantiation of CONVERT can
--                 subsequently be renamed VSTR or STR.
--
--                 Example:  Given two VSTRINGS instantiations X and Y:
--                   function "+" is new X.CONVERT(X.VSTRING, Y.VSTRING);
--                   function "+" is new X.CONVERT(Y.VSTRING, X.VSTRING);
--
--                   (Y.CONVERT could have been used in place of X.CONVERT)
--
--                   function VSTR(A : X.VSTRING) return Y.VSTRING renames "+";
--                   function VSTR(A : Y.VSTRING) return X.VSTRING renames "+";
--
--                 "+" is equivelent to VSTR.  It is supplied as a short-hand
--                 notation for the function.  The "+" operator cannot immed-
--                 iately follow the "&" operator; use ... & (+ ...) instead.
pragma PAGE;
\f


--  DISCUSSION:
--
--	This package implements the type "variable-length string" (vstring)
--	using generics.  The alternative approaches are to use a discriminant 
--	record in which the discriminant controls the length of a STRING inside
--	the record, or a record containing an access type which points to a
--      string, which can be deallocated and reallocated when necessary.
--
--	Advantages of this package:
--	  * The other approaches force the vstring to be a limited private 
--          type.  Thus, their vstrings cannot appear on the left side of
--          the assignment operator; ie., their vstrings cannot be given
--          initial values or values by direct assignment.  This package
--          uses a private type; therefore, these things can be done.
--         
--	  * The other approach stores the vstring in a string whose length
--	    is determined dynamically.  This package uses a fixed length 
--          string.  This difference might be reflected in faster and more
--          consistent execution times (this has NOT been verified).
--
--	Disadvantages of this package:
--	  * Different instantiations must be used to declare vstrings with
--	    different maximum lengths (this may be desirable, since
--	    CONSTRAINT_ERROR will be raised if the maximum is exceeded).
--
--	  * A second declaration is required to give the type declared by
--	    the instantiation a name other than "VSTRING."
--
--	  * The storage required for a vstring is determined by the generic
--	    parameter LAST and not the actual length of its contents.  Thus,
--          each object is allocated the maximum amount of storage, regardless
--          of its actual size.
--
--  MISCELLANEOUS:
--     Constraint checking is done explicitly in the code; thus, it cannot
--     be suppressed.  On the other hand, constraint checking is not lost
--     if pragma suppress is supplied to the compilation (-S option) 
--     (The robustness of the explicit constraint checking has NOT been 
--     determined).
--
--     Compiling with the optimizer (-O option) may significantly reduce
--     the size (and possibly execution time) of the resulting executable.
--
--     Compiling an instantiation of VSTRINGS is roughly equivelent to
--     recompiling VSTRINGS.  Since this takes a significant amount of time,
--     and the instantiation does not depend on any other library units,
--     it is STRONGLY recommended that the instantiation be compiled
--     separately, and thus done only ONCE.
--
--  USAGE: with VSTRINGS;
--         package package_name is new VSTRINGS(maximum_length);
-- .......................................................................... --
pragma PAGE;
\f


with TEXT_IO; use TEXT_IO;
generic
  LAST : NATURAL;
package VSTRINGS is

  subtype STRINDEX is NATURAL;
  FIRST : constant STRINDEX := STRINDEX'FIRST + 1;
  type VSTRING is private;
  NUL : constant VSTRING;

-- Attributes of a VSTRING

  function LEN(FROM : VSTRING) return STRINDEX;
  function MAX(FROM : VSTRING) return STRINDEX;
  function STR(FROM : VSTRING) return STRING;
  function CHAR(FROM: VSTRING; POSITION : STRINDEX := FIRST)
                return CHARACTER;

-- Comparisons

  function "<" (LEFT: VSTRING; RIGHT: VSTRING) return BOOLEAN;
  function ">" (LEFT: VSTRING; RIGHT: VSTRING) return BOOLEAN;
  function "<=" (LEFT: VSTRING; RIGHT: VSTRING) return BOOLEAN;
  function ">=" (LEFT: VSTRING; RIGHT: VSTRING) return BOOLEAN;
  -- "=" and "/=" are predefined

-- Input/Output

  procedure PUT(FILE : in FILE_TYPE; ITEM : in VSTRING);
  procedure PUT(ITEM : in VSTRING);

  procedure PUT_LINE(FILE : in FILE_TYPE; ITEM : in VSTRING);
  procedure PUT_LINE(ITEM : in VSTRING);

  procedure GET(FILE : in FILE_TYPE; ITEM : out VSTRING;
                LENGTH : in STRINDEX := LAST);
  procedure GET(ITEM : out VSTRING; LENGTH : in STRINDEX := LAST);

  procedure GET_LINE(FILE : in FILE_TYPE; ITEM : in out VSTRING);
  procedure GET_LINE(ITEM : in out VSTRING);

-- Extraction

  function SLICE(FROM: VSTRING; FRONT, BACK : STRINDEX) return VSTRING;
  function SUBSTR(FROM: VSTRING; START, LENGTH: STRINDEX) return VSTRING;
  function DELETE(FROM: VSTRING; FRONT, BACK : STRINDEX) return VSTRING;

-- Editing

  function INSERT(TARGET: VSTRING; ITEM: VSTRING;
                  POSITION: STRINDEX := FIRST) return VSTRING;
  function INSERT(TARGET: VSTRING; ITEM: STRING;
                  POSITION: STRINDEX := FIRST) return VSTRING;
  function INSERT(TARGET: VSTRING; ITEM: CHARACTER;
                  POSITION: STRINDEX := FIRST) return VSTRING;

  function APPEND(TARGET: VSTRING; ITEM: VSTRING; POSITION: STRINDEX)
                  return VSTRING;
  function APPEND(TARGET: VSTRING; ITEM: STRING; POSITION: STRINDEX)
                  return VSTRING;
  function APPEND(TARGET: VSTRING; ITEM: CHARACTER; POSITION: STRINDEX)
                  return VSTRING;

  function APPEND(TARGET: VSTRING; ITEM: VSTRING) return VSTRING;
  function APPEND(TARGET: VSTRING; ITEM: STRING) return VSTRING;
  function APPEND(TARGET: VSTRING; ITEM: CHARACTER) return VSTRING;

  function REPLACE(TARGET: VSTRING; ITEM: VSTRING;
                   POSITION: STRINDEX := FIRST) return VSTRING;
  function REPLACE(TARGET: VSTRING; ITEM: STRING;
                   POSITION: STRINDEX := FIRST) return VSTRING;
  function REPLACE(TARGET: VSTRING; ITEM: CHARACTER;
                   POSITION: STRINDEX := FIRST) return VSTRING;

-- Concatenation

  function "&" (LEFT: VSTRING; RIGHT : VSTRING) return VSTRING;
  function "&" (LEFT: VSTRING; RIGHT : STRING) return VSTRING;
  function "&" (LEFT: VSTRING; RIGHT : CHARACTER) return VSTRING;
  function "&" (LEFT: STRING; RIGHT : VSTRING) return VSTRING;
  function "&" (LEFT: CHARACTER; RIGHT : VSTRING) return VSTRING;

-- Determine the position of a substring

  function INDEX(WHOLE: VSTRING; PART: VSTRING; OCCURRENCE : NATURAL := 1)
                 return STRINDEX;
  function INDEX(WHOLE : VSTRING; PART : STRING; OCCURRENCE : NATURAL := 1)
                 return STRINDEX;
  function INDEX(WHOLE : VSTRING; PART : CHARACTER; OCCURRENCE : NATURAL := 1)
                 return STRINDEX;


  function RINDEX(WHOLE: VSTRING; PART: VSTRING; OCCURRENCE : NATURAL := 1)
                 return STRINDEX;
  function RINDEX(WHOLE : VSTRING; PART : STRING; OCCURRENCE : NATURAL := 1)
                 return STRINDEX;
  function RINDEX(WHOLE : VSTRING; PART : CHARACTER; OCCURRENCE : NATURAL := 1)
                 return STRINDEX;

-- Conversion from other associated types

  function VSTR(FROM : STRING) return VSTRING;
  function VSTR(FROM : CHARACTER) return VSTRING;
  function "+" (FROM : STRING) return VSTRING;
  function "+" (FROM : CHARACTER) return VSTRING;

  generic
    type FROM is private;
    type TO is private;
    with function STR(X : FROM) return STRING is <>;
    with function VSTR(Y : STRING) return TO is <>;
   function CONVERT(X : FROM) return TO;

pragma PAGE;
\f


  private
    type VSTRING is
      record 
        LEN : STRINDEX := STRINDEX'FIRST;
        VALUE : STRING(FIRST .. LAST) := (others => ASCII.NUL);
      end record;
 
    NUL : constant VSTRING := (STRINDEX'FIRST, (others => ASCII.NUL));
end VSTRINGS;
--
-- .......................................................................... --
--
-- DISTRIBUTION AND COPYRIGHT:
--                                                           
-- This software is released to the Public Domain (note:
--   software released to the Public Domain is not subject
--   to copyright protection).
-- Restrictions on use or distribution:  NONE
--                                                           
-- DISCLAIMER:
--                                                           
-- This software and its documentation are provided "AS IS" and
-- without any expressed or implied warranties whatsoever.
-- No warranties as to performance, merchantability, or fitness
-- for a particular purpose exist.
--
-- Because of the diversity of conditions and hardware under
-- which this software may be used, no warranty of fitness for
-- a particular purpose is offered.  The user is advised to
-- test the software thoroughly before relying on it.  The user
-- must assume the entire risk and liability of using this
-- software.
--
-- In no event shall any person or organization of people be
-- held responsible for any direct, indirect, consequential
-- or inconsequential damages or lost profits.