Trailing-Edge
-
PDP-10 Archives
-
decuslib10-12
-
43,50552/forsem.pas
There are no other files named forsem.pas in the archive.
{ Semantic actions for FORVER version 2.6 }
{$M-,C-.... No main program, No run-time checks.... }
program forsem;
{
Page directory:
Page First non-blank line
---- --------------------
1 Semantic actions for FORVER version 2.6
2 ---- D E S C R I P T I O N O F F O R V E R ----
3 type
4 var
5 ---- M I S C E L A N E O U S P R O C E D U R E S ----
6 ---- S E M A N T I C A C T I O N P R O C E D U R E S ----
7 ---- D U M M Y A R G U M E N T H A N D L I N G ----
8 ---- S T U F F T O S E T V A R I A B L E T Y P E S ----
9 ---- E X P R E S S I O N T Y P E E V A L U A T I O N ----
10 ---- I N C L U D E ----
11 ---- A S S I G N M E N T ----
12 ---- E X T E R N A L R E F E R E N C E S ----
13 -- I N T R I N S I C F U N C T I O N I N I T I A L I Z A T I O N --
14 ---- V E R I F I C A T I O N P R O P E R ----
15 ---- L E X I C A L S E M A N T I C A C T I O N S ----
}
include 'sym6c.def';
include 'lexi.def';
include 'syni.def';
include 'filstk.def';
include 'fnames.def';
include 'forvio.def';
{------------------------------------------------------------------------}
{---- D E S C R I P T I O N O F F O R V E R ----}
{---- D A T A S T R U C T U R E S ----}
{------------------------------------------------------------------------}
{
--------------------------------------------------------------------------
| |
| H A S H T A B L E S : |
| |
| -------------- ; top level table. wiped at each "END". |
| | Locals | |
| -------------- |
| VV |
| -------------- ; table of intrinsic function names. |
| | Intrinsics | |
| -------------- |
| VV |
| -------------- ; table of FORTRAN pseudo-reserved words. |
| | Keywords | |
| -------------- |
| |
| |
| -------------- ; table of MODULE names (not entries!). |
| | Modules | |
| -------------- |
| |
| -------------- ; table of external (entry) names. |
| | Globals | |
| -------------- |
| |
--------------------------------------------------------------------------
--------------------------------------------------------------------------
| |
| O B J E C T S : |
| |
--------------------------------------------------------------------------
--------------------------------------------------------------------------
| |
| P R O P E R T I E S : |
| |
--------------------------------------------------------------------------
}
{------------------------------------------------------------------------}
{---- G L O B A L V A R I A B L E S ----}
{------------------------------------------------------------------------}
type
char3 = packed array [1..3] of char;
var
{ Token numbers }
tk_lparen { left paranthesis. },
tk_rparen { right paranthesis. },
tk_star { multiply. },
tk_divide { divide. },
tk_function { FUNCTION keyword. },
tk_subroutine { SUBROUTINE keyword. },
tk_entry { ENTRY keyword. },
tk_aidentifier { an ARRAY identifier. },
tk_ifidentifier { an Intrinsic function identifier. },
tk_fidentifier { a FUNCTION identifier. },
tk_identifier { a normal identifier. },
tk_string { the type of a char. string. },
tk_label { the type of a label constant. },
tk_integer { the type INTEGER. },
tk_real { the type REAL. },
tk_double { the type DOUBLE PRECISION. },
tk_complex { the type COMPLEX. },
tk_logical { the type LOGICAL. },
tk_typeless { no type at all (eg. subroutine names). },
tk_intconstant { an INTEGER constant. },
tk_realconstant { a REAL constant. },
tk_dblconstant { a DOUBLE PRECISION constant. },
tk_boolconstant { a LOGICAL constant. },
tk_strconstant { a Char. String constant. },
tk_hollconstant { a Hollerith constant. },
tk_labelconstant { a label constant },
tk_block { the BLOCK (DATA) word. },
tk_program { the PROGRAM word. }
: word;
{ Now some frequently used names }
n_argclass { class of dummy arguments. },
n_argcount { number of dummy arguments. },
n_args { the dummies themselves. },
n_argtypes { type of dummy arguments. },
n_badasn { set of lines with bad assignments. },
n_block { "BLOCK." - default BLOCK DATA name. },
n_changed { reflects variables altered within some routine. },
n_defined { says whether some routine's definition is known. },
n_defline { definition line of some routine. },
n_defpage { definition page of some routine. },
n_dummy { says whether some variable is a dummy. },
n_entries { name of ENTRIES table. },
n_external { says whether some variable is external. },
n_globals { name of GLOBALS table. },
n_intdiv { set of lines with integer divisions. },
n_libdef { says whether some routine is actually a library definition. },
n_main { "MAIN." - default PROGRAM name. },
n_misc { "MISC." - general purpose junk name. },
n_modules { name of MODULES table },
n_numrefs { number of times some routine was called. },
n_refs { where and how some routine gets called. },
n_type { type of intrinsic functions. },
n_typed { says whether some variable was explicitly typed. },
n_undvar { set of variables not explicitly declared. },
n_univar { set of uninitialized variables. },
n_used { reflects variables used in some routine. },
n_who { pointer from GLOBALS to LOCALS linking the current entry. }
: name_type;
{ Remaining random junk... }
p { all-around temp. property. },
entries { list of entry objects for this module. },
arguments { list of dummy types for each entry. },
argclass { list of dummy classes for each entry. },
undeclared_variables { set of undeclared variables in this module. },
bad_assignments { set of lines where there's a potentially dangerous assignment. },
integer_divisions { set of lines where there are integer divisions. },
uninit_variables { set of uninitialized variables in this module. }
: property;
obj { all-around temp. object. },
entry { object: currently being defined entry. },
module { object: current module. }
: object;
locals { table of local symbols. },
intrinsics { table of FORTRAN intrinsic names. },
globals { table of external names (entries). },
modules { table of module names (NOT entries). }
{ keywords } { table of "reserved" words. owned by LEXI. }
: hash_table;
bnf : grammar { the FORTRAN parser table for SYNI. };
dfa : automaton { the FORTRAN scanner table for LEXI. };
mod_name { name of current module. },
name6 { temp name. },
name6_1 { temp name. }
: name_type;
name7 { temp ASCII name. }
: char_name;
tok { temp TOKEN variable. },
tok1 { temp TOKEN variable. },
tok2 { temp TOKEN variable. },
opr { temp TOKEN variable. },
type_tok { token saying the type of the current entry. },
entry_tok { token saying what kind of entry this is. }
: token_type;
in_module { says whether we've found a "module start" statement. },
ok { is this routine call ok? },
is_call { is this a SUBROUTINE or FUNCTION call? }
: boolean;
i, j, k, l { temp integer variables. },
len { length of PSTRING buffer. },
count { number of arguments in some routine call. },
nargs { number of arguments in a routine definition. },
num_args { number of arguments in a routine definition. },
nbadrefs { number of bad calls to some routine. },
nline { line number of a routine call. },
npage { page number of a routine call. },
undefined { number of as-yet undefined external names. },
number_errors { number of errors in this module. },
last_error_line { just what it says, dude... }
: integer;
current_type { the type in a type declaration... },
mod_class { says what kind of module we're in. }
: word;
c : char; { temp character variable. }
options : set of char { the options given by the user. };
constants : set of 0..71 { token numbers of constants. };
default_type: array [char] of word { default types based on first letter of names. };
const_type : array [0..71] of word { types associated with various constants. };
argtypes : array [1..100] of word { types of arguments in routine calls. };
buf : pstring { buffer used for TOKDESCR. };
tempfile : file of char { used to pre-check existance of INCLUDE files. };
ttyin : file of char { used to read from the terminal, since the TTY file is so weird. };
vtr_file : file of char { PASCAL file variable to handle VTR files. };
flname : packed array [1..30] of char { some file name. };
vtr_name : filename { used to generate .VTR filename };
vtr_default : filename { default extension for above };
{------------------------------------------------------------------------}
{---- M I S C E L A N E O U S P R O C E D U R E S ----}
{------------------------------------------------------------------------}
function strip ( s : string):integer; extern;
procedure cron ( on : boolean); extern;
function first_letter (name : name_type) : char;
begin
first_letter := chr (name[1] + 040b);
end;
function type_of (item : object) : word;
begin
if plookup (item, n_typed) <> nil
then type_of := ovalue (item) /* explicitly typed */
else begin /* not explicitly typed: */
oname (item, name6); /* get default type */
ochange (item, okind (item), default_type [first_letter (name6)]);
type_of := ovalue (item);
if 'U' in options then padd (undeclared_variables, sfobj (item));
end;
end;
procedure review_entry_defs;
begin
preset (entries);
while not pend (entries) do begin
entry := stobj (pvalue (entries));
arguments := plookup (entry, n_args);
p := pcreate (entry, n_argclass, true, p_sequence);
preset (arguments);
while not pend (arguments) do begin { change from NAME to TYPE }
if pvalue (arguments) <> tk_label
then begin
obj := stobj (pvalue (arguments));
if okind (obj) = 0
then pwrite (p, tk_identifier) { default to ID }
else pwrite (p, okind (obj));
passign (arguments, type_of (obj));
end
else pwrite (p, tk_identifier);
pget (arguments);
end;
obj := stobj (pvalue (plookup (entry, n_who)));
ochange (entry, okind (obj), type_of (obj));
pget (entries);
end;
end;
procedure xon; begin tsearch (locals, 0) end;
procedure xoff; begin tsearch (locals, 1) end;
{------------------------------------------------------------------------}
{---- S E M A N T I C A C T I O N P R O C E D U R E S ----}
{------------------------------------------------------------------------}
{;
; All these procedures take zero parameters and are
; prefixed with the letter "X" to identify them as
; semantic actions.
;
; Following the procedure header is a comment
; describing how they take and leave the argument
; stack:
; N1, N2,... -> M1, M2, ...
; where Ni is an input argument it expects to find on
; the stack and Mi is what it leaves on the stack.
;
; The special symbol `$' means that the stack will
; be (or was) empty at this stage.
;}
procedure xend { $ -> $ };
{F: This procedure is called when an END statement is parsed.
It does some fixups and wipes the LOCALS table and some
properties as well.
}
var
lname : packed array [1..20] of char;
grunt : boolean;
procedure warn_undeclared_variables;
begin
if pcard (undeclared_variables) <> 0 then begin
echoff;
nextline;
lston (true);
fverr (1, 'VND', 'Found ');
fvinteger (pcard (undeclared_variables), 10, 0);
fvstring (' variables not explicitly declared');
fvnl;
if not ('L' in options) then lstoff;
i := pfelement (undeclared_variables);
j := 0;
while i <> 0 do begin
obj := stobj (i);
if (j mod 4) = 0 then nextline;
oname (obj, name6);
sf6name (name6, name7);
write (name7, ' (');
lexname (dfa, ovalue (obj), lname, k);
write (lname:k, ')', ' ':11-k);
i := pnelement (undeclared_variables);
j := j+1;
end;
nextline;
end;
end;
procedure warn_bad_assignments;
begin
if pcard (bad_assignments) <> 0 then begin
echoff;
lston (true);
nextline;
fverr (1, 'AIC', 'Found ');
fvinteger (pcard (bad_assignments), 10, 0);
fvstring (' variables being assigned a value of a different type');
fvnl;
if not ('L' in options) then lstoff;
i := pfelement (bad_assignments);
j := 0;
while i <> 0 do begin
obj := stobj (i);
if (j mod 8) = 0 then nextline
else write (' ');
oname (obj, name6);
sf6name (name6, name7);
write (name7);
i := pnelement (bad_assignments);
j := j+1;
end;
nextline;
end;
end;
procedure warn_integer_divisions;
begin
if pcard (integer_divisions) <> 0 then begin
echoff;
lston (true);
nextline;
fverr (1, 'IDV', 'Found ');
fvinteger (pcard (integer_divisions), 10, 0);
fvstring (' lines with integer divisions');
fvnl;
write ('Offending line numbers:');
nextline;
i := pfelement (integer_divisions);
j := 0;
while i <> 0 do begin
if (j mod 8) = 0 then nextline
else write (' ');
write (i:5);
i := pnelement (integer_divisions);
j := j+1;
end;
nextline;
if not ('L' in options) then lstoff;
end;
end;
procedure warn_uninit_variables;
begin
{?}
end;
begin
if in_module
then begin
grunt :=
((pcard (undeclared_variables) <> 0) and ('U' in options)) or
((pcard (bad_assignments) <> 0) and ('A' in options)) or
((pcard (integer_divisions) <> 0) and ('D' in options)) or
((pcard (uninit_variables) <> 0) and ('I' in options));
sf6name (mod_name, name7);
if number_errors <> 0
then write (tty, ' ... ', name7, ' ... ');
if grunt and not ('L' in options) then begin
nextline;
write ('warnings for module ',name7:strip(name7),':');
nextline;
end;
wrlabeled (ttyoutput, number_errors, ' error');
writeln (ttyoutput, ' detected.');
number_errors := 0;
if 'U' in options then warn_undeclared_variables;
if 'A' in options then warn_bad_assignments;
if 'D' in options then warn_integer_divisions;
if 'I' in options then warn_uninit_variables;
if grunt
then writeln (tty);
review_entry_defs;
twipe (locals);
pwipe (undeclared_variables);
pwipe (bad_assignments);
pwipe (integer_divisions);
pwipe (uninit_variables);
if 'L' in options then eject;
echon;
number_errors := 0;
for c := 'A' to 'Z' do default_type [c] := tk_real;
for c := 'I' to 'N' do default_type [c] := tk_integer;
end
else begin
number_errors := number_errors + 1;
fverr (1, 'EES', 'Extraneous END statement. Ignored');
fvnl;
end;
in_module := false;
end;
procedure xmodule { CLASS, NAME -> CLASS, NAME };
{F: This procedure is called when a PROGRAM, SUBROUTINE,
etc... statement is encountered. It sets the module
name and does some other junk concerning the entry
points.
}
begin
if in_module
then begin
number_errors := number_errors + 1;
fverr (2, 'MES', 'Missing END statement. Supplied free of charge');
fvnl;
xend;
end;
xswap (bnf); xtop (bnf, tok); { get module CLASS }
mod_class := tok.typ;
xswap (bnf); xtop (bnf, tok); { get module NAME }
if (mod_class = tk_block) and (tok.typ = tk_nil)
then mod_name := n_block
else mod_name := tok.nval;
in_module := true;
sf6name (mod_name, name7);
write (ttyoutput, 'Module ', name7, ' ... ');
module := oshove (modules, mod_name);
ochange (module, mod_class, 0) { KIND is module class };
cron (true);
entries := pcreate (module, n_entries, true, p_sequence);
end;
procedure xentry { CLASS, NAME or TYPE, FUNCTION, NAME -> $ };
{F: Used to add an entry name.
}
begin
xpop (bnf, entry_tok); { this guy's got the name. }
xpop (bnf, tok); { and this one says SUBROUTINE, FUNCTION or ENTRY }
if tok.typ = tk_function
then xpop (bnf, type_tok)
else type_tok.typ := tk_nil;
if tok.typ = tk_entry then tok.typ := mod_class; { an ENTRY gets the module's class }
obj := ofind (locals, entry_tok.nval);
if tok.typ = tk_subroutine
then begin { SUBROUTINEs are typeless and forced declared. }
ochange (obj, tk_identifier, tk_typeless);
p := pcreate (obj, n_typed, true, p_boolean);
end
else if type_tok.typ = tk_nil
then begin { Not explicitly typed FUNCTION. }
if plookup (obj, n_typed) = nil then padd (undeclared_variables, sfobj (obj));
ochange (obj, tk_fidentifier, tk_nil);
end
else begin { Explicitly typed FUNCTION. }
p := pcreate (obj, n_typed, true, p_boolean);
ochange (obj, tk_fidentifier, type_tok.typ);
end;
entry := olookup (globals, entry_tok.nval);
if entry = nil
then entry := ocreate (globals, entry_tok.nval)
else if plookup (entry, n_defined) <> nil
then begin
number_errors := number_errors + 1;
fverr (1, 'DUP', 'Duplicate entry name: ');
fvname (entry_tok.nval);
fvstring ('. Earlier definition ignored');
fvnl;
end;
ochange (entry, okind (obj), ovalue (obj));
pwrite (entries, sfobj (entry));
passign (pcreate (entry, n_who, true, p_scalar), sfobj (obj));
passign (pcreate (entry, n_modules, true, p_scalar), sfobj (module));
passign (pcreate (entry, n_defpage, true, p_scalar), fvpage);
passign (pcreate (entry, n_defline, true, p_scalar), fvline);
p := pcreate (entry, n_refs, false, p_sequence);
p := pcreate (entry, n_defined, false, p_boolean);
p := pcreate (entry, n_numrefs, false, p_scalar);
arguments := pcreate (entry, n_args, true, p_sequence);
num_args := 0;
end;
procedure xx; { $ -> $ }
{F: Used to check whether we've got a "bare" main program,
ie. a main program with no PROGRAM statement. This is
detected when we find a non-null statement and we
are not inside a (named) module.
}
begin
xoff;
if not in_module
then begin { well, looks like we DO have a bare main! }
{ simulate something like "PROGRAM MAIN." }
tok.typ := tk_program; xpush (bnf, tok);
tok.typ := tk_identifier; tok.nval := n_main; xpush (bnf, tok);
xmodule;
xpop (bnf, tok); xpop (bnf, tok);
end;
end;
{------------------------------------------------------------------------}
{---- D U M M Y A R G U M E N T H A N D L I N G ----}
{------------------------------------------------------------------------}
procedure xdummy; { NAME -> $ }
{F: Marks a given variable as being a dummy.
}
begin
xpop (bnf, tok);
num_args := num_args + 1;
if tok.typ = tk_star
then pwrite (arguments, tk_label)
else begin
obj := ofind (locals, tok.nval);
if plookup (obj, n_dummy) <> nil
then begin
number_errors := number_errors + 1;
fverr (2, 'DUM', 'Dummy argument ');
fvname (tok.nval);
fvstring (' already was a dummy');
fvnl;
end
else p := pcreate (obj, n_dummy, true, p_boolean);
ochange (obj, tk_identifier, 0);
pwrite (arguments, sfobj (obj));
end;
end;
procedure xedum; { $ -> $ }
{F: End of dummy argument list. Saves the number of arguments
for the current entry.
}
begin
passign (pcreate (entry, n_argcount, true, p_scalar), num_args);
end;
{------------------------------------------------------------------------}
{---- S T U F F T O S E T V A R I A B L E T Y P E S ----}
{------------------------------------------------------------------------}
procedure ximplicit; { TYPE, LETTERS... -> $ }
{F: Handles the IMPLICIT statement... kinda messy!
}
var
range : set of char;
letter,
letter1,
letter2 : char;
begin
range := [];
loop
xpop (bnf, tok2);
exit if not (tok2.typ in [tk_nil, tk_identifier, tk_aidentifier]);
xpop (bnf, tok1);
letter1 := first_letter (tok1.nval);
if tok2.typ <> tk_nil
then letter2 := first_letter (tok2.nval)
else letter2 := letter1;
range := range + [letter1..letter2];
end;
for letter := 'A' to 'Z' do
if letter in range then default_type [letter] := tok2.typ;
end;
procedure xexternal; { NAME -> $ }
{F: Handle the EXTERNAL statement.
}
begin
xpop (bnf, tok);
p := pcreate (ofind (locals, tok.nval), n_external, true, p_boolean);
end;
procedure xparameter; { NAME, CONSTANT -> $ }
{F: Handle the PARAMETER statement: change the symbol
NAME to be a CONSTANT... Local reserved word.
}
begin
xpop (bnf, tok2);
xpop (bnf, tok);
lchange (dfa, tok, tok2.typ);
end;
procedure xtyp; { TYPE -> $ }
{F: Save some type in the variable "current_type".
}
begin
xpop (bnf, tok);
current_type := tok.typ;
end;
procedure xlocal; { NAME -> NAME }
{F: Used when a name is seen. May count it as a not explicitly
declared (typewise) symbol.
}
begin
xtop (bnf, tok);
obj := ofind (locals, tok.nval);
ochange (obj, tok.typ, type_of (obj));
end;
procedure xstyp; { NAME -> NAME }
{F: Set a variable's type, mark it as explicitly declared.
}
begin
xtop (bnf, tok);
if tok.typ = tk_ifidentifier {:begin 2.3 }
then begin {: 2.3 }
xpop (bnf, tok); {: 2.3 }
tok.typ := tk_identifier; {: 2.3 }
xpush (bnf, tok); {: 2.3 }
end; {:end 2.3 }
obj := ofind (locals, tok.nval);
ochange (obj, tok.typ, current_type);
if plookup (obj, n_typed) <> nil
then begin
number_errors := number_errors + 1;
fverr (2, 'VAT', 'Variable ');
fvname (tok.nval);
fvstring (' already type-declared');
fvnl;
end
else begin
p := pcreate (obj, n_typed, true, p_boolean);
premove (undeclared_variables, sfobj (obj));
end;
end;
procedure xretyp; { TYPE, LENGTH -> NEWTYPE }
{F: Handle things such as REAL*8...
}
begin
xpop (bnf, tok1) { length spec };
xpop (bnf, tok2) { base type };
if (tok2.typ = tk_real) and (tok1.ival = 8)
then tok2.typ := tk_double;
xpush (bnf, tok2) { shove it back };
end;
{------------------------------------------------------------------------}
{---- E X P R E S S I O N T Y P E E V A L U A T I O N ----}
{------------------------------------------------------------------------}
procedure xxstyp; { NAME or CONSTANT -> TYPE/REF? }
{F: Gets a token from the stack, and replaces it by its
type. Also puts there some info on whether it's a
variable's address.
}
begin
xpop (bnf, tok);
if tok.typ in constants
then begin
tok.typ := const_type [tok.typ];
tok.ival := 0 { means it's a constant value };
end
else begin
tok.typ := type_of (ofind (locals, tok.nval));
tok.ival := 1 { means it can be a variable passed by reference };
end;
xpush (bnf, tok);
end;
procedure xxtyp; { TYPE1, OP, TYPE2 -> TYPE }
{F: It's here that type evaluation is actually done for
expressions. It takes the types of two operands
and the operator. It returns the type of the
result. Note that this applies to "numeric" types
only and, for instance, "complex" is assumed to be
greater than, say, "integer"...
}
begin
xpop (bnf, tok1);
xpop (bnf, opr);
xpop (bnf, tok2);
if tok1.typ > tok2.typ
then tok.typ := tok1.typ
else tok.typ := tok2.typ;
if (tok.typ = tk_integer) and (opr.typ = tk_divide)
then padd (integer_divisions, 100000*fvpage + fvline);
tok.ival := 0 { means that this can only be passed by value };
xpush (bnf, tok);
end;
procedure xxlog; { TYPE1, TYPE2 -> LOGICAL }
{F: Like XXTYP, but it's used only with relational
operators, therefore the result is ALWAYS
"logical".
}
begin
xpop (bnf, tok);
xpop (bnf, tok);
tok.typ := tk_logical;
tok.ival := 0;
xpush (bnf, tok);
end;
procedure xcmplx; { RPART, IPART -> COMPLEX }
{F: This is the kludge used to implement COMPLEX
constants: take two REAL or INTEGER constants
with a special (ouch!) operator "," and make
a COMPLEX constant out of it!!!
}
begin
xpop (bnf, tok1);
xpop (bnf, tok2);
if (tok1.ival + tok2.ival) <> 0
then begin
number_errors := number_errors + 1;
fverr (1, 'ICC', 'Illegal COMPLEX constant');
fvnl;
end;
tok.typ := tk_complex;
tok.ival := 0;
xpush (bnf, tok);
end;
procedure xxsityp; { ARGUMENTS, NAME -> TYPE }
{F: This one returns the type of an intrinsic function.
Note that all arguments to the intrinsic are simply
thrown away...
}
begin
repeat { ignore arguments to intrinsic functions }
xpop (bnf, tok);
until tok.typ = tk_mark;
xpop (bnf, tok); { this should be the intrinsic's name }
tok.typ := pvalue (plookup (olookup (intrinsics, tok.nval), n_type));
tok.ival := 0;
xpush (bnf, tok);
end;
{------------------------------------------------------------------------}
{---- I N C L U D E ----}
{------------------------------------------------------------------------}
procedure xinclude; { $ -> $ }
{F: Process the INCLUDE statement: direct GETCHAR to read
from the specified source, stacking the current one.
}
var
j : integer;
pbuf : packed array [1..50] of char;
begin
tokdescr (dfa, buf, len); { get file name }
i := 1;
while (i < len-1) and (buf^[i+1] <> '/') do begin
i := i + 1;
pbuf[i-1] := buf^[i];
end;
for j := i to 50 do pbuf[j] := ' ';
reset (tempfile, pbuf, true);
if eof (tempfile)
then begin
number_errors := number_errors + 1;
fverr (2, 'FNF', 'INCLUDE-file "');
fvxstring (pbuf, i-1);
fvstring ('" not found. Ignored');
fvnl;
end
else begin
if (buf^[i+1] = '/') and (buf^[i+2] in ['N', 'n'])
then lstoff { 'file.ext/NOLIST'... }
else begin { 'file.ext/LIST' or just 'file.ext'... }
lstnl;
lstxch ('*');
end;
SPush (pbuf);
end;
close (tempfile);
end;
{------------------------------------------------------------------------}
{---- A S S I G N M E N T ----}
{------------------------------------------------------------------------}
procedure xassign; { NAME, VALUE-TYPE -> $ }
{F: Called when an assignment has been parsed. It takes
the name of the variable being assigned to and the type
of the value being put there and does two things:
1. check that the types are compatible.
2. mark the variable as being "changed" and "used".
}
var
itstype : word;
begin
xpop (bnf, tok1);
xpop (bnf, tok);
if tok.ival <> -1 {:begin 2.3 }
then begin {:end 2.3 }
obj := ofind (locals, tok.nval);
itstype := type_of (obj);
ochange (obj, tok.typ, itstype);
p := pcreate (obj, n_changed, true, p_boolean);
p := pcreate (obj, n_used, true, p_boolean);
if not (tok1.typ in [tk_string, tk_label]) { LABEL and STRING always match }
then if tok1.typ <> itstype { type mismatch? }
then padd (bad_assignments, sfobj (obj));
end; {: 2.3 }
end;
procedure xref; { $ -> $ }
{F: Takes a symbol and simply says that it's been
referenced in this module. It's always called after
<XXSTYP> therefore OBJ points to the right thing.
}
begin
p := pcreate (obj, n_used, true, p_boolean);
end;
{------------------------------------------------------------------------}
{---- E X T E R N A L R E F E R E N C E S ----}
{------------------------------------------------------------------------}
procedure xcall; { NAME, #, ARG... -> $ or NAME }
{F: Handles function/subroutine calls. It checks out the
argument types. It's always called right after either
XFREF (for function calls) or XSREF (for subroutine
calls), this is needed for expression types to be evaluated
correctly. This is indicated by global boolean variable
IS_CALL, which is true iff it's a subroutine call.
}
var
count : integer;
argtypes : array [1..100] of integer;
begin
count := 0;
xpop (bnf, tok);
while tok.typ <> tk_mark do begin { while there are arguments }
count := count + 1;
argtypes [count] := tok.typ;
xpop (bnf, tok);
end;
if is_call
then xpop (bnf, tok) { the subroutine's name }
else xtop (bnf, tok) { the function's name (stays put) };
obj := ofind (locals, tok.nval);
if is_call then ochange (obj, tok.typ, tk_typeless);
if plookup (obj, n_dummy) = nil { not a dummy routine name? }
then begin
p := pcreate (obj, n_external, true, p_boolean);
obj := olookup (globals, tok.nval);
if obj = nil
then begin { Referenced but not (yet) defined. }
obj := ocreate (globals, tok.nval);
ochange (obj, tk_nil, tk_nil);
end;
p := plookup (obj, n_numrefs);
if p = nil
then begin
p := pcreate (obj, n_numrefs, false, p_scalar);
passign (p, 0);
end;
passign (p, pvalue (p) + 1);
arguments := plookup (obj, n_refs);
if arguments = nil then arguments := pcreate (obj, n_refs, false, p_sequence);
pappend (arguments);
pwrite (arguments, sfobj (module)) { name of caller };
{ pwrite (arguments, fvpage) { page number };
pwrite (arguments, fvline) { line number };
{ pwrite (arguments, okind (obj)) { SUBROUTINE or FUNCTION };
{ pwrite (arguments, ovalue (obj)) { presumed type };
pwrite (arguments, count) { number args };
for i := count downto 1 do
pwrite (arguments, argtypes [i]) { each arg type };
end
else arguments := nil;
end;
procedure xsref; { NAME, #, arg1, ... argN -> $ } {:begin 2.4 }
{F: Subroutine reference. Actually calls XCALL.
}
begin {: 2.4 }
is_call := true; {: 2.4 }
xcall; {: 2.4 }
end; {:end 2.4 }
procedure xfref; { NAME, #, arg1, ... argN -> NAME }
{F: Function reference. Like XSREF but leaves the function name
on the argument stack for use by other people.
}
begin
is_call := false; {: 2.4 }
xcall;
end;
procedure xldef; {:begin 2.3 }
{F: provide a means of handling statement-functions.
They are treated as dummy parameters.
}
var {: 2.3 }
itstype : word; {: 2.3 }
begin {: 2.3 }
repeat {: 2.3 }
xpop (bnf, tok); {: 2.3 }
until tok.typ = tk_mark; {: 2.3 }
xpop (bnf, tok); {: 2.3 }
obj := ofind (locals, tok.nval); {: 2.3 }
p := pcreate (obj, n_dummy, true, p_boolean); {: 2.3 }
itstype := type_of (obj); {: 2.3 }
ochange (obj, tk_fidentifier, itstype); {: 2.3 }
xpush (bnf, tok); {: 2.3 }
end; {:end 2.3 }
{------------------------------------------------------------------------}
{-- I N T R I N S I C F U N C T I O N I N I T I A L I Z A T I O N --}
{------------------------------------------------------------------------}
procedure intini;
procedure zdefint (name : char_name;
nargs : integer;
atyp : integer;
ftyp : integer);
begin { zdefint }
with tok do begin
typ := tk_identifier;
st6name (nval, name);
end;
lchange (dfa, tok, tk_ifidentifier);
obj := olookup (intrinsics, tok.nval);
passign (pcreate (obj, n_argcount, true, p_scalar), nargs);
passign (pcreate (obj, n_argtypes, true, p_scalar), atyp);
passign (pcreate (obj, n_type, true, p_scalar), ftyp);
end { zdefint };
begin { intini }
{
;+
; Intrinsic Functions (FORTRAN-10 Defined Functions)
;
; See FORTRAN-10 reference manual pages 15-4 to 15-6.
;-
}
zdefint ('ABS ', 1, tk_real , tk_real );
zdefint ('IABS ', 1, tk_integer, tk_integer);
zdefint ('DABS ', 1, tk_double , tk_double );
zdefint ('CABS ', 1, tk_complex, tk_real );
zdefint ('FLOAT ', 1, tk_integer, tk_real );
zdefint ('IFIX ', 1, tk_real , tk_integer);
zdefint ('SNGL ', 1, tk_double , tk_real );
zdefint ('DBLE ', 1, tk_real , tk_double );
zdefint ('DFLOAT', 1, tk_integer, tk_double );
{ zdefint ('REAL ', 1, tk_complex, tk_real ); }
zdefint ('AIMAG ', 1, tk_complex, tk_real );
zdefint ('CMPLX ', 2, tk_real , tk_complex);
zdefint ('AINT ', 1, tk_real , tk_real );
zdefint ('INT ', 1, tk_real , tk_integer);
zdefint ('IDINT ', 1, tk_double , tk_integer);
zdefint ('AMOD ', 2, tk_real , tk_real );
zdefint ('MOD ', 2, tk_integer, tk_integer);
zdefint ('DMOD ', 2, tk_double , tk_double );
zdefint ('AMAX0 ',-2, tk_integer, tk_real );
zdefint ('AMAX1 ',-2, tk_real , tk_real );
zdefint ('MAX0 ',-2, tk_integer, tk_integer);
zdefint ('MAX1 ',-2, tk_real , tk_integer);
zdefint ('DMAX1 ',-2, tk_double , tk_double );
zdefint ('AMIN0 ',-2, tk_integer, tk_real );
zdefint ('AMIN1 ',-2, tk_real , tk_real );
zdefint ('MIN0 ',-2, tk_integer, tk_integer);
zdefint ('MIN1 ',-2, tk_real , tk_integer);
zdefint ('DMIN1 ',-2, tk_double , tk_double );
zdefint ('SIGN ', 2, tk_real , tk_real );
zdefint ('ISIGN ', 2, tk_integer, tk_integer);
zdefint ('DSIGN ', 2, tk_double , tk_double );
zdefint ('DIM ', 2, tk_real , tk_real );
zdefint ('IDIM ', 2, tk_integer, tk_integer);
{
;+
; Basic External Functions (FORTRAN-10 Defined Functions)
;
; See FORTRAN-10 reference manual pages 15-10 to 15-12.
;-
}
zdefint ('EXP ', 1, tk_real , tk_real );
zdefint ('DEXP ', 1, tk_double , tk_double );
zdefint ('CEXP ', 1, tk_complex, tk_complex);
zdefint ('ALOG ', 1, tk_real , tk_real );
zdefint ('ALOG10', 1, tk_real , tk_real );
zdefint ('DLOG ', 1, tk_double , tk_double );
zdefint ('DLOG10', 1, tk_double , tk_double );
zdefint ('CLOG ', 1, tk_complex, tk_complex);
zdefint ('SQRT ', 1, tk_real , tk_real );
zdefint ('DSQRT ', 1, tk_double , tk_double );
zdefint ('CSQRT ', 1, tk_complex, tk_complex);
zdefint ('SIN ', 1, tk_real , tk_real );
zdefint ('SIND ', 1, tk_real , tk_real );
zdefint ('DSIN ', 1, tk_double , tk_double );
zdefint ('CSIN ', 1, tk_complex, tk_complex);
zdefint ('COS ', 1, tk_real , tk_real );
zdefint ('COSD ', 1, tk_real , tk_real );
zdefint ('DCOS ', 1, tk_double , tk_double );
zdefint ('CCOS ', 1, tk_complex, tk_complex);
zdefint ('ASIN ', 1, tk_real , tk_real );
zdefint ('ACOS ', 1, tk_real , tk_real );
zdefint ('ATAN ', 1, tk_real , tk_real );
zdefint ('DATAN ', 1, tk_double , tk_double );
zdefint ('ATAN2 ', 2, tk_real , tk_real );
zdefint ('DATAN2', 2, tk_double , tk_double );
zdefint ('CONJG ', 1, tk_complex, tk_complex);
zdefint ('RAN ', 1, tk_any, tk_real );
zdefint ('TIM2GO', 1, tk_any, tk_real );
end { intini };
procedure semini (xbnf : grammar; xdfa : automaton);
var
on, ok : boolean;
option : char;
begin { semini }
bnf := xbnf;
dfa := xdfa;
initio (vtr_file, options, 'Listing of the FORTRAN-10 source file');
{ setup miscelaneous names }
st6name (n_argclass,'argcla');
st6name (n_argcount,'argcou');
st6name (n_args, 'args ');
st6name (n_argtypes,'argtyp');
st6name (n_badasn, 'badasn');
st6name (n_block, 'block.');
st6name (n_changed, 'change');
st6name (n_defined, 'defind');
st6name (n_defline, 'deflin');
st6name (n_defpage, 'defpag');
st6name (n_dummy, 'dummy ');
st6name (n_entries, 'entrie');
st6name (n_external,'extern');
st6name (n_globals, 'global');
st6name (n_intdiv, 'intdiv');
st6name (n_libdef, 'libdef');
st6name (n_main, 'main. ');
st6name (n_misc, 'misc. ');
st6name (n_modules, 'module');
st6name (n_numrefs, 'numref');
st6name (n_refs, 'refs ');
st6name (n_type, 'type ');
st6name (n_typed, 'typed ');
st6name (n_undvar, 'undvar');
st6name (n_univar, 'univar');
st6name (n_used, 'used ');
st6name (n_who, 'who ');
{ get the numbers for some useful tokens }
tk_lparen := lexnum (dfa, '@(');
tk_rparen := lexnum (dfa, '@)');
tk_star := lexnum (dfa, '@*');
tk_divide := lexnum (dfa, '@/');
tk_function := lexnum (dfa, 'Function');
tk_subroutine := lexnum (dfa, 'Subroutine');
tk_entry := lexnum (dfa, 'Entry');
tk_block := lexnum (dfa, 'Block');
tk_program := lexnum (dfa, 'Program');
tk_intconstant := lexnum (dfa, 'Integer_Constant');
tk_aidentifier := lexnum (dfa, 'Array_Identifier');
tk_ifidentifier := lexnum (dfa, 'Intrinsic_Identifier');
tk_fidentifier := lexnum (dfa, 'Function_Identifier');
tk_identifier := lexnum (dfa, 'Identifier');
tk_string := lexnum (dfa, 'String');
tk_label := lexnum (dfa, 'Label');
tk_integer := lexnum (dfa, 'Integer');
tk_real := lexnum (dfa, 'Real');
tk_double := lexnum (dfa, 'Double');
tk_complex := lexnum (dfa, 'Complex');
tk_logical := lexnum (dfa, 'Logical');
tk_typeless := lexnum (dfa, 'Typeless');
tk_intconstant := lexnum (dfa, 'Integer_Constant');
tk_realconstant := lexnum (dfa, 'Real_Constant');
tk_dblconstant := lexnum (dfa, 'Double_Constant');
tk_boolconstant := lexnum (dfa, 'Boolean_Constant');
tk_strconstant := lexnum (dfa, 'String_Constant');
tk_hollconstant := lexnum (dfa, 'Hollerith_Constant');
tk_labelconstant := lexnum (dfa, 'Label_Constant');
{ set of tokens to be considered "constants" }
constants := [tk_intconstant,
tk_realconstant,
tk_boolconstant,
tk_dblconstant,
tk_strconstant,
tk_hollconstant,
tk_labelconstant];
{ types corresponding to the "constant" tokens }
const_type [tk_intconstant] := tk_integer;
const_type [tk_realconstant] := tk_real;
const_type [tk_dblconstant] := tk_double;
const_type [tk_boolconstant] := tk_logical;
const_type [tk_strconstant] := tk_string;
const_type [tk_hollconstant] := tk_string;
const_type [tk_labelconstant] := tk_label;
for c := 'A' to 'Z' do default_type [c] := tk_real;
for c := 'I' to 'N' do default_type [c] := tk_integer;
intrinsics := tbegin (lextable (dfa), 233);
locals := tbegin (intrinsics, 1009);
globals := tcreate (n_globals, 1009);
modules := tcreate (n_modules, 1009);
lexuse (dfa, intrinsics); intini;
lexuse (dfa, locals);
obj := ocreate (modules, n_misc);
undeclared_variables := pcreate (obj, n_undvar, true, p_set);
bad_assignments := pcreate (obj, n_badasn, true, p_set);
integer_divisions := pcreate (obj, n_intdiv, true, p_set);
uninit_variables := pcreate (obj, n_univar, true, p_set);
number_errors := 0;
last_error_line := 0;
in_module := false;
xreset (bnf);
end;
{------------------------------------------------------------------------}
{---- V E R I F I C A T I O N P R O P E R ----}
{------------------------------------------------------------------------}
procedure verify;
var
lname : packed array [1..20] of char;
none : boolean;
procedure write_vtr_file;
begin { write_vtr_file }
writeln (tty);
writeln (tty, '[FVRSRT Sorting global symbol table]');
tsort (globals, true) { so names come in alphabetical order };
if 'V' in options then writeln (tty, '[FVRVTR Writing .VTR attribute file]');
obj := ofirst (globals);
while obj <> nil do begin
if (plookup (obj, n_defined) <> nil) and
('V' in options)
then begin { procedure defined here: write it out }
oname (obj, name6);
sf6name (name6, name7);
write (vtr_file, name7:strip(name7), ':');
if ovalue (obj) = tk_typeless
then write (vtr_file, ':')
else begin
lexname (dfa, ovalue (obj), lname, l);
write (vtr_file, lname:l, ':');
end;
count := pvalue (plookup (obj, n_argcount));
write (vtr_file, count:0, ':');
if count = 0
then writeln (vtr_file, '.')
else begin
arguments := plookup (obj, n_args);
preset (arguments);
argclass := plookup (obj, n_argclass);
preset (argclass);
while not pend (arguments) do begin
lexname (dfa, pvalue (arguments), lname, l);
write (vtr_file, lname:l);
if pvalue (argclass) = tk_aidentifier
then write (vtr_file, '*')
else if pvalue (argclass) = tk_identifier
then write (vtr_file, '+')
else write (vtr_file, '$');
count := count-1;
if count = 0
then writeln (vtr_file, '.')
else write (vtr_file, ',');
pget (arguments);
pget (argclass);
end;
end;
end
else if plookup (obj, n_defined) = nil
then undefined := undefined + 1;
obj := onext (obj);
end;
close (vtr_file);
end { write_vtr_file };
procedure solve_external_references;
procedure install_this_thing;
begin { install_this_thing }
writeln (tty, ' ', name7);
undefined := undefined - 1;
none := false;
get (vtr_file) { skip over the ":" };
read (vtr_file, lname:i:[':']);
lname[i+1] := chr(0);
p := pcreate (obj, n_typed, true, p_boolean);
p := pcreate (obj, n_defined, true, p_boolean);
if i = 0 { no type: subroutine }
then ochange (obj, okind (obj), tk_typeless)
else ochange (obj, okind (obj), lexnum (dfa, lname));
get (vtr_file) { skip over the ":" };
read (vtr_file, i);
passign (pcreate (obj, n_argcount, true, p_scalar), i);
arguments := pcreate (obj, n_args, true, p_sequence);
p := pcreate (obj, n_libdef, true, p_boolean);
argclass := pcreate (obj, n_argclass, true, p_sequence);
get (vtr_file) { skip over the ":" };
while vtr_file^ <> '.' do
begin
read (vtr_file, lname:i:['+',',','.','*','$']);
lname[i+1] := chr (0);
if i <> 0
then begin
pwrite (arguments, lexnum (dfa, lname));
if vtr_file^ = '*'
then pwrite (argclass, tk_aidentifier)
else if vtr_file^ = '$'
then pwrite (argclass, tk_fidentifier)
else pwrite (argclass, tk_identifier);
if vtr_file^ in ['*','$','+'] then get (vtr_file);
end;
if vtr_file^ <> '.' then get (vtr_file);
end;
readln (vtr_file);
end { install_this_thing };
procedure show_undefined;
begin { show_undefined }
writeln (tty);
writeln (tty, '[FVRLUS List of undefined symbols]');
i := 0;
obj := ofirst (globals);
while obj <> nil do begin
if plookup (obj, n_defined) = nil
then begin
if (i mod 8) = 0 then writeln (tty)
else write (tty, ' ');
oname (obj, name6);
sf6name (name6, name7);
write (tty, name7);
i := i + 1;
end;
obj := onext (obj);
end;
writeln (tty);
end { show_undefined };
begin { solve_external_references }
if undefined <> 0 then writeln (tty);
loop
write (tty, '[FVRUDS ');
wrlabeled (ttyoutput, undefined, ' undefined external reference');
writeln (tty, ']');
if undefined = 0
then i := 0
else begin
write (tty, 'Search: ');
reset (ttyin, 'TTY:', '/U/I'); readln (ttyin);
read (ttyin, vtr_name.spec:i);
end;
exit if i = 0;
if vtr_name.spec [1] = '?' { list undefined? }
then show_undefined { yes-- show them! }
else begin { no-- search a .VTR file }
anspec (vtr_name);
blankspec (vtr_default);
vtr_default.ext := 'VTR';
defspec (vtr_name, vtr_default);
genspec (vtr_name);
reset (vtr_file, vtr_name.spec);
obj := ofirst (globals);
read (vtr_file, name7:i:[':']);
st6name (name6, name7);
write (tty, ' Found');
none := true;
while (obj <> nil) and (not eof (vtr_file)) do begin
oname (obj, name6_1);
case scmnames (name6, name6_1) of
s_eq: begin
if plookup (obj, n_defined) = nil
then install_this_thing;
read (vtr_file, name7:i:[':']);
st6name (name6, name7);
obj := onext (obj);
end;
s_gt: obj := onext (obj);
s_lt: begin
readln (vtr_file);
read (vtr_file, name7:i:[':']);
st6name (name6, name7);
end;
end { case };
end { while };
if none then writeln (tty, ' nothing here.');
end;
writeln (tty);
end { loop };
end { solve_external_references };
procedure write_verification;
var
totalbadrefs : integer;
begin { write_verification }
writeln (tty, '[FVRVER Verifying all routine calls]');
lstsubttl ('Verification of all SUBROUTINE / FUNCTION calls');
lstheader ('Name module line calls Argument types (A1,A2,...,An)');
eject; { start on a new page }
obj := ofirst (globals);
totalbadrefs := 0;
while obj <> nil do
begin
oname (obj, name6);
sf6name (name6, name7);
write (name7, ' ');
if plookup (obj, n_defined) = nil
then begin
write (' udf. ', pvalue (plookup (obj, n_numrefs)):4,
' Not known. No verification.');
nextline;
end
else begin { ok, it's defined... }
if plookup (obj, n_libdef) <> nil
then write ('ext. lib. ')
else begin
oname (stobj (pvalue (plookup (obj, n_modules))), name6);
sf6name (name6, name7);
write (name7, ' ');
write (pvalue (plookup (obj, n_defline)):5, ' ');
end;
write (pvalue (plookup (obj, n_numrefs)):4, ' ');
arguments := plookup (obj, n_args);
preset (arguments);
nargs := pvalue (plookup (obj, n_argcount));
write ('(');
while not pend (arguments) do begin
lexname (dfa, pvalue (arguments), lname, l);
write (lname:l);
pget (arguments);
if not pend (arguments) then write (',');
end;
write (')');
nextline;
p := plookup (obj, n_refs);
preset (p);
nbadrefs := 0;
while not pend (p) do begin
oname (stobj (pvalue (p)), name6); pget (p);
pread (p, nline);
pread (p, count);
preset (arguments);
ok := count = nargs;
for i := 1 to count do begin
pread (p, argtypes [i]);
ok := ok and (argtypes [i] = pvalue (arguments));
if not pend (arguments) then pget (arguments);
end;
if not ok then begin
nbadrefs := nbadrefs + 1;
sf6name (name6, name7);
write (' ? ', name7, ' ', nline:5);
write (' (');
for i := 1 to count do begin
lexname (dfa, argtypes [i], lname, l);
write (lname:l);
if i<count then write (',');
end;
write (')');
nextline;
end;
end;
if nbadrefs <> 0
then begin
if totalbadrefs = 0 then writeln (tty);
oname (obj, name6);
sf6name (name6, name7);
write (tty, '?FVRICC ');
wrlabeled (ttyoutput, nbadrefs, ' incorrect call');
writeln (tty, ' to routine ',name7:strip(name7), '.');
end;
totalbadrefs := totalbadrefs + nbadrefs;
end;
obj := onext (obj);
end;
if totalbadrefs = 0
then writeln (tty, '[FVRCOK All routine calls correct]');
writeln (tty);
writeln (tty, '[FVREND End of FORTRAN-10 verification]');
END;
BEGIN { verify }
write_vtr_file;
solve_external_references;
write_verification;
END { verify };
{------------------------------------------------------------------------}
{---- L E X I C A L S E M A N T I C A C T I O N S ----}
{------------------------------------------------------------------------}
procedure holstr;
const
cr=15b; lf=12b; ff=14b; vt=13b;
var
junk : word;
begin
tokdescr (dfa, buf, len);
junk := 0;
for i := 1 to len-1 do junk := (10 * junk) + (ord (buf^[i]) - ord ('0'));
i := 0;
repeat
c := lexgchar (dfa);
i := i + 1;
until (i = junk) or (ord(c) in [cr,lf,vt,ff]);
if not (ord(c) in [cr,lf,vt,ff]) then c := lexgchar (dfa);
end;
procedure intcnv;
var
junk : word;
begin
tokdescr (dfa, buf, len);
lexgtok (dfa, tok);
junk := 0;
if buf^[1] = '"'
then for i := 2 to len do junk := 8*junk + (ord(buf^[i])-ord('0'))
else for i := 1 to len do junk := 10*junk + (ord(buf^[i])-ord('0'));
tok.ival := junk;
lexstok (dfa, tok);
end;
procedure synerr (bnf : grammar; reason : integer; tok : token_type);
var
junk : packed array [1..50] of char;
begin { synerr }
lexname (dfa, tok.typ, junk, len);
number_errors := number_errors + 1;
if reason = 0
then fverr (2, 'SED', 'Unexpected ')
else fverr (2, 'SEI', 'Expected something before ');
if junk[1] = '@'
then begin
fvchar ('"');
for i := 2 to len do fvchar (junk[i]);
end
else begin
fvchar ('<');
for i := 1 to len do fvchar (junk[i]);
fvstring ('>: "');
tokdescr (syndfa (bnf), buf, len);
for i := 1 to len do fvchar (buf^ [i]);
end;
fvchar ('"'); fvnl;
xsemant (bnf, false);
end { synerr };
procedure lexerr (dfa : automaton);
begin { lexerr }
tokdescr (dfa, buf, len);
number_errors := number_errors + 1;
fverr (2, 'LER', 'Unrecognized symbol: "');
for i := 1 to len do fvchar (buf^[i]);
fvstring ('", ignored');
fvnl;
c := lexgchar (dfa);
end { lexerr }.