⟦b472dd200⟧

TextFile

(*$R+ let main be resident *)
program pass2(input='pascalpif',output,slang);

label 9999,1;
(*$R- *)

const
version = 'pascal pass2 version   1980.06.17';
lowerror = 301;  (* first error number *)
higherror = 408; (* last error number  *)
alfalength  = 12;
maxident    = 3333; (* maximum number of nodeidents from pass1 *)
defaultcode   = 1500; (* default value of maxindex *)
alfatypeident = 97; (* to find the standard type alfa *)
maxbit      = 23;   (* number of bits in one CM-word minus 1*)
oneword     = 2;    (* number of addressing units (halfwords) in one CM-word *)
maxreg      = 3;    (* number of registers - 1 *)
noofreg     = 4;    (* number of registers *)
maxint          = 8388607;    (* 2**23 -1 *)
minint          =-8388608;    (* -2**23  *)
firstchar       = 32;
lastchar        = 126;
maxaddress      = maxint;
maxworkspace    = 2;    (* maximum number of words for temporary
storage in code *)
maxnest         = 20;   (* maximum depth of nesting of structure *)
maxparamoffset  = 512;  (* maximum number of halfwords for parameters *)
maxshortcopy    = 24;   (* maximum number of halfwords in shortcopy *)
maxordinal      = 2047; (* maximum ordinal number for variables *)
minparamordinal = -2036;(* ordinal of first parameter to a procedure *)
standardentries = 10;   (* space for running system entries, allocated in main instead of parameters *)
stringmax       = 100;  (* maximum length of a string *)
mintemporary    = 48;   (* minimum number of halfwords for temporaries *)
procdescrlength =  1;   (* procedure descriptor increment *)
intsize         = 2;    (* number of halfwords needed for an integer *)
realsize        = 4;    (* number of halfwords needed for a real *)
ptrsize         = 2;    (* number of halfwords needed for a pointer *)
setsize         = 12;   (* number of halfwords needed for a set *)
asciiperword    = 3;    (* number of chars held in one word *)
bitperascii     = 8;    (* number of bits used by one variable
of standard type ASCII *)
nilvalue        = -2047;(* value of the pointer constant NIL *)
stackaddr       = 2;    (* the register holding the address of current
activation record *)
blockmark       = 12;   (* size of fixed part of an activation record *)
returnaddroffset= -2041;(* offset in data block to return address *)
dynlinkoffset   = -2037;(* offset in data block to dynamic link *)
calloffset      = -2047;(* offset in main data block to address of call-routine *)
returnoffset    = -2045;(* offset in main data block to address of return-routine *)
stdcalloffset   = -2035;(* offset in main data block to address of standard-routine *)
erroroffset     = -2033;(* offset in main data block to address of error-routine *)
valueoffset     = -2031;(* offset in main data block to address of routine
to read in a block af values *)
binaryget = 28672;      (* library addr of binary get: 7 < 12 + 0 *)
binaryput = 28673;      (* library addr of binary put: 7 < 12 + 1 *)
newoffset       = -2029;(* offset in main data block to address of new *)
disposeoffset   = -2027;(* offset in main data block to address of dispose *)
maxsignedhalfword= 2047;
minsignedhalfword= -2048;
maxhalfword     = 4095;
maxcode         = 1018; (* maximum number of codewords and constants in one block *)
maxvalue        = 512;  (* maximum number of halfwords in valuelist *)
directmode      = false;(* addressing is direct *)
indirectmode    = true; (* addressing is indirect *)
reladdr         = true; (* address mode is relative *)
absaddr         = false;(* address mode is absolute *)
h0              = -36;  (* relative addr. of buffer and share descriptor *)
h4              = 8;    (* relative addr. of user's parameters part *)
h5              = 50;   (* length of zone descriptor in halfwords *)
h6              = 24;   (* length of share descriptor in halfwords *)
h20             = 360;  (* current input zone descriptor *)
h21             = 410;  (* current output zone descriptor *)
current_process = 66;
process_start   = 22;
filenamelength  = 8;    (* length of file name in halfwords *)
bufferlength    = 512;  (* length of file buffer in halfwords *)
segmentlgt      = 512;  (* length in halfwords of a segment on disc *)

type
addressrange    = 0..maxaddress;
nodeident       = 0..maxident;
halfword        = 0..maxhalfword;
signedhalfword  = minsignedhalfword..maxsignedhalfword;
bitrange        = 0..maxbit;
regrange        = 0..maxreg;
stringrange     = 1..stringmax;

symbolptr       = ^symbolnode;
pseudoptr       = ^pseudonode;
stringptr       = ^stringnode;
setptr          = ^setnode;
addrptr         = ^addrnode;
codeptr         = ^codenode;
caselabptr      = ^caselabnode;
valueptr        = ^valuenode;
jumpchainptr    = ^jumpchainnode;

packkind  = (paack, unpack, hlfword, signedhlfword);
ckind     = (signedshortconst,
wordconst, realconst, setconst, stringconst);
valuekind = (procfunc, expression, variable, tmp,
wordcst, shortsignedcst, longcst, reg, valueinit);
skipkind  = (skipfalse, skiptrue, noskip);

intmtwords = (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);

operators = eset..eendcall;
mkind = esystem..estandard;

standards =  (ps_put,     ps_get,     ps_reset,   ps_rewrite, ps_new,
ps_dispose, ps_read,    ps_readln,  ps_write,   ps_writeln,
ps_page,    ps_open,    ps_close,   ps_putrand, ps_getrand,
ps_pack,    ps_unpack,
fs_abs,     fs_sqr,     fs_sin,     fs_cos,     fs_exp,
fs_ln,      fs_sqrt,    fs_arctan,  fs_odd,     fs_eof,
fs_eoln,    fs_trunc,   fs_round,   fs_ord,     fs_chr,
fs_succ,    fs_pred ,   fs_sinh,    fs_arcsin,  fs_system,
fs_monitor, fs_clock,   ps_date,    ps_time,    ps_replace,
last_std );

opcodes =    (aw, d0, bl, hl, la, lo, lx, wa, ws, am,
wm, al, ri, jl, jd, je, xl, bs, ba, bz,
rl, sp, re, rs, wd, rx, hs, xs, gg, di,
d2, d1, ci, ac, ns, nd, as, ad, ls, ld,
sh, sl, se, sn, so, sz, sx, gp, fa, fs,
fm, ks, fd, cf, dl, ds, aa, ss);
(* d1, d2 are nonexisting opcodes*)

addrnode = packed record
case boolean of
false: (
index : pseudoptr;
packk:packkind;
bitstart:bitrange;
case simpleaddr:boolean of
true : (blocknumber,ordinal:integer);
false : (postordinal:integer;
reference:addrptr)
);
true: ( zzint : integer;);
end;

symbolnode =
packed record
next : symbolptr; (* to chain elements in free list *)
case key : intmtwords of
ename : ( case namekind : intmtwords of
econst : (constname: alfa;
constant : symbolptr ) ;
etype : ( typdescr : symbolptr ) ; (* not used *)
effunc, evar,
efield, evarparam,
evalparam, etagfield,
efile,
efproc : ( vartypedescr : symbolptr ;
varaddr : addrnode;
case boolean of
true : ( valparordinal : integer);
false : ( extname : stringptr) );
eprogram,
efunc,
eproc : ( routinename : ^alfa;
functype : symbolptr ;
blocklevel : signedhalfword;
coreresident : boolean;
case standard : boolean of
true : ( stnd_name : standards ) ;
false : (starttmp, availtmp : signedhalfword;
declarationlist,
paramlist : symbolptr;
routinedescr : integer ));
emodule : (modulename : alfa;
modulekind : mkind) );
econst : ( consttype : symbolptr ;
startchain, constindex : integer;
case constkind : ckind of
signedshortconst,
wordconst : (intval : integer);
realconst : (realval : real);
setconst : (setval : setptr);
stringconst : (stringval : stringptr) ) ;
elabel : ( labellevel : halfword;
labelordinal : signedhalfword;
labeladdroffset, procaddr : integer );
etype : ( packedtype : packkind ;
size : addressrange ;
bitsize : halfword; (*Used for packing*)
case typkind : intmtwords of
esubrange : ( subtyp : symbolptr ;
firstconst,
lastconst : integer ) ;
einteger,
ereal : (noth: 0..0);
escalar, eboolean,
eascii : ( lastscalar : integer;
namelist : addressrange ); (* number of the list of scalarnames *)
estring : ( length : stringrange ) ;
earray: ( indextyp, valtyp : symbolptr ;
packedval,     (* true if array elements are packed *)
stringcomp : boolean);
erecord : ( varlist : symbolptr );
eset : ( setoftyp : symbolptr ) ;
efile : ( randomfile : boolean ;
fileindextyp,elementtyp : symbolptr ) ;
epointer : ( pointertotyp : symbolptr ) ) ;
enamelist : (case listkind : intmtwords of
efix : (byteoffset : integer;
bitoffset : halfword;
packlist : boolean;
lastfixlist,oldvarlist : symbolptr );
edeclaration : (discaddr, codelength,
maxstackoffset, startline, firstlineofproc : integer );
eparam : (displayoffset : signedhalfword;
initlist : valueptr;
valuesegment, lengthofvalue : integer;
filelist,        (* list of local files *)
copyvalparam : symbolptr ); (* list of value parameters to copy at entry *)
escalarlist : ( nothi:0..0 ));
etagelement : ( labellist, nexttag, varlst : symbolptr ;
tagsize : addressrange ) ;
ecaselist,
erecordlabel : ( reclabvalue : integer ;
nextreclab : symbolptr ) ;
evarlist : ( fixsize : addressrange ;(* length of preceeding fixlist *)
taglist : symbolptr )
end ;

stringnode = record
next : stringptr;
length : 0..stringmax;
returnable : boolean; (* true if this node may be returned after use *)
case boolean of
false: (str : packed arrayÆstringrangeÅ of char);
true: (alfastr : packed arrayÆ1..alfalengthÅ of char);
end;

setnode = record
case integer of
0 : (val : set of 0..71);
1 : (hlfwords : packed arrayÆ1..setsizeÅ of halfword);
2 : (bits : packed arrayÆ0..143Å of 0..1);
end;


pseudonode = packed record
typ : symbolptr;
next : pseudoptr;
case kind : valuekind of
procfunc : (symb : symbolptr ); (* procedure as parameter or a functioncall *)
expression : ( leftoperand,rightoperand : pseudoptr;
operator : operators);
variable,tmp : (addr : addrnode);
shortsignedcst,
wordcst : (constant : integer);
longcst : (constptr : symbolptr);
reg :     (regno:regrange;
sameregister : pseudoptr);
valueinit : (valcount : integer;
pack : boolean);

end;


packindicator = record (* used for packed arrays to communicate the element size *)
size : integer; (* and the bitstart (kept in a register connected to ps)  *)
ps : pseudoptr;  (* between the procedures that have to load/store an element *)
end;

regnode = record
user : pseudoptr; (*pseudonodes using the register*)
valid : boolean; (* flag telling if the content of the register is meaningfull *)
lastused : addressrange;
case kind:valuekind of
variable,
tmp: (locassociated : boolean; (*tells if the variable has a
location associated or not (used for temporary var's) *)
addr:addrnode);
shortsignedcst, wordcst : (constant : integer);
longcst : (constptr : symbolptr)
end;

nestingnode = record
startindex, index : integer;
case intmtwords of
eif : (skipif : skipkind); (* used by IF <constant> ... *)
ecase : (labelchain : caselabptr;
lowlabel,highlabel : integer;
otherw : boolean);
ewithvar : (withvar : pseudoptr);
efor : (stepregister : regrange);
ecallproc,
ecallfunc : (procfunc : symbolptr;
oldtop : pseudoptr);
end;

jumpchainnode = record
next : jumpchainptr;
jumpindex : integer;
end;

caselabnode = record
next : caselabptr;
labval : integer;
codindex : integer;
end;

opnode = packed record
case  integer of
0 : (opcode : opcodes;
w : regrange;
relative : boolean;
indirect : boolean;
index : regrange;
displacement : signedhalfword);
1 : (constval : integer);
2 : (realval1 : integer);
3 : (realval2 : integer);
4 : (str : packed arrayÆ1..asciiperwordÅ of char);
5 : (half1,half2 : halfword);
end;

codenode  =record
case integer of
1    : (c : arrayÆ1..6000Å of opnode);
500  : (code500 : arrayÆ1..500Å of opnode);
1000 : (code1000 : arrayÆ1..1000Å of opnode);
1500 : (code1500 : arrayÆ1..1500Å of opnode);
2000 : (code2000 : arrayÆ1..2000Å of opnode);
2500 : (code2500 : arrayÆ1..2500Å of opnode);
3000 : (code3000 : arrayÆ1..3000Å of opnode);
3500 : (code3500 : arrayÆ1..3500Å of opnode);
4000 : (code4000 : arrayÆ1..4000Å of opnode);
4500 : (code4500 : arrayÆ1..4500Å of opnode);
5000 : (code5000 : arrayÆ1..5000Å of opnode);
5500 : (code5500 : arrayÆ1..5500Å of opnode);
6000 : (code6000 : arrayÆ1..6000Å of opnode);
end;

valuenode = record
next : valueptr;
ordinal : integer;
initval : opnode;
end;

var
slangmode, printproctable, compilertest : boolean; (* for test only *)
slang : file of integer; (* for slang code *)
linetable : file of integer; (* holds correspondence between
linenumbers and codeaddresses *)
index : array ÆnodeidentÅ of symbolptr;
code : codeptr;
codefilename : alfa;
lefthandside : boolean;
strnodecount,           (* number of used string nodes *)
addrnodecount,          (* number of used address nodes *)
psnodecount,            (* number of used pseudo nodes *)
caslabcount,            (* number of used case label nodes *)
valnodecount,           (* number of used value nodes *)
symbnodecount,          (* number of used symbol nodes *)

i, l,
inputordinal,           (* ordinal of pointer to file INPUT *)
outputordinal,          (* ordinal of pointer to file OUTPUT *)
valueword,              (* the last value read *)
wordoffset,             (* offset to the next word to initialize in value *)
nextbit,                (* offset to the next bit to initialize in value *)
noofvalue,              (* number of words to initialize in this value-part *)
highvalue,              (* highest offset in value-part *)
paramoffset,            (* offset to last parameter put on stack *)
maxstack,               (* offset to top of current activation record *)
linetablelgt,           (* number of words in line table *)
lengthofentrycode,      (* number of instructions in the entry code part *)
codesegment,            (* number of first free segment of code *)
lastindex,              (* index to the last used codenode *)
heapsize,               (* startsize for heap *)
maxindex,               (* index to the highest allocated codenode *)
outconstlimit,          (* when codeallocation reaches this index
all constants must be allocated *)
ndepth,                 (* temporary, holding depth of nesting *)
display,                (* offset to the first word in current display *)
currentline,            (* last linenumber read *)
procfuncoffset,         (* first free byteaddress in the block of
procedure/function addresses *)
programident,           (* the PIF-identification of the program name *)
lastnodeident,          (* indexÆlastnodeidentÅ points to last entered node in symboltable *)
labnumber,              (* the start of a possible label list *)
namelistsize,           (* length of last namelist,fix or varlist *)
localordinal,           (* first free byteaddress relative to current blockaddress *)
fstfreetmp,             (* index of the first free temporary location *)
nooffreetmp,            (* number of free temporary locations *)
level   : integer;      (* current level of block ( an even number ) *)
packedvalue,             (* true if the fields are packed used in value-part *)
resident,                (* true if procedures must be core resident *)
lineoutput,              (* true if line numbers must be remembered
for error checking *)
noconstcheck,            (* false if subrange check was performed on constant *)
check,                   (* true if the optional checking is on *)
alwayscheck,               (* true if index check always should be performed *)
standenvir : boolean;    (* true while reading standard environment *)

s, s1,                      (* temporaries *)
intchain,                   (* chain of integer constants in this block *)
constchain,                 (* chain of other constants used in this block *)
settype,                    (* type of the empty set *)
inputfilename,              (* standard file input, if in programhead *)
outputfilename,             (* standard file output *)
integertype,                (* standard type integer *)
booltype,                   (* standard type boolean *)
realtype,                   (* standard type real *)
alfatype,                   (* standard type alfa *)
asciitype,                  (* standard type ascii *)
fieldlist,                  (* list of fields in last allocated word *)
sortlist,                   (* sorted list of not yet allocated variables *)
scalartype,                 (* holding the type when reading scalarlist *)
freesymbol,                 (* list of free symbolnodes *)
currentproc,                (* last entered procedure *)
currentmodule,              (* if reading a <module declaration part> then
the last module name else NIL *)
currentcase,                (* last label in record *)
currentvarlist,             (* last entered varlist *)
currentfixlist : symbolptr; (* pointer to last entered fixlist *)

ps, pseudo, leftps,         (* temporaries *)
powersetpseudo,             (* the constant part of a powerset *)
freepseudo,                 (* free list of pseudoptr *)
pseudotop : pseudoptr;      (* top of the pseudoevaluationstack *)

freestring : stringptr;     (* free list of stringnodes *)

sett : setptr;              (* temporary *)
freeaddress,                (* free list of address nodes *)

address : addrptr;          (* temporary *)

lab,
freecaselab : caselabptr;   (* list of free caselabnodes *)

shortjumps : jumpchainptr;  (* list of index to chain of not yet
finished short jumps *)
freevalue,                  (* list of free valuenodes *)
valuelist : valueptr;       (* chain of valuenodes *)

standardcounter : standards;(* next standard function/procedure number
in PIF *)

intermitword : intmtwords;

powerset : setnode;       (* the constant part of a set, while reading
the set specification *)
chartonumber : arrayÆ'0'..'F'Å of integer;
konvrelation : arrayÆelt..egtÅ of elt..egt;
stdroutine : arrayÆps_put .. last_stdÅ of integer; (* holds procedure/function number *)
readkind : arrayÆescalar .. easciiÅ of integer;
writekind : arrayÆescalar .. estringÅ of integer;
neststack : arrayÆ1..maxnestÅ of nestingnode;
workspace : arrayÆ1..maxworkspaceÅ of integer; (* index to a chain of opcodes
using temporary storage in code *)
power : arrayÆ0..maxbitÅ of integer; (* power of two *)
mnemonics : arrayÆopcodesÅ of packed arrayÆ1..2Å of char;

register : array Æ0..maxregÅ of regnode; (* internal register descriptors *)
bitmask : array Æ0..24Å of integer; (* masks for packing and unpacking *)
packptr : packindicator;
errormarks : packed array Æ lowerror .. higherror Å of boolean;
errorcount : integer;

value
(*make some bitmasks for unpacking*)
bitmask= (       0, (* 2**0 - 1  *)
1, (* 2**1 - 1  *)
3, (* 2**2 - 1  *)
7, (* 2**3 - 1  *)
15, (* 2**4 - 1  *)
31, (* 2**5 - 1  *)
63, (* 2**6 - 1  *)
127, (* 2**7 - 1  *)
255, (* 2**8 - 1  *)
511, (* 2**9 - 1  *)
1023, (* 2**10 - 1 *)
2047, (* 2**11 - 1 *)
4095, (* 2**12 - 1 *)
8191, (* 2**13 - 1 *)
16383, (* 2**14 - 1 *)
32767, (* 2**15 - 1 *)
65535, (* 2**16 - 1 *)
131071, (* 2**17 - 1 *)
262143, (* 2**18 - 1 *)
524287, (* 2**19 - 1 *)
1048575, (* 2**20 - 1 *)
2097151, (* 2**21 - 1 *)
4194303, (* 2**22 - 1 *)
8388607, (* 2**23 - 1 *)
-1); (* 2**24 - 1 *)
(* initialize the registers *)

register = (<0..3>*(nil,false,0,longcst:(nil)));
strnodecount = 0;
addrnodecount = 0;
psnodecount = 0;
caslabcount = 0;
valnodecount = 0;
symbnodecount = 0;
compilertest = false;
printproctable = false;    (* option  survey.no  default *)

slangmode=false;           (* option   c-  default *)
inputordinal = minsignedhalfword;
outputordinal = minsignedhalfword;
paramoffset=-2;
linetablelgt = 0;
lastindex = 0;
heapsize = 0;
currentline = 0;
procfuncoffset =0;
localordinal = minparamordinal;   (* ... or some similar value, used when reading environment *)
level=-4;
ndepth = 0;
resident = false;
lineoutput = false;
check = true;
alwayscheck = false;  (* set by option 't+' *)
standenvir =true;

intchain=nil;
constchain=nil;
inputfilename = nil;
fieldlist = nil;
sortlist = nil;
freesymbol = nil;
currentproc = nil;
currentmodule = nil;
currentcase = nil;
currentvarlist = nil;
currentfixlist = nil;
freeaddress = nil;

freepseudo = nil;
pseudotop = nil;

freestring = nil;

freecaselab = nil;
shortjumps=nil;

freevalue = nil;
valuelist = nil;

standardcounter =ps_put;

chartonumber= (0, 1, 2, 3, 4, 5, 6, 7, 8, 9, <':' .. '@'>*0, 10, 11, 12, 13, 14, 15);

konvrelation= (egt, ege, ele, elt);

stdroutine= (20482, 24578, 16386, 16388, newoffset,
disposeoffset, 24576, 24577, 20480, 20481,
20482, 16384, 16390, 1, 1,
28674, 28676, 0, 0, 12294,
12292,  4098,  4096,  8194, 12288,
0, 0, 1, 1, 1,
1, 1, 1, 1, 4100,
8192, 4102, 16396, 4104, 8196,
8198, 16394, 0);
(* const  binaryget = 7 < 12 + 0;
binaryput = 7 < 12 + 1; *)

readkind= (0,  6,  8,  0,  0);

writekind= (0,
32770,   (* default format 8 *)
57344,   (* default format 14 *)
24580,   (* default format 6 *)
4102,    (* default format 1 *)
8);      (* default format length of string *)
workspace= (0,0);

power= (1, 2, 4, 8, 16, 32, 64, 128,
256, 512, 1024, 2048, 4096, 8192, 16384, 32768,
65536, 131072, 262144, 524288, 1048576, 2097152, 4194304, -8388608);

mnemonics = ('aw', 'do', 'bl', 'hl', 'la', 'lo', 'lx', 'wa', 'ws', 'am',
'wm', 'al', 'ri', 'jl', 'jd', 'je', 'xl', 'bs', 'ba', 'bz',
'rl', 'sp', 're', 'rs', 'wd', 'rx', 'hs', 'xs', 'gg', 'di',
'd2', 'd1', 'ci', 'ac', 'ns', 'nd', 'as', 'ad', 'ls', 'ld',
'sh', 'sl', 'se', 'sn', 'so', 'sz', 'sx', 'gp', 'fa', 'fs',
'fm', 'ks', 'fd', 'cf', 'dl', 'ds', 'aa', 'ss');
errormarks = (<lowerror .. higherror> * false );
errorcount = 0;





procedure error(number:integer);
begin
writeln( 'error no', number : 4, ' in line no ', currentline : 1 ) ;
errorcount := errorcount + 1;
errormarks Æ number Å := true;
end;(*PROCEDURE error*)

procedure printerrors;
var
i, currenttextno : integer;
ch : char;
begin
page(output);
writeln(output,'number of errors  :', errorcount : 4);
writeln(output);
writeln(output,'error  description');

open(input,'pascalenv');
reset(input);

(* scan the environment file until end of standard environment *)
repeat
readln(ch);
until ch = '*'; (* the environment must be separated from the errortext by
at least one line starting with an '*' !!!!!!!! *)
repeat
readln(i);
until i = 22222; (* pass 2 errors must be preceded by a line starting with '22222'  !!!!!!! *)


currenttextno := lowerror - 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 := ....  *)
close ( input );
end; (* printerrors *)



procedure stop(no : integer);
begin
error(no);
writeln(' fatal error, compilation stops');
goto 9999;
end;


function getnumber:integer;
var
n:integer;
begin
read(n);
getnumber:=n;
end;

procedure readalfa( var alf : alfa ) ;
var
i : integer ;
a : arrayÆ1..alfalengthÅ of char;

begin
i:=1;
repeat
read(aÆiÅ);
i:=i+1;
until input^=' ';
for i := i to alfalength do aÆiÅ:=' ';
pack(a,1,alf);
end ;

function getintmtwords : intmtwords ;
(* reads in a coded PIF word ( not nessecarily an opcode ) *)

var
cheat :
record
case boolean of
false : ( a : intmtwords ) ;
true : ( b : integer ) ;
end ;

begin
read( cheat.b ) ;
getintmtwords := cheat.a ;
end ;

function getsymbptr : symbolptr ;
(* reads a nodeident (a <ref> or an (N) ) from input and converts it *)
(* into the corresponding symbolptr *)

var n : integer ;
symbol : symbolptr;

begin
read( n ) ;
get(input); (* skip space *)
if n > maxident then error(401)
else
if n= 0 then getsymbptr := nil
else
begin
if indexÆ n Å = nil (* i. e. this entrance has not been referenced before *)
then
begin
if freesymbol = nil then
begin
symbnodecount := symbnodecount + 1;
new(symbol);
end
else
begin
symbol := freesymbol;
freesymbol := symbol^.next;
end;
lastnodeident := n;
indexÆnÅ := symbol;
end ;
getsymbptr := indexÆ n Å ;
end;
end ;

procedure forgetsymbptr(ident:nodeident) ;
(* may only be used when one know for sure, that the nodeident
will never be referenced later on *)

var
symbol:symbolptr;
begin
symbol:=indexÆidentÅ;
if symbol <> nil then
begin
indexÆidentÅ:=nil;
symbol^.next:=freesymbol;
freesymbol:=symbol;
end;
end ;

function newstring:stringptr;
var string : stringptr;
begin
if freestring=nil then
begin
strnodecount := strnodecount + 1;
new(string);
end
else
begin
string:=freestring;
freestring:=string^.next;
end;
string^.returnable:=true;
newstring:=string;
end;

procedure returnstring(string:stringptr);
begin
if string <> nil then
if string^.returnable then
begin
string^.next:=freestring;
freestring:=string;
end;
end;

function newaddress : addrptr;
var 
adr : addrptr;
begin
if freeaddress = nil then
begin
addrnodecount := addrnodecount + 1;
new(adr);
end
else
begin
adr := freeaddress;
freeaddress := adr^.reference;
end;
adr^.reference := nil;
newaddress := adr;
end;


procedure returnaddress(var adr : addrptr);
(* return the list of address nodes starting at adr *)
var
boo : boolean;
adr1 : addrptr;
begin
if compilertest then
begin adr1 := nil;
repeat
with adr^ do
begin
boo := simpleaddr;
simpleaddr := false;
if not boo then adr1 := reference else adr1 := nil;
reference := freeaddress; freeaddress := adr;
zzint := -20000;
postordinal := 1000000;
end;
adr := adr1
until boo;
end
else
begin
adr1 := adr;
while not adr1^.simpleaddr do
adr1 := adr1^.reference;

(*
writeln(currentproc^.routinename^,
currentline - currentproc^.declarationlist^.firstlineofproc,
ord(adr), ord(adr1), ord(freeaddress));
*)
with adr1^ do
begin
simpleaddr := false;
reference := freeaddress;
end;
(* freeaddress := adr;  no reuse of the nodes *)
adr := nil;
end;
end; (* return address chain *)

function newpseudo:pseudoptr;
var ps:pseudoptr;
begin
if freepseudo = nil then
begin
psnodecount := psnodecount + 1;
new(ps);
end
else
begin
ps:=freepseudo;
freepseudo:=ps^.next;
end;
newpseudo:=ps;
end;

procedure returnpseudo(var ps:pseudoptr);
(* return the pseudonode pointed to by ps
to the free list and set the parameter to ps^.next.
If ps is pointed to by a registernode then
remove ps from this register. *)
var pseudo, pseudo1 : pseudoptr;
size : integer;
begin
if ps <> nil then
begin
pseudo:=ps;
if pseudo^.kind=reg then
with registerÆpseudo^.regnoÅ do
begin
if user = pseudo then user:=pseudo^.sameregister
else
begin
pseudo1:=user;
while pseudo1 <> nil do
begin
if pseudo1^.sameregister = pseudo then pseudo1^.sameregister:=pseudo^.sameregister;
pseudo1:=pseudo1^.sameregister;
end;
end;
end
else
if pseudo^.kind = tmp then
begin (* return temporary storage *)
size:=pseudo^.typ^.size;
nooffreetmp:=nooffreetmp+size;
fstfreetmp:=fstfreetmp-size;
end;

with pseudo^ do
if (kind = tmp) or (kind = variable) then
if not addr.simpleaddr then
returnaddress(addr.reference);



ps:=pseudo^.next;
pseudo^.next:=freepseudo;
freepseudo:=pseudo;
end;
end;

function newcaselab:caselabptr;
var cas:caselabptr;
begin
if freecaselab = nil then
begin
caslabcount := caslabcount + 1;
new(cas);
end
else
begin
cas:=freecaselab;
freecaselab:=cas^.next;
end;
newcaselab:=cas;
end;

procedure returncaselab(cas:caselabptr);
(* return the caselabnode pointed to by cas
to the free list *)
begin
if cas <> nil then
begin
cas^.next:=freecaselab;
freecaselab:=cas;
end;
end;

function newvalue:valueptr;
var val:valueptr;
begin
if freevalue = nil then
begin
valnodecount := valnodecount + 1;
new(val);
end
else
begin
val:=freevalue;
freevalue:=val^.next;
end;
newvalue:=val;
end;

procedure returnvalue(var val:valueptr);
(* return the valuenode pointed to by val
to the free list *)
var
valu : valueptr;
begin
valu:=val;
if valu <> nil then
begin
val:=valu^.next;
valu^.next:=freevalue;
freevalue:=valu;
end;
end;
procedure comptestoutput;
(* if  compilertest then produce statistics about the heap usage *)

var count : integer;
begin
page(output);
writeln(output,' information about the amount of used heap storage');
writeln(output);
writeln(output,' ':17, 'max number of used nodes  number of returned nodes');
count := 0;
while freestring <> nil do
begin
count := count + 1;
freestring := freestring^.next;
end;
writeln(output, 'string nodes     : ', strnodecount, count : 25);
count := 0;
while freeaddress <> nil do
begin
count := count + 1;
freeaddress := freeaddress^.reference;
end;
writeln(output,'address nodes    : ', addrnodecount, count : 25);

count := 0;
while freepseudo <> nil do
begin
count := count + 1;
freepseudo := freepseudo^.next;
end;
writeln(output, 'pseudo nodes     : ',psnodecount, count : 25);
count := 0;
while freecaselab <> nil do
begin
count := count + 1;
freecaselab := freecaselab^.next;
end;
writeln(output,'case label nodes : ',caslabcount, count : 25);
count := 0;
while freevalue <> nil do
begin
count := count + 1;
freevalue := freevalue^.next;
end;
writeln(output,'value nodes      : ',valnodecount, count : 25);
count := 0;
while freesymbol <> nil do
begin
count := count + 1;
freesymbol := freesymbol^.next;
end;
writeln(output,'symbol nodes     : ',symbnodecount, count : 25);
end;




procedure initialize;
var
ch : char;
codesize, i, codeword : integer;
paslib : file of integer;  (* file containing the entry code to copy *)
begin (* initialize *)
if compilertest then writeln(output,version);
lefthandside := false;
for i := 0 to maxident do indexÆ i Å := nil ;
codesize:=defaultcode;
rewrite(linetable);

new(settype); (* type of a constant set *)
with settype^ do
begin
key:=etype;
packedtype:=unpack;
size:=setsize;
typkind:=eset;
setoftyp:=nil;
end;

intermitword:=getintmtwords;
while intermitword = eoption do
begin
get(input);
read(ch);
if ch = 'f' then
begin
get(input);
get(input);
readalfa(codefilename);
lefthandside := true;
end
else if ch = 'h' then read(heapsize)
else if ch = 's' then read(codesize)
else if ch = 'p' then
begin
printproctable := true;
readln; (* skip 'yes' *);
end;
intermitword:=getintmtwords;
end;
if lefthandside then
begin
open(slang,codefilename);
rewrite(slang);

(* copy entry code from pascallib *)
open(paslib,'pascallib'); (* do not care about a warning (165) *)
reset(paslib);
read(paslib,i, lengthofentrycode); (* skip word(0) *)
for i := 1 to lengthofentrycode do
begin
read(paslib,codeword);
write(slang,codeword);
end;
close(paslib);
open(paslib,'           '); (* do not call remove entry with name=pascallib *)

for i := 1 to ((segmentlgt -
((lengthofentrycode*oneword) mod segmentlgt)) mod segmentlgt) div oneword do
write(slang,0); (* fill the segment *)
codesegment := (lengthofentrycode * oneword + (segmentlgt-1)) div segmentlgt;

end;
heapsize:=heapsize*oneword;
if codesize < 0 then codesize:=0
else
if codesize>6000 then codesize:=6000;
codesize:=(codesize+499) div 500;
maxindex:=codesize*500;
case codesize of
0,1:begin
maxindex:=500;
new(code,500);
end;
2:new(code,1000);
3:new(code,1500);
4:new(code,2000);
5:new(code,2500);
6:new(code,3000);
7:new(code,3500);
8:new(code,4000);
9:new(code,4500);
10:new(code,5000);
11:new(code,5500);
12:new(code,6000);
end;
end;

procedure routinedescriptorwords;
(* output the words which describes the procedures/functions as the
last segment of a program *)
var i, l, int,  lengthofcode, no_of_resident, erroraddr, procaddr, infaddr : integer;
tail : array Æ1..10Å of integer;

begin
lengthofcode:=0;
no_of_resident:=0;
erroraddr:=codesegment;
reset(linetable);
if lefthandside then
for l:=1 to linetablelgt do
begin
read(linetable,int);
write(slang,int);
end;
int := 0;
if lefthandside then
for i := 1 to ((segmentlgt-((linetablelgt*oneword) mod segmentlgt))
mod segmentlgt) div oneword do
write(slang,int);
codesegment:=(linetablelgt*oneword+(segmentlgt-1)) div segmentlgt + codesegment;
procaddr := codesegment;
l := 0; (* only used if slangmode = true *)
lastindex := 0;
for i:=programident to lastnodeident do
if indexÆiÅ <> nil then
with indexÆiÅ^ do
begin
if key = ename then
if (namekind = eproc) or (namekind = efunc) or (namekind = eprogram) then
begin
if coreresident then
begin
no_of_resident:=no_of_resident+1;
code^.cÆno_of_residentÅ.constval:=routinedescr;
end;
with declarationlist^ do
begin
lengthofcode:=lengthofcode+codelength;
if slangmode or printproctable then
begin
if l = 0 then begin
page(output);
writeln(output,'  procedure table ');
writeln(output);
writeln(output,'  nr name          line  segm  length   stack   alarm');
writeln(output);
end;
writeln(output, l:4,' ',indexÆiÅ^.routinename^,firstlineofproc:6,discaddr:6
,codelength
,maxstackoffset
,startline);
l := l + procdescrlength;
end;
if lefthandside then
begin
write(slang,discaddr); write(slang,codelength);
write(slang,maxstackoffset);
write(slang,startline);
lastindex := lastindex + 4;
end;
end;
end;
end;
if lefthandside then
for l := 1 to ((segmentlgt - ((lastindex*oneword)
mod segmentlgt)) mod segmentlgt) div oneword do
write(slang,int); (* fill the rest of the segment with zero(s) *)
codesegment := (procfuncoffset + (segmentlgt - 1)) div segmentlgt + codesegment;
infaddr := codesegment;

if slangmode or printproctable then
begin
writeln(output); writeln(output); writeln(output);
writeln(output,' information segment:', infaddr : 5);
writeln(output,heapsize (* startsize of heap *)
,procfuncoffset
,procaddr
,erroraddr);
for l:=1 to no_of_resident do writeln(output,code^.cÆlÅ.constval);
end;
if lefthandside then
begin
lastindex := 0; (* used for counting number of words in the information part *)
write(slang,heapsize,procfuncoffset,procaddr,erroraddr);
lastindex := lastindex + 4;
for i:=1 to no_of_resident do
begin
write(slang,code^.cÆiÅ.constval);
lastindex := lastindex + 1;
end;
write(slang,-1);
lastindex := lastindex + 1;
repeat
write(slang,infaddr);
lastindex := lastindex + 1;
until (lastindex mod (segmentlgt div oneword - 1)) = 0; (*last word of the segment has been written *)

close(slang);
(* change entry, insert the address of the information segment *)
if monitor(42 (*lookup entry*), codefilename, tail) = 0 then
begin
tailÆ8Å := 0; (* segment with entry code = 0 *)
tailÆ9Å := 2*4096 + 0; (* contents key := 2 , entry point := 0 *)
tailÆ10Å := lengthofentrycode * oneword;
if monitor(44 (*change entry*), codefilename, tail) <> 0 then
writeln(output,'??? warning, error in call of change entry');
end;
end;

writeln(output,'Code:',
lengthofcode div 1024:3,'K +',lengthofcode mod 1024:5,' Halfwords');
if errorcount > 0 then writeln(output,'Error(s) found in pass2');
end;

procedure outconstblock(jump : boolean); forward;

procedure makerelcode(op:opcodes;disp:integer); forward;


function emitcode : integer;
(* emits code and constants for a procedure and returns the number of the first
segment of the produced code *)
var i, j : integer;
zero : integer;

begin
outconstblock(false);
intchain:=nil;
constchain:=nil;
emitcode := codesegment;
i := codesegment; (* for slangmode, the start segment of the procedure *)
codesegment := codesegment + (lastindex*oneword+(segmentlgt-1))div segmentlgt;
zero := 0;
if lefthandside then
for j := 1 to ((segmentlgt div oneword) - lastindex mod
(segmentlgt div oneword)) mod (segmentlgt div oneword) do
write(slang,zero);
with code^ do
if slangmode then
begin
writeln(output);
writeln(output,'s.w. ',currentproc^.routinename^,'segment:',i:5);
for l:=1 to lastindex do
with cÆlÅ do
begin
write(output,(l-1)*oneword : 4, ':', constval : 9,' ');
write(output,mnemonicsÆopcodeÅ);
if relative then write(output,'. w', w:1)
else write(output,'  w', w:1);
if indirect then write(output,' (')
else write(output, '  ');
if index > 0 then write(output,'x', index:1)
else write(output,'  ');
if displacement <> 0 then
begin
if displacement > 0 then
if index <> 0 then write(output,'+')
else write(output,' ');
write(output,displacement:1);
end
else
if index = 0 then write(output,' 0');

if indirect then write(output,')');
if relative then write(output,displacement+ (l-1)*oneword);
writeln(output);
end;
writeln(output,'e.');
end;
if lefthandside then
with code^ do
for i:=1 to lastindex do
write(slang,cÆiÅ.constval);
end;

procedure outcode(word:opnode);
(* put word into next available word in the structure
holding the code for this procedure *)
begin
if lastindex >= maxindex then stop(405);
if lastindex >= outconstlimit then outconstblock(true);
lastindex:=lastindex+1;
code^.cÆlastindexÅ := word;
end;

procedure makeallcode(op:opcodes;ac:regrange;rel,ind:boolean;x:regrange;disp:integer);
(* generate a word of code with the fields
set according to parameters *)
var
word : opnode;
begin
with word do
begin
opcode:=op;
w:=ac;
relative:=rel;
indirect:=ind;
index:=x;
displacement:=disp;
end;
outcode(word);
end;

procedure makecode(op:opcodes;ac:regrange;disp:integer);
(* generate a word of code with the operator,w,displacement
set according to parameters and the rest of the fields
set by default *)
var
word : opnode;
value word = (0:(ks,0,false,false,0,0));
begin
with word do
begin
opcode:=op;
w:=ac;
displacement:=disp;
end;
outcode(word);
end;

procedure makewrelcode(op:opcodes; ac:regrange; disp:integer);
(* generate a word of code with the operator,w,displacement
set according to parameters and the rest of the fields
set by default *)
var
word : opnode;
value word = (0:(ks,0,true,false,0,0));
begin
with word do
begin
opcode:=op;
w:=ac;
displacement:=disp;
end;
outcode(word);
end;

procedure makerelcode; (* (op:opcodes;disp:integer) FORWARD declared *)
(* generate a word of code with the operator,displacement
set according to parameters and the rest of the fields
set by default *)
var
word : opnode;
value word = (0:(ks,0,true,false,0,0));
begin
with word do
begin
opcode:=op;
w:=0;
displacement:=disp;
end;
outcode(word);
end;

procedure makeindirectcode(op:opcodes;ac,x:regrange;disp:integer);
(* generate a word of code with the operator,w,index,displacement
set according to parameters and the rest of the fields
set by default *)
var
word : opnode;
value word = (0:(ks,0,false,true,0,0));
begin
with word do
begin
opcode:=op;
w:=ac;
index:=x;
displacement:=disp;
end;
outcode(word);
end;

procedure makeindexcode(op:opcodes;ac,x:regrange;disp:integer);
(* generate a word of code with the operator,w,index,displacement
set according to parameters and the rest of the fields
set by default *)
var
word : opnode;
value word = (0:(ks,0,false,false,0,0));
begin
with word do
begin
opcode:=op;
w:=ac;
index:=x;
displacement:=disp;
end;
outcode(word);
end;

procedure makewordcode(val:integer);
var word:opnode;
begin
word.constval:=val;
outcode(word);
end;

procedure reservecode(number : integer);
(* reserve number words of code in the block
of code *)
begin
if lastindex + number >= outconstlimit then
outconstblock(true);
end;

procedure makeconst(val:integer; symb:symbolptr);
(* if symb = NIL then insert val in the chain of integer
constants else insert symb in a chain. Insert the index of the
last made code in the chain for the constant *)
(* the address (after 'outconstblock') will, depending on
symb^.constkind, be
1) for wordconst : first halfword
2) for realconst : third halfword
3) for stringconst and setconst : first halfword 
*)
var
s, symbol : symbolptr;
i : integer;
begin
if symb = nil then
begin
s:=intchain;
while s <> nil do
begin
if s^.intval = val then
begin
symb:=s;
s:=nil;
end
else s:=s^.next;
end;
if symb = nil then
begin
new(symb);
with symb^ do
begin
next:=intchain;
key:=econst;
consttype:=integertype;
startchain:=0;
constindex:=0;
constkind:=wordconst;
intval:=val;
end;
intchain:=symb;
end;
end
else
if symb^.constkind = wordconst then
begin (* insert symbol in chain of integers *)
s:=intchain;
val:=symb^.intval;
symbol:=nil;
while s <> nil do
begin
if s^.intval = val then
begin
symbol:=s;
s:=nil;
end
else s:=s^.next;
end;
if symbol = nil then
begin
symb^.next:=intchain;
symb^.startchain:=0;
symb^.constindex:=0;
intchain:=symb;
end
else symb:=symbol;
end
else
begin
s:=constchain;
symbol:=nil;
while s <> nil do
begin
if s = symb then
begin
symbol:=s;
s:=nil;
end
else s:=s^.next;
end;
if symbol = nil then
begin
symb^.next:=constchain;
constchain:=symb;
symb^.startchain:=0;
symb^.constindex:=0;
end;
end;
if (symb^.constindex <> 0) and
(symb^.constindex-lastindex >= minsignedhalfword div oneword) then
code^.cÆlastindexÅ.displacement:=(symb^.constindex-lastindex)*oneword
else
begin
symb^.constindex:=0;
i:=symb^.startchain;
if i <> 0 then i:=i-lastindex;
symb^.startchain:=lastindex;
code^.cÆlastindexÅ.displacement:=i;
outconstlimit:=outconstlimit-symb^.consttype^.size div oneword;
end;
end; (* makeconst *)


