Google
 

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 }.