3402 lines
101 KiB
OpenEdge ABL
3402 lines
101 KiB
OpenEdge ABL
#include <em_spec.h>
|
|
#include <em_pseu.h>
|
|
#include <em_mnem.h>
|
|
#include <em_mes.h>
|
|
#include <em_reg.h>
|
|
#include <pc_size.h>
|
|
|
|
{
|
|
(c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
|
|
|
|
This product is part of the Amsterdam Compiler Kit.
|
|
|
|
Permission to use, sell, duplicate or disclose this software must be
|
|
obtained in writing. Requests for such permissions may be sent to
|
|
|
|
Dr. Andrew S. Tanenbaum
|
|
Wiskundig Seminarium
|
|
Vrije Universiteit
|
|
Postbox 7161
|
|
1007 MC Amsterdam
|
|
The Netherlands
|
|
|
|
}
|
|
|
|
{if next line is included the compiler itself is written in standard pascal}
|
|
{#define STANDARD 1}
|
|
|
|
{if next line is included, the compiler won't generate static exchanges}
|
|
{#define NO_EXC 1}
|
|
|
|
{Author: Johan Stevenson Version: 32}
|
|
{$l- : no source line numbers}
|
|
{$r- : no subrange checking}
|
|
{$a- : no assertion checking}
|
|
#ifdef STANDARD
|
|
{$s+ : test conformancy to standard}
|
|
#endif
|
|
|
|
program pem(input,em,errors);
|
|
{/*
|
|
This Pascal compiler produces EM code as described in
|
|
- A.S.Tanenbaum, J.W.Stevenson & H. van Staveren,
|
|
"Description of a machine architecture for use with
|
|
block structured languages" Informatika rapport 81.
|
|
NOTE: this version is modified to produce the modified EM code of
|
|
januari 1981. it is not possible, using this compiler, to
|
|
generate code for machines with 1 byte wordsize.
|
|
NOTE: this version is modified by Kees Visser in such a way that
|
|
the compiler can now run on 2 and 4 byte machines. It is also
|
|
able to generate em-code for a 2 bytes machine while running
|
|
on a 4-bytes machine. Cross-compilation from a 2 bytes to a
|
|
four bytes machine is also possible with the following
|
|
exception: large integers that don't fit in an integer of
|
|
the compiler are treated like longs and are thus not allowed
|
|
in types.
|
|
|
|
A description of Pascal is given in
|
|
- K.Jensen & N.Wirth, "PASCAL user manual and report", Springer-Verlag.
|
|
Several options may be given in the normal pascal way. Moreover,
|
|
a positive number may be used instead of + and -. The options are:
|
|
a: interpret assertions (+)
|
|
c: C-type strings allowed (-)
|
|
d: type long may be used (-)
|
|
i: controls the number of elements in integer sets
|
|
default: (wordsize in bits)
|
|
l: insert code to keep track of source lines (+)
|
|
o: optimize (+)
|
|
r: check subranges (+)
|
|
s: accept only standard pascal programs (-)
|
|
t: trace procedure entry and exit (-)
|
|
u: treat '_' as letter (-)
|
|
*/}
|
|
{===================================================================}
|
|
#ifdef STANDARD
|
|
label 9999;
|
|
#endif
|
|
|
|
const
|
|
{fundamental constants}
|
|
MB1 = 7;
|
|
NB1 = 8;
|
|
MI1 = 127;
|
|
NI1 = 128;
|
|
MI2 = 32767;
|
|
MU1 = 255;
|
|
NU1 = 256;
|
|
|
|
{string constants}
|
|
imax = 10;
|
|
max2bytes = '0000032767';
|
|
max4bytes = '2147483647';
|
|
|
|
#if EM_WSIZE == 4
|
|
{this can only be compiled with a compiler that has integer size 4}
|
|
MU2 = 65535;
|
|
NU2 = 65536;
|
|
|
|
{characteristics of the machine on which the compiler will run}
|
|
{wordsize and integer size are 4}
|
|
MI = 2147483647;
|
|
maxcompintstring = max4bytes;
|
|
#endif
|
|
#if EM_WSIZE == 2
|
|
MU2 = 0; {not used}
|
|
NU2 = 0; {not used}
|
|
|
|
MI = MI2;
|
|
maxcompintstring = max2bytes;
|
|
#endif
|
|
#if EM_WSIZE != 2 && EM_WSIZE != 4
|
|
Something wrong here!
|
|
#endif
|
|
|
|
{maximal indices}
|
|
idmax = 8;
|
|
fnmax = 14;
|
|
smax = 72;
|
|
|
|
{opt values}
|
|
off = 0;
|
|
on = 1;
|
|
|
|
{for push and pop: }
|
|
global = false;
|
|
local = true;
|
|
|
|
{for sizeof and posaddr: }
|
|
wordmult = false;
|
|
wordpart = true;
|
|
|
|
{ASCII characters}
|
|
ascht = 9;
|
|
ascnl = 10;
|
|
ascvt = 11;
|
|
ascff = 12;
|
|
asccr = 13;
|
|
|
|
{miscellaneous}
|
|
maxcharord = 127; {maximal ordinal number of chars}
|
|
maxargc = 13; {maximal index in argv}
|
|
rwlim = 34; {number of reserved words}
|
|
spaces = ' ';
|
|
|
|
{-------------------------------------------------------------------}
|
|
type
|
|
{scalar types}
|
|
symbol= (comma,semicolon,colon1,colon2,notsy,lbrack,ident,
|
|
intcst,charcst,realcst,longcst,stringcst,nilcst,minsy,
|
|
plussy,lparent,arrow,arraysy,recordsy,setsy,filesy,
|
|
packedsy,progsy,labelsy,constsy,typesy,varsy,procsy,
|
|
funcsy,beginsy,gotosy,ifsy,whilesy,repeatsy,forsy,
|
|
withsy,casesy,becomes,starsy,divsy,modsy,slashsy,
|
|
andsy,orsy,eqsy,nesy,gtsy,gesy,ltsy,
|
|
lesy,insy,endsy,elsesy,untilsy,ofsy,dosy,
|
|
downtosy,tosy,thensy,rbrack,rparent,period
|
|
); {the order is important}
|
|
chartype= (lower,upper,digit,layout,tabch,
|
|
quotech,dquotech,colonch,periodch,lessch,
|
|
greaterch,lparentch,lbracech,
|
|
{different entries}
|
|
rparentch,lbrackch,rbrackch,commach,semich,arrowch,
|
|
plusch,minch,slash,star,equal,
|
|
{also symbols}
|
|
others
|
|
);
|
|
standpf= (pread,preadln,pwrite,pwriteln,pput,pget,
|
|
preset,prewrite,pnew,pdispose,ppack,punpack,
|
|
pmark,prelease,ppage,phalt,
|
|
{all procedures}
|
|
feof,feoln,fabs,fsqr,ford,fchr,fpred,fsucc,fodd,
|
|
ftrunc,fround,fsin,fcos,fexp,fsqt,flog,fatn
|
|
{all functions}
|
|
); {the order is important}
|
|
libmnem= (ELN ,EFL ,CLS ,WDW , {input and output}
|
|
OPN ,GETX,RDI ,RDC ,RDR ,RDL ,RLN ,
|
|
{on inputfiles}
|
|
CRE ,PUTX,WRI ,WSI ,WRC ,WSC ,WRS ,WSS ,WRB ,
|
|
WSB ,WRR ,WSR ,WRL, WSL, WRF ,WRZ ,WSZ ,WLN ,PAG ,
|
|
{on outputfiles, order important}
|
|
ABR ,RND ,SINX,COSX,EXPX,SQT ,LOG ,ATN ,
|
|
{floating point}
|
|
ABI ,ABL ,BCP ,BTS ,NEWX,SAV ,RST ,INI ,HLT ,
|
|
ASS ,GTO ,PAC ,UNP, DIS, ASZ, MDI, MDL
|
|
{miscellaneous}
|
|
);
|
|
structform= (scalar,subrange,pointer,power,files,arrays,carray,
|
|
records,variant,tag); {order important}
|
|
structflag= (spack,withfile);
|
|
identflag= (refer,used,assigned,noreg,loopvar,samesect);
|
|
idclass= (types,konst,vars,field,carrbnd,proc,func);
|
|
kindofpf= (standard,formal,actual,extern,varargs,forward);
|
|
where= (blck,rec,wrec);
|
|
attrkind= (cst,fixed,pfixed,loaded,ploaded,indexed);
|
|
twostruct= (eq,subeq,ir,ri,il,li,lr,rl,es,se,noteq); {order important}
|
|
|
|
{subrange types}
|
|
rwrange= 0..rwlim;
|
|
byte= 0..MU1;
|
|
|
|
{pointer types}
|
|
sp= ^structure;
|
|
ip= ^identifier;
|
|
lp= ^labl;
|
|
bp= ^blockinfo;
|
|
np= ^nameinfo;
|
|
#ifdef NO_EXC
|
|
mp= ^mmark;
|
|
op= ^outrec;
|
|
#endif NO_EXC
|
|
|
|
{set types}
|
|
sos= set of symbol;
|
|
setofids= set of idclass;
|
|
formset= set of structform;
|
|
sflagset= set of structflag;
|
|
iflagset= set of identflag;
|
|
|
|
{array types}
|
|
idarr=packed array[1..idmax] of char;
|
|
fnarr=packed array[1..fnmax] of char;
|
|
|
|
{record types}
|
|
position=record {the addr info of certain variable}
|
|
ad:integer; {for locals it is the byte offset}
|
|
lv:integer; {the level of the beast}
|
|
end;
|
|
|
|
{records of type attr are used to remember qualities of
|
|
expression parts to delay the loading of them.
|
|
Reasons to delay the loading of one word constants:
|
|
- bound checking
|
|
- set building.
|
|
Reasons to delay the loading of direct accessible objects:
|
|
- efficient handling of read/write
|
|
- efficient handling of the with statement.
|
|
}
|
|
attr=record
|
|
asp:sp; {type of expression}
|
|
packbit:boolean; {true for part of packed structure}
|
|
ak:attrkind; {access method}
|
|
pos:position; {lv and ad}
|
|
{If ak=cst then the value is stored in ad}
|
|
end;
|
|
|
|
nameinfo=record {one for each separate name space}
|
|
nlink:np; {one deeper}
|
|
fname:ip; {first name: root of tree}
|
|
case occur:where of
|
|
blck:();
|
|
rec: ();
|
|
wrec:(wa:attr) {name space opened by with statement}
|
|
end;
|
|
|
|
blockinfo=record {all info of the current procedure}
|
|
nextbp:bp; {pointer to blockinfo of surrounding proc}
|
|
reglb:integer; {data location counter (from begin of proc) }
|
|
minlb:integer; {keeps track of minimum of reglb}
|
|
ilbno:integer; {number of last local label}
|
|
forwcount:integer; {number of not yet specified forward procs}
|
|
lchain:lp; {first label: header of chain}
|
|
end;
|
|
|
|
structure=record
|
|
size:integer; {size of structure in bytes}
|
|
sflag:sflagset; {flag bits}
|
|
case form:structform of
|
|
scalar :(scalno:integer; {number of range descriptor}
|
|
fconst:ip {names of constants}
|
|
);
|
|
subrange:(min,max:integer; {lower and upper bound}
|
|
rangetype:sp; {type of bounds}
|
|
subrno:integer {number of subr descriptor}
|
|
);
|
|
pointer :(eltype:sp); {type of pointed object}
|
|
power :(elset:sp); {type of set elements}
|
|
files :(filtype:sp); {type of file elements}
|
|
arrays,carray:
|
|
(aeltype:sp; {type of array elements}
|
|
inxtype:sp; {type of array index}
|
|
arpos:position {position of array descriptor}
|
|
);
|
|
records :(fstfld:ip; {points to first field}
|
|
tagsp:sp {points to tag if present}
|
|
);
|
|
variant :(varval:integer; {tag value for this variant}
|
|
nxtvar:sp; {next equilevel variant}
|
|
subtsp:sp {points to tag for sub-case}
|
|
);
|
|
tag :(fstvar:sp; {first variant of case}
|
|
tfldsp:sp {type of tag}
|
|
)
|
|
end;
|
|
|
|
identifier=record
|
|
idtype:sp; {type of identifier}
|
|
name:idarr; {name of identifier}
|
|
llink,rlink:ip; {see enterid,searchid}
|
|
next:ip; {used to make several chains}
|
|
iflag:iflagset; {several flag bits}
|
|
case klass:idclass of
|
|
types :();
|
|
konst :(value:integer); {for integers the value is
|
|
computed and stored in this field.
|
|
For strings and reals an assembler constant is
|
|
defined labeled '.1', '.2', ... This '.' number is then
|
|
stored in value. For reals value may be negated to
|
|
indicate that the opposite of the assembler constant
|
|
is needed. }
|
|
vars :(vpos:position); {position of var}
|
|
field :(foffset:integer); {offset to begin of record}
|
|
carrbnd :(); {idtype points to carray struct}
|
|
proc,func:
|
|
(case pfkind:kindofpf of
|
|
standard:(key:standpf); {identification}
|
|
formal,actual,forward,extern,varargs:
|
|
(pfpos:position; {lv gives declaration level.
|
|
ad is relevant for formal pf s and for
|
|
functions (no conflict!!).
|
|
for functions: ad is the result address.
|
|
for formal pf s: ad is the address of the
|
|
descriptor }
|
|
pfno:integer; {unique pf number}
|
|
maxlb:integer; {bytes of parameters}
|
|
parhead:ip {head of parameter list}
|
|
)
|
|
)
|
|
end;
|
|
|
|
labl=record
|
|
nextlp:lp; {chain of labels}
|
|
seen:boolean;
|
|
labval:integer; {label number given by the programmer}
|
|
labname:integer; {label number given by the compiler}
|
|
labdlb:integer {zero means only locally used,
|
|
otherwise dlbno of label information}
|
|
end;
|
|
|
|
#ifdef NO_EXC
|
|
outrec=record
|
|
next:op; {chain of records}
|
|
bytes:array[1..16] of byte;
|
|
cnt:0..16;
|
|
end;
|
|
|
|
mmark=record
|
|
next:mp; {chain of marks}
|
|
count,where:integer;
|
|
end;
|
|
#endif NO_EXC
|
|
{-------------------------------------------------------------------}
|
|
var {the most frequent used externals are declared first}
|
|
sy:symbol; {last symbol}
|
|
a:attr; {type,access method,position,value of expr}
|
|
{returned by insym}
|
|
ch:char; {last character}
|
|
chsy:chartype; {type of ch, used by insym}
|
|
val:integer; {if last symbol is an constant }
|
|
ix:integer; {string length}
|
|
eol:boolean; {true of current ch is a space, replacing a newline}
|
|
zerostring:boolean; {true for strings in " "}
|
|
id:idarr; {if last symbol is an identifier}
|
|
{some counters}
|
|
lino:integer; {line number on code file (1..n) }
|
|
dlbno:integer; {number of last global number}
|
|
holeb:integer; {size of hol-area}
|
|
level:integer; {current static level}
|
|
argc:integer; {index in argv}
|
|
lastpfno:integer; {unique pf number counter}
|
|
copt:integer; {C-type strings allowed if on}
|
|
dopt:integer; {longs allowed if on}
|
|
iopt:integer; {number of bits in sets with base integer}
|
|
sopt:integer; {standard option}
|
|
srcchno:integer; {column count for errors}
|
|
srclino:integer; {source line number after preprocessing}
|
|
srcorig:integer; {source line number before preprocessing}
|
|
fildlb:integer; {label number of source string}
|
|
{pointers pointing to standard types}
|
|
realptr,intptr,textptr,nullset,boolptr:sp;
|
|
charptr,nilptr,zeroptr,procptr,longptr:sp;
|
|
{flags}
|
|
giveline:boolean; {give source line number at next statement}
|
|
including:boolean; {no LINs for included code}
|
|
eofexpected:boolean; {quit without error if true (nextch) }
|
|
main:boolean; {complete programme or a module}
|
|
intypedec:boolean; {true if nested in typedefinition}
|
|
fltused:boolean; {true if floating point instructions are used}
|
|
seconddot:boolean; {indicates the second dot of '..'}
|
|
{pointers}
|
|
fwptr:ip; {head of chain of forward reference pointers}
|
|
progp:ip; {program identifier}
|
|
currproc:ip; {current procedure/function ip (see selector)}
|
|
top:np; {pointer to the most recent name space}
|
|
lastnp:np; {pointer to nameinfo of last searched ident }
|
|
{records}
|
|
b:blockinfo; {all info to be stacked at pfdeclaration}
|
|
fa:attr; {attr for current file name}
|
|
{arrays}
|
|
sizes:array[0 .. sz_last] of integer;
|
|
maxintstring,maxlongstring:packed array[1..imax] of char;
|
|
strbuf:array[1..smax] of char;
|
|
rw:array[rwrange] of idarr;
|
|
{reserved words}
|
|
frw:array[0..idmax] of integer;
|
|
{indices in rw}
|
|
rsy:array[rwrange] of symbol;
|
|
{symbol for reserved words}
|
|
cs:array[char] of chartype;
|
|
{chartype of a character}
|
|
csy:array[rparentch..equal] of symbol;
|
|
{symbol for single character symbols}
|
|
lmn:array[libmnem] of packed array[1..4] of char;
|
|
{mnemonics of pascal library routines}
|
|
opt:array['a'..'z'] of integer;
|
|
forceopt:array['a'..'z'] of boolean;
|
|
{26 different options}
|
|
undefip:array[idclass] of ip;
|
|
{used in searchid}
|
|
iop:array[boolean] of ip;
|
|
{false:standard input, true:standard output}
|
|
argv:array[0..maxargc] of
|
|
record name:idarr; ad:integer end;
|
|
{save here the external heading names}
|
|
{files}
|
|
em:file of byte; {the EM code}
|
|
errors:text; {the compilation errors}
|
|
source:fnarr;
|
|
#ifdef NO_EXC
|
|
ohead: op; {head of outrec list}
|
|
mhead: mp; {head of marks list}
|
|
bcnt: integer;
|
|
#define newmark setmark
|
|
#define relmark(xx) freemark(xx)
|
|
#else not NO_EXC
|
|
#define newmark lino
|
|
#define relmark(xx)
|
|
#endif NO_EXC
|
|
|
|
{===================================================================}
|
|
|
|
procedure initpos(var p:position);
|
|
begin p.lv:=level; p.ad:=0; end;
|
|
|
|
procedure inita(fsp:sp; fad:integer);
|
|
begin with a do begin
|
|
asp:=fsp; packbit:=false; ak:=fixed; pos.ad:=fad; pos.lv:=level;
|
|
end end;
|
|
|
|
function newip(kl:idclass; n:idarr; idt:sp; nxt:ip):ip;
|
|
var p:ip; f:iflagset;
|
|
begin f:=[];
|
|
case kl of
|
|
types,carrbnd: {similar structure}
|
|
new(p,types);
|
|
konst:
|
|
begin new(p,konst); p^.value:=0 end;
|
|
vars:
|
|
begin new(p,vars); f:=[used,assigned]; initpos(p^.vpos) end;
|
|
field:
|
|
begin new(p,field); p^.foffset:=0 end;
|
|
proc,func: {same structure}
|
|
begin new(p,proc,actual); p^.pfkind:=actual;
|
|
initpos(p^.pfpos); p^.pfno:=0; p^.maxlb:=0; p^.parhead:=nil;
|
|
end
|
|
end;
|
|
p^.name:=n; p^.klass:=kl; p^.idtype:=idt; p^.next:=nxt;
|
|
p^.llink:=nil; p^.rlink:=nil; p^.iflag:=f; newip:=p
|
|
end;
|
|
|
|
function newsp(sf:structform; sz:integer):sp;
|
|
var p:sp; sflag:sflagset;
|
|
begin sflag:=[];
|
|
case sf of
|
|
scalar:
|
|
begin new(p,scalar); p^.scalno:=0; p^.fconst:=nil end;
|
|
subrange:
|
|
new(p,subrange);
|
|
pointer:
|
|
begin new(p,pointer); p^.eltype:=nil end;
|
|
power:
|
|
new(p,power);
|
|
files:
|
|
begin new(p,files); sflag:=[withfile] end;
|
|
arrays,carray: {same structure}
|
|
new(p,arrays);
|
|
records:
|
|
new(p,records);
|
|
variant:
|
|
new(p,variant);
|
|
tag:
|
|
new(p,tag);
|
|
end;
|
|
p^.form:=sf; p^.size:=sz; p^.sflag:=sflag; newsp:=p;
|
|
end;
|
|
|
|
function sizeof(fsp:sp; partword:boolean):integer;
|
|
var s:integer;
|
|
begin if fsp=nil then s:=0 else s:=fsp^.size;
|
|
if s<>0 then
|
|
if partword and (s<sz_word) then
|
|
while sz_word mod s <> 0 do s:=s+1
|
|
else
|
|
while s mod sz_word <> 0 do s:=s+1;
|
|
sizeof:=s
|
|
end;
|
|
|
|
function formof(fsp:sp; forms:formset):boolean;
|
|
begin if fsp=nil then formof:=false else formof:=fsp^.form in forms end;
|
|
|
|
{===================================================================}
|
|
|
|
#ifdef NO_EXC
|
|
procedure newoutrec;
|
|
var p:op;
|
|
begin
|
|
new(p);
|
|
bcnt := bcnt+1;
|
|
with p^ do begin cnt := 0; next := ohead end;
|
|
ohead := p
|
|
end;
|
|
|
|
procedure put1(b:byte);
|
|
begin
|
|
if mhead = nil then write(em,b)
|
|
else begin
|
|
if ohead^.cnt = 16 then newoutrec;
|
|
with ohead^ do
|
|
begin cnt := cnt + 1; bytes[cnt] := b end
|
|
end
|
|
end;
|
|
#else not NO_EXC
|
|
procedure put1(b:byte);
|
|
begin write(em,b) end;
|
|
#endif NO_EXC
|
|
|
|
procedure put2(i:integer);
|
|
var i1,i2:byte;
|
|
begin
|
|
if i<0 then
|
|
begin i:=-(i+1); i1:=MU1 - i mod NU1; i2:=MU1 - i div NU1 end
|
|
else
|
|
begin i1:=i mod NU1; i2:=i div NU1 end;
|
|
put1(i1); put1(i2)
|
|
end;
|
|
|
|
#if EM_WSIZE == 4
|
|
procedure put4(i:integer);
|
|
var i1,i2:integer;
|
|
begin
|
|
if i<0 then
|
|
begin i:=-(i+1); i1:=MU2 - i mod NU2; i2:=MU2 - i div NU2 end
|
|
else
|
|
begin i1:=i mod NU2; i2:=i div NU2 end;
|
|
put1(i1 mod NU1); put1(i1 div NU1);
|
|
put1(i2 mod NU1); put1(i2 div NU1)
|
|
end;
|
|
#endif
|
|
|
|
procedure argend;
|
|
begin put1(sp_cend) end;
|
|
|
|
procedure argcst(i:integer);
|
|
begin
|
|
if (i >= -sp_zcst0) and (i < sp_ncst0-sp_zcst0) then
|
|
put1(i + sp_zcst0 + sp_fcst0)
|
|
else
|
|
#if EM_WSIZE == 4
|
|
if (i >= -MI2-1) and (i <= MI2) then
|
|
#endif
|
|
begin put1(sp_cst2); put2(i) end
|
|
#if EM_WSIZE == 4
|
|
else begin put1(sp_cst4); put4(i) end
|
|
#endif
|
|
end;
|
|
|
|
procedure argnil;
|
|
begin put1(sp_icon); argcst(sz_addr); argcst(1); put1(ord('0')) end;
|
|
|
|
procedure argilb(i:integer);
|
|
begin
|
|
if i<=MU1 then
|
|
begin put1(sp_ilb1); put1(i) end
|
|
else
|
|
begin put1(sp_ilb2); put2(i) end
|
|
end;
|
|
|
|
procedure argdlb(i:integer);
|
|
begin
|
|
if i<=MU1 then
|
|
begin put1(sp_dlb1); put1(i) end
|
|
else
|
|
begin put1(sp_dlb2); put2(i) end
|
|
end;
|
|
|
|
procedure argident(var a:idarr);
|
|
var i,j:integer;
|
|
begin i:=idmax;
|
|
while (a[i]=' ') and (i>1) do i:=i-1;
|
|
put1(sp_pnam); argcst(i);
|
|
for j:=1 to i do put1(ord(a[j]))
|
|
end;
|
|
|
|
procedure genop(b:byte);
|
|
begin put1(b); lino:=lino+1 end;
|
|
|
|
procedure gencst(b:byte; i:integer);
|
|
begin genop(b); argcst(i) end;
|
|
|
|
procedure gensp(m:libmnem; s:integer);
|
|
var i:integer;
|
|
begin genop(op_cal); put1(sp_pnam); argcst(4);
|
|
for i:=1 to 4 do put1(ord(lmn[m][i]));
|
|
gencst(op_asp,s)
|
|
end;
|
|
|
|
procedure genpnam(b:byte; fip:ip);
|
|
var n:idarr; i,j:integer;
|
|
begin
|
|
if fip^.pfpos.lv<=1 then n:=fip^.name else
|
|
begin n:='_ '; j:=1; i:=fip^.pfno;
|
|
while i<>0 do
|
|
begin j:=j+1; n[j]:=chr(i mod 10 + ord('0')); i:=i div 10 end;
|
|
end;
|
|
genop(b); argident(n)
|
|
end;
|
|
|
|
procedure genasp(m:byte);
|
|
begin gencst(m,sizeof(a.asp,wordmult)) end;
|
|
|
|
procedure genlin;
|
|
begin giveline:=false;
|
|
if opt['l']<>off then if main then gencst(op_lin,srcorig)
|
|
end;
|
|
|
|
procedure genreg(sz,ad,regval:integer);
|
|
begin gencst(ps_mes,ms_reg);
|
|
argcst(ad); argcst(sz); argcst(regval); argend
|
|
end;
|
|
|
|
procedure laedlb(d:integer);
|
|
begin genop(op_lae); argdlb(d) end;
|
|
|
|
#ifdef NO_EXC
|
|
procedure reloutrec;
|
|
var i,j,k:integer;
|
|
q, r, p:op;
|
|
m : mp;
|
|
begin p := ohead; q := p;
|
|
if mhead <> nil then
|
|
begin
|
|
m := mhead; while m^.next <> nil do m := m^.next;
|
|
k := (bcnt - m^.where) + 1
|
|
end
|
|
else begin k := 0; ohead := nil; bcnt := 0 end;
|
|
for i := 1 to k do begin q := p; p := p^.next end;
|
|
if q <> p then q^.next := nil;
|
|
if p <> nil then
|
|
begin r := nil;
|
|
while p <> nil do
|
|
begin q := p^.next; p^.next := r; r := p; p := q end;
|
|
while r <> nil do with r^ do
|
|
begin
|
|
for j := 1 to cnt do write(em, bytes[j]);
|
|
r := next
|
|
end
|
|
end
|
|
end;
|
|
|
|
function setmark:integer;
|
|
var p:mp; nm:boolean;
|
|
begin nm := false;
|
|
if mhead <> nil then with mhead^ do
|
|
if (where = bcnt) and (ohead^.cnt = 0) then
|
|
begin count := count + 1; nm := true end;
|
|
if not nm then
|
|
begin new(p); newoutrec;
|
|
with p^ do
|
|
begin where := bcnt; count := 1; next := mhead end;
|
|
mhead := p;
|
|
end;
|
|
setmark := bcnt
|
|
end;
|
|
|
|
procedure freemark(m : integer);
|
|
var p, q : mp;
|
|
begin assert(mhead <> nil); p := mhead; q := p;
|
|
while p^.where <> m do
|
|
begin q := p; p := p^.next; assert(p <> nil) end;
|
|
with p^ do
|
|
begin assert(count > 0); count := count - 1; if count = 0 then
|
|
begin
|
|
if p = mhead then begin mhead := next; reloutrec end
|
|
else q^.next := next
|
|
end
|
|
end end;
|
|
|
|
procedure exchange(n,m:integer);
|
|
var i:integer;
|
|
p,q,r:op;
|
|
begin assert(m >= n);
|
|
if n <> m then
|
|
begin
|
|
p := ohead;
|
|
for i := bcnt downto m+1 do p := p^.next;
|
|
q := p;
|
|
for i := m downto n+1 do q := q^.next;
|
|
r := ohead; ohead := p^.next; p^.next := q^.next; q^.next := r
|
|
end
|
|
end;
|
|
#else not NO_EXC
|
|
procedure exchange(l1,l2:integer);
|
|
var d1,d2:integer;
|
|
begin d1:=l2-l1; d2:=lino-l2;
|
|
if (d1<>0) and (d2<>0) then
|
|
begin gencst(ps_exc,d1); argcst(d2) end
|
|
end;
|
|
#endif NO_EXC
|
|
|
|
procedure newilb(i:integer);
|
|
begin lino:=lino+1;
|
|
if i<sp_nilb0 then put1(i+sp_filb0) else argilb(i)
|
|
end;
|
|
|
|
function newdlb:integer;
|
|
begin lino:=lino+1; dlbno:=dlbno+1; argdlb(dlbno); newdlb:=dlbno end;
|
|
|
|
function romstr(typ:byte; siz:integer):integer;
|
|
var i:integer;
|
|
begin romstr:=newdlb; genop(ps_rom);
|
|
put1(typ); if typ<>sp_scon then argcst(siz); argcst(ix);
|
|
for i:=1 to ix do put1(ord(strbuf[i])); argend
|
|
end;
|
|
|
|
{===================================================================}
|
|
|
|
procedure error(err:integer);
|
|
{as you will notice, all error numbers are preceded by '+' and '0' to
|
|
ease their renumbering in case of new errornumbers.
|
|
}
|
|
begin writeln(errors,err,srclino,srcchno);
|
|
if err>0 then begin gencst(ps_mes,ms_err); argend end
|
|
end;
|
|
|
|
procedure errid(err:integer; var id:idarr);
|
|
begin write(errors,'''',id); error(err) end;
|
|
|
|
procedure errint(err:integer; i:integer);
|
|
begin write(errors,i:1); error(err) end;
|
|
|
|
procedure errasp(err:integer);
|
|
begin if a.asp<>nil then begin error(err); a.asp:=nil end end;
|
|
|
|
procedure teststandard;
|
|
begin if sopt<>off then error(-(+01)) end;
|
|
|
|
procedure enterid(fip: ip);
|
|
{enter id pointed at by fip into the name-table,
|
|
which on each declaration level is organised as
|
|
an unbalanced binary tree}
|
|
var nam:idarr; lip,lip1:ip; lleft,again:boolean;
|
|
begin nam:=fip^.name; again:=false; assert nam[1]<>' ';
|
|
lip:=top^.fname;
|
|
if lip=nil then top^.fname:=fip else
|
|
begin
|
|
repeat lip1:=lip;
|
|
if lip^.name>nam then
|
|
begin lip:=lip^.llink; lleft:=true end
|
|
else
|
|
begin if lip^.name=nam then again:=true; {name conflict}
|
|
lip:=lip^.rlink; lleft:=false;
|
|
end;
|
|
until lip=nil;
|
|
if lleft then lip1^.llink:=fip else lip1^.rlink:=fip
|
|
end;
|
|
fip^.llink:=nil; fip^.rlink:=nil;
|
|
if again then errid(+02,nam);
|
|
end;
|
|
|
|
{===================================================================}
|
|
|
|
procedure trace(tname:idarr; fip:ip; var namdlb:integer);
|
|
var i:integer;
|
|
begin
|
|
if opt['t']<>off then
|
|
begin
|
|
if namdlb=0 then
|
|
begin namdlb:=newdlb; genop(ps_rom); put1(sp_scon); argcst(8);
|
|
for i:=1 to 8 do put1(ord(fip^.name[i])); argend;
|
|
end;
|
|
laedlb(namdlb); genop(op_cal); argident(tname);
|
|
gencst(op_asp,sz_addr);
|
|
end;
|
|
end;
|
|
|
|
procedure expandnullset(fsp:sp);
|
|
var s:integer;
|
|
begin s:=sizeof(fsp,wordmult)-sz_word;
|
|
if s<>0 then gencst(op_zer,s); a.asp:=fsp
|
|
end;
|
|
|
|
procedure push(local:boolean; ad:integer; sz:integer);
|
|
begin assert sz mod sz_word = 0;
|
|
if sz=sz_word then
|
|
if local then gencst(op_lol,ad) else gencst(op_loe,ad)
|
|
else if sz=2*sz_word then
|
|
if local then gencst(op_ldl,ad) else gencst(op_lde,ad)
|
|
else
|
|
begin if local then gencst(op_lal,ad) else gencst(op_lae,ad);
|
|
gencst(op_loi,sz)
|
|
end
|
|
end;
|
|
|
|
procedure pop(local:boolean; ad:integer; sz:integer);
|
|
begin assert sz mod sz_word = 0;
|
|
if sz=sz_word then
|
|
if local then gencst(op_stl,ad) else gencst(op_ste,ad)
|
|
else if sz=2*sz_word then
|
|
if local then gencst(op_sdl,ad) else gencst(op_sde,ad)
|
|
else
|
|
begin if local then gencst(op_lal,ad) else gencst(op_lae,ad);
|
|
gencst(op_sti,sz)
|
|
end
|
|
end;
|
|
|
|
procedure lexaddr(lv:integer; ad:integer);
|
|
begin assert level>=lv;
|
|
if ad>=0 then gencst(op_lxa,level-lv) else gencst(op_lxl,level-lv);
|
|
gencst(op_adp,ad)
|
|
end;
|
|
|
|
procedure loadpos(var p:position; sz:integer);
|
|
begin with p do
|
|
if lv<=0 then push(global,ad,sz) else
|
|
if lv=level then push(local,ad,sz) else
|
|
begin lexaddr(lv,ad); gencst(op_loi,sz) end;
|
|
end;
|
|
|
|
procedure descraddr(var p:position);
|
|
begin if p.lv=0 then laedlb(p.ad) else loadpos(p,sz_addr) end;
|
|
|
|
procedure loadaddr;
|
|
begin with a,pos do begin
|
|
case ak of
|
|
fixed:
|
|
if lv<=0 then gencst(op_lae,ad) else
|
|
if lv=level then gencst(op_lal,ad) else lexaddr(lv,ad);
|
|
pfixed:
|
|
loadpos(pos,sz_addr);
|
|
ploaded:
|
|
;
|
|
indexed:
|
|
gencst(op_aar,sz_word);
|
|
end; {case}
|
|
ak:=ploaded;
|
|
end end;
|
|
|
|
procedure load;
|
|
var sz:integer;
|
|
begin with a do begin sz:=sizeof(asp,packbit);
|
|
if asp<>nil then begin
|
|
case ak of
|
|
cst:
|
|
gencst(op_loc,pos.ad); {only one-word scalars}
|
|
fixed:
|
|
loadpos(pos,sz);
|
|
pfixed:
|
|
begin loadpos(pos,sz_addr); gencst(op_loi,sz) end;
|
|
loaded:
|
|
;
|
|
ploaded:
|
|
gencst(op_loi,sz);
|
|
indexed:
|
|
gencst(op_lar,sz_word);
|
|
end; {case}
|
|
if asp^.form = subrange then
|
|
if sz < sz_word then
|
|
if asp^.min < 0 then
|
|
{ do sign extension }
|
|
begin gencst(op_loc, sz); gencst(op_loc, sz_word); genop(op_cii) end;
|
|
end;
|
|
ak:=loaded;
|
|
end end;
|
|
|
|
procedure store;
|
|
var sz:integer;
|
|
begin with a,pos do begin sz:=sizeof(asp,packbit);
|
|
if asp<>nil then
|
|
case ak of
|
|
fixed:
|
|
if lv<=0 then pop(global,ad,sz) else
|
|
if level=lv then pop(local,ad,sz) else
|
|
begin lexaddr(lv,ad); gencst(op_sti,sz) end;
|
|
pfixed:
|
|
begin loadpos(pos,sz_addr); gencst(op_sti,sz) end;
|
|
ploaded:
|
|
gencst(op_sti,sz);
|
|
indexed:
|
|
gencst(op_sar,sz_word);
|
|
end; {case}
|
|
end end;
|
|
|
|
procedure fieldaddr(off:integer);
|
|
begin with a do
|
|
if (ak=fixed) and not packbit then pos.ad:=pos.ad+off else
|
|
begin loadaddr; gencst(op_adp,off) end
|
|
end;
|
|
|
|
procedure loadcheap;
|
|
begin if formof(a.asp,[arrays..records]) then loadaddr else load end;
|
|
|
|
{===================================================================}
|
|
|
|
procedure nextch;
|
|
begin
|
|
eol:=eoln(input); read(input,ch); chsy:=cs[ch];
|
|
if chsy <> tabch then srcchno:=srcchno+1
|
|
end;
|
|
|
|
procedure nextln;
|
|
begin
|
|
if eof(input) then
|
|
begin
|
|
if not eofexpected then error(+03) else
|
|
if fltused then begin gencst(ps_mes,ms_flt); argend end;
|
|
#ifdef STANDARD
|
|
goto 9999
|
|
#else
|
|
halt
|
|
#endif
|
|
end;
|
|
srcchno:=0; srclino:=srclino+1;
|
|
if not including then
|
|
begin srcorig:=srcorig+1; giveline:=true end;
|
|
end;
|
|
|
|
procedure options(normal:boolean);
|
|
var ci:char; i:integer;
|
|
|
|
procedure getc;
|
|
begin if normal then nextch else read(errors,ch) end;
|
|
|
|
begin
|
|
repeat getc;
|
|
if (ch>='a') and (ch<='z') then
|
|
begin ci:=ch; getc; i:=0;
|
|
if ch='+' then begin i:=1; getc end else
|
|
if ch='-' then getc else
|
|
if cs[ch]=digit then
|
|
repeat i:=i*10 + ord(ch) - ord('0'); getc;
|
|
until cs[ch]<>digit
|
|
else i:=-1;
|
|
if i>=0 then
|
|
if not normal then
|
|
begin forceopt[ci]:=true; opt[ci]:=i end
|
|
else
|
|
if not forceopt[ci] then opt[ci]:=i;
|
|
end;
|
|
until ch<>',';
|
|
end;
|
|
|
|
procedure linedirective;
|
|
var i:integer; fname:fnarr;
|
|
begin
|
|
repeat nextch until (ch='"') or eol;
|
|
if eol then error(+04) else
|
|
begin nextch; i:=0;
|
|
while (ch<>'"') and not eol do
|
|
begin
|
|
if ch='/' then i:=0 else
|
|
begin i:=i+1; if i<=fnmax then fname[i]:=ch end;
|
|
nextch
|
|
end;
|
|
while i<fnmax do begin i:=i+1; fname[i]:=' ' end;
|
|
including:=fname<>source; while not eol do nextch
|
|
end;
|
|
end;
|
|
|
|
procedure putdig;
|
|
begin ix:=ix+1; if ix<=smax then strbuf[ix]:=ch; nextch end;
|
|
|
|
procedure inident;
|
|
label 1;
|
|
var i,k:integer;
|
|
begin k:=0; id:=spaces;
|
|
repeat
|
|
if chsy=upper then ch:=chr(ord(ch)-ord('A')+ord('a'));
|
|
if k<idmax then begin k:=k+1; id[k]:=ch end;
|
|
nextch
|
|
until chsy>digit;
|
|
{lower=0,upper=1,digit=2. ugly but fast}
|
|
for i:=frw[k-1] to frw[k] - 1 do
|
|
if rw[i]=id then
|
|
begin sy:=rsy[i]; goto 1 end;
|
|
sy:=ident;
|
|
1:
|
|
end;
|
|
|
|
procedure innumber;
|
|
label 1;
|
|
var i,j:integer;
|
|
is:packed array[1..imax] of char;
|
|
begin ix:=0; sy:=intcst; val:=0;
|
|
repeat putdig until chsy<>digit;
|
|
if (ch='.') or (ch='e') or (ch='E') then
|
|
begin
|
|
if ch='.' then
|
|
begin putdig;
|
|
if ch='.' then
|
|
begin seconddot:=true; ix:=ix-1; goto 1 end;
|
|
if chsy<>digit then error(+05) else
|
|
repeat putdig until chsy<>digit;
|
|
end;
|
|
if (ch='e') or (ch='E') then
|
|
begin putdig;
|
|
if (ch='+') or (ch='-') then putdig;
|
|
if chsy<>digit then error(+06) else
|
|
repeat putdig until chsy<>digit;
|
|
end;
|
|
if ix>smax then begin error(+07); ix:=smax end;
|
|
sy:=realcst; fltused:=true; val:=romstr(sp_fcon,sz_real);
|
|
end;
|
|
1:if (chsy=lower) or (chsy=upper) then teststandard;
|
|
if sy=intcst then
|
|
if ix>imax then error(+08) else
|
|
begin is:='0000000000'; i:=ix; j:=imax;
|
|
repeat is[j]:=strbuf[i]; j:=j-1; i:=i-1 until i=0;
|
|
if (is<=maxintstring) and (is<=maxcompintstring) then
|
|
repeat j:=j+1; val:=val*10 - ord('0') + ord(is[j]) until j=imax
|
|
else if (is<=maxlongstring) and (dopt<>off) then
|
|
begin sy:=longcst; val:=romstr(sp_icon,sz_long) end
|
|
else error(+09)
|
|
end
|
|
end;
|
|
|
|
procedure instring(qc:char);
|
|
begin ix:=0; zerostring:=qc='"';
|
|
repeat
|
|
repeat nextch; ix:=ix+1; if ix<=smax then strbuf[ix]:=ch;
|
|
until (ch=qc) or eol;
|
|
if ch=qc then nextch else error(+010);
|
|
until ch<>qc;
|
|
if not zerostring then
|
|
begin ix:=ix-1; if ix=0 then error(+011) end
|
|
else
|
|
begin strbuf[ix]:=chr(0); if copt=off then error(+012) end;
|
|
if (ix=1) and not zerostring then
|
|
begin sy:=charcst; val:=ord(strbuf[1]) end
|
|
else
|
|
begin if ix>smax then begin error(+013); ix:=smax end;
|
|
sy:=stringcst; val:=romstr(sp_scon,0);
|
|
end
|
|
end;
|
|
|
|
procedure incomment;
|
|
var stopc:char;
|
|
begin nextch; stopc:='}';
|
|
if ch='$' then options(true);
|
|
while (ch<>'}') and (ch<>stopc) do
|
|
begin stopc:='}'; if ch='*' then stopc:=')';
|
|
if eol then nextln; nextch
|
|
end;
|
|
if ch<>'}' then teststandard;
|
|
nextch
|
|
end;
|
|
|
|
procedure insym;
|
|
{read next basic symbol of source program and return its
|
|
description in the global variables sy, op, id, val and ix}
|
|
label 1;
|
|
begin
|
|
1:case chsy of
|
|
tabch:
|
|
begin srcchno:=srcchno - srcchno mod 8 + 8; nextch; goto 1 end;
|
|
layout:
|
|
begin if eol then nextln; nextch; goto 1 end;
|
|
lower,upper: inident;
|
|
digit: innumber;
|
|
quotech,dquotech:
|
|
instring(ch);
|
|
colonch:
|
|
begin nextch;
|
|
if ch='=' then begin sy:=becomes; nextch end else sy:=colon1
|
|
end;
|
|
periodch:
|
|
begin nextch;
|
|
if seconddot then begin seconddot:=false; sy:=colon2 end else
|
|
if ch='.' then begin sy:=colon2; nextch end else sy:=period
|
|
end;
|
|
lessch:
|
|
begin nextch;
|
|
if ch='=' then begin sy:=lesy; nextch end else
|
|
if ch='>' then begin sy:=nesy; nextch end else sy:=ltsy
|
|
end;
|
|
greaterch:
|
|
begin nextch;
|
|
if ch='=' then begin sy:=gesy; nextch end else sy:=gtsy
|
|
end;
|
|
lparentch:
|
|
begin nextch;
|
|
if ch<>'*' then sy:=lparent else
|
|
begin teststandard; incomment; goto 1 end;
|
|
end;
|
|
lbracech:
|
|
begin incomment; goto 1 end;
|
|
rparentch,lbrackch,rbrackch,commach,semich,arrowch,
|
|
plusch,minch,slash,star,equal:
|
|
begin sy:=csy[chsy]; nextch end;
|
|
others:
|
|
begin
|
|
if (ch='#') and (srcchno=1) then linedirective else
|
|
begin error(+014); nextch end;
|
|
goto 1
|
|
end;
|
|
end {case}
|
|
end;
|
|
|
|
procedure nextif(fsy:symbol; err:integer);
|
|
begin if sy=fsy then insym else error(-err) end;
|
|
|
|
function find1(sys1,sys2:sos; err:integer):boolean;
|
|
{symbol of sys1 expected. return true if sy in sys1}
|
|
begin
|
|
if not (sy in sys1) then
|
|
begin error(err); while not (sy in sys1+sys2) do insym end;
|
|
find1:=sy in sys1
|
|
end;
|
|
|
|
function find2(sys1,sys2:sos; err:integer):boolean;
|
|
{symbol of sys1+sys2 expected. return true if sy in sys1}
|
|
begin
|
|
if not (sy in sys1+sys2) then
|
|
begin error(err); repeat insym until sy in sys1+sys2 end;
|
|
find2:=sy in sys1
|
|
end;
|
|
|
|
function find3(sy1:symbol; sys2:sos; err:integer):boolean;
|
|
{symbol sy1 or one of sys2 expected. return true if sy1 found and skip it}
|
|
begin find3:=true;
|
|
if not (sy in [sy1]+sys2) then
|
|
begin error(err); repeat insym until sy in [sy1]+sys2 end;
|
|
if sy=sy1 then insym else find3:=false
|
|
end;
|
|
|
|
function endofloop(sys1,sys2:sos; sy3:symbol; err:integer):boolean;
|
|
begin endofloop:=false;
|
|
if find2(sys2+[sy3],sys1,err) then nextif(sy3,err+1)
|
|
else endofloop:=true;
|
|
end;
|
|
|
|
function lastsemicolon(sys1,sys2:sos; err:integer):boolean;
|
|
begin lastsemicolon:=true;
|
|
if not endofloop(sys1,sys2,semicolon,err) then
|
|
if find2(sys2,sys1,err+2) then lastsemicolon:=false
|
|
end;
|
|
|
|
{===================================================================}
|
|
|
|
function searchid(fidcls: setofids):ip;
|
|
{search for current identifier symbol in the name table}
|
|
label 1;
|
|
var lip:ip; ic:idclass;
|
|
begin lastnp:=top;
|
|
while lastnp<>nil do
|
|
begin lip:=lastnp^.fname;
|
|
while lip<>nil do
|
|
if lip^.name=id then
|
|
if lip^.klass in fidcls then
|
|
begin
|
|
if lip^.klass=vars then if lip^.vpos.lv<>level then
|
|
lip^.iflag:=lip^.iflag+[noreg];
|
|
goto 1
|
|
end
|
|
else lip:=lip^.rlink
|
|
else
|
|
if lip^.name< id then lip:=lip^.rlink else lip:=lip^.llink;
|
|
lastnp:=lastnp^.nlink;
|
|
end;
|
|
errid(+015,id);
|
|
if types in fidcls then ic:=types else
|
|
if vars in fidcls then ic:=vars else
|
|
if konst in fidcls then ic:=konst else
|
|
if proc in fidcls then ic:=proc else
|
|
if func in fidcls then ic:=func else ic:=field;
|
|
lip:=undefip[ic];
|
|
1:
|
|
searchid:=lip
|
|
end;
|
|
|
|
function searchsection(fip: ip):ip;
|
|
{to find record fields and forward declared procedure identifiers
|
|
-->procedure pfdeclaration
|
|
-->procedure selector}
|
|
label 1;
|
|
begin
|
|
while fip<>nil do
|
|
if fip^.name=id then goto 1 else
|
|
if fip^.name< id then fip:=fip^.rlink else fip:=fip^.llink;
|
|
1: searchsection:=fip
|
|
end;
|
|
|
|
function searchlab(flp:lp; val:integer):lp;
|
|
label 1;
|
|
begin
|
|
while flp<>nil do
|
|
if flp^.labval=val then goto 1 else flp:=flp^.nextlp;
|
|
1:searchlab:=flp
|
|
end;
|
|
|
|
procedure opconvert(ts:twostruct);
|
|
var op:integer;
|
|
begin with a do begin genasp(op_loc);
|
|
case ts of
|
|
ir, lr: begin asp:=realptr; op:=op_cif; fltused:=true end;
|
|
ri: begin asp:=intptr ; op:=op_cfi; fltused:=true end;
|
|
rl: begin asp:=longptr; op:=op_cfi; fltused:=true end;
|
|
li: begin asp:=intptr ; op:=op_cii end;
|
|
il: begin asp:=longptr; op:=op_cii end;
|
|
end;
|
|
genasp(op_loc); genop(op)
|
|
end end;
|
|
|
|
procedure negate;
|
|
begin if a.asp=realptr then genasp(op_ngf) else genasp(op_ngi) end;
|
|
|
|
function desub(fsp:sp):sp;
|
|
begin if formof(fsp,[subrange]) then fsp:=fsp^.rangetype; desub:=fsp end;
|
|
|
|
function nicescalar(fsp:sp):boolean;
|
|
begin
|
|
if fsp=nil then nicescalar:=true else
|
|
nicescalar:=(fsp^.form=scalar) and (fsp<>realptr) and (fsp<>longptr)
|
|
end;
|
|
|
|
function bounded(fsp:sp):boolean;
|
|
begin bounded:=false;
|
|
if fsp<>nil then
|
|
if fsp^.form=subrange then bounded:=true else
|
|
if fsp^.form=scalar then bounded:=fsp^.fconst<>nil
|
|
end;
|
|
|
|
procedure bounds(fsp:sp; var fmin,fmax:integer);
|
|
begin
|
|
if fsp=nil then
|
|
begin fmin:=0; fmax:=0 end
|
|
else
|
|
case fsp^.form of
|
|
subrange:
|
|
begin fmin:=fsp^.min; fmax:=fsp^.max end;
|
|
scalar:
|
|
begin fmin:=0; fmax:=fsp^.fconst^.value end
|
|
end
|
|
end;
|
|
|
|
procedure genrck(fsp:sp);
|
|
var min,max,sno:integer;
|
|
begin
|
|
if opt['r']<>off then if bounded(fsp) then
|
|
begin
|
|
if fsp^.form=scalar then sno:=fsp^.scalno else sno:=fsp^.subrno;
|
|
if sno=0 then
|
|
begin bounds(fsp,min,max); sno:=newdlb;
|
|
gencst(ps_rom,min); argcst(max); argend;
|
|
if fsp^.form=scalar then fsp^.scalno:=sno else fsp^.subrno:=sno
|
|
end;
|
|
laedlb(sno); gencst(op_rck,sz_word);
|
|
end
|
|
end;
|
|
|
|
procedure checkbnds(fsp:sp);
|
|
var min1,max1,min2,max2:integer;
|
|
begin
|
|
if bounded(fsp) then
|
|
if not bounded(a.asp) then genrck(fsp) else
|
|
begin bounds(fsp,min1,max1); bounds(a.asp,min2,max2);
|
|
if (min2<min1) or (max2>max1) then
|
|
genrck(fsp);
|
|
end;
|
|
a.asp:=fsp;
|
|
end;
|
|
|
|
function eqstruct(p,q:sp):boolean;
|
|
begin eqstruct:=(p=q) or (p=nil) or (q=nil) end;
|
|
|
|
function string(fsp:sp):boolean;
|
|
var lsp:sp;
|
|
begin string:=false;
|
|
if formof(fsp,[arrays]) then
|
|
if eqstruct(fsp^.aeltype,charptr) then
|
|
if spack in fsp^.sflag then
|
|
begin lsp:=fsp^.inxtype;
|
|
if lsp=nil then string:=true else
|
|
if lsp^.form=subrange then
|
|
if lsp^.rangetype=intptr then
|
|
if lsp^.min=1 then
|
|
string:=true
|
|
end
|
|
end;
|
|
|
|
function compat(p,q:sp):twostruct;
|
|
begin compat:=noteq;
|
|
if eqstruct(p,q) then compat:=eq else
|
|
begin p:=desub(p); q:=desub(q);
|
|
if eqstruct(p,q) then compat:=subeq else
|
|
if p^.form=q^.form then
|
|
case p^.form of
|
|
scalar:
|
|
if (p=intptr) and (q=realptr) then compat:=ir else
|
|
if (p=realptr) and (q=intptr) then compat:=ri else
|
|
if (p=intptr) and (q=longptr) then compat:=il else
|
|
if (p=longptr) and (q=intptr) then compat:=li else
|
|
if (p=longptr) and (q=realptr) then compat:=lr else
|
|
if (p=realptr) and (q=longptr) then compat:=rl else
|
|
;
|
|
pointer:
|
|
if (p=nilptr) or (q=nilptr) then compat:=eq;
|
|
power:
|
|
if p=nullset then compat:=es else
|
|
if q=nullset then compat:=se else
|
|
if compat(p^.elset,q^.elset) <= subeq then
|
|
if p^.sflag=q^.sflag then compat:=eq;
|
|
arrays:
|
|
if string(p) and string(q) and (p^.size=q^.size) then compat:=eq;
|
|
files,carray,records: ;
|
|
end;
|
|
end
|
|
end;
|
|
|
|
procedure checkasp(fsp:sp; err:integer);
|
|
var ts:twostruct;
|
|
begin
|
|
ts:=compat(a.asp,fsp);
|
|
case ts of
|
|
eq:
|
|
if fsp<>nil then if withfile in fsp^.sflag then errasp(err);
|
|
subeq:
|
|
checkbnds(fsp);
|
|
li:
|
|
begin opconvert(ts); checkasp(fsp,err) end;
|
|
il,rl,lr,ir:
|
|
opconvert(ts);
|
|
es:
|
|
expandnullset(fsp);
|
|
noteq,ri,se:
|
|
errasp(err);
|
|
end
|
|
end;
|
|
|
|
procedure force(fsp:sp; err:integer);
|
|
begin load; checkasp(fsp,err) end;
|
|
|
|
function newident(kl:idclass; idt:sp; nxt:ip; err:integer):ip;
|
|
begin newident:=nil;
|
|
if sy<>ident then error(err) else
|
|
begin newident:=newip(kl,id,idt,nxt); insym end
|
|
end;
|
|
|
|
function stringstruct:sp;
|
|
var lsp:sp;
|
|
begin {only used when ix and zerostring are still valid}
|
|
if zerostring then lsp:=zeroptr else
|
|
begin lsp:=newsp(arrays,ix*sz_char); lsp^.sflag:=[spack];
|
|
lsp^.aeltype:=charptr; lsp^.inxtype:=nil;
|
|
end;
|
|
stringstruct:=lsp;
|
|
end;
|
|
|
|
function posaddr(var lb:integer; fsp:sp; partword:boolean):integer;
|
|
var sz:integer;
|
|
begin sz:=sizeof(fsp,partword);
|
|
if sz_int = 2 then
|
|
if lb >= MI2-sz-sz_word then begin error(+016); lb:=0 end;
|
|
if not partword or (sz>=sz_word) then
|
|
while lb mod sz_word <> 0 do lb:=lb+1;
|
|
posaddr:=lb;
|
|
lb:=lb+sz
|
|
end;
|
|
|
|
function negaddr(fsp:sp):integer;
|
|
var sz:integer;
|
|
begin with b do begin
|
|
sz:=sizeof(fsp,wordmult);
|
|
if sz_int = 2 then
|
|
if reglb <= -MI2+sz+sz_word then begin error(+017); reglb:=0 end;
|
|
reglb:=reglb-sz;
|
|
while reglb mod sz_word <> 0 do reglb:=reglb-1;
|
|
if reglb < minlb then minlb:=reglb;
|
|
negaddr:=reglb
|
|
end end;
|
|
|
|
procedure temporary(fsp:sp;r:integer);
|
|
begin inita(fsp,negaddr(fsp));
|
|
if r>=0 then genreg(sizeof(fsp,wordmult),a.pos.ad,r)
|
|
end;
|
|
|
|
procedure genhol;
|
|
var sz: integer;
|
|
begin sz := posaddr(holeb,nil,false); if sz = 0 then sz := sz_word;
|
|
gencst(ps_hol,sz);
|
|
if sz_word = 4 then begin put1(sp_cst4); put1(0); put1(0); end
|
|
else put1(sp_cst2);
|
|
put1(0); put1(128); { 1000000000000000 pattern}
|
|
argcst(0); level:=1
|
|
end;
|
|
|
|
function arraysize(fsp:sp; pack:boolean):integer;
|
|
var sz,min,max,tot,n:integer;
|
|
begin sz:=sizeof(fsp^.aeltype,pack);
|
|
bounds(fsp^.inxtype,min,max);
|
|
fsp^.arpos.lv:=0; fsp^.arpos.ad:=newdlb;
|
|
gencst(ps_rom,min); argcst(max-min); argcst(sz); argend;
|
|
n:=max-min+1; tot:=sz*n;
|
|
if sz<>0 then if tot div sz <> n then begin error(+018); tot:=0 end;
|
|
arraysize:=tot
|
|
end;
|
|
|
|
procedure treewalk(fip:ip);
|
|
var lsp:sp; i,sz:integer;
|
|
begin
|
|
if fip<>nil then
|
|
begin treewalk(fip^.llink); treewalk(fip^.rlink);
|
|
if fip^.klass=vars then
|
|
begin if not (used in fip^.iflag) then errid(-(+019),fip^.name);
|
|
if not (assigned in fip^.iflag) then errid(-(+020),fip^.name);
|
|
lsp:=fip^.idtype;
|
|
if level<>1 then
|
|
if (refer in fip^.iflag) or not (noreg in fip^.iflag) then
|
|
if (refer in fip^.iflag) or formof(lsp,[pointer]) then
|
|
genreg(sz_addr,fip^.vpos.ad,reg_pointer)
|
|
else
|
|
begin sz:=sizeof(lsp,wordmult);
|
|
if loopvar in fip^.iflag then
|
|
genreg(sz,fip^.vpos.ad,reg_loop)
|
|
else if lsp=realptr then
|
|
genreg(sz,fip^.vpos.ad,reg_float)
|
|
else
|
|
genreg(sz,fip^.vpos.ad,reg_any);
|
|
end;
|
|
if lsp<>nil then if withfile in lsp^.sflag then
|
|
if lsp^.form=files then
|
|
if level=1 then
|
|
begin
|
|
for i:=2 to argc do with argv[i] do
|
|
if name=fip^.name then ad:=fip^.vpos.ad
|
|
end
|
|
else
|
|
begin
|
|
if not (refer in fip^.iflag) then
|
|
begin gencst(op_lal,fip^.vpos.ad); gensp(CLS,sz_addr)
|
|
end
|
|
end
|
|
else
|
|
if level<>1 then errid(-(+021),fip^.name)
|
|
end
|
|
end
|
|
end;
|
|
|
|
procedure constant(fsys:sos; var fsp:sp; var fval:integer);
|
|
var signed,min:boolean; lip:ip;
|
|
begin signed:=(sy=plussy) or (sy=minsy);
|
|
if signed then begin min:=sy=minsy; insym end else min:=false;
|
|
if find1([ident..stringcst],fsys,+022) then
|
|
begin fval:=val;
|
|
case sy of
|
|
stringcst: fsp:=stringstruct;
|
|
charcst: fsp:=charptr;
|
|
intcst: fsp:=intptr;
|
|
realcst: fsp:=realptr;
|
|
longcst: fsp:=longptr;
|
|
ident:
|
|
begin lip:=searchid([konst]);
|
|
fsp:=lip^.idtype; fval:=lip^.value;
|
|
end
|
|
end; {case}
|
|
if signed then
|
|
if (fsp<>intptr) and (fsp<>realptr) and (fsp<>longptr) then
|
|
error(+023)
|
|
else if min then fval:= -fval;
|
|
{note: negating the v-number for reals and longs}
|
|
insym;
|
|
end
|
|
else begin fsp:=nil; fval:=0 end;
|
|
end;
|
|
|
|
function cstinteger(fsys:sos; fsp:sp; err:integer):integer;
|
|
var lsp:sp; lval,min,max:integer;
|
|
begin constant(fsys,lsp,lval);
|
|
if fsp<>lsp then
|
|
if not eqstruct(desub(fsp),lsp) then
|
|
begin error(err); lval:=0 end
|
|
else if bounded(fsp) then
|
|
begin bounds(fsp,min,max);
|
|
if (lval<min) or (lval>max) then error(+024)
|
|
end;
|
|
cstinteger:=lval
|
|
end;
|
|
|
|
{===================================================================}
|
|
|
|
function typid(err:integer):sp;
|
|
var lip:ip; lsp:sp;
|
|
begin lsp:=nil;
|
|
if sy<>ident then error(err) else
|
|
begin lip:=searchid([types]); lsp:=lip^.idtype; insym end;
|
|
typid:=lsp
|
|
end;
|
|
|
|
function simpletyp(fsys:sos):sp;
|
|
var lsp,lsp1:sp; lip,hip:ip; min,max:integer; lnp:np;
|
|
newsubrange:boolean;
|
|
begin lsp:=nil;
|
|
if find1([ident..lparent],fsys,+025) then
|
|
if sy=lparent then
|
|
begin insym; lnp:=top; {decl. consts local to innermost block}
|
|
while top^.occur<>blck do top:=top^.nlink;
|
|
lsp:=newsp(scalar,sz_word); hip:=nil; max:=0;
|
|
repeat lip:=newident(konst,lsp,hip,+026);
|
|
if lip<>nil then
|
|
begin enterid(lip); hip:=lip; lip^.value:=max; max:=max+1 end;
|
|
until endofloop(fsys+[rparent],[ident],comma,+027); {+028}
|
|
if max<=MU1 then lsp^.size:=sz_byte
|
|
#if EM_WSIZE == 4
|
|
else if max <= MU2 then lsp^.size := 2*sz_byte
|
|
#endif
|
|
;
|
|
lsp^.fconst:=hip; top:=lnp; nextif(rparent,+029);
|
|
end
|
|
else
|
|
begin newsubrange:=true;
|
|
if sy=ident then
|
|
begin lip:=searchid([types,konst]); insym;
|
|
if lip^.klass=types then
|
|
begin lsp:=lip^.idtype; newsubrange:=false end
|
|
else
|
|
begin lsp1:=lip^.idtype; min:=lip^.value end
|
|
end
|
|
else constant(fsys+[colon2,ident..plussy],lsp1,min);
|
|
if newsubrange then
|
|
begin lsp:=newsp(subrange,sz_word); lsp^.subrno:=0;
|
|
if not nicescalar(lsp1) then
|
|
begin error(+030); lsp1:=nil; min:=0 end;
|
|
lsp^.rangetype:=lsp1;
|
|
nextif(colon2,+031); max:=cstinteger(fsys,lsp1,+032);
|
|
if min>max then begin error(+033); max:=min end;
|
|
if ((min>=0) and (max<=MU1)) or ((min>=-NI1) and (max<=MI1)) then
|
|
lsp^.size:=sz_byte
|
|
#if EM_WSIZE == 4
|
|
else if ((min>=0) and (max<=MU2)) or ((min>=-MI2-1) and (max<=MI2)) then
|
|
lsp^.size := 2*sz_byte
|
|
#endif
|
|
;
|
|
lsp^.min:=min; lsp^.max:=max
|
|
end
|
|
end;
|
|
simpletyp:=lsp
|
|
end;
|
|
|
|
function arraytyp(fsys:sos;
|
|
artyp:structform;
|
|
sflag:sflagset;
|
|
function element(fsys:sos):sp
|
|
):sp;
|
|
var lsp,lsp1,hsp:sp; ok:boolean; sepsy:symbol; lip:ip;
|
|
oksys:sos;
|
|
begin insym; nextif(lbrack,+034); hsp:=nil;
|
|
repeat lsp:=newsp(artyp,0); initpos(lsp^.arpos);
|
|
lsp^.aeltype:=hsp; hsp:=lsp; {link reversed}
|
|
if artyp=carray then
|
|
begin sepsy:=semicolon; oksys:=[ident];
|
|
lip:=newident(carrbnd,lsp,nil,+035); if lip<>nil then enterid(lip);
|
|
nextif(colon2,+036);
|
|
lip:=newident(carrbnd,lsp,lip,+037); if lip<>nil then enterid(lip);
|
|
nextif(colon1,+038); lsp1:=typid(+039);
|
|
ok:=nicescalar(desub(lsp1));
|
|
end
|
|
else
|
|
begin sepsy:=comma; oksys:=[ident..lparent];
|
|
lsp1:=simpletyp(fsys+[comma,rbrack,ofsy,ident..packedsy]);
|
|
ok:=bounded(lsp1)
|
|
end;
|
|
if not ok then begin error(+040); lsp1:=nil end;
|
|
lsp^.inxtype:=lsp1
|
|
until endofloop(fsys+[rbrack,ofsy,ident..packedsy],oksys,
|
|
sepsy,+041); {+042}
|
|
nextif(rbrack,+043); nextif(ofsy,+044);
|
|
lsp:=element(fsys);
|
|
if lsp<>nil then sflag:=sflag + lsp^.sflag * [withfile];
|
|
repeat {reverse links and compute size}
|
|
lsp1:=hsp^.aeltype; hsp^.aeltype:=lsp; hsp^.sflag:=sflag;
|
|
if artyp=arrays then hsp^.size:=arraysize(hsp,spack in sflag);
|
|
lsp:=hsp; hsp:=lsp1
|
|
until hsp=nil; {lsp points to array with highest dimension}
|
|
arraytyp:=lsp
|
|
end;
|
|
|
|
function typ(fsys:sos):sp;
|
|
var lsp,lsp1:sp; off,sz,min,errno:integer;
|
|
sflag:sflagset; lnp:np;
|
|
|
|
function fldlist(fsys:sos):sp;
|
|
{level 2: << typ}
|
|
var fip,hip,lip:ip; lsp:sp;
|
|
|
|
function varpart(fsys:sos):sp;
|
|
{level 3: << fldlist << typ}
|
|
var tip,lip:ip; lsp,headsp,hsp,vsp,tsp,tsp1,tfsp:sp;
|
|
minoff,maxoff,int,nvar:integer; lid:idarr;
|
|
begin insym; tip:=nil; lip:=nil;
|
|
tsp:=newsp(tag,0);
|
|
if sy<>ident then error(+045) else
|
|
begin lid:=id; insym;
|
|
if sy=colon1 then
|
|
begin tip:=newip(field,lid,nil,nil); enterid(tip); insym;
|
|
if sy<>ident then error(+046) else
|
|
begin lid:=id; insym end;
|
|
end;
|
|
if sy=ofsy then {otherwise you may destroy id}
|
|
begin id:=lid; lip:=searchid([types]) end;
|
|
end;
|
|
if lip=nil then tfsp:=nil else tfsp:=lip^.idtype;
|
|
if bounded(tfsp) then
|
|
begin bounds(tfsp,int,nvar); nvar:=nvar-int+1 end
|
|
else
|
|
begin nvar:=0; if tfsp<>nil then begin error(+047); tfsp:=nil end end;
|
|
tsp^.tfldsp:=tfsp;
|
|
if tip<>nil then {explicit tag}
|
|
begin tip^.idtype:=tfsp;
|
|
tip^.foffset:=posaddr(off,tfsp,spack in sflag)
|
|
end;
|
|
nextif(ofsy,+048); minoff:=off; maxoff:=minoff; headsp:=nil;
|
|
repeat hsp:=nil; {for each caselabel list}
|
|
repeat nvar:=nvar-1;
|
|
int:=cstinteger(fsys+[ident..plussy,comma,colon1,lparent,
|
|
semicolon,casesy,rparent],tfsp,+049);
|
|
lsp:=headsp; {each label may occur only once}
|
|
while lsp<>nil do
|
|
begin if lsp^.varval=int then error(+050);
|
|
lsp:=lsp^.nxtvar
|
|
end;
|
|
vsp:=newsp(variant,0); vsp^.varval:=int;
|
|
vsp^.nxtvar:=headsp; headsp:=vsp; {chain of case labels}
|
|
vsp^.subtsp:=hsp; hsp:=vsp;
|
|
{use this field to link labels with same variant}
|
|
until endofloop(fsys+[colon1,lparent,semicolon,casesy,rparent],
|
|
[ident..plussy],comma,+051); {+052}
|
|
nextif(colon1,+053); nextif(lparent,+054);
|
|
tsp1:=fldlist(fsys+[rparent,semicolon,ident..plussy]);
|
|
if off>maxoff then maxoff:=off;
|
|
while vsp<>nil do
|
|
begin vsp^.size:=off; hsp:=vsp^.subtsp;
|
|
vsp^.subtsp:=tsp1; vsp:=hsp
|
|
end;
|
|
nextif(rparent,+055);
|
|
off:=minoff;
|
|
until lastsemicolon(fsys,[ident..plussy],+056); {+057 +058}
|
|
if nvar>0 then error(-(+059));
|
|
tsp^.fstvar:=headsp; tsp^.size:=minoff; off:=maxoff; varpart:=tsp;
|
|
end;
|
|
|
|
begin {fldlist}
|
|
if find2([ident],fsys+[casesy],+060) then
|
|
repeat lip:=nil; hip:=nil;
|
|
repeat fip:=newident(field,nil,nil,+061);
|
|
if fip<>nil then
|
|
begin enterid(fip);
|
|
if lip=nil then hip:=fip else lip^.next:=fip; lip:=fip;
|
|
end;
|
|
until endofloop(fsys+[colon1,ident..packedsy,semicolon,casesy],
|
|
[ident],comma,+062); {+063}
|
|
nextif(colon1,+064);
|
|
lsp:=typ(fsys+[casesy,semicolon]);
|
|
if lsp<>nil then if withfile in lsp^.sflag then
|
|
sflag:=sflag+[withfile];
|
|
while hip<>nil do
|
|
begin hip^.idtype:=lsp;
|
|
hip^.foffset:=posaddr(off,lsp,spack in sflag);
|
|
hip:=hip^.next
|
|
end;
|
|
until lastsemicolon(fsys+[casesy],[ident],+065); {+066 +067}
|
|
if sy=casesy then fldlist:=varpart(fsys) else fldlist:=nil;
|
|
end;
|
|
|
|
|
|
begin {typ}
|
|
sflag:=[]; lsp:=nil;
|
|
if sy=packedsy then begin sflag:=[spack]; insym end;
|
|
if find1([ident..filesy],fsys,+068) then
|
|
if sy in [ident..arrow] then
|
|
begin if spack in sflag then error(+069);
|
|
if sy=arrow then
|
|
begin lsp:=newsp(pointer,sz_addr); insym;
|
|
if not intypedec then lsp^.eltype:=typid(+070) else
|
|
if sy<>ident then error(+071) else
|
|
begin fwptr:=newip(types,id,lsp,fwptr); insym end
|
|
end
|
|
else lsp:=simpletyp(fsys);
|
|
end
|
|
else
|
|
case sy of
|
|
{<<<<<<<<<<<<}
|
|
arraysy:
|
|
lsp:=arraytyp(fsys,arrays,sflag,typ);
|
|
recordsy:
|
|
begin insym;
|
|
new(lnp,rec); lnp^.occur:=rec; lnp^.nlink:=top; lnp^.fname:=nil; top:=lnp;
|
|
off:=0; lsp1:=fldlist(fsys+[endsy]); {fldlist updates off}
|
|
lsp:=newsp(records,off); lsp^.tagsp:=lsp1;
|
|
lsp^.fstfld:=top^.fname; lsp^.sflag:=sflag;
|
|
top:=top^.nlink; nextif(endsy,+072)
|
|
end;
|
|
setsy:
|
|
begin insym; nextif(ofsy,+073);
|
|
lsp:=simpletyp(fsys); lsp1:=desub(lsp); errno:=0;
|
|
if bounded(lsp1) then
|
|
begin bounds(lsp1,min,sz);
|
|
if sz div NB1>=sz_mset then errno:=+074
|
|
end
|
|
else if bounded(lsp) then {subrange of integer}
|
|
begin bounds(lsp,min,sz);
|
|
if (min<0) or (sz>=iopt) then errno:=+075;
|
|
sz:=iopt-1
|
|
end
|
|
else if lsp=intptr then
|
|
begin sz:=iopt-1; errno:=-(+076) end
|
|
else
|
|
errno:=+077;
|
|
if errno<>0 then
|
|
begin error(errno); if errno>0 then begin lsp1:=nil; sz:=0 end end;
|
|
lsp:=newsp(power,sz div NB1 +1); lsp^.elset:=lsp1;
|
|
end;
|
|
filesy:
|
|
begin insym; nextif(ofsy,+078); lsp1:=typ(fsys);
|
|
if lsp1<>nil then if withfile in lsp1^.sflag then error(-(+079));
|
|
sz:=sizeof(lsp1,wordpart); if sz<sz_buff then sz:=sz_buff;
|
|
lsp:=newsp(files,sz+sz_head); lsp^.filtype:=lsp1;
|
|
end;
|
|
{>>>>>>>>>>>>}
|
|
end; {case}
|
|
typ:=lsp;
|
|
end;
|
|
|
|
function vpartyp(fsys:sos):sp;
|
|
begin
|
|
if find2([arraysy],fsys+[ident],+080) then
|
|
vpartyp:=arraytyp(fsys,carray,[],vpartyp)
|
|
else
|
|
vpartyp:=typid(+081)
|
|
end;
|
|
|
|
{===================================================================}
|
|
|
|
procedure block(fsys:sos; fip:ip); forward;
|
|
{pfdeclaration calls block. With a more obscure lexical
|
|
structure this forward declaration can be avoided}
|
|
|
|
procedure labeldeclaration(fsys:sos);
|
|
var llp:lp;
|
|
begin with b do begin
|
|
repeat
|
|
if sy<>intcst then error(+082) else
|
|
begin
|
|
if searchlab(lchain,val)<>nil then errint(+083,val) else
|
|
begin new(llp); llp^.labval:=val;
|
|
if val>9999 then teststandard;
|
|
ilbno:=ilbno+1; llp^.labname:=ilbno; llp^.labdlb:=0;
|
|
llp^.seen:=false; llp^.nextlp:=lchain; lchain:=llp;
|
|
end;
|
|
insym
|
|
end
|
|
until endofloop(fsys+[semicolon],[intcst],comma,+084); {+085}
|
|
nextif(semicolon,+086)
|
|
end end;
|
|
|
|
procedure constdefinition(fsys:sos);
|
|
var lip:ip;
|
|
begin
|
|
repeat lip:=newident(konst,nil,nil,+087);
|
|
if lip<>nil then
|
|
begin nextif(eqsy,+088);
|
|
constant(fsys+[semicolon,ident],lip^.idtype,lip^.value);
|
|
nextif(semicolon,+089); enterid(lip);
|
|
end;
|
|
until not find2([ident],fsys,+090);
|
|
end;
|
|
|
|
procedure typedefinition(fsys:sos);
|
|
var lip:ip;
|
|
begin fwptr:=nil; intypedec:=true;
|
|
repeat lip:=newident(types,nil,nil,+091);
|
|
if lip<>nil then
|
|
begin nextif(eqsy,+092);
|
|
lip^.idtype:=typ(fsys+[semicolon,ident]);
|
|
nextif(semicolon,+093); enterid(lip);
|
|
end;
|
|
until not find2([ident],fsys,+094);
|
|
assert sy<>ident;
|
|
while fwptr<>nil do
|
|
begin
|
|
id:=fwptr^.name; lip:=searchid([types]);
|
|
fwptr^.idtype^.eltype:=lip^.idtype; fwptr:=fwptr^.next
|
|
end;
|
|
intypedec:=false;
|
|
end;
|
|
|
|
procedure vardeclaration(fsys:sos);
|
|
var lip,hip,vip:ip; lsp:sp;
|
|
begin
|
|
repeat hip:=nil; lip:=nil;
|
|
repeat vip:=newident(vars,nil,nil,+095);
|
|
if vip<>nil then
|
|
begin enterid(vip); vip^.iflag:=[];
|
|
if lip=nil then hip:=vip else lip^.next:=vip; lip:=vip;
|
|
end;
|
|
until endofloop(fsys+[colon1,ident..packedsy],[ident],comma,+096); {+097}
|
|
nextif(colon1,+098);
|
|
lsp:=typ(fsys+[semicolon,ident]);
|
|
while hip<>nil do
|
|
begin hip^.idtype:=lsp;
|
|
if level<=1 then
|
|
hip^.vpos.ad:=posaddr(holeb,lsp,false)
|
|
else
|
|
hip^.vpos.ad:=negaddr(lsp);
|
|
hip:=hip^.next
|
|
end;
|
|
nextif(semicolon,+099);
|
|
until not find2([ident],fsys,+0100);
|
|
end;
|
|
|
|
procedure pfhead(fsys:sos;var fip:ip;var again:boolean;param:boolean);
|
|
forward;
|
|
|
|
procedure parlist(fsys:sos; slink:boolean; var tip:ip; var maxlb:integer);
|
|
var lastip,hip,lip,pip:ip; lsp,tsp:sp; iflag:iflagset; again:boolean;
|
|
begin tip:=nil; lastip:=nil;
|
|
maxlb:=0; if slink then maxlb:=sz_addr;
|
|
repeat {once for each formal-parameter-section}
|
|
if find1([ident,varsy,procsy,funcsy],fsys+[semicolon],+0101) then
|
|
begin
|
|
if (sy=procsy) or (sy=funcsy) then
|
|
begin
|
|
pfhead(fsys+[semicolon,ident,varsy,procsy,funcsy],hip,again,true);
|
|
hip^.pfpos.ad:=posaddr(maxlb,procptr,false);
|
|
hip^.pfkind:=formal; lip:=hip;
|
|
top:=top^.nlink; level:=level-1
|
|
end
|
|
else
|
|
begin hip:=nil; lip:=nil; iflag:=[assigned];
|
|
if sy=varsy then
|
|
begin iflag:=[refer,assigned,used]; insym end;
|
|
repeat pip:=newident(vars,nil,nil,+0102);
|
|
if pip<>nil then
|
|
begin enterid(pip); pip^.iflag:=iflag;
|
|
if lip=nil then hip:=pip else lip^.next:=pip; lip:=pip;
|
|
end;
|
|
iflag:=iflag+[samesect];
|
|
until endofloop(fsys+[semicolon,colon1],[ident],comma,+0103);
|
|
{+0104}
|
|
nextif(colon1,+0105);
|
|
if refer in iflag then
|
|
begin lsp:=vpartyp(fsys+[semicolon]); tsp:=lsp;
|
|
while formof(tsp,[carray]) do
|
|
begin tsp^.arpos.ad:=posaddr(maxlb,nilptr,false);
|
|
tsp:=tsp^.aeltype
|
|
end;
|
|
tsp:=nilptr;
|
|
end
|
|
else
|
|
begin lsp:=typid(+0106); tsp:=lsp end;
|
|
pip:=hip;
|
|
while pip<>nil do
|
|
begin pip^.vpos.ad:=posaddr(maxlb,tsp,false); pip^.idtype:=lsp;
|
|
pip:=pip^.next
|
|
end;
|
|
end;
|
|
if lastip=nil then tip:=hip else lastip^.next:=hip; lastip:=lip;
|
|
end;
|
|
until endofloop(fsys,[ident,varsy,procsy,funcsy],semicolon,+0107); {+0108}
|
|
end;
|
|
|
|
procedure pfhead; {forward declared}
|
|
var lip:ip; lsp:sp; lnp:np; kl:idclass;
|
|
begin lip:=nil; again:=false;
|
|
if sy=procsy then kl:=proc else
|
|
begin kl:=func; fsys:=fsys+[colon1,ident] end;
|
|
insym;
|
|
if sy<>ident then begin error(+0109); id:=spaces end;
|
|
if not param then lip:=searchsection(top^.fname);
|
|
if lip<>nil then
|
|
if (lip^.klass<>kl) or (lip^.pfkind<>forward) then errid(+0110,id) else
|
|
begin b.forwcount:=b.forwcount-1; again:=true end;
|
|
if again then insym else
|
|
begin lip:=newip(kl,id,nil,nil);
|
|
if sy=ident then begin enterid(lip); insym end;
|
|
lastpfno:=lastpfno+1; lip^.pfno:=lastpfno;
|
|
end;
|
|
level:=level+1;
|
|
new(lnp,blck); lnp^.occur:=blck; lnp^.nlink:=top; top:=lnp;
|
|
if again then lnp^.fname:=lip^.parhead else
|
|
begin lnp^.fname:=nil;
|
|
if find3(lparent,fsys,+0111) then
|
|
begin parlist(fsys+[rparent],lip^.pfpos.lv>1,lip^.parhead,lip^.maxlb);
|
|
nextif(rparent,+0112)
|
|
end;
|
|
end;
|
|
if (kl=func) and not again then
|
|
begin nextif(colon1,+0113); lsp:=typid(+0114);
|
|
if formof(lsp,[power..tag]) then
|
|
begin error(+0115); lsp:=nil end;
|
|
lip^.idtype:=lsp;
|
|
end;
|
|
fip:=lip;
|
|
end;
|
|
|
|
procedure pfdeclaration(fsys:sos);
|
|
var lip:ip; again,headonly:boolean; markp:^integer; lbp:bp; kind:kindofpf;
|
|
begin with b do begin
|
|
pfhead(fsys+[ident,semicolon,labelsy..beginsy],lip,again,false);
|
|
nextif(semicolon,+0116);
|
|
if find1([ident,labelsy..beginsy],fsys+[semicolon],+0117) then
|
|
begin headonly:=sy=ident;
|
|
if headonly then
|
|
begin kind:=standard;
|
|
if id='forward ' then kind:=forward else
|
|
if id='extern ' then kind:=extern else
|
|
if id='varargs ' then kind:=varargs else errid(+0118,id);
|
|
if kind<>standard then
|
|
begin insym; lip^.pfkind:=kind;
|
|
if kind=forward then
|
|
if again then errid(+0119,lip^.name) else
|
|
forwcount:=forwcount+1
|
|
else
|
|
begin lip^.pfpos.lv:=1; teststandard end
|
|
end;
|
|
end;
|
|
if not again then
|
|
if lip^.pfpos.lv<=1 then genpnam(ps_exp,lip) else genpnam(ps_inp,lip);
|
|
if not headonly then
|
|
begin lip^.pfkind:=actual;
|
|
#ifndef STANDARD
|
|
mark(markp);
|
|
#endif
|
|
new(lbp); lbp^:=b; nextbp:=lbp;
|
|
reglb:=0; minlb:=0; ilbno:=0; forwcount:=0; lchain:=nil;
|
|
block(fsys+[semicolon],lip);
|
|
b:=nextbp^;
|
|
#ifndef STANDARD
|
|
release(markp);
|
|
#endif
|
|
end;
|
|
end;
|
|
if not main then eofexpected:=forwcount=0;
|
|
nextif(semicolon,+0120);
|
|
level:=level-1; top:=top^.nlink;
|
|
end end;
|
|
|
|
{===================================================================}
|
|
|
|
procedure expression(fsys:sos); forward;
|
|
{this forward declaration cannot be avoided}
|
|
|
|
procedure selectarrayelement(fsys:sos);
|
|
var isp,lsp:sp;
|
|
begin
|
|
repeat loadaddr; isp:=nil;
|
|
if formof(a.asp,[arrays,carray]) then isp:=a.asp^.inxtype else
|
|
errasp(+0121);
|
|
lsp:=a.asp;
|
|
expression(fsys+[comma]); force(desub(isp),+0122);
|
|
{no range check}
|
|
if lsp<>nil then
|
|
begin a.packbit:=spack in lsp^.sflag;
|
|
descraddr(lsp^.arpos); lsp:=lsp^.aeltype
|
|
end;
|
|
a.asp:=lsp; a.ak:=indexed;
|
|
until endofloop(fsys,[notsy..lparent],comma,+0123); {+0124}
|
|
end;
|
|
|
|
procedure selector(fsys: sos; fip:ip; iflag:iflagset);
|
|
{selector computes the address of any kind of variable.
|
|
Four possibilities:
|
|
1.for direct accessable variables (fixed), a contains offset and level,
|
|
2.for indirect accessable variables (ploaded), the address is on the stack.
|
|
3.for array elements, the top of stack gives the index (one word).
|
|
The address of the array is beneath it.
|
|
4.for variables with address in direct accessible pointer variable (pfixed),
|
|
the offset and level of the pointer is stored in a.
|
|
If a.asp=nil then an error occurred else a.asp gives
|
|
the type of the variable.
|
|
}
|
|
var lip:ip;
|
|
begin inita(fip^.idtype,0);
|
|
case fip^.klass of
|
|
vars: with a do
|
|
begin pos:=fip^.vpos; if refer in fip^.iflag then ak:=pfixed end;
|
|
field:
|
|
begin a:=lastnp^.wa; fieldaddr(fip^.foffset); a.asp:=fip^.idtype end;
|
|
func: with a do
|
|
if fip^.pfkind=standard then errasp(+0125) else
|
|
if (fip^.pfpos.lv>=level-1) and (fip<>currproc) then error(+0126) else
|
|
if fip^.pfkind<>actual then error(+0127) else
|
|
begin pos:=fip^.pfpos; pos.lv:=pos.lv+1;
|
|
if sy=arrow then error(+0128);
|
|
end
|
|
end; {case}
|
|
if (sy=lbrack) or (sy=period) then iflag:=iflag+[noreg];
|
|
while find2([lbrack,period,arrow],fsys,+0129) do with a do
|
|
if sy=lbrack then
|
|
begin insym; selectarrayelement(fsys+[rbrack,lbrack,period,arrow]);
|
|
nextif(rbrack,+0130);
|
|
end else
|
|
if sy=period then
|
|
begin insym;
|
|
if sy<>ident then error(+0131) else
|
|
begin
|
|
if not formof(asp,[records]) then errasp(+0132) else
|
|
begin lip:=searchsection(asp^.fstfld);
|
|
if lip=nil then begin errid(+0133,id); asp:=nil end else
|
|
begin packbit:=spack in asp^.sflag;
|
|
fieldaddr(lip^.foffset); asp:=lip^.idtype
|
|
end
|
|
end;
|
|
insym
|
|
end
|
|
end
|
|
else
|
|
begin insym; iflag:=[used];
|
|
if asp<>nil then
|
|
if asp=zeroptr then errasp(+0134) else
|
|
if asp^.form=pointer then
|
|
begin
|
|
if ak=fixed then ak:=pfixed else
|
|
begin load; ak:=ploaded end;
|
|
asp:=asp^.eltype
|
|
end else
|
|
if asp^.form=files then
|
|
begin loadaddr; gensp(WDW,sz_addr); gencst(op_lfr,sz_addr);
|
|
asp:=asp^.filtype; ak:=ploaded; packbit:=true;
|
|
end
|
|
else errasp(+0135);
|
|
end;
|
|
fip^.iflag:=fip^.iflag+iflag;
|
|
end;
|
|
|
|
procedure variable(fsys:sos);
|
|
var lip: ip;
|
|
begin
|
|
if sy=ident then
|
|
begin lip:=searchid([vars,field]); insym;
|
|
selector(fsys,lip,[used,assigned,noreg])
|
|
end
|
|
else begin error(+0136); inita(nil,0) end;
|
|
end;
|
|
|
|
{===================================================================}
|
|
|
|
function plistequal(p1,p2:ip):boolean;
|
|
var ok:boolean; q1,q2:sp;
|
|
begin plistequal:=eqstruct(p1^.idtype,p2^.idtype);
|
|
p1:=p1^.parhead; p2:=p2^.parhead;
|
|
while (p1<>nil) and (p2<>nil) do
|
|
begin ok:=false;
|
|
if p1^.klass=p2^.klass then
|
|
if p1^.klass<>vars then ok:=plistequal(p1,p2) else
|
|
begin q1:=p1^.idtype; q2:=p2^.idtype; ok:=true;
|
|
while ok and formof(q1,[carray]) and formof(q2,[carray]) do
|
|
begin ok:=eqstruct(q1^.inxtype,q2^.inxtype);
|
|
q1:=q1^.aeltype; q2:=q2^.aeltype;
|
|
end;
|
|
if not (eqstruct(q1,q2) and
|
|
(p1^.iflag*[refer,samesect] = p2^.iflag*[refer,samesect]))
|
|
then ok:=false;
|
|
end;
|
|
if not ok then plistequal:=false;
|
|
p1:=p1^.next; p2:=p2^.next
|
|
end;
|
|
if (p1<>nil) or (p2<>nil) then plistequal:=false
|
|
end;
|
|
|
|
procedure callnonstandard(fsys:sos; moreargs:boolean; fip:ip);
|
|
var nxt,lip:ip; l0,l1,l2,l3,sz:integer; lsp,savasp:sp;
|
|
begin with a do begin
|
|
l0:=newmark; l1:=newmark; sz:=0; nxt:=fip^.parhead;
|
|
while moreargs do
|
|
begin
|
|
if nxt=nil then
|
|
begin if fip^.pfkind<>varargs then error(+0137);
|
|
expression(fsys); load; sz:=sz+sizeof(asp,wordmult)
|
|
end
|
|
else
|
|
begin lsp:=nxt^.idtype;
|
|
if nxt^.klass<>vars then {proc or func}
|
|
begin inita(procptr,0); sz:=sz+sz_proc;
|
|
if sy<>ident then error(+0138) else
|
|
begin lip:=searchid([nxt^.klass]); insym;
|
|
if lip^.pfkind=standard then error(+0139) else
|
|
if not plistequal(nxt,lip) then error(+0140)
|
|
else
|
|
begin pos:=lip^.pfpos;
|
|
if lip^.pfkind=formal then load else
|
|
begin
|
|
if lip^.pfpos.lv<=1 then gencst(op_zer,sz_addr) else
|
|
gencst(op_lxl,level-lip^.pfpos.lv);
|
|
genpnam(op_lpi,lip)
|
|
end
|
|
end
|
|
end
|
|
end
|
|
else if not (refer in nxt^.iflag) then {call by value}
|
|
begin expression(fsys); force(lsp,+0141);
|
|
sz:=sz+sizeof(asp,wordmult);
|
|
end
|
|
else {call by reference}
|
|
begin variable(fsys); loadaddr; sz:=sz+sz_addr;
|
|
if samesect in nxt^.iflag then lsp:=savasp else
|
|
begin savasp:=asp; l2:=newmark;
|
|
while formof(lsp,[carray])
|
|
and formof(asp,[arrays,carray]) do
|
|
if (compat(lsp^.inxtype,asp^.inxtype) > subeq) or
|
|
(lsp^.sflag<>asp^.sflag) then errasp(+0142) else
|
|
begin l3:=newmark; descraddr(asp^.arpos); exchange(l2,l3);
|
|
relmark(l3);
|
|
sz:=sz+sz_addr; asp:=asp^.aeltype; lsp:=lsp^.aeltype
|
|
end;
|
|
relmark(l2)
|
|
end;
|
|
if not eqstruct(asp,lsp) then errasp(+0143);
|
|
if packbit then errasp(+0144);
|
|
end;
|
|
nxt:=nxt^.next
|
|
end;
|
|
exchange(l0,l1);
|
|
relmark(l1);
|
|
l1:=newmark; moreargs:=find3(comma,fsys,+0145)
|
|
end;
|
|
relmark(l0); relmark(l1);
|
|
if nxt<>nil then error(+0146);
|
|
inita(procptr,0); pos:=fip^.pfpos;
|
|
if fip^.pfkind=formal then
|
|
with b do
|
|
begin load; ilbno:=ilbno+2;
|
|
gencst(op_exg,sz_addr);
|
|
gencst(op_dup,sz_addr);
|
|
gencst(op_zer,sz_addr);
|
|
genop(op_cmp);
|
|
gencst(op_zeq,ilbno-1);
|
|
gencst(op_exg,sz_addr);
|
|
genop(op_cai);
|
|
gencst(op_asp,sz_addr);
|
|
gencst(op_bra,ilbno);
|
|
newilb(ilbno-1);
|
|
gencst(op_asp,sz_addr);
|
|
genop(op_cai);
|
|
newilb(ilbno);
|
|
end
|
|
else
|
|
begin
|
|
if pos.lv>1 then
|
|
begin gencst(op_lxl,level-pos.lv); sz:=sz+sz_addr end;
|
|
genpnam(op_cal,fip)
|
|
end;
|
|
if sz<>0 then gencst(op_asp,sz);
|
|
asp:=fip^.idtype;
|
|
if asp<>nil then genasp(op_lfr);
|
|
if (fip^.pfkind = extern) and (opt['l'] <> off) then
|
|
begin genop(op_fil); argdlb(fildlb) end;
|
|
genlin
|
|
end end;
|
|
|
|
procedure fileaddr;
|
|
var la:attr;
|
|
begin la:=a; a:=fa; loadaddr; a:=la end;
|
|
|
|
procedure callr(l1,l2:integer);
|
|
var la:attr; m:libmnem;
|
|
begin with a do begin
|
|
la:=a; asp:=desub(asp); fileaddr; m:=RDI;
|
|
if asp<>intptr then
|
|
if asp=charptr then m:=RDC else
|
|
if asp=realptr then m:=RDR else
|
|
if asp=longptr then m:=RDL else errasp(+0147);
|
|
gensp(m,sz_addr); genasp(op_lfr);
|
|
if asp<>la.asp then checkbnds(la.asp);
|
|
a:=la; exchange(l1,l2); store;
|
|
end end;
|
|
|
|
procedure callw(fsys:sos; l1,l2:integer);
|
|
var m:libmnem; s:integer;
|
|
begin with a do begin
|
|
fileaddr; exchange(l1,l2); loadcheap; asp:=desub(asp);
|
|
if string(asp) then
|
|
begin gencst(op_loc,asp^.size); m:=WRS; s:=sz_addr+sz_word end
|
|
else
|
|
begin m:=WRI; s:=sizeof(asp,wordmult);
|
|
if asp<>intptr then
|
|
if asp=charptr then m:=WRC else
|
|
if asp=realptr then m:=WRR else
|
|
if asp=boolptr then m:=WRB else
|
|
if asp=zeroptr then m:=WRZ else
|
|
if asp=longptr then m:=WRL else errasp(+0148);
|
|
end;
|
|
if find3(colon1,fsys,+0149) then
|
|
begin expression(fsys+[colon1]); force(intptr,+0150);
|
|
m:=succ(m); s:=s+sz_int
|
|
end;
|
|
if find3(colon1,fsys,+0151) then
|
|
begin expression(fsys); force(intptr,+0152); s:=s+sz_int;
|
|
if m<>WSR then error(+0153) else m:=WRF;
|
|
end;
|
|
gensp(m,s+sz_addr);
|
|
end end;
|
|
|
|
procedure callrw(fsys:sos; lpar,w,ln:boolean);
|
|
var l1,l2,errno:integer; ftype,lsp,fsp:sp; (* savlb:integer;*) m:libmnem;
|
|
begin with b do begin (* savlb:=reglb; *) ftype:=textptr;
|
|
inita(textptr,argv[ord(w)].ad); a.pos.lv:=0; fa:=a;
|
|
if lpar then
|
|
begin l1:=newmark; if w then expression(fsys+[colon1]) else variable(fsys);
|
|
l2:=newmark;
|
|
if formof(a.asp,[files]) then
|
|
begin ftype:=a.asp;
|
|
if (a.ak<>fixed) and (a.ak<>pfixed) then
|
|
begin loadaddr; temporary(nilptr,reg_pointer);
|
|
store; a.ak:=pfixed
|
|
end;
|
|
fa:=a; {store does not change a}
|
|
if (sy<>comma) and not ln then error(+0154);
|
|
end
|
|
else
|
|
begin if iop[w]=nil then error(+0155);
|
|
if w then callw(fsys,l1,l2) else callr(l1,l2)
|
|
end;
|
|
relmark(l1); relmark(l2);
|
|
while find3(comma,fsys,+0156) do with a do
|
|
begin l1:=newmark;
|
|
if w then expression(fsys+[colon1]) else variable(fsys);
|
|
l2:=newmark;
|
|
if ftype=textptr then
|
|
if w then callw(fsys,l1,l2) else callr(l1,l2)
|
|
else
|
|
begin errno:=+0157; fsp:=ftype^.filtype;
|
|
if w then force(fsp,errno) else
|
|
begin store; lsp:=asp; relmark(l2); l2 := newmark end;
|
|
fileaddr; gensp(WDW,sz_addr); gencst(op_lfr,sz_addr);
|
|
ak:=ploaded; packbit:=true; asp:=fsp;
|
|
if w then store else
|
|
begin force(lsp,errno); exchange(l1,l2) end;
|
|
fileaddr; if w then m:=PUTX else m:=GETX; gensp(m,sz_addr)
|
|
end;
|
|
relmark(l1); relmark(l2);
|
|
end;
|
|
end
|
|
else
|
|
if not ln then error(+0158) else
|
|
if iop[w]=nil then error(+0159);
|
|
if ln then
|
|
begin if ftype<>textptr then error(+0160);
|
|
fileaddr; if w then m:=WLN else m:=RLN; gensp(m,sz_addr)
|
|
end;
|
|
(* reglb:=savlb *)
|
|
end end;
|
|
|
|
procedure callnd(fsys:sos);
|
|
label 1;
|
|
var lsp:sp; int:integer;
|
|
begin with a do begin
|
|
if asp=zeroptr then errasp(+0161) else asp:=asp^.eltype;
|
|
while find3(comma,fsys,+0162) do
|
|
begin
|
|
if asp<>nil then {asp of form record or variant}
|
|
if asp^.form=records then asp:=asp^.tagsp else
|
|
if asp^.form=variant then asp:=asp^.subtsp else errasp(+0163);
|
|
if asp=nil then constant(fsys,lsp,int) else
|
|
begin assert asp^.form=tag;
|
|
int:=cstinteger(fsys,asp^.tfldsp,+0164); lsp:=asp^.fstvar;
|
|
while lsp<>nil do
|
|
if lsp^.varval<>int then lsp:=lsp^.nxtvar else
|
|
begin asp:=lsp; goto 1 end;
|
|
end;
|
|
1: end;
|
|
genasp(op_loc)
|
|
end end;
|
|
|
|
procedure call(fsys: sos; fip: ip);
|
|
var lkey: standpf; lpar:boolean; lsp,sp1,sp2:sp;
|
|
m:libmnem; s:integer; b:byte;
|
|
begin with a do begin fsys:=fsys+[comma];
|
|
lpar:=find3(lparent,fsys,+0165); if lpar then fsys:=fsys+[rparent];
|
|
if fip^.pfkind<>standard then callnonstandard(fsys,lpar,fip) else
|
|
begin lkey:=fip^.key; m:=CLS; lsp:=nil;
|
|
if not lpar then
|
|
if lkey in [pput..prelease,fabs..fatn] then error(+0166);
|
|
if lkey in [pput..ppage,feof,feoln] then
|
|
begin s:=sz_addr;
|
|
if lpar then
|
|
begin variable(fsys); loadaddr end
|
|
else
|
|
begin asp:=textptr;
|
|
if iop[lkey=ppage]=nil then errasp(+0167) else
|
|
gencst(op_lae,argv[ord(lkey=ppage)].ad)
|
|
end;
|
|
if lkey in [pput..prewrite,ppage,feof,feoln] then
|
|
if not formof(asp,[files]) then
|
|
begin error(+0168); asp:=textptr end;
|
|
if lkey in [pnew,pdispose,pmark,prelease] then
|
|
if not formof(asp,[pointer]) then
|
|
begin error(+0169); asp:=nilptr end;
|
|
end;
|
|
case lkey of
|
|
pread, preadln, pwrite, pwriteln: {0,1,2,3 resp}
|
|
callrw(fsys,lpar,lkey>=pwrite,odd(ord(lkey)));
|
|
pput: m:=PUTX;
|
|
pget: m:=GETX;
|
|
ppage: m:=PAG;
|
|
preset: m:=OPN;
|
|
prewrite: m:=CRE;
|
|
pnew: m:=NEWX;
|
|
pdispose: m:=DIS;
|
|
ppack:
|
|
begin sp2:=asp; nextif(comma,+0170); expression(fsys); load;
|
|
lsp:=asp; nextif(comma,+0171); variable(fsys); loadaddr;
|
|
sp1:=asp; asp:=lsp; m:=PAC
|
|
end;
|
|
punpack:
|
|
begin sp1:=asp; nextif(comma,+0172); variable(fsys); loadaddr;
|
|
sp2:=asp; nextif(comma,+0173); expression(fsys); load;
|
|
m:=UNP
|
|
end;
|
|
pmark: m:=SAV;
|
|
prelease: m:=RST;
|
|
phalt:
|
|
begin m:=HLT; teststandard;
|
|
if lpar then lsp:=intptr else gencst(op_loc,0);
|
|
end;
|
|
feof: m:=EFL;
|
|
feoln: m:=ELN;
|
|
fodd, fchr: lsp:=intptr;
|
|
fpred: b:=op_dec;
|
|
fsucc: b:=op_inc;
|
|
fround: m:=RND;
|
|
fsin, fcos, fexp, fsqt, flog, fatn: lsp:=realptr;
|
|
fabs, fsqr, ford, ftrunc: ;
|
|
end;
|
|
if lpar then if lkey in [phalt,fabs..fatn] then
|
|
begin expression(fsys);
|
|
force(lsp,+0174); s:=sizeof(asp,wordmult)
|
|
end;
|
|
if lkey in [ppack,punpack,fabs..fodd] then
|
|
asp:=desub(asp);
|
|
case lkey of
|
|
ppage, feoln:
|
|
begin if asp<>textptr then error(+0175); asp:=boolptr end;
|
|
preset, prewrite:
|
|
begin s:=sz_addr+sz_word;
|
|
if asp=textptr then gencst(op_loc,0) else
|
|
gencst(op_loc,sizeof(asp^.filtype,wordpart));
|
|
end;
|
|
pnew, pdispose:
|
|
begin callnd(fsys); s:=sz_addr+sz_word end;
|
|
ppack, punpack:
|
|
begin s:=2*sz_addr+sz_int;
|
|
if formof(sp1,[arrays,carray])
|
|
and formof(sp2,[arrays,carray]) then
|
|
if (spack in (sp1^.sflag - sp2^.sflag)) and
|
|
eqstruct(sp1^.aeltype,sp2^.aeltype) and
|
|
eqstruct(desub(sp1^.inxtype),asp) and
|
|
eqstruct(desub(sp2^.inxtype),asp) then
|
|
begin descraddr(sp1^.arpos); descraddr(sp2^.arpos) end
|
|
else error(+0176)
|
|
else error(+0177)
|
|
end;
|
|
pmark, prelease: teststandard;
|
|
feof: asp:=boolptr;
|
|
fabs:
|
|
if asp=intptr then m:=ABI else
|
|
if asp=longptr then m:=ABL else
|
|
if asp=realptr then m:=ABR else errasp(+0178);
|
|
fsqr:
|
|
begin
|
|
if (asp=intptr) or (asp=longptr) then b:=op_mli else
|
|
if asp=realptr then begin b:=op_mlf; fltused:=true end
|
|
else errasp(+0179);
|
|
genasp(op_dup); genasp(b)
|
|
end;
|
|
ford:
|
|
begin if not nicescalar(asp) then errasp(+0180); asp:=intptr end;
|
|
fchr: checkbnds(charptr);
|
|
fpred, fsucc:
|
|
begin genop(b);
|
|
if nicescalar(asp) then genrck(asp) else errasp(+0181)
|
|
end;
|
|
fodd:
|
|
begin gencst(op_loc,1); asp:=boolptr; genasp(op_and) end;
|
|
ftrunc, fround: if asp<>realptr then errasp(+0182);
|
|
fsin: m:=SINX;
|
|
fcos: m:=COSX;
|
|
fexp: m:=EXPX;
|
|
fsqt: m:=SQT;
|
|
flog: m:=LOG;
|
|
fatn: m:=ATN;
|
|
phalt:s:=0;
|
|
pread, preadln, pwrite, pwriteln, pput, pget: ;
|
|
end;
|
|
if m<>CLS then
|
|
begin gensp(m,s);
|
|
if lkey>=feof then genasp(op_lfr)
|
|
end;
|
|
if (lkey=fround) or (lkey=ftrunc) then
|
|
opconvert(ri);
|
|
end;
|
|
if lpar then nextif(rparent,+0183);
|
|
end end;
|
|
|
|
{===================================================================}
|
|
|
|
procedure convert(fsp:sp; l1:integer);
|
|
{Convert tries to make the operands of some operator of the same type.
|
|
The operand types are given by fsp and a.asp. The resulting type
|
|
is put in a.asp.
|
|
l1 gives the lino of the first instruction of the right operand.
|
|
}
|
|
var l2:integer; ts:twostruct; lsp:sp;
|
|
begin with a do begin asp:=desub(asp);
|
|
ts:=compat(asp,fsp);
|
|
case ts of
|
|
eq,subeq:
|
|
;
|
|
il,ir,lr:
|
|
opconvert(ts);
|
|
es:
|
|
expandnullset(fsp);
|
|
li,ri,rl,se:
|
|
begin l2:=newmark; lsp:=asp; asp:=fsp;
|
|
convert(lsp,l1); exchange(l1,l2); relmark(l2); asp:=lsp
|
|
end;
|
|
noteq:
|
|
errasp(+0184);
|
|
end;
|
|
if asp=realptr then fltused:=true
|
|
end end;
|
|
|
|
procedure buildset(fsys:sos);
|
|
{This is a bad construct in pascal. Two objections:
|
|
- expr..expr very difficult to implement on most machines
|
|
- this construct makes it hard to implement sets of different size
|
|
}
|
|
const ncsb = 32; {tunable}
|
|
type byteset = set of 0..MB1;
|
|
var i,j,val1,val2,ncst,l1,l2,sz:integer;
|
|
cst1,cst2,cst12,varpart:boolean;
|
|
cstpart:array[1..ncsb] of byteset;
|
|
|
|
procedure genconstset(sz:integer);
|
|
{level 2: << buildset}
|
|
var i,j:integer;
|
|
|
|
function setcode(s:byteset):byte;
|
|
{level 3: << buildset}
|
|
var b,i,w:byte;
|
|
begin i:=0; w:=0; b:=1;
|
|
for i:=0 to MB1 do
|
|
begin if i in s then w:=w+b; b:=b+b end;
|
|
setcode := w;
|
|
end;
|
|
|
|
begin
|
|
i:=sz;
|
|
repeat
|
|
genop(op_loc); j:=i; i:=i-sz_word;
|
|
|
|
{the bytes of the next word to be loaded on the stack}
|
|
{are in cstpart[i+1] .. cstpart[j]}
|
|
while (cstpart[j] = []) and (j > i+1) do j:=j-1;
|
|
if j = i+1 then argcst(setcode(cstpart[j]))
|
|
else
|
|
begin
|
|
if (j = i+2) and ((sz_word <= 2) or not (MB1 in cstpart[j])) then put1(sp_cst2)
|
|
else begin j:=i+4; put1(sp_cst4) end;
|
|
for j:=i+1 to j do put1(setcode(cstpart[j]))
|
|
end;
|
|
until i = 0;
|
|
end;
|
|
|
|
procedure setexpr(fsys:sos; var c:boolean; var v:integer);
|
|
{level 2: << buildset}
|
|
var min:integer; lsp:sp;
|
|
begin with a do begin c:=false; v:=0; lsp:=asp;
|
|
expression(fsys); asp:=desub(asp);
|
|
if not eqstruct(asp,lsp^.elset) then
|
|
begin error(+0185); lsp:=nullset end;
|
|
if lsp=nullset then
|
|
begin
|
|
if bounded(asp) then bounds(asp,min,sz) else
|
|
if asp=intptr then sz:=iopt-1 else begin errasp(+0186); sz:=0 end;
|
|
sz:=sz div NB1 + 1; while sz mod sz_word <> 0 do sz:=sz+1;
|
|
if sz>sz_mset then errasp(+0187);
|
|
lsp:=newsp(power,sz); lsp^.elset:=asp
|
|
end;
|
|
if asp<>nil then if ak=cst then
|
|
if (pos.ad<0) or (pos.ad div NB1>=sizeof(lsp,wordmult)) then
|
|
error(+0188)
|
|
else if sz<=ncsb*sz_byte then
|
|
begin c:=true; v:=pos.ad end;
|
|
if not c then load; asp:=lsp
|
|
end end;
|
|
|
|
begin with a do begin {buildset}
|
|
varpart:=false; ncst:=0; asp:=nullset;
|
|
for i:=1 to ncsb do cstpart[i]:=[];
|
|
if find2([notsy..lparent],fsys,+0189) then
|
|
repeat l1:=newmark;
|
|
setexpr(fsys+[colon2,comma],cst1,val1); cst12:=cst1;
|
|
if find3(colon2,fsys+[comma,notsy..lparent],+0190) then
|
|
begin setexpr(fsys+[comma,notsy..lparent],cst2,val2);
|
|
cst12:=cst12 and cst2;
|
|
if not cst12 then
|
|
begin
|
|
if cst2 then gencst(op_loc,val2);
|
|
if cst1 then
|
|
begin l2:=newmark; gencst(op_loc,val1); exchange(l1,l2);
|
|
relmark(l2);
|
|
end;
|
|
l2:=newmark; genasp(op_zer); exchange(l1,l2);
|
|
relmark(l2);
|
|
genasp(op_loc); gensp(BTS,3*sz_word)
|
|
end;
|
|
end
|
|
else
|
|
if cst12 then val2:=val1 else genasp(op_set);
|
|
if cst12 then
|
|
for i:=val1 to val2 do
|
|
begin j:=i div NB1 + 1; ncst:=ncst+1;
|
|
cstpart[j]:=cstpart[j] + [i mod NB1]
|
|
end
|
|
else
|
|
if varpart then genasp(op_ior) else varpart:=true;
|
|
relmark(l1);
|
|
until endofloop(fsys,[notsy..lparent],comma,+0191); {+0192}
|
|
ak:=loaded;
|
|
if ncst>0 then
|
|
begin
|
|
genconstset(sizeof(asp,wordmult));
|
|
if varpart then genasp(op_ior);
|
|
end
|
|
else
|
|
if not varpart then genasp(op_zer); {empty set}
|
|
end end;
|
|
|
|
procedure factor(fsys: sos);
|
|
var lip:ip; lsp:sp;
|
|
begin with a do begin
|
|
asp:=nil; packbit:=false; ak:=loaded;
|
|
if find1([notsy..nilcst,lparent],fsys,+0193) then
|
|
case sy of
|
|
ident:
|
|
begin lip:=searchid([konst,vars,field,func,carrbnd]); insym;
|
|
case lip^.klass of
|
|
func: {call moves result to top stack}
|
|
begin call(fsys,lip); ak:=loaded; packbit:=false end;
|
|
konst:
|
|
begin asp:=lip^.idtype;
|
|
if nicescalar(asp) then {including asp=nil}
|
|
begin ak:=cst; pos.ad:=lip^.value end
|
|
else
|
|
begin ak:=ploaded; laedlb(abs(lip^.value));
|
|
if asp^.form=scalar then
|
|
begin load; if lip^.value<0 then negate end
|
|
else
|
|
if asp=zeroptr then ak:=loaded
|
|
end
|
|
end;
|
|
field,vars:
|
|
selector(fsys,lip,[used]);
|
|
carrbnd:
|
|
begin lsp:=lip^.idtype; assert formof(lsp,[carray]);
|
|
descraddr(lsp^.arpos); lsp:=lsp^.inxtype; asp:=desub(lsp);
|
|
if lip^.next=nil then ak:=ploaded {low bound} else
|
|
begin gencst(op_loi,2*sz_int); genasp(op_adi) end;
|
|
load; checkbnds(lsp);
|
|
end;
|
|
end {case}
|
|
end;
|
|
intcst:
|
|
begin asp:=intptr; ak:=cst; pos.ad:=val; insym end;
|
|
realcst:
|
|
begin asp:=realptr; ak:=ploaded; laedlb(val); insym end;
|
|
longcst:
|
|
begin asp:=longptr; ak:=ploaded; laedlb(val); insym end;
|
|
charcst:
|
|
begin asp:=charptr; ak:=cst; pos.ad:=val; insym end;
|
|
stringcst:
|
|
begin asp:=stringstruct; laedlb(val); insym;
|
|
if asp<>zeroptr then ak:=ploaded;
|
|
end;
|
|
nilcst:
|
|
begin insym; asp:=nilptr; genasp(op_zer); end;
|
|
lparent:
|
|
begin insym; expression(fsys+[rparent]); nextif(rparent,+0194) end;
|
|
notsy:
|
|
begin insym; factor(fsys); load; genop(op_teq); asp:=desub(asp);
|
|
if asp<>boolptr then errasp(+0195)
|
|
end;
|
|
lbrack:
|
|
begin insym; buildset(fsys+[rbrack]); nextif(rbrack,+0196) end;
|
|
end
|
|
end end;
|
|
|
|
procedure term(fsys:sos);
|
|
var lsy:symbol; lsp:sp; l1:integer; first:boolean;
|
|
begin with a,b do begin first:=true;
|
|
factor(fsys+[starsy..andsy]);
|
|
while find2([starsy..andsy],fsys,+0197) do
|
|
begin if first then begin load; first:=false end;
|
|
lsy:=sy; insym; l1:=newmark; lsp:=asp;
|
|
factor(fsys+[starsy..andsy]); load; convert(lsp,l1);
|
|
if asp<>nil then
|
|
case lsy of
|
|
starsy:
|
|
if (asp=intptr) or (asp=longptr) then genasp(op_mli) else
|
|
if asp=realptr then genasp(op_mlf) else
|
|
if asp^.form=power then genasp(op_and) else errasp(+0198);
|
|
slashsy:
|
|
begin
|
|
if (asp=intptr) or (asp=longptr) then
|
|
begin lsp:=asp;
|
|
convert(realptr,l1); {make real of right operand}
|
|
convert(lsp,l1); {make real of left operand}
|
|
end;
|
|
if asp=realptr then genasp(op_dvf) else errasp(+0199);
|
|
end;
|
|
divsy:
|
|
if (asp=intptr) or (asp=longptr) then genasp(op_dvi) else
|
|
errasp(+0200);
|
|
modsy:
|
|
begin
|
|
if asp=intptr then gensp(MDI,2*sz_int) else
|
|
if asp=longptr then gensp(MDL,2*sz_long) else errasp(+0201);
|
|
genasp(op_lfr);
|
|
end;
|
|
andsy:
|
|
if asp=boolptr then genasp(op_and) else errasp(+0202);
|
|
end; {case}
|
|
relmark(l1)
|
|
end {while}
|
|
end end;
|
|
|
|
procedure simpleexpression(fsys:sos);
|
|
var lsy:symbol; lsp:sp; l1:integer; signed,min,first:boolean;
|
|
begin with a do begin first:=true;
|
|
signed:=(sy=plussy) or (sy=minsy);
|
|
if signed then begin min:=sy=minsy; insym end else min:=false;
|
|
term(fsys + [minsy,plussy,orsy]); lsp:=desub(asp);
|
|
if signed then
|
|
if (lsp<>intptr) and (lsp<>realptr) and (lsp<>longptr) then
|
|
errasp(+0203)
|
|
else if min then
|
|
begin load; first:=false; asp:=lsp; negate end;
|
|
while find2([plussy,minsy,orsy],fsys,+0204) do
|
|
begin if first then begin load; first:=false end;
|
|
lsy:=sy; insym; l1:=newmark; lsp:=asp;
|
|
term(fsys+[minsy,plussy,orsy]); load; convert(lsp,l1);
|
|
if asp<>nil then
|
|
case lsy of
|
|
plussy:
|
|
if (asp=intptr) or (asp=longptr) then genasp(op_adi) else
|
|
if asp=realptr then genasp(op_adf) else
|
|
if asp^.form=power then genasp(op_ior) else errasp(+0205);
|
|
minsy:
|
|
if (asp=intptr) or (asp=longptr) then genasp(op_sbi) else
|
|
if asp=realptr then genasp(op_sbf) else
|
|
if asp^.form=power then begin genasp(op_com); genasp(op_and) end
|
|
else errasp(+0206);
|
|
orsy:
|
|
if asp=boolptr then genasp(op_ior) else errasp(+0207);
|
|
end; {case}
|
|
relmark(l1)
|
|
end {while}
|
|
end end;
|
|
|
|
procedure expression; { fsys:sos }
|
|
var lsy:symbol; lsp:sp; l1,l2:integer;
|
|
begin with a do begin l1:=newmark;
|
|
simpleexpression(fsys+[eqsy..insy]);
|
|
if find2([eqsy..insy],fsys,+0208) then
|
|
begin lsy:=sy; insym; lsp:=asp; loadcheap; l2:=newmark;
|
|
simpleexpression(fsys); loadcheap;
|
|
if lsy=insy then
|
|
begin
|
|
if not formof(asp,[power]) then errasp(+0209) else
|
|
if asp=nullset then genasp(op_and) else
|
|
{this effectively replaces the word on top of the
|
|
stack by the result of the 'in' operator: false }
|
|
if not (compat(lsp,asp^.elset) <= subeq) then errasp(+0210) else
|
|
begin exchange(l1,l2); genasp(op_inn) end
|
|
end
|
|
else
|
|
begin convert(lsp,l2);
|
|
if asp<>nil then
|
|
case asp^.form of
|
|
scalar:
|
|
if asp=realptr then genasp(op_cmf) else genasp(op_cmi);
|
|
pointer:
|
|
if (lsy=eqsy) or (lsy=nesy) then genop(op_cmp) else
|
|
errasp(+0211);
|
|
power:
|
|
case lsy of
|
|
eqsy,nesy: genasp(op_cms);
|
|
ltsy,gtsy: errasp(+0212);
|
|
lesy: {'a<=b' equivalent to 'a-b=[]'}
|
|
begin genasp(op_com); genasp(op_and); genasp(op_zer);
|
|
genasp(op_cms); lsy:=eqsy
|
|
end;
|
|
gesy: {'a>=b' equivalent to 'a=a+b'}
|
|
begin gencst(op_dup,2*sizeof(asp,wordmult));
|
|
genasp(op_asp); genasp(op_ior);
|
|
genasp(op_cms); lsy:=eqsy
|
|
end
|
|
end; {case}
|
|
arrays:
|
|
if string(asp) then
|
|
begin gencst(op_loc,asp^.size);
|
|
gensp(BCP,2*sz_addr+sz_word);
|
|
gencst(op_lfr,sz_word)
|
|
end
|
|
else errasp(+0213);
|
|
records: errasp(+0214);
|
|
files: errasp(+0215)
|
|
end; { case }
|
|
case lsy of
|
|
ltsy: genop(op_tlt);
|
|
lesy: genop(op_tle);
|
|
gtsy: genop(op_tgt);
|
|
gesy: genop(op_tge);
|
|
nesy: genop(op_tne);
|
|
eqsy: genop(op_teq)
|
|
end
|
|
end;
|
|
relmark(l2);
|
|
asp:=boolptr; ak:=loaded
|
|
end;
|
|
relmark(l1)
|
|
end end;
|
|
|
|
{===================================================================}
|
|
|
|
procedure statement(fsys:sos); forward;
|
|
{this forward declaration can be avoided}
|
|
|
|
procedure assignment(fsys:sos; fip:ip);
|
|
var la:attr; l1,l2:integer;
|
|
begin
|
|
l1:=newmark; selector(fsys+[becomes],fip,[assigned]); l2:=newmark;
|
|
la:=a; nextif(becomes,+0216);
|
|
expression(fsys); loadcheap; checkasp(la.asp,+0217);
|
|
exchange(l1,l2); a:=la;
|
|
relmark(l1); relmark(l2);
|
|
if not formof(la.asp,[arrays..records]) then store else
|
|
begin loadaddr;
|
|
if la.asp^.form<>carray then genasp(op_blm) else
|
|
begin descraddr(la.asp^.arpos); gensp(ASZ,sz_addr);
|
|
gencst(op_lfr,sz_word); gencst(op_bls,sz_word)
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure gotostatement;
|
|
{jumps into structured statements can give strange results. }
|
|
label 1;
|
|
var llp:lp; lbp:bp; diff:integer;
|
|
begin
|
|
if sy<>intcst then error(+0218) else
|
|
begin llp:=searchlab(b.lchain,val);
|
|
if llp<>nil then gencst(op_bra,llp^.labname) else
|
|
begin lbp:=b.nextbp; diff:=1;
|
|
while lbp<>nil do
|
|
begin llp:=searchlab(lbp^.lchain,val);
|
|
if llp<>nil then goto 1;
|
|
lbp:=lbp^.nextbp; diff:=diff+1;
|
|
end;
|
|
1: if llp=nil then errint(+0219,val) else
|
|
begin
|
|
if llp^.labdlb=0 then
|
|
begin dlbno:=dlbno+1; llp^.labdlb:=dlbno;
|
|
genop(ps_ina); argdlb(dlbno); {forward data reference}
|
|
end;
|
|
laedlb(llp^.labdlb);
|
|
if diff=level-1 then gencst(op_zer,sz_addr) else
|
|
gencst(op_lxl,diff);
|
|
gensp(GTO,2*sz_addr);
|
|
end;
|
|
end;
|
|
insym;
|
|
end
|
|
end;
|
|
|
|
procedure compoundstatement(fsys:sos; err:integer);
|
|
begin
|
|
repeat statement(fsys+[semicolon])
|
|
until endofloop(fsys,[beginsy..casesy],semicolon,err)
|
|
end;
|
|
|
|
procedure ifstatement(fsys:sos);
|
|
var lb1,lb2:integer;
|
|
begin with b do begin
|
|
expression(fsys+[thensy,elsesy]);
|
|
force(boolptr,+0220); ilbno:=ilbno+1; lb1:=ilbno; gencst(op_zeq,lb1);
|
|
nextif(thensy,+0221); statement(fsys+[elsesy]);
|
|
if find3(elsesy,fsys,+0222) then
|
|
begin ilbno:=ilbno+1; lb2:=ilbno; gencst(op_bra,lb2);
|
|
newilb(lb1); statement(fsys); newilb(lb2)
|
|
end
|
|
else newilb(lb1);
|
|
end end;
|
|
|
|
procedure casestatement(fsys:sos);
|
|
label 1;
|
|
type cip=^caseinfo;
|
|
caseinfo=record
|
|
next: cip;
|
|
csstart: integer;
|
|
cslab: integer
|
|
end;
|
|
var lsp:sp; head,p,q,r:cip; l0,l1:integer;
|
|
ilb1,ilb2,dlb,i,n,m,min,max:integer;
|
|
begin with b do begin
|
|
expression(fsys+[ofsy,semicolon,ident..plussy]); lsp:=a.asp; load;
|
|
if not nicescalar(desub(lsp)) then begin error(+0223); lsp:=nil end;
|
|
l0:=newmark; ilbno:=ilbno+1; ilb1:=ilbno;
|
|
nextif(ofsy,+0224); head:=nil; max:=-MI; min:=MI; n:=0;
|
|
repeat ilbno:=ilbno+1; ilb2:=ilbno; {label of current case}
|
|
repeat i:=cstinteger(fsys+[comma,colon1,semicolon],lsp,+0225);
|
|
if i>max then max:=i; if i<min then min:=i; n:=n+1;
|
|
q:=head; r:=nil; new(p);
|
|
while q<>nil do
|
|
begin {chain all cases in ascending order}
|
|
if q^.cslab>=i then
|
|
begin if q^.cslab=i then error(+0226); goto 1 end;
|
|
r:=q; q:=q^.next
|
|
end;
|
|
1: p^.next:=q; p^.cslab:=i; p^.csstart:=ilb2;
|
|
if r=nil then head:=p else r^.next:=p;
|
|
until endofloop(fsys+[colon1,semicolon],[ident..plussy],comma,+0227);
|
|
{+0228}
|
|
nextif(colon1,+0229); newilb(ilb2); statement(fsys+[semicolon]);
|
|
gencst(op_bra,ilb1);
|
|
until lastsemicolon(fsys,[ident..plussy],+0230); {+0231 +0232}
|
|
assert n<>0; newilb(ilb1); l1:=newmark;
|
|
dlb:=newdlb; genop(ps_rom); argnil;
|
|
if (max div 3) - (min div 3) < n then
|
|
begin argcst(min); argcst(max-min);
|
|
m:=op_csa;
|
|
while head<>nil do
|
|
begin
|
|
while head^.cslab>min do
|
|
begin argnil; min:=min+1 end;
|
|
argilb(head^.csstart); min:=min+1; head:=head^.next
|
|
end;
|
|
end
|
|
else
|
|
begin argcst(n); m:=op_csb;
|
|
while head<>nil do
|
|
begin argcst(head^.cslab);argilb(head^.csstart);head:=head^.next end;
|
|
end;
|
|
argend; laedlb(dlb); gencst(m,sz_word); exchange(l0,l1);
|
|
relmark(l0); relmark(l1)
|
|
end end;
|
|
|
|
procedure repeatstatement(fsys:sos);
|
|
var lb1: integer;
|
|
begin with b do begin
|
|
ilbno:=ilbno+1; lb1:=ilbno; newilb(lb1);
|
|
compoundstatement(fsys+[untilsy],+0233); {+0234}
|
|
nextif(untilsy,+0235); genlin;
|
|
expression(fsys); force(boolptr,+0236); gencst(op_zeq,lb1);
|
|
end end;
|
|
|
|
procedure whilestatement(fsys:sos);
|
|
var lb1,lb2: integer;
|
|
begin with b do begin
|
|
ilbno:=ilbno+1; lb1:=ilbno; newilb(lb1);
|
|
ilbno:=ilbno+1; lb2:=ilbno;
|
|
genlin; expression(fsys+[dosy]);
|
|
force(boolptr,+0237); gencst(op_zeq,lb2);
|
|
nextif(dosy,+0238); statement(fsys);
|
|
gencst(op_bra,lb1); newilb(lb2)
|
|
end end;
|
|
|
|
procedure forstatement(fsys:sos);
|
|
var lip:ip; tosym:boolean; endlab,looplab(* ,savlb *):integer;
|
|
av,at1,at2:attr; lsp:sp;
|
|
|
|
procedure forbound(fsys:sos; var fa:attr; fsp:sp);
|
|
begin
|
|
expression(fsys); fa:=a; force(fsp,+0239);
|
|
if fa.ak<>cst then
|
|
begin temporary(fsp,reg_any);
|
|
genasp(op_dup); fa:=a; store
|
|
end
|
|
end;
|
|
|
|
begin with b do begin (* savlb:=reglb; *) tosym:=false;
|
|
ilbno:=ilbno+1; looplab:=ilbno; ilbno:=ilbno+1; endlab:=ilbno;
|
|
inita(nil,0);
|
|
if sy<>ident then error(+0240) else
|
|
begin lip:=searchid([vars]); insym;
|
|
a.asp:=lip^.idtype; a.pos:=lip^.vpos;
|
|
lip^.iflag:=lip^.iflag+[used,assigned,loopvar];
|
|
if level>1 then
|
|
if (a.pos.ad>=0) or (a.pos.lv<>level) then
|
|
error(+0241);
|
|
end;
|
|
lsp:=desub(a.asp);
|
|
if not nicescalar(lsp) then begin errasp(+0242); lsp:=nil end;
|
|
av:=a; nextif(becomes,+0243);
|
|
forbound(fsys+[tosy,downtosy,notsy..lparent,dosy],at1,lsp);
|
|
if find1([tosy,downtosy],fsys+[notsy..lparent,dosy],+0244) then
|
|
begin tosym:=sy=tosy; insym end;
|
|
forbound(fsys+[dosy],at2,lsp);
|
|
if tosym then gencst(op_bgt,endlab) else gencst(op_blt,endlab);
|
|
a:=at1; force(av.asp,+0245); a:=av; store; newilb(looplab);
|
|
nextif(dosy,+0246); statement(fsys);
|
|
a:=av; load; a:=at2; load; gencst(op_beq,endlab);
|
|
a:=av; load; if tosym then genop(op_inc) else genop(op_dec);
|
|
a.asp:=lsp; checkbnds(av.asp); a:=av; store;
|
|
gencst(op_bra,looplab); newilb(endlab);
|
|
(* reglb:=savlb *)
|
|
end end;
|
|
|
|
procedure withstatement(fsys:sos);
|
|
var lnp,savtop:np; (* savlb:integer; *) pbit:boolean;
|
|
begin with b do begin
|
|
(* savlb:=reglb;*) savtop:=top;
|
|
repeat variable(fsys+[comma,dosy]);
|
|
if not formof(a.asp,[records]) then errasp(+0247) else
|
|
begin pbit:=spack in a.asp^.sflag;
|
|
new(lnp,wrec); lnp^.occur:=wrec; lnp^.fname:=a.asp^.fstfld;
|
|
if a.ak<>fixed then
|
|
begin loadaddr; temporary(nilptr,reg_pointer); store;
|
|
a.ak:=pfixed;
|
|
end;
|
|
a.packbit:=pbit; lnp^.wa:=a; lnp^.nlink:=top; top:=lnp;
|
|
end;
|
|
until endofloop(fsys+[dosy],[ident],comma,+0248); {+0249}
|
|
nextif(dosy,+0250); statement(fsys);
|
|
top:=savtop; (* reglb:=savlb; *)
|
|
end end;
|
|
|
|
procedure assertion(fsys:sos);
|
|
begin teststandard;
|
|
if opt['a']=off then
|
|
while not (sy in fsys) do insym
|
|
else
|
|
begin expression(fsys); force(boolptr,+0251);
|
|
gencst(op_loc,srcorig); gensp(ASS,2*sz_word);
|
|
end
|
|
end;
|
|
|
|
procedure statement; {fsys: sos}
|
|
var lip:ip; llp:lp; lsy:symbol;
|
|
begin
|
|
assert [labelsy..casesy,endsy] <= fsys;
|
|
assert [ident,intcst] * fsys = [];
|
|
if find2([intcst],fsys+[ident],+0252) then
|
|
begin llp:=searchlab(b.lchain,val);
|
|
if llp=nil then errint(+0253,val) else
|
|
begin if llp^.seen then errint(+0254,val) else llp^.seen:=true;
|
|
newilb(llp^.labname)
|
|
end;
|
|
insym; nextif(colon1,+0255);
|
|
end;
|
|
if find2([ident,beginsy..casesy],fsys,+0256) then
|
|
begin if giveline then if sy<>whilesy then genlin;
|
|
if sy=ident then
|
|
if id='assert ' then
|
|
begin insym; assertion(fsys) end
|
|
else
|
|
begin lip:=searchid([vars,field,func,proc]); insym;
|
|
if lip^.klass=proc then call(fsys,lip) else assignment(fsys,lip)
|
|
end
|
|
else
|
|
begin lsy:=sy; insym;
|
|
case lsy of
|
|
beginsy:
|
|
begin compoundstatement(fsys,+0257); {+0258}
|
|
nextif(endsy,+0259)
|
|
end;
|
|
gotosy:
|
|
gotostatement;
|
|
ifsy:
|
|
ifstatement(fsys);
|
|
casesy:
|
|
begin casestatement(fsys); nextif(endsy,+0260) end;
|
|
whilesy:
|
|
whilestatement(fsys);
|
|
repeatsy:
|
|
repeatstatement(fsys);
|
|
forsy:
|
|
forstatement(fsys);
|
|
withsy:
|
|
withstatement(fsys);
|
|
end
|
|
end;
|
|
end
|
|
end;
|
|
|
|
{===================================================================}
|
|
|
|
procedure body(fsys:sos; fip:ip);
|
|
var i,dlb,l0,l1,ssp:integer; llp:lp; spset:boolean;
|
|
begin with b do begin
|
|
{produce PRO}
|
|
genpnam(ps_pro,fip); argend;
|
|
gencst(ps_mes,ms_par);argcst(fip^.maxlb); argend;
|
|
l0:=newmark; dlb:=0; trace('procentr',fip,dlb);
|
|
{global labels}
|
|
llp:=lchain; spset:=false;
|
|
while llp<>nil do
|
|
begin
|
|
if llp^.labdlb<>0 then
|
|
begin
|
|
if not spset then
|
|
begin spset:=true;
|
|
gencst(ps_mes,ms_gto); argend;
|
|
temporary(nilptr,-1); ssp:=a.pos.ad;
|
|
gencst(op_lor,1); store
|
|
end;
|
|
argdlb(llp^.labdlb); lino:=lino+1; genop(ps_rom);
|
|
argilb(llp^.labname); argcst(ssp); argend;
|
|
end;
|
|
llp:=llp^.nextlp
|
|
end;
|
|
{the body itself}
|
|
currproc:=fip;
|
|
compoundstatement(fsys,+0261); {+0262}
|
|
trace('procexit',fip,dlb);
|
|
{undefined labels}
|
|
llp:=lchain;
|
|
while llp<>nil do
|
|
begin if not llp^.seen then errint(+0263,llp^.labval);
|
|
llp:=llp^.nextlp
|
|
end;
|
|
{finish and close files}
|
|
treewalk(top^.fname);
|
|
if level=1 then
|
|
begin l1:=newmark;
|
|
genop(op_fil); argdlb(fildlb); {temporarily}
|
|
dlb:=newdlb; gencst(ps_con,argc+1);
|
|
for i:=0 to argc do with argv[i] do
|
|
begin argcst(ad);
|
|
if (ad=-1) and (i>1) then errid(+0264,name)
|
|
end;
|
|
argend; gencst(op_lxl,0); laedlb(dlb); gencst(op_lae,0);
|
|
gencst(op_lxa,0); gensp(INI,4*sz_addr);
|
|
exchange(l0,l1); relmark(l1); gencst(op_loc,0); gensp(HLT,0)
|
|
end
|
|
else
|
|
begin inita(fip^.idtype,fip^.pfpos.ad);
|
|
if fip^.klass=func then
|
|
begin load;
|
|
if not (assigned in fip^.iflag) then
|
|
errid(-(+0265),fip^.name)
|
|
end;
|
|
genasp(op_ret)
|
|
end;
|
|
relmark(l0);
|
|
gencst(ps_end,-minlb)
|
|
end end;
|
|
|
|
{===================================================================}
|
|
|
|
procedure block; {forward declared}
|
|
begin with b do begin
|
|
assert [labelsy..withsy] <= fsys;
|
|
assert [ident,intcst,casesy,endsy,period] * fsys = [];
|
|
if find3(labelsy,fsys,+0266) then labeldeclaration(fsys);
|
|
if find3(constsy,fsys,+0267) then constdefinition(fsys);
|
|
if find3(typesy,fsys,+0268) then typedefinition(fsys);
|
|
if find3(varsy,fsys,+0269) then vardeclaration(fsys);
|
|
if fip=progp then
|
|
begin
|
|
if iop[true]<>nil then
|
|
begin argv[1].ad:=posaddr(holeb,textptr,false);
|
|
iop[true]^.vpos.ad:=argv[1].ad
|
|
end;
|
|
if iop[false]<>nil then
|
|
begin argv[0].ad:=posaddr(holeb,textptr,false);
|
|
iop[false]^.vpos.ad:=argv[0].ad
|
|
end;
|
|
genhol; genpnam(ps_exp,fip);
|
|
end; {externals are also extern for the main body}
|
|
fip^.pfpos.ad:=negaddr(fip^.idtype); {function result area}
|
|
while find2([procsy,funcsy],fsys,+0270) do pfdeclaration(fsys);
|
|
if forwcount<>0 then error(+0271); {forw proc not specified}
|
|
nextif(beginsy,+0272);
|
|
body(fsys+[casesy,endsy],fip);
|
|
nextif(endsy,+0273);
|
|
end end;
|
|
|
|
{===================================================================}
|
|
|
|
procedure programme(fsys:sos);
|
|
var stdin,stdout:boolean; p:ip;
|
|
begin
|
|
nextif(progsy,+0274); nextif(ident,+0275);
|
|
if find3(lparent,fsys+[semicolon],+0276) then
|
|
begin
|
|
repeat
|
|
if sy<>ident then error(+0277) else
|
|
begin stdin:=id='input '; stdout:=id='output ';
|
|
if stdin or stdout then
|
|
begin p:=newip(vars,id,textptr,nil);
|
|
enterid(p); iop[stdout]:=p;
|
|
end
|
|
else
|
|
if argc<maxargc then
|
|
begin
|
|
argc:=argc+1; argv[argc].name:=id; argv[argc].ad:=-1
|
|
end;
|
|
insym
|
|
end
|
|
until endofloop(fsys+[rparent,semicolon],[ident],comma,+0278); {+0279}
|
|
if argc>maxargc then
|
|
begin error(+0280); argc:=maxargc end;
|
|
nextif(rparent,+0281);
|
|
end;
|
|
nextif(semicolon,+0282);
|
|
block(fsys,progp);
|
|
if opt['l']<>off then
|
|
begin gencst(ps_mes,ms_src); argcst(srcorig); argend end;
|
|
eofexpected:=true; nextif(period,+0283);
|
|
end;
|
|
|
|
procedure compile;
|
|
var lsys:sos;
|
|
begin lsys:=[progsy,labelsy..withsy];
|
|
repeat eofexpected:=false;
|
|
main:=find2([progsy,labelsy,beginsy..withsy],lsys,+0284);
|
|
if main then programme(lsys) else
|
|
begin
|
|
if find3(constsy,lsys,+0285) then constdefinition(lsys);
|
|
if find3(typesy,lsys,+0286) then typedefinition(lsys);
|
|
if find3(varsy,lsys,+0287) then vardeclaration(lsys);
|
|
genhol;
|
|
while find2([procsy,funcsy],lsys,+0288) do pfdeclaration(lsys);
|
|
end;
|
|
error(+0289);
|
|
until false; { the only way out is the halt in nextln on eof }
|
|
end;
|
|
|
|
{===================================================================}
|
|
|
|
procedure init1;
|
|
var c:char;
|
|
begin
|
|
{reserved words}
|
|
rw[ 0]:='if '; rw[ 1]:='do '; rw[ 2]:='of ';
|
|
rw[ 3]:='to '; rw[ 4]:='in '; rw[ 5]:='or ';
|
|
rw[ 6]:='end '; rw[ 7]:='for '; rw[ 8]:='nil ';
|
|
rw[ 9]:='var '; rw[10]:='div '; rw[11]:='mod ';
|
|
rw[12]:='set '; rw[13]:='and '; rw[14]:='not ';
|
|
rw[15]:='then '; rw[16]:='else '; rw[17]:='with ';
|
|
rw[18]:='case '; rw[19]:='type '; rw[20]:='goto ';
|
|
rw[21]:='file '; rw[22]:='begin '; rw[23]:='until ';
|
|
rw[24]:='while '; rw[25]:='array '; rw[26]:='const ';
|
|
rw[27]:='label '; rw[28]:='repeat '; rw[29]:='record ';
|
|
rw[30]:='downto '; rw[31]:='packed '; rw[32]:='program ';
|
|
rw[33]:='function'; rw[34]:='procedur';
|
|
{corresponding symbols}
|
|
rsy[ 0]:=ifsy; rsy[ 1]:=dosy; rsy[ 2]:=ofsy;
|
|
rsy[ 3]:=tosy; rsy[ 4]:=insy; rsy[ 5]:=orsy;
|
|
rsy[ 6]:=endsy; rsy[ 7]:=forsy; rsy[ 8]:=nilcst;
|
|
rsy[ 9]:=varsy; rsy[10]:=divsy; rsy[11]:=modsy;
|
|
rsy[12]:=setsy; rsy[13]:=andsy; rsy[14]:=notsy;
|
|
rsy[15]:=thensy; rsy[16]:=elsesy; rsy[17]:=withsy;
|
|
rsy[18]:=casesy; rsy[19]:=typesy; rsy[20]:=gotosy;
|
|
rsy[21]:=filesy; rsy[22]:=beginsy; rsy[23]:=untilsy;
|
|
rsy[24]:=whilesy; rsy[25]:=arraysy; rsy[26]:=constsy;
|
|
rsy[27]:=labelsy; rsy[28]:=repeatsy; rsy[29]:=recordsy;
|
|
rsy[30]:=downtosy; rsy[31]:=packedsy; rsy[32]:=progsy;
|
|
rsy[33]:=funcsy; rsy[34]:=procsy;
|
|
{indices into rw to find reserved words fast}
|
|
frw[0]:= 0; frw[1]:= 0; frw[2]:= 6; frw[3]:=15; frw[4]:=22;
|
|
frw[5]:=28; frw[6]:=32; frw[7]:=33; frw[8]:=35;
|
|
{char types}
|
|
for c:=chr(0) to chr(maxcharord) do cs[c]:=others;
|
|
for c:='0' to '9' do cs[c]:=digit;
|
|
for c:='A' to 'Z' do cs[c]:=upper;
|
|
for c:='a' to 'z' do cs[c]:=lower;
|
|
cs[chr(ascnl)]:=layout;
|
|
cs[chr(ascvt)]:=layout;
|
|
cs[chr(ascff)]:=layout;
|
|
cs[chr(asccr)]:=layout;
|
|
{characters with corresponding chartype in ASCII order}
|
|
cs[chr(ascht)]:=tabch;
|
|
cs[' ']:=layout; cs['"']:=dquotech; cs['''']:=quotech;
|
|
cs['(']:=lparentch; cs[')']:=rparentch; cs['*']:=star;
|
|
cs['+']:=plusch; cs[',']:=commach; cs['-']:=minch;
|
|
cs['.']:=periodch; cs['/']:=slash; cs[':']:=colonch;
|
|
cs[';']:=semich; cs['<']:=lessch; cs['=']:=equal;
|
|
cs['>']:=greaterch; cs['[']:=lbrackch; cs[']']:=rbrackch;
|
|
cs['^']:=arrowch; cs['{']:=lbracech;
|
|
{single character symbols in chartype order}
|
|
csy[rparentch]:=rparent; csy[lbrackch]:=lbrack;
|
|
csy[rbrackch]:=rbrack; csy[commach]:=comma;
|
|
csy[semich]:=semicolon; csy[arrowch]:=arrow;
|
|
csy[plusch]:=plussy; csy[minch]:=minsy;
|
|
csy[slash]:=slashsy; csy[star]:=starsy;
|
|
csy[equal]:=eqsy;
|
|
{pascal library mnemonics}
|
|
lmn[ELN ]:='_eln'; lmn[EFL ]:='_efl'; lmn[CLS ]:='_cls';
|
|
lmn[WDW ]:='_wdw';
|
|
lmn[OPN ]:='_opn'; lmn[GETX]:='_get'; lmn[RDI ]:='_rdi';
|
|
lmn[RDC ]:='_rdc'; lmn[RDR ]:='_rdr'; lmn[RDL ]:='_rdl';
|
|
lmn[RLN ]:='_rln';
|
|
lmn[CRE ]:='_cre'; lmn[PUTX]:='_put'; lmn[WRI ]:='_wri';
|
|
lmn[WSI ]:='_wsi'; lmn[WRC ]:='_wrc'; lmn[WSC ]:='_wsc';
|
|
lmn[WRS ]:='_wrs'; lmn[WSS ]:='_wss'; lmn[WRB ]:='_wrb';
|
|
lmn[WSB ]:='_wsb'; lmn[WRR ]:='_wrr'; lmn[WSR ]:='_wsr';
|
|
lmn[WRL ]:='_wrl'; lmn[WSL ]:='_wsl';
|
|
lmn[WRF ]:='_wrf'; lmn[WRZ ]:='_wrz'; lmn[WSZ ]:='_wsz';
|
|
lmn[WLN ]:='_wln'; lmn[PAG ]:='_pag';
|
|
lmn[ABR ]:='_abr'; lmn[RND ]:='_rnd'; lmn[SINX]:='_sin';
|
|
lmn[COSX]:='_cos'; lmn[EXPX]:='_exp'; lmn[SQT ]:='_sqt';
|
|
lmn[LOG ]:='_log'; lmn[ATN ]:='_atn'; lmn[ABI ]:='_abi';
|
|
lmn[ABL ]:='_abl';
|
|
lmn[BCP ]:='_bcp'; lmn[BTS ]:='_bts'; lmn[NEWX]:='_new';
|
|
lmn[SAV ]:='_sav'; lmn[RST ]:='_rst'; lmn[INI ]:='_ini';
|
|
lmn[HLT ]:='_hlt'; lmn[ASS ]:='_ass'; lmn[GTO ]:='_gto';
|
|
lmn[PAC ]:='_pac'; lmn[UNP ]:='_unp'; lmn[DIS ]:='_dis';
|
|
lmn[ASZ ]:='_asz'; lmn[MDI ]:='_mdi'; lmn[MDL ]:='_mdl';
|
|
{scalar variables}
|
|
b.nextbp:=nil;
|
|
b.reglb:=0;
|
|
b.minlb:=0;
|
|
b.ilbno:=0;
|
|
b.forwcount:=0;
|
|
b.lchain:=nil;
|
|
srcchno:=0;
|
|
srclino:=1;
|
|
srcorig:=1;
|
|
lino:=0;
|
|
dlbno:=0;
|
|
holeb:=0;
|
|
argc:=1;
|
|
lastpfno:=0;
|
|
giveline:=true;
|
|
including:=false;
|
|
eofexpected:=false;
|
|
intypedec:=false;
|
|
fltused:=false;
|
|
seconddot:=false;
|
|
iop[false]:=nil;
|
|
iop[true]:=nil;
|
|
argv[0].ad:=-1;
|
|
argv[1].ad:=-1;
|
|
#ifdef NO_EXC
|
|
ohead := nil;
|
|
bcnt := 0;
|
|
mhead := nil;
|
|
#endif NO_EXC
|
|
end;
|
|
|
|
procedure init2;
|
|
var p:ip; k:idclass; j:standpf;
|
|
pfn:array[standpf] of idarr;
|
|
begin
|
|
{initialize the first name space}
|
|
new(top,blck); top^.occur:=blck; top^.nlink:=nil; top^.fname:=nil;
|
|
level:=0;
|
|
{undefined identifier pointers used by searchid}
|
|
for k:=types to func do
|
|
undefip[k]:=newip(k,spaces,nil,nil);
|
|
{names of standard procedures/functions}
|
|
pfn[pread ]:='read '; pfn[preadln ]:='readln ';
|
|
pfn[pwrite ]:='write '; pfn[pwriteln ]:='writeln ';
|
|
pfn[pput ]:='put '; pfn[pget ]:='get ';
|
|
pfn[ppage ]:='page '; pfn[preset ]:='reset ';
|
|
pfn[prewrite ]:='rewrite '; pfn[pnew ]:='new ';
|
|
pfn[pdispose ]:='dispose '; pfn[ppack ]:='pack ';
|
|
pfn[punpack ]:='unpack '; pfn[pmark ]:='mark ';
|
|
pfn[prelease ]:='release '; pfn[phalt ]:='halt ';
|
|
pfn[feof ]:='eof '; pfn[feoln ]:='eoln ';
|
|
pfn[fabs ]:='abs '; pfn[fsqr ]:='sqr ';
|
|
pfn[ford ]:='ord '; pfn[fchr ]:='chr ';
|
|
pfn[fpred ]:='pred '; pfn[fsucc ]:='succ ';
|
|
pfn[fodd ]:='odd '; pfn[ftrunc ]:='trunc ';
|
|
pfn[fround ]:='round '; pfn[fsin ]:='sin ';
|
|
pfn[fcos ]:='cos '; pfn[fexp ]:='exp ';
|
|
pfn[fsqt ]:='sqrt '; pfn[flog ]:='ln ';
|
|
pfn[fatn ]:='arctan ';
|
|
{standard procedure/function identifiers}
|
|
for j:=pread to phalt do
|
|
begin new(p,proc,standard); p^.klass:=proc;
|
|
p^.name:=pfn[j]; p^.pfkind:=standard; p^.key:=j; enterid(p);
|
|
end;
|
|
for j:=feof to fatn do
|
|
begin new(p,func,standard); p^.klass:=func; p^.idtype:=nil;
|
|
p^.name:=pfn[j]; p^.pfkind:=standard; p^.key:=j; enterid(p);
|
|
end;
|
|
{program identifier}
|
|
progp:=newip(proc,'m_a_i_n ',nil,nil);
|
|
end;
|
|
|
|
procedure init3;
|
|
var n:np; p,q:ip; i:integer; c:char;
|
|
#if EM_WSIZE == 2
|
|
is:packed array[1..imax] of char;
|
|
#endif
|
|
begin
|
|
for i:=0 to sz_last do readln(errors,sizes[i]);
|
|
if sz_int = 2 then maxintstring := max2bytes
|
|
else maxintstring := max4bytes;
|
|
if sz_long = 2 then maxlongstring := max2bytes
|
|
else maxlongstring := max4bytes;
|
|
gencst(ps_mes,ms_emx); argcst(sz_word); argcst(sz_addr); argend;
|
|
ix:=1;
|
|
while not eoln(errors) do
|
|
begin read(errors,c);
|
|
if ix<smax then begin strbuf[ix]:=c; ix:=ix+1 end
|
|
end;
|
|
readln(errors); strbuf[ix]:=chr(0);
|
|
for i:=1 to fnmax do
|
|
if i<ix then source[i]:=strbuf[i] else source[i]:=' ';
|
|
fildlb:=romstr(sp_scon,0);
|
|
{standard type pointers}
|
|
intptr :=newsp(scalar,sz_int);
|
|
realptr:=newsp(scalar,sz_real);
|
|
longptr:=newsp(scalar,sz_long);
|
|
charptr:=newsp(scalar,sz_char);
|
|
boolptr:=newsp(scalar,sz_bool);
|
|
nilptr :=newsp(pointer,sz_addr);
|
|
zeroptr:=newsp(pointer,sz_addr);
|
|
procptr:=newsp(records,sz_proc);
|
|
nullset:=newsp(power,sz_word); nullset^.elset:=nil;
|
|
textptr:=newsp(files,sz_head+sz_buff); textptr^.filtype:=charptr;
|
|
{standard type names}
|
|
enterid(newip(types,'integer ',intptr,nil));
|
|
enterid(newip(types,'real ',realptr,nil));
|
|
enterid(newip(types,'char ',charptr,nil));
|
|
enterid(newip(types,'boolean ',boolptr,nil));
|
|
enterid(newip(types,'text ',textptr,nil));
|
|
{standard constant names}
|
|
q:=nil; p:=newip(konst,'false ',boolptr,q); enterid(p);
|
|
q:=p; p:=newip(konst,'true ',boolptr,q); p^.value:=1; enterid(p);
|
|
boolptr^.fconst:=p;
|
|
{maxint of the target machine}
|
|
p:=newip(konst,'maxint ',intptr,nil);
|
|
if sz_int = 2 then p^.value:=MI2
|
|
else
|
|
#if EM_WSIZE == 4
|
|
p^.value := MI;
|
|
#else
|
|
{EM_WSIZE = 2, sz_int = 4}
|
|
begin p^.idtype:=longptr; ix:=imax; is:=max4bytes;
|
|
for i:=1 to ix do strbuf[i]:=is[i];
|
|
p^.value:=romstr(sp_icon,sz_int);
|
|
end;
|
|
#endif
|
|
enterid(p);
|
|
p:=newip(konst,spaces,charptr,nil); p^.value:=maxcharord;
|
|
charptr^.fconst:=p;
|
|
{new name space for user externals}
|
|
new(n,blck); n^.occur:=blck; n^.nlink:=top; n^.fname:=nil; top:=n;
|
|
{options}
|
|
for c:='a' to 'z' do begin opt[c]:=0; forceopt[c]:=false end;
|
|
opt['a']:=on;
|
|
opt['i']:=NB1*sz_iset;
|
|
opt['l']:=on;
|
|
opt['o']:=on;
|
|
opt['r']:=on;
|
|
sopt:=off;
|
|
end;
|
|
|
|
procedure init4;
|
|
begin
|
|
copt:=opt['c'];
|
|
dopt:=opt['d']; if EM_WSIZE < sz_int then dopt:=on;
|
|
iopt:=opt['i'];
|
|
sopt:=opt['s'];
|
|
if sopt<>off then begin copt:=off; dopt:=off end
|
|
else if opt['u']<>off then cs['_']:=lower;
|
|
if copt<>off then enterid(newip(types,'string ',zeroptr,nil));
|
|
if dopt<>off then enterid(newip(types,'long ',longptr,nil));
|
|
if opt['o']=off then begin gencst(ps_mes,ms_opt); argend end;
|
|
if dopt<>off then fltused:=true; {temporary kludge}
|
|
end;
|
|
|
|
begin {main body of pcompiler}
|
|
init1; {initialize tables and scalars}
|
|
init2; {initialize heap objects}
|
|
rewrite(em); put2(sp_magic); reset(errors);
|
|
init3; {size dependent initialization}
|
|
while not eof(errors) do
|
|
begin options(false); readln(errors) end;
|
|
rewrite(errors);
|
|
if not eof(input) then
|
|
begin nextch; insym;
|
|
init4; {option dependent initialization}
|
|
compile
|
|
end;
|
|
#ifdef STANDARD
|
|
9999: ;
|
|
#endif
|
|
end. {pcompiler}
|