procedure putreal(realvalue : real; codeoffset : integer);
var
exp : integer;
rc8000real : packed record
case boolean of
true : (i1 : integer;
i2 : integer);
false : (realval : real);
end;

word : opnode;
begin
with rc8000real do
begin
realval := realvalue;
word.realval1 := i1;
code^.cÆcodeoffsetÅ := word;
word.realval2 := i2;
code^.cÆcodeoffset + 1Å := word;
end;
end; (* put real *)


procedure outconstblock; (* jump:boolean FORWARD declared *)
(* output all not yet allocated*)
var
s : symbolptr;
word : opnode;
i, j, jumpindex : integer;
sjump : jumpchainptr;

procedure insertchain(chain : integer);
var
disp : integer;
begin
disp:=chain;
with code^ do
while disp <> 0 do
with cÆchainÅ do
begin
disp:=displacement;
displacement:=(lastindex-chain)*oneword;
chain:=chain+disp;
end;
end;

begin (* outconstblock *)
if jump then
begin
outconstlimit:=outconstlimit+1;
makerelcode(jl,0);
jumpindex:=lastindex;
end;

(* prevent recursive calling from outcode *)
outconstlimit := maxindex;

s:=intchain;
while s <> nil do
begin
if s^.constindex = 0 then
begin
s^.constindex:=lastindex + 1;
word.constval:=s^.intval;
outcode(word);
insertchain(s^.startchain);
s^.startchain:=0;
end;
s:=s^.next;
end;

for i:=1 to maxworkspace do
begin
if workspaceÆiÅ <> 0 then
begin
word.constval:=i;
outcode(word);
insertchain(workspaceÆiÅ);
workspaceÆiÅ:=0;
end;
end;

s:= constchain;
while s <> nil do
begin
if s^.constindex = 0 then
begin
case s^.constkind of
realconst:
begin
if lastindex + realsize div oneword >= maxindex then
stop ( 405 ); (* use option codesize *)
putreal(s^.realval,lastindex+1);
lastindex := lastindex + realsize div oneword;
s^.constindex:=lastindex;
insertchain(s^.startchain);
end;
setconst: begin
lastindex := lastindex + 1; (* prepare call of insertchain *)
insertchain(s^.startchain);
lastindex := lastindex - 1; (* reestablish pointer *)
s^.constindex:=lastindex;
for i:=1 to setsize div oneword do
begin
word.half1:=s^.setval^.hlfwordsÆi*oneword-1Å;
word.half2:=s^.setval^.hlfwordsÆi*onewordÅ;
outcode(word);
end;
end;
stringconst: begin
lastindex := lastindex + 1; (* prepare call of insertchain *)
insertchain(s^.startchain);
lastindex := lastindex - 1; (* reestablish pointer *)
s^.constindex:=lastindex;
with s^.stringval^ do
begin
j:=0;
for i:=1 to length do
begin
j:=j+1;
word.strÆjÅ:=strÆiÅ;
if j mod asciiperword =0 then
begin
outcode(word);
j:=0;
end;
end;
if j <> 0 then
begin
for i:=j +1 to  asciiperword do
word.strÆiÅ:=' ';
outcode(word);
end;
end;
returnstring(s^.stringval);
end;
end;
end;
s^.startchain:=0;
s:=s^.next;
end;

if maxindex-lastindex < maxcode then outconstlimit:=maxindex
else outconstlimit:=lastindex+maxcode;

if jump then
begin
for i:=1 to ndepth do
with neststackÆiÅ do
begin
if index <> 0 then
begin
makerelcode(jl,index-lastindex-1);
index:=lastindex;
end;
end;
sjump:=shortjumps;
while sjump <> nil do
begin
makerelcode(jl,sjump^.jumpindex-lastindex-1);
sjump^.jumpindex:=lastindex;
sjump:=sjump^.next;
end;
code^.cÆjumpindexÅ.displacement:=(lastindex-jumpindex+1)*oneword;
end;
end; (* outconstblock *)

function makerealconst(val:real) : symbolptr;
(* search through the list of long constants,
if val is found then the result is this symbolnode
else the result is a new allocated symbolnode
containing the constant val *)
var
symb, newsymb : symbolptr;
begin
symb:=constchain;
newsymb:=nil;
while symb <> nil do
begin
if (symb^.constkind = realconst) and
(symb^.realval = val) then
begin
newsymb:=symb;
symb:=nil;
end
else symb:=symb^.next;
end;

if newsymb = nil then
begin
new(newsymb);
with newsymb^ do
begin
next:=constchain;
key:=econst;
consttype:=realtype;
startchain:=0;
constindex:=0;
constkind:=realconst;
realval:=val;
end;
constchain:=newsymb;
end;
makerealconst:=newsymb;
end;



procedure nextline ;
(* correct use of this procedure ensures that variable intermitword *)
(* always contains a PIF opcode, as the first code on a line is an opcode *)

begin
readln ;
intermitword := getintmtword ;
end ;

function getbasetype(symbol:symbolptr):intmtwords;
(*translate symbol^.key into name(intmtword)*)
begin
if symbol = nil then getbasetype := enone
else
with symbol^ do
case typkind of
esubrange:
getbasetype:=subtyp^.typkind;
escalar,eboolean,eascii,
eset,efile,
epointer,einteger,ereal,
erecord:
getbasetype:=typkind;
estring:
if length=1 then getbasetype:=eascii
else getbasetype:=estring;
earray:
if stringcomp then getbasetype:=estring
else getbasetype:=earray
end;
end; (*FUNCTION getbasetype*)

procedure readconst;
(*reads a constant*)
var
s:symbolptr;
ch:char;
lngt,i:integer;

procedure readsign(var sign:boolean);
(*reads an optional sign*)
begin
sign := ch = '-' ;
if (ch='+') or (ch='-') then
read( ch ) ;
end; (*PROCEDURE readsign*)

function readint:integer;
(*The result is the value read on input*)
label 9999; (*jump hereto if number to large*)
var
isign:boolean;
digits:set of '0'..'F';
limit,base,fig:integer;

procedure readbase;
(* note: limit is defined thus: when a number read is smaller than limit, *)
(* it is possible to append any digit from set digits to it without *)
(* risk of overflow; if not, we must read the next digit (if any) with special care *)
begin
if ch='#' then
begin
read(ch);
if ch='O' then
begin
base:=8;
digits:=Æ'0'..'7'Å;
limit:=-1048576;(* -2**20 *)
end
else if ch='H' then
begin
base:=16;
digits:=Æ'0'..'9','A'..'F'Å;
limit:=-524288; (* -2**19 *)
end
else
begin
base:=2;
digits:=Æ'0'..'1'Å;
limit:=-4194304; (* -2**22 *)
end;
read( ch ) ;
end
else
begin
base:=10;
digits:=Æ'0'..'9'Å;
limit:=-838860;
end;
end; (*PROCEDURE readbase*)

begin (*readint*)
readsign(isign);
readbase;
fig:=0;
repeat
if fig>limit then fig:=fig*base-chartonumberÆchÅ
else
if base<>10 then
begin
if (fig=limit) and (ch='0') and isign then fig:=fig*base
else
begin
error(302);
goto 9999;
end;
end
else
if (fig=limit) and ((ch<='7') or isign and (ch='8'))
then fig:=fig*10-chartonumberÆchÅ
else
begin
error(301);
goto 9999;
end;
read(ch);
until  (ch=' ');
9999:
if isign then readint:=fig
else readint:=-fig;
end; (*PROCEDURE readint*)

function readreal:real;
const
limit=3435973835.0;
lim1=616;
lim2=-616;
type
posint=0..lim1;
var
msign,scsign:boolean;
exp,exp2:integer;
fig,res1:real;

function ten(e:posint):real;
var
i:integer;
t:real;
begin
i:=0;
t:=1.0;
repeat
if odd(e) then
case i of
0:t:=t*1.0E1;
1:t:=t*1.0E2;
2:t:=t*1.0E4;
3:t:=t*1.0E8;
4:t:=t*1.0E16;
5:t:=t*1.0E32;
6:t:=t*sqr(1.0E32);
7:t:=t*sqr(sqr(1.0E32));
8:t:=t*sqr(sqr(sqr(1.0E32)));
9:t:=t*sqr(sqr(sqr(sqr(1.0E32))));
end;
e:=e div 2;
i:=i+1;
until e=0;
ten:=t;
end; (*FUNCTION ten*)

begin (* readreal *)
readsign(msign);
fig:=0;
exp:=0;
repeat
if fig<limit then fig:=fig*10+chartonumberÆchÅ
else exp:=exp+1;
read(ch);
until  not(ch in Æ'0'..'9'Å);
if ch='.' then
begin
(*read fraction*)
read(ch);
while  (ch in Æ'0'..'9'Å) do
begin
if fig<limit then
begin
fig:=fig*10+chartonumberÆchÅ;
exp:=exp-1;
end;
read(ch);
end;
end;
if ch='E' then
begin
(*read scale factor*)
read(ch);
readsign(scsign);
exp2:=0;
while  (ch<>' ') do
begin
if exp2<limit then exp2:=exp2*10+chartonumberÆchÅ;
read(ch);
end;
if scsign then exp:=exp-exp2 else exp:=exp+exp2;
end;
if exp<lim2 then
begin
fig:=0;
exp:=0;
end
else
if exp>lim1 then
begin
error(303);
exp:=0;
end;
if msign then res1:=-fig else res1:=fig;
if exp<0 then readreal:=res1/ten(-exp)
else
if exp<>0 then readreal:=res1*ten(exp)
else readreal:=res1;
end; (*FUNCTION readreal*)

begin (*readconst*)
(* PIF opcode const has just been read *)
s := getsymbptr;
with s^ do
begin
key := econst ;
consttype := getsymbptr;
read( ch );
case consttype^.typkind of
einteger, escalar, eboolean,
eascii:
begin
constkind:=wordconst;
intval:=readint;
if (intval<=maxsignedhalfword) and (intval>=minsignedhalfword) then
constkind:=signedshortconst
end;
ereal:
begin
constkind:=realconst;
realval:=readreal;
end;
estring:
begin
lngt:=consttype^.length;
if lngt>stringmax then
begin
error(402);
lngt:=stringmax;
end;
constkind:=stringconst;
stringval:=newstring;
with stringval^ do
begin
length:=lngt;
for i := 1 to lngt do
begin
strÆiÅ:=ch;
read(ch);
end;
end;
end; (*estring*)
epointer:
begin (* the pointer value NIL *)
constkind:=signedshortconst;
intval:=nilvalue;
end;
end; (*CASE *)
end (* WITH s^ DO ... *) ;
end; (*PROCEDURE readconst*)


procedure readlabeldecl ;
var s : symbolptr ;
begin
(* PIF opcode label has just been read *)
s := getsymbptr ;
with  s^  do
begin
key := elabel ;
labellevel:=level;
labelordinal:=localordinal;
if localordinal >= maxordinal -oneword -mintemporary then error(306)
else localordinal:=localordinal+oneword;
procaddr:=procfuncoffset-procdescrlength;
end ;
end ;

function log2(x:integer):integer;
var
i,j:integer;
begin
if x>=maxint div 2 then log2:=maxbit
else
begin
i:=0;
j:=1;
repeat
i:=i+1;
j:=j*2;
until j > x;
log2:=i;
end;
end;

procedure insertsorted(symbol:symbolptr);
(*insert symbol which must be a variable in a list sorted after the length
of storage requirement *)
var
length:integer;
s,s1:symbolptr;
begin
length:=symbol^.vartypedescr^.size;
symbol^.next:=nil;
if sortlist = nil then sortlist:=symbol
else
begin
s:=sortlist;
if s^.vartypedescr^.size >= length then
begin
symbol^.next:=s;
sortlist:=symbol;
end
else
begin
while length > s^.vartypedescr^.size do
begin
s1:=s;
s:=s^.next;
if s = nil then
begin
s:=s1;
length:=0;
end;
end;
if length <> 0 then symbol^.next:=s;
s1^.next:=symbol;
end;
end;
end;

procedure reallocatefields;
var
flist : symbolptr;
shift : bitrange;
begin
flist:=fieldlist;
fieldlist:=nil;
if flist <> nil then
if flist^.next = nil then
with flist^.varaddr do
begin (* only one field in this word *)
packk:=unpack;
end
else
begin
shift:=maxbit+1-flist^.varaddr.bitstart-flist^.vartypedescr^.bitsize;
repeat
with flist^.varaddr do
begin
bitstart:=bitstart+shift;
flist:=flist^.next;
end;
until flist=nil;
end;
end;

procedure readnamedef ;

var
a : alfa ;
aptr : ^alfa;
s, s1: symbolptr;
i, j : integer;
n : nodeident ;
ch : char ;
address : addrptr;
string : stringptr;
externalfile : boolean;

begin
(* PIF opcode name has just been read *)
s := getsymbptr ;
readalfa( a ) ; (* if name is a scalar constant, a proc/func, a program,
or a module we need the name itself *)
with s^  do
begin
key := ename ;
namekind := getintmtwords ;
case namekind of
etype :
forgetsymbptr(lastnodeident) ; (* as name of type is never used *)
econst :
begin
constant:=getsymbptr;
if constant^.consttype = scalartype then
begin
constname:=a;
scalartype^.lastscalar:=constant^.intval;
if constant^.consttype^.typkind = eascii then forgetsymbptr(lastnodeident);
end
else
begin
if constant^.constkind=stringconst then constant^.stringval^.returnable:=false;
forgetsymbptr(lastnodeident);
end;
end ;
effunc, efproc,
evarparam :
if standenvir then
forgetsymbptr(lastnodeident) (* parameters of standard procedures are never used by this program *)
else
with varaddr do
begin
valparordinal:=0;
if namekind <> efproc then vartypedescr := getsymbptr ;
index:=nil;
bitstart := 0;
packk:=unpack;
simpleaddr:=true;
blocknumber:=level;
ordinal:=localordinal;
localordinal:=localordinal+oneword;
if namekind <> evarparam then localordinal:=localordinal+oneword;
end;
evalparam,
evar:
if standenvir then forgetsymbptr(lastnodeident)
else
with varaddr do
begin
valparordinal:=0;
vartypedescr:=getsymbptr;
index:=nil;
packk:=unpack;
if (vartypedescr^.size <= 4) and
(localordinal < maxordinal-4-mintemporary) then
begin
simpleaddr:=true;
bitstart := 0;
blocknumber:=level;
ordinal:=localordinal;
localordinal:=localordinal+vartypedescr^.size;
end
else
begin
if namekind=evalparam then
begin
valparordinal:=localordinal;
localordinal:=localordinal+oneword;
end;
insertsorted(s);
end;
end;
efield,
etagfield:
begin
s1:=getsymbptr;
vartypedescr:=s1;
i:=s1^.size;
j:=s1^.bitsize;
with varaddr,currentfixlist^ do
begin
simpleaddr:=true;
if packlist then
begin
packk:=s1^.packedtype;
if j+bitoffset > maxbit+1 then
begin (*not enough free bits in this word *)
reallocatefields;
s^.next:=nil;
fieldlist:=s;
bitstart:=0;
ordinal:=byteoffset+oneword;
byteoffset:=byteoffset+i;
bitoffset:=j;
end
else
begin
s^.next:=fieldlist;
fieldlist:=s;
bitstart:=bitoffset;
ordinal:=byteoffset;
bitoffset:=bitoffset+j;
byteoffset:=byteoffset+i-oneword;
end;
end
else
begin
bitstart:=0;
ordinal:=byteoffset;
packk:=unpack;
byteoffset:=byteoffset+i;
end;
end;
end;
efunc,
eproc :
begin
new(aptr);
aptr^ := a;
routinename := aptr;
blocklevel:=level;
coreresident:=resident;
standard := standenvir;
if currentmodule = nil then
begin
currentproc:=s;
paramlist:=getsymbptr;
paramlist^.displayoffset:=localordinal;
routinedescr := procfuncoffset ;
starttmp:=0;
availtmp:=0;
procfuncoffset:=procfuncoffset+procdescrlength;
(* Note that the level is 1 less than the level of the parameter and variables *)
end
else
if currentmodule^.modulekind = esystem then
begin
stnd_name := standardcounter ;
standardcounter := succ( standardcounter ) ;
n:=getnumber; (* parameter list is not used *)
end;
if namekind = efunc then functype := getsymbptr ;
end ;
eprogram :
begin
(* note, that a program has no parameter list; therefore all the work done for *)
(* a procedure on namelist, param has to be done here for the program. *)
programident:=lastnodeident;
new(aptr);
aptr^ := a;
routinename := aptr;
blocklevel:=level;
coreresident:=resident;
standard:=false;
currentproc:=s;
routinedescr:=procfuncoffset;
procfuncoffset:=procfuncoffset+procdescrlength;
starttmp:=0;
availtmp:=0;
localordinal:=minparamordinal+standardentries;
new(s1);
with s1^ do
begin
key:=enamelist;
listkind:=eparam;
displayoffset:=localordinal;
localordinal := localordinal + oneword;
copyvalparam:=nil;
filelist:=nil;
initlist:=nil;
lengthofvalue:=0;
end;
paramlist:=s1;
alfatype:=indexÆalfatypeidentÅ;
end ;
efile :
begin
externalfile:= getintmtwords = eext;
vartypedescr := getsymbptr ;
with varaddr do
begin
index:=nil;
packk:=unpack;
simpleaddr:=true;
blocknumber:=level;
if blocknumber < 0 then
begin (* standard file INPUT or OUTPUT *)
blocknumber:=0;
ordinal:=localordinal;
if a = 'INPUT     ' then
begin
inputordinal:=ordinal;
inputfilename:=s;
end
else
begin
outputordinal:=ordinal;
outputfilename:=s;
end;
localordinal:=localordinal+oneword;
address := newaddress;
address^:=varaddr;
simpleaddr:=false;
postordinal:=0;
reference:=address;
end
else
insertsorted(s); (* remember filedeclaration for later allocation *)
end;
if externalfile then
begin
new(string);
extname:=string;
i:=0;
if not eoln(input) then read(ch);
while (not eoln(input)) and (i<alfalength) do
begin
i:=i+1;
string^.strÆiÅ:=ch;
read(ch);
end;
if i<=1 then string^.length:=0
else
begin
for i:=i+1 to filenamelength div oneword *asciiperword do string^.strÆiÅ:=' ';
string^.length:=filenamelength div oneword *asciiperword;
end;
end
else extname:=nil;
end;
emodule :
begin
modulename:=a;
currentmodule:=s;
modulekind:=getintmtwords;
end;
end (* CASE namekind OF ... *) ;
end (* WITH s^ .. *) ;
end (* readnamedef *) ;

