|
DataMuseum.dkPresents historical artifacts from the history of: RC3500 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about RC3500 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 144384 (0x23400)
Types: TextFileVerbose
Names: »p1rcpas«
└─⟦2c55ea56f⟧ Bits:30001844 SW-save af projekt 1000, Alarm-system
└─⟦6b41451d2⟧
└─⟦this⟧ »p1rcpas«
program pass1(input,output,environment,intermitfil);
(* *)
(* B O B S - SYSTEM *)
(* *)
(* SKELETON COMPILER *)
(* *)
(* VERSION OCTOBER 1976 *)
label 10; (*EXIT LABEL*)
const
(* BOBS-CONSTANTS*)
stackmax=100; (*SIZE OF ATTSTACK AND PARSESTACK *)
stringmax=100; (* SIZE OF ATTRIBUTE STRING *)
chbufmax=200; (* SIZE OF ARRAY CHBUF *)
minch=' '; maxch='~'; (*FIRST/LAST CHARACTER IN TYPE CHAR*)
linemax=120; (*MAX. LENGTH OF LINES*)
testoutput=false; (* DO NOT OUTPUT THE STEPS IN THE PARSE *)
(*global constants used in code*)
higherror = 167; (* highest error number from code *)
version = 'pascal version 1980.03.26';
alfalength=12; (*length of alfa variable*)
charsperword=3; (*number of chars packed in one word*)
blank=' '; (*to clear a variable of type alfa*)
(* CONSTANTS FOR SYMBOL-TABLES *)
maxlevel = 15;
labellength = 4;
(* CONSTANTS FOR EMIT-PROCEDURES *)
nilref = -1;
hashmax = 200; (* number of elements in a hashnode, used for
reading an environment *)
type
(* BOBS-TYPES*)
chbufinx=0..chbufmax;
stackinx=0..stackmax;
string=packed array[1..stringmax] of char;
(* TYPES FOR THE SYMBOL-TABLE *)
nameptr = ^namenode;
typptr = ^typnode;
stringptr = ^stringnode;
namelistptr = ^namelisthead;
caselabptr = ^caselabnode;
caselistptr = ^caselisthead;
tagnodeptr = ^tagnode;
taglistptr = ^taglisthead;
constptr = ^constnode;
labelptr = ^labelnode;
headfilptr = ^headfilnode;
extptr = ^extmodules;
checkcaseptr = ^checkcasenode;
nodeident = integer;
labelval = packed array[1..labellength] of char;
nkind = (constname, typname, varname, fieldname,
varparname, valparname, filename, procname,
funcname, fprocname, ffuncname,programname,
tagfldname, modulename);
tkind = (recordtyp, settyp, filetyp, pointertyp,
scalartyp, inttyp, realtyp,
booleantyp, asciityp, subrangetyp, arraytyp, stringtyp);
nlstkind = (fixnamelist, paramnamelist,
scalarnamelist, declarationlist);
leveltypes = (standardlevel, programlevel, blocklevel,
withlevel, firstwithlevel);
pfmodes = (internal, forw, extpascal, extstand,
extfortran,systemmode);
stringnode = record
case length: integer of
-1: (stringnul: 0..0);
0,1,2,3: (string3: packed array [1..3] of char);
4,5,6: (string6: packed array [1..6] of char);
7,8,9: (string9: packed array [1..9] of char);
10,11,12: (string12: packed array [1..12] of char);
13,14,15: (string15: packed array [1..15] of char);
16,17,18: (string18: packed array [1..18] of char);
19,20,21: (string21: packed array [1..21] of char);
22,23,24: (string24: packed array [1..24] of char);
25,26,27: (string27: packed array [1..27] of char);
28,29,30: (string30: packed array [1..30] of char);
31,32,33: (string33: packed array [1..33] of char);
34,35,36: (string36: packed array [1..36] of char);
37,38,39: (string39: packed array [1..39] of char);
40,41,42: (string42: packed array [1..42] of char);
43,44,45: (string45: packed array [1..45] of char);
46,47,48: (string48: packed array [1..48] of char);
49,50,51: (string51: packed array [1..51] of char);
52,53,54: (string54: packed array [1..54] of char);
55,56,57: (string57: packed array [1..57] of char);
58,59,60: (string60: packed array [1..60] of char);
61,62,63: (string63: packed array [1..63] of char);
64,65,66: (string66: packed array [1..66] of char);
67,68,69: (string69: packed array [1..69] of char);
70,71,72: (string72: packed array [1..72] of char);
73,74,75: (string75: packed array [1..75] of char);
76,77,78: (string78: packed array [1..78] of char);
79,80,81: (string81: packed array [1..81] of char);
82,83,84: (string84: packed array [1..84] of char);
85,86,87: (string87: packed array [1..87] of char);
88,89,90: (string90: packed array [1..90] of char);
91,92,93: (string93: packed array [1..93] of char);
94,95,96: (string96: packed array [1..96] of char);
97,98,99: (string99: packed array [1..99] of char);
100: (string100: packed array [1..100] of char);
999: (alfastr: alfa);
1000: (str: string);
1001: (compare: array[1..34] of integer)
end;
namenode = packed record
namestr: alfa;
ident: nodeident;
lefttree, righttree, list : nameptr;
case namekind: nkind of
constname: (constant: constptr);
typname, varname, fieldname, varparname,
valparname, ffuncname, tagfldname: (typ: typptr;
initialized : boolean);
filename: (filetyp: typptr;
ext: boolean;
extname: stringptr);
fprocname,
programname: (nothing: 0..0);
procname: (pmodulename: nameptr;
pmode: pfmodes;
pparamlist, plokvarlist:
namelistptr);
funcname: (fmodulename: nameptr;
assignable,
assigned : boolean;
fmode: pfmodes;
fparamlist, flokvarlist:
namelistptr;
functyp: typptr);
modulename: (modulekind: pfmodes;
procfunclist:nameptr)
end;
constnode = packed record
ident: nodeident;
constval: stringptr;
consttyp: typptr;
leftconsttree, rightconsttree: constptr
end;
labelnode = packed record
ident: nodeident;
labelvalue: labelval;
defined: boolean;
labellist: labelptr
end;
namelisthead = packed record
ident: nodeident;
pack: boolean;
namelistkind: nlstkind;
nametree, namelist: nameptr;
labeltree: labelptr
end;
typnode = packed record
ident: nodeident;
pack: boolean;
case typkind: tkind of
subrangetyp: (subtyp: typptr;
firstconst, lastconst:
constptr);
booleantyp, asciityp,
scalartyp: (scalarlist: namelistptr;
noofscalars : integer);
inttyp, realtyp: (nothing:0..0);
arraytyp: (indextyp, valtyp: typptr);
stringtyp: (length:0..stringmax;
next: typptr);
recordtyp: (fixlist: namelistptr;
variantlist: taglistptr);
settyp: (setoftyp: typptr);
filetyp: (randomfile: boolean;
fileindextyp,
elementtyp:typptr);
pointertyp: (case declar: boolean of
true: (pointertotyp: typptr);
false: (ptrlistptr: typptr;
ptrtypname: ^alfa)
)
end;
caselabnode = packed record
ident: nodeident;
constant: constptr;
list: caselabptr
end;
taglisthead = packed record
ident: nodeident;
pack: boolean;
tagfield: nameptr;
tagtyp: typptr;
varlist: tagnodeptr
end;
tagnode = packed record
ident: nodeident;
caselablist: caselistptr;
fixlist: namelistptr;
taglist: taglistptr;
list: tagnodeptr
end;
caselisthead = packed record
ident: nodeident;
labellist: caselabptr
end;
headfilnode = record
filename: alfa;
externname: stringptr;
nextheadfil: headfilptr
end;
extmodules = record
name:nameptr;
next:extptr
end;
checkcasenode = packed record
constant:constptr;
next:checkcaseptr
end;
(* TYPES TO EMIT PROCEDURES *)
emitwords = (enone, ename, eprogram, econst, etype,
evar, efield, etagfield, evalparam, evarparam,
effunc, efproc, eproc, efunc, emodule,
esystem, epascal, efortran, estandard, eint,
eext, elabel, elabeldef, escalar, einteger,
ereal, eboolean, eascii, estring, esubrange,
earray, erecord, eset, efile, epointer,
eunpacked, epacked, eseq, erandom, ebackref,
enamelist, efix, eparam, edeclaration, escalarlist,
evarlist, ecaselist, erecordlabel, etagelement, eforward,
eendprogram, eendmodule, eendnamelist, eendvarlist, eendcaselist,
ecase, eoff, eotherwise, egotoendcase, eendcase,
ecaselabel, ewhile, ewhiledo, eendwhile, ewith,
ewithdo, ewithvar, ewithname, eendwith, erepeat,
euntil, eendrepeat, efor, eforinit, efortodo,
efordowntodo, efortoend, efordntoend, eif, ethen,
eelse, eendif, enamecode, efunction, econstcode,
ereference, eindex, eload, estore, estorefunc,
estartset, esetrange, eendset, eleftconv, erightconv,
enot, emult, eadd, edif, erealdiv,
eintdiv, emod, eand, eor, esetdif,
esetunion, esetinter, eminus, eeq, ene,
elt, ele, ege, egt, ein,
evalue, evaluename, evaluenaend, eelementbegin,eelementend,
efieldbegin, efieldend, estorevalue, eendvalue, ecallproc,
ecallfunc, eformat, eendcall, eblockbegin, eblockend,
egoto, elinenumber, eoption);
(*types used in code*)
attributes=record
chbufp:chbufinx;
constant:constptr;
case integer of
1:(list:namelistptr;
nam:nameptr;
typp:typptr);
2:(taglist:taglistptr;
oldcasetag:taglistptr);
3:(fixxlist:namelistptr;
variant:tagnodeptr;
caselabels:caselistptr);
4:(varnam:nameptr;
vartypp:typptr;
formalname:nameptr;
firstpar:boolean);
5:(valnam:nameptr;
valtypp:typptr;
valtag:taglistptr;
count:integer);
6:(extmod:extptr);
7:(paramtypp:typptr;
moreparameters,secondparameter:boolean);
8:(selectortypp:typptr;
casecheck:checkcaseptr);
9:(withnumber:integer)
end;
(*types used to hash the identifications in connection
with reading/writing an environment *)
hashptr=^hashnode;
hashelement = packed record
ident:nodeident;
case integer of
1:(constant:constptr);
2:(typ:typptr);
3:(namlist:namelistptr);
4:(taglist:taglistptr);
5:(caselablist:caselistptr);
6:(nam:nameptr)
end;
hashindex = 0..hashmax;
hashnode=record
next:hashptr;
elements:array[hashindex] of hashelement
end;
var
inputfile : boolean;
(* BOBS-VARIABLES*)
attstack: array[stackinx] of attributes;
chbuf: array[chbufinx] of char;
chbufi: chbufinx;
ok: boolean;
(* tables: text; *)
(*CHBUF, CHBUFI, FIELD CHBUFP OF ATTRIBUTES, TABLES AND OK
(*SHOULD NOT BE CHANGED BY THE USER *)
errormarks : packed array [0..higherror] of boolean;
warningcount,
errorcount : integer ;
line: array[1..linemax] of char; (*CONTAINS CURRENT LINE*)
linelength, (*LENGTH OF CURRENT LINE*)
errorinx, (*POSITION IN LINE OF LAST ERROR MARK*)
indention, (*number of leading spaces on a line *)
lineinx: integer; (*POSITION IN LINE OF CURRENT CH*)
printed: boolean; (*TRUE IF CURRENT LINE HAS BEEN PRINTED*)
(*global variables used in code *)
conststring:stringnode; (*the last read string or number*)
constroot:constptr; (*the tree containing numbers*)
stringtypes:typptr; (*pointer to a list of stringtypes
with different length's *)
scalarvalue:integer; (*ordinal value of a scalar*)
identification:integer; (*last identification given to a node*)
locallinenumber, (* relative line number of a procedure *)
linenumber : integer; (*line numbers are added to the programlisting*)
programlist:boolean; (*true if a listing is wanted, option L+ *)
integertype,realtype,booltype,asciitype:typptr; (*pointers to standard types*)
nilconst : constptr; (* the constant NIL *)
indexkinds:set of tkind; (*the typekinds allowed as index*)
asciiorstring:array[asciityp..stringtyp] of tkind;
prodtab:array[0..289] of integer;(*converts production numbers*)
writeformat:integer; (*number of formating parameters*)
outputfound,inputfound : boolean; (*true if output/input is in program heading *)
globalhash : hashptr; (*holds the first hashnode in the list *)
globalmodule:extptr; (*holds the list of EXTERNAL MODULE names *)
globalfieldlist:namelistptr;
globalvaltypp:typptr;
globalvalnam:nameptr;
globalvalcount:integer;
packstructure, (* > 0 if parsing a packed structure *)
levelnumber : integer; (*levelnumber for nested statements *)
vardeclaration : boolean; (*true if variable declaration part*)
globaltag : taglistptr;
globalcasetype : typptr;
globcasecheck,freecasecheck:checkcaseptr; (*holds lists in connection with check of caselabels *)
characters:array[char] of constptr; (*holds constants of type char *)
(* GLOBAL VARIABLES FOR THE SYMBOL-TABLE *)
levels: array[-1..maxlevel] of (* A RECORD FOR EACH LEVEL IN THE PROGRAM *)
packed record
leveltype: leveltypes;
namelist: namelistptr;
withnumber:integer;
withvartyp: typptr
end;
leveltop: integer; (* THE ACTUAL NUMBER OF LEVELS *)
unsatptrtyplist: typptr; (* A POINTER TO THE LIST OF UNSATIFIED POINTERTYPES *)
unsatheadfil: headfilptr; (* A POINTER TO THE LIST OF UNSATIFIED HEADFILES-DECLARATIONS *)
(* THE GLOBAL VARIABLES USED IN EMIT-PROCEDURES *)
intermitfil : text;
outputmode : (human,compress,machine);
nilstr: stringnode;
pfmodeconv: array[forw..systemmode] of emitwords;
nkindconv: array[nkind] of emitwords;
tkindconv:array[scalartyp..asciityp] of emitwords;
emitwconv: array[emitwords] of packed array[1..12] of char;
emitfileconv,emitpackconv,emitrandconv: array[boolean] of emitwords;
emitnlistconv: array[nlstkind] of emitwords;
emitbuffered, loadbuffered: boolean;
oldtyp: typptr;
oldname: nameptr;
environment:text;
envtoname:array[2..33] of nkind;
envtotype:array[23..34] of tkind;
envtomodes:array[15..18] of pfmodes;
value
prodtab=( 0, 0,1302, 0, 401, 402, 0, 403, 501, 501,
502, 503, 504, 505, 506, 507, 0, 0, 0, 0,
0, 602, 0, 607, 629, 601, 603, 606, 604, 605,
101, 0, 0, 0, 0, 101, 608, 609, 611, 626,
627, 628, 609, 610, 101, 612, 613, 614, 0, 0,
0, 0, 618, 615, 0, 616, 617, 101, 619, 620,
621, 0, 101, 622, 0, 623, 624, 625, 103, 701,
702, 703, 704, 0, 705, 706, 707, 707, 824, 825,
826, 827, 828, 829, 830, 0, 104, 800, 801, 802,
803, 804, 805, 806, 0, 0, 807, 831, 808, 808,
809, 810, 0, 811, 812, 813, 814, 815, 816, 817,
0, 818, 819, 820, 821, 822, 823, 0, 832, 913,
913, 0, 0, 0, 0, 0, 0, 901, 901, 902,
903, 904, 0, 905, 906, 907, 0, 908, 909, 911,
912, 917, 0, 918, 920, 921, 0, 926, 928, 931,
932, 935, 0, 0, 0, 0, 0, 0, 901, 902,
903, 904, 0, 905, 906, 907, 0, 910, 916, 914,
915, 0, 0, 919, 922, 0, 0, 923, 924, 0,
925, 925, 927, 929, 930, 933, 933, 934, 937, 936,
936, 0,1001,1005,1005, 101,1002,1003,1004, 0,
0, 0, 0,1015,1015, 0, 0,1016, 0,1034,
1035, 0, 0,1006, 0, 0,1007,1008,1009,1010,
101,1011,1012,1013,1014, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0,1017, 0, 0, 0,1018,
1019,1020,1021,1022,1023,1023,1024,1025, 0,1030,
1031, 0,1026, 0,1027,1028,1029,1032,1033,1036,
1037,1038, 0, 0,1039,1039, 0,1102,1102,1103,
1103, 101, 0, 0, 0,1101,1104,1301, 0, 0,
1303, 106,1304, 0, 0,1305,1306,1307, 0, 0);
inputfile = false;
programlist = false;
locallinenumber = -1;
errormarks = (<0..higherror>*false);
errorcount = 0;
warningcount = 0;
linenumber = 0;
unsatptrtyplist = nil;
unsatheadfil = nil;
constroot=nil;
stringtypes=nil;
identification=0;
leveltop=-2;
levelnumber = 0;
indexkinds=[subrangetyp,booleantyp,asciityp,scalartyp,inttyp];
asciiorstring=(asciityp, asciityp, stringtyp, stringtyp);
globalmodulename=nil;
globcasecheck=nil;
freecasecheck=nil;
outputfound=false;
inputfound=false;
packstructure=0;
envtoname=(programname, constname, typname, varname,
fieldname, tagfldname, valparname, varparname,
ffuncname, fprocname, procname, funcname,
modulename, <15..33>*filename);
envtotype=(scalartyp, inttyp, realtyp, booleantyp,
asciityp, stringtyp, subrangetyp, arraytyp,
recordtyp, settyp, filetyp, pointertyp);
envtomodes=(systemmode, extpascal, extfortran, extstand);
outputmode = compress;
nilstr=(-1:(0));
nkindconv=( econst, etype, evar, efield,
evarparam, evalparam, efile, eproc,
efunc, efproc, effunc, eprogram,
etagfield, emodule);
tkindconv=( escalar, einteger, ereal, eboolean, eascii);
pfmodeconv=( enone, epascal, estandard, efortran, esystem);
emitfileconv=( eint, eext);
emitpackconv=( eunpacked, epacked);
emitrandconv=( eseq, erandom);
emitnlistconv=( efix, eparam, escalarlist, edeclaration);
emitwconv=(' ', 'NAME ', 'PROGRAM ', 'CONST ', 'TYPE ',
'VAR ', 'FIELD ', 'TAGFIELD ', 'VALUEPARAM ', 'VARPARAM ',
'FFUNC ', 'FPROC ', 'PROC ', 'FUNC ', 'MODULE ',
'SYSTEM ', 'PASCAL ', 'FORTRAN ', 'STANDARD ', 'INT ',
'EXT ', 'LABEL ', 'LABELDEF ', 'SCALAR ', 'INTEGER ',
'REAL ', 'BOOLEAN ', 'ASCII ', 'STRING ', 'SUBRANGE ',
'ARRAY ', 'RECORD ', 'SET ', 'FILE ', 'POINTER ',
'UNPACKED ', 'PACKED ', 'SEQ ', 'RANDOM ', 'BACKREF ',
'NAMELIST ', 'FIX ', 'PARAM ', 'DECLARATION ', 'SCALAR ',
'VARLIST ', 'CASELIST ', 'RECORDLABEL ', 'TAGELEMENT ', 'FORWARD ',
'ENDPROGRAM ', 'ENDMODULE ', 'ENDNAMELIST ', 'ENDVARLIST ', 'ENDCASELIST ',
'CASE ', 'OF ', 'OTHERWISE ', 'GOTOENDCASE ', 'ENDCASE ',
'CASELABEL ', 'WHILE ', 'WHILEDO ', 'ENDWHILE ', 'WITH ',
'WITHDO ', 'WITHVAR ', 'WITHNAME ', 'ENDWITH ', 'REPEAT ',
'UNTIL ', 'ENDREPEAT ', 'FOR ', 'FORINIT ', 'FORTODO ',
'FORDOWNTODO ', 'FORTOEND ', 'FORDOWNTOEND', 'IF ', 'THEN ',
'ELSE ', 'ENDIF ', 'NAMECODE ', 'FUNCTION ', 'CONSTCODE ',
'REFERENCE ', 'INDEX ', 'LOAD ', 'STORE ', 'STOREFUNC ',
'STARTSET ', 'SETRANGE ', 'ENDSET ', 'LEFTCONV ', 'RIGHTCONV ',
'NOT ', 'MULT ', 'ADD ', 'DIF ', 'REALDIV ',
'INTDIV ', 'MOD ', 'AND ', 'OR ', 'SETDIF ',
'SETUNION ', 'SETINTER ', 'MINUS ', 'EQ ', 'NE ',
'LT ', 'LE ', 'GE ', 'GT ', 'IN ',
'VALUE ', 'VALUENAME ', 'VALUENAMEEND', 'ELEMENTBEGIN', 'ELEMENTEND ',
'FIELDBEGIN ', 'FIELDEND ', 'STOREVALUE ', 'ENDVALUE ', 'CALLPROC ',
'CALLFUNC ', 'FORMAT ', 'ENDCALL ', 'BLOCKBEGIN ', 'BLOCKEND ',
'GOTO ', 'LINENUMBER ', 'OPTION ');
(* BOBS-PROCEDURES*)
procedure stop(n: integer); forward;
procedure printline;
var i :integer;
begin
if programlist then
begin
write(linenumber:5,' ');
if locallinenumber < 0 then write(' ':5)
else write(locallinenumber : 4, ' ');
if indention>0 then write(' ':indention);
for i:=1 to linelength do write(line[i]);
writeln;
end;
printed:=true
end; (*PRINTLINE*)
procedure warning(n: integer);
var i : integer;
prgrlst : boolean;
begin
warningcount := warningcount + 1;
errormarks[n] := true;
if not printed then
begin
prgrlst := programlist;
programlist := true; (* force printing of erroneous line *)
printline;
programlist := prgrlst;
end;
if errorinx=0 then
begin
write(' *********');
if indention>0 then write(' ':indention);
end;
for i:=errorinx to lineinx-2 do write(' ');
write('^',n:3); (*N <=999 *)
errorinx:=lineinx+3
end; (* warning *)
procedure markerror(n : integer);
var oldwarning : integer;
begin
errorcount := errorcount + 1;
oldwarning := warningcount;
warning(n);
warningcount := oldwarning;
end; (* markerror *)
procedure printerrors;
var
i, currenttextno : integer;
ch : char;
begin
page(output);
writeln(output,'number of errors :', errorcount : 4);
writeln(output,'number of warnings:', warningcount : 4);
writeln(output);
writeln(output,'error description');
open(input,'pascalenv');
reset(input);
(* scan the environment file until end of standard environment *)
repeat
read(i); (* intermediate form code *)
if i = ord(eendnamelist) then
begin
read(i); (* namelist kind *)
if i = ord(edeclaration) then
read(i) (* level number *)
else
i := 0;
end
else
i := 0;
readln(input);
until i = 1;
currenttextno := -1;
for i := currenttextno + 1 to higherror do
if errormarks[i] then
begin
(* find the text *)
while i > currenttextno do
begin
if not eof(input) then readln(input);
if not eof(input) then read(currenttextno)
else currenttextno := higherror + 1;
end;
write(output,i : 4, ': ');
if i <> currenttextno then
write(output, ' (no text) ')
else
while not eoln(input) do
begin
read(ch);
write(output,ch);
end;
writeln(output);
end; (* for i := .... *)
end; (* printerrors *)
(* EMIT PROCEDURES *)
procedure emitold; forward;
procedure emit(nr: integer;
text1: emitwords;
var val1:stringnode;
text2, text3, text4: emitwords;
var val2: stringnode;
ref1, ref2, ref3: nodeident);
(* THE PROCEDURE IS USED TO WRITE INTERMEDIATE FORM-LINES
OF THE SYMBOL-TABLE *)
var
j: integer;
begin
if emitbuffered then emitold;
if outputmode = human then
begin
if nr >= 0 then write(intermitfil,nr:5,' ') else write(intermitfil,' ':6);
write(intermitfil,emitwconv[text1]:12);
if val1.length >= 0 then
write(intermitfil,', ''',val1.str:val1.length,''' ');
if text2 <> enone then write(intermitfil,', ',emitwconv[text2]:11);
if text3 <> enone then write(intermitfil,', ',emitwconv[text3]:8);
if text4 <> enone then write(intermitfil,', ',emitwconv[text4]:8);
if ref1 <> nilref then write(intermitfil,',',ref1:5);
if ref2 <> nilref then write(intermitfil,',',ref2:5);
if ref3 <> nilref then write(intermitfil,',',ref3:5);
if val2.length >= 0 then
write(intermitfil,', ''',val2.str:val2.length,'''');
writeln(intermitfil,';');
end (* HUMAN *)
else
begin
write(intermitfil,ord(text1):1);
if nr > 0 then write(intermitfil,' ',nr:1);
if val1.length >= 0 then write(intermitfil,' ',val1.str:val1.length);
if text2 <> enone then
begin
write(intermitfil,' ',ord(text2):1);
if text3 <> enone then
begin
write(intermitfil,' ',ord(text3):1);
if text4 <> enone then
write(intermitfil,' ',ord(text4):1);
end;
end;
if ref1 <> nilref then
begin
write(intermitfil,' ',ref1:1);
if ref2 <> nilref then
begin
write(intermitfil,' ',ref2:1);
if ref3 <> nilref then
write(intermitfil,' ',ref3:1);
end;
end;
if val2.length >= 0 then
write(intermitfil,' ',val2.str:val2.length);
writeln(intermitfil,' ');
end (* compress *)
end; (* EMIT *)
procedure emitcode(text: emitwords; ref1, ref2: nodeident);
(* THE PROCEDURE IS USED TO WRITE INTERMEDIATE FORM-LINES
OF THE CODE *)
begin
if emitbuffered then emitold;
if outputmode = human then
begin
write(intermitfil,' ':6);
write(intermitfil,emitwconv[text]:12);
if ref1 <> nilref then write(intermitfil,',',ref1:5);
if ref2 <> nilref then write(intermitfil,',',ref2:5);
writeln(intermitfil,';');
end (* HUMAN *)
else
begin
write(intermitfil,ord(text):1);
if ref1 <> nilref then
begin
write(intermitfil,' ',ref1:1);
if ref2 <> nilref then
write(intermitfil,' ',ref2:1);
end;
writeln(intermitfil,' ');
end (* compress *)
end; (* EMITCODE *)
procedure emitname(name: nameptr);
(* USED FOR NAME-NODES *)
var str,str1: stringnode;
ref, ref2, i:integer;
begin
if name <> nil then
with name^ do
begin
str.length := alfalength;
str.alfastr := namestr;
case namekind of
constname:
begin
if constant = nil then ref := 0
else ref := constant^.ident;
emit(ident,ename, str, econst, enone, enone, nilstr, ref, nilref, nilref);
end;
typname, varname, fieldname, varparname, valparname, ffuncname,
tagfldname:
begin
if typ=nil then ref :=0
else ref := typ^.ident;
emit(ident,ename, str, nkindconv[namekind], enone, enone, nilstr, ref, nilref, nilref);
end;
filename:
begin
if filetyp = nil then ref := 0
else ref := filetyp^.ident;
if ext then
begin
if extname = nil then str1.length := 0
else str1 := extname^;
end
else str1:=nilstr;
emit(ident,ename,str,efile,emitfileconv[ext],enone,str1,ref,nilref,nilref);
end;
fprocname,
programname:
emit(ident,ename, str, nkindconv[namekind], enone, enone, nilstr, nilref, nilref,nilref);
procname:
begin
if pparamlist = nil then ref := 0
else ref := pparamlist^.ident;
emit(ident,ename,str,eproc,enone,enone,nilstr,ref,nilref,nilref);
end;
funcname:
begin
if fparamlist = nil then ref := 0
else ref := fparamlist^.ident;
if functyp = nil then ref2 := 0
else ref2 := functyp^.ident;
emit(ident,ename,str,efunc,enone,enone,nilstr,ref,ref2,nilref);
end;
modulename:
emit(ident,ename,str,emodule,pfmodeconv[modulekind],enone,nilstr,nilref,nilref,nilref)
end; (* CASE *)
end; (* WITH *)
end; (* EMITNAME *)
procedure emitlabel(lab:labelptr);
(* USED FOR LABEL-NODES *)
var str:stringnode;
i:integer;
begin
if lab <> nil then
with lab^ do
begin
for i:=1 to labellength do str.str[i]:=labelvalue[i];
str.length:=labellength;
emit(ident,elabel,str,enone,enone,enone,nilstr,nilref,nilref,nilref);
end;
end;
procedure emittype(typ:typptr);
(* USED FOR TYPE-NODES *)
var ref1, ref2, ref3: nodeident;
begin
if typ <> nil then
with typ^ do
begin
case typkind of
subrangetyp:
begin
if subtyp = nil then ref1 := 0
else ref1 := subtyp^.ident;
if firstconst = nil then ref2 := 0
else ref2 := firstconst^.ident;
if lastconst = nil then ref3 := 0
else ref3 := lastconst^.ident;
emit(ident,etype,nilstr,esubrange,enone,enone,nilstr,
ref1, ref2, ref3);
end;
booleantyp,asciityp,
scalartyp:
begin
if scalarlist = nil then ref1 := 0
else ref1 := scalarlist^.ident;
emit(ident,etype,nilstr,tkindconv[typkind],enone,enone,
nilstr,ref1,nilref,nilref);
end;
inttyp, realtyp:
emit(ident,etype,nilstr,tkindconv[typkind],enone,enone,
nilstr,nilref,nilref,nilref);
stringtyp:
emit(ident,etype,nilstr,estring,enone,enone,
nilstr,length,nilref,nilref);
arraytyp:
begin
if indextyp = nil then ref1 := 0
else ref1 := indextyp^.ident;
if valtyp = nil then ref2 := 0
else ref2 := valtyp^.ident;
emit(ident,etype,nilstr,earray,emitpackconv[pack <> false],enone,nilstr,ref1,ref2,nilref);
end;
recordtyp:
begin
if fixlist = nil then ref1 := 0
else ref1 := fixlist^.ident;
if variantlist=nil then ref2 := 0
else ref2 := variantlist^.ident;
emit(ident,etype,nilstr,erecord,emitpackconv[pack],enone,
nilstr,ref1,ref2,nilref);
end;
settyp:
begin
if setoftyp = nil then ref1 := 0
else ref1 := setoftyp^.ident;
emit(ident,etype,nilstr,eset,emitpackconv[pack],enone,nilstr,ref1,nilref,nilref);
end;
filetyp:
begin
if elementtyp = nil then ref1 := 0
else ref1 := elementtyp^.ident;
if fileindextyp = nil then ref2 := nilref
else ref2 := fileindextyp^.ident;
emit(ident,etype,nilstr,efile,emitpackconv[pack],
emitrandconv[randomfile],nilstr,ref1,ref2,nilref);
end;
pointertyp:
begin
if (not declar) or (pointertotyp = nil) then ref1 := 0
else ref1 := pointertotyp^.ident;
emit(ident,etype,nilstr,epointer,enone,enone,nilstr,ref1,nilref,nilref)
end
end; (* CASE *)
end; (* WITH TYPKIND *)
end; (* EMITTYP *)
procedure emitnamelist(list:namelistptr);
(* USED FOR START NAMELIST *)
begin
if list <> nil then
with list^ do
begin
if namelistkind = fixnamelist then
emit(ident,enamelist,nilstr,emitnlistconv[namelistkind],emitpackconv[pack],enone,
nilstr,nilref,nilref,nilref)
else
emit(ident,enamelist,nilstr,emitnlistconv[namelistkind],enone,enone,
nilstr,nilref,nilref,nilref);
end;
end;
procedure emitendnamelist(list:namelistptr);
(* USED FOR END NAMELIST *)
begin
if list <> nil then
emit(nilref,eendnamelist,nilstr,emitnlistconv[list^.namelistkind],enone,enone,
nilstr,list^.ident,nilref,nilref);
end;
procedure emitvarlist(varlist: taglistptr);
(* USED FOR START VARLIST *)
var
ref1, ref2, ref3: nodeident;
begin
if varlist <> nil then
with varlist^ do
begin
if tagfield = nil then ref1 := 0
else ref1 := tagfield^.ident;
if tagtyp = nil then ref2 := 0
else ref2 := tagtyp^.ident;
emit(ident,evarlist,nilstr,enone,enone,enone,nilstr,ref1,ref2,nilref);
end;
end; (* EMITVARLIST *)
procedure emittagelement(tagel: tagnodeptr);
(* USED FOR TAGELEMENT-NODES *)
var
ref1, ref2, ref3: nodeident;
begin
if tagel <> nil then
with tagel^ do
begin
if caselablist = nil then ref1 := 0
else ref1 := caselablist^.ident;
if fixlist = nil then ref2 := 0
else ref2 := fixlist^.ident;
if taglist = nil then ref3 := 0
else ref3 := taglist^.ident;
emit(ident,etagelement,nilstr,enone,enone,enone,nilstr,ref1,ref2,ref3);
end;
end; (* EMITTAGELEMENT *)
procedure emitrecordlabel(caselab: caselabptr);
(* USED FOR RECORDLABEL-NODES *)
var
ref1: nodeident;
begin
if caselab <> nil then
with caselab^ do
begin
if constant = nil then ref1 := 0
else ref1 := constant^.ident;
emit(ident,erecordlabel,nilstr,enone,enone,enone,nilstr,ref1,nilref,nilref);
end;
end; (* EMITRECORDLABEL *)
procedure emitbackref(ident: nodeident; name: nameptr; lokvar: namelistptr);
(* USED FOR BACKREF *)
var
ref1, ref2: nodeident;
begin
if name = nil then ref1 := 0
else ref1 := name^.ident;
if lokvar = nil then ref2 := 0
else ref2 := lokvar^.ident;
emit(ident,ebackref, nilstr, enone, enone, enone, nilstr, ref1, ref2, nilref);
end;
procedure emitforcontrol(word: emitwords; number: integer; name: nameptr);
(* USED FOR FOR-CONTROLSTRUCTURE (FOR, FORINIT, FORTO ETC. *)
var
ref1: nodeident;
begin
if name = nil then ref1 := nilref
else ref1 := name^.ident;
emitcode(word, number, ref1);
end;
procedure emitarith(func: emitwords; typ1, typ2: typptr);
(* USED FOR ARITHMETIC INSTRUCTIONS (REFERENCE, INDEX, LOAD, STORE, SET, SETRANGE,
LEFTCONV, RIGHTCONV, MULT, ADD, DIF ETC. *)
var
ref1, ref2: nodeident;
begin
if typ1 = nil then ref1 := nilref
else ref1 := typ1^.ident;
if typ2 = nil then ref2 := nilref
else ref2 := typ2^.ident;
emitcode(func, ref1, ref2);
end; (* EMITARITH *)
procedure emitrefname(reftype: emitwords; name: nameptr);
(* USED FOR INSTRICTIONS WITH ONE NAME PARAMETER (NAMECODE, FUNCTION,
VALUENAME, FIELDBEGIN, ENDBLOCK) *)
var
ref1: nodeident;
begin
if name = nil then ref1 := 0
else ref1 := name^.ident;
emitcode(reftype, ref1, nilref);
end; (* EMITREFNAME *)
procedure emitrefconst(reftype: emitwords; constant: constptr; ref2:integer);
(* USED FOR INSTRUCTIONS WITH ONE CONSTANT PARAMETER (CONSTCODE, CASELABEL) *)
var
ref1: nodeident;
begin
if constant = nil then ref1 := 0
else ref1 := constant^.ident;
emitcode(reftype, ref1, ref2);
end; (* EMITREFCONST *)
procedure emitfield(name: nameptr; typ: typptr);
(* USED FOR FIELD *)
var
ref1, ref2: nodeident;
begin
if name = nil then ref1 := 0
else ref1 := name^.ident;
if typ = nil then ref2 := 0
else ref2 := typ^.ident;
emitcode(efield, ref1, ref2);
end; (* EMITFIELD *)
procedure emitcall(reftype:emitwords; name:nameptr);
(* used for callfunc,callproc *)
var ref1: nodeident;
begin
levelnumber:=levelnumber+1;
if name=nil then ref1:=0
else ref1:=name^.ident;
emitcode(reftype,levelnumber,ref1);
end;
procedure emitendcall(name: nameptr);
(* USED FOR ENDCALL *)
var
ref1: nodeident;
begin
if name = nil then ref1 := 0
else ref1 := name^.ident;
emitcode(eendcall, levelnumber, ref1);
levelnumber:=levelnumber-1;
end; (* EMITENDCALL *)
procedure emitparam(typ: typptr; formal: nameptr);
(* USED FOR PARAM *)
var
ref1, ref2: nodeident;
begin
if typ = nil then ref1 := 0
else ref1 := typ^.ident;
if formal = nil then ref2 := 0
else ref2 := formal^.ident;
emit(nilref, eparam, nilstr, enone, enone, enone, nilstr, levelnumber, ref1, ref2);
end; (* EMITPARAM *)
procedure emitelementbegin(typ: typptr; count: integer);
(* USED FOR ELEMENTBEGIN *)
var
ref1: nodeident;
begin
if typ = nil then ref1 := 0
else ref1 := typ ^.ident;
emitcode(eelementbegin, ref1, count);
end; (* EMITELEMENTBEGIN *)
procedure emitstorevalue(typ1, typ2: typptr; constant: constptr);
(* USED FOR STOREVALUE *)
var
ref1, ref2, ref3: nodeident;
begin
if typ1 = nil then ref1 := 0
else ref1 := typ1^.ident;
if typ2 = nil then ref2 := 0
else ref2 := typ2^.ident;
if constant = nil then ref3 := 0
else ref3 := constant^.ident;
emit(nilref, estorevalue, nilstr, enone, enone, enone, nilstr, ref1, ref2, ref3);
end; (* EMITSTOREVALUE *)
procedure emitendlist(word: emitwords);
(* USED FOR ENDLIST WITH NO PARAMETER (ENDVARLIST, ENDCASELIST, ENDMODULE) *)
begin
emit(nilref, word, nilstr, enone, enone, enone, nilstr, nilref, nilref, nilref);
end; (* EMITENDLIST *)
procedure emitstorefunc(name: nameptr; typ1, typ2: typptr);
(* USED FOR STOREFUNCTION *)
var
ref1, ref2, ref3: nodeident;
begin
if name = nil then ref1 := 0
else ref1 := name^.ident;
if typ1 = nil then ref2 := 0
else ref2 := typ1^.ident;
if typ2 = nil then ref3 := 0
else ref3 := typ2^.ident;
emit(nilref, estorefunc, nilstr, enone, enone, enone, nilstr, ref1, ref2, ref3);
end; (* EMITSTOREFUNC *)
procedure emitoption(opt: alfa);
(* USED FOR OPTION *)
var
str: stringnode;
begin
str.length := 2;
str.alfastr := opt;
emit(nilref, eoption, str, enone, enone, enone, nilstr, nilref, nilref, nilref);
end; (* EMITOPTION *)
procedure emitmodule(name: alfa);
(* USED FOR MODULE *)
var
str: stringnode;
begin
str.length := alfalength;
str.alfastr := name;
emit(nilref, emodule, str, enone, enone, enone, nilstr, nilref, nilref, nilref);
end; (* EMITMODULE *)
procedure emitload(typ: typptr);
(* USED FOR LOAD. THE EMIT IS BUFFERED AND IF "EMITBUFFERED"
IS RESET BEFORE NEXT CALL OF AN EMITPROCEDURE, THIS
EMIT ISN'T WRITTEN *)
begin
if emitbuffered then emitold;
emitbuffered := true;
loadbuffered := true;
oldtyp := typ;
end;
procedure emitcallfunc(name: nameptr);
(* USED FOR CALLFUNC WITHOUT PARAMETERS.
THE EMIT IS BUFFERED AND IF "EMITBUFFERED" IS RESET
BEFORE NEXT CALL OF A EMITPROCEDURE, THIS
EMIT ISN'T WRITTEN *)
begin
if emitbuffered then emitold;
emitbuffered := true;
loadbuffered := false;
oldname := name;
end; (* EMITCALLFUNC *)
procedure emitold;
(* THE PROCEDURE WRITES THE BUFFERED EMIT *)
begin
emitbuffered := false;
if loadbuffered then
emitarith(eload,oldtyp, nil)
else
begin
emitcall(ecallfunc,oldname);
emitendcall(oldname);
end;
end; (* EMITOLD *)
function insertname(name:alfa; nlist, tree: namelistptr): nameptr;
(*
The procedure inserts a namenode containing NAME in the
list of the namelist NLIST and in the tree of the namelist
TREE. If NLIST = NIL the node is only inserted in the
tree. If the name was in the tree, the result is NIL else
the result is a pointer to the inserted node.
*)
var
help:(notfound,found,stop);
nameelement,element:nameptr;
begin
help:=notfound;
nameelement:=tree^.nametree;
if nameelement=nil then
begin
new(element);
tree^.nametree:=element;
end
else
while help=notfound do
with nameelement^ do
begin
if namestr>name then
begin
if lefttree<>nil then nameelement:=lefttree
else
begin
new(element);
lefttree:=element;
help:=stop;
end;
end
else
if namestr<name then
begin
if righttree<>nil then nameelement:=righttree
else
begin
new(element);
righttree:=element;
help:=stop;
end;
end
else
help:=found;
end;
if help<>found then
with element^ do
begin
identification:=identification+1;
ident:=identification;
lefttree:=nil;
righttree:=nil;
list:=nil;
namestr:=name;
if nlist<>nil then
begin
nameelement:=nlist^.namelist;
if nameelement<>nil then
begin
while nameelement^.list<>nil do nameelement:=nameelement^.list;
nameelement^.list:=element;
end
else
nlist^.namelist:=element;
end;
insertname:=element;
end
else insertname:=nil;
end;
function searchfield(name:alfa; environment:namelistptr):nameptr;
(*
The procedure searches the name in the namelist
ENVIRONMENT. If it wasn't found the result is NIL, else
the result is a pointer to the namenode containing NAME.
*)
var
tree:nameptr;
notfound:boolean;
begin
notfound:=true;
if environment = nil then tree:=nil
else tree:=environment^.nametree;
if tree<>nil then
while notfound do
with tree^ do
begin
if namestr>name then
begin
notfound:=lefttree<>nil;
tree:=lefttree;
end
else
if namestr<name then
begin
notfound:=righttree<>nil;
tree:=righttree;
end
else notfound:=false;
end;
searchfield:=tree;
end;
function searchname(name: alfa; var levelnr: integer) : nameptr;
(*
The procedure searches the name in the levelstack,
starting with LEVELS[LEVELTOP]. If the name wasn't found,
the result is NIL, else the result is a pointer to the
namenode containing NAME, and levelnumber of the node is
returned in LEVELNR.
*)
var
i:integer;
tree:nameptr;
begin
i:=leveltop;
tree:=nil;
while (tree=nil) and (i>=-1) do
begin
tree:=searchfield(name,levels[i].namelist);
i:=i-1;
end;
levelnr:=i+1;
searchname:=tree;
end;
function newconstant(var constant:stringnode; typ:typptr):constptr;
(*The procedure creates a new CONSTNODE with a pointer
to STRINGNODE containing the string in CONSTANT.
The result is a pointer to the new CONSTNODE *)
var
stringelement:stringptr;
constelement:constptr;
ref : nodeident;
i,l : integer;
begin
new(constelement);
with constelement^ do
begin
identification:=identification+1;
ident:=identification;
leftconsttree:=nil;
rightconsttree:=nil;
consttyp:=typ;
l := (constant.length + (charsperword - 1) ) div charsperword;
case l of
0,1:begin
new(stringelement,1);
stringelement^.string3:=constant.string3;
end;
2:begin
new(stringelement,4);
stringelement^.string6:=constant.string6;
end;
3:begin
new(stringelement,7);
stringelement^.string9:=constant.string9;
end;
4:begin
new(stringelement,10);
stringelement^.string12:=constant.string12;
end;
5:new(stringelement,13);
6:new(stringelement,16);
7:new(stringelement,19);
8:new(stringelement,22);
9:new(stringelement,25);
10:new(stringelement,28);
11:new(stringelement,31);
12:new(stringelement,34);
13:new(stringelement,37);
14:new(stringelement,40);
15:new(stringelement,43);
16:new(stringelement,46);
17:new(stringelement,49);
18:new(stringelement,52);
19:new(stringelement,55);
20:new(stringelement,58);
21: new(stringelement,61);
22: new(stringelement,64);
23: new(stringelement,67);
24: new(stringelement,70);
25: new(stringelement,73);
26: new(stringelement,76);
27: new(stringelement,79);
28: new(stringelement,82);
29: new(stringelement,85);
30: new(stringelement,88);
31: new(stringelement,91);
32: new(stringelement,94);
33: new(stringelement,97);
34: new(stringelement,100);
end;
if l>4 then
for i:=1 to l do stringelement^.compare[i]:=constant.compare[i];
stringelement^.length:=constant.length;
constval:=stringelement;
if typ = nil then ref:=0
else ref:=typ^.ident;
emit(ident,econst,nilstr,enone,enone,enone,constval^,ref,nilref,nilref);
end;
newconstant:=constelement;
end;
function searchconst(var constant: stringnode;
typ:typptr): constptr;
(*
The procedure searches the constant CONSTANT in the
constanttree. If it wasn't found, the procedure inserts a
constantnode and calls EMITCONSTANT. The result is a
pointer to the constantnode containing CONSTANT.
*)
var
i,j:integer;
help:(notfound,found,right,left);
element,constelement:constptr;
begin
constelement:=constroot;
i := (constant.length + (charsperword - 1)) div charsperword;
help:=notfound;
for j:=constant.length+1 to i*charsperword do constant.str[j]:=' ';
j:=1;
if constroot=nil then
begin
constelement:=newconstant(constant,typ);
constroot:=constelement;
help:=found;
end
else
while help=notfound do
with constelement^ do
begin
if constval^.compare[j]>constant.compare[j] then
begin
if leftconsttree<>nil then constelement:=leftconsttree
else help:=left;
j:=1;
end
else
if constval^.compare[j]<constant.compare[j] then
begin
if rightconsttree<>nil then constelement:=rightconsttree
else help:=right;
j:=1;
end
else
begin
if j<i then
begin
if constval^.length>j*charsperword then j:=j+1
else
if rightconsttree=nil then help:=right
else
begin
constelement:=rightconsttree;
j:=1;
end;
end
else
begin
if constval^.length=constant.length then help:=found
else
if leftconsttree=nil then help:=left
else
begin
constelement:=leftconsttree;
j:=1;
end;
end;
end;
end;
if help=found then searchconst:=constelement
else
begin
element:=newconstant(constant,typ);
if help=left then constelement^.leftconsttree:=element
else constelement^.rightconsttree:=element;
searchconst:=element;
end;
end;
function newnamelist(kind:nlstkind):namelistptr;
(*create a new NAMELISTHEAD *)
var list:namelistptr;
begin
new(list);
with list^ do
begin
identification:=identification+1;
ident:=identification;
namelistkind:=kind;
pack:=packstructure>0;
nametree:=nil;
namelist:=nil;
labeltree:=nil;
end;
newnamelist:=list;
end;
procedure searchextfile(name:nameptr;typp:typptr);
var extfile:headfilptr;
begin
while name<> nil do
with name^ do
begin
namekind:=filename;
filetyp:=typp;
ext := false;
extfile:=unsatheadfil;
if leveltop = 0 then (* external files must be declared in main *)
while extfile<>nil do
with extfile^ do
begin
if namestr=filename then
begin
ext:=true;
extname:=externname;
end;
extfile:=nextheadfil;
end;
emitname(name);
name:=list;
end
end;
procedure makestring(val:integer; var str:stringnode);
(* convert the integer VALUE to a string in the parameter
STR *)
var i:integer;
begin
with str do
begin
i:=1;
length:=0;
while i*10<=val do i:=i*10;
while i>0 do
begin
length:=length+1;
str[length]:=chr((val div i) +ord('0'));
val:=val mod i;
i:=i div 10;
end
end;
end;
function makeinteger(cons:constptr):integer;
(* Convert the integer string pointed to by cons
to an integer. If CONS=NIL the result is 0 *)
var i,start,val,base:integer;
begin
if cons=nil then makeinteger:=0
else
with cons^ do
if constval=nil then makeinteger:=0
else
with constval^ do
begin
base:=10;
if str[1] in ['+','-'] then start:=2
else start:=1;
val:=0;
if str[2]='#' then
begin
start:=4;
case str[3] of
'B':base:=2;
'O':base:=8;
'H':base:=16
end;
end;
for i:=start to length do
begin
val:=val*base+ord(str[i]);
if str[i] in ['0'..'9'] then val:=val-ord('0')
else val:=val-ord('A');
end;
if str[1]='-' then val:=-val;
makeinteger:=val;
end;
end;
procedure newblocklevel;
begin
if leveltop<maxlevel then leveltop:=leveltop+1
else stop(7);
with levels[leveltop] do
begin
namelist:=globalfieldlist;
leveltype:=blocklevel;
end;
end;
procedure writetree(name:nameptr);
var i:integer;
marks : packed array[1..150] of char;
procedure writeleft(name:nameptr;blanks:integer);forward;
procedure writeright(name:nameptr;blanks:integer);
begin
if name=nil then marks[blanks-4]:='|'
else
with name^ do
begin
writeright(righttree,blanks+5);
writeln(output,marks:blanks-5,'/....',namestr);
marks[blanks-4]:='|';
writeleft(lefttree,blanks+5);
end;
end;
procedure writeleft;
begin
if name=nil then marks[blanks-4]:=' '
else
with name^ do
begin
writeright(righttree,blanks+5);
writeln(output,marks:blanks-5,'\....',namestr);
marks[blanks-4]:=' ';
writeleft(lefttree,blanks+5);
end;
end;
begin
writeln(output);
with name^ do
begin
for i:=1 to 150 do marks[i]:=' ';
writeright(righttree,5);
writeln(output,namestr);
writeleft(lefttree,5);
end;
writeln(output);
end;
procedure readcall;
(* read the call of the compiler from current input *)
const
power12=4096;
equality=6;
point=8;
list = 'list ';
yes = 'yes ';
no = 'no ';
heap = 'heap ';
code = 'codesize ';
survey= 'survey ';
var
paramno, i,j, int, separator, length : integer;
a, codefilename, sourcefilename : alfa;
first : boolean;
param : (list_program,heapsize,codesize,surveyinfo);
procedure error;
begin
writeln(' ??? Error in call of PASCAL compiler');
markerror(0);
goto 10;
end;
procedure emitdirective(directive:char; size:integer; name:alfa);
var
localstr : stringnode;
begin
with localstr do
begin
if size >= 0 then makestring(size,localstr)
else
begin
alfastr:=name;
length:=alfalength;
end;
for j := (length + charsperword - 1) div charsperword downto 1 do
compare[j+1] := compare[j];
string3:=' ';
length := length + 3;
str[1]:=directive;
emit(nilref,eoption,localstr,enone,enone,enone,nilstr,nilref,nilref,nilref);
end;
end;
begin
open(intermitfil,'pascalpif');
rewrite(intermitfil);
j:=system(1,int,sourcefilename);
separator:=j div power12;
if separator = equality then
begin (* skip name PASCAL *)
i:=system(0,int,codefilename);
length:=i mod power12;
if length <> 10 then error;
paramno:=2;
end
else
begin
codefilename:=' ';
paramno:=1;
end;
(* file to hold code *)
emitdirective('f',-1,codefilename);
(*sourcefile name *)
i:=system(paramno,int,sourcefilename);
j:=system(paramno+1,int,a);
if (i=4*power12 + 10) and ((j div power12) <> point) then
begin
paramno:=paramno+1;
open(input,sourcefilename);
reset(input);
inputfile:=true;
end;
j:=system(paramno,int,a);
first:=true;
while ((j mod power12) <> 0) and ((j div power12) <> 2) do
begin
separator:=j div power12;
length:=j mod power12;
if first then
begin
first:=false;
if separator = point then error
else
if a = list then param:=list_program
else if a = heap then param:=heapsize
else if a = code then param:=codesize
else if a = survey then param := surveyinfo
else error;
end
else
begin
first:=true;
if separator <> point then error
else
case param of
list_program:if length <> 10 then error
else
if a = yes then programlist:=true
else if a = no then programlist:=false
else error;
heapsize:if length <> 4 then error
else emitdirective('h',int,a);
codesize:if length <> 4 then error
else emitdirective('s',int,a);
surveyinfo: if length <> 10 then error
else if a = yes then emitdirective('p',-1,a)
else if a <> no then error;
end;
end;
paramno:=paramno+1;
j:=system(paramno,int,a);
end;
(* open(tables,'pascaltable');
reset(tables); *)
end;
function newhash:hashptr;
(*get a new hash node *)
var i:integer;
h:hashptr;
begin
new(h);
with h^ do
begin
for i:=0 to hashmax do elements[i].ident:=nilref;
next:=nil;
end;
newhash:=h;
end;
procedure inserthash(hash:hashelement);
(*insert HASH in the hashing list *)
var h:hashptr;
notfound:boolean;
index:hashindex;
begin
index:=hash.ident mod (hashmax+1);
h:=globalhash;
notfound:=true;
while notfound do
with h^ do
begin
notfound:=elements[index].ident <> nilref;
if notfound then
begin
if next=nil then next:=newhash;
h:=next;
end
else elements[index]:=hash;
end;
end;
procedure findhash(id:nodeident;var hash:hashelement);
(*find the node with identification ID. If it is not found
HASH.IDENT <> ID *)
var notfound:boolean;
h:hashptr;
index:hashindex;
begin
index:=id mod (hashmax+1);
h:=globalhash;
notfound:=true;
while notfound do
with h^,elements[index] do
begin
notfound:=(ident <> id) and (next <> nil);
if notfound then h:=next;
end;
hash:=h^.elements[index];
end;
procedure readenvironment(thismodule:alfa);
(*read an environment, if thismodule is found as a module-name
then we have found the environment for this module *)
type
allptr=record
case integer of
1:(tag:tagnodeptr);
2:(taglist:taglistptr);
3:(labellist:caselabptr);
4:(namlist:namelistptr)
end;
var ptr:allptr;
stopreading:boolean;
readmodule:nameptr;
lastblocklevel:integer;
globalmode : pfmodes;
code : emitwords;
envconv : array[0..132] of emitwords;
procedure readlist(var pointer:allptr);
var id,constnumber,fixnumber,tagnumber,typenumber:nodeident;
i:integer;
hash:hashelement;
ptr:allptr;
found:boolean;
caselablist:caselistptr;
tag:tagnodeptr;
taglist:taglistptr;
caselab:caselabptr;
lab:labelptr;
ch:char;
typkind:tkind;
procedure readstring(var string:stringnode);
var ch:char;
begin
get(environment);(*drop ' ' before name*)
with string do
begin
length:=0;
repeat
length:=length+1;
read(environment,ch);
if not eoln(environment) then str[length]:=ch;
until eoln(environment);
length:=length-1;
end;
end;
procedure readname;
var name:nameptr;
id,constnumber,typenumber,idlist:nodeident;
i:integer;
hash:hashelement;
namestr:alfa;
ptr:allptr;
begin
read(environment,id);
get(environment);(*drop ' ' before name *)
namestr:=' ';
i:=1;
repeat
read(environment,ch);
namestr[i]:=ch;
i:=i+1;
until environment^=' ';
identification:=id-1;
name:=insertname(namestr,globalfieldlist,levels[leveltop].namelist);
with name^ do
begin
read(environment,i);
namekind:=envtoname[i];
case namekind of
constname:begin
read(environment,constnumber);
findhash(constnumber,hash);
constant:=hash.constant;
end;
typname,varname,fieldname,varparname,valparname,
ffuncname:begin
read(environment,typenumber);
if typenumber=0 then typ:=nil
else
begin
findhash(typenumber,hash);
typ:=hash.typ;
end;
end;
tagfldname:begin
read(environment,typenumber);
findhash(typenumber,hash);
typ:=hash.typ;
hash.ident:=id;
hash.nam:=name;
inserthash(hash);
end;
filename:begin
read(environment,i);
ext:=eext=envconv[i];
if ext then
begin (* find external filename*)
new(extname);
readstring(extname^);
end
else extname:=nil;
read(environment,typenumber);
findhash(typenumber,hash);
filetyp:=hash.typ;
end;
programname:globalmode:=internal;
fprocname:;
procname:begin
pmodulename:=readmodule;
pmode:=globalmode;
read(environment,idlist);
if idlist=0 then pparamlist:=nil (*standardprocedure*)
else
begin
findhash(idlist,hash);
pparamlist:=hash.namlist;
end;
end;
funcname:begin
fmodulename:=readmodule;
fmode:=globalmode;
assignable:=false;
read(environment,idlist,typenumber);
findhash(idlist,hash);
fparamlist:=hash.namlist;
if typenumber=0 then functyp:=nil
else
begin
findhash(typenumber,hash);
functyp:=hash.typ;
end;
end;
modulename:begin
read(environment,i);
modulekind:=envtomodes[i];
readmodule:=name;
globalmode:=modulekind;
if namestr=thismodule then lastblocklevel:=leveltop;
(*we have found the desired module, i.e. stop after reading this block *)
end
end;
emitname(name);
end;
end; (* readname *)
procedure readtype;
var id,typenumber,elementnumber,const1,const2,fixnumber,varnumber:nodeident;
ptr:allptr;
hash:hashelement;
typp,typ1:typptr;
i,rand:integer;
newnode:boolean;
begin
read(environment,id,i);
newnode:=true;
if envtotype[i]=pointertyp then
begin
findhash(id,hash);
if id=hash.ident then
begin
newnode:=false;
typp:=hash.typ;
end;
end;
if newnode then
begin
new(typp);
hash.ident:=id;
hash.typ:=typp;
inserthash(hash);
end;
with typp^ do
begin
ident:=id;
typkind:=envtotype[i];
case typkind of
subrangetyp:begin
read(environment,typenumber,const1,const2);
findhash(typenumber,hash);
subtyp:=hash.typ;
findhash(const1,hash);
firstconst:=hash.constant;
findhash(const2,hash);
lastconst:=hash.constant;
end;
booleantyp,asciityp,
scalartyp:begin
read(environment,id);
if typkind=booleantyp then booltype:=typp
else
if typkind=asciityp then asciitype:=typp;
end;
inttyp:integertype:=typp;
realtyp:realtype:=typp;
arraytyp:begin
read(environment,i,typenumber,elementnumber);
pack:=envconv[i]=epacked;
findhash(typenumber,hash);
indextyp:=hash.typ;
findhash(elementnumber,hash);
valtyp:=hash.typ;
end;
stringtyp:begin
read(environment,i);
length:=i;
next:=stringtypes;
stringtypes:=typp;
end;
recordtyp:begin
read(environment,i,fixnumber,varnumber);
pack:= envconv[i]=epacked;
if fixnumber=0 then fixlist:=nil
else
begin
findhash(fixnumber,hash);
fixlist:=hash.namlist;
end;
if varnumber=0 then variantlist:=nil
else
begin
findhash(varnumber,hash);
variantlist:=hash.taglist;
end;
end;
settyp:begin
read(environment,i,typenumber);
pack:= envconv[i]=epacked;
findhash(typenumber,hash);
setoftyp:=hash.typ;
end;
filetyp:begin
read(environment,i,rand,typenumber);
pack:= envconv[i]=epacked;
randomfile:= envconv[rand]=erandom;
findhash(typenumber,hash);
if randomfile then
begin
fileindextyp:=hash.typ;
read(environment,typenumber);
findhash(typenumber,hash);
elementtyp:=hash.typ;
end
else
begin
fileindextyp:=nil;
elementtyp:=hash.typ;
end;
end;
pointertyp:begin
read(environment,typenumber);
findhash(typenumber,hash);
if typenumber=hash.ident then
begin (* the pointertype has been defined *)
declar:=true;
pointertotyp:= hash.typ;
end
else
begin
pointertotyp:=nil;
end;
end
end;
if not (typkind in [scalartyp,booleantyp,asciityp]) then emittype(typp);
end;
end; (* readtype *)
procedure readnamelist;
var id:nodeident;
namlist:namelistptr;
hash:hashelement;
ptr:allptr;
i:integer;
begin
read(environment,id,i);
namlist:=globalfieldlist;
new(globalfieldlist);
hash.ident:=id;
hash.namlist:=globalfieldlist;
inserthash(hash);
with globalfieldlist^ do
begin
ident:=id;
nametree:=nil;
namelist:=nil;
labeltree:=nil;
case envconv[i] of
escalarlist:begin
namelistkind:=scalarnamelist;
findhash(id-1,hash);(*find the type of this scalarlist*)
with hash do
begin
typ^.scalarlist:=globalfieldlist;
emittype(typ);
end;
end;
efix:begin
namelistkind:=fixnamelist;
end;
eparam:begin
namelistkind:=paramnamelist;
newblocklevel;
end;
edeclaration:begin
namelistkind:=declarationlist;
newblocklevel;
end
end;
end;
emitnamelist(globalfieldlist);
readlist(ptr);
globalfieldlist:=namlist;
end;
begin (* readlist *)
found:=false;
repeat
read(environment,i);
case envconv[i] of
ename:readname;
econst:begin
read(environment,id,typenumber);
readstring(conststring);
identification:=id-1;(*automatically incremented later *)
findhash(typenumber,hash);
with hash do
begin
typkind:=typ^.typkind;
if typkind in [inttyp,realtyp] then
begin
constant:=searchconst(conststring,typ);
end
else
begin
constant:=newconstant(conststring,typ);
if typkind in [booleantyp,asciityp,scalartyp] then
constant^.consttyp^.noofscalars:=makeinteger(constant);
if typkind=asciityp then
begin
ch:=chr(makeinteger(constant));
if (ch>=minch) and (ch<=maxch) then characters[ch]:=constant;
end
else
if conststring.str[1]='N' then nilconst:=constant;(*the constant NIL *)
end;
ident:=id;
end;
inserthash(hash);
end;
elabel:with levels[leveltop].namelist^ do
begin
read(environment,id);
lab:=labeltree;
new(labeltree);
with labeltree^ do
begin
ident:=id;
defined:=true;
labellist:=lab;
get(environment); (*drop ' ' before labelstring *)
for i:=1 to labellength do
begin
read(environment,ch);
labelvalue[i]:=ch;
end;
end;
emitlabel(labeltree);
end;
etype:readtype;
enamelist:readnamelist;
evarlist:begin
read(environment,id,tagnumber,typenumber);
new(taglist);
hash.ident:=id;
hash.taglist:=taglist;
inserthash(hash);
with taglist^ do
begin
ident:=id;
if tagnumber=0 then tagfield:=nil
else
begin
findhash(tagnumber,hash);
tagfield:=hash.nam;
end;
findhash(typenumber,hash);
tagtyp:=hash.typ;
emitvarlist(taglist);
readlist(ptr);
varlist:=ptr.tag;
end;
end;
ecaselist:begin
read(environment,id);
new(caselablist);
hash.ident:=id;
hash.caselablist:=caselablist;
inserthash(hash);
with caselablist^ do
begin
ident:=id;
emit(id,ecaselist,nilstr,enone,enone,enone,nilstr,nilref,nilref,nilref);
readlist(ptr);
labellist:=ptr.labellist;
end;
end;
etagelement:begin
read(environment,id,constnumber,fixnumber,tagnumber);
new(tag);
with tag^ do
begin
ident:=id;
findhash(constnumber,hash);
caselablist:=hash.caselablist;
if fixnumber=0 then fixlist:=nil
else
begin
findhash(fixnumber,hash);
fixlist:=hash.namlist;
end;
if tagnumber=0 then taglist:=nil
else
begin
findhash(tagnumber,hash);
taglist:=hash.taglist;
end;
emittagelement(tag);
readlist(ptr);
list:=ptr.tag;
end;
pointer.tag:=tag;
found:=true;
end;
erecordlabel:begin
read(environment,id,constnumber);
new(caselab);
with caselab^ do
begin
ident:=id;
findhash(constnumber,hash);
constant:=hash.constant;
emitrecordlabel(caselab);
readlist(ptr);
list:=ptr.labellist;
end;
pointer.labellist:=caselab;
found:=true;
end;
eendmodule:begin
with readmodule^ do
begin
procfunclist:=list;
list:=nil;
end;
readmodule:=nil;
globalmode:=internal;
emitendlist(eendmodule);
end;
eendvarlist:begin
pointer.tag:=nil;
found:=true;
emitendlist(evarlist);
end;
eendnamelist:with globalfieldlist^ do
begin
readln(environment);
if namelistkind <> declarationlist then emitendnamelist(globalfieldlist);
found:=true;
if namelistkind=paramnamelist then leveltop:=leveltop-1
else
if namelistkind=declarationlist then
if lastblocklevel=leveltop then stopreading:=true
else
begin
emitendnamelist(globalfieldlist);
leveltop:=leveltop-1;
end;
end;
eendcaselist:begin
emitendlist(eendcaselist);
pointer.labellist:=nil;
found:=true;
end;
end
otherwise readln(environment)
until found or stopreading;
end; (* readlist *)
begin (* readenvironment *)
stopreading:=false;
globalmode:=systemmode;
for code:=enone to eoption do envconv[ord(code)]:=code;
lastblocklevel:=leveltop+1;
if thismodule=blank then open(environment,'pascalenv')
else open(environment,thismodule);
reset(environment);
readlist(ptr);
close(environment);
levels[-1].leveltype:=standardlevel;
identification := identification + 2; (* not enough in the general case *)
end; (* readenvironment *)
procedure initialize;
var
ch:char;
dato, tim:alfa;
begin
date(dato);
time(tim);
writeln(dato,tim:15,version:50);
writeln;
for ch:=minch to maxch do characters[ch]:=nil;
globalhash:=newhash;
end;
(* BOBS PROCEDURE CODE*)
(*$R+*)
procedure code(oldtop,newtop: stackinx; prod: integer);
(*$R-*)
(* BOBS LOCAL PROCEDURES*)
procedure getstring(sy,start: integer; var str:string; var length: integer);
var i,j,t:integer;
begin
if sy>=0 then t:=newtop+(sy-1)
else t:=oldtop+(sy-1);
length:=attstack[t].chbufp-attstack[t-1].chbufp+start-1;
if length>stringmax-start+1 then stop(5);
j:=start;
for i:=attstack[t-1].chbufp to attstack[t].chbufp-1 do
begin
str[j]:=chbuf[i]; j:=j+1
end
end; (*GETSTRING*)
procedure outtest;
(*OUTTEST PRODUCES A SEQUENCE OF SNAPHOTS OF THE PARSE
(*OUTTEST MAY BE REMOVED BY THE USER *)
(*DURING THE PARSE, SNAPSHOTS ARE WRITTEN ON FILE OUTPUT *)
(*PROGRAM LINES WHICH WRITES SNAPSHOTS CONTAINS THE COMMENT:*)
(***SNAPSHOT***)
var s: string;
i,j,l:integer; ch:char;
begin
writeln(output);
write(output,' PRODUCTION:',prod:3);
for i:=1 to oldtop-newtop+1 do
begin getstring(i,1,s,l);
if l>0 then
begin writeln(output);
write(output,' SYMB',i:1,' ');
for j:=1 to l do write(output,s[j])
end
end
end; (*OUTTEST*)
procedure getname(no:integer;var name:alfa);
(* Return the first alfalength characters of the NAME
connected with the no'th node on a lefthand side of a
production. If there are less than alfalength chars in
a NAME it is followed by trailing blanks *)
var i,j,length:integer;
nam:alfa;
begin
nam:=blank;
i:=attstack[newtop+no-2].chbufp;
length:=attstack[newtop+no-1].chbufp-i;
if length>alfalength then length:=alfalength;
i:=i-1;
for j:=1 to length do nam[j]:=chbuf[i+j];
name:=nam;
end;
function searchstringtype(llength:integer):typptr;
(*search in the list of stringtypes and return
a pointer to a type STRINGTYP with length llength
possibly after insertion of a new stringtype *)
var typ:typptr;
begin
if stringtypes=nil then
begin
new(stringtypes);
with stringtypes^ do
begin
identification:=identification+1;
ident:=identification;
length:=llength;
typkind:=stringtyp;
next:=nil;
searchstringtype:=stringtypes;
emittype(stringtypes);
end
end
else
begin
typ:=stringtypes;
while (typ^.length<>llength) and (typ^.next<>nil) do
typ:=typ^.next;
if typ^.length= llength then searchstringlength:=typ
else
begin
new(typ);
with typ^ do
begin
identification:=identification+1;
ident:=identification;
length:=llength;
typkind:=stringtyp;
next:=stringtypes;
stringtypes:=typ;
end;
emittype(typ);
searchstringtype:=typ;
end;
end;
end;
procedure addtypetolist(kind:nkind);
(* Add the type in ATTSTACK[OLDTOP].TYPP to the
names in a list starting with ATTSTACK[NEWTOP].NAM,
and write the names out in the intermidiate code*)
var name:nameptr;
begin
name:=attstack[newtop].nam;
with attstack[oldtop] do
begin
while name<> nil do
with name^ do
begin
namekind:=kind;
if kind=filename then
begin
filetyp:=typp;
ext:=false;
end
else
typ:=typp;
if (kind = varname) or (kind = fieldname) or (kind = tagfldname) then
initialized := false;
emitname(name);
name:=list;
end;
end;
end;
procedure addnametolist(no:integer;list:namelistptr);
(* Get the name pointed to by ATTSTACK[NO] and add it to
the nametree and the namelist LIST*)
var name:nameptr;
namestring:alfa;
begin
getname(no,namestring);
name:=insertname(namestring,list,levels[leveltop].namelist);
if name=nil then markerror(102);
with attstack[newtop] do
if nam=nil then nam:=name;
end;
procedure newstring;
(* Get a string from the top of the attribute stack
and insert the constant in the top of the attribute stack,
if it is a string of length 1 it is loked up in a special table *)
var ch:char;
begin
with conststring,attstack[newtop] do
begin
getstring(1,1,str,length);
if length=1 then
begin
ch:=str[1];
if characters[ch]=nil then
begin (*create a new constant *)
makestring(ord(ch),conststring);
constant:=newconstant(conststring,asciitype);
characters[ch]:=constant;
end
else constant:=characters[ch];
end
else
constant:=
newconstant(conststring,searchstringtype(length));
end;
end;
function getbasetype(typ:typptr):typptr;
(* Find the base type of a subrange type *)
begin
if typ<>nil then
with typ^ do
if typkind=subrangetyp then typ:=subtyp;
if typ <> nil then
if typ^.typkind=stringtyp then
if typ^.length=1 then typ:=asciitype;
getbasetype:=typ;
end;
function getstringlength(typ:typptr;errorno:integer):integer;
(* Find the length of a string of type TYP. If TYP is not a
string mark it as an error *)
var i:integer;
typ1:typptr;
begin
typ1:=getbasetype(typ);
if typ1=asciitype then getstringlength:=1
else
with typ^ do
begin
getstringlength:=0;
if (typkind=arraytyp) and pack then
begin
typ1:=getbasetype(valtyp);
if typ1<>nil then
if typ1^.typkind<>asciityp then markerror(errorno)
else
if indextyp<>nil then
with indextyp^ do
begin
if makeinteger(firstconst)<>1 then markerror(errorno)
else
begin
i:=makeinteger(lastconst);
if i<0 then markerror(errorno)
else getstringlength:=i;
end;
end;
end
else
if typkind=stringtyp then getstringlength:=length
else markerror(errorno);
end;
end;
procedure checkparam(name:nameptr);
(* Check that the parameters does agree with the forward
declaration *)
var error:boolean;
paramname:nameptr;
begin
error:=false;
levels[leveltop].namelist^.nametree:=name; (*USE THE PARAMETERLIST
FROM FORWARD DECLARATION *)
paramname:=globalfieldlist^.namelist;
if paramname<>nil then
begin (*there are some parameters*)
while paramname<>nil do
with paramname^ do
begin
if name=nil then error:=true
else
begin
if namestr<>name^.namestr then error:=true
else
if namekind<>name^.namekind then error:=true
else
if namekind in [varparname,valparname,ffuncname] then
if typ<>name^.typ then error:=true;
name:=name^.list;
end;
paramname:=list;
end;
if error or (name<>nil) then markerror(140);
end;
end;
function findvariant(variantlist:taglistptr;cons:constptr):tagnodeptr;
(*find the variant which corresponds to the label in cons *)
var case1:caselabptr;
tag1:tagnodeptr;
notfound:boolean;
begin
tag1:=nil;
with variantlist^ do
begin
if getbasetype(tagtyp) <> getbasetype(cons^.consttyp) then markerror(135)
else
begin (*find the variant*)
tag1:=varlist;
notfound:=true;
while notfound and (tag1 <> nil) do
with tag1^ do
begin
if caselablist=nil then case1:=nil
else case1:=caselablist^.labellist;
while notfound and (case1 <> nil) do
begin
notfound:=case1^.constant <> cons;
if notfound then case1:=case1^.list;
end;
if notfound then tag1:=tag1^.list;
end;
end;
end;
findvariant:=tag1;
end;
procedure checkname(name:nameptr);
begin
if name <> nil then
with name^ do
if namekind in [funcname,fprocname,procname] then
begin
if namekind=funcname then
begin
if fparamlist^.namelist <> nil then markerror(131);
end
else markerror(157);
end;
end;
procedure errorprod;
(* Errorpoductions in then parser*)
begin
with attstack[newtop] do
begin
constant:=nil;
case prod of
101:begin
list:=nil;
nam:=nil;
typp:=nil;
end;
102:begin
taglist:=nil;
oldcasetag:=nil;
end;
103:begin
fixxlist:=nil;
variant:=nil;
caselabels:=nil;
end;
104:begin
varnam:=nil;
vartypp:=nil;
end;
105:begin
valnam:=nil;
valtypp:=nil;
valtag:=nil;
count:=1;
end;
106:if leveltop<-1 then
begin
readenvironment(blank);
vardeclaration:=false;
leveltop:=leveltop+1;
with levels[leveltop] do
begin
leveltype:=programlevel;
namelist:=nil;
end;
end
end;
end;
end;
procedure standardparam(firstparam:boolean);
(*check parameter of standard procedure or function*)
var name:nameptr;
typ1:typptr;
i:integer;
procfuncname:alfa;
begin
name:=attstack[newtop-2].varnam;(*GET PROCEDURE OR FUNCTION *)
attstack[newtop-1].moreparameters:=false;
if name <> nil then
with attstack[oldtop] do
if vartypp <> nil then
begin
procfuncname:=name^.namestr;
if (name^.namekind=procname) and (name^.pmode=systemmode) then
with vartypp^ do
begin (*STANDARD PROCEDURE CALLED*)
if (procfuncname='WRITE ') or (procfuncname='WRITELN ') then
begin
writeformat:=0;(*no formatting yet*)
if firstparam then attstack[newtop-1].paramtypp:=asciitype;(*default output file type*)
if typkind=filetyp then
begin
if (not randomfile) and firstparam then
with attstack[newtop-1] do
begin (*remember file type to check parameters*)
paramtypp:=getbasetype(elementtyp);
moreparameters:=procfuncname <> 'WRITELN ';(*there must be more parameters*)
emitbuffered:=false;
if (attstack[newtop-1].paramtypp <> asciitype) and
(procfuncname = 'WRITELN ') then markerror(163);
end
else markerror(132);
end
else
if attstack[newtop-1].paramtypp=asciitype then
begin
if not (typkind in [subrangetyp,booleantyp,asciityp,scalartyp,
inttyp,realtyp,stringtyp]) then i:=getstringlength(valtypp,130);
end
else
if attstack[newtop-1].paramtypp <> getbasetype(vartypp) then markerror(130);
end
else
if (procfuncname='READ ') or (procfuncname='READLN ') then
begin
if firstparam then
begin
attstack[newtop-1].paramtypp:=asciitype;
if typkind <> filetyp then
begin
name:=searchname('INPUT ',i);
if name=nil then markerror(161)
else
with name^ do
if namekind <> filename then markerror(162)
else
with filetyp^ do
begin
if randomfile then markerror(162)
else attstack[newtop-1].paramtypp:=elementtyp;
end;
end;
end;
if emitbuffered and (constant=nil) then
begin (*the parameter is a variable (not a constant) *)
emitbuffered:=false;(*AVOID A LOAD INSTRUCTION*)
end
else markerror(133);
if typkind=filetyp then
begin
if (not randomfile) and firstparam then
with attstack[newtop-1] do
begin
paramtypp:=getbasetype(elementtyp);
moreparameters:=procfuncname <> 'READLN ';
emitbuffered:=false;
if (attstack[newtop-1].paramtypp <> asciitype) and
(procfuncname = 'READLN ') then markerror(163);
end
else markerror(132);
end
else
if attstack[newtop-1].paramtypp=asciitype then
begin
if not ((typkind in [subrangetyp,booleantyp,asciityp,scalartyp,
inttyp,realtyp]) or (getbasetype(vartypp)=asciitype)) then
markerror(132)
end
else
if attstack[newtop-1].paramtypp <> getbasetype(vartypp) then markerror(132);
end
else
if (procfuncname='PACK ') or (procfuncname='UNPACK ') then
begin
if firstparam then
begin
with attstack[newtop-1] do
begin
secondparameter:=true;
moreparameters:=true;
end;
if (typkind <> arraytyp) or (pack=(procfuncname='PACK ')) then
begin
markerror(132);
attstack[newtop-1].paramtypp:=nil;
end
else attstack[newtop-1].paramtypp:=vartypp;
end
else
begin
typ1:=attstack[newtop-1].paramtypp;
if typ1=nil then markerror(132)
else
if attstack[newtop-1].secondparameter=(procfuncname='PACK ') then
begin
if getbasetype(typ1^.indextyp) <> getbasetype(vartypp) then markerror(130);
with attstack[newtop-1] do
begin
moreparameters:=secondparameter;
secondparameter:=false;
end;
end
else
begin
if typkind <> arraytyp then markerror(132)
else
if (getbasetype(indextyp) <> getbasetype(typ1^.indextyp))
or (valtyp <> typ1^.valtyp) or
(pack <> (procfuncname='PACK ')) then markerror(132);
with attstack[newtop - 1] do
begin
moreparameters:=secondparameter;
secondparameter:=false;
end;
end;
end;
end
else
if (procfuncname='PUT ') or (procfuncname='GET ')
or (procfuncname='RESET ') or (procfuncname='REWRITE ') then
begin
if (typkind <> filetyp) or randomfile
or (not firstparam) then markerror(132);
emitbuffered:=false;
end
else
if procfuncname='PAGE ' then
begin
emitbuffered:=false;
with vartypp^ do
if firstparam and (typkind = filetyp) and (not randomfile) then
begin
if getbasetype(elementtyp) <> asciitype then markerror(132);
end
else markerror(132);
end
else
if (procfuncname='NEW ') or (procfuncname='DISPOSE ') then
begin
if firstparam then
with attstack[newtop-1] do
begin
emitbuffered:=false;(*avoid a load instruction*)
if typkind <> pointertyp then markerror(132);
end
end
else
if (procfuncname='PUTRAND ') or (procfuncname='GETRAND ') then
begin
if firstparam then
with attstack[newtop-1] do
begin
paramtypp:=nil;
if (typkind=filetyp) and randomfile then
begin
paramtypp:=elementtyp;
moreparameters:=true;(*one more parameter*)
emitbuffered:=false;
end
else markerror(132);
end
else
begin
if attstack[newtop-1].paramtypp=nil then markerror(131)
else
if getbasetype(attstack[newtop-1].paramtypp^.fileindextyp)
<> getbasetype(vartypp) then markerror(120);
attstack[newtop-1].paramtypp:=nil;
end;
end
else
if procfuncname='OPEN ' then
begin
if firstparam then
begin
if typkind <> filetyp then markerror(132)
else if not varnam^.ext then warning(165);
with attstack[newtop-1] do
begin
moreparameters:=true;(*one more parameter*)
paramtypp:=asciitype;
end;
emitbuffered:=false;
end
else
begin
if attstack[newtop-1].paramtypp=nil then markerror(131)
else
i:=getstringlength(vartypp,132);(*second parameter must be a string*)
attstack[newtop-1].paramtypp:=nil;
end;
end
else
if procfuncname='CLOSE ' then
begin
emitbuffered:=false;
if firstparam then
begin
if typkind <> filetyp then markerror(132)
else if not varnam^.ext then warning(165);
end
else markerror(131);
end;
end
else
if (name^.namekind=funcname) and (name^.fmode=systemmode) and
(firstparam or (procfuncname = 'MONITOR ')) then
begin(*standard function called*)
if (procfuncname='ABS ') or (procfuncname='SQR ') then
begin
if getbasetype(vartypp)=integertype then
attstack[newtop-2].vartypp:=integertype
else
if vartypp=realtype then
attstack[newtop-2].vartypp:=realtype
else markerror(132);
end
else
with vartypp^ do
if procfuncname='EOF ' then
begin
if (typkind <> filetyp) or randomfile then markerror(132);
end
else
if procfuncname='ORD ' then
begin
if not ((typkind in indexkinds) or (typkind = pointertyp)) then
markerror(132);
end
else
if procfuncname = 'MONITOR ' then
begin (* only legal on RC8000 *)
if typkind = arraytyp then
begin
if (getbasetype(valtyp) <> integertype) or
(indextyp^.typkind <> subrangetyp) or
(getbasetype(indextyp) <> integertype) then markerror(130)
else
if (makeinteger(indextyp^.firstconst) <> 1) or
(makeinteger(indextyp^.lastconst) <> 10) then markerror(130);
end
else markerror(130);
end
else
begin(* SUCC or PRED *)
if typkind in indexkinds then
attstack[newtop-2].vartypp:=vartypp
else markerror(132);
end;
end
else markerror(131);
end;
end; (* standardparam *)
procedure chapter4;
(* Identifiers, Numbers and Strings *)
var i:integer;
ok:boolean;
digitch:set of char;
begin
case prod of
401:(* <unsigned integer> ::= KONST *)
begin
with conststring do
getstring(1,2,str,length);
attstack[newtop].typp:=integertype;
end;
402:(* <unsigned integer> ::= # NAME *)
with conststring do
begin
getstring(2,3,str,length);
str[2]:='#';
ok:=true;
if length<4 then ok:=false
else
if str[3]='B' then digitch:=['0','1']
else
if str[3]='O' then digitch:=['0'..'7']
else
if str[3]='H' then digitch:=['0'..'9','A'..'F']
else ok:=false;
for i:=4 to length do
ok:=(str[i] in digitch) and ok;
if not ok then
begin
length:=2;
str[2]:='1';
markerror(103);
end;
attstack[newtop].typp:=integertype;
end;
403:(* <unsigned number> ::= REALKONST *)
begin
with conststring do
getstring(1,2,str,length);
attstack[newtop].typp:=realtype;
end
end;
end;
procedure chapter5;
(* Constant definitions *)
var name:nameptr;
i,level:integer;
namestring:alfa;
begin
case prod of
501:(* <constant> ::= <unsigned number> *)
(* | + <unsigned number> *)
begin
conststring.str[1]:='+';
attstack[newtop].constant:=searchconst(conststring,attstack[oldtop].typp);
end;
502:(* <constant> ::= - <unsigned number> *)
begin
conststring.str[1]:='-';
attstack[newtop].constant:=searchconst(conststring,attstack[oldtop].typp);
end;
503,(* <constant> ::= NAME *)
504, (* <constant> ::= + name *)
505: (* <constant> ::= - name *)
begin
getname(oldtop - newtop + 1,namestring);
name:=searchname(namestring,level);
with attstack[newtop] do
begin
if name=nil then
begin
markerror(101);
constant:=nil;
end
else
if name^.namekind = constname then
begin
constant := name^.constant;
if prod = 505 then
with constant^ do
begin
with constval^ do
begin (* local copy *)
conststring. length := length;
for i := 1 to (length + (charsperword - 1)) div charsperword do
conststring.compare [ i ] := compare [ i ];
end; (* with constval^ *)
if conststring.str [ 1 ] = '-' then
conststring.str [ 1 ] := '+'
else
conststring.str [ 1 ] := '-';
constant := searchconst(conststring, consttyp);
end; (* if 505 ... with *)
end (* if namekind = constname *)
else
begin
markerror(164);
constant:=nil;
end;
end;
end;
506: (* <constant> ::= string *)
newstring;
507:(* <constant definition> ::= NAME = <constant> *)
begin
getname(1,namestring);
with levels[leveltop] do
name:=insertname(namestring,namelist,namelist);
if name=nil then markerror(102)
else
with name^ do
begin
namekind:=constname;
constant:=attstack[oldtop].constant;
emitname(name);
end;
end
end;
end;
procedure chapter6;
(* Data type definitions *)
var typ:typptr;
namestring:alfa;
alf:^alfa;
name,tagname:nameptr;
level:integer;
lvariant:tagnodeptr;
procedure scalname(no:integer);
(* Insert the next name in a list of a user defined
scalar type*)
var name:nameptr;
namestr:alfa;
begin
with attstack[newtop] do
begin
getname(no,namestring);
name:=insertname(namestring,list,levels[leveltop].namelist);
if name=nil then markerror(102)
else
with name^ do
begin
scalarvalue:=scalarvalue+1;
makestring(scalarvalue,conststring);
namekind:=constname;
constant:=newconstant(conststring,typp);
emitname(name);
end;
end;
end;
procedure arrays;
(* Declaration of a new array type *)
var typ:typptr;
begin
with attstack[oldtop-1] do
if typp<> nil then
if not (typp^.typkind in indexkinds) then markerror(106);
new(typ);
with typ^ do
begin
identification:=identification +1;
ident:=identification;
pack:= packstructure>0;
typkind:=arraytyp;
indextyp:=attstack[oldtop-1].typp;
valtyp:=attstack[oldtop].typp;
end;
emittype(typ);
attstack[newtop].typp:=typ;
end;
procedure newrecord;
(* Declaration of a new record type *)
var typ:typptr;
begin
new(typ);
with typ^ do
begin
identification:=identification+1;
ident:=identification;
pack:= packstructure>0;
typkind:=recordtyp;
fixlist:=levels[leveltop].namelist;
leveltop:=leveltop-1;
variantlist:=attstack[oldtop-1].taglist;
end;
emittype(typ);
globalfieldlist:=attstack[oldtop-2].fixxlist; (*get fixlist for surrounding level*)
attstack[newtop].typp:=typ;
end;
procedure newlabellist(caselabels:caselistptr;cons:constptr);
(*Insert the constant CONS in a list of caselabels
in a record declaration *)
var lablist:caselabptr;
begin
if cons<>nil then
if findvariant(globaltag,cons) <> nil then markerror(115)
else
begin
lablist:=caselabels^.labellist;
if lablist=nil then
begin
new(lablist);
caselabels^.labellist:=lablist;
end
else
begin
while lablist^.list<>nil do lablist:=lablist^.list;
new(lablist^.list);
lablist:=lablist^.list;
end;
with lablist^ do
begin
identification:=identification+1;
ident:=identification;
constant:=cons;
list:=nil;
end;
emitrecordlabel(lablist);
end;
end;
procedure newsettype;
(* Declaration of a new set type *)
begin
with attstack[oldtop] do
begin
if typp<>nil then
if not (typp^.typkind in indexkinds) then markerror(108);
end;
with attstack[newtop] do
begin
new(typp);
with typp^ do
begin
identification:=identification+1;
ident:=identification;
pack:= packstructure>0;
typkind:=settyp;
setoftyp:=getbasetype(attstack[oldtop].typp);
end;
emittype(typp);
end;
end;
procedure newfiletype(rand:boolean);
(* Declaration of a new file type *)
begin
with attstack[newtop] do
begin
new(typp);
with typp^ do
begin
identification:=identification+1;
ident:=identification;
pack:= packstructure>0;
typkind:=filetyp;
randomfile:=rand;
elementtyp:=attstack[oldtop].typp;
if rand then fileindextyp:=attstack[oldtop-3].typp
else fileindextyp:=nil;
end;
emittype(typp);
end;
end;
procedure newtaglist(name:nameptr);
begin
with attstack[newtop] do
begin
new(taglist);
with taglist^ do
begin
identification:=identification+1;
ident:=identification;
pack:= packstructure>0;
tagfield:=nil;
if name=nil then tagtyp:=nil
else tagtyp:=name^.typ;
oldcasetag:=globaltag;
globaltag:=taglist; (*to check the labels*)
varlist:=nil;
end;
emitendnamelist(globalfieldlist);
end;
end;
begin
case prod of
601:(* <type definition> ::= NAME = <type> *)
begin
getname(1,namestring);
with levels[leveltop] do
name:=insertname(namestring,namelist,namelist);
if name=nil then markerror(102)
else
with name^ do
begin
namekind:=typname;
typ:=attstack[oldtop].typp;
emitname(name);
end;
end;
602:(* <simple type> ::= NAME *)
with attstack[newtop] do
begin
getname(1,namestring);
name:=searchname(namestring,level);
typp:=nil;
if name=nil then markerror(101)
else
with name^ do
if namekind=typname then typp:=typ
else markerror(107);
end;
603: (* <scalar type> ::= ( <scalar list> ) *)
with attstack[newtop+1] do
begin
emitendnamelist(list);
typp^.noofscalars:=scalarvalue;
attstack[newtop].typp:=typp;
end;
604:(* <scalar list> ::= <scalar list> , NAME *)
scalname(3);
605:(* <scalar list> ::= NAME *)
with attstack[newtop] do
begin
scalarvalue:=-1;
new(typp);
with typp^ do
begin
identification:=identification+1;
ident:=identification;
typkind:=scalartyp;
scalarlist:=newnamelist(scalarnamelist);
list:=scalarlist;
end;
emittype(typp);
emitnamelist(list);
scalname(1);
end;
606:(* <subrange type> ::= <constant> .. <constant> *)
with attstack[newtop] do
begin
if (constant<> nil) and (attstack[oldtop].constant<>nil) then
with constant^ do
if consttyp<>attstack[oldtop].constant^.consttyp then
markerror(104)
else
if not (consttyp^.typkind in indexkinds) and
(attstack[oldtop].constant^.consttyp^.typkind in indexkinds) then markerror(105);
new(typ);
with typ^ do
begin
identification:=identification+1;
ident:=identification;
typkind:=subrangetyp;
if constant=nil then subtyp:=nil
else subtyp:=constant^.consttyp;
firstconst:=constant;
lastconst:=attstack[oldtop].constant;
end;
emittype(typ);
typp:=typ;
end;
607:(* <structured type> ::= <packed> <unpacked structured type> *)
begin
packstructure:=packstructure-1;
attstack[newtop]:=attstack[oldtop];
end;
608:(* <packed> ::= PACKED *)
packstructure:=packstructure+1;
609:(* <array type> ::= ARRAY [ <index type> <component type> *)
(*<component type> ::= , <index type> <component type> *)
arrays;
610:(* <component type> ::= ] OF <type> *)
(* <packed component type> ::= ] OF <type> *)
attstack[newtop].typp:=attstack[oldtop].typp;
611:(* <record type> ::= <record> <field list> END *)
newrecord;
612:(* <record> ::= RECORD *)
with attstack[newtop] do
begin
fixxlist:=globalfieldlist; (*remember old fieldlist until return
from record*)
globalfieldlist:=newnamelist(fixnamelist);
emitnamelist(globalfieldlist);
if leveltop<maxlevel then leveltop:=leveltop+1
else stop(7);
levels[leveltop].namelist:=globalfieldlist;
end;
613:(* <field list> ::= <fixed part> *)
with attstack[newtop] do
begin
taglist:=nil;
emitendnamelist(globalfieldlist);
end;
614:(* <field list> ::= <fixed part> ; <variant part> *)
attstack[newtop].taglist:=attstack[oldtop].taglist;
615:(* <record section> ::= <field identifier list> : <type> *)
addtypetolist(fieldname);
616:(* <field identifier list> ::= <field identifier list> , NAME *)
addnametolist(3,globalfieldlist);
617:(* <field identifier list> ::= NAME *)
begin
attstack[newtop].nam:=nil;
addnametolist(1,globalfieldlist);
end;
618:(*variant part> ::= <case of> OF <variant list> *)
begin
attstack[newtop].taglist^.varlist:=attstack[oldtop].variant;
globaltag:=attstack[newtop].oldcasetag;
emitendlist(eendvarlist);
end;
619:(* <case of> ::= CASE NAME : NAME *)
with attstack[newtop] do
begin
getname(2,namestring);
tagname:=insertname(namestring,globalfieldlist,levels[leveltop].namelist);
if tagname=nil then markerror(102);
getname(4,namestring);
name:=searchname(namestring,level);
if name=nil then markerror(101)
else
with name^ do
if namekind<>typname then markerror(107)
else
if not (typ^.typkind in indexkinds) then markerror(108)
else
if tagname<>nil then
begin
with tagname^ do
begin
namekind:=tagfldname;
typ:=name^.typ;
end;
emitname(tagname);
end;
newtaglist(name);
taglist^.tagfield:=tagname;
emitvarlist(taglist);
end;
620:(* <case of> ::= CASE NAME *)
with attstack[newtop] do
begin
getname(2,namestring);
name:=searchname(namestring,level);
if name=nil then markerror(101)
else
with name^ do
if namekind<>typname then markerror(107)
else
if not (typ^.typkind in indexkinds) then markerror(108);
newtaglist(name);
emitvarlist(taglist);
end;
621:(* <variant list> ::= <variant list> ; <variant> *)
begin
if attstack[newtop].variant=nil then
attstack[newtop].variant:=attstack[oldtop].variant
end;
622:(* <variant> ::= <total case label list> ( <field list> ) *)
with attstack[newtop] do
begin
with variant^ do
begin
identification:=identification+1;
ident:=identification;
fixlist:=fixxlist;
taglist:=attstack[newtop+2].taglist;
end;
emittagelement(variant);
end;
623:(* <total case label list> ::= <variant label list : *)
with attstack[newtop] do
begin
emitendlist(eendcaselist);
fixxlist:=newnamelist(fixnamelist);
globalfieldlist:=fixxlist;
emitnamelist(list);
end;
624:(* <variant label list> ::= <variant label list> , <constant> *)
newlabellist(attstack[newtop].caselabels,attstack[oldtop].constant);
625:(* <variant label list> ::= <constant> *)
with attstack[newtop] do
begin
new(caselabels);
new(variant);
variant^.caselablist:=caselabels;
variant^.list:=nil;
with caselabels^ do
begin
identification:=identification+1;
ident:=identification;
labellist:=nil;
emit(ident,ecaselist,nilstr,enone,enone,enone,nilstr,nilref,nilref,nilref);
end;
lvariant:=globaltag^.varlist;
if lvariant=nil then globaltag^.varlist:=variant
else
begin
while lvariant^.list<>nil do lvariant:=lvariant^.list;
lvariant^.list:=variant;
end;
newlabellist(caselabels,constant);
end;
626:(* <set type> ::= SET OF <simple type> *)
newsettype;
627:(* <file type> ::= FILE OF <type> *)
newfiletype(false);
628:(* <file type> ::= RANDOM FILE [ <index type> ] OF <type> *)
newfiletype(true);
629:(* <pointer type> ::= ^ NAME *)
with attstack[newtop] do
begin
new(typp);
with typp^ do
begin
identification:=identification+1;
ident:=identification;
declar:=true;
typkind:=pointertyp;
end;
getname(2,namestring);
if vardeclaration then
begin
name:=searchname(namestring,level);
if name=nil then markerror(101);
with name^ do
begin
if namekind<>typname then markerror(110)
else
typp^.pointertotyp:=typ;
emittype(typp);
end;
end
else
with typp^ do
begin
pointertotyp:=nil;
emittype(typp);
(*typedeclaration, remember NAME*)
declar:=false;
ptrlistptr:=unsatptrtyplist;
unsatptrtyplist:=typp;
new(alf);
ptrtypname:=alf;
ptrtypname^:=namestring;
end;
end
end;
end;
procedure chapter7;
(* Declaration and denotations of variables *)
var name:nameptr;
namestring:alfa;
level:integer;
typ, typ1 : typptr;
begin
case prod of
701:(* <variable declaration> ::= <identifier list> : <type> *)
with attstack[oldtop] do
begin
if typp=nil then addtypetolist(varname)
else
if typp^.typkind=filetyp then
begin (*might be external file*)
searchextfile(attstack[newtop].nam,typp);
end
else
addtypetolist(varname);
end;
702:(* <identifier list> ::= <identifier list> , NAME *)
addnametolist(3,levels[leveltop].namelist);
703:(* <identifier list> ::= NAME *)
begin
attstack[newtop].nam:=nil;
addnametolist(1,levels[leveltop].namelist);
end;
704:(* <variable> ::= NAME *)
with attstack[newtop] do
begin
getname(1,namestring);
name:=searchname(namestring,level);
constant:=nil;
varnam:=name;
vartypp:=nil;
if name=nil then markerror(101)
else
with name^ do
begin
case namekind of
varname,valparname,
varparname:
begin
initialized:=false;
vartypp:=typ;
emitrefname(enamecode,name);
end;
ffuncname:vartypp:=typ;
tagfldname,
fieldname:with levels[level] do
begin
vartypp:=typ;
emitcode(ewithname,withnumber,nilref);
emitfield(name,withvartyp);
end;
constname:begin
if constant=nil then vartypp:=nil
else
begin
vartypp:=constant^.consttyp;
attstack[newtop].constant:=constant;
emitrefconst(econstcode,constant,nilref);
end;
end;
filename:begin
vartypp:=filetyp;
emitrefname(enamecode,name);
end;
fprocname,procname:;
programname,typname,modulename:markerror(117);
funcname:begin
vartypp:=functyp;
end
end;
end;
end;
705:(* <variable> ::= <variable> . NAME *)
with attstack[newtop] do
begin
typ:=nil;
varnam:=nil;
getname(3,namestring);
if vartypp<>nil then
with vartypp^ do
begin
if typkind<>recordtyp then
begin
markerror(111);
typ:=nil;
end
else
begin
name:=searchfield(namestring,fixlist);
varnam:=name;
if name=nil then markerror(112)
else
begin
typ:=name^.typ;
emitfield(name,vartypp);
end;
end;
end;
vartypp:=typ;
end;
706:(* <variable> ::= <variable> ^ *)
with attstack[newtop] do
begin
if vartypp<> nil then
with vartypp^ do
begin
if typkind=pointertyp then
begin
emitarith(ereference,vartypp,pointertotyp);
vartypp:=pointertotyp;
end
else
if typkind=filetyp then
begin
emitarith(ereference,vartypp,elementtyp);
vartypp:=elementtyp;
end
else
begin
markerror(118);
vartypp:=nil;
end;
end;
end;
707:(* <array> ::= <variable> [ <expression> *)
(* | <array> , <expression> *)
with attstack[newtop] do
begin
typ:=nil;
if vartypp<>nil then
with vartypp^ do
if typkind<>arraytyp then markerror(119)
else
begin
typ1:=getbasetype(attstack[oldtop].vartypp);
if (typ1 <> nil) and (getbasetype(indextyp)<>typ1) then
markerror(120)
else
begin
typ:=valtyp;
emitarith(eindex,vartypp,nil);
end;
end;
vartypp:=typ;
end
end;
end;
procedure chapter8;
(* Expressions *)
var typ1,typ2:typptr;
namestring:alfa;
level:integer;
procedure maketerm(operator:emitwords);
(* Check arithmetic operations * , / , + , - *)
var typ1,typ2:typptr;
begin
with attstack[newtop] do
begin
checkname(varnam);
checkname(attstack[oldtop].varnam);
typ1:=getbasetype(vartypp);
typ2:=getbasetype(attstack[oldtop].vartypp);
if (typ1<>nil) and (typ2<>nil) then
begin
if typ1^.typkind=inttyp then
begin
if (typ2^.typkind=realtyp) or (operator = erealdiv) then
begin
emitarith(eleftconv,typ1,realtype);
typ1:=realtype;
end;
end;
if typ1^.typkind=realtyp then
begin
if typ2^.typkind=inttyp then
begin
emitarith(erightconv,typ1,typ2);
typ2:=typ1;
end;
end;
if typ1^.typkind<>typ2^.typkind then markerror(124)
else
with typ1^ do
if typkind in[inttyp,realtyp] then emitarith(operator,typ1,nil)
else
if typkind=settyp then
begin
if setoftyp<>typ2^.setoftyp then markerror(124)
else
case operator of
emult:emitarith(esetinter,typ1,nil);
erealdiv:markerror(125);
eadd:emitarith(esetunion,typ1,nil);
edif:emitarith(esetdif,typ1,nil)
end;
end
else markerror(125);
end;
vartypp:=typ1;
varnam:=nil;
constant:=nil;
end;
end;
procedure equaltypes(operator:emitwords;kind:tkind);
(* Check arithmetic operators where both operands
must have the same base type *)
var typ1,typ2:typptr;
i:integer;
begin
with attstack[newtop] do
begin
checkname(varnam);
checkname(attstack[oldtop].varnam);
typ1:=getbasetype(vartypp);
typ2:=getbasetype(attstack[oldtop].vartypp);
if (typ1<>nil) and (typ2<>nil) then
if (typ1^.typkind=kind) and (typ2^.typkind=kind) then
emitarith(operator,nil,nil)
else markerror(125);
varnam:=nil;
constant:=nil;
if kind=booleantyp then vartypp:=booltype
else vartypp:=typ1;
end;
end;
procedure relation(operator:emitwords);
(* Check the relational operators *)
var typ1,typ2,typ3:typptr;
i,j:integer;
begin
with attstack[newtop] do
begin
checkname(varnam);
checkname(attstack[oldtop].varnam);
typ1:=getbasetype(vartypp);
typ3:=attstack[oldtop].vartypp;
typ2:=getbasetype(typ3);
if (typ1<>nil) and (typ2<>nil) then
with typ1^ do
begin
case typkind of
booleantyp,
scalartyp:if typ2^.typkind<>typkind then markerror(124)
else
if scalarlist<>typ2^.scalarlist then markerror(124)
else emitarith(operator,typ1,nil);
inttyp:with typ2^ do
begin
if typkind=realtyp then
begin
emitarith(eleftconv,typ1,typ2);
emitarith(operator,typ2,nil);
end
else
if typkind=inttyp then emitarith(operator,typ1,nil)
else markerror(124);
end;
realtyp:with typ2^ do
begin
if typkind=inttyp then
begin
emitarith(erightconv,typ1,typ2);
emitarith(operator,typ1,nil);
end
else
if typkind=realtyp then emitarith(operator,typ1,nil)
else markerror(124);
end;
arraytyp:if (typ1=typ2) and ((operator=eeq) or (operator=ene)) then
emitarith(operator,typ1,nil)
else
begin
i:=getstringlength(typ1,124);
j:=getstringlength(typ2,124);
if i>j then emitarith(erightconv,typ1,typ2)
else
if (i<j) or ((i=1) and
(stringtyp<>asciiorstring[typ3^.typkind])) then
begin
emitarith(eleftconv,typ1,typ3);
typ1:=typ2;
end;
emitarith(operator,typ1,nil);
end;
asciityp:begin
i:=getstringlength(typ2,124);
if i > 0 then
if (i>1) or (asciiorstring[vartypp^.typkind] <> asciiorstring[typ3^.typkind])
then emitarith(eleftconv,vartypp,typ3);
emitarith(operator,vartypp,nil);
end;
stringtyp:begin
i:=getstringlength(typ2,124);
if i > 0 then
if (length>i) or ((i=1) and
(stringtyp <> asciiorstring[typ3^.typkind])) then
emitarith(erightconv,typ1,typ3)
else
if i>length then
begin
emitarith(eleftconv,typ1,typ3);
typ1:=typ3;
end;
emitarith(operator,typ1,nil);
end;
recordtyp:if typ1=typ2 then
begin
if (operator=eeq) or (operator=ene) then emitarith(operator,typ1,nil)
else markerror(109);
end
else markerror(124);
settyp:if typ2^.typkind<>settyp then markerror(124)
else
begin
if (setoftyp<>typ2^.setoftyp) and (setoftyp<>nil) and
(typ2^.setoftyp<>nil) then markerror(124)
else
if (operator=elt) or (operator=egt) then markerror(127)
else emitarith(operator,typ1,nil);
end;
filetyp:markerror(126);
pointertyp:begin
if pointertyp<>typ2^.typkind then markerror(124)
else
if (pointertotyp<>typ2^.pointertotyp) and (pointertotyp<>nil)
and (typ1 <> nilconst^.consttyp) and (typ2 <> nilconst^.consttyp) then
markerror(124)
else
if (operator =eeq) or (operator=ene) then emitarith(operator,typ1,nil)
else markerror(109);
end
end;
end;
vartypp:=booltype;
varnam:=nil;
constant:=nil;
end;
end;
begin
case prod of
800:(* <unsigned constant> ::= <unsigned integer> *)
with attstack[newtop] do
begin
conststring.str[1]:='+';
constant:=searchconst(conststring,typp);
end;
801:(* <unsigned constant> ::= REALKONST *)
with conststring do
begin
getstring(1,2,str,length);
str[1]:='+';
attstack[newtop].constant:=searchconst(conststring,realtype);
end;
802:(* <unsigned constant> ::= STRING *)
newstring;
803:(* <unsigned constant> ::= NIL *)
attstack[newtop].constant:=nilconst;
804:(* <factor> ::= ( <expression> ) *)
with attstack[newtop+1] do
begin
if vartypp=nil then checkname(varnam)
else
if not (vartypp^.typkind in [subrangetyp,booleantyp,inttyp,realtyp,settyp]) then
markerror(108);
with attstack[newtop] do
begin
vartypp:=attstack[newtop+1].vartypp;
varnam:=nil;
constant:=nil;
end;
end;
805:(* <factor> ::= <variable> *)
with attstack[newtop] do
begin
if varnam<>nil then
begin
with varnam^ do
if namekind in [funcname,ffuncname] then emitcallfunc(varnam)
else emitload(vartypp);
end
else emitload(vartypp);
end;
806:(* <factor> ::= <unsigned constant> *)
with attstack[newtop] do
begin
emitrefconst(econstcode,constant,nilref);
vartypp:=constant^.consttyp;
varnam:=nil;
emitarith(eload,vartypp,nil);
end;
807:(* <factor> ::= NOT <factor> *)
with attstack[oldtop] do
begin
checkname(varnam);
if vartypp<>nil then
if vartypp^.typkind<>booleantyp then markerror(121);
with attstack[newtop] do
begin
vartypp:=booltype;
varnam:=nil;
constant:=nil;
end;
emitcode(enot,nilref,nilref);
end;
808:(* <set> ::= <startset> <element list> ] *)
(* | <startset> ] *)
with attstack[newtop] do
begin
varnam:=nil;
constant:=nil;
new(vartypp);
with vartypp^ do
begin
(* 80.03.26 *)
identification := identification + 1;
ident := identification;
pack := false;
typkind:=settyp;
setoftyp:=attstack[newtop+1].vartypp;
end;
emitcode(eendset,nilref,nilref);
emittype(vartypp);
end;
809:(* <startset> ::= [ *)
begin
attstack[newtop+1].vartypp:=nil;
emitcode(estartset,nilref,nilref);
end;
810:(* <element list> ::= <element list> , <element> *)
with attstack[newtop] do
begin
if vartypp=nil then vartypp:=attstack[oldtop].vartypp
else
if attstack[oldtop].vartypp<>nil then
if vartypp<>attstack[oldtop].vartypp then
markerror(122);
end;
811:(* <element> ::= <expression> *)
with attstack[newtop] do
begin
checkname(varnam);
vartypp:=getbasetype(vartypp);
varnam:=nil;
emitarith(eset,vartypp,nil);
end;
812:(* <element> ::= <expression> .. <expression> *)
with attstack[newtop] do
begin
checkname(varnam);
checkname(attstack[oldtop].varnam);
typ1:=getbasetype(vartypp);
typ2:=getbasetype(attstack[oldtop].vartypp);
if (typ1<>nil) and (typ2<>nil) then
begin
if typ1^.typkind<>typ2^.typkind then markerror(122)
else
if not (typ1^.typkind in indexkinds) then markerror(123);
emitarith(esetrange,typ1,nil);
end;
vartypp:=typ1;
varnam:=nil;
end;
813:(* <term> ::= <term> * <factor> *)
maketerm(emult);
814:(* term> ::= <term> / <factor> *)
begin
maketerm(erealdiv);
attstack[newtop].vartypp:=realtype;
end;
815:(* <term> ::= <term> DIV <factor> *)
equaltypes(eintdiv,inttyp);
816:(* <term> ::= <term> MOD <factor> *)
equaltypes(emod,inttyp);
817:(* <term> ::= <term> AND <factor> *)
equaltypes(eand,booleantyp);
818:(* <simple expression> ::= <simple expression> + <term> *)
maketerm(eadd);
819:(* <simple expression> ::= <simple expression> - <term> *)
maketerm(edif);
820:(* <simple expression> ::= <simple expression> OR <term> *)
equaltypes(eor,booleantyp);
821:(* <simple expression> ::= + <term> *)
with attstack[newtop] do
begin
checkname(attstack[oldtop].varnam);
varnam:=nil;
constant:=nil;
vartypp:=getbasetype(attstack[oldtop].vartypp);
if vartypp<>nil then
if not (vartypp^.typkind in [inttyp,realtyp]) then markerror(125);
end;
822:(* <simple expression> ::= - <term> *)
with attstack[newtop] do
begin
checkname(attstack[oldtop].varnam);
varnam:=nil;
constant:=nil;
vartypp:=getbasetype(attstack[oldtop].vartypp);
if vartypp<>nil then
if vartypp^.typkind in [inttyp,realtyp] then emitarith(eminus,vartypp,nil)
else markerror(125);
end;
823:(* <simple expression> ::= OR <term> *)
with attstack[newtop] do
begin
checkname(attstack[oldtop].varnam);
varnam:=nil;
constant:=nil;
vartypp:=getbasetype(attstack[oldtop].vartypp);
if vartypp<>nil then
if not (vartypp^.typkind =booleantyp) then markerror(125);
end;
824:(* <expression> ::= <simple expression> = <simple expression> *)
relation(eeq);
825:(* <expression> ::= <simple expression> <> <simple expression> *)
relation(ene);
826:(* <expression> ::= <simple expression> < <simple expression> *)
relation(elt);
827:(* <expression> ::= <simple expression> <= <simple expression> *)
relation(ele);
828:(* <expression> ::= <simple expression> >= <simple expression> *)
relation(ege);
829:(* <expression> ::= <simple expression> > <simple expression> *)
relation(egt);
830:(* <expression> ::= <simple expression> IN <simple expression> *)
with attstack[oldtop] do
begin
checkname(attstack[newtop].varnam);
checkname(varnam);
if vartypp<>nil then
with vartypp^ do
if typkind<>settyp then markerror(125)
else
begin
typ1:=getbasetype(attstack[newtop].vartypp);
if typ1<>getbasetype(setoftyp) then markerror(124)
else emitarith(ein,setoftyp,nil);
end;
attstack[newtop].vartypp:=booltype;
end;
831:(* <function designator> ::= <function identifier>
(* ( <actual parameter list> ) *)
with attstack[newtop+2] do
begin
if formalname <> nil then
if formalname^.list <> nil then markerror(131);
emitendcall(varnam);
attstack[newtop].varnam:=nil;
end;
832:(* <function identifier> ::= NAME *)
with attstack[newtop] do
begin
firstpar:=true;
formalname:=nil;
vartypp:=nil;
getname(1,namestring);
varnam:=searchname(namestring,level);
if varnam=nil then markerror(101)
else
with varnam^ do
begin
if namekind=ffuncname then vartypp:=typ
else
if namekind=funcname then vartypp:=functyp
else markerror(128);
emitcall(ecallfunc,varnam);
end;
end
end;
end;
procedure chapter9;
var lab:labelptr;
typ1,typ2,exptyp:typptr;
name:nameptr;
namestring:alfa;
i,j:integer;
localcase:checkcaseptr;
notfound:boolean;
function findlabel(no:integer;def:boolean):labelptr;
(* Find a label in the symbol table *)
var lab:labelptr;
i,level:integer;
notfound:boolean;
labvalue:labelval;
begin
with conststring do
begin
getstring(no,1,str,length);
if length>labellength then markerror(114);
for i:=length+1 to labellength do str[i]:=' ';
for i:=1 to labellength do labvalue[i]:=str[i];
end;
level:=leveltop;
repeat
while levels[level].leveltype in [withlevel,firstwithlevel] do level:=level-1;
lab:=levels[level].namelist^.labeltree;
notfound:=true;
while notfound and (lab<>nil) do
with lab^ do
begin
notfound:=labelvalue<>labvalue;
if notfound then lab:=labellist;
end;
level:=level-1;
until def or (level=-1) or (not notfound);
findlabel:=lab;
end;
procedure checkformal(name:nameptr);
var namelist:namelistptr;
begin
emitbuffered:=false;
emitrefname(enamecode,name);
if name <> nil then
begin
namelist:=nil;
with name^ do
if namekind=funcname then namelist:=fparamlist
else if namekind=procname then namelist:=pparamlist;
if namelist <> nil then
begin
name:=namelist^.namelist;
while name <> nil do
begin
if name^.namekind <> valparname then
begin
markerror(158);
name:=nil;
end
else name:=name^.list;
end;
end;
end;
end;
procedure paramtype(name:nameptr);
(* Check an actual parameter in a procedure/function
call against the declaration *)
var i, j :integer;
typ1, typ2 : typptr;
begin
with attstack[newtop],name^ do
(*newtop : actual argument *)
(*name : namenode of formal param *)
(*notice :
- vartypp describes : type of actual
- typ - " - : type of formal
*)
case namekind of
ffuncname:begin
if varnam = nil then markerror(133)
else
begin
if (not (varnam^.namekind in [funcname,ffuncname])) or
(getbasetype(vartypp)<>getbasetype(typ)) then markerror(132);
checkformal(varnam);
end;
end;
fprocname:begin
if varnam=nil then markerror(133)
else
begin
if varnam^.namekind in [procname,fprocname] then
checkformal(varnam)
else markerror(132);
end;
end;
valparname:
begin
checkname(varnam);
typ1:=getbasetype(typ);
typ2:=getbasetype(vartypp);
(* the following check is a copy of the check performed for an assignment *)
if typ2<>typ1 then
begin
if (typ1<>nil) and (typ2<>nil) then
with typ1^ do
if (typkind=realtyp) and (typ2^.typkind=inttyp) then
emitarith(erightconv,typ1,vartypp)
else
if typkind=pointertyp then
begin
with typ2^ do
if typkind<>pointertyp then markerror(132)
else
if (pointertotyp<>typ1^.pointertotyp) and (pointertotyp<>nil) then
markerror(132);
end
else
if typkind=settyp then
begin
if typ2^.typkind <> settyp then markerror(132)
else
if (setoftyp <> typ2^.setoftyp) and (typ2^.setoftyp <> nil)
then markerror(132);
end
else
begin
i:=getstringlength(typ1,132);
if i>0 then
begin
j:=getstringlength(typ2,132);
if j > 0 then
if (i<>j) or ((i=1) and
(asciiorstring[typkind] <>asciiorstring[typ2^.typkind])) then
emitarith(erightconv,typ,vartypp);
end; (* if i > 0 *)
end; (* else strings *)
end; (* typ1 <> typ2 *)
end;
varparname:begin
if varnam = nil then markerror(133)
else
if varnam^.namekind in [constname,typname,procname,funcname,
fprocname,ffuncname] then markerror(133)
else
if vartypp <> nil then
if emitbuffered and (attstack[newtop].constant=nil) then
begin
emitbuffered:=false;
if vartypp <> typ then markerror(132);
(* types must be equal *)
end
else markerror(133)
end
end;
end;
procedure assignment;
var
typ1,typ2,exptyp:typptr;
begin
checkname(attstack[oldtop].varnam);
with attstack[newtop] do
begin
(* typ1 = basetype of lefthand side *)
(* typ2 = basetype of righthand side *)
(* the check is a copy of the check performed for a valueparameter
( in procedure paramtype *)
typ1:=getbasetype(vartypp);
exptyp:=attstack[oldtop].vartypp;
typ2:=getbasetype(exptyp);
if typ2<>typ1 then
begin
if (typ1<>nil) and (typ2<>nil) then
with typ1^ do
if (typkind=realtyp) and (typ2^.typkind=inttyp) then
begin
emitarith(erightconv,typ1,exptyp);
exptyp:=typ1;
end
else
if typkind=pointertyp then
begin
with typ2^ do
if typkind<>pointertyp then markerror(130)
else
if (pointertotyp<>typ1^.pointertotyp) and (pointertotyp<>nil) then
markerror(130);
end
else
if typkind=settyp then
begin
if typ2^.typkind <> settyp then markerror(130)
else
if (setoftyp <> typ2^.setoftyp) and (typ2^.setoftyp <> nil)
then markerror(130);
end
else
begin
i:=getstringlength(typ1,130);
if i>0 then
begin
j:=getstringlength(typ2,130);
if j > 0 then
if (i<>j) or ((i=1) and
(asciiorstring[typkind] <>asciiorstring[typ2^.typkind])) then
begin
emitarith(erightconv,vartypp,exptyp);
exptyp:=vartypp;
end;
end;
end;
end;
if varnam=nil then emitarith(estore,vartypp,exptyp)
else
if varnam^.namekind=funcname then emitstorefunc(varnam,vartypp,exptyp)
else
emitarith(estore,vartypp,exptyp);
end;
end;
procedure insertcase(cons:constptr);
var help:checkcaseptr;
begin
if freecasecheck=nil then
begin
new(freecasecheck);
freecasecheck^.next:=nil;
end;
help:=globcasecheck;
globcasecheck:=freecasecheck;
with globcasecheck^ do
begin
freecasecheck:=next;
next:=help;
constant:=cons;
end;
end;
procedure returncase(casecheck:checkcaseptr);
var help:checkcaseptr;
begin
while casecheck <> nil do
begin
help:=freecasecheck;
freecasecheck:=casecheck;
casecheck:=casecheck^.next;
freecasecheck^.next:=help;
end;
end;
begin
case prod of
901:(* <statement> ::= <if then> <statement> *)
(* | <if then else> <statement> *)
(*balanced statement> ::= <if then else> <balanced statement> *)
begin
emitcode(eendif,levelnumber,nilref);
levelnumber:=levelnumber-1;
end;
902:(* <statement> ::= <case part otherwise part> <statement> *)
(*<balanced statement> ::= <casepart otherwise part> <balanced statement> *)
with attstack[newtop] do
begin
emitcode(egotoendcase,levelnumber,nilref);
emitcode(eendcase,levelnumber,nilref);
globalcasetype:=selectortypp;
returncase(globcasecheck);
globcasecheck:=casecheck;
levelnumber:=levelnumber-1;
end;
903:(* <statement> ::= <case part> *)
(* | <case part> <balanced statement> *)
with attstack[newtop] do
begin
emitcode(eendcase,levelnumber,nilref);
globalcasetype:=selectortypp;
returncase(globcasecheck);
globcasecheck:=casecheck;
levelnumber:=levelnumber-1;
end;
904:(* <statement> ::= <while do> <statement> *)
(* <balanced statement> ::= <while do> <balanced statement> *)
begin
emitcode(eendwhile,levelnumber,nilref);
levelnumber:=levelnumber-1;
end;
905:(* <statement> ::= <for to do> <statement> *)
(* <balanced statement> ::= <for to do> <balanced statement> *)
begin
emitforcontrol(efortoend,levelnumber,attstack[newtop].varnam);
levelnumber:=levelnumber-1;
end;
906:(* <statement> ::= <for downto do> <statement> *)
(* <balanced statement> ::= <for downto do> <balanced statement> *)
begin
emitforcontrol(efordntoend,levelnumber,attstack[newtop].varnam);
levelnumber:=levelnumber-1;
end;
907:(* <statement> ::= <with do> <statement> *)
(* <balanced statement> ::= <with do> <balanced statement> *)
begin
levelnumber:=attstack[newtop].withnumber;
emitcode(eendwith,levelnumber,nilref);
levelnumber:=levelnumber-1;
while levels[leveltop].leveltype<>firstwithlevel do leveltop:=leveltop-1;
leveltop:=leveltop-1;
end;
908:(* <label> ::= KONST *)
begin
lab:=findlabel(1,true);
if lab=nil then markerror(129)
else
with lab^ do
begin
if defined then markerror(147)
else defined:=true;
emitcode(elabeldef,ident,nilref);
end;
end;
909:(* <assignment statement> ::= <leftside> := <expression> *)
assignment;
910:(* <leftside> ::= <variable> *)
with attstack[newtop] do
if varnam <> nil then
with varnam^ do
if namekind in [constname,fprocname,procname,ffuncname,funcname] then
begin
if namekind=funcname then
begin
if assignable then
begin
assigned:=true;
emitrefname(efunction,varnam);
end
else markerror(156);
end
else markerror(108)
end;
911:(* <procedure statement> ::= <procedure identifier> *)
with attstack[newtop] do
begin
if varnam<>nil then
with varnam^ do
begin
if namekind=procname then
if pmode=systemmode then
begin
if (namestr <> 'WRITELN ') and (namestr <> 'READLN ') then markerror(131);
end
else
begin
if pparamlist^.namelist<>nil then markerror(131)
end;
emitendcall(varnam);
end;
end;
912:(* <procedure statement> ::= <procedure identifier> *)
(* ( <actual parameterlist> ) *)
with attstack[newtop+2] do
begin
if varnam<>nil then
with varnam^ do
begin
if namekind=procname then
begin
if pmode=systemmode then
begin
if attstack[oldtop].moreparameters then markerror(131);
end
else
if formalname <> nil then
if formalname^.list<>nil then
markerror(131);
end;
emitendcall(varnam);
end;
end;
913:(* <actual parameterlist> ::= <actual parameterlist> , <actual parameter> *)
(* | <actual parameter> *)
with attstack[oldtop-2] do
begin
if formalname=nil then
if varnam <> nil then
with varnam^ do
if (namestr='WRITE ') or (namestr='WRITELN ') then
if writeformat > 0 then emitcode(eformat,levelnumber,writeformat);
emitparam(attstack[oldtop].vartypp,formalname);
if newtop=oldtop then
begin
attstack[newtop]:=attstack[newtop-2];
if newtop=stackmax then stop(1);
attstack[newtop+1]:=attstack[newtop-1];
end;
end;
914:(* <actual parameter> ::= <actual parameter> : <expression> *)
begin
name:=attstack[newtop-2].varnam;
if name <> nil then
if (name^.namekind=procname) and (name^.pmode=systemmode)
and ((name^.namestr='WRITE ') or (name^.namestr='WRITELN ')) then
with attstack[newtop] do
if vartypp <> nil then
begin
if (attstack[newtop-1].paramtypp <> asciitype) or
(vartypp^.typkind=filetyp) then markerror(132)
else
begin
if getbasetype(attstack[oldtop].vartypp) <> integertype then
markerror(108);
writeformat:=writeformat+1;
if (writeformat>2) or ((writeformat=2) and (vartypp <> realtype)) then markerror(154);
end;
end
else markerror(132)
else markerror(154);
end;
915:(* <actual parameter> ::= <expression> *)
with attstack[newtop-2] do
if varnam<>nil then
with varnam^ do
if firstpar then
begin
name:=nil;
if namekind=procname then
if (pmode=systemmode) and (pparamlist = nil) then standardparam(true)
else
begin
name:=pparamlist^.namelist;
if name=nil then markerror(131)
else paramtype(name);
attstack[newtop-1].moreparameters:=false;
end
else
if namekind=funcname then
begin
name:=fparamlist^.namelist;
if name=nil then markerror(131)
else
if (name^.namekind <> fprocname) and (name^.typ=nil) then
begin
standardparam(true);
name:=nil;
end
else paramtype(name);
end;
firstpar:=false;
formalname:=name;
end
else
if formalname=nil then
begin
if namekind in [procname,funcname] then standardparam(false)
end
else
begin
formalname:=formalname^.list;
if formalname=nil then markerror(131)
else
with formalname^ do
if (namekind in [varparname,valparname])
and (typ = nil) then standardparam(false)
else paramtype(formalname);
end;
916:(* <procedure identifier> ::= NAME *)
with attstack[newtop] do
begin
firstpar:=true;
formalname:=nil;
getname(1,namestring);
varnam:=searchname(namestring,i);
if varnam=nil then markerror(101)
else
if not (varnam^.namekind in [fprocname,procname]) then
markerror(134);
emitcall(ecallproc,varnam);
end;
917:(* <go to statement> ::= GOTO KONST *)
begin
lab:=findlabel(2,false);
if lab=nil then markerror(129)
else emitcode(egoto,lab^.ident,nilref);
end;
918:(* <if then> ::= <if part> <expression> THEN *)
if attstack[newtop+1].vartypp<>booltype then markerror(137)
else emitcode(ethen,levelnumber,nilref);
919:(* <if part> ::= IF *)
begin
levelnumber:=levelnumber+1;
emitcode(eif,levelnumber,nilref);
end;
920:(* <if then else> ::= <if then> <balanced statement> ELSE *)
emitcode(eelse,levelnumber,nilref);
921:(* <case part otherwise part> ::= <case part> OTHERWISE *)
emitcode(eotherwise,levelnumber,nilref);
922:(* <selector part> ::= <case> <expression> OF *)
begin
emitcode(eoff,levelnumber,nilref);
with attstack[newtop] do
begin
selectortypp:=globalcasetype;
casecheck:=globcasecheck;
end;
globcasecheck:=nil;
globalcasetype:=getbasetype(attstack[newtop+1].vartypp);
if globalcasetype<>nil then
if not (globalcasetype^.typkind in indexkinds) then markerror(130);
end;
923:(* <case> ::= CASE *)
begin
levelnumber:=levelnumber+1;
emitcode(ecase,levelnumber,nilref);
end;
924:(* <case list element> ::= <case label list> : <statement> *)
emitcode(egotoendcase,levelnumber,nilref);
925:(* <case label list> ::= <case label list> , <constant> *)
(* | <constant> *)
with attstack[oldtop] do
begin
if constant<>nil then
if globalcasetype<>getbasetype(constant^.consttyp) then markerror(136)
else
begin
localcase:=globcasecheck;
notfound:=true;
while (localcase <> nil) and notfound do
begin
notfound:=localcase^.constant <> constant;
localcase:=localcase^.next;
end;
if notfound then insertcase(constant)
else markerror(147);
emitrefconst(ecaselabel,constant,levelnumber);
end;
end;
926:(* <while do> ::= <while> <expression> DO *)
if attstack[newtop+1].vartypp<>booltype then markerror(137)
else emitcode(ewhiledo,levelnumber,nilref);
927:(* <while> ::= WHILE *)
begin
levelnumber:=levelnumber+1;
emitcode(ewhile,levelnumber,nilref);
end;
928:(* <repeat statement> ::= <repeat until> <expression> DO *)
begin
if attstack[newtop+1].vartypp<>booltype then markerror(137)
else emitcode(eendrepeat,levelnumber,nilref);
levelnumber:=levelnumber-1;
end;
929:(* <repeat until> ::= <repeat> <statement list> UNTIL *)
emitcode(euntil,levelnumber,nilref);
930:(* <repeat> ::= REPEAT *)
begin
levelnumber:=levelnumber+1;
emitcode(erepeat,levelnumber,nilref);
end;
931:(* <for to do> ::= <for to> <expression> DO *)
with attstack[newtop] do
if getbasetype(attstack[newtop+1].vartypp)<>vartypp then markerror(130)
else emitforcontrol(efortodo,levelnumber,varnam);
932:(* <for downto do> ::= <for downto> <expression> DO *)
with attstack[newtop] do
if getbasetype(attstack[newtop+1].vartypp)<>vartypp then
markerror(130)
else emitforcontrol(efordowntodo,levelnumber,varnam);
933:(* <for to> ::= <for name> <expression> TO *)
(* <for downto> ::= <for name> <expression> DOWNTO *)
with attstack[newtop] do
if getbasetype(attstack[newtop+1].vartypp)<>vartypp then
markerror(130)
else emitforcontrol(eforinit,levelnumber,varnam);
934:(* <for name> ::= FOR NAME := *)
with attstack[newtop] do
begin
getname(2,namestring);
varnam:=searchname(namestring,i);
if varnam=nil then markerror(101)
else
with varnam^ do
if namekind in [varname,varparname,valparname] then
begin
levelnumber:=levelnumber+1;
vartypp:=getbasetype(typ);
if vartypp<>nil then
if not (vartypp^.typkind in indexkinds) then markerror(108)
else emitforcontrol(efor,levelnumber,varnam);
end
else markerror(159);
end;
935:(* <with do> ::= <with> <record variable list> DO *)
begin
emitcode(ewithdo,attstack[newtop].withnumber,nilref);
end;
936:(* <record variable list> ::= <record variable list> , <variable> *)
(* | <variable> *)
with attstack[oldtop] do
begin
if leveltop<maxlevel then leveltop:=leveltop+1
else stop(7);
with levels[leveltop] do
begin
levelnumber:=levelnumber+1;
withnumber:=levelnumber;
namelist:=nil;
withvartyp:=nil;
if oldtop=newtop then leveltype:=firstwithlevel
else leveltype:=withlevel;
if vartypp<>nil then
with vartypp^ do
if typkind=recordtyp then
begin
namelist:=fixlist;
withvartyp:=vartypp;
emitcode(ewithvar,withnumber,nilref);
end
else markerror(111);
end
end;
937:(* <with> ::= WITH *)
begin
levelnumber:=levelnumber+1;
emitcode(ewith,levelnumber,nilref);
attstack[newtop].withnumber:=levelnumber;
end
end;
end;
procedure chapter10;
(* Procedure declarations *)
var
name:nameptr;
namestring:alfa;
i,level:integer;
typ1,typ2:typptr;
lab:labelptr;
ext:extptr;
procedure getprocname;
var namestring:alfa;
begin
with attstack[newtop-1] do
begin
getname(1,namestring);
with levels[leveltop] do
nam:=insertname(namestring,namelist,namelist);
globalfieldlist:=newnamelist(paramnamelist);
emitnamelist(globalfieldlist);
if nam=nil then
begin (*might be forward declared *)
nam:=searchfield(namestring,levels[leveltop].namelist);
if nam=nil then markerror(102)
else
with nam^ do
begin (* forward declared*)
if namekind<>procname then markerror(113)
else
if pmode<>forw then markerror(113);
end;
end
else
with nam^ do
begin
namekind:=procname;
pmode:=internal;
plokvarlist:=nil;
pparamlist:=globalfieldlist;
end;
end;
end;
procedure paramgroup(kind:nkind;no:integer);
(* Add the type of a parameter group to the
names in the group *)
var name:nameptr;
namestring:alfa;
level:integer;
begin
attstack[oldtop].typp:=nil;
getname(no,namestring);
name:=searchname(namestring,level);
if name=nil then markerror(101)
else
with name^ do
begin
if namekind<>typname then markerror(107)
else attstack[oldtop].typp:=name^.typ;
end;
attstack[newtop].nam:=attstack[newtop+no-3].nam;
addtypetolist(kind);
end;
procedure newlabel(no:integer);
(* Declaration of a label *)
var error:boolean;
lab:labelptr;
labvalue:labelval;
i:integer;
begin
with conststring do
begin
getstring(no,1,str,length);
if length>labellength then markerror(114);
for i:=length+1 to labellength do str[i]:=' ';
for i:=1 to labellength do labvalue[i]:=str[i];
end;
lab:=levels[leveltop].namelist^.labeltree;
error:=false;
if lab<>nil then
while lab^.labellist<>nil do
with lab^ do
begin
if labelvalue=labvalue then error:=true;
lab:=labellist;
end;
if error then markerror(115)
else
begin
new(lab);
with lab^ do
begin
identification:=identification+1;
ident:=identification;
defined:=false;
labelvalue:=labvalue;
with levels[leveltop].namelist^ do
begin
labellist:=labeltree;
labeltree:=lab;
end;
end;
emitlabel(lab);
end;
end;
procedure getnextvalelement;
begin
with attstack[newtop],globalvaltypp^ do
begin
globalvalnam:=nil;
if typkind=arraytyp then
begin
count:=0;
globalvaltypp:=valtyp;
if indextyp <> nil then
with indextyp^ do
begin
if typkind=subrangetyp then count:=makeinteger(firstconst)
else
if (typkind <> inttyp) and (scalarlist <> nil) then
with scalarlist^ do
if namelist <> nil then count:=makeinteger(namelist^.constant);
end;
end
else
if typkind=recordtyp then
begin
if fixlist=nil then globalvaltypp:=nil
else
begin
globalvalnam:=fixlist^.namelist;
if globalvalnam=nil then globalvaltypp:=nil
else globalvaltypp:=globalvalnam^.typ;
end;
valtag:=variantlist;
end;
end;
globalvalcount:=1;
end;
procedure tagfield;
var
tag1:tagnodeptr;
cons:constptr;
begin
cons:=attstack[newtop].constant;
with attstack[newtop-1] do
begin
if valtypp = nil then
begin
if valtag=nil then markerror(112)
else tag1:=findvariant(valtag,cons);
end
else
with valtypp^ do
if typkind <> recordtyp then markerror(111)
else
begin
if variantlist=nil then markerror(149)
else tag1:=findvariant(variantlist,cons);
valtag:=variantlist;
end;
if valtag <> nil then
with valtag^ do
begin
emitrefname(efieldbegin,tagfield);
emitstorevalue(globalvaltypp,cons^.consttyp,cons);
if tagfield <> globalvalnam then markerror(150);
if tag1 = nil then markerror(112)
else
with tag1^ do
begin
if fixlist=nil then
begin
globalvalnam:=nil;
globalvaltypp:=nil;
end
else
begin
globalvalnam:=fixlist^.namelist;
if globalvalnam=nil then globalvaltypp:=nil
else globalvaltypp:=globalvalnam^.typ;
end;
with attstack[newtop+1] do
begin
valtypp:=nil;
valnam:=nil;
valtag:=tag1^.taglist;
count:=1;
end;
end;
end;
end;
end;
procedure newextmodule(mode:pfmodes);
var name:nameptr;
namestring:alfa;
ext,ext1:extptr;
begin
getname(3,namestring);
with levels[leveltop] do
name:=insertname(namestring,namelist,namelist);
with name^ do
begin
namekind:=modulename;
modulekind:=mode;
procfunclist:=nil;
end;
attstack[newtop].nam:=name;
new(ext);
ext^.name:=name;
if mode=extpascal then
if globalmodule=nil then
begin
ext^.next:=nil;
globalmodule:=ext
end
else
begin
ext1:=globalmodule;
repeat
if ext1^.name^.namestr=namestring then
begin
markerror(155);
ext1:=nil;
end
else ext1:=ext1^.next;
until ext1=nil;
ext^.next:=globalmodule;
globalmodule:=ext;
end;
emitname(name);
end;
procedure gettypeofconst(no:integer);
begin
with attstack[newtop+no] do
begin
valtypp:=getbasetype(constant^.consttyp);
if valtypp <> nil then
if valtypp^.typkind in [realtyp,arraytyp,stringtyp,recordtyp,
settyp,filetyp,pointertyp] then
begin
markerror(123);
valtypp:=nil;
end
else emitrefconst(econstcode,constant,nilref);
end;
end;
procedure storevalue;
begin
with attstack[newtop] do
begin
if globalvalnam=nil then
begin
emitelementbegin(globalvaltypp,globalvalcount);
emitstorevalue(globalvaltypp,constant^.consttyp,constant);
end
else
begin
emitrefname(efieldbegin,globalvalnam);
emitstorevalue(globalvaltypp,constant^.consttyp,constant);
globalvalnam:=globalvalnam^.list;
if globalvalnam=nil then globalvaltypp:=nil
else globalvaltypp:=globalvalnam^.typ;
end;
end;
globalvalcount:=1;
end;
begin
case prod of
1001:(* <procedure declaration> ::= <procedure heading> ; FORWARD *)
with attstack[newtop] do
begin
if nam<>nil then
with nam^ do
if pmode=forw then markerror(142)
else pmode:=forw;
leveltop:=leveltop-1;
identification:=identification+1;
emit(identification,eforward,nilstr,enone,enone,enone,nilstr,nilref,nilref,nilref);
end;
1002:(* <block> ::= <blockstart> *)
(* <declaration part> *)
(* <compound statement> *)
begin
lab:=levels[leveltop].namelist^.labeltree;
while lab<>nil do
with lab^ do
begin
if not defined then markerror(146);
lab:=labellist;
end;
with attstack[newtop-2] do
begin
with nam^ do
if namekind = funcname then
begin
assignable:=false;
if not assigned then markerror(166);
end;
locallinenumber := -1; (* suppress printing of local line numbers *)
emitrefname(eblockend,nam);
end;
leveltop:=leveltop-1;
end;
1003:(* <blockstart> ::= EMPTY *)
with attstack[newtop-2] do
begin
list:=newnamelist(declarationlist);
with levels[leveltop] do
if leveltype=programlevel then
begin
namelist:=list;
name:=insertname('OUTPUT ',namelist,namelist);
name^.ext:=false;
if inputfound then name:=insertname('INPUT ',namelist,namelist);
name:=searchname('TEXT ',level);
searchextfile(namelist^.namelist,name^.typ);
end
else
begin
list^.nametree:=namelist^.nametree;
namelist^.nametree:=nil;
namelist:=list;
end;
if nam<>nil then
begin
if nam^.namekind=procname then
begin
nam^.plokvarlist:=list;
nam^.pmode:=internal;
end
else
begin
nam^.flokvarlist:=list;
nam^.fmode:=internal;
end;
end;
emitnamelist(list);
vardeclaration:=false;
end;
1004:(* <declaration part> ::= <label declaration part> *)
(* <constant definition part> *)
(* <type definition part> *)
(* <variable declaration part> *)
(* <value part> *)
(* <module declaration part> *)
(* <procedure and function declaration part> *)
with attstack[newtop-3] do
begin
emitendnamelist(list);
if list<>nil then
begin
name:=list^.namelist;
if testoutput then
if name<>nil then writetree(name);
while name<>nil do
with name^ do
begin
if namekind=procname then
begin
if pmode=forw then markerror(145);
end
else
if namekind=funcname then
begin
if fmode=forw then markerror(145);
end;
name:=list;
end;
end;
ext:=globalmodule;
if (ext <> nil) and (ext <> attstack[oldtop-1].extmod) then
begin
while ext <> attstack[oldtop-1].extmod do
begin
ext:=ext^.next;
end;
end;
locallinenumber := 0;
emitrefname(eblockbegin,nam);
end;
1005:(* <procedure heading> ::= PROCEDURE <procedure name> *)
(* | PROCEDURE <procedure name> ( <formal parameter list> ) *)
with attstack[newtop] do
begin
if nam<>nil then
with nam^ do
begin
emitendnamelist(pparamlist);
if pmode=forw then
begin
identification:=identification+1;
emitbackref(identification,nam,plokvarlist);
checkparam(pparamlist^.namelist);
end
else emitname(nam);
end;
end;
1006:(* <procedure name> ::= NAME *)
begin
getprocname;
newblocklevel;
end;
1007:(* <formal parameter section> ::= <parameter group> : NAME *)
paramgroup(valparname,3);
1008:(* <formal parameter section> ::= VAR <parameter group> : NAME *)
paramgroup(varparname,4);
1009:(* <formal parameter section> ::= FUNCTION <parameter group> : NAME *)
paramgroup(ffuncname,4);
1010:(* <formal parameter section> ::= PROCEDURE <parameter group> *)
with attstack[oldtop] do
begin
typp:=nil;
attstack[newtop].nam:=nam;
addtypetolist(fprocname);
end;
1011:(* <parameter group> ::= <parameter group> , NAME *)
addnametolist(3,globalfieldlist);
1012:(* <parameter group> ::= NAME *)
begin
attstack[newtop].nam:=nil;
addnametolist(1,globalfieldllist);
end;
1013:(* <label list> ::= <label list> , KONST *)
newlabel(3);
1014:(* <label list> ::= KONST *)
newlabel(1);
1015:(* <type definition part> ::= TYPE <type definition list> *)
(* | EMPTY *)
begin
vardeclaration:=true;
while unsatptrtyplist<>nil do
with unsatptrtyplist^ do
begin
typ1:=ptrlistptr;
name:=searchname(ptrtypname^,level);
declar:=true;
if name=nil then
begin
markerror(138);
pointertotyp:=nil;
end
else
with name^ do
begin
pointertotyp:=typ;
emittype(unsatptrtyplist);
end;
unsatptrtyplist:=typ1;
end;
end;
1016:(* <value part> ::= <value start> <value list> ; *)
emitcode(eendvalue,nilref,nilref);
1017:(* <value start> ::= VALUE *)
emitcode(evalue,nilref,nilref);
1018:(* <value> ::= <value name> <const specification> *)
emitcode(evaluenaend,nilref,nilref);
1019:(* <value name> ::= NAME = *)
with attstack[newtop] do
begin
getname(1,namestring);
valtypp:=nil;
globalvalnam:=nil;
globalvaltypp:=nil;
count:=1;
globalvalcount:=1;
valnam:=searchfield(namestring,levels[leveltop].namelist);
if valnam=nil then markerror(116)
else
if valnam^.namekind<>varname then markerror(116)
else
with valnam^ do
begin
if initialized then markerror(153);
initialized:=true;
emitrefname(evaluename,valnam);
valtypp:=typ;
globalvaltypp:=valtypp;
end;
end;
1020:(* <const specification> ::= <constant> *)
begin
with attstack[newtop] do
if getbasetype(globalvaltypp) <> getbasetype(constant^.consttyp)
then
begin
i:=getstringlength(globalvaltypp,130);
if i <> 0 then
begin
i:=getstringlength(constant^.consttyp,130);
storevalue;
end;
end
else storevalue;
end;
1021:(* <const specification> ::= NIL *)
with attstack[newtop] do
begin
if globalvaltypp <> nil then
if globalvaltypp^.typkind <> pointertyp then markerror(130);
constant:=nilconst;
storevalue;
end;
1022:(* <const specification> ::= <structured const begin> <structured const> ) *)
with attstack[oldtop] do
begin
if valnam=nil then emitcode(eelementend,nilref,nilref)
else emitcode(efieldend,nilref,nilref);
if valtypp <> nil then
if valtypp^.typkind=recordtyp then
if (globalvaltypp <> nil) or (valtag <> nil) then markerror(151);
globalvaltypp:=valtypp;
globalvalnam:=valnam;
globalvalcount:=1;
if valtypp <> nil then
with valtypp^ do
if typkind=arraytyp then
begin
if indextyp <> nil then
with indextyp^ do
begin
i:=count;
if typkind =subrangetyp then i:=makeinteger(lastconst)
else
if typkind <> inttyp then i:=noofscalars;
if count-1 <> i then markerror(152);
end;
end;
if globalvalnam <> nil then
begin
globalvalnam:=globalvalnam^.list;
if globalvalnam=nil then globalvaltypp:=nil
else globalvaltypp:=globalvalnam^.typ;
end;
end;
1023:(* <constspecification> ::= <startconstset> <setconstlist> ] *)
(* | <startconstset> ] *)
with attstack[newtop+1] do
begin
emitcode(eendset,nilref,nilref);
if globalvaltypp <> nil then
with globalvaltypp^ do
begin
if typkind <> settyp then markerror(122)
else
if (getbasetype(setoftyp) <> valtypp)
and (valtypp <> nil) then markerror(122);
end;
emitstorevalue(globalvaltypp,valtypp,nil);
if globalvalnam <> nil then
begin
globalvalnam:=globalvalnam^.list;
if globalvalnam=nil then globalvaltyp:=nil
else globalvaltypp:=globalvalnam^.typ;
end;
globalvalcount:=1;
end;
1024:(* <structured const begin> ::= ( *)
with attstack[newtop] do
begin
valtypp:=globalvaltypp;
valnam:=globalvalnam;
if globalvalnam=nil then emitelementbegin(globalvaltypp,globalvalcount)
else emitrefname(efieldbegin,valnam);
if globalvaltypp=nil then markerror(151)
else getnextvalelement;
end;
1025:(* <structured const> ::= <str const elem> *)
attstack[newtop+1] := attstack[newtop-1];
1026:(* <str const elem> ::= <const specification> *)
attstack[newtop-1].count:=attstack[newtop-1].count+1;
1027:(* <str const elem> ::= <tagvalue> ( <structured const> ) *)
with attstack[newtop-1] do
begin
if globalvalnam <> nil then markerror(150);
valtypp:=nil;
valnam:=nil;
valtag:=nil;
end;
1028:(* <indexrange> ::= < <constant> .. <constant> ] *)
begin
with attstack[newtop-1] do
if valtypp = nil then markerror(119)
else
with valtypp^ do
if typkind=arraytyp then
begin
with attstack[newtop+1] do
begin
if constant^.consttyp <> attstack[newtop+3].constant^.consttyp then
markerror(104)
else (*test for correct index type*)
if getbasetype(indextyp) <> getbasetype(constant^.consttyp) then markerror(120)
else
begin
i:=makeinteger(constant);
if i <> attstack[newtop-1].count then markerror(148);
i:=makeinteger(attstack[newtop+3].constant)-i+1;
if i<1 then markerror(148);
globalvalcount:=i;
attstack[newtop-1].count:=attstack[newtop-1].count+i;
end;
end;
end
end;
1029:(* <tagvalue> ::= <constant> : *)
tagfield;
1030:(* <startconstset> ::= [ *)
begin
if globalvalnam=nil then emitelementbegin(globalvaltypp,globalvalcount)
else emitrefname(efieldbegin,globalvalnam);
emitcode(estartset,nilref,nilref);
attstack[newtop+1].valtypp:=nil;
end;
1031:(* <setconstlist> ::= <setconstlist> , <setconstelement> *)
with attstack[newtop] do
begin
if valtypp=nil then valtypp:=attstack[oldtop].valtypp
else
if attstack[oldtop].vartypp <> nil then
if vartypp <> attstack[oldtop].vartypp then markerror(122);
end;
1032:(* <setconstelement> ::= <constant> *)
begin
gettypeofconst(0);
emitarith(eset,attstack[newtop].vartypp,nil);
end;
1033:(* <setconstelement> ::= <constant> .. <constant> *)
begin
gettypeofconst(0);
gettypeofconst(2);
with attstack[newtop] do
begin
if valtypp <> attstack[oldtop].valtypp then markerror(122);
emitarith(esetrange,valtypp,nil);
end;
end;
1034:(* <module declaration part> ::= <module declaration part>
(* <external module>
(* <procedure or function heading list> END *)
with attstack[newtop+1] do
begin
if nam <> nil then
with nam^ do
begin
procfunclist:=list;
list:=nil;
end;
emitendlist(eendmodule);
end;
1035:(* <module declaration part> ::= EMPTY *)
attstack[newtop].extmod:=globalmodule;
1036:(* <external module> ::= EXTERNAL MODULE NAME : PASCAL *)
newextmodule(extpascal);
1037:(* <external module> ::= EXTERNAL MODULE NAME : FORTRAN *)
newextmodule(extfortran);
1038:(* <external module> ::= EXTERNAL MODULE NAME *)
newextmodule(extstand);
1039:(*procedure or function heading> ::= <procedure heading>
(* | <function heading> *)
leveltop:=leveltop-1
end;
end;
procedure chapter11;
(* Function declarations*)
var name:nameptr;
namestring:alfa;
level:integer;
typ:typptr;
begin
case prod of
1101:(* <function declaration> ::= <function heading> ; FORWARD *)
with attstack[newtop] do
begin
if nam<>nil then
with nam^ do
if fmode=forw then markerror(142)
else
begin
assignable:=false;
fmode:=forw;
end;
leveltop:=leveltop-1;
identification :=identification+1;
emit(identification,eforward,nilstr,enone,enone,enone,nilstr,nilref,nilref,nilref);
end;
1102:(* <function heading> ::= FUNCTION <function name> : NAME *)
(* | FUNCTION <function name> ( <formal parameter list> ) : NAME *)
with attstack[newtop] do
begin
getname(oldtop-newtop+1,namestring);
name:=searchname(namestring,level);
if name=nil then markerror(101)
else
if name^.namekind<>typname then markerror(107)
else
begin
typ:=getbasetype(name^.typ);
if not (typ^.typkind in [booleantyp,asciityp,
scalartyp,inttyp,realtyp,pointertyp]) then markerror(108)
else
if nam<>nil then
with nam^ do
begin
emitendnamelist(fparamlist);
if fmode=forw then
begin
identification:=identification+1;
emitbackref(identification,nam,flokvarlist);
checkparam(fparamlist^.namelist);
if name^.typ<>functyp then markerror(139);
end
else
begin
functyp:=name^.typ;
emitname(nam);
end;
end;
end;
end;
1103:(* <function heading> ::= FUNCTION <function name> ( <formal parameter list> ) *)
(* | FUNCTION <function name> *)
with attstack[newtop] do
begin
if nam<>nil then
with nam^ do
begin
if fmode<>forw then markerror(113)
else
begin
emitendnamelist(fparamlist);
identification:=identification+1;
emitbackref(identification,nam,flokvarlist);
checkparam(fparamlist^.namelist);
end;
end;
end;
1104:(* <function name> ::= NAME *)
with attstack[newtop-1] do
begin
getname(1,namestring);
with levels[leveltop] do
nam:=insertname(namestring,namelist,namelist);
if nam=nil then
begin (*might be forward declared *)
nam:=searchfield(namestring,levels[leveltop].namelist);
if nam=nil then markerror(102)
else
with nam^ do
begin
if namekind<>funcname then markerror(113)
else
begin
if fmode<>forw then markerror(113);
assignable:=true;
end;
end;
end
else
with nam^ do
begin
namekind:=funcname;
assignable:=true;
assigned:=false;
fmode:=internal;
flokvarlist:=nil;
fparamlist:=nil;
functyp:=nil;
end;
globalfieldlist:=newnamelist(paramnamelist);
emitnamelist(globalfieldlist);
if nam<>nil then
begin
with nam^ do
if fmode<>forw then fparamlist:=globalfieldlist;
end;
newblocklevel;
end
end;
end;
procedure chapter13;
(* Programs *)
var namestring:alfa;
headf:headfilptr;
name:nameptr;
level:integer;
procedure checkfilename;
var namestr:alfa;
begin
namestr:=headf^.filename;
outputfound:=outputfound or (namestr='OUTPUT ');
inputfound:=inputfound or (namestr='INPUT ');
headf:=headf^.nextheadfil;
while headf <> nil do
begin
if headf^.filename = namestr then markerror(160);
headf:=headf^.nextheadfil;
end;
end;
begin
case prod of
1301:(* <progrm> ::= <program heading> <block> *)
begin
emitcode(eendprogram,nilref,nilref);
headf:=unsatheadfil;
leveltop:=leveltop+1;
while headf<>nil do
begin
name:=searchname(headf^.filename,level);
if name=nil then markerror(141)
else
if name^.namekind<>filename then markerror(141);
headf:=headf^.nextheadfil;
end;
emitendnamelist(levels[-1].namelist);
ok:=false; (* stop reading sourcefile *)
if not printed then printline;
end;
1302:(* <program> ::= MODULE <module> . *)
emitcode(eendmodule,nilref,nilref);
1303:(* <program heading> ::= <program identifier> ( <program parameters> ) ; *)
with levels[-1] do
begin
if not outputfound then markerror(144);
emitname(attstack[newtop-1].nam);
end;
1304:(* <program identifier> ::= NAME *)
begin
readenvironment(blank);(*read standard environment*)
getname(1,namestring);
outputfound:=false;
name:=levels[leveltop].namelist^.namelist;
while name^.list <> nil do name:=name^.list;
new(name^.list);
name:=name^.list;
with name^ do
begin
identification:=identification+1;
ident:=identification;
lefttree:=nil;
righttree:=nil;
list:=nil;
namestr:=namestring;
namekind:=programname;
end;
attstack[newtop-1].nam:=name;
vardeclaration:=false;
leveltop:=leveltop+1;
with levels[leveltop] do
begin
leveltype:=programlevel;
end;
end;
1305:(* <file identifier> ::= NAME *)
begin
new(headf);
with headf^ do
begin
getname(1,filename);
new(externname);
externname^.length:=0;
nextheadfil:=unsatheadfil;
end;
unsatheadfil:=headf;
checkfilename;
end;
1306:(* <file identifier> ::= NAME = STRING *)
begin
new(headf);
with headf^ do
begin
getname(1,filename);
new(externname);
with externname^ do
getstring(3,1,str,length);
nextheadfil:=unsatheadfil;
end;
unsatheadfil:=headf;
checkfilename;
end;
1307:(* <module identifier> ::= NAME *)
begin
getname(1,namestring);
readenvironment(namestring);
emitmodule(namestring);
end
end;
end;
begin (*code*)
prod:=prodtab[prod];
if testoutput then outtest;(***snapshot***)
case prod div 100 of
0:;(*nothing is done on these productions*)
1:errorprod; (* Errorproductions in the parser *)
4:chapter4;(*productions corresponding to those in
chapter 4 of the PASCAL Report *)
5:chapter5;
6:chapter6;
7:chapter7;
8:chapter8;
9:chapter9;
10:chapter10;
11:chapter11;
13:chapter13
end;
end;(*code*)
(* BOBS PROCEDURES CONTINUATED*)
procedure stop;
begin
markerror(0);
writeln(output);writeln(output);
case n of
1: writeln(output,' *** PARSE STACK OVERFLOW. CONST ''STACKMAX'' TOO SMALL');
2: writeln(output,' *** END OF FILE ENCOUNTERED ');
3: writeln(output,' *** RECOVERY ABANDONED ');
4: writeln(output,' *** REDUCTION BUFFER OVERFLOW. CONST ''REDUMAX'' TOO SMALL');
5: writeln(output,' *** CONST ''STRINGMAX'' TOO SMALL ');
6: writeln(output,' *** CONST ''CHBUFMAX'' TOO SMALL ');
7: writeln(output,' *** CONST ''MAXLEVEL'' TOO SMALL ')
end;
goto 10; (*EXIT*)
end;(*STOP*)
procedure parser;
const
(*BOBS, CONSTANTS GENERATED BY THE GENERATOR *)
symbmax= 207;
prodmax= 289;
lrmax= 1129;
lxmax= 178;
errorval= 49;
nameval= 48;
constval= 47;
stringval= 50;
stringch='''';
combegin= 2;
comlength= 1;
(*BOBS*)
(*-END-OF-GENERATED-CONSTANTS-*)
realkonst=51;
skipch=' ';
(*-END-OF-PARSER-CONSTANTS-*)
type
symbol=0..symbmax;
errno=0..prodmax;
prodno=0..prodmax;
rslength=-1..symbmax;
mode=0..6;
lrinx=0..lrmax;
lrelm=packed record
chain: lrinx; (*NEXT ITEM IN THIS STATE*)
next: lrinx; (*NEXT STATE*)
case kind: mode of
1,2,4,6: (symb: symbol; err: errno);
0,3 : (rs: rslength; prod: prodno);
5: (lb: lrinx)
end;
lxinx=0..lxmax;
lxelm=packed record
np,hp: lxinx;
tv: symbol; ch:char
end;
stackelm=packed record
link: stackinx;
table: lrinx
end;
(*-END-OF-PARSER-TYPES-*)
var
lr: array[lrinx] of lrelm; (* LR-PARSE TABLES *)
parsestack: array[stackinx] of stackelm; (*PARSE STACK*)
entry: array[char] of lxelm;
lx: array[lxinx] of lxelm; (*LEXICAL TABLES*)
namech, (*CHARS USED IN NAMES*)
digitch:set of char; (*CHARS USED FOR DIGITS*)
newsymb: symbol; (*CURRENT TERMINAL SYMBOL*)
ch: char; (*CURRENT CHAR*)
stringescape: integer; (*INTERNAL VALUE OF THE STRINGESCAPE TERMINAL*)
oldbufi: chbufinx; (*FIRST CHAR IN CHBUF OF CURRENT LEXICAL TOKEN *)
moreinput:boolean; (*BECOMES FALSE WHEN INPUT IS EXHAUSTED*)
comend : array[1..comlength] of char ; (*STRING WHICH ENDS A COMMENT *)
(*-END-OF-PARSER-VARIABLES-*)
procedure dumplr;
var i:integer;
begin writeln(' I ',' CHAIN NEXT KIND SYMB PROD');
for i:=1 to lrmax do
with lr[i] do
begin write(' ',i:3,chain:6,next:5,kind:5);
case kind of
1,2,4,6: writeln(symb:5,err:5);
0,3 : writeln(rs:5,prod:5);
5: writeln(lb:5)
end
end
end;
(* PROCEDURES FOR INPUT/OUTPUT OF CHARACTERS*)
(*$R+*)
procedure readline;
var lgt : integer;
ch : char;
begin lineinx:=0; lgt:=-1; printed:=false; errorinx:=0;
if locallinenumber >= 0 then
locallinenumber := locallinenumber + 1;
linenumber:=linenumber+1;
emitcode(elinenumber,linenumber,nilref);
if eof(input) then moreinput:=false;
ch:=' ';
while (ch = ' ') and not eoln(input) do
begin
lgt:=lgt+1;
read(ch);
end;
indention:=lgt;
if not moreinput then ch := '.'; (* ch <> skipch *)
line[1]:=ch;
lgt:=2;
while not eoln(input) and (lgt<linemax) do
begin
read(line[lgt]); lgt:=lgt+1
end;
if eoln(input) then
begin
if not eof(input) then
readln;
line[lgt]:=' ';
end
else read(line[lgt]);
linelength:=lgt;
end; (*READLINE*)
procedure inchar;
begin
if lineinx=linelength then
begin
if not printed and moreinput then printline;
if errorinx>0 then writeln;
readline;
end;
lineinx:=lineinx+1;
ch:=line[lineinx];
if (ch>='a') and (ch <= 'z') then
ch := chr(ord(ch) - ord('a') + ord('A')); (* convert to upper case *)
end; (*INCHAR*)
(*$R-*)
(*END OF INPUT/OUTPUT PROCEDURES*)
procedure initialize(var tables : text);
var cc,ch1:char;
a,b,c,d,e,i:integer;
firstlb : integer;
newlb : boolean;
begin ok:=true; (* error:=false; *)
moreinput:=true; lineinx:=1; chbufi:=0;
linelength:=1; printed:=true; errorinx:=0;
parsestack[0].table:=0; attstack[0].chbufp:=chbufi;
ch:=' '; parsestack[0].link:=0;
digitch:=['0'..'9']; namech:=['A'..'Z','0'..'9','_'];
readln(tables,i); (* i := number of constants to skip *)
for i := i downto 1 do readln(tables);
for i:=1 to comlength do read(tables,comend[i]) ;
readln(tables) ;
for ch1:=minch to maxch do
begin readln(tables,cc,cc,a,b,c);
with entry[cc] do
begin
ch:=cc; np:=a; hp:=b; tv:=c
end
end;
entry['"']:=entry[''''];
for i:=0 to lxmax do
with lx[i] do
begin readln(tables,cc,cc,a,b,c);
ch:=cc; np:=a; hp:=b; tv:=c
end;
if stringch=' ' then (*STRING FACILITY IS NOT USED *) stringescape:=-2
else stringescape:= entry[stringch].tv;
newlb:=true;
for i:=0 to lrmax do
with lr[i] do
begin read(tables,a,b,c,d);
if c <> 5 then readln(tables,e) else readln(tables) ;
chain:=a; next:=b; kind:=c;
case c of
1,2,4,6: begin symb:=d; err:=e end;
0,3 : begin rs:=d; prod:=e end;
5 :begin lb:=d;
if newlb then
begin firstlb:=i; newlb:=false; end;
if a=0 then
begin
lr[firstlb].chain:=i;
newlb:=true;
end;
end
end
end
end;(*INITIALIZE*)
(*$R+*)
procedure lexical;
(*$R-*)
(* RETURNS NEXT TERMINAL IN NEWSYMB*)
var
newi: integer;
oldch: char;
lxnode: lxelm;
procedure skipcomment;
(* READ NEXT CHAR ON INPUT UNTIL COMEND IS RECOGNIZED *)
var option:alfa;
begin
if ch='$' then
begin (* OPTION*)
inchar;
if (ch >= 'A') and (ch <= 'Z') then ch := chr (ord(ch) + ord('a') - ord('A'));
(* convert upper case to lower case *)
option:=blank;
if ch in ['l', 't', 'r', 'c', '$'] then
while ch in ['l', 't', 'r', 'c'] do
begin
option[1]:=ch;
inchar;
if ch in ['+','-'] then
begin
option[2]:=ch;
emitoption(option);
inchar;
if ch=',' then inchar;
programlist:=(programlist or (option='l+ '))
and (option <>'l- ');
end
else markerror(143);
end
else markerror(143);
end;
if oldch='*' then
repeat
while ch<>'*' do inchar;
inchar;
until ch=')'
else
while ch<>'}' do inchar;
inchar;
end (* SKIPCOMMENT *) ;
(*$R+*)
procedure pushch;
(*$R-*)
begin
chbuf[chbufi]:=ch;
if chbufi<chbufmax then chbufi:=chbufi+1
else stop(6);
if testoutput then write(output,ch); (***SNAPSHOT***)
end; (*PUSHCH*)
procedure readstring;
var strch:char;
instring : boolean;
begin
strch:=oldch;
ch:=line[lineinx]; (* maybe ch was converted to upper case *)
instring := true;
while
( instring (* preceding character was not a string delimiter *)
or ( ch = strch ) (* this character is a delim *)
) and ( lineinx <> linelength ) (* stop at eoln *)
do
begin
instring := (ch <> strch) or not instring;
(* false at first delim after character, else true *)
if instring then pushch;
lineinx := lineinx + 1;
ch := line[lineinx]; (* inchar without converting to upper case *)
end;
if instring or (ch=strch) then markerror(167);
(* string did not terminate within line *)
newsymb:=stringval
end; (*READSTRING*)
begin (*LEXICAL*)
if testoutput then
begin
writeln(output); write(output,' LEXICAL: '); (***SNAPSHOT***)
end;
while ch = skipch do inchar;
oldbufi:=chbufi;
if not moreinput then
begin
if newsymb=0 then (*THIRD*) stop(2)
else
if newsymb=1 then (*SECOND*) newsymb:=0
else (*FIRST*) newsymb:=1
end
else
if ch in digitch then
begin (*KONST*)
repeat
pushch; inchar;
until not (ch in digitch);
newsymb:=constval;
if (ch='.') and (line[lineinx+1]<>'.') then
begin (*DECIMAL FRACTION*)
pushch; inchar;
if ch in digitch then
repeat
pushch; inchar;
until not (ch in digitch)
else markerror(100);
newsymb:=realkonst;
end;
if ch='E' then
begin (*EXPONENT*)
pushch; inchar;
if ch in ['+','-'] then
begin
pushch; inchar;
end;
if ch in digitch then
repeat
pushch; inchar;
until not (ch in digitch)
else markerror(100);
newsymb:=realkonst;
end;
end
else (* NOT KONST *)
begin (* SEARCH IN TERMTREE *)
pushch;
lxnode:=entry[ch]; newi:=lxnode.hp;
inchar;
if newi <> 0 then
repeat
if lx[newi].ch=ch then
begin pushch;
lxnode:=lx[newi];
newi:=lxnode.hp;
inchar
end
else newi:=lx[newi].np;
until newi=0;
oldch:=chbuf[chbufi-1];
if (oldch in namech) and (ch in namech) then
begin
repeat pushch;
inchar;
until not(ch in namech);
newsymb:=nameval
end
else
if lxnode.tv > 0 then (*VALID TERMINAL*)
begin
if lxnode.tv=realkonst then newsymb:=nameval
else
begin newsymb:=lxnode.tv;
chbufi:=oldbufi;
if newsymb=stringescape then readstring
else
if newsymb=combegin then begin skipcomment ; lexical end
end
end
else
if oldch in namech then newsymb:=nameval
else markerror(0)
end
end; (*LEXICAL*)
(*$R+*)
procedure parse;
const
redumax= 25; (* REDUCTION BUFFER SIZE *)
type
reduinx= 0..redumax;
reduelem= record
oldtop,newtop: stackinx;
prod: prodno
end;
var
redubuf: array[reduinx] of reduelem; (* REDUCTION BUFFER *)
redutop: reduinx;
stacktop,pseudotop,validtop,top : stackinx;
startinx,lri,start: lrinx;
procedure advance;
var i: integer;
begin
(*PERFORM REDUCTIONS*)
for i:=1 to redutop do
with redubuf[i] do
begin
if prodtab[prod] <> 0 then code(oldtop,newtop,prod);
attstack[newtop].chbufp:=attstack[newtop-1].chbufp
end;
(*UPDATE STACK*)
for i:=1 to stacktop-validtop do
parsestack[validtop+i]:=parsestack[top+i];
if redutop>0 then (* POSSIBLE POP OF CHBUF *)
if oldbufi=chbufi then (* NEWSYMB NOTIN [NAME,KONST,STRING]*)
chbufi:=attstack[stacktop-1].chbufp
else (*NEWSYMB IN [NAME,KONST,STRING]*)
attstack[stacktop].chbufp:=oldbufi;
(*SHIFT*)
if stacktop=stackmax then stop(1);
stacktop:=stacktop+1;
parsestack[stacktop].table:=startinx;
attstack[stacktop].chbufp:=chbufi;
(* FREEZE NEW STACK SITUATION, READY FOR NEW LOOKAHEAD *)
top:=stacktop; pseudotop:=stacktop; validtop:=stacktop;
start:=lri; redutop:=0
end; (*ADVANCE*)
procedure backtrack( btop: stackinx; bstart: lrinx);
begin
stacktop:= btop; validtop:= btop; pseudotop:= btop;
startinx:= bstart; lri:= bstart;
redutop:= 0
end; (* BACKTRACK *)
procedure pseudoshift;
begin
if pseudotop=stackmax then stop(1);
stacktop:= stacktop+1;
pseudotop:= top+(stacktop-validtop);
parsestack[pseudotop].table:= startinx;
attstack[pseudotop].chbufp:=chbufi;
end; (* PSEUDOSHIFT *)
function lookahead( lsymbol: symbol): boolean;
label 11,12;
var decided: boolean;
li,si,locallri,low,high,k,locallb: lrinx;
procedure queue( rs: rslength; p: prodno);
begin
if redutop=redumax then stop(4);
redutop:= redutop+1;
with redubuf[redutop] do
begin
oldtop:= stacktop; stacktop:= stacktop-rs; newtop:= stacktop;
if stacktop <= validtop then
begin
pseudotop:= stacktop; validtop:= stacktop
end else pseudotop:= pseudotop-rs;
prod:=p
end
end; (* QUEUE *)
begin
decided:= false;
locallri:=lri;
repeat
startinx:= locallri;
case lr[locallri].kind of
0: begin
decided:= true; lookahead:= true; ok:= false
end;
1: begin
while lr[locallri].symb<>lsymbol do
begin li:= lr[locallri].chain;
if li=0 then goto 11; (* EXIT LOOP *)
locallri:= li
end;
11: decided:= true; lookahead:= lr[locallri].symb=lsymbol
end;
2,4,6:
begin
while lr[locallri].symb<>lsymbol do
begin li:= lr[locallri].chain;
if li=0 then goto 12; (* EXIT LOOP *)
locallri:= li
end;
12: if lr[locallri].kind= 2 then
begin
decided:= true; lookahead:= true
end
else if lr[locallri].kind= 6 then
begin
pseudoshift;
stacktop:=stacktop-1; pseudotop:=pseudotop-1;
queue(-1,lr[locallri].err)
end
end;
3: begin
queue(lr[locallri].rs,lr[locallri].prod)
end;
5: begin
si:= parsestack[pseudotop].table;
low:=locallri;
locallri:=lr[locallri].chain;
high:=locallri-1;
while low < high do
begin
k:=(low+high) div 2;
locallb:=lr[k].lb;
if locallb > si then high:=k-1
else
if locallb < si then low:=k+1
else
begin
high:=k;
low:=high;
end;
end;
k:=(low+high+1) div 2;
if lr[k].lb = si then locallri:=k;
end
end; (* CASE *)
locallri:= lr[locallri].next;
until decided;
lri:=locallri;
end; (* LOOKAHEAD *)
procedure syntaxerror;
var success: boolean;
s,s1: stackinx;
begin
if testoutput then write(output,' <---SYNTAXERROR'); (***SNAPSHOT***)
markerror(lr[startinx].err);
backtrack(top,start);
pseudoshift;
s:= 0;
for s1:= 0 to top do
begin
backtrack(s1,parsestack[s1+1].table);
if lookahead(errorval) then
begin
parsestack[s1].link:= s; s:= s1
end
end;
success:= false;
repeat
s1:= s;
repeat
backtrack(s1,parsestack[s1+1].table);
if lookahead(errorval) then
begin
pseudoshift;
success:= lookahead(newsymb)
end;
s1:= parsestack[s1].link;
until (s1=0) or success;
if not success then
begin
(* MARK PREVIOUS SYMBOL SKIPPED *)
if testoutput then write(output,' <---SKIPPED'); (***SNAPSHOT***)
lexical
end;
until success or (not ok); (*MIDLERTIDIG*)
if not ok then stop(3)
end; (* SYNTAXERROR *)
begin (* PARSE *)
top:=0; start:=1;
backtrack(top,start);
while ok do
begin
lexical;
if not lookahead(newsymb) then syntaxerror;
advance;
end;
end; (*PARSE*)
(*$R-*)
begin (* PARSER *)
open(input,'pascaltable'); reset(input);
initialize(input);
close(input);
parse;
end; (*PARSER*)
begin
readcall;
initialize;
parser;
10:
if inputfile then close(input);
if errorcount > 0 then printerrors
else
begin
if (warningcount > 0) and (errorcount = 0) then
(* no errors but warnings *)
printerrors;
close(environment);
(* close(tables); *)
close(intermitfil);
replace('pascalpass2');
end;
end. (*BOBS*)
«eof»