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