procedure allocatelist;
var
firsttemp, i: integer;
slist, vallist, fillist, s : symbolptr;
address : addrptr;
tmpallocated : boolean;
begin (* allocate the variables in the sorted list *)
slist:=sortlist;
sortlist:=nil;
vallist:=nil;
fillist:=nil;
tmpallocated:=false;
while slist <> nil do
with slist^,varaddr do
begin
if tmpallocated or
( localordinal+vartypedescr^.size < maxordinal-mintemporary) then
begin
index:=nil;
packk:=unpack;
bitstart:=0;
simpleaddr:=true;
blocknumber:=level;
ordinal:=localordinal;
localordinal:=localordinal+vartypedescr^.size;
if namekind = evalparam then
begin
s:=next;
next:=vallist;
vallist:=slist;
slist:=s;
end
else
if namekind = efile then
begin
if namekind = efile then ordinal:=ordinal+(filenamelength-h0);
s:=next;
next:=fillist;
fillist:=slist;
slist:=s;
end
else slist:=next;
end
else
begin (* no more space in first block *)
firsttemp:=localordinal;
localordinal:=localordinal+mintemporary;
tmpallocated:=true;
end;
end;

if not tmpallocated then firsttemp:=localordinal;

with currentproc^ do
begin
if availtmp = 0 then
begin
starttmp:=firsttemp;
availtmp:=mintemporary;
paramlist^.copyvalparam:=vallist;
paramlist^.filelist:=fillist;
if not tmpallocated then localordinal:=localordinal+mintemporary;
declarationlist^.maxstackoffset:=localordinal;
end;
end;
end; (* allocatelist *)

procedure readnamelist ;
var s:symbolptr;

begin
s:=getsymbptr;
with s^ do
begin
key:=enamelist;
listkind := getintmtwords ;
case listkind of
eparam :
if standenvir then forgetsymbptr(lastnodeident)
(* no parameterlists for standardfunctions *)
else
begin
if currentproc <> nil then allocatelist;
localordinal:=minparamordinal;
copyvalparam:=nil;
filelist:=nil;
initlist:=nil;
lengthofvalue:=0;
level := level + oneword ;
end ;
edeclaration :
begin
level := level + oneword ;
if currentproc <> nil then
currentproc^.declarationlist:=s;
localordinal:=localordinal+level+oneword;(*storage for display *)
if localordinal > maxordinal-mintemporary then error(306);
end ;
escalarlist : forgetsymbptr(lastnodeident);
efix :
begin
if currentvarlist=nil then byteoffset:=0
else byteoffset:=currentvarlist^.fixsize;
bitoffset:=0;
lastfixlist:=currentfixlist;
oldvarlist:=currentvarlist;
currentvarlist:=nil;
currentfixlist:=s;
packlist:=getintmtwords = epacked;
end
end; (* CASE LISTKIND OF *)
end (* WITH s^ ... *) ;
end (* readnamelist ... *) ;

procedure sizeoftype(symb:symbolptr; first,last:integer);
begin
with symb^ do
begin
packedtype:=paack;
if first > 0 then first:=0;
size:=intsize;
if getbasetype(symb) = eascii then bitsize:=bitperascii
else bitsize:=log2(last-first);
if (first>=minsignedhalfword) and (last<=maxsignedhalfword) then
begin
if first<0 then
begin
bitsize:=(maxbit+1) div 2;
packedtype:=signedhlfword;
end;
end
else
if (first>=0) and (last<=maxhalfword)and
(bitsize=(maxbit+1) div 2) then packedtype:=hlfword
else
if first < 0 then
begin
bitsize:=maxbit+1;
packedtype:=unpack;
end;
end;
end; (* sizeoftype *)

procedure readendnamelist ;
begin
case getintmtwords of
escalarlist :
begin
sizeoftype(scalartype,0,scalartype^.lastscalar);
scalartype:=nil;
end;
edeclaration :begin
if currentproc <> nil then allocatelist;
lastindex:=0;
if maxindex-lastindex < maxcode then outconstlimit:=maxindex
else outconstlimit:=maxcode;
labnumber:=getnumber+1;
end;
eparam :
if not standenvir then
begin
level:=level-oneword;
end ;
efix :
with currentfixlist^ do
begin
reallocatefields;
namelistsize:=byteoffset;
if bitoffset>0 then
namelistsize:=namelistsize+oneword;
currentfixlist:=lastfixlist;
end ;
end ; (*CASE getintmtwords OF ... *)
end (* readendnamelist *) ;

procedure readtypegeneral ;
var
noofwords, noofelements, elementsperword, first, last : integer ;
mini, maxi, s : symbolptr ;

begin (*readtypegeneral*)
s := getsymbptr ;
with s^ do
begin
bitsize:=maxbit+1;
packedtype:=unpack;
key := etype ;
typkind := getintmtwords ;
case typkind of
einteger :
begin
size := intsize ;
integertype:=s;
end;
ereal:
begin
size := realsize ;
realtype:=s;
end;
esubrange :
begin
subtyp := getsymbptr ;
mini := getsymbptr ;  maxi := getsymbptr ;
first:=mini^.intval;
last:=maxi^.intval;
firstconst:=first;
lastconst:=last;
if first > last then
begin
error(307) ;
size:=intsize;
end
else sizeoftype(s,first,last);
end;
eboolean :
begin
scalartype:=s;
namelist:=getnumber;
booltype:=s;
end;
escalar: begin
namelist:=getnumber;
scalartype:=s;
(* preparing for the following (namelist, scalar) *)
end ;
eascii :
begin
namelist:=getnumber;
scalartype:=s;
(* preparing for the following (namelist, scalar) *)
asciitype:=s;
end ;
earray :
begin
if getintmtwords=epacked then packedtype:=paack;
packedval:=false;
indextyp := getsymbptr ;  valtyp := getsymbptr ;
with indextyp ^ do
case typkind of
esubrange :
begin
s^.stringcomp:=((subtyp^.typkind=einteger) and
(getbasetype(s^.valtyp)=eascii) and
(s^.packedtype=paack) and
(firstconst=1));
first := firstconst ;
last := lastconst ;
end ;
escalar, eboolean,
eascii :
begin
stringcomp:=false;
first := 0 ;
last := lastscalar ;
end ;
einteger :
begin
stringcomp:=false;
first:=-maxint-1;
last:=maxint;
end;
end ;
noofelements:=last-first+1;
if noofelements<0 then
begin
noofelements:=1;
error(304);
end;
if (packedtype=paack) and (valtyp^.size=oneword) then
begin
elementsperword:=(maxbit+1) div valtyp^.bitsize;
if elementsperword > 1 then
begin
noofwords:=noofelements div elementsperword;
if noofelements mod elementsperword > 0 then noofwords:=noofwords+1;
size:=noofwords*oneword;
packedval:=true;
end
else size:=noofelements*oneword;
end
else size:=valtyp^.size*noofelements;
if size<0 then
begin
size:=oneword;
error(304);
end;
end ;
erecord :
begin
(* global namelistsize was set by preceding fixlist or varlist *)
size := namelistsize ;
if getintmtwords=epacked then packedtype:=paack;
varlist:=currentvarlist;
currentvarlist:=nil;
end ;
eset :
begin
if getintmtwords=epacked then packedtype:=paack;
size := setsize ;
setoftyp := getsymbptr ;
end ;
efile :
begin
if getintmtwords=epacked then packedtype:=paack;
randomfile := erandom = getintmtwords ;
if randomfile then
begin
fileindextype:=getsymbptr;
error(406);
end;
elementtyp := getsymbptr ;
size := filenamelength +h5+h6+bufferlength;
if getbasetype(elementtyp) <> eascii then size:=size+elementtyp^.size;
end ;
epointer :
begin
size := ptrsize ;
pointertotyp := getsymbptr ;
end ;
estring :
begin
length := getnumber ;
noofwords := length div asciiperword;
if length mod asciiperword > 0 then noofwords:=noofwords+1;
size:=noofwords*oneword;
end ;
end (* CASE typkind OF .. *)
end (* WITH s^ DO ... *);
end (* readtypegeneral *) ;

procedure readrecordlabel;
var
s,s1,s2:symbolptr;
labelvalue:integer;
multilabel:boolean;
begin
s:=getsymbptr;
s1:=getsymbptr;
labelvalue:=s1^.intval;
s1:=currentvarlist^.taglist;
multilabel:=false;
while s1 <> nil do
begin
s2:=s1^.labellist^.nextreclab;
while s2 <> nil do
begin
if labelvalue=s2^.reclabvalue then multilabel:=true;
s2:=s2^.nextreclab;
end;
s1:=s1^.nexttag;
end;
if multilabel then error(308);
with s^ do
begin
key:=erecordlabel;
reclabvalue:=labelvalue;
nextreclab:=nil;
end;
currentcase^.nextreclab:=s;
currentcase:=s;
end; (* readrecordlabel *)

procedure newtop(op:operators; exptyp:symbolptr; psleft,psright:pseudoptr);
(* pop two top elements from pseudostack (if psright=NIL just one)
and push a new element on pseudostack,
with operator op, leftoperand =psleft and rightoperand=psright *)

var
pseudo:pseudoptr;
begin
pseudotop:=pseudotop^.next;
if psright <> nil then pseudotop:=pseudotop^.next;
pseudo:=newpseudo;
with pseudo^ do
begin
typ:=exptyp;
next:=pseudotop;
kind:=expression;
leftoperand:=psleft;
rightoperand:=psright;
operator:=op;
end;
pseudotop:=pseudo;
end;


procedure indexaddress(var arr : addrnode; var elementlength : integer); forward;

procedure changeamcode(disp : integer); forward;

procedure amchange(bn : integer; var disp : integer); forward;


function sameaddress(addr1,addr2 : addrnode) : boolean;
(* true if the address chains starting with addr1 and addr2 are equivalent *)
var
notfinished : boolean;

begin
notfinished := true;
while notfinished do
with addr1 do
if (packk = addr2.packk) and (bitstart = addr2.bitstart) and
(simpleaddr = addr2.simpleaddr) and (index = addr2.index) then
begin
if simpleaddr then
begin
sameaddress := (blocknumber = addr2.blocknumber) and (ordinal = addr2.ordinal);
notfinished := false;
end
else
if (postordinal = addr2.postordinal) and (reference <> nil) and (addr2.reference <> nil) then
begin
addr1 := reference^;
addr2 := addr2.reference^;
end
else
begin
notfinished := false;
sameaddress := false;
end;
end
else
begin
notfinished := false;
sameaddress := false;
end;
end; (* same address *)


procedure storetmp(ps : pseudoptr);
(* store the content of the register (ps) into the first free
temporary and let ps be of kind tmp *)

var
regnumber : regrange;
next,samereg : pseudoptr;
op : opcodes;
adjustment : integer;

begin
if ps <> nil then
begin
if ps^.typ^.size > oneword then
begin  (* size must be 4 !! *)
adjustment := oneword;
op := ds;
end
else
begin
adjustment := 0;
op := rs;
end;
if nooffreetmp <= 2 then error(311);
if ps^.kind <> reg then
error(403)
else
begin
samereg := ps^.sameregister;
regnumber := ps^.regno;
if (op = ds) and (registerÆregnumberÅ.user = registerÆ(regnumber+1) mod noofregÅ.user) then
regnumber := (regnumber + 1) mod noofreg;
next := ps;
repeat
with next^ do
begin
kind := tmp;
with addr do
begin
index := nil;
packk := unpack;
bitstart := 0;
simpleaddr := true;
blocknumber := level;
ordinal := fstfreetmp;
end;
end;
next := samereg;
if next <> nil then
if next^.kind <> reg then
next := nil
else
samereg := next^.sameregister;
until next = nil;
makeindexcode(op,regnumber,stackaddr,fstfreetmp+adjustment);
with registerÆregnumberÅ do
begin
user := nil;
lastused := lastindex;
valid := true;
kind := tmp;
locassociated := true;
addr := ps^.addr;
end;
if op = ds then
registerÆ(regnumber+maxreg) mod noofregÅ := registerÆregnumberÅ;
fstfreetmp := fstfreetmp + oneword + adjustment;
nooffreetmp := nooffreetmp - oneword - adjustment;
end;
end;
end; (* store temporary *)


procedure loadnotsimple(var addr : addrnode; regnumber : regrange;
var pckptr : packindicator); forward;

procedure loadaddress(regnumber : regrange; ps : pseudoptr); forward;

procedure loadregister(regnumber : regrange; ps : pseudoptr); forward;

procedure forgetregisters;
(* forget all about the content of the registers *)
var
j : integer;
begin
for j := 0 to maxreg do
with registerÆjÅ do
begin
user := nil;
valid := false;
end;
end; (* forget registers *)


procedure registerstore(regnumber:regrange; nodestroy:integer); forward;


function freeregister(index : boolean) : regrange;
(* get a free register *)
var
count, old, oldused, firstreg : integer;
found : boolean;

begin
if index then firstreg := 1
else firstreg := 0;
count := firstreg;
repeat
with registerÆcountÅ do
found :=  (user = nil) and (not valid) and (count <> stackaddr);
count := count + 1;
until (found or (count > maxreg));
if not found then
begin (* look for a register holding a constant *)
count := firstreg;
repeat
with registerÆcountÅ do
found :=  (count <> stackaddr) and ((kind = shortsignedcst) or (kind = wordcst));
count := count + 1;
until (found or (count > maxreg));
if not found then
(* force a free register *)
begin
old := firstreg; oldused := registerÆoldÅ.lastused;
for count := firstreg + 1 to maxreg do
if count <> stackaddr then
with registerÆcountÅ do
if lastused < oldused then
begin
oldused := lastused;
old := count;
end;
count := old;
end
else count := count - 1;
if registerÆcountÅ.user <> nil then
registerstore(count,-1);
end
else count := count - 1;
registerÆcountÅ.valid := false;
freeregister := count;
end; (* free register *)


procedure makeregister(ps : pseudoptr; regtostore : integer);
(* if regtostore < 0 then get a free register and connect it with ps
else connect ps and regtostore, the internal knowledge of regtostore will be destroyed *)
var
w : regrange;

begin
if regtostore < 0 then
w := freeregister(false)
else
w := regtostore;
with registerÆwÅ do
begin
user := ps;
lastused := lastindex;
kind := variable;
valid := true;
locassociated := false; (* no address associated yet *)
addr.simpleaddr:=true;
addr.blocknumber:=-2;
end; (* with w do *)
if ps^.typ^.size > oneword then
registerÆ(w+1) mod noofregÅ := registerÆwÅ;
with ps^ do
begin
kind := reg;
regno := w;
sameregister := nil;
end; (* with ps^ do *)
end; (* make register *)


procedure registerstore; (* regnumber:regrange; nodestroy : integer *)
(*make code to store the content of registerÆregnumberÅ into the address
specified in the register node, but only if kind = variable, see
the special use of kind in procedure load . If nodestroy <> -1
then register(nodestroy) will remain unchanged after the
call of the procedure, even if user = nil *)

var
next, nextnext, index1, ps, ps1 : pseudoptr;
found,  amcode, field, addressmode : boolean;
count, disp, disp1, shift, siz : integer;
freereg, v, v1, w, stackp, regtostore : regrange;
addr1 : addrnode;
pckptr : packindicator;

begin  (* register store *)
regtostore := regnumber;
with registerÆregnumberÅ do
if (kind = variable) or (kind = tmp) then
begin
if (user <> nil) and (kind = variable) and (not locassociated) then
storetmp(user)   (* make code to store the content of the register
into the first free temporary location *)
else
begin
if kind = variable then
begin
locassociated := false;  (* force storing in a temporary *)
if user <> nil then
if user^.typ^.size > oneword then
registerÆ(regnumber+1) mod noofregÅ.locassociated := false;
(* make code to store the content of the register *)
with addr do
if simpleaddr and (packk = unpack) then
begin
v := stackaddr;
if index <> nil then
begin
ps := user;
if ps = nil then
begin
ps := newpseudo;
ps^.typ := integertype;
makeregister(ps,regnumber);
end;
addr1 := addr;
indexaddress(addr1,siz);
with addr1 do
if index^.kind = reg then
begin
reservecode(8);
v1 := index^.regno;
if ps^.kind <> reg then
(* the register has been used for index calculation, and the
former contents are stored in a temporary *)
begin
if (v1 = regnumber) or ((ps^.typ^.size > oneword) and
(v1 = ((regnumber+1) mod noofreg))) then
storetmp(registerÆv1Å.user);
loadregister(regnumber,ps);
end;
if index^.kind = reg then
if v1 = 0 then
makeindirectcode(am,0,0,0) (* am  (0) *)
else
makeindexcode(am,0,v1,0)   (* am   x *)
else
makeindirectcode(am,0,stackaddr,index^.addr.ordinal);
registerÆv1Å.valid := v1 = regnumber;
end;
addr := addr1;
index1 := index;
returnpseudo(index1);
index := nil;
end;
if blocknumber = level then
begin
if abs(ordinal) <= maxordinal then
disp := ordinal
else
begin
if code^.cÆlastindexÅ.opcode = am then
changeamcode(ordinal)
else
begin
makeallcode(am,0,reladdr,indirectmode,0,0);
makeconst(ordinal,nil);
end;
disp := 0;
end;
end
else (* block number <> level *)
begin
disp := ordinal;
amchange(blocknumber,disp);
with code^.cÆlastindexÅ do
if (indirect = directmode) and (index <> 0) then
(* am  x? *)
begin
v := index;
lastindex := lastindex - 1;
(* the am instruction is not necessary *)
end
else
v := 0;
end;
makeindexcode(rs,regnumber,v,disp);
end
else  (* not simple address or packk <> unpack *)
if packk <> unpack then  (* pack and store !! *)
begin
if index <> nil then
begin
addr1 := addr;
ps := registerÆregnumberÅ.user;
if ps = nil then
begin
ps := newpseudo;
ps^.typ := integertype;
makeregister(ps,regnumber);
end;
stackp := stackaddr;
indexaddress(addr1,siz);
with addr1 do
if index^.kind = reg then
begin
reservecode(6);
ps1 := nil;
field := siz = maxbit;
v1 := index^.regno;
if field then
begin
siz := ps^.typ^.bitsize; (* a packed field, not an array element *)
stackp := 0;
disp := maxbit + 1 - bitstart - siz; (* number of bits to shift *)
addressmode := directmode;
end
else
begin (* the bitstart of the array element is in
register(v1-1), the mask shifting uses 24-reg(v1-1)-siz *)
makeindirectcode(am,0,0,oneword*((v1+maxreg) mod noofreg));
makecode(ac,(v1+maxreg) mod noofreg,siz - 24);
ps1 := newpseudo;
ps1^.typ := integertype;
makeregister(ps1,(v1+maxreg) mod noofreg);
storetmp(ps1);
disp := ps1^.addr.ordinal; (* tmp *)
stackp := stackaddr;
addressmode := indirectmode;
end;
if regnumber = 0 then
w := 1 else w := noofreg - regnumber;
if simpleaddr then
begin
if blocknumber <> level then
makeindexcode(wa,index^.regno,stackaddr,display+blocknumber);
if abs(ordinal) > maxordinal then
begin
makewrelcode(wa,index^.regno,0);
makeconst(ordinal,nil);
end;
storetmp(index); (* this is done to simplify the compiler,
and it is most often necessary anyway, because the RC8000
only has four registers *)
end
else
begin
storetmp(index); (* this is done to simplify the compiler,
and it is most often necessary anyway, because the RC8000
only has four registers *)
loadnotsimple(reference^,w,pckptr);
makeindexcode(wa,w,stackaddr,index^.addr.ordinal);
if abs(postordinal) > maxordinal then
begin
makewrelcode(wa,w,0);
makeconst(postordinal,nil);
end;
makeindexcode(rs,w,stackaddr,index^.addr.ordinal);
end;
if ps^.kind <> reg then  (* tmp *)
loadregister(regnumber,ps); (* get the original content back *)
if siz = (maxbit + 1) div oneword then (* halfword *)
makecode(bz,regnumber,regnumber*oneword + 1); (* remove the sign extension
from signed halfwords *)
makewrelcode(rl,w,0);
makeconst(bitmaskÆsizÅ, nil); (* right justified mask *)
makeallcode(ls,w,absaddr,addressmode,stackp,disp);
makeallcode(ls,regnumber,absaddr,addressmode,stackp,disp);
makeindexcode(ac,w,w,1);  (* complement the mask *)
makeindirectcode(am,0,stackaddr,index^.addr.ordinal);
if simpleaddr then
begin
if blocknumber <> level then
stackp := 0
else
stackp := stackaddr;
if abs(ordinal) <= maxordinal then
disp := ordinal
else
disp := 0;
end (* simple address *)
else
begin
if abs(postordinal) <= maxordinal then
disp := postordinal
else
disp := 0;
stackp := 0;
end;
makeindexcode(la,w,stackp,disp);
makecode(lo,regnumber,oneword*w);
makeindirectcode(am,0,stackaddr,index^.addr.ordinal);  (* tmp *)
makeindexcode(rs,regnumber,stackp,disp);
registerÆwÅ.valid := false;
registerÆregnumberÅ.valid := false;
if ps1 <> nil then returnpseudo(ps1);
end  (* index^.kind = reg *)
else
begin
index1 := index;
returnpseudo(index1);
index := nil;
end;
addr := addr1;
end; (* index <> nil *)
if index <> nil then (* index was changed to nil in the former section if
all the array indices were constant therefore it is tested once more*)

