|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 Tapes |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Tapes Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - downloadIndex: ┃ T ┃
Length: 367029 (0x599b5)
Types: TextFile
Names: »TOUT«
└─⟦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⟧
-- 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.