begin
addr := addr1;
index1 := index;
returnpseudo(index1);
index := nil;
end
else
begin
if simpleaddr then
begin
if blocknumber = level then
stackp := stackaddr
else
stackp := 0;
(* indicates that an  am  instruction is required before the la, and rs *)
disp := ordinal;
end
else
begin
lastused := lastindex; (* avoid freeing of register(regnumber) *)
disp := freeregister(true);
loadnotsimple(reference^,disp,pckptr);
ps := newpseudo;
ps^.typ := integertype;
stackp := disp;
makeregister(ps,stackp);
disp := postordinal; (* even displacement *)
end;
siz := user^.typ^.bitsize;
shift := maxbit - bitstart + 1 - siz;
if (siz = (maxbit + 1) div oneword) and ((shift = 0) or (shift = (maxbit+1) div oneword)) then
begin  (* half word *)
if shift = 0 then  (* right half word *)
disp := disp + 1;
if stackp = 0 then
begin
reservecode(4);
makeindirectcode(am,0,stackaddr,display+blocknumber); (* am  (x2+BN+display) *)
end;
if abs(disp) <= maxordinal then
makeindexcode(hs,regnumber,stackp,disp)
else
begin
if code^.cÆlastindexÅ.opcode = am then
changeamcode(disp)
else
begin
makeallcode(am,0,reladdr,indirectmode,0,0);
makeconst(disp,nil);
end;
makeindexcode(hs,regnumber,stackp,0);
end;
end
else (* not a half word *)
begin
lastused := lastindex; (* avoid freeing of register(regnumber) *)
w := freeregister(false);
makewrelcode(rl,w,0);
makeconst(-1 - bitmaskÆmaxbit - bitstart + 1Å + bitmaskÆshiftÅ,nil);
disp1 := disp;
if abs(disp) <= maxordinal then
begin
if stackp = 0 then
makeindirectcode(am,0,stackaddr,display+blocknumber); (* am  (x2+BN+display) *)
makeindexcode(la,w,stackp,disp1);
end
else
begin
if stackp = 0 then
amchange(blocknumber,disp1)
else
begin
reservecode(2);
makeallcode(am,0,reladdr,indirectmode,0,0);
makeconst(disp,nil);
disp1 := 0;
end;
makeindexcode(la,w,stackp,disp1);
end;
if shift <> 0 then
makecode(ls,regnumber,shift);
makecode(lo,regnumber,oneword * w);
if abs(disp) > maxordinal then
begin
if stackp = 0 then
amchange(blocknumber,disp)
else
begin
reservecode(2);
makeallcode(am,0,reladdr,indirectmode,0,0);
makeconst(disp,nil);
end;
end
else
if stackp = 0 then
makeindirectcode(am,0,stackaddr,display+blocknumber); (* am  (x2+BN+display) *)
makeindexcode(rs,regnumber,stackp,disp1);
registerÆwÅ.valid := false;
end; (* not half word *)
if not simpleaddr then
begin
(* register(stackp) has been reserved for address information
which is of no interest any more *)
registerÆstackpÅ.valid := false;
returnpseudo(ps);
end;
registerÆregnumberÅ.valid := false; (* do not remember packed results *)
end;
end (* packk <> unpack *)
else
begin
(* not simple addr and packk = unpack *)
count := maxreg;
repeat
found := (registerÆcountÅ.user = nil) and (count <> stackaddr) and (count <> nodestroy);
count := count - 1;
until (found or (count < 0));
freereg := count + 1;
if not found or (freereg=0)then
begin
if regnumber = 0 then
freereg := maxreg else freereg := noofreg - regnumber;
storetmp(registerÆfreeregÅ.user);
end;
registerÆfreeregÅ.valid := false;
ps := registerÆregnumberÅ.user;
if ps = nil then
begin
ps := newpseudo;
ps^.typ := integertype;
makeregister(ps,regnumber);
end;
addr1 := addr;  (* for two reasons: 1: to be used as parameter (packed)
2: in case of temp store of rightside-value: don't forget the address *)
loadnotsimple(reference^,freereg,pckptr);
if index <> nil then
begin
ps1 := newpseudo;
ps1^.typ := integertype;
makeregister(ps1,freereg);
indexaddress(addr1,siz);
with addr1 do
begin
if index^.kind = reg then
begin
v1 := index^.regno;
if ps1^.kind <> reg then
begin
makeindexcode(wa,v1,stackaddr,ps1^.addr.ordinal);
index^ := ps1^;
freereg := v1;
makeregister(ps1,freereg);
end
else
begin
with registerÆv1Å do
begin
user := nil;
valid := false;
end;
makecode(wa,freereg,oneword*v1);
end;
end; (* index = register *)
end; (* with addr1 do *)
returnpseudo(ps1);
end; (* if index <> nil *)
if ps^.kind <> reg then
begin
if (freereg = regnumber) or ((ps^.typ^.size > oneword)
and (freereg=((regnumber+1) mod noofreg))) then
begin
if regnumber = 0 then
v1 := maxreg else v1 := noofreg - regnumber;
makecode(rl,v1,oneword*freereg);
with registerÆfreeregÅ do
begin
user := nil;
valid := false;
end;
freereg := v1;
makeregister(ps1,freereg);
end;
loadregister(regnumber,ps);
end;
addr := addr1;
(* this assignment has been delayed until 'regnumber' really (again)
contained the rightside-value *)

index1 := index;
returnpseudo(index1);
index := nil;
if abs(postordinal) <= maxordinal then
disp := postordinal
else
begin
reservecode(2);
disp := 0;
makeallcode(am,0,reladdr,indirectmode,0,0);
makeconst(postordinal,nil);
end;
makeindexcode(rs,regnumber,freereg,disp);
end;
kind := tmp;  (* prevent storing the register more than once *)
locassociated := true;
end; (* if kind = variable *)
if user <> nil then
begin
next := user;
repeat
if next^.kind <> reg then
nextnext := nil
else
nextnext := next^.sameregister;
if locassociated then
begin
next^.kind := variable;
next^.addr := addr;
end
else
next^.kind := tmp;
next := nextnext;
until next = nil;
end;
end;
if not addr.simpleaddr then
begin
field := valid; (* valid is false for packed fields *)
forgetregisters;
(* avoid unpredictable side effects with pointer variables and VAR parameters *)
valid := field;
end;
end (* if (kind = variable) or (kind = tmp)  *)
else  (* constant *)
if (user <> nil) and (kind <> expression) then (* cheat *)
begin
next := user;
repeat
if next^.kind <> reg then
nextnext := nil
else
begin
nextnext := next^.sameregister;
next^.kind := kind;
if kind = longcst then
next^.constptr := constptr
else (* one-word constant *)
next^.constant := constant;
end;
next := nextnext;
until next = nil;
end; (* constant *)
registerÆregtostoreÅ.user := nil;
end; (* register store *)


procedure store(regnumber : regrange; ps : pseudoptr);
(*change the register desription to be ps and the pseudonode
to be of kind register, and let register.kind := variable,
and make code to store the content of the register *)
var
count : integer;
nextreg : regrange;
notvalid : boolean;

begin
if (ps^.kind <> variable) and (ps^.kind <> tmp) then
error(403)
else
begin
for count := 0 to maxreg do
with registerÆcountÅ do
if ((user <> nil) or valid) and ((kind = variable) and
sameaddress(ps^.addr,addr)) then
begin
user := nil;
valid := false;
end;
with registerÆregnumberÅ do
begin
 if ((kind=tmp) or (kind=variable) ) and valid then
 if not addr.simpleaddr then
 returnaddress(addr.reference);
user := ps;
valid := true;
kind := variable;
addr := ps^.addr;
notvalid := addr.index <> nil; (* if array ref then forget the reg contents after storing *)
locassociated := ps^.kind = variable;
with ps^ do
begin
if typ^.size > oneword then
begin
nextreg := (regnumber + 1) mod noofreg;
registerÆ nextreg Å := registerÆ regnumber Å;
end;
kind := reg;
regno := regnumber;
sameregister := nil;
end;
registerstore(regnumber,regnumber);
if notvalid then registerÆregnumberÅ.valid := false;
if ps^.typ^.size > oneword then
begin
registerÆ nextreg Å := registerÆ regnumber Å;
with code^.cÆlastindexÅ do
begin
opcode := ds;
displacement := displacement + oneword;
w := (w + 1) mod noofreg;
end;
end;
end;
end;
end;  (* store *)


procedure storeregisters(nostore : pseudoptr);
(* store away all registers holding variables,
without destroying the one (if any) specified by nostore  *)
var
j, savereg : integer;

begin
if nostore <> nil then
savereg := nostore^.regno
else
savereg := -1;
for j := maxreg downto 0 do
with registerÆjÅ do
begin
if (user <> nil) then
registerstore(j,savereg);
valid := false;
end;
end;


procedure loadsimple(var addr:addrnode; regnumber:regrange;
var pckptr : packindicator);
var
v, v1, siz, regnr : integer;
index1 : pseudoptr;
amcode : boolean;

begin
pckptr.size := maxbit;
regnr := regnumber;
if regnumber = 0 then
begin
if registerÆ3Å.user = nil then regnumber := 3
else if registerÆ1Å.user = nil then regnumber := 1
else error(403);
registerÆregnumberÅ.valid := false;
end;
v := regnumber;
with addr do
begin
if index <> nil then
indexaddress(addr,siz);
if blocknumber = level then
begin
if index <> nil then
begin
if index^.kind = reg then
begin
reservecode(3);
v := index^.regno;
with pckptr do
if siz <> maxbit then
begin
size := siz;
ps := newpseudo;
ps^.typ := integertype;
makeregister(ps,(v+maxreg) mod noofreg);
storetmp(ps);
end;
if v = 0 then
makeindirectcode(am,0,0,0) (* am (0) *)
else
makeindexcode(am,0,v,0);    (* am  x  *)
end;
index1 := index;
returnpseudo(index1);
index := nil;
registerÆvÅ.valid := registerÆvÅ.user <> nil;
end;
if abs(ordinal) < maxordinal then
makeindexcode(rl,regnr,stackaddr,ordinal)
else
begin
reservecode(5);
with code^.cÆlastindexÅ do
begin
amcode := opcode = am;
v1 := index;
(* if index <> stackaddr and amcode then array-index = register(index) *)
end;
if amcode then
begin
with code^ do cÆlastindex + 1Å := cÆlastindexÅ;
lastindex := lastindex - 1;
makewrelcode(wa,v1,0); (* v1 <> stackaddr !! *)
makeconst(ordinal,nil);
lastindex := lastindex + 1;
end
else (* not amcode *)
begin
makeallcode(am,0,reladdr,indirectmode,0,0);  (* am. (ordinalconst) *)
makeconst(ordinal,nil);
end;
makeindexcode(rl,regnr,stackaddr,0);
end;
end
else
begin
if index = nil then
makeindexcode(rl,regnumber,stackaddr,display+blocknumber)
else
begin
reservecode(4);
v := 0;
if index^.kind = reg then
begin
reservecode(3);
v := index^.regno;
with pckptr do
if siz <> maxbit then
begin
size := siz;
ps := newpseudo;
ps^.typ := integertype;
makeregister(ps,(v+maxreg) mod noofreg);
storetmp(ps);
end;
makeindexcode(wa,v,stackaddr,display+blocknumber);
if v = 0 then
makeindirectcode(am,0,0,0); (* am (0) *)
end
else
makeindirectcode(am,0,stackaddr,display + blocknumber);
index1 := index;
returnpseudo(index1);
index := nil;
registerÆvÅ.valid := registerÆvÅ.user <> nil;
end;
if abs(ordinal) < maxordinal then
makeindexcode(rl,regnr,v,ordinal)
else
begin
reservecode(5);
with code^.cÆlastindexÅ do
begin
amcode := opcode = am;
v1 := index;
(* if index <> stackaddr and amcode then array-index = register(index) *)
end;
if amcode then
begin
if v1 <> stackaddr then
begin
with code^ do cÆlastindex + 1Å := cÆlastindexÅ;
lastindex := lastindex - 1;
makewrelcode(wa,v1,0); (* v1 <> stackaddr !! *)
makeconst(ordinal,nil);
lastindex := lastindex + 1;
end
else
begin
(* delete am (x2+display+BN); and make wa to the free register regnumber *)
lastindex := lastindex -1;
makeindexcode(rl,regnumber,stackaddr,display+blocknumber);
makewrelcode(wa,regnumber,0);
makeconst(ordinal,nil);
v := regnumber;
end;
end
else (* not amcode *)
begin
makeallcode(am,0,reladdr,indirectmode,0,0);
makeconst(ordinal,nil);
end;
makeindexcode(rl,regnr,v,0);
end;
end;
end; (* with ... *)
end; (* load simple *)


procedure indexcode(var address : addrnode; var pckptr : packindicator;
var v : regrange; preserve : pseudoptr; double : boolean);
(* v is an index register containing address information
preserve is (if present) a register which must not be used for the index,
double tells if register(preserve - 1) must be zeroed before the am
instructions, this is necessary before a  wd ,
note: the procedure  may terminate with at most one
am-instruction  *)

var
ps, index1 : pseudoptr;
returnps : boolean;
ww, w, w1, siz : integer;

begin
pckptr.size := maxbit;
with address do
begin
if preserve <> nil then w1 := preserve^.regno;
ps := registerÆvÅ.user;
if ps = nil then
begin
returnps := true;
ps := newpseudo;
ps^.typ := integertype;
makeregister(ps,v);
end
else returnps := false;
indexaddress(address,siz);
if index^.kind = reg then
begin
w := index^.regno;
with pckptr do
if siz <> maxbit then
begin
size := siz;
ps := newpseudo;
ps^.typ := integertype;
makeregister(ps,(w+maxreg) mod noofreg);
storetmp(ps);
end;
if preserve <> nil then
begin
if preserve^.kind <> reg then  (* preserve is a temporary *)
begin
if (w = w1) or ((preserve^.typ^.size > oneword) and
(w = ((w1+1) mod noofreg))) then
storetmp(registerÆwÅ.user);
loadregister(w1,preserve);
end;
if double and (index^.kind = reg) then
begin
ww := (w1 + maxreg) mod noofreg;
if w = ww then
storetmp(registerÆwÅ.user);
(* sign extension before a wd instruction *)
makecode(bl, ww, 2*w1);
makecode(bl, ww, 2*ww);
end;
end;
if ps^.kind <> reg then
(* the register has been used for index calculation, and the
former content is stored in a temporary *)
begin
if index^.kind = reg then
begin
v := w;
makeindexcode(wa,w,stackaddr,ps^.addr.ordinal); (* tmp *)
if w = 0 then
begin
reservecode(4);
makeindirectcode(am,0,0,0); (* am  (0) *)
end;
end
else
begin
v := 0;
if nooffreetmp < 4 then error(311);
makeindexcode(rs,1,stackaddr,fstfreetmp);
makeindexcode(rl,1,stackaddr,index^.addr.ordinal);
makeindexcode(wa,1,stackaddr,ps^.addr.ordinal);
makeindexcode(rs,1,stackaddr,ps^.addr.ordinal);
makeindexcode(rl,1,stackaddr,fstfreetmp);
reservecode(4);
makeindirectcode(am,0,stackaddr,ps^.addr.ordinal); (* am  (x2+tmp) *)
end;
end
else
begin
reservecode(4);
if index^.kind = reg then
if w = 0 then
makeindirectcode(am,0,0,0) (* am (0) *)
else
makeindexcode(am,0,w,0)    (* am  x  *)
else
makeindirectcode(am,0,stackaddr,index^.addr.ordinal);
end;
index1 := index;
returnpseudo(index1);
index := nil;
registerÆwÅ.valid := registerÆwÅ.user <> nil;
end;
end;
if returnps then returnpseudo(ps);
end;  (* index code *)


procedure loadnotsimple;
(* FORWARD declared with parameter list: (VAR addr:addrnode; regnumber:regrange;
VAR pckptr : packindicator) *)
var
v : regrange;
 count, amcount, disp, regnr : integer;
index1 : pseudoptr;

begin
regnr := regnumber;
if regnumber = 0 then
begin
if registerÆ3Å.user = nil then regnumber := 3
else if registerÆ1Å.user = nil then regnumber := 1
else error(403);
registerÆregnumberÅ.valid := false;
end;
if addr.simpleaddr then
loadsimple(addr,regnumber,pckptr)
else
begin
loadnotsimple(addr.reference^,regnumber,pckptr);
with addr do
begin
v := regnumber;
if index <> nil then
indexcode(addr,pckptr,v,nil,false);
if abs(postordinal) <= maxordinal then
disp := postordinal
else
begin
amcount := 0;
with code^ do
begin
while cÆlastindex - amcountÅ.opcode = am do
amcount := amcount + 1;
for count := 1 to amcount do
cÆlastindex + 2 -countÅ := cÆlastindex + 1 - countÅ;
lastindex := lastindex - amcount;
makewrelcode(wa,v,0);
makeconst(postordinal,nil);
lastindex := lastindex + amcount;
end; (*with code*)
disp := 0;
end;
makeindexcode(rl,regnr,v,disp);
end; (* with ... *)
end;
end;  (* load not simple *)


procedure changeamcode; (* disp : integer *)
var
v : integer;

begin
with code^ do
begin
v := cÆlastindexÅ.index;
if (v <> stackaddr) and
(not((v=0) and (cÆlastindexÅ.indirect=directmode))) then
begin
cÆlastindex + 1Å := cÆlastindexÅ;
lastindex := lastindex -1;
makewrelcode(wa,v,0);
makeconst(disp,nil);
lastindex := lastindex + 1;
end
else (* index = stackadr, i.e. am (x2+tmp) *)
begin
cÆlastindex + 1Å := cÆlastindexÅ;
lastindex := lastindex - 1;
if nooffreetmp < 4 then error(311);
makeindexcode(rs,1,stackaddr,fstfreetmp);
lastindex := lastindex + 1;
with cÆlastindexÅ do
begin
opcode := rl;
indirect := directmode;
w := 1;
end;
makewrelcode(wa,1,0);
makeconst(disp,nil);
makeindexcode(rs,1,stackaddr,fstfreetmp+oneword);
makeindexcode(rl,1,stackaddr,fstfreetmp);
reservecode(4);
makeindirectcode(am,0,stackaddr,fstfreetmp+oneword);
end;
end;
end;



procedure addresscode(var address : addrnode; w, x : regrange);
var
v : integer;
index1 : pseudoptr;

begin
with address do
begin
if index <> nil then
begin
if index^.kind = reg then
begin
reservecode(4);
v := index^.regno;
with code^.cÆlastindexÅ do
if opcode = am then
begin
opcode := wa;
w := v;
indirect := directmode;
end;
if v = 0 then
makeindirectcode(am,0,0,0) (* am (0) *)
else
if x <> 0 then
makeindexcode(am,0,v,0)    (* am  x?  *)
else x := v;
registerÆvÅ.valid := false;
end;
index1 := index;
returnpseudo(index1);
index := nil;
end;
if abs(ordinal) <= maxordinal then
makeindexcode(al,w,x,ordinal)
else
begin
reservecode(3);
with code^, cÆlastindexÅ do
if opcode = am then
changeamcode(ordinal)
else (* former instruction <> am *)
begin
makeallcode(am,0,reladdr,indirectmode,0,0);  (* am. (ordinalconst) *)
makeconst(ordinal,nil);
end;
makeindexcode(al,w,x,0);
end;
end;
end;  (* address code *)



procedure loadaddress; (* FORWARD declared (regnumber : regrange; ps : pseudoptr) *)
(* load the address of the variable with address
in ps into regnumber                                            *)
var
v : regrange;
 count, amcount, regnr, size : integer;
pckptr : packindicator;

begin
if registerÆregnumberÅ.user <> nil then
registerstore(regnumber,-1);
regnr := regnumber;
with ps^ do
begin
case kind of
variable,
tmp: begin
if regnumber = 0 then
begin
if registerÆmaxregÅ.user = nil then
regnumber := maxreg
else if registerÆ1Å.user = nil then regnumber := 1
else error(403);
registerÆregnumberÅ.valid := false;
end;
with addr do
if simpleaddr then
begin
if index <> nil then indexaddress(addr,size);
if blocknumber = level then
addresscode(addr,regnr,stackaddr)
else
begin
if index = nil then
makeindexcode(rl,regnumber,stackaddr,display+blocknumber)
else
begin
regnumber := 0;
reservecode(5);
makeindirectcode(am,0,stackaddr,display+blocknumber);
end;
addresscode(addr, regnr, regnumber);
end;
end
else
begin
loadnotsimple(reference^,regnumber,pckptr);
v := regnumber;
if index <> nil then
indexcode(addr,pckptr,v,nil,false);
if (postordinal <> 0) or (regnr <> v) then
if abs(postordinal) <= maxordinal then
makeindexcode(al,regnr,v,postordinal)
else
begin
with code^ do
begin
amcount := 0;
while cÆlastindex - amcountÅ.opcode = am do
amcount := amcount + 1;
for count := 1 to amcount do
cÆlastindex + 2 -countÅ := cÆlastindex + 1 - countÅ;
lastindex := lastindex - amcount;
makewrelcode(wa,v,0);
makeconst(postordinal,nil);
lastindex := lastindex + amcount;
end; (*with code*)
makeindexcode(al,regnr,v,0);
end;
end;
end;  (* variable, tmp *)
shortsignedcst, wordcst: begin
reservecode(2);
makewrelcode(al,regnumber,0);
makeconst(constant,nil);
end;
longcst: begin
reservecode(typ^.size div oneword + 2);
makewrelcode(al,regnumber,0);
makeconst(0,constptr);
end; (* long constant *)
end;
registerÆregnrÅ.valid := false; (* the content of the register node is unspecified *)
end;
end; (* load address *)


procedure searchregisters(ps : pseudoptr; var regfound : boolean);
(* search the registers to see if ps is there *)
var
found : boolean;
count : integer;

begin
if ps^.kind = reg then
begin
count := ps^.regno;
found := true;
end
else
begin
found := false;
count := -1;
repeat
count := count + 1;
with registerÆcountÅ do
if (user <> nil) or valid then
if (kind = ps^.kind) or ((kind = tmp) and (ps^.kind = variable)) then
case kind of
variable,
tmp: found := sameaddress(addr,ps^.addr) and locassociated;
shortsignedcst,
wordcst: found := constant = ps^.constant;
longcst: found := constptr = ps^.constptr
end; (* case kind *)
until (found or (count = maxreg));
end;
if found then
with registerÆcountÅ do
begin
if ps^.typ^.size > oneword then
begin
if kind = longcst then
(* if the variable/constant is in reg(maxreg) and (0) then count := maxreg *)
begin
if (constptr = registerÆmaxregÅ.constptr) and
registerÆmaxregÅ.valid and (registerÆmaxregÅ.kind = longcst) then
begin
count := maxreg;
registerÆmaxregÅ.user := ps;
end
else
if (constptr = registerÆ1Å.constptr) and
registerÆ1Å.valid and (registerÆ1Å.kind = longcst) then
registerÆ1Å.user := ps
else
found := false;
end
else (* variable or tmp *)
if sameaddress(addr,registerÆmaxregÅ.addr) and registerÆmaxregÅ.valid then
begin
registerÆmaxregÅ.user := ps;
count := maxreg;
end
else
if (count = 0) and sameaddress(addr,registerÆ1Å.addr) and registerÆ1Å.valid then
registerÆ1Å.user := ps
else
found := false;
end;
if found and (ps^.kind <> reg) then
begin
ps^.kind := reg;
ps^.sameregister := user;
user := ps;
ps^.regno := count;
end;
end;
regfound := found;
end; (* search the registers for ps *)


procedure loadregister; (* regnumber : regrange; ps : pseudoptr *)
(* load register(regnumber) with ps *)
var
help, shift, siz, count : integer;
found : boolean;
pckptr : packindicator;

begin
searchregisters(ps, found);
with registerÆregnumberÅ do
begin
if (user <> nil) and
(not (locassociated and sameaddress(addr,ps^.addr)))
and ((ps^.kind <> reg) or (ps^.regno <> regnumber)) then
registerstore(regnumber,-1);
case ps^.kind of
reg: begin
with ps^ do
begin
if regno = regnumber then
registerÆregnumberÅ.user := ps
else
if typ^.size > oneword then
begin
makecode(dl,(regnumber+1) mod noofreg,((regno+1) mod noofreg)*oneword);
help := (regno + maxreg) mod noofreg;
registerÆregnumberÅ := registerÆregnoÅ;
registerÆ(regnumber + maxreg) mod noofregÅ := registerÆhelpÅ;
with registerÆhelpÅ do
begin
user := nil;
valid := false;
end;
end
else
begin
if regno = 0 then
makecode(rl,regnumber,0)
else
makeindexcode(al,regnumber,regno,0);
registerÆregnumberÅ := registerÆregnoÅ;
user := ps;
lastused := lastindex;
with registerÆregnoÅ do
begin
user := nil;
valid := false;
end;
end;
end; (* with ... *)
end; (* kind = reg *)
variable,
tmp: begin
with ps^.addr do
case packk of
hlfword,
signedhlfword,
paack: (* unpack and load register *)
begin
if simpleaddr then
loadsimple(ps^.addr, regnumber,pckptr)
else
loadnotsimple(ps^.addr, regnumber,pckptr);
if pckptr.size = maxbit then
siz := ps^.typ^.bitsize
else
begin
siz := pckptr.size;
makeindirectcode(am,0,stackaddr,pckptr.ps^.addr.ordinal);
returnpseudo(pckptr.ps);
end;
shift := bitstart + siz - 1 - maxbit;
if (shift <> 0) or (pckptr.size <> maxbit) then
makecode(ls,regnumber,shift);
if siz = (maxbit + 1) div oneword then
(* halfwords are loaded with byte instructions *)
if packk = signedhlfword then
makecode(bl,regnumber,regnumber*oneword+1)
else
makecode(bz,regnumber,regnumber*oneword+1)
else
if (bitstart <> 0 ) or (pckptr.size <> maxbit) then
begin
makewrelcode(la,regnumber,0);
makeconst(bitmaskÆsizÅ,nil);
end;
end; (* hlfword, signedhlfwrd, paack *)
unpack: if ps^.typ^.size > oneword then
(* need 2 registers *)
begin
if regnumber = maxreg then
begin
user := nil;
valid := false;
(* free registers 0 and 1 *)
for count := 0 to 1 do
with registerÆcountÅ do
if user <> nil then
registerstore(count,-1);
end
else
if regnumber = 0 then
if (registerÆ1Å.user <> ps) and
((registerÆ1Å.user <> nil) or registerÆ1Å.valid) then
registerstore(1,-1);
regnumber := 1;
if ps^.addr.simpleaddr then
loadsimple(ps^.addr,regnumber,pckptr)
else
loadnotsimple(ps^.addr,regnumber,pckptr);
(* change the code from  rl  to  dl *)
with code^.cÆlastindexÅ do
begin
opcode := dl;
displacement := displacement + oneword;
end;
for count := 0 to 1 do
with registerÆcountÅ do
begin
user := ps;
lastused := lastindex;
valid := true;
locassociated := true;
kind := tmp;
addr := ps^.addr;
end;
regnumber := (regnumber + maxreg) mod noofreg;
end
else
if simpleaddr then
loadsimple(ps^.addr,regnumber,pckptr)
else
loadnotsimple(ps^.addr,regnumber,pckptr);
end; (* case packk of *)
siz := ps^.typ^.size;
if siz = oneword then
begin
user := ps;
locassociated := ps^.kind = variable;
kind := tmp;
(* this is done to avoid storing of unchanged registers *)
valid := true;
lastused := lastindex;
addr := ps^.addr;
end;
if ps^.kind = tmp then
begin
nooffreetmp := nooffreetmp + siz;
fstfreetmp := fstfreetmp - siz;
end;
end; (* variable, tmp: *)
shortsignedcst,
wordcst: begin
constant := ps^.constant;
if ps^.kind = shortsignedcst then
makecode(al,regnumber,constant)
else
begin
makewrelcode(rl,regnumber,0);
makeconst(constant,nil);
end;
user := ps;
lastused := lastindex;
valid := true;
kind := ps^.kind;
end;
longcst: (* load of a real const or string const *)
begin
if ps^.typ^.size = oneword then (* constant string *)
begin
with registerÆregnumberÅ do
begin
if (user <> nil) or valid then registerstore(regnumber,-1);
user := ps;
lastused := lastindex;
valid := true;
kind := longcst;
constptr := ps^.constptr;
end;
makewrelcode(rl,regnumber,0);
makeconst(0,ps^.constptr);
end
else (*real or double-word string *)
begin
if regnumber = maxreg then
begin
user := nil;
valid := false;
end;
for count := 0 to 1 do
with registerÆcountÅ do
begin
if (user <> nil) or valid then registerstore(count,-1);
user := ps;
lastused := lastindex;
valid := true;
kind := longcst;
constptr := ps^.constptr;
end;
regnumber := 0;
reservecode(8);
if ps^.typ^.typkind <> ereal then
makecode(am, 0, oneword); (* the address of the constant denotes the first word *)
makewrelcode(dl,1,0);
makeconst(0,ps^.constptr);
end;
end;
expression,procfunc,valueinit: error(403);
end; (* case kind of *)
ps^.kind := reg;
ps^.regno := regnumber;
ps^.sameregister := nil;
end; (* with registerÆregnumberÅ do *)
end; (* load register *)


procedure load(ps:pseudoptr);
(* load the variable with address in ps into register(s)
the resultant register is always the first one, even for reals *)
var
count, oldused, firstreg : integer;
found : boolean;
result : regrange;

begin (* load *)
searchregisters(ps,found);
if not found then
begin
(* look for a free register, or free one *)
if (ps^.kind = shortsignedcst) or (ps^.kind = wordcst) or (ps^.kind = longcst) then
firstreg := 0 else firstreg := 1;
count := firstreg;
repeat
with registerÆcountÅ do
if (user = nil) and (count <> stackaddr) and not valid then
(* a free register is found *)
begin
found := true;
result := count;
end;
count := count + 1;
until (found or (count > maxreg));
if not found then
begin (* use the oldest register, after storing the content *)
result := firstreg;
oldused := registerÆresultÅ.lastused;
for count := firstreg + 1 to maxreg do
if count <> stackaddr then
with registerÆcountÅ do
if lastused < oldused then
begin
oldused := lastused;
result := count;
end;
end;
loadregister(result,ps);
end;
end; (* load *)

procedure amchange; (* bn : integer; VAR disp : integer *)
var
move, v1 : integer;

begin
with code^ do
begin
reservecode(6);
if abs(disp) <= maxordinal then move := 1
else
move := 2;
if cÆlastindexÅ.opcode = am then
begin
v1 := cÆlastindexÅ.index;
if v1 <> stackaddr then
begin
cÆlastindex+moveÅ := cÆlastindexÅ;
lastindex := lastindex - 1;
if move = 2 then
begin
makewrelcode(wa,v1,0);
makeconst(disp,nil);
disp := 0;
end;
makeindexcode(wa,v1,stackaddr,display+bn);
lastindex := lastindex + 1;
end  (* v1 <> stackaddr *)
else
begin
if nooffreetmp < 4 then error(311);
cÆlastindex + 1Å := cÆlastindexÅ;
lastindex := lastindex - 1;
makeindexcode(rs,1,stackaddr,fstfreetmp);
lastindex := lastindex + 1;
with cÆlastindexÅ do
begin
(* change am (x2+tmp) to rl 1,x2+tmp *)
opcode := rl;
w := 1;
indirect := directmode;
end;
if move = 2 then
begin
makewrelcode(wa,1,0);
makeconst(disp,nil);
disp := 0;
end;
makeindexcode(wa,1,stackaddr,display+bn);
makeindexcode(rs,1,stackaddr,fstfreetmp+oneword);
makeindexcode(rl,1,stackaddr,fstfreetmp);
makeindirectcode(am,0,stackaddr,fstfreetmp+oneword);
end;
end
else
(* not am code *)
begin
if move = 2 then
begin
if nooffreetmp < 4 then error(311);
makeindexcode(rs,1,stackaddr,fstfreetmp);
makeindexcode(rl,1,stackaddr,display+bn);
makewrelcode(wa,1,0);
makeconst(disp,nil);
makeindexcode(rs,1,stackaddr,fstfreetmp+oneword);
makeindexcode(rl,1,stackaddr,fstfreetmp);
makeindirectcode(am,0,stackaddr,fstfreetmp+oneword);
disp := 0;
end
else  (* disp <= maxordinal *)
makeindirectcode(am,0,stackaddr,display+bn);
end;
end;
end;


procedure operation( op : opcodes; expr, left, right : pseudoptr);
(* make code for: load(left)
.                 op  w  right
it may save some code to do the address calculation
for left and right in parallel                       *)
var
v, w, x : regrange;
disp, rsize, count : integer;
found : boolean;
index1 : pseudoptr;
pckptr : packindicator;

procedure checkdoubleregister(op : opcodes; var operand : regrange);
(* if op is a double register operation then make code to save
the content of the register used in connection with operand by op;
if the operand register is maxreg then use registers 0 and maxreg, i.e. save reg(0) and
move the content of reg(maxreg) to reg(0) and change operand to 0 *)
var
reserve : integer;

begin (* check double register *)
if (op=wm) or (op=wd) or (op=ci) then
begin
reserve := (operand + maxreg) mod noofreg;
if reserve = stackaddr then
begin
(* use reg(0) and (maxreg), i.e. let (0) be the operand register *)
with registerÆ0Å do
if user <> nil then
registerstore(0,maxreg);
registerÆ0Å := registerÆmaxregÅ;
with registerÆmaxregÅ do
begin
user := nil;
valid := false;
end;
makeindexcode(al,0,maxreg,0);
reserve := maxreg;
operand := 0;
end
else  (* reserve <> stackaddr *)
with registerÆreserveÅ do
begin
if user <> nil then
registerstore(reserve,-1);
valid := false;
user := nil;
end;
if op = wd then 
begin (* sign extension *)
makecode(bl, reserve, 2*operand);
makecode(bl, reserve, 2*reserve);
end;
end; (* op = wm or wd or ci *)
end; (* check double register *)

procedure load_packed_right;
(* in case of a packed right operand the operand is loaded
and it is assured that the left operand is in register w at procedure
exit, and if op=wd the sign extension is done once more.
disp and v is assigned suitable for
"makeindexcode(op, w, v, disp)"     *)

begin
load(right);
(* check whether right can stay in a register *)
if (w=right^.regno) or
((op = wd) and (right^.regno = (w + maxreg) mod noofreg)) then
begin
storetmp(right); (* register(right) is needed for the operation *)
disp := right^.addr.ordinal;
v := stackaddr;
end
else
begin
v := 0;
disp := right^.regno * oneword;
with registerÆ disp div 2 Å do
begin
user := nil;
valid := false;
end;
end;

(* now assure that left is in register w *)
with left^ do
if kind <> reg then
if (kind = variable) or (kind = tmp) then
loadregister(w, left)
else
(* kind = word constant or short signed constant *)
if abs(constant) <= maxordinal then
makecode(al, w, constant)
else
begin
makewrelcode(rl, w, 0);
makeconst(constant, nil);
end;

if op = wd then (* extend the sign of left *)
checkdoubleregister(wd, w);

end; (* load packed right *)

procedure load_not_simple_right(right : pseudoptr);

(* get a register and load a pointer to the start of the
structure denoted by right, and assure that left is still
in register w at exit; let v and disp be prepared for
"makeindexcode(op, w, v, disp) "  , at exit there is still reservecode'd 3 words *)
 
begin
with right^.addr do
begin
if w <> 0 then
begin
v := noofreg - w;
if (registerÆvÅ.user <> nil) or registerÆvÅ.valid then
registerstore(v,w);  (* do not destroy w *)
end
else
begin
(* use register 1 to avoid convflict with a possible sign extension in
register 3  *)
with register Æ 1 Å do
if (user <> nil) or valid then
registerstore( 1, w );
v := 1;
end; (* w = 0 *)
loadnotsimple(reference^,v,pckptr);
with left^ do
if kind <> reg then (*left must be loaded once more *)
begin
if (kind = variable) or (kind = tmp) then 
(* left is temporary stored, or "easy" to load again
without destroying registers *)
loadregister(w, left)
else
if (kind = wordcst) or (kind = shortsignedcst) then
if abs(constant) <= maxordinal then
makecode(al,w,constant)
else
begin
makewrelcode(rl,w,0);
makeconst(constant,nil);
end
else (* longconstant *)
begin
makewrelcode(dl,w,0);
makeconst(0,constptr);
end;
checkdoubleregister(op,w);
end;

if rsize > oneword then postordinal := postordinal + oneword;
if index <> nil then
indexcode(right^.addr,pckptr,v,left,op=wd);
registerÆvÅ.valid := false; (* forget the contents of reg(v) *)
if abs(postordinal) <= maxordinal then
disp := postordinal
else
begin
disp := 0;
if code^.cÆlastindexÅ.opcode = am then
changeamcode(postordinal)
else
begin
reservecode(5);
makeallcode(am,0,reladdr,indirectmode,0,0);
makeconst(postordinal,nil);
end;
end;
(* note: we still have reservecode'd about 3 words *)

end; (* with right^.regno do *)
 end;  (* load not simple right *)




(* ******   operation    ****** *)

begin
w := stackaddr;
rsize := right^.typ^.size;
searchregisters(left,found);
case left^.kind of
shortsignedcst, wordcst, longcst,
reg: begin
with left^ do
begin
if kind <> reg then load(left);
if rsize > oneword then
w := (regno + 1) mod noofreg
else w := regno;
end; (* with *)
checkdoubleregister(op,w);
searchregisters(right, found);
case right^.kind of
reg: begin
with right^ do
if rsize > oneword then
v := (regno + 1) mod noofreg  else v := regno;
reservecode(3);
makecode(op,w,v*oneword);
end; (* reg: *)
variable,
tmp: begin
with right^.addr do
if packk = unpack then
if simpleaddr then
begin
if index <> nil then indexaddress(right^.addr,count);
if rsize > oneword then ordinal := ordinal + oneword;
if index <> nil then
begin
if index^.kind = reg then
begin
x := index^.regno;
if left^.kind <> reg then  (* left is a temporary *)
begin
if (x = w) or ((rsize > oneword) and
(x = ((w+maxreg) mod noofreg))) then
storetmp(registerÆxÅ.user);
loadregister(w,left);
end;
if (op = wd) and (index^.kind = reg) then
(* the sign extension may have been destroyed during index
calculation, e.g. the calculated index may be in the register needed
by wd, therefore it is checked once more *)
checkdoubleregister(wd (* op = wd *), w );
reservecode(5); (* 5 in order to ensure a call of amchange *)
if index^.kind = reg then
if x = 0 then
makeindirectcode(am,0,0,0) (* am  (0) *)
else
makeindexcode(am,0,x,0)   (* am   x *)
else
makeindirectcode(am,0,stackaddr,index^.addr.ordinal);
registerÆxÅ.valid := registerÆxÅ.user^.sameregister <> nil;
end;
index1 := index;
returnpseudo(index1);
index := nil;
end;
if blocknumber <> level then
begin
disp := ordinal;
amchange(blocknumber, disp);
v := 0;
end
else
begin
v := stackaddr;
if abs(ordinal) <= maxordinal then
disp := ordinal
else
begin
if code^.cÆlastindexÅ.opcode = am then
changeamcode(ordinal)
else
begin
reservecode(5);
makeallcode(am,0,reladdr,indirectmode,0,0);
makeconst(ordinal,nil);
end;
disp := 0;
end;
end;
end
else
begin (* not simpleaddr *)
load_not_simple_right(right);
(* with left kept in register  w , the address of right is
calculated, resulting in  v  and  disp  properly initialized for
"op  w  v+disp"   *)
end
else (* packk <> unpack *)
load_packed_right;
reservecode(3);
makeindexcode(op,w,v,disp);
end;
shortsignedcst,
wordcst:begin
reservecode(4);
makewrelcode(op,w,0);
makeconst(right^.constant,nil);
end;
longcst: begin
reservecode(4);
makewrelcode(op,w,0);
makeconst(0,right^.constptr);
end;
expression,procfunc,valueinit: error(403);
end; (* case right^.kind *)
end; (* left^.kind = reg or shortsignedcst or wordcst *)
variable,
tmp: begin
searchregisters(right, found);
case right^.kind of
reg: begin
if left^.typ^.size > oneword then
begin
if sameaddress(registerÆ0Å.addr, registerÆ1Å.addr) then
v := 1 else v := 0;
with registerÆ0Å do
begin
user := nil;
valid := false;
end;
if v = 1 then count := 1 else count := maxreg;
with registerÆcountÅ do
begin
user := nil;
valid := false;
end;
if nooffreetmp < 4 then error(311);
makeindexcode(ds,v,stackaddr,fstfreetmp+oneword);
load(left);
w := (left^.regno + 1) mod noofreg;
reservecode(3);
makeindexcode(op,w,stackaddr,fstfreetmp+oneword);
end
else
begin
load(left);
w := left^.regno;
checkdoubleregister(op, w);
if right^.kind = reg then
begin
reservecode(3);
makecode(op,w,right^.regno*oneword)
end
else
begin
registerÆwÅ.kind := variable;
operation(op, expr, left, right);
end;
end;
end; (* right^.kind = reg *)
variable,
tmp: with left^ do
begin
if addr.simpleaddr and right^.addr.simpleaddr and
(addr.blocknumber = right^.addr.blocknumber) then
begin
if (addr.blocknumber = level) or (addr.index <> nil)
or (addr.packk <> unpack) then
begin
w := freeregister(false);
if (addr.packk = unpack) and (rsize = oneword) then
begin
loadsimple(addr,w,pckptr);
makeregister(left,w);
end
else
loadregister(w,left);
w := regno; (* only changed for reals *)
with registerÆwÅ do (* force temporary storing of w if necessary *)
begin
kind := variable;
locassociated := false;
end;
if rsize > oneword then
with registerÆ(w+1) mod noofregÅ do
begin
kind := variable;
locassociated := false;
end;
v := stackaddr;
end (* if blocknumber = level *)
else
begin
(* use w3 as stackpointer for the stackframe of which left and right
are variables *)
storeregisters(nil);
w := 1;
makeindexcode(rl,maxreg,stackaddr,display+addr.blocknumber);
with addr do
if abs(ordinal) < maxordinal then
disp := ordinal
else
begin
reservecode(3);
makeallcode(am,0,reladdr,indirectmode,0,0);
makeconst(ordinal,nil);
disp := 0;
end;
v := maxreg;
makeindexcode(rl,w,v,disp);
if rsize > oneword then
begin
w := 0;
makeregister(left,w);
registerÆ1Å := registerÆ0Å;
with code^.cÆlastindexÅ do
begin
opcode := dl;
displacement := displacement + oneword;
end;
end
else
makeregister(left,w);
end; (* now left is loaded into reg(w) *)
(* perform sign extension in case of op=wd *)
checkdoubleregister(op, w);
with right^.addr do
begin
if packk = unpack then
begin
if index <> nil then
begin
indexaddress(right^.addr,count);
if index^.kind = reg then
begin
v := stackaddr; (* a possible common display in reg(3) may have been destroyes *)
x := index^.regno;
if left^.kind <> reg then  (* left is a temporary *)
begin
if (x = w) or ((rsize > oneword) and (x = ((w+1) mod noofreg))) then
storetmp(registerÆxÅ.user);
loadregister(w,left);
end;
if (op = wd) and (index^.kind = reg) then
(* the sign extension may have been destroyed during index 
calculation therefore it is performed once more *)
checkdoubleregister( wd (* op=wd *), w);
reservecode(5);
if index^.kind = reg then
if x = 0 then
makeindirectcode(am,0,0,0) (* am  (0) *)
else
makeindexcode(am,0,x,0)   (* am   x *)
else
makeindirectcode(am,0,stackaddr,index^.addr.ordinal);
registerÆxÅ.valid := registerÆxÅ.user^.sameregister <> nil;
end;
index1 := index;
returnpseudo(index1);
index := nil;
end;
if (blocknumber <> level) and (v <> maxreg) then
(* (v=maxreg) <=> register(maxreg) = display + bn *)
begin
count := 0;
amchange(blocknumber,count);(* second parameter is not used *)
x := code^.cÆlastindexÅ.index;
if (x <> 0) and (x <> stackaddr) then
begin (* the am instruction is not needed *)
v := x;
lastindex := lastindex - 1;
end
else v := 0;
end;
if rsize > oneword then
begin
w := (w+1) mod noofreg;
ordinal := ordinal + oneword;
end;
if abs(ordinal) <= maxordinal then
disp := ordinal
else
begin
if code^.cÆlastindexÅ.opcode = am then
changeamcode(ordinal)
else
begin
reservecode(5);
makeallcode(am,0,reladdr,indirectmode,0,0);
makeconst(ordinal,nil);
end;
disp := 0;
end;
end
else
  (* packed right operand *)
load_packed_right;
end;
reservecode(3);
makeindexcode(op,w,v,disp);
end
else
begin (* not simpleaddr or left.BN <> right.BN *)
load(left);
if rsize > oneword then
begin
with registerÆregnoÅ do
begin
locassociated := false;
kind := variable;
end;
w := (regno + 1) mod noofreg
end
else
w := regno;
with registerÆwÅ do
begin
locassociated := false;
kind := variable; (* ensure temporary storing if necessary *)
end;
checkdoubleregister(op, w);
with right^.addr do
if packk = unpack then
if simpleaddr then
begin
if index <> nil then
begin
indexaddress(right^.addr,count);
if index^.kind = reg then
begin
v := index^.regno;
if left^.kind <> reg then  (* left is a temporary *)
begin
if (v = w) or ((rsize > oneword) and (v = ((w+maxreg) mod noofreg))) then
storetmp(registerÆvÅ.user);
loadregister(w,left);
end;
reservecode(5);
if index^.kind = reg then
if index^.regno = 0 then
makeindirectcode(am,0,0,0) (* am  (0) *)
else
makeindexcode(am,0,index^.regno,0)   (* am   x *)
else
makeindirectcode(am,0,stackaddr,index^.addr.ordinal);
registerÆvÅ.valid := registerÆvÅ.user^.sameregister <> nil;
end;
index1 := index;
returnpseudo(index1);
index := nil;
end;
if rsize > oneword then ordinal := ordinal + oneword;
if blocknumber <> level then
begin
disp := ordinal;
amchange(blocknumber, disp);
v := 0;
end
else
begin
v := stackaddr;
if abs(ordinal) < maxordinal then
disp := ordinal
else
begin
if code^.cÆlastindexÅ.opcode = am then
changeamcode(ordinal)
else
begin
reservecode(5);
makeallcode(am,0,reladdr,indirectmode,0,0);
makeconst(ordinal,nil);
end;
disp := 0;
end;
end;
end
else
begin (* not simpleaddr *)
load_not_simple_right(right);
(* with left kept in register  w  the address of right is
calculated, resulting in  v  and  disp  properly initialized for
" op  w  v+disp "   *)
end
else
(* packkind <> unpack *)
load_packed_right;
reservecode(3);
makeindexcode(op,w,v,disp);
end;
end; (* variable, tmp *)
shortsignedcst,
wordcst: begin
load(left);
w := left^.regno;
checkdoubleregister(op,w);
reservecode(4);
makewrelcode(op,w,0);
makeconst(right^.constant,nil);
end;
longcst: begin
load(left);
w := (left^.regno + 1) mod noofreg; (* must be a double register *)
reservecode(5);
makewrelcode(op,w,0);
makeconst(0,right^.constptr);
end;
expression,procfunc,valueinit: error(403);
end; (* case right^.kind *)
end; (* left^.kind = variable or tmp *)
expression,procfunc,valueinit: error(403);
end; (* case left^.kind of *)
if w = stackaddr then
error(403)
else
with registerÆwÅ do
begin
user := expr;
lastused := lastindex;
valid := true;
kind := variable;
with addr do
begin
index := nil;
simpleaddr := true;
blocknumber := level;
end;
locassociated := false;
end;
(* if double register operation then update the second register *)
(* except for wm, we are not interested in the overflow part *)
if op in Æwd, ci, fa, fs, fm, fdÅ then
begin
registerÆ(maxreg+w) mod noofregÅ := registerÆwÅ;
if op <> wd then
w := (w + maxreg) mod noofreg;
end;
with expr^ do
begin
kind := reg;
regno := w;
sameregister := nil;
end;
end; (* operation *)


procedure evaltoresult(ps:pseudoptr; skipk:skipkind); forward;

procedure pushnest;
var nd:integer;
begin
read(nd);
if nd > maxnest then stop(404);
with neststackÆndÅ do
begin
startindex:=lastindex;
index:=0;
end;
ndepth:=nd;
end;

procedure commute(typ:symbolptr);
var pseudo : pseudoptr;
begin
pseudo:=pseudotop^.next;
if ((pseudo^.kind=wordcst) or (pseudo^.kind=shortsignedcst)) and
((pseudotop^.kind=wordcst) or (pseudotop^.kind=shortsignedcst)) then
begin (* only integer constants *)
case intermitwords of
emult: pseudo^.constant:= pseudo^.constant * pseudotop^.constant;
eadd: pseudo^.constant:= pseudo^.constant + pseudotop^.constant;
eeq: pseudo^.constant:= ord(pseudo^.constant = pseudotop^.constant);
ene: pseudo^.constant:= ord(pseudo^.constant <> pseudotop^.constant);
end;
if (pseudo^.constant <= maxsignedhalfword) and
(pseudo^.constant >= minsignedhalfword) then pseudo^.kind:=shortsignedcst
else pseudo^.kind:=wordcst;
returnpseudo(pseudotop);
end
else
begin
if (pseudotop^.kind=expression) or (pseudo^.kind=wordcst)
or (pseudo^.kind=shortsignedcst) or (pseudo^.kind=longcst) then
begin (*exchange top and top-1 *)
pseudotop^.next:=pseudo^.next;
pseudo^.next:=pseudotop;
pseudotop:=pseudo;
end;
newtop(intermitword,typ,pseudotop^.next,pseudotop);
end;
end; (* commute *)

procedure copyshort(length,start:integer; reverse:boolean);
(* copy length bytes starting with that which has address in
register 1 to that which has address in register 2 + start
if reverse then copy the other way
destroyes register 0 and 3
length +start must be less than maxordinal *)
var
i:integer;
begin
if reverse then
begin
for i:=0 to length div (2*oneword) -1 do
begin
makeindexcode(dl,0,2,i*(2*oneword)+oneword+start);
makeindexcode(ds,0,1,i*(2*oneword)+oneword);
end;
if odd(length div oneword) then
begin
makeindexcode(rl,0,2,length-oneword+start);
makeindexcode(rs,0,1,length-oneword);
end;
end
else
begin
for i:=0 to length div (2*oneword) -1 do
begin
makeindexcode(dl,0,1,i*(2*oneword)+oneword);
makeindexcode(ds,0,2,i*(2*oneword)+oneword+start);
end;
if odd(length div oneword) then
begin
makeindexcode(rl,0,1,length-oneword);
makeindexcode(rs,0,2,length-oneword+start);
end;
end;
end; (* copyshort *)

procedure copylong(length:integer; pseudo:pseudoptr);
(* copy length >=4 bytes starting with that which has address
in register 1 to that which has address in pseudo.
Destroyes register 0 and 3 *)
var
psfrom : pseudoptr;
distance, lgt : integer;
begin
psfrom:=newpseudo;
psfrom^.typ:=integertype;
makeregister(psfrom,1);
loadaddress(3,pseudo);
if psfrom^.kind <> reg then
makeindexcode(rl,1,stackaddr,psfrom^.addr.ordinal);
returnpseudo(psfrom);
storeregisters(nil);
reservecode(16);
if length > maxshortcopy then
begin
lgt:=length-2*oneword;
if lgt < maxsignedhalfword then makeindexcode(al,0,1,lgt)
else
begin
makeindexcode(al,0,1,0);
makewrelcode(wa,0,0);
makeconst(lgt,nil);
end;

distance:=workspaceÆ1Å;
if distance <> 0 then distance:=distance-lastindex-1;
makewrelcode(rs,0,distance);
workspaceÆ1Å:=lastindex;
end;
distance:=workspaceÆ2Å;
if distance <> 0 then distance:=distance-lastindex-1;
makewrelcode(rs,2,distance);
workspaceÆ2Å:=lastindex;
(* remember upper limit and stackaddr in 2 words *)
makeindexcode(al,2,3,0);
if length <= maxshortcopy then copyshort(length,0,false)
else
begin
makeindexcode(dl,0,1,oneword);
makeindexcode(ds,0,2,oneword);
makeindexcode(al,2,2,2*oneword);
makeindexcode(al,1,1,2*oneword);
makeallcode(sh,1,true,true,0,workspaceÆ1Å-lastindex-1);
workspaceÆ1Å:=lastindex;
makerelcode(jl,-5*oneword);
if odd(length div oneword) then
begin
makeindexcode(rl,0,1,0);
makeindexcode(rs,0,2,0);
end
end;
makewrelcode(rl,2,workspaceÆ2Å-lastindex-1);
workspaceÆ2Å:=lastindex;
end; (* copylong *)

procedure forstatement(skip,skip1:opcodes; increment:integer);
var
w:integer;
s:symbolptr;
pseudo : pseudoptr;
begin
with pseudotop^ do
begin
if kind = expression then evaltoresult(pseudotop,noskip);
if kind <> shortsignedcst then
begin
if kind <> reg then load(pseudotop);
storetmp(pseudotop);
end;
case next^.kind of
expression:begin
evaltoresult(next,noskip);
w:=next^.regno;
registerÆwÅ.user:=nil;
storeregisters(next);
if w=0 then
begin
w:=1;
makecode(rl,1,0);
end;
end;
variable:begin
load(next);
w:=next^.regno;
storeregisters(next);
end;
shortsignedcst:begin
storeregisters(nil);
w:=1;
makecode(al,1,next^.constant);
end;
wordcst:begin
storeregisters(nil);
makewrelcode(rl,1,0);
makeconst(next^.constant,nil);
w:=1;
end;
end;
reservecode(5);
if kind = shortsignedcst then makecode(skip1,w,constant)
else makeindirectcode(skip1,w,stackaddr,addr.ordinal);
makerelcode(jl,4*oneword);
if kind = shortsignedcst then
makecode(skip,w,constant)
else
makeindirectcode(skip,w,stackaddr,addr.ordinal);
makerelcode(jl,0);
pushnest;
with neststackÆndepthÅ do
begin
index:=lastindex;
stepregister:=w;
end;
outconstlimit:=outconstlimit-1;
makeindexcode(al,w,w,increment);
end;

s:=getsymbptr;
pseudo:=newpseudo;
with pseudo^ do
begin
typ:=s^.vartypedescr;
kind:=variable;
addr:=s^.varaddr;
end;
store(w,pseudo);
returnpseudo(pseudo);
end; (* forstatement *)

procedure jump(jumplength:integer);
begin
if jumplength < maxsignedhalfword then makerelcode(jl,-jumplength)
else
if jumplength < maxhalfword then
begin
makecode(am,0,minsignedhalfword);
makerelcode(jl,-minsignedhalfword-jumplength-oneword);
end
else
begin
makewrelcode(rl,1,0);
makeconst(-jumplength-oneword,nil);
makeallcode(jl,0,true,false,1,0);
end;
end;

procedure boolexpression;
var regnumber : regrange;
begin
with pseudotop^ do
begin
ndepth:=getnumber;
if kind = expression then
begin
storeregisters(nil);
evaltoresult(pseudotop,skiptrue);
end
else
begin
if kind <> reg then load(pseudotop);
regnumber := regno;
storeregisters(pseudotop);
reservecode(2);
makecode(se,regnumber,1);
makerelcode(jl,0);
end;
end;
returnpseudo(pseudotop);
end;

procedure convertconstant(newtyp:symbolptr);
var
localsymb : symbolptr;
string : stringptr;
l, j : integer;
begin
with pseudotop^ do
case newtyp^.typkind of
ereal:if (kind=shortsignedcst) or (kind=wordcst) then
begin
constptr:=makerealconst(constant);
kind:=longcst;
end
else newtop(erightconv,newtyp,pseudotop,nil);
estring,
earray:begin
if kind = shortsignedcst then
begin
new(localsymb);
with localsymb^ do
begin
key:=econst;
consttype:=newtyp;
startchain:=0;
constindex:=0;
constkind:=stringconst;
stringval:=newstring;
with stringval^ do
begin
strÆ1Å:=chr(pseudotop^.constant);
length:=1;
end;
end;
kind:=longcst;
constptr:=localsymb;
end;

if kind = longcst then
begin

(* let constanttype be the newtype in order to assure correct reservation
of room for the constant *)
constptr^.consttype := newtyp;
with constptr^.stringval^ do
begin
if newtyp^.typkind = estring then l:=newtyp^.length
else l:=newtyp^.indextyp^.lastconst;
if l<=stringmax then
begin
for j:=length+1 to l do strÆjÅ:=' ';
length:=l;
end
else error(313);
end;
end
else error(313);
end;
esubrange,
eascii:if kind = longcst then
begin
string:=constptr^.stringval;
kind:=shortsignedcst;
constant:=ord(string^.strÆ1Å);
returnstring(string);
end
else error(313);
end;
pseudotop^.typ:=newtyp;
end; (* convertconstant *)

procedure callstandard; forward;

procedure blockbegin;
var
alfatointeger : record case boolean of
true:  (alf : alfa);
false: (i1,i2,i3,i4 : integer)
end;
labeldecl : boolean;
l : integer;
s, filename : symbolptr;
pseudo : pseudoptr;
vallist : valueptr;
begin
currentproc:=getsymbptr;
with currentproc^ do
begin
declarationlist^.firstlineofproc := currentline;
fstfreetmp:=starttmp;
nooffreetmp:=availtmp;
if not lineoutput then
begin (* start output of line number table for this procedure *)
(* remember start of line table for this procedure *)
declarationlist^.startline:=linetablelgt;
lineoutput:=true;
linetablelgt:=linetablelgt+6; (* startline number (1) name (4) first entry (1) *)
linetable^:=currentline;
put(linetable);
with alfatointeger do
begin
(* now the procedure name is inserted *)
alf := routinename^;
linetable^ := i1;
put(linetable);
linetable^ := i2;
put(linetable);
linetable^ := i3;
put(linetable);
linetable^ := i4;
put(linetable);
end;
linetable^:=lastindex * oneword;
put(linetable);
end;
display:=paramlist^.displayoffset;
maxstack:=declarationlist^.maxstackoffset;
makeindexcode(rs,stackaddr,stackaddr,level+display);
if namekind <> eprogram then copyshort(level,display,false);

(* initialize variables from value-part *)
if paramlist^.lengthofvalue > 0 then
if paramlist^.initlist = nil then
with paramlist^ do
begin (* read the values from disc *)
makeindexcode(al,0,stackaddr,display+level+oneword);
makecode(al,1,lengthofvalue);
if level > 0 then
begin
makeindexcode(rl,3,stackaddr,display);
l:=3;
end
else l:=stackaddr;
makeindirectcode(jl,3,l,valueoffset);
makewordcode(valuesegment);
end
else
with code^ do
begin
vallist:=paramlist^.initlist;
l:=paramlist^.lengthofvalue;
makerelcode(jl,l+oneword);
l:=l div oneword;
l:=l+lastindex;
lastindex:=l;
repeat
cÆlÅ:=vallist^.initval;
vallist:=vallist^.next;
l:=l-1;
until vallist = nil;
vallist:=paramlist^.initlist;
l:=-oneword;
repeat
with vallist^ do
if next <> nil then
begin
if next^.ordinal = ordinal -oneword then
begin
makewrelcode(dl,0,l);
makeindexcode(ds,0,stackaddr,ordinal);
l:=l-4*oneword;
returnvalue(vallist);
end
else
begin
makewrelcode(rl,0,l);
makeindexcode(rs,0,stackaddr,ordinal);
l:=l-3*oneword;
end;
end
else
begin
makewrelcode(rl,0,l);
makeindexcode(rs,0,stackaddr,ordinal);
l:=l-3*oneword;
end;
returnvalue(vallist);
until vallist = nil;
end;
end;
(* initialize labels, first label if present is found in indexÆlabnumberÅ *)
labeldecl := indexÆlabnumberÅ <> nil;
while labeldecl do
begin
with indexÆlabnumberÅ^ do
if key = elabel then
begin
makewrelcode(rl,0,2*oneword);
makerelcode(jl,2*oneword);
makewordcode(0);
labeladdroffset := lastindex;
makeindexcode(rs,0,stackaddr,labelordinal);
end
else
labeldecl := (key = ename) and (namekind = efile);
labnumber := labnumber + 1;
if indexÆlabnumberÅ = nil then labeldecl := false;
end;


if currentproc^.namekind = eprogram then
begin
makecode(rl,1,current_process);
makeindexcode(rl,1,1,process_start);
makeindexcode(al,3,1,h21);
makeindexcode(rs,3,stackaddr,outputordinal);
if inputordinal > minsignedhalfword then
begin
makeindexcode(al,1,1,h20);
makeindexcode(rs,1,stackaddr,inputordinal);
if inputfilename^.extname <> nil then
if inputfilename^.extname^.length > 0 then
begin (* open on input *)
new(filename);
with filename^ do
begin
key:=econst;
consttype:=alfatype;
constkind:=stringconst;
stringval:=inputfilename^.extname;
end;
makewrelcode(al,0,0);
makeconst(0,filename);
callstandard;
makewordcode(stdroutineÆps_openÅ);
makewordcode(1);
makeindexcode(rl,1,stackaddr,inputordinal);
callstandard;
makewordcode(stdroutineÆps_resetÅ);
end;
end;
if outputfilename^.extname^.length > 0 then
begin (* open on output *)
new(filename);
with filename^ do
begin
key:=econst;
consttype:=alfatype;
constkind:=stringconst;
stringval:=outputfilename^.extname;
end;
makeindexcode(rl,1,stackaddr,outputordinal);
makewrelcode(al,0,0);
makeconst(0,filename);
callstandard;
makewordcode(stdroutineÆps_openÅ);
makewordcode(1);
makeindexcode(rl,1,stackaddr,outputordinal);
callstandard;
makewordcode(stdroutineÆps_rewriteÅ);
end;
end;

s:=currentproc^.paramlist^.copyvalparam;
while s <> nil do
begin (* copy value parameters *)
makeindexcode(rl,1,stackaddr,s^.valparordinal);
l:=s^.vartypedescr^.size;
if s^.varaddr.simpleaddr then
begin
if (l <= maxshortcopy) and (s^.varaddr.ordinal + l < maxordinal) then
copyshort(l,s^.varaddr.ordinal,false)
else
begin
pseudo := newpseudo;  (* temporary node *)
pseudo^.kind:=variable;
pseudo^.addr:=s^.varaddr;
copylong(l,pseudo);
returnpseudo(pseudo);
end;
end;
s:=s^.next;
end;

s:=currentproc^.paramlist^.filelist;
if s <> nil then
begin
pseudo:=newpseudo;
while s <> nil do
begin (* initialize local files *)
pseudo^.kind:=variable;
pseudo^.addr:=s^.varaddr;
loadaddress(1,pseudo);
new(filename);
with filename^ do
begin
key:=econst;
consttype:=alfatype;
constkind:=stringconst;
end;
if s^.extname <> nil then
begin (* copy filename *)
filename^.stringval:=s^.extname;
with filename^.stringval^ do
if length = 0 then
begin
length:=alfalength;
alfastr:='            ';
end;
end
else
begin
filename^.stringval:=newstring;
with filename^.stringval^ do
begin
length:=alfalength;
alfastr:='            ';
end;
end;
makewrelcode(al,0,0);
makeconst(0,filename);

(* call initfile *)
callstandard;
makewordcode(stdroutineÆps_openÅ);
if getbasetype(s^.vartypedescr^.elementtyp) = eascii then l:=1
else l:=0;
makewordcode(l);
s:=s^.next;
end;
returnpseudo(pseudo);
end;
end; (* blockbegin *)

procedure blockend;
var
s, returnlast : symbolptr;
pseudo : pseudoptr;
i, id : integer;
begin
storeregisters(nil);
s:=currentproc^.paramlist^.filelist;
if s <> nil then
begin (* close or return local files *)
pseudo:=newpseudo;
while s <> nil do
begin
pseudo^.typ:=s^.vartypedescr^.elementtyp;
pseudo^.kind:=variable;
pseudo^.addr:=s^.varaddr;
loadaddress(1,pseudo);
callstandard;
i:=stdroutineÆps_closeÅ;
if s^.extname = nil then i:=i+2; (* remove entry *)
makewordcode(i);
s:=s^.next;
end;
returnpseudo(pseudo);
end;
if currentproc^.namekind = eprogram then
begin
(* program end, call runtime error('endprogram') *)
makecode(al,1,0);
makeindirectcode(jl,3,stackaddr,erroroffset);
end
else
begin
makeindexcode(rl,3,stackaddr,display);
makeindirectcode(jl,0,3,returnoffset);
end;
level:=level-oneword;
if lineoutput then
begin
lineoutput:=false;
linetablelgt:=linetablelgt+1;
linetable^:=lastindex * oneword;
put(linetable);
end;
with currentproc^.declarationlist^ do
begin
discaddr:=emitcode;
codelength:=lastindex*oneword;
end;

(* return local symbols *)
id:=lastnodeident;
returnlast:=currentproc^.declarationlist;
s:=indexÆidÅ;
while s <> returnlast do
begin
if s <> nil then
if ((s^.key <> econst) and
not ((s^.key = enamelist) and (s^.listkind = edeclaration)) and
not ((s^.key = etype) and (s^.typkind = estring)) and
not ((s^.key = ename) and (s^.namekind  in Æeprogram,eproc,efuncÅ))) or
((s^.key = econst) and (s^.constkind = stringconst)) then
begin (* return symbol to free list *)
s^.next:=freesymbol;
freesymbol:=s;
indexÆidÅ:=nil;
end;
id:=id-1;
s:=indexÆidÅ;
end;
end; (* blockend *)


procedure checkrange(checkpseudo:pseudoptr; first,last:integer);
begin
with checkpseudo^ do
if (kind=shortsignedcst) or
(kind=wordcst) then
begin
if (constant<first) or
(constant>last) then error(312);
end
else
if registerÆregnoÅ.kind in Æshortsignedcst,wordcstÅ then
with registerÆregnoÅ do
begin
if (constant < first) or
(constant > last) then error(312);
end
else
if (typ^.typkind <> esubrange) or alwayscheck or
((typ^.firstconst < first) or
(typ^.lastconst > last)) then
begin
reservecode(7);
if (last >= minsignedhalfword) and (last <= maxsignedhalfword) then
makecode(sh,regno,last)
else
begin
makeallcode(sh,regno,true,true,0,0);
makeconst(last,nil);
end;
if first < -maxint then makerelcode(jl,2*oneword) (* skip allways *)
else
begin
first:=first-1;
if (first >= minsignedhalfword) and (first <= maxsignedhalfword) then
makecode(sh,regno,first)
else
begin
makeallcode(sh,regno,true,true,0,0);
makeconst(first,nil);
end;
end;
makecode(d2, regno, -2); (* force alarm *)
end;
end;

procedure callroutine;
var dispreg : integer;
begin
if level > 0 then
begin
dispreg := 3;
makeindexcode(rl,dispreg,1,0);
end
else dispreg := stackaddr;
reservecode(2);
makeindirectcode(jl,3,dispreg,calloffset);
makewordcode(maxstack+maxordinal+paramoffset+oneword+1);
if paramoffset > maxparamoffset then error(314);
end;

procedure loadformal(var routineaddr:addrnode);
begin
with routineaddr do
if blocknumber = level then makeindexcode(dl,1,stackaddr,ordinal+oneword)
else
begin
makeindexcode(rl,1,stackaddr,display+blocknumber);
makeindexcode(dl,1,1,ordinal);
end;
end;

procedure actualparam(formalparam:symbolptr; actual:pseudoptr);
var
w : regrange;
paramsize : integer;
store : opcodes;
paramkind : intmtwords;
begin
if formalparam = nil then paramkind:=evalparam (* call a formal procedure *)
else paramkind:=formalparam^.namekind;
store:=rs;

case paramkind of
evalparam:begin
if actual^.kind = expression then evaltoresult(actual,noskip);
paramsize:=actual^.typ^.size;
if paramsize <= 4 then
begin
if actual^.kind <> reg then load(actual);
w:=actual^.regno;
if check and (formalparam <> nil) then
with formalparam^.vartypedescr^ do
if typkind = esubrange then checkrange(actual,firstconst,lastconst);
registerÆwÅ.user:=nil;
if paramsize=2*oneword then
begin
store:=ds;
w:=(w+1) mod noofreg;
registerÆwÅ.user:=nil;
end;
end
else
begin
loadaddress(1,actual);
paramsize:=oneword;
w:=1;
end;
end;
evarparam:  begin
if actual^.addr.packk <> unpack then
error( 323 ); (* packed fields not allowed as VAR-parameters *)
loadaddress(1,actual);
paramsize:=oneword;
w:=1;
end;
effunc,
efproc:with actual^.symb^ do
begin
storeregisters(nil);
if (namekind=efproc) or (namekind =effunc) then
loadformal(varaddr)
else
begin
makeindexcode(al,1,stackaddr,display);
makewrelcode(rl,0,0);
makeconst(routinedescr,nil);
end;
store:=ds;
paramsize:=2*oneword;
w:=1;
end;
end;
paramoffset:=paramoffset+paramsize;
if maxstack+paramoffset <= maxsignedhalfword then
makeindexcode(store,w,stackaddr,maxstack+paramoffset)
else
begin
reservecode(3);
makeallcode(am,0,true,true,0,0);
makeconst(maxstack+paramoffset,nil);
makeindexcode(store,w,stackaddr,0);
end;
end; (* actualparam *)

procedure callstandard;
var
w : regrange;
begin
if level > 0 then
begin
makeindexcode(rl,3,stackaddr,display);
w:=3;
end
else w:=stackaddr;
reservecode(4);
makeindirectcode(jl,3,w,stdcalloffset);
forgetregisters;
end;

procedure standardprocedure;
var
pseudo, ps, psnext, param, filparam : pseudoptr;
tagvalue, length, relative1, relative2,
argument, argument2, argument3, routinenumber : integer;
second, found : boolean;
node, nodetype, s1, s2 : symbolptr;
kind : intmtwords;
standardname : standards;

procedure readwritebinary(kind:integer; var par : pseudoptr);
var
param : pseudoptr;
begin
param:=par;
filparam^.typ:=integertype;
par:=nil;
if filparam^.kind = reg then storetmp(filparam);
repeat
if param^.kind = expression then
begin
evaltoresult(param,noskip);
storetmp(param);
end;
loadaddress(0,param);
if second or (filparam^.kind <> reg) then makeindexcode(rl,1,stackaddr,filparam^.addr.ordinal);
callstandard;
makewordcode(kind);
makewordcode(param^.typ^.size);
returnpseudo(param);
second:=true;
until param = nil;
end;

function defaultfile(fileordinal : integer) : pseudoptr;
(* make a pseudonode describing one of the standardfiles INPUT or OUTPUT *)
var
fil : pseudoptr;
begin
fil:=newpseudo;
with fil^ do
begin
typ:=asciitype;
kind:=variable;
with addr do
begin
index:=nil;
packk:=unpack;
simpleaddr:=true;
blocknumber:=0;
ordinal:=fileordinal;
end;
end;
loadregister(1,fil);
defaultfile:=fil;
end; (* defaultfile *)

procedure pack_unpack(param_a,param_i,param_z:pseudoptr; prockind:integer);
var
length_a, length_z : integer;
begin
param:=nil;
if getbasetype(param_a^.typ^.valtyp) <> eascii then error(408);
if param_i^.kind = expression then evaltoresult(param_i,noskip)
else
if param_i^.kind <> reg then load(param_i);

with param_z^.typ^.indextyp^ do
if typkind <> esubrange then length_z:=lastscalar+1
else length_z:=lastconst-firstconst+1;

with param_a^.typ^.indextyp^ do
if typkind <> esubrange then length_a:=lastscalar+1
else
begin
length_a:=lastconst-firstconst+1;
if check then checkrange(param_i,firstconst,lastconst-length_z+1);
makewrelcode(ws,param_i^.regno,0);
makeconst(firstconst,nil);
end;

if length_a < length_z then error(320);
makecode(as,param_i^.regno,1); (* not correct if oneword <> 2 ! *)
makeregister(param_i,param_i^.regno);
loadaddress(0,param_a);
param_a^.typ:=param_a^.typ^.valtyp;
makeregister(param_a,0);
operation(wa,param_a,param_a,param_i);
loadaddress(1,param_z);
if param_a^.kind <> reg then loadregister(0,param_a);
callstandard;
makewordcode(prockind);
makewordcode(length_z);
returnpseudo(param_a);
returnpseudo(param_i);
returnpseudo(param_z);
end; (* pack_unpack *)

begin (* standardprocedure *)
param:=nil;
pseudo:=pseudotop;
with neststackÆndepthÅ do
begin
while pseudo <> oldtop do
begin (* reverse the list of parameters *)
psnext:=pseudo^.next;
pseudo^.next:=param;
param:=pseudo;
pseudo:=psnext;
end;
standardname := procfunc^.stnd_name;
routinenumber:=stdroutineÆstandardnameÅ;

case standardname of
ps_put, ps_get, ps_reset, ps_rewrite,
ps_close: begin
storeregisters(nil);
param^.typ := param^.typ^.elementtyp;
loadaddress(1,param);
if standardname = ps_reset then
begin (* make a call of reset and a call of get *)
callstandard; (*register 1 must remain unchanged !!! *)
makewordcode(routinenumber);
standardname := ps_get;
routinenumber := stdroutineÆstandardnameÅ;
end; (* reset *)
if ((standardname=ps_put)or(standardname=ps_get)) and
(getbasetype(param^.typ) <> eascii) then (* binary io *)
begin
makeindexcode(rl,0,1,h4+4); (* load bufferaddress *)
if standardname = ps_put then routinenumber := binaryput
else routinenumber := binaryget;
length := param^.typ^.size (* the buffer length *)
end
else
length := 10; (* the relative entry of the lib-segment for put *)

callstandard;
makewordcode(routinenumber);
if (standardname=ps_put) or (routinenumber=binaryget) then
makewordcode(length);
end; (* put, get, reset, rewrite, close *)
ps_new:begin
storeregisters(nil);
loadaddress(1,param);
nodetype:=param^.typ^.pointertotyp;
returnpseudo(param);
if param = nil then length:=nodetype^.size
else
begin
node:=nodetype^.varlist;
repeat (* search through the list of tag values *)
if (param^.kind <> shortsignedcst) and
(param^.kind <> wordcst) then
begin
error(316);
tagvalue:=1;
end
else tagvalue:=param^.constant;

found:=false;
s1:=node^.taglist;
while (s1 <> nil) and (not found) do
begin
length:=s1^.tagsize;
s2:=s1^.labellist^.nextreclab;
while s2 <> nil do
begin
if tagvalue = s2^.reclabvalue then found:=true;
s2:=s2^.nextreclab;
end;
s1:=s1^.nexttag;
end;
if not found then error(317);
returnpseudo(param);
node:=node^.varlst;
until (node = nil) or (param = nil);
end;

if param <> nil then error(318);
if length < maxsignedhalfword then makecode(al,0,length)
else
begin
makewrelcode(rl,0,0);
makeconst(length,nil);
end;
makeindexcode(rl,3,stackaddr,display);
makeindirectcode(jl,3,3,routinenumber);
forgetregisters;
end;
ps_readln,
ps_read:begin
storeregisters(nil);
if param = nil then filparam:=defaultfile(inputordinal)
else
if param^.typ^.typkind = efile then
begin
param^.typ:=param^.typ^.elementtyp;
loadaddress(1,param);
filparam:=param;
param:=filparam^.next;
end
else filparam:=defaultfile(inputordinal);
makeregister(filparam,1);
second:=false;

if getbasetype(filparam^.typ) = eascii then
begin
if param = nil then
begin (* readln *)
callstandard;
makewordcode(routinenumber+10);
end
else
repeat
if param^.addr.packk <> unpack then
error( 323 ); (* packed fields must not be used as VAR-parameters *)
loadaddress(0,param);
kind:=getbasetype(param^.typ);
argument:=readkindÆkindÅ;
if kind = eascii then
with param^.typ^ do
begin
if typkind = esubrange then
if (firstconst >= firstchar) and (lastconst <= lastchar) then argument:=4;
(* char *)
end
else
if kind = escalar then error(407);

if filparam^.kind <> reg then makeindexcode(rl,1,stackaddr,filparam^.addr.ordinal);
returnpseudo(param);
if (param <> nil) and (filparam^.kind <> reg) then storeregisters(nil);
callstandard;
if param = nil then
makewordcode(routinenumber+argument)
else
begin
makewordcode(stdroutineÆps_readÅ+argument);
loadregister(1,filparam);
end;
until param = nil;
end
else readwritebinary(7*4096,param);
returnpseudo(filparam);
end;
ps_writeln,
ps_write:begin
storeregisters(nil);
if param = nil then filparam:=defaultfile(outputordinal)
else
if param^.typ^.typkind = efile then
begin
param^.typ:=param^.typ^.elementtyp;
loadaddress(1,param);
filparam:=param;
param:=filparam^.next;
end
else filparam:=defaultfile(outputordinal);
makeregister(filparam,1);
second:=false;

if param = nil then
begin (* writeln *)
callstandard;
makewordcode(routinenumber+2);
makewordcode(12);
end
else
begin
if param^.next <> nil then
with param^.next^ do
if (next <> nil) or (kind <> expression) or
(operator <> eformat) then storetmp(filparam);

if getbasetype(filparam^.typ) <> eascii then readwritebinary(7*4096+1,param)
else
repeat
argument3:=-1;
relative1:=0;
relative2:=0;
if param^.next = nil then argument:=routinenumber
else
begin
argument:=stdroutineÆps_writeÅ;
with param^.next^ do
if (kind = expression) and (operator = eformat) then
begin
if param^.next^.next = nil then argument:=routinenumber;
if leftoperand^.kind = expression then evaltoresult(leftoperand,noskip)
else
if leftoperand^.kind <> reg then load(leftoperand);
reservecode(50); (* call of write must be within range*)
makewrelcode(hs,leftoperand^.regno,0);
relative2:=lastindex;
ps:=leftoperand;
returnpseudo(ps);
if rightoperand <> nil then
begin
if rightoperand^.kind = expression then evaltoresult(rightoperand,noskip)
else
if rightoperand^.kind <> reg then load(rightoperand);
makewrelcode(hs,rightoperand^.regno,0);
relative1:=lastindex;
ps:=rightoperand;
returnpseudo(ps);
end;
end;
end;

if param^.kind = expression then evaltoresult(param,noskip);
kind:=getbasetype(param^.typ);
argument2:=writekindÆkindÅ;
case kind of
ereal:begin
if param^.kind = reg then storetmp(param);
if param^.kind = longcst then
begin
reservecode(4);
makecode(am,0,-oneword);
end;
loadaddress(0,param);
end;
eboolean,
eascii,
einteger:begin
argument:=argument+2;
if (param^.kind <> reg) or (param^.regno <> 0) then
loadregister(0,param);
end;
escalar: error(407);
estring:begin
argument:=argument+2;
with param^.typ^ do
begin
if typkind = estring then
begin
argument3:=length;
argument2:=argument2+argument3*(maxhalfword+1);
end
else
if typkind = earray then
begin
argument3:=indextyp^.lastconst;
argument2:=argument2+argument3*(maxhalfword+1);
end;
end;
loadaddress(0,param);
end;
end;

if second or (filparam^.kind <> reg) then
makeindexcode(rl,1,stackaddr,filparam^.addr.ordinal);
callstandard;
makewordcode(argument);
makewordcode(argument2);
if (relative2 <> 0) and
(lastindex-relative2 > maxsignedhalfword div oneword) then error(319)
else
begin
if relative1 <> 0 then code^.cÆrelative1Å.displacement:=(lastindex-relative1)*oneword+1;
if relative2 <> 0 then code^.cÆrelative2Å.displacement:=(lastindex-relative2)*oneword;
end;
if argument3 >= 0 then makewordcode(argument3);

returnpseudo(param);
if param <> nil then
if (param^.kind = expression) and
(param^.operator = eformat) then returnpseudo(param);
second:=true;
until param = nil;
end;
returnpseudo(filparam);
end;
ps_page:begin
storeregisters(nil);
loadaddress(1,param);
makecode(al,0,ord(ff));
callstandard;
makewordcode(routinenumber);
makewordcode(writekindÆeasciiÅ);
end;
ps_open:begin
filparam:=param;
param:=filparam^.next;

if param^.kind = variable then
begin
if param^.typ^.size <> filenamelength then error(313);
end
else
begin
pseudotop:=param;
convertconstant(alfatype);
end;
loadaddress(0,param);
param^.typ:=integertype;
makeregister(param,0);
loadaddress(1,filparam);
if param^.kind <> reg then loadregister(0,param);
callstandard;
makewordcode(routinenumber);
if getbasetype(filparam^.typ^.elementtyp) = eascii then length:=1
else length:=0;
makewordcode(length);
returnpseudo(filparam);
end;
ps_putrand,
ps_getrand:error(406);
ps_pack:pack_unpack(param,param^.next,param^.next^.next,routinenumber);
ps_unpack:pack_unpack(param^.next,param^.next^.next,param,routinenumber);
ps_replace,
ps_date,
ps_time:begin
storeregisters(nil);
if procfunc^.stnd_name = ps_replace then
if level <> 0 then error(322);
loadaddress(1,param);
callstandard;
makewordcode(routinenumber);
end;
end;

returnpseudo(param);
end;
pseudotop:=pseudo;
end; (* standardprocedure *)


procedure insertaddr(chainindex, jumpindex : integer);
(* insert displacement part of the jump-chain starting
with chainindex, so that the jumps are to jumpindex *)
var
i, distance : integer;
begin
with code^ do
repeat
with cÆchainindexÅ do
begin
distance:=(jumpindex-chainindex)*oneword;
if distance > maxsignedhalfword then
begin
jumpindex:=chainindex-i;
distance:=(jumpindex-chainindex)*oneword;
end;
i:=displacement;
displacement:=distance;
chainindex:=chainindex+i;
end;
until i=0;
end;

procedure newshortjump;
(* remember the chain of short jumps starting in lastindex *)
var sjump : jumpchainptr;
begin
new(sjump);
sjump^.jumpindex:=lastindex;
sjump^.next:=shortjumps;
shortjumps:=sjump;
outconstlimit:=outconstlimit-1;
end;

function poweroftwo(c:integer):integer;
(* if c is a power of 2 then the result is that power
else result is -1 *)
var
i,j,low,high : integer;
begin
if c=2 then poweroftwo:=1
else
begin
low:=1;
high:=maxbit;
i:=(maxbit+1) div 2;
for j:=1 to 5 do
begin
if bitmaskÆiÅ > c then high:=i
else low:=i;
i:=(low+high) div 2;
end;

if c-bitmaskÆlowÅ = 1 then poweroftwo:=low
else poweroftwo:=-1;
end;
end;

procedure evaltoresult; (* (ps:pseudoptr ; skipk:skipkind) FORWARD declared *)
var
pseudo, left, right : pseudoptr;
i, j, oldparam, w, w_1 : integer;
skip : opcodes;

procedure inoperator;
var
jindex, highset : integer;
begin
with left^ do
begin
if (right^.kind = variable) then
with right^.addr do
if (index <> nil) or (not simpleaddr)
or (blocknumber <> level) or (ordinal > maxordinal) then
begin
loadaddress(3,right);
right^.typ:=integertype;
makeregister(right,3);
end;
loadregister(1,left);
registerÆ1Å.user:=nil;
reservecode(13);
highset:=maxint;
with typ^ do
if (typkind = einteger) or
((typkind = esubrange) and (firstconst < 0)) then
makecode(sl,regno,0)
else if typkind = esubrange then highset:=lastconst
else if typkind = escalar then highset:=lastscalar;
if highset <= maxbit then
begin (* must be in first word of set *)
makeindexcode(al,0,1,0);
case right^.kind of
longcst:
begin
makewrelcode(rl,1,0);
with right^.constptr^.setval^ do
makeconst(hlfwordsÆ1Å*4096+hlfwordsÆ2Å,nil);
end;
variable:
begin
right^.typ:=integertype;
loadregister(1,right);
end;
reg: makeindexcode(rl,1,3,0);
tmp: makeindexcode(rl,1,stackaddr,right^.addr.ordinal);
end;
end
else
begin
if highset >= setsize*((maxbit+1) div oneword) then
begin
makecode(sl,regno,setsize*((maxbit+1) div oneword));
makerelcode(jl,0);
jindex:=lastindex;
end;
makecode(al,0,0);
makewrelcode(wd,1,0);
makeconst(maxbit+1,nil);
makecode(as,1,1); (* not correct if oneword <> 2 ! *)
with right^ do
case kind of
variable:begin
makeindexcode(am,0,1,0);
makeindexcode(rl,1,stackaddr,addr.ordinal);
end;
tmp:begin
makeindexcode(wa,1,stackaddr,addr.ordinal);
makeindexcode(rl,1,1,0);
end;
longcst: begin
reservecode(setsize+1);
makeallcode(rl,1,true,false,1,0);
makeconst(0,constptr);
end;
reg:begin
makeindexcode(am,0,1,0);
makeindexcode(rl,1,regno,0);
end;
end;
end;

forgetregisters;
makeindirectcode(ls,1,0,0);
reservecode(2);
if skipk = skiptrue then
begin
makecode(sl,1,0);
if highset < setsize*(maxbit+1) div oneword then jindex:=lastindex+1;
makerelcode(jl,jindex-lastindex-1);
end
else
begin
makecode(sh,1,-1);
if skipk = skipfalse then
begin
makerelcode(jl,0);
if highset >= setsize*(maxbit+1) div oneword then insertaddr(jindex,lastindex+1);
end
else
begin
makecode(am,0,1);
makecode(al,1,0);
makeregister(ps,1);
if highset >= setsize*(maxbit+1) div oneword then insertaddr(jindex,lastindex);
end;
end;
end;
end;

procedure setoperation(op:opcodes);
var
invert : boolean;
temp : signedhalfword;
i, siz : integer;

procedure fastsetoperation(op:opcodes; pseudo:pseudoptr;
index1,index2:regrange; disp1,disp2:signedhalfword);
var
localtemp, i : integer;
begin
localtemp:=temp+oneword;
reservecode(setsize+1);
loadaddress(1,pseudo);
storeregisters(nil);

(* reserve a work set *)
fstfreetmp := fstfreetmp + siz;
nooffreetmp := nooffreetmp - siz;
if nooffreetmp < 0 then error(314)
else
for i:=1 to pseudo^.typ^.size div (2*oneword) do
begin
makeindexcode(dl,0,index1,disp1);
if invert then
begin
makewrelcode(lx,0,0);
makeconst(-1,nil);
makeindexcode(ac,3,3,1);
end;

makeindexcode(op,3,index2,disp2);
makeindexcode(op,0,index2,disp2+oneword);
makeindexcode(ds,0,stackaddr,localtemp);
disp1:=disp1+2*oneword;
disp2:=disp2+2*oneword;
localtemp:=localtemp+2*oneword;
end;
end;

begin (* setoperation *)
invert:=false;
if op = ac then
begin
op:=la;
invert:=true;
end;
siz:=right^.typ^.size;
temp:=fstfreetmp;
(* let temp be the address of the result (work set) of the operation *)
if right^.kind = tmp then 
temp := temp - siz;
if left^.kind = tmp then
temp := temp - siz;

if (right^.kind <> longcst) and
right^.addr.simpleaddr and
(right^.addr.index = nil) and
(right^.addr.blocknumber = level) and
(right^.addr.ordinal+siz <= maxordinal) then
fastsetoperation(op,left,stackaddr,1,right^.addr.ordinal+oneword,0)
else
if (left^.kind <> longcst) and
left^.addr.simpleaddr and
(left^.addr.index = nil) and
(left^.addr.blocknumber = level) and
(left^.addr.ordinal+siz <= maxordinal) then
fastsetoperation(op,right,1,stackaddr,oneword,left^.addr.ordinal)
else
begin (* operation on one word at a time *)
reservecode(setsize+1);
storeregisters(nil);
loadaddress(1,left);
left^.typ:=integertype;
makeregister(left,1);
reservecode(setsize+1);
loadaddress(3,right);
if left^.kind <> reg then loadregister(1,left);
registerÆ1Å.user:=nil;
registerÆ3Å.user:=nil;

(* reserve a work set *)
fstfreetmp := fstfreetmp  + siz;
nooffreetmp:= nooffreetmp - siz;
if nooffreetmp < 0 then error(314)
else
for i:=0 to siz div oneword -1 do
begin
makeindexcode(rl,0,3,i*oneword);
if invert then
begin
makewrelcode(lx,0,0);
makeconst(-1,nil);
end;
makeindexcode(op,0,1,i*oneword);
makeindexcode(rs,0,stackaddr,temp+i*oneword);
end;
end;
if (right^.kind=tmp) and (left^.kind=tmp) then
begin (* operation on two work set operands, the result is one
work set, i.e. give one set back to the pool of free temp storage *)
fstfreetmp := fstfreetmp - siz;
nooffreetmp := nooffreetmp + siz;
end;

with ps^ do
begin
typ:=right^.typ;
kind:=tmp;
with addr do
begin
index:=nil;
packk:=unpack;
simpleaddr:=true;
blocknumber:=level;
ordinal:=temp;
end;
end;
left^.kind:=expression; (* to avoid reclaiming of temporaries *)
right^.kind:=expression;
end;

procedure standardfunction(funct,param : pseudoptr);
var
w : regrange;
std_func : standards;
constant : symbolptr;
skip : opcodes;
storeindex :integer;
nextparam, param1, param2 : pseudoptr;
begin
std_func:=funct^.rightoperand^.symb^.stnd_name;
if param <> nil then
begin
param:=param^.rightoperand;
if param^.kind = expression then evaltoresult(param,noskip);
end;

case std_func of
fs_abs:begin
if param^.kind <> reg then load(param);
w:=param^.regno;
makecode(sh,w,-1);
if param^.typ^.typkind = ereal then
begin
funct^.typ:=realtype;
makeregister(funct,w);
makewrelcode(fm,(w+1) mod noofreg , 0);
constant:=makerealconst(-1);
makeconst(0,constant);
end
else
begin
funct^.typ:=integertype;
makeregister(funct,w);
if w = 0 then makeindirectcode(ac,0,0,0)
else makeindexcode(ac,w,w,0);
end;
end;
fs_sqr:begin
if param^.typ^.typkind = ereal then
begin
funct^.typ:=realtype;
if param^.kind <> reg then load(param);
operation(fm,funct,param,param);
end
else
begin
funct^.typ:=integertype;
if (param^.kind <> reg) or (param^.regno =3) then loadregister(1,param);
operation(wm,funct,param,param);
end;
end;
fs_arcsin,
fs_sinh,
fs_arctan,
fs_sqrt,
fs_ln,
fs_exp,
fs_cos,
fs_sin:begin
loadregister(0,param);
registerÆ0Å.user:=nil;
registerÆ1Å.user:=nil;
storeregisters(nil);
callstandard;
makewordcode(stdroutineÆstd_funcÅ);
makeregister(funct,0);
registerÆ1Å:=registerÆ0Å;
end;
fs_odd:begin
if param^.kind <> reg then load(param);
if skipk = noskip then
begin
makewrelcode(la,param^.regno,0);
makeconst(1,nil);
makeregister(funct,param^.regno);
end
else
begin
reservecode(2);
if skipk = skiptrue then makecode(so,param^.regno,1)
else makecode(sz,param^.regno,1);
makerelcode(jl,0);
forgetregisters;
end;
end;
fs_eoln,
fs_eof:begin
loadaddress(1,param);
makeindexcode(bz,1,1,stdroutineÆstd_funcÅ+h4);
if skipk = noskip then makeregister(funct,1)
else
begin
if skipk = skiptrue then skip:=se
else skip:=sn;
makecode(skip,1,1);
makerelcode(jl,0);
forgetregisters;
end;
end;
fs_round,
fs_trunc:begin
if param^.kind <> reg then load(param);
w:=(param^.regno+1) mod noofreg;
if std_func = fs_trunc then
begin
reservecode(12);
makecode(sl, param^.regno, 0); (* test if negative *)
makerelcode(jl, 12); (* if positive then jump *)
makewrelcode(fm, w, 0); (* negative: change sign *)
constant := makerealconst(-1);
makeconst(0, constant);
makewrelcode(fs,w,0);
constant:=makerealconst(0.5);
makeconst(0,constant);
makecode(cf, w, 0 ); (* convert to integer *)
if w = 0 then
makeindirectcode(ac, 0 , 0, 0) (* negate the result *)
else
makeindexcode(ac, w, w, 0);
makerelcode(jl, 6) ; (* end of negative argument *)
makewrelcode(fs, w, 0);
makeconst(0,constant);
end;
makecode(cf,w,0);
makeregister(funct,w);
end;
fs_ord,
fs_chr:begin
if param^.kind <> reg then load(param);
makeregister(funct,param^.regno);
end;
fs_succ:begin
if param^.kind <> reg then load(param);
w:=param^.regno;
if w = 0 then makewrelcode(ba,0,1)
else makeindexcode(al,w,w,1);
funct^.typ:=integertype;
makeregister(funct,w);
end;
fs_pred:begin
if param^.kind <> reg then load(param);
w:=param^.regno;
if w = 0 then makewrelcode(bs,0,1)
else makeindexcode(al,w,w,-1);
funct^.typ:=integertype;
makeregister(funct,w);
end;
fs_system,
fs_monitor:begin
if param^.kind <> reg then load(param);
reservecode(50);
makewrelcode(rs,param^.regno,0);
storeindex:=lastindex;
nextparam:=funct^.leftoperand^.leftoperand;
param1:=nextparam^.rightoperand;
param1^.typ := integertype;  (* force operand to simple size *)
loadaddress(0,param1);
makeregister(param1,0);
param2:=nextparam^.leftoperand;
returnpseudo(nextparam);
nextparam:=param2^.rightoperand;
loadaddress(1,nextparam);
if param1^.kind <> reg then loadregister(0,param1);
callstandard;
makewordcode(stdroutineÆstd_funcÅ);
makewordcode(0);
if lastindex-storeindex >= maxsignedhalfword div oneword then error(319)
else code^.cÆstoreindexÅ.displacement:=(lastindex-storeindex)*oneword;
makeregister(funct,1);
returnpseudo(param1);
returnpseudo(param2);
returnpseudo(nextparam);
end;
fs_clock:begin
storeregisters(nil);
callstandard;
makewordcode(stdroutineÆstd_funcÅ);
makeregister(funct,0);
registerÆ1Å:=registerÆ0Å;
end;
end;
returnpseudo(param);
end; (* standardfunction *)

procedure longcheck(op:opcodes;left,right:pseudoptr);
(* set up a loop which checks one word of the structure in each passage.
When op is false jump out of the loop *)
var
pseudo : pseudoptr;
length : integer;
begin
loadaddress(1,right);
storeregisters(right);
right^.typ := integertype;
makeregister(right,1);
loadaddress(3,left);
if right^.kind <> reg then (*temporary*)
loadregister(1,right);
length:=left^.typ^.size-oneword;
if (length <= maxsignedhalfword) and (length >= minsignedhalfword) then
makeindexcode(al,0,1,length)
else
begin
makecode(rl,0,2);
makerelcode(wa,0);
makeconst(length,nil);
end;

pseudo:=newpseudo;
with pseudo^ do
begin
typ:=integertype;
kind:=reg;
regno:=0;
sameregister:=nil;
end;
storetmp(pseudo);

reservecode(11);
makeindexcode(rl,0,3,0);
makeindirectcode(op,0,1,0);
makerelcode(jl,6*oneword);
makeindexcode(al,3,3,oneword);
makeindexcode(al,1,1,oneword);
makeindirectcode(sh,1,2,pseudo^.addr.ordinal);
makerelcode(jl,-6*oneword);
returnpseudo(pseudo);
end; (* longcheck *)

procedure stringcheck(op : opcodes; left,right : pseudoptr);
(* make code for strinc comparison ( =, <>, < )  *)
var
noofelements,checklength, jumplength, next : integer;
pseudo : pseudoptr;

begin
with left^.typ^ do
begin
if typkind = estring then
noofelements := length mod asciiperword (* elements to check (0..2) *)
else
noofelements := indextyp^.lastconst mod asciiperword;
checklength := size - oneword - ((noofelements+1)div 2)* 2; (* no of halfwords to check *)
end; (* with left^.typ^ do *)

if noofelements = 0 then
begin
if checklength >= 2 then
begin
longcheck(se,left,right);
if (op = se) or (op = sl) then
begin
makerelcode(jl,2*oneword); (* skip on true *)
if op = sl then makeindirectcode(sl,0,1,0);
end;
end
else
begin
operation(op,ps,left,right);
code^.cÆlastindexÅ.indirect := true;
end;
end
else
(* at most 1 or 2 elements of the last word of the strings are significant *)
begin
loadaddress(1,right);
storeregisters(right);
right^.typ := integertype;
makeregister(right,1);
loadaddress(3,left);
reservecode(21);
if checklength >= 2 then
begin
if right^.kind <> reg then (* stored in a temporary *)
loadregister(1,right);
if op = sn then jumplength := 22 else jumplength := 20;
(* no of halfwords to bypass on loop exit *)
next := 0; (* tells if x1 and x3 points at next word (0) or last
tested word (2) *)
if checklength < maxsignedhalfword then
makeindexcode(al,0,1,checklength)
else
begin
makecode(rl,0,2);
makerelcode(wa,0);
makeconst(checklength,nil);
end;
pseudo := newpseudo;
with pseudo^ do
begin
typ := integertype;
kind := reg;
regno := 0;
sameregister := nil;
end;
storetmp(pseudo);
makeindexcode(rl,0,3,0);
makeindirecttcode(se,0,1,0);
makerelcode(jl,jumplength); (* exit of the loop *)
makeindexcode(al,3,3,oneword);
makeindexcode(al,1,1,oneword);
makeindirectcode(sh,1,stackaddr,pseudo^.addr.ordinal); (*last element ? *)
makerelcode(jl,-6 * oneword);
returnpseudo(pseudo);
end
else (* checklength < 2, i.e. at most one word and some elements are
to be compared *)
begin
if op = sn then jumplength := 14 else jumplength := 12;
if checklength = 0 then (* one word *)
begin
next := oneword; (* x1 and x3 are not adjusted *)
makeindexcode(rl,0,3,0);
makeindirectcode(se,0,1,0);
makerelcode(jl,jumplength);
end
else
(* just one or two elements *)
next := 0;
end;

makeindexcode(rl,0,3,next);
makecode(ls,0,-24 + 8*noofelements); (* right justify *)
makeindexcode(rl,1,1,next);
makecode(ls,1,-24 + 8*noofelements);
if op = sl then
begin (* load w1 on loop exit *)
makerelcode(jl,2*oneword);
makeindexcode(rl,1,1,0);
end;
makeindexcode(op,0,1,0);
end;

end;  (* string check *)

procedure endoftest;
begin
forgetregisters;
if skipk = noskip then
begin
makeregister(ps,-1);
makecode(am,0,-1);
makecode(al,ps^.regno,1);
end
else
makerelcode(jl,0);
end; (* endoftest *)

procedure eqnerelation(eqne:opcodes);
var left, right : pseudoptr;
begin
left:=ps^.leftoperand;
right:=ps^.rightoperand;
with left^.typ^ do
if (size = oneword) and
((typkind <> estring) and ((typkind<> earray) or not stringcomp)) then
begin
if right^.kind = shortsignedcst then
begin
if left^.kind <> reg then load(left);
reservecode(3);
makecode(eqne,left^.regno,right^.constant);
end
else
begin
if right^.kind=reg then operation(eqne,ps,right,left)
else operation(eqne,ps,left,right);
code^.cÆlastindexÅ.indirect:=true;
end;
end
else
if typkind = ereal then
begin
if right^.kind = reg then operation(fs,ps,right,left)
else operation(fs,ps,left,right);
reservecode(3);
makecode(eqne,ps^.regno,0);
end
else
begin (* set, record or array *)
if (typkind = estring) or ((typkind = earray) and stringcomp) then
stringcheck(eqne,left,right)
else
begin
longcheck(se,left,right);
if eqne=se then makerelcode(jl,2*oneword);(* to get skip on true*)
end;
end;
endoftest;
end; (* eqnerelations *)

procedure ltgtrelation(left,right : pseudoptr);
begin
if right^.kind = shortsignedcst then
begin
if left^.kind <> reg then load(left);
reservecode(3);
makecode(sl,left^.regno,right^.constant);
end
else
if left^.kind = shortsignedcst then
begin
if right^.kind <> reg then load(right);
reservecode(3);
makecode(sh,right^.regno,left^.constant);
end
else
if (getbasetype(left^.typ)=estring)  then
stringcheck(sl,left,right)
else
begin
if left^.typ^.typkind = ereal then
begin
operation(fs,ps,left,right);
makecode(sl,ps^.regno,0);
end
else
begin
if right^.kind=reg then operation(sh,ps,right,left)
else operation(sl,ps,left,right);
code^.cÆlastindexÅ.indirect:=true;
end;
end;
endoftest;
end; (* ltgtrelations *)

procedure legerelation(left,right : pseudoptr);
begin
if left^.typ^.size = oneword then
begin
if (right^.kind = shortsignedcst) and (right^.constant <> maxsignedhalfword) then
begin
if left^.kind <> reg then load(left);
reservecode(3);
makecode(sl,left^.regno,right^.constant+1);
end
else
if (left^.kind = shortsignedcst) and (left^.constant <> minsignedhalfword) then
begin
if right^.kind <> reg then load(right);
reservecode(3);
makecode(sh,right^.regno,left^.constant-1);
end
else
begin
if right^.kind=reg then operation(sl,ps,right,left)
else operation(sh,ps,left,right);
code^.cÆlastindexÅ.indirect:=true;
makerelcode(jl,4);
end;
end
else
if left^.typ^.typkind = ereal then
begin
operation(fs,ps,right,left);
reservecode(3);
makeallcode(sz,ps^.regno,true,true,0,0);
makeconst(-maxint-1,nil);
end
else
if left^.typ^.typkind = eset then
begin
longcheck(so,right,left);
if skipk=skiptrue then makerelcode(jl,2*oneword);
end
else
begin
longcheck(se,left,right);
makerelcode(jl,3*oneword);
makeindirectcode(sl,0,1,0);
end;

endoftest;
end; (* legerelations *)

procedure boolexp(pseudo:pseudoptr; skip:skipkind);
begin
if pseudo^.kind = expression then evaltoresult(pseudo,skip)
else
begin
if pseudo^.kind <> reg then load(pseudo);
reservecode(3);
makecode(se,pseudo^.regno,ord(skip));
makerelcode(jl,0);
forgetregisters;
end;
end;

begin (* evaltoresult *)
left:=ps^.leftoperand;
right:=ps^.rightoperand;
case ps^.operator of
eor:
begin
boolexp(left,skipfalse);
newshortjump;
with shortjumps^ do
if skipk = noskip then
begin
boolexp(right,skiptrue);
insertaddr(lastindex,lastindex);
lastindex:=lastindex-1;
makeregister(ps,-1);
makecode(am,0,-1);
makecode(al,ps^.regno,1);
insertaddr(jumpindex,lastindex);
end
else
begin
boolexp(right,skipk);
if skipk = skiptrue then insertaddr(jumpindex,lastindex+1)
else
with code^ do
begin (*insert a link into the chain of jumps *)
i := lastindex;
j := cÆiÅ.displacement;
while j <> 0 do
begin
i := i + j;
j := cÆiÅ.displacement;
end;
cÆiÅ.displacement := jumpindex - i;
end;  (* with .. *)
end;
shortjumps:=shortjumps^.next;
end;
eand:
begin
boolexp(left,skiptrue);
newshortjump;
with shortjumps^ do
if skipk = noskip then
begin
boolexp(right,skiptrue);
insertaddr(lastindex,lastindex);
lastindex:=lastindex-1;
makeregister(ps,-1);
makecode(am,0,-1);
insertaddr(jumpindex,lastindex);
makecode(al,ps^.regno,1);
end
else
begin
boolexp(right,skipk);
if skipk = skipfalse then insertaddr(jumpindex,lastindex+1)
else
with code^ do
begin (*insert a link into the chain of jumps *)
i := lastindex;
j := cÆiÅ.displacement;
while j <> 0 do
begin
i := i + j;
j := cÆiÅ.displacement;
end;
cÆiÅ.displacement := jumpindex - i;
end;  (* with .. *)
end;
shortjumps:=shortjumps^.next;
end;
enot:
begin
if skipk=noskip then
begin
if left^.kind = expression then
begin
evaltoresult(left,skipfalse);
insertaddr(lastindex,lastindex);
lastindex:=lastindex-1;
makeregister(ps,-1);
makecode(am,0,-1);
makecode(al,ps^.regno,1);
end
else
begin
makeregister(ps,-1);
makecode(al,ps^.regno,1);
operation(lx,ps,ps,left); (*?????????????????????? *)
end;
end
else
begin
if skipk=skiptrue then skipk:=skipfalse
else skipk:=skiptrue;
boolexp(left,skipk);
end;
end;
eeq,
ene:
if left^.typ^.typkind=eboolean then
begin
if left^.kind=expression then evaltoresult(left,noskip);
if right^.kind=expression then
begin
storetmp(left);
evaltoresult(right,noskip);
end;
end
else
begin
if left^.kind=expression then evaltoresult(left,skipk);
if right^.kind=expression then evaltoresult(right,skipk);
end;
erightconv,
eminus:
if left^.kind=expression then evaltoresult(left,skipk);
eendcall:; (* do nothing *)
eset:
begin
if left^.kind =longcst then
begin (* copy constant part of set to temporary *)
storeregisters(nil);
reservecode(setsize+2);
loadaddress(1,left);
copyshort(left^.typ^.size,fstfreetmp,false);
with left^ do
begin
kind:=tmp;
with addr do
begin
index:=nil;
packk:=unpack;
simpleaddr:=true;
blocknumber:=level;
ordinal:=fstfreetmp;
end;
end;

fstfreetmp:=fstfreetmp+left^.typ^.size;
nooffreetmp:=nooffreetmp-left^.typ^.size;
if nooffreetmp < 0 then error(311);
end
else evaltoresult(left,noskip);
end;
end (* CASE ps^.operator OF *)
otherwise
begin
if right^.kind=expression then evaltoresult(right,skipk);
if left^.kind=expression then evaltoresult(left,skipk);
end;

(* backtrack and make code *)

if skipk=skipfalse then
case ps^.operator of
eeq:begin
ps^.operator:=ene;
skipk:=skiptrue;
end;
ene:begin
ps^.operator:=eeq;
skipk:=skiptrue;
end;
elt:begin
ps^.operator:=ege;
skipk:=skiptrue;
end;
egt:begin
ps^.operator:=ele;
skipk:=skiptrue;
end;
ege: if left^.typ^.typkind <> eset then
begin
ps^.operator:=elt;
skipk:=skiptrue;
end;
ele: if left^.typ^.typkind <> eset then
begin
ps^.operator:=egt;
skipk:=skiptrue;
end;
end (* CASE ps^.operator OF *)
otherwise ;

case ps^.operator of
eor, eand, enot:;
eeq: eqnerelation(se);
ene: if (skipk = noskip) and (left^.typ^.typkind = eboolean) then
begin
if right^.kind = reg then operation(lx,ps,right,left)
else operation(lx,ps,left,right)
end
else eqnerelation(sn);
elt: ltgtrelations(left,right);
egt: ltgtrelations(right,left);
ele: legerelations(left,right);
ege: legerelations(right,left);
emult: if (right^.kind=shortsignedcst) or (right^.kind=wordcst) then
begin
i:=poweroftwo(right^.constant);
if i>0 then
begin
if left^.kind <> reg then load(left);
makecode(as,left^.regno,i);
makeregister(ps,left^.regno);
end
else operation(wm,ps,left,right);
end
else
if ps^.typ^.typkind <> ereal then
begin
if right^.kind=reg then operation(wm,ps,right,left)
else operation(wm,ps,left,right);
end
else
begin
if right^.kind=reg then operation(fm,ps,right,left)
else operation(fm,ps,left,right);
end;
eadd: if right^.kind = shortsignedcst then
begin
if left^.kind <> reg then load(left);
if left^.regno = 0 then
begin
makewrelcode(wa,0,0);
makeconst(right^.constant,nil);
end
else
makeindexcode(al,left^.regno,left^.regno,right^.constant);
makeregister(ps,left^.regno);
end
else
if ps^.typ^.typkind=ereal then
begin
if right^.kind=reg then operation(fa,ps,right,left)
else operation(fa,ps,left,right);
end
else
if right^.kind=reg then operation(wa,ps,right,left)
else operation(wa,ps,left,right);
edif: if right^.kind=shortsignedcst then
begin
if left^.kind <> reg then load(left);
if left^.regno = 0 then
begin
makewrelcode(ws,0,0);
makeconst(right^.constant,nil);
end
else makeindexcode(al,left^.regno,left^.regno,-right^.constant);
makeregister(ps,left^.regno);
end
else
if ps^.typ^.typkind=ereal then operation(fs,ps,left,right)
else operation(ws,ps,left,right);
erealdiv: operation(fd,ps,left,right);
eintdiv:
begin
 if (right^.kind = shortsignedcst) or (right^.kind = wordcst) then
i:=poweroftwo(right^.constant) else i := 0;
if (i > 0) and (left^.typ^.typkind = esubrange) and
(left^.typ^.firstconst >= 0) then
(* only shift if the argument is positive *)
begin
if left^.kind <> reg then load(left);
makecode(as,left^.regno,-i);
makeregister(ps,left^.regno);
end
else
begin
operation(wd,ps,left,right);
with registerÆ(ps^.regno+maxreg) mod noofregÅ do
begin
user:=nil;
valid:=false;
end;
end;
end;
emod:begin
operation(wd,ps,left,right);
with registerÆps^.regnoÅ do
begin
user:=nil;
valid:=false;
end;
ps^.regno:=(ps^.regno+maxreg) mod noofreg;
end;
eminus:begin
if ps^.typ^.typkind =ereal then
begin
right:=newpseudo;
with right^ do
begin
typ:=realtype;
kind:=longcst;
constptr:=makerealconst(0.0);
end;
operation(fs,ps,right,left);
end
else
begin
if (left^.kind=reg) and (left^.regno <> 0) then
begin
makeindexcode(ac,left^.regno,left^.regno,0);
makeregister(ps,left^.regno);
end
else
begin
makeregister(ps,-1);
operation(ac,ps,ps,left);
code^.cÆlastindexÅ.indirect:=true;
end;
end;
end;
erightconv:if ps^.typ^.typkind = ereal then
begin
if left^.kind = reg then
begin
w:=left^.regno;
if w = maxreg then
begin
loadregister(1,left);
w:=1;
end;
end
else
begin
loadregister(1,left);
w:=1;
end;
w_1:=(w+maxreg) mod noofreg;
with registerÆw_1Å do
if (user <> nil) or valid then registerstore(w_1,w);
makecode(ci,w,0);
makeregister(ps,w_1);
registerÆwÅ:=registerÆw_1Å;
end
else (* ? *);
eendcall:with right^.symb^ do
if (namekind = efunc) and
standard then standardfunction(ps,left)
else
begin
oldparam:=paramoffset;
paramoffset:=paramoffset+blockmark;
while left <> nil do
begin
actualparam(left^.typ,left^.rightoperand);
pseudo:=left^.rightoperand;
returnpseudo(pseudo);
pseudo:=left;
left:=left^.leftoperand;
returnpseudo(pseudo)
end;

storeregisters(nil);
paramoffset:=oldparam;
if namekind = efunc then
begin
makeindexcode(al,1,stackaddr,display);
makecode(al,0,routinedescr);
callroutine;
end
else
begin
loadformal(varaddr);
callroutine;
end;
oldparam:=oldparam+maxstack+oneword;
makeregister(ps,0);
if oldparam >= maxsignedhalfword then
begin
reservecode(3);
makeallcode(am,0,true,true,0,0);
makeconst(oldparam,nil);
oldparam:=0;
end;
if ps^.typ^.typkind=ereal then
begin
makeindexcode(dl,1,stackaddr,oldparam+oneword);
registerÆ1Å:=registerÆ0Å;
end
else
begin
makeindexcode(rl,0,stackaddr,oldparam);
if (getbasetype(ps^.typ) = eboolean) and (skipk <> noskip) then
begin
if skipk = skiptrue then skip:=se
else skip:=sn;
makecode(skip,0,1);
makerelcode(jl,0);
forgetregisters;
end;
end;
end;
eset:begin
if right^.operator = eset then
begin
pseudo:=right^.leftoperand;
if pseudo^.kind = expression then evaltoresult(pseudo,noskip);
loadregister(1,pseudo);
reservecode(15);
with pseudo^,typ^ do
if (typkind = einteger) or
((typkind = esubrange) and (firstconst < 0)) then
makecode(sl,regno,0);
makecode(sl,pseudo^.regno,setsize * ((maxbit+1) div oneword));
makerelcode(jl,11*oneword);
returnpseudo(pseudo);
makecode(al,0,0);
makewrelcode(wd,1,0);
makeconst(maxbit+1,nil);
makecode(as,1,1);
makeindirectcode(ac,3,0,0);
makewrelcode(rl,0,0);
makeconst(minint,nil);
makeindexcode(ls,0,3,0);
makeindexcode(am,0,1,0);
makeindexcode(lo,0,stackaddr,left^.addr.ordinal);
makeindexcode(am,0,1,0);
makeindexcode(rs,0,stackaddr,left^.addr.ordinal);
end;
ps^:=left^;
left^.kind:=variable;
end;
ein:inoperator;
esetinter: setoperation(la);
esetunion: setoperation(lo);
esetdif: setoperation(ac);
end; (* CASE ps^.operator OF *)
returnpseudo(left);
returnpseudo(right);
end; (* evaltoresult *)


procedure endcasecode;
var
w, i, low, loww, startjump,
otherwoffset, firstfreeindex : integer;
lab, lab1 : caselabptr;

procedure jumpforward(length,fromindex:integer);
begin
length:=(length+2)*oneword;
with code^ do
if length < maxsignedhalfword then cÆfromindex-2Å.displacement:=length
else
if length < maxhalfword then
begin
cÆfromindex-2Å.opcode:=am;
cÆfromindex-1Å.displacement:=length-maxsignedhalfword;
end
else
begin
with cÆfromindex-2Å do
begin
opcode:=rl;
w:=3;
displacement:=2*oneword;
end;
with cÆfromindex-1Å do
begin
index:=3;
relative:=true;
end;
cÆfromindexÅ.constval:=length-oneword;
end;
end; (* jumpforward *)

begin (* endcasecode *)
w:=pseudotop^.regno;
with neststackÆgetnumberÅ do
begin
startjump:=lastindex;
if (lowlabel = maxint) and (highlabel = -maxint) then
(* empty case statement list, force otherwise action *)
lowlabel := highlabel;
if otherw or check then
begin
reservecode(5); (* reserve room for 3 instructions and possibly 2 constants *)
if abs( highlabel) > maxsignedhalfword then
begin
makeallcode( sh, w, reladdr, indirectmode, 0, 0);
makeconst( highlabel, nil );
end
else
makecode(sh,w,highlabel);
if abs( lowlabel ) > maxsignedhalfword then
begin
makeallcode( sh, w, reladdr, indirectmode, 0, 0);
makeconst( lowlabel - 1, nil );
makewrelcode( rl, w, 0);
makeconst( lowlabel - 1, nil );
end
else
begin
makecode(sh,w,lowlabel-1);
makecode(al,w,lowlabel-1);
end;
end;
if highlabel-lowlabel > maxcode-6 then error(310)
else
begin
reservecode(highlabel-lowlabel+6);
makecode(as,w,1);
loww:=(4-lowlabel)*oneword;
low:=loww;
if (low < minsignedhalfword) or (low > maxsignedhalfword) then
begin
low:=0;
makewrelcode(wa,w,6);
end;
makeallcode(rl,1,true,false,w,low);
makeallcode(jl,0,true,false,1,0);
makewordcode(loww);

low:=lastindex;
firstfreeindex:=low+highlabel-lowlabel+3;
if otherw then otherwoffset:=labelchain^.codindex+1
else otherwoffset:=firstfreeindex;
otherwoffset:=(otherwoffset-low+1)*oneword;
for i:=low+1 to firstfreeindex-1 do makewordcode(otherwoffset);
low:=low+2;
lab:=labelchain;
while lab <> nil do
begin
i:=lab^.codindex;
code^.cÆlab^.labval-lowlabel+lowÅ.constval:=(i-low+4)*oneword;
if i <> startindex then
jumpforward(firstfreeindex-i,i);
lab1:=lab;
lab:=lab^.next;
returncaselab(lab1);
end;
jumpforward(startjump-startindex+1,startindex);
jumpforward(firstfreeindex-startjump,startjump);
end;
end;
returnpseudo(pseudotop);
end; (* endcasecode *)


procedure indexaddress; (* VAR arr : addrnode; VAR elementlength : integer  FORWARD declared *)
var
fixedbase, fixedrecbase, lowbound, elementsize, elementprindex,
bitprelement, elementsprword, w, l : integer;
left, right, oldright, oldpseudo, indexpseudo, recordbase : pseudoptr;
varindexmet, packelements : boolean;
begin
left:=arr.index;
oldpseudo:=nil;
elementlength:=maxbit; (* represents no packing *)

(* invert the list of indices *)
while left <> nil do
begin
left^.next:=oldpseudo;
oldpseudo:=left;
left:=left^.leftoperand;
end;

fixedbase:=0;
left:= oldpseudo;
oldright:=nil;
recordbase := nil;
fixedrecbase := 0;
varindexmet:=false;
packelements:=false;
elementprindex:=maxbit+1;

while left <> nil do
with left^ do
begin
right:=rightoperand;
if right^.kind = expression then evaltoresult(right,noskip)
else
if right^.kind = variable then load(right);

with typ^.indextyp^ do
if typkind = esubrange then
begin
lowbound:=firstconst;
if check then
checkrange(right,lowbound,lastconst);
end
else lowbound:=0;

with typ^.valtyp^ do
begin
if (typkind = earray) and (left^.next <> nil) then
with indextyp^ do
begin
if typkind = esubrange then elementsize:=lastconst-firstconst+1
else elementsize:=lastscalar+1;
elementprindex:=elementsize;
end
else
begin
elementsize:=size;
packelements:=typ^.packedval;
if packelements then
begin
bitprelement:=bitsize;
elementsize:=1;
elementlength:=bitprelement;
elementsprword:=(maxbit+1) div bitprelement;
if elementsprword > elementprindex then elementsprword:=elementprindex;
end;
end;
end;

if right^.kind = reg then
begin
varindexmet:=true;
if oldright <> nil then
begin
operation(wa,right,right,oldright);
with oldright^ do
if kind = reg then registerÆregnoÅ.user:=nil;
end;
oldright:=right;
end
else
begin (* constant index *)
lowbound:=lowbound-right^.constant;
if varindexmet then right:=oldright;
end;
if varindexmet and(elementsize > 1) then
with right^ do
begin (* unpacked elements *)
l:=poweroftwo(elementsize);
if l > 0 then
with registerÆregnoÅ do
begin
makecode(as,regno,l);
locassociated:=false;
kind:=variable;
lastused:=0;
end
else
begin
indexpseudo:=newpseudo;
with indexpseudo^ do
begin
typ:=integertype;
kind:=wordcst;
constant:=elementsize;
end;
operation(wm,right,right,indexpseudo);
registerÆright^.regnoÅ.lastused:=0;
returnpseudo(indexpseudo);
end;
end;
fixedbase:=(fixedbase-lowbound)*elementsize;

if (typ^.valtyp^.typkind <> earray) or (next = nil) then
begin
(* this element is a record element or the last element of
an index list *)
if recordbase <> nil then
begin
(* add recordbase to array-relative *)
operation(wa, right, right, recordbase);
with recordbase^ do
if kind = reg then
with registerÆregnoÅ do (* forget the old recordbase *)
begin
user := nil;
valid := false;
end;
end; (* if recordbase <> nil *)

if varindexmet then
recordbase := right; (* remember the recordbase register *)
oldright := nil; (* force fresh index computing *)
fixedrecbase := fixedrecbase + fixedbase;
fixedbase := 0; 
varindexmet := false;
end; (* typkind <> array or last element *)
left:=next;
end;

fixedbase := fixedbase + fixedrecbase;

indexpseudo:=arr.index;
right:=indexpseudo^.rightoperand;
(* return pseudo nodes, changed 79.12.18 *)
returnpseudo(right);
while oldpseudo^.next <> nil do
begin
right := oldpseudo^.rightoperand;
returnpseudo(right);
returnpseudo(oldpseudo);
end;
with indexpseudo^ do
begin
typ:=integertype;
if not packelements then
with arr do
if simpleaddr then ordinal:=fixedbase+ordinal
else postordinal:=postordinal+fixedbase;
if recordbase<> nil then
begin
w := recordbase^.regno;
if packelements then
begin (* packed elements *)
registerÆwÅ.user:=nil;
storeregisters(nil);
if w <> 1 then
begin
makecode(rl,1,w*oneword);
w:=1;
end;
if (fixedbase < minsignedhalfword) or (fixedbase > maxsignedhalfword) then
begin
makewrelcode(wa,w,0);
makeconst(fixedbase,nil);
end
else
if fixedbase <> 0 then makeindexcode(al,w,w,fixedbase);
makecode(bl, 0, 2); (* sign extension  *)
makecode(bl, 0, 0);
makewrelcode(wd,w,0);
makeconst(elementsprword,nil);
makecode(as,w,1);
if bitprelement <> 1 then
begin
l:=poweroftwo(bitprelement);
if l>0 then makecode(as,0,l)
else
begin
reservecode(2);
makewrelcode(wm,0,0);
makeconst(bitprelement,nil);
end;
end;
end;

makeregister(indexpseudo,w);
end
else
begin (* constant index *)
if packelements then
with arr do
begin (* packed elements *)
bitstart:=bitstart+(fixedbase mod elementsprword)*bitprelement;
if simpleaddr then ordinal:=(fixedbase div elementsprword)*oneword+ordinal
else postordinal:=(fixedbase div elementsprword)*oneword+postordinal;
end;
end;
end;
end;
procedure addvaluetolist(intval:integer; symb:symbolptr);
var
i, j, l, size : integer;
word : opnode;
val : valueptr;
begin
l:=(wordoffset-currentproc^.paramlist^.displayoffset-level) div oneword ;
with code^ do
(* use code^.c to hold values *)
if symb = nil then
with cÆlÅ do
begin (* integer *)
constval:=intval;
wordoffset:=wordoffset+oneword;
size:=1;
l:=l+1;
end
else
begin
case symb^.constkind of
realconst:begin
putreal(symb^.realval,l);
wordoffset:=wordoffset+realsize;
size:=realsize div oneword;
l:=l+size;
end;
setconst:begin
size:=setsize div oneword;
with symb^.setval^ do
for i:=1 to setsize div oneword do
begin
word.half1:=hlfwordsÆi*oneword-1Å;
word.half2:=hlfwordsÆi*onewordÅ;
cÆlÅ:=word;
l:=l+1;
end;
wordoffset:=wordoffset+setsize;
end;
stringconst:begin
with symb^.stringval^ do
begin
size:=(length+(asciiperword-1)) div asciiperword;
j:=0;
for i:=1 to length do
begin
j:=j+1;
word.strÆjÅ:=strÆiÅ;
if j mod asciiperword = 0 then
begin
cÆlÅ:=word;
j:=0;
l:=l+1;
end;
end;
if j <> 0 then
begin
for i:=j+1 to asciiperword do word.strÆiÅ:=' ';
cÆlÅ:=word;
l:=l+1;
end;
end;
wordoffset:=wordoffset+size*oneword;
end;
end;
end;

if noofvalue <= maxvalue then
begin (* add to valuelist *)
for i:=size downto 1 do
begin
val:=newvalue;
with val^ do
begin
next:=valuelist;
ordinal:=wordoffset-i*oneword;
initval:=code^.cÆl-iÅ;
end;
valuelist:=val;
end;
end;
valueword:=0;
nextbit:=0;
end; (* addvaluetolist *)

procedure storevalue;
var
valuetype, constvalue : symbolptr;
string : pseudoptr;
val, i : integer;
begin
valuetype:=getsymbptr;
i:=getnumber; (* not used *)
constvalue:=getsymbptr;
if constvalue = nil then
begin (* set *)
constvalue:=pseudotop^.constptr;
returnpseudo(pseudotop);
end;

if valuetype <> nil then
with valuetype^ do
begin
if typkind = earray then
begin (* convert strings *)
string:=newpseudo;
with string^ do
begin
next:=pseudotop;
if constvalue^.constkind = stringconst then
begin
kind:=longcst;
constptr:=constvalue;
end
else
begin
kind:=shortsignedcst;
constant:=constvalue^.intval;
end;
end;
pseudotop:=string;
convertconstant(valuetype);
constvalue:=pseudotop^.constptr;
returnpseudo(pseudotop);
end
else val:=constvalue^.intval;

if typkind = esubrange then
if (val < firstconst) or (val > lastconst) then
error(312);
packedvalue:=pseudotop^.pack;
if (packedtype = signedhlfword) and (val < 0) and
packedvalue then val:=val+(maxhalfword+1);

for i:=1 to pseudotop^.valcount do (* repeat array elements *)
if (size = oneword) and (typkind <> earray) then
begin
if packedvalue then
begin
if nextbit + bitsize > maxbit+1 then
begin (* new word *)
valueword:=valueword*powerÆmaxbit+1-nextbitÅ;
addvaluetolist(valueword,nil);
end
else valueword:=valueword*powerÆbitsizeÅ;
valueword:=valueword+val;
nextbit:=nextbit+bitsize;
end
else
begin
valueword:=val;
addvaluetolist(valueword,nil);
end;
end
else addvaluetolist(0,constvalue);
if typkind = earray then returnstring(constvalue^.stringval);
returnpseudo(pseudotop);
end;
end; (* storevalue *)

procedure elementend;
var
size, i, j, l, val, last, first, woffset : integer;
vallist : valueptr;
begin
with pseudotop^ do
begin
size:=typ^.size;
if (nextbit > 0) and (typ^.bitsize > maxbit) then
begin
if nextbit <= maxbit then valueword:=valueword*powerÆmaxbit+1-nextbitÅ;
addvaluetolist(valueword,nil);
end;
packedvalue:=pack;
if valcount > 1 then
begin (* repeat array elements *)
if packedvalue then
with typ^ do
begin
val:=valueword;
if val < 0 then val:=val-minint;
val:=val mod powerÆbitsizeÅ; (* ? *)
for i:=2 to valcount do
begin
if nextbit+bitsize > maxbit+1 then
begin (* new word *)
valueword:=valueword*powerÆmaxbit+1-nextbitÅ;
addvaluetolist(valueword,nil);
end
else valueword:=valueword*powerÆbitsizeÅ;
valueword:=valueword+val;
nextbit:=nextbit+bitsize;
end
end
else
begin
size:=size div oneword;
woffset:=wordoffset;
l:=(woffset-currentproc^.paramlist^.displayoffset-level) div oneword;
last:=l;
first:=last-size;
last:=last-1;
with code^ do
for i:=2 to valcount do
begin
for j:=first to last do
begin
cÆlÅ:=cÆjÅ;
l:=l+1;
if noofvalue <= maxvalue then
begin
vallist:=newvalue;
with vallist^ do
begin
next:=valuelist;
ordinal:=woffset;
woffset:=woffset+oneword;
initval:=cÆjÅ;
end;
valuelist:=vallist;
end;
end;
end;
wordoffset:=wordoffset+(valcount-1)*size*oneword;
end;
end;
end;
returnpseudo(pseudotop);
end; (* elementend *)

procedure fieldbegin;
var
ps : pseudoptr;
field : symbolptr;
begin
field:=getsymbptr;
if field <> nil then
begin
packedvalue:=field^.varaddr.packk <> unpack;
if (nextbit > 0 ) and (nextbit <> field^.varaddr.bitstart) then
begin
valueword:=valueword*powerÆmaxbit+1-nextbitÅ;
addvaluetolist(valueword,nil);
end;
nextbit:=field^.varaddr.bitstart;
end;
ps:=newpseudo;
with ps^ do
begin
next:=pseudotop;
kind:=valueinit;
valcount:=1;
pack:=packedvalue;
end;
pseudotop:=ps;
end; (* fieldbegin *)


begin (* pass2 *)
initialize;

while intermitword<>eendprogram do
begin (* process one PIF statement *)
case intermitword of
enone:;
ename:
readnamedef ;
econst:
readconst ;
elabel:
readlabeldecl ;
etype:
readtypegeneral ;
ebackref:
begin
s:=getsymbptr;(* not used *)
currentproc:=getsymbptr;
with currentproc^ do
begin
sortlist:=declarationlist;
declarationlist:=nil;
availtmp:=0;
localordinal:=paramlist^.displayoffset;
end;
end;
enamelist:
readnamelist ;
evarlist:
begin
s := getsymbptr ;
with s^ do
begin
key := evarlist ;
fixsize := namelistsize ; (* from preceding endnamelist, fix *)
taglist := nil ;
end ;
currentvarlist := s ;
end ;
ecaselist:
begin (*making a head of the case record label list *)
currentcase := getsymbptr ;
with currentcase^ do
begin
key:=ecaselist;
nextreclab := nil ;
end;
end ;
etagelement:
begin
s := getsymbptr ;
with s^ do
begin
key := etagelement ;
labellist := getsymbptr ;
tagsize := namelistsize ;  (*from preceding endnamelist, fix or endvarlist*)
s1:=getsymbptr;
currentvarlist:=s1^.oldvarlist;
nexttag := currentvarlist ^.taglist ;
varlst:=getsymbptr;
currentvarlist^.taglist := s ;
end ;
end ;
erecordlabel:
readrecordlabel;
eforward:
begin
currentproc^.declarationlist:=sortlist;
sortlist:=nil;
currentproc:=nil;
end;
eendvarlist:
with currentvarlist^ do
begin
s := taglist ;
namelistsize := fixsize ;
while s <> nil do
begin
if namelistsize< s^.tagsize then namelistsize:=s^.tagsize;
s:=s^.nexttag;
end; (* WHILE s<>nil  ... *)
end ;
eendnamelist:
readendnamelist ;
eendcaselist: (* nothing is done *);

eendmodule:
begin
standenvir:=false;
currentmodule:=nil;
end;
evalue:
begin
(* initialize the code area, the value 7654321 is used
because it is an ill. pointer, an ill. index, and an ill.
instruction *)
for i := 1 to maxindex do
code^.cÆiÅ.constval := 7654321;
allocatelist;
noofvalue:=0;
highvalue:=minsignedhalfword;
valuelist:=nil;
end;
eendvalue:
begin
if noofvalue <= maxvalue then
begin (* remember the values until blockbegin *)
with currentproc^.paramlist^ do
begin
initlist:=valuelist;
lengthofvalue:=noofvalue;
end;
end
else
begin
while valuelist <> nil do
begin
returnvalue(valuelist);
end;
highvalue:=highvalue-currentproc^.paramlist^.displayoffset-level;
i:=(highvalue+(segmentlgt-3)) div segmentlgt;
highvalue:=i*(segmentlgt div oneword);
if highvalue > maxindex then
begin
error(405);
highvalue:=maxindex;
end;
lastindex:=highvalue;
with currentproc^.paramlist^ do
begin
valuesegment:=emitcode;
lengthofvalue := codesegment - valuesegment;
end;
end;
end;
evaluename:
begin
s:=getsymbptr;
wordoffset:=s^.varaddr.ordinal;
nextbit:=0;
valueword:=0;
packedvalue:=s^.varaddr.packk <> unpack;
noofvalue:=noofvalue+s^.vartypedescr^.size;
if highvalue <= wordoffset then highvalue:=wordoffset+s^.vartypedescr^.size;
if highvalue-currentproc^.paramlist^.displayoffset-level >
maxindex*oneword then stop (405);
end;
evaluenaend:
if nextbit <> 0 then
begin
valueword:=valueword*powerÆmaxbit+1-nextbitÅ;
addvaluetolist(valueword,nil);
end;
eelementbegin:
begin
pseudo:=newpseudo;
with pseudo^ do
begin
next:=pseudotop;
typ:=getsymbptr;
kind:=valueinit;
valcount:=getnumber;
pack:=packedvalue;
packedvalue:=typ^.packedval;
end;
pseudotop:=pseudo;
end;
eelementend:
elementend;
efieldbegin:
fieldbegin;
efieldend:
begin
packedvalue:=pseudotop^.pack;
returnpseudo(pseudotop);
end;
estorevalue:
storevalue;
eblockbegin:
blockbegin;
eblockend:
blockend;
enamecode:
begin
s:=getsymbptr;
pseudo:=newpseudo;
with pseudo^ do
begin
next:=pseudotop;
with s^ do
case namekind of
efile,
evar,
evalparam:begin
typ:=vartypedescr;
kind:=variable;
addr:=varaddr;
 if not addr.simpleaddr then
 (* namekind = file and file name is input or output *)
 (* take a copy of the address node *)
 begin
 address := newaddress;
 address^ := addr.reference^;
 addr.reference := address;
 end; (* at most one level of address nodes !!! *)
end;
evarparam:begin
typ:=vartypedescr;
kind:=variable;
address := newaddress;
address^:=varaddr;
with addr do
begin
index:=nil;
packk:=s^.varaddr.packk;
bitstart := s^.varaddr.bitstart; (* 80.03.19 *)
simpleaddr:=false;
postordinal:=0;
reference:=address;
end
end;

effunc,
efproc,
efunc,
eproc:
begin (* procedure/function as parameter *)
kind:=procfunc;
if namekind=efunc then typ:=functype
else
if namekind=effunc then typ:=vartypedescr;
if standard then
begin
(* ? *)
end
else symb:=s;
end;
end;
end;
pseudotop:=pseudo;
end;
efunction:
begin
s:=getsymbptr;
pseudo:=newpseudo;
with s^, pseudo^ do
begin
typ:=functype;
next:=pseudotop;
kind:=variable;
with addr do
begin
index:=nil;
packk:=unpack;
simpleaddr:=true;
blocknumber:=blocklevel+oneword;
ordinal:=minparamordinal-blockmark;
end;
end;
pseudotop:=pseudo;
end;
econstcode:
begin
s:=getsymbptr;
pseudo:=newpseudo;
with s^,pseudo^ do
begin
typ:=consttype;
next:=pseudotop;
if constkind = signedshortconst then
begin
kind:=shortsignedcst;
constant:=intval;
end
else
if constkind=wordconst then
begin
kind:=wordcst;
constant:=intval;
end
else
begin
kind:=longcst;
constptr:=s;
end;
end;
pseudotop:=pseudo;
end;
efield:
begin
s:=getsymbptr;
with pseudotop^ do
begin
with addr do
begin
if simpleaddr then ordinal:=ordinal+s^.varaddr.ordinal
else postordinal:=postordinal+s^.varaddr.ordinal;
packk:=s^.varaddr.packk;
bitstart:=s^.varaddr.bitstart;
end;
typ:=s^.vartypedescr;
end;
end;
ereference:
with pseudotop^ do
begin
if typ^.typkind = efile then
begin
if addr.simpleaddr then addr.ordinal:=addr.ordinal+(h4+4)
else addr.postordinal:=addr.postordinal+(h4+4);
typ:=typ^.elementtyp;
if getbasetype(typ) = eascii then goto 1;
end
else typ:=typ^.pointertotyp;
address := newaddress;
address^:=pseudotop^.addr;
with addr do
begin
index:=nil;
packk:=typ^.packedtype;
simpleaddr:=false;
postordinal:=0;
reference:=address;
end;
1:
end;
eindex:
begin
pseudo:=pseudotop^.next;
newtop(eindex,getsymbptr,pseudo^.addr.index,pseudotop);
pseudo^.addr.index:=pseudotop;
pseudo^.addr.packk:=pseudo^.typ^.valtyp^.packedtype;
if not pseudo^.typ^.packedval then pseudo^.addr.packk:=unpack;
pseudo^.typ:=pseudo^.typ^.valtyp;
pseudotop:=pseudo;
end;
eload:; (* nothing is done *)
estorefunc,
estore:
begin
s:=pseudotop^.next^.typ;
with s^,  pseudotop^ do
begin
if kind=expression then
begin
if getbasetype(typ) = eboolean then storeregisters(nil);
evaltoresult(pseudotop,noskip);
end;
if size > 4 then
begin
if size <= maxshortcopy then
begin
pseudo:=pseudotop^.next;
if pseudo^.addr.simpleaddr
and (pseudo^.addr.index = nil)
and (pseudo^.addr.blocknumber = level)
and (pseudo^.addr.ordinal+size <= maxordinal) then
begin
loadaddress(1,pseudotop);
storeregisters(pseudotop);
copyshort(size,pseudo^.addr.ordinal,false);
end
else
if ((kind = variable) or (kind = tmp))
and addr.simpleaddr
and (addr.index = nil)
and (addr.blocknumber = level)
and (addr.ordinal+size <= maxordinal) then
begin
loadaddress(1,pseudo);
storeregisters(pseudo);
copyshort(size,addr.ordinal,true);
end
else
begin
loadaddress(1,pseudotop);
copylong(size,pseudo);
end;
end
else
begin
loadaddress(1,pseudotop);
copylong(size,next);
end;
returnpseudo(pseudotop);
returnpseudo(pseudotop);
end
else
with next^.typ^ do
begin
noconstcheck:=true;
if kind <> reg then
begin
if ((kind=wordcst) or (kind = shortsignedcst))
and (typkind = esubrange) then
begin
checkrange(pseudotop,firstconst,lastconst);
noconstcheck:=false;
end;
load(pseudotop);
end;
if check and noconstcheck and (typkind = esubrange) then
checkrange(pseudotop,firstconst,lastconst);
store(pseudotop^.regno,pseudotop^.next);
returnpseudo(pseudotop);
returnpseudo(pseudotop);
end;
end;
end;
estartset :
begin
for i:=1 to setsize do powerset.hlfwordsÆiÅ:=0;
powersetpseudo:=newpseudo;
with powersetpseudo^ do
begin
typ:=settype;
next:=pseudotop;
kind:=longcst;
end;
pseudotop:=powersetpseudo;
end;
eset:
with pseudotop^ do
if kind=shortsignedcst then
begin
if (constant<0) or
(constant> (maxbit+1)*setsize div oneword -1 ) then error(305)
else
powerset.bitsÆconstantÅ:=1;
returnpseudo(pseudotop);
end
else
begin
newtop(eset,typ,pseudotop,nil);
newtop(eset,typ,pseudotop^.next,pseudotop);
end;
esetrange:
with pseudotop^ do
if (kind=shortsignedcst) and
(next^.kind=shortsignedcst) then
begin
if (next^.constant < 0 ) or
(constant > (maxbit+1)*setsize div oneword -1) then error(305)
else
for i:=next^.constant to constant do
powerset.bitsÆiÅ:=1;
returnpseudo(pseudotop);
returnpseudo(pseudotop);
end
else
begin
error(315);
newtop(esetrange,typ,next,pseudotop);
newtop(eset,typ,pseudotop^.next,pseudotop);
end;
eendset:
with powersetpseudo^ do
begin
new(s);
constptr:=s;
with s^ do
begin
key:=econst;
consttype:=settype;(* ? *)
startchain:=0;
constindex:=0;
constkind:=setconst;
new(sett);
sett^:=powerset;
setval:=sett;
end;
end;
erightconv:
convertconstant(getsymbptr);
eleftconv:
begin
pseudo:=pseudotop;
pseudotop:=pseudotop^.next;
s:=getsymbptr;
convertconstant(getsymbptr);
pseudo^.next:=pseudotop;
pseudotop:=pseudo;
end;
enot:
begin
if pseudotop^.kind=shortsignedcst then
begin
pseudotop^.constant:=1-pseudotop^.constant;
end
else newtop(enot,booltype,pseudotop,nil);
end;
eand,
eor:
begin
if intermitword=eand then i:=0 else i:=1;
pseudo:=pseudotop^.next;
if pseudo^.kind=shortsignedcst then
begin
if pseudo^.constant=i then
begin
pseudotop^.constant:=i;
pseudotop^.kind:=shortsignedcst;
end;
returnpseudo(pseudo);
pseudotop^.next:=pseudo;
end
else
if pseudotop^.kind=shortsignedcst then
begin
if pseudotop^.constant=i then
begin
pseudo^.constant:=i;
pseudo^.kind:=shortsignedcst;
end;
returnpseudo(pseudotop);
end
else
begin
if pseudotop^.kind=expression then newtop(intermitword,booltype,pseudo,pseudotop)
else newtop(intermitword,booltype,pseudotop,pseudo);
end;
end;
emult, eadd, esetunion,
esetinter:
commute(getsymbptr);
eeq,ene:
commute(booltype);
elt, ele, ege,
egt:
begin
pseudo:=pseudotop^.next;
if ((pseudo^.kind=wordcst) or (pseudo^.kind=shortsignedcst)) and
((pseudotop^.kind=wordcst) or (pseudotop^.kind=shortsignedcst)) then
begin
case intermitword of
elt: pseudo^.constant:= ord(pseudo^.constant < pseudotop^.constant);
ele: pseudo^.constant:= ord(pseudo^.constant <= pseudotop^.constant);
ege: pseudo^.constant:= ord(pseudo^.constant >= pseudotop^.constant);
egt: pseudo^.constant:= ord(pseudo^.constant > pseudotop^.constant);
end;
pseudo^.kind:=shortsignedcst;
pseudo^.typ:=booltype;
returnpseudo(pseudotop);
end
else
begin
if (pseudotop^.kind=expression) or (pseudo^.kind=wordcst)
or (pseudo^.kind=shortsignedcst) or (pseudo^.kind=longcst) then
begin (*exchange top and top-1 *)
pseudotop^.next:=pseudo^.next;
pseudo^.next:=pseudotop;
pseudotop:=pseudo;
intermitword:=konvrelationÆintermitwordÅ;
pseudo:=pseudotop^.next;
end;
if (pseudotop^.typ^.typkind=eboolean) and
(pseudo^.kind=expression) then
case intermitword of
ele,
elt:
begin
if intermitword=elt then intermitword:=eand
else intermitword:=eor;
ps:=pseudotop;
pseudotop:=pseudo;
newtop(enot,booltype,pseudo,nil);
ps^.next:=pseudotop;
pseudotop:=ps;
newtop(intermitword,booltype,pseudotop^.next,pseudotop);
end;
egt,
ege:
begin
if intermitword=ege then intermitword:=eand
else intermitword:=eor;
ps:=pseudotop;
pseudotop:=pseudo;
newtop(enot,booltype,pseudo,nil);
ps^.next:=pseudotop;
pseudotop:=ps;
newtop(intermitword,booltype,pseudotop^.next,pseudotop);
newtop(enot,booltype,pseudotop,nil);
end;
end
else
newtop(intermitword,booltype,pseudo,pseudotop);
end;
end;
erealdiv,esetdif,
eintdiv,emod,
edif:
begin
pseudo:=pseudotop^.next;
if ((pseudo^.kind=wordcst) or (pseudo^.kind=shortsignedcst)) and
((pseudotop^.kind=wordcst) or (pseudotop^.kind=shortsignedcst)) then
begin
case intermitwords of
eintdiv:if pseudotop^.constant = 0 then error(324)
else pseudo^.constant:= pseudo^.constant div pseudotop^.constant;
emod:if pseudotop^.constant = 0 then error(324)
else pseudo^.constant:= pseudo^.constant mod pseudotop^.constant;
edif: pseudo^.constant:= pseudo^.constant - pseudotop^.constant;
end;
if (pseudo^.constant <= maxsignedhalfword) and
(pseudo^.constant >= minsignedhalfword) then pseudo^.kind:=shortsignedcst
else pseudo^.kind:=wordcst;
returnpseudo(pseudotop);
end
else
begin
if (intermitword = eintdiv) or (intermitword = emod) then s:=pseudo^.typ
else s:=getsymbptr;
newtop(intermitword,s,pseudo,pseudotop);
end;
end;
ein:
newtop(ein,booltype,pseudotop^.next,pseudotop);
eminus:
with pseudotop^ do
if (kind=shortsignedcst) or (kind=wordcst) then
begin
constant:=-constant;
if (constant <= maxsignedhalfword) and
(constant >= minsignedhalfword) then
kind := shortsignedcst
else kind := wordcst;
end 
else
begin
newtop(eminus,typ,pseudotop,nil);
end;
eif:
begin
pushnest;
neststackÆndepthÅ.skipif:=noskip;
end;
ethen:
begin
ndepth:=getnumber;
if pseudotop^.kind = expression then
begin
evaltoresult(pseudotop,skiptrue);
forgetregisters;
end
else
begin
if pseudotop^.kind = shortsignedcst then
begin
if pseudotop^.constant=0 then
begin (* skip until else or endif *)
repeat
repeat
nextline;
if intermitword = econst then readconst
else if intermitword = etype then readtypegeneral
else if intermitword = elabeldef then error(321);
until (intermitword = eelse) or (intermitword = eendif);
until getnumber = ndepth;
neststackÆndepthÅ.skipif:=skipfalse;
end
else neststackÆndepthÅ.skipif:=skiptrue;
end
else
begin
if pseudotop^.kind <> reg then load(pseudotop);
i := pseudotop^.regno;
storeregisters(pseudotop);
reservecode(2);
makecode(se,i,1);
makerelcode(jl,0);
outconstlimit:=outconstlimit-1;
end;
end;
neststackÆndepthÅ.index:=lastindex;
returnpseudo(pseudotop);
end;
eelse:
begin
ndepth:=getnumber;
if neststackÆndepthÅ.skipif = noskip then
begin
storeregisters(nil);
makerelcode(jl,0);
insertaddr(neststackÆndepthÅ.index,lastindex+1);
neststackÆndepthÅ.index:=lastindex;
end
else
if neststackÆndepthÅ.skipif = skiptrue then
begin
repeat
repeat
nextline;
if intermitword = econst then readconst
else if intermitword = etype then readtypegeneral
else if intermitword = elabeldef then error(321);
until intermitword = eendif;
until getnumber = ndepth;
end;
end;
eendif:
begin
ndepth:=getnumber;
if neststackÆndepthÅ.skipif = noskip then
begin
storeregisters(nil);
insertaddr(neststackÆndepthÅ.index,lastindex+1);
end;
end;
elabeldef:
begin
storeregisters(nil);
s:=getsymbptr;
code^.cÆs^.labeladdroffsetÅ.constval:=(lastindex)*oneword;
end;
egoto:
begin
storeregisters(nil);
s:=getsymbptr;
with s^ do
if labellevel = level then
begin
makeindexcode(rl,3,stackaddr,labelordinal);
makewrelcode(wa,3,2*oneword);
makeallcode(jl,0,true,false,3,0);
makewordcode((1-lastindex)*oneword);
end
else
begin
makeindexcode(rl,1,stackaddr,display+labellevel);
makeindexcode(rs,1,stackaddr,dynlinkoffset);
makeindexcode(rl,3,1,labelordinal);
makewrelcode(rl,0,0);
makeconst(procaddr,nil);
makeindexcode(ds,0,stackaddr,returnaddroffset);
makeindexcode(rl,3,stackaddr,display);
makeindirectcode(jl,0,3,returnoffset);
end;
end;
ecase:
begin
pushnest;
with neststackÆndepthÅ do
begin
labelchain:=nil;
lowlabel:=maxint;
highlabel:=-maxint;
otherw:=false;
end;
end;
eoff:
with pseudotop^ do
begin
if kind = expression then evaltoresult(pseudotop,noskip)
else if kind <> reg then load(pseudotop);
i:=regno;
registerÆiÅ.kind:=expression;
storeregisters(nil);
if i=0 then
begin
makecode(rl,1,0);
i:=1;
end;
kind:=reg;
regno:=i;
reservecode(3);
makerelcode(jl,maxsignedhalfword);
makecode(jl,0,0);
makewordcode(0);
pushnest; (* must! be called; side effect:
nextstack Æ ndepth Å . startindex := lastindex  *)
end;
ecaselabel:
begin
s:=getsymbptr;
ndepth:=getnumber;
with neststackÆndepthÅ do
begin
l:=s^.intval;
if s^.consttype^.typkind = einteger then
begin (* check multible occurences of the label *)
lab:=labelchain;
while lab <> nil do
begin
if lab^.labval = l then
begin
error(308);
lab:=nil;
end
else lab:=lab^.next;
end;
end;
lab:=newcaselab;
with lab^ do
begin
next:=labelchain;
labval:=l;
codindex:=lastindex;
end;
labelchain:=lab;
if lowlabel > l then
begin
if l < -maxint then error(309)
else lowlabel:=l;
end;
if highlabel < l then highlabel:=l;
end;
end;
egotoendcase:
begin
storeregisters(nil);
reservecode(3);
makerelcode(jl,maxsignedhalfword);
makecode(jl,0,0);
makewordcode(0);
end;
eotherwise:
with neststackÆgetnumberÅ do
begin
otherw:=true;
lab:=newcaselab;
with lab^ do
begin
next:=labelchain;
codindex:=lastindex;
labval:=lowlabel-1;
end;
labelchain:=lab;
end;
eendcase:
endcasecode;
ewhile:
begin
storeregisters(nil);
pushnest;
end;
ewhiledo:
begin
boolexpression;
neststackÆndepthÅ.index:=lastindex;
outconstlimit:=outconstlimit-1;
end;
eendwhile:
begin
storeregisters(nil);
ndepth:=getnumber;
i:=(lastindex-neststackÆndepthÅ.startindex)*oneword;
jump(i);
insertaddr(neststackÆndepthÅ.index,lastindex+1);
end;
erepeat:
begin
storeregisters(nil);
pushnest;
end;
euntil: ; (* nothing is done *)
eendrepeat:
begin
boolexpression;
i:=(lastindex-neststackÆndepthÅ.startindex)*oneword;
l:=lastindex;
if i < maxsignedhalfword then insertaddr(lastindex,neststackÆndepthÅ.startindex+1)
else
begin
reservecode(4);
makerelcode(jl,3*oneword);
insertaddr(l,lastindex+1);
jump(i+2);
end;
end;

efor,eforinit: (* nothing is done *);
efortodo:
forstatement(sl,sh,1);
efordowntodo:
forstatement(sh,sl,-1);
efordntoend,
efortoend:
begin
ndepth:=getnumber;
s:=getsymbptr;
pseudo:=newpseudo;
with pseudo^ do
begin
next:=nil;
typ:=s^.vartypedescr;
kind:=variable;
addr:=s^.varaddr;
end;
loadregister(neststackÆndepthÅ.stepregister,pseudo);
storeregisters(pseudo);
returnpseudo(pseudo);
i:=(lastindex-neststackÆndepthÅ.startindex+2)*oneword;
jump(i);
insertaddr(neststackÆndepthÅ.index,lastindex+1);
returnpseudo(pseudotop);
returnpseudo(pseudotop);
end;

ewith:; (* nothing is done *)
ewithvar:
begin
pushnest;
with pseudotop^ do
begin
if (addr.index <> nil) or not addr.simpleaddr then
begin
address := newaddress;
i:=freeregister(true);
loadaddress(i,pseudotop);
typ:=integertype;
kind:=reg;
regno:=i;
sameregister:=nil;
storetmp(pseudotop);
address^:=addr;
addr.simpleaddr:=false;
addr.postordinal:=0;
addr.reference:=address;
end;
end;
neststackÆndepthÅ.withvar:=pseudotop;
end;
ewithdo:; (* nothing is done *)
ewithname:
begin
pseudo:=newpseudo;
pseudo^:=neststackÆgetnumberÅ.withvar^;
(* take a copy of the addressnode, in case of notsimple with *)
(* ... see returnpseudo,returnaddress ... *)
if not pseudo^.addr.simpleaddr then
  begin
  address := newaddress;
  address^ := pseudo^.addr.reference^;
  pseudo^.addr.reference := address;
  end; (* at most one level of address nodes ! *)
pseudo^.next:=pseudotop;
pseudo^.kind:=variable;
pseudotop:=pseudo;
end;
eendwith:
begin
ndepth:=getnumber+1;
while neststackÆndepthÅ.withvar <> pseudotop do
begin
returnpseudo(pseudotop);
end;
returnpseudo(pseudotop);
end;
ecallproc:
begin
pushnest;
with neststackÆndepthÅ do
begin
procfunc:=getsymbptr;
oldtop:=pseudotop;
end;
paramoffset:=blockmark-oneword;
end;
ecallfunc:
begin
pushnest;
s:=getsymbptr;
neststackÆndepthÅ.procfunc:=s;
pseudo:=newpseudo;
with pseudo^ do
begin
next:=pseudotop;
kind:=procfunc;
symb:=s;
if s^.namekind = efunc then typ:=s^.functype
else typ:=s^.vartypedescr;
end;
pseudotop:=pseudo;
end;
eparam:
begin
ndepth:=getnumber;
i:=getnumber;
with neststackÆndepthÅ.procfunc^ do
begin
if standard then s:=nil
else s:=getsymbptr;
case namekind of
eproc:
if  not standard then
begin
actualparam(s,pseudotop);
returnpseudo(pseudotop);
end;
efproc:
begin
actualparam(nil,pseudotop);
returnpseudo(pseudotop);
end;
effunc,
efunc:
newtop(eparam,s,pseudotop^.next,pseudotop);
end;
end;
end;
eformat:
begin
ndepth:=getnumber;
if getnumber = 1 then newtop(eformat,nil,pseudotop,nil)
else newtop(eformat,nil,pseudotop^.next,pseudotop);
end;
eendcall:
begin
ndepth:=getnumber;
with neststackÆndepthÅ.procfunc^ do
case namekind of
eproc:begin
paramoffset:=-oneword;
if standard then standardprocedure
else
begin
storeregisters(nil);
makeindexcode(al,1,stackaddr,display);
makecode(al,0,routinedescr);
callroutine;
end;
end;
efproc: begin
storeregisters(nil);
loadformal(varaddr);
paramoffset:=-oneword;
callroutine;
end;
effunc,
efunc: begin
pseudo:=pseudotop;
newtop(eendcall,nil,pseudotop,nil);
ps:=nil;
while pseudo^.kind <> procfunc do
begin
leftps:=pseudo^.leftoperand;
pseudo^.leftoperand:=ps;
ps:=pseudo;
pseudo:=leftps;
end;
pseudotop^.leftoperand:=ps;
pseudotop^.rightoperand:=pseudo;
if namekind = efunc then
if functype = nil then
pseudotop^.typ := ps^.rightoperand^.typ (* some standard functions with parameter dependent
type, e.g. succ, pred, sqr, abs, ... *)
else
pseudotop^.typ := functype
else pseudotop^.typ:=vartypedescr;
end;
end;
end;

elinenumber:
begin
read(currentline);
if lineoutput then
begin
linetablelgt:=linetablelgt+1;
linetable^:=lastindex*oneword;
put(linetable);
end;
end;
eoption:
begin
get(input);
if input^='t' then
begin
get(input);
check:=input^='+';
alwayscheck := check;
end
else
if input^='r' then
begin
get(input);
resident:=input^='+'
end
else if input^ = 'c' then
begin
get(input);
slangmode := input^ = '+';

end;
end;
end; (* CASE intermitword OF *)
nextline;
end; (* WHILE intermitword <> eendprogram DO ... *)
routinedescriptorwords;
if compilertest then comptestoutput;
9999:
if errorcount > 0 then printerrors;
close(input);
end.
.  ▶EOF◀
DataMuseum.dk

RC4000/8000/9000

⟦b472dd200⟧ TextFile

Derivation

TextFile
