mirror of
https://github.com/byteworksinc/ORCA-Pascal.git
synced 2024-08-19 19:29:03 +00:00
5080 lines
128 KiB
ObjectPascal
5080 lines
128 KiB
ObjectPascal
{$optimize 7}
|
|
{------------------------------------------------------------}
|
|
{ }
|
|
{ ORCA/Pascal 2 }
|
|
{ }
|
|
{ A native code compiler for the Apple IIGS. }
|
|
{ }
|
|
{ By Mike Westerfield }
|
|
{ }
|
|
{ Copyright March 1988 }
|
|
{ By the Byte Works, Inc. }
|
|
{ }
|
|
{------------------------------------------------------------}
|
|
|
|
unit parser;
|
|
|
|
interface
|
|
|
|
{$segment 'pascal'}
|
|
|
|
{$LibPrefix '0/obj/'}
|
|
|
|
uses PCommon, Scanner, CGI, Symbols, Call;
|
|
|
|
var
|
|
{structured constants:}
|
|
{---------------------}
|
|
blockbegsys: setofsys; {symbols that can start a block}
|
|
statbegsys: setofsys;
|
|
|
|
{------------------------------------------------------------}
|
|
|
|
procedure DoConstant (fsys: setofsys; var fsp: stp; var fvalu: valu);
|
|
|
|
{ compile a constant term }
|
|
{ }
|
|
{ parameters: }
|
|
{ fsys - following symbols }
|
|
{ fsp - (output) constant type }
|
|
{ fvalu - (output) constant value }
|
|
|
|
procedure Expression(fsys: setofsys; fprocp: ctp);
|
|
{compile an expression}
|
|
|
|
procedure InitScalars;
|
|
{Initialize global scalars}
|
|
|
|
procedure InitSets;
|
|
{initialize structured set constants}
|
|
|
|
procedure Selector (fsys: setofsys; fcp,fprocp: ctp; var isMethod: boolean);
|
|
|
|
{ handle indexing arrays, field selection, dereferencing of }
|
|
{ pointers, windowing files }
|
|
{ }
|
|
{ parameters: }
|
|
{ fsys - }
|
|
{ fcp - }
|
|
{ fprocp - identifier for program or program-level }
|
|
{ subroutine contining this statement }
|
|
{ isMethod - (returned) Did the selection resolve to a }
|
|
{ method call? If so, take no further action. }
|
|
|
|
procedure Programme(fsys:setofsys);
|
|
{Compile a program}
|
|
|
|
{------------------------------------------------------------}
|
|
|
|
implementation
|
|
|
|
const
|
|
digmax = 255; {maxcnt-1}
|
|
workspace = 16; {# bytes of work space on stack frame}
|
|
|
|
{-------------------------------------------------------------------------}
|
|
|
|
type
|
|
{case statement}
|
|
{--------------}
|
|
cip = ^caseinfo;
|
|
caseinfo = packed record
|
|
next: cip;
|
|
csstart: unsigned;
|
|
cslab: integer;
|
|
end;
|
|
|
|
var
|
|
{counters:}
|
|
{---------}
|
|
|
|
lastline: integer; {last line seen by gen}
|
|
firstlab: integer; {value for intlabel at start of segment}
|
|
|
|
|
|
{switches:}
|
|
{---------}
|
|
|
|
inseg: boolean; {tells if a segment is active}
|
|
inUses: boolean; {tells if a uses is being compiled}
|
|
doingCast: boolean; {casting a type?}
|
|
|
|
{pointers:}
|
|
{---------}
|
|
fextfilep: extfilep; {head of chain for external files}
|
|
thisType: pStringPtr; {pointer to name of current type}
|
|
|
|
|
|
{msc}
|
|
{---}
|
|
|
|
namFound: boolean; {has nam been found? {i.e., should line
|
|
#'s be generated?}
|
|
|
|
{objects}
|
|
{-------}
|
|
isMethod: boolean; {are we compiling a method?}
|
|
objectcp: ctp; {last procedure or function identifier}
|
|
objectName: pString; {object name (for methods)}
|
|
objectType: stp; {type of method's object}
|
|
|
|
{structured constants:}
|
|
{---------------------}
|
|
|
|
constbegsys,simptypebegsys,typebegsys,selectsys,facbegsys,
|
|
typedels: setofsys;
|
|
inputid,outputid,erroroutputid: pString; {commonly compared identifiers}
|
|
|
|
{----Parser and Semantic Analysis-----------------------------------------}
|
|
|
|
procedure DoConstant {fsys: setofsys; var fsp: stp; var fvalu: valu};
|
|
|
|
{ compile a constant term }
|
|
{ }
|
|
{ parameters: }
|
|
{ fsys - following symbols }
|
|
{ fsp - (output) constant type }
|
|
{ fvalu - (output) constant value }
|
|
|
|
var
|
|
lsp: stp;
|
|
lcp: ctp;
|
|
sign: (none,pos,neg);
|
|
lvp: csp;
|
|
|
|
begin {DoConstant}
|
|
lsp := nil;
|
|
fvalu.ival := 0;
|
|
if not(sy in constbegsys) then begin
|
|
Error(22);
|
|
Skip(fsys+constbegsys)
|
|
end; {if}
|
|
if sy in constbegsys then begin
|
|
if sy = stringconst then begin
|
|
if (sy = addop) and (op in [plus,minus]) then begin
|
|
Error(34);
|
|
InSymbol;
|
|
end; {if}
|
|
if lgth = 1 then
|
|
lsp := charptr
|
|
else begin
|
|
lsp := pointer(Malloc(sizeof(structure)));
|
|
with lsp^ do begin
|
|
aeltype := charptr;
|
|
inxtype := nil;
|
|
ispacked := pkpacked;
|
|
hasSFile := false;
|
|
size := lgth*packedcharsize;
|
|
form := arrays;
|
|
end; {with}
|
|
end; {else}
|
|
fvalu := val;
|
|
InSymbol;
|
|
end
|
|
else begin
|
|
sign := none;
|
|
if (sy = addop) and (op in [plus,minus]) then begin
|
|
if op = plus then sign := pos else sign := neg;
|
|
InSymbol;
|
|
end; {if}
|
|
if sy = ident then begin
|
|
searchid([konst],lcp);
|
|
if lcp <> nil then
|
|
with lcp^ do begin
|
|
lsp := idtype;
|
|
fvalu := values;
|
|
end {with}
|
|
else begin
|
|
fvalu.ival := 0;
|
|
lsp := intptr;
|
|
end; {else}
|
|
if sign = neg then
|
|
if (lsp = intptr) or (lsp = byteptr) then
|
|
fvalu.ival := -fvalu.ival
|
|
else if lsp = longptr then begin
|
|
lvp := pointer(Malloc(constantRec_longC));
|
|
lvp^.cclass := longC;
|
|
lvp^.lval := -fvalu.valp^.lval;
|
|
fvalu.valp := lvp;
|
|
end {else if}
|
|
else if IsReal(lsp) then begin
|
|
lvp := pointer(Malloc(constantRec_reel));
|
|
lvp^.cclass := reel;
|
|
lvp^.rval := -fvalu.valp^.rval;
|
|
fvalu.valp := lvp;
|
|
end; {else if}
|
|
if sign <> none then
|
|
if (lsp <> intptr) and (not IsReal(lsp)) and
|
|
(lsp <> byteptr) and (lsp <> longptr) then
|
|
Error(34);
|
|
InSymbol;
|
|
end {if}
|
|
else if sy = intconst then begin
|
|
if sign = neg then
|
|
val.ival := -val.ival;
|
|
lsp := intptr;
|
|
fvalu := val;
|
|
InSymbol;
|
|
end {else if}
|
|
else if sy = realconst then begin
|
|
if sign = neg then
|
|
val.valp^.rval := -val.valp^.rval;
|
|
lsp := realptr;
|
|
fvalu := val;
|
|
InSymbol;
|
|
end {else if}
|
|
else if sy = longintconst then begin
|
|
if sign = neg then
|
|
val.valp^.lval := -val.valp^.lval;
|
|
lsp := longptr;
|
|
fvalu := val;
|
|
InSymbol;
|
|
end {else if}
|
|
else begin
|
|
Error(35);
|
|
Skip(fsys);
|
|
end {else if}
|
|
end; {else}
|
|
if not (sy in fsys) then begin
|
|
Error(6);
|
|
Skip(fsys);
|
|
end; {if}
|
|
end; {if}
|
|
fsp := lsp;
|
|
end; {DoConstant}
|
|
|
|
|
|
procedure CheckUses(var id: pString; sym: symbol);
|
|
{make sure this name has not been used from another level}
|
|
|
|
label 1;
|
|
|
|
var
|
|
p: lptr; {work pointer for traversing list}
|
|
lcp: ctp; {work pointer for checking fwd ptrs}
|
|
|
|
begin {CheckUses}
|
|
p := display[top].labsused;
|
|
while p <> nil do begin
|
|
if CompNames(p^.name^,id) = 0 then begin
|
|
Error(18);
|
|
goto 1;
|
|
end;
|
|
p := p^.next;
|
|
end;
|
|
if sym <> typesy then begin
|
|
lcp := fwptr;
|
|
while lcp <> nil do begin
|
|
if CompNames(lcp^.name^,id) = 0 then begin
|
|
Error(18);
|
|
goto 1;
|
|
end;
|
|
lcp := lcp^.next;
|
|
end;
|
|
end;
|
|
1:
|
|
end; {CheckUses}
|
|
|
|
procedure ExportUses;
|
|
{uses from more than one level back are exported to the previous level}
|
|
|
|
label 1;
|
|
|
|
var
|
|
p,q,r: lPtr; {for moveing used id list up}
|
|
|
|
begin {ExportUses}
|
|
p := display[top].labsused; {check all labels in curent list}
|
|
while p <> nil do begin
|
|
if p^.disx < top-1 then begin {if they are from more than one level }
|
|
q := display[top-1].labsused; { back, they must be in the last list }
|
|
while q <> nil do begin {skip if the label is already in the }
|
|
if q^.name = p^.name then { last list }
|
|
goto 1;
|
|
q := q^.next;
|
|
end; {while}
|
|
new(r); {insert in the last list}
|
|
r^.next := display[top-1].labsused;
|
|
display[top-1].labsused := r;
|
|
r^.name := p^.name;
|
|
r^.disx := p^.disx;
|
|
end; {if}
|
|
p := p^.next;
|
|
end; {while}
|
|
1:
|
|
end; {ExportUses}
|
|
|
|
|
|
procedure ProcDeclaration (fsy: symbol; fsys: setofsys;
|
|
isObject, compilebody: boolean; var foundbody: boolean); forward;
|
|
|
|
{ Procedure/function declaration }
|
|
|
|
|
|
procedure Typ (fsys: setofsys; var fsp: stp; var fsize: addrrange;
|
|
isType: boolean);
|
|
|
|
{ compile a type definition }
|
|
{ }
|
|
{ parameters: }
|
|
{ fsys - follow symbols }
|
|
{ fsp - }
|
|
{ fsize - }
|
|
{ isType - is this the root level of a type declaration? }
|
|
|
|
var
|
|
lsp,lsp1,lsp2: stp;
|
|
oldtop: disprange; {display level on entry}
|
|
ttop: disprange; {temp display level}
|
|
lcp, lcp2: ctp;
|
|
lsize,disp1: addrrange;
|
|
lmin,lmax: longint;
|
|
ispacked: packedkinds;
|
|
test: boolean;
|
|
lvalu: valu;
|
|
len: integer; {string length}
|
|
l1,l2,l3: longint; {used to compute array size}
|
|
lval: record {used to convert between types}
|
|
case boolean of
|
|
true : (long: longint);
|
|
false: (lsw: integer; msw: integer);
|
|
end;
|
|
|
|
|
|
procedure Duplicate (var ncp: ctp; ocp: ctp);
|
|
|
|
{ Duplicate a field list }
|
|
{ }
|
|
{ parameters: }
|
|
{ ncp - (output) new (copied) identifier }
|
|
{ ocp - identifier to copy }
|
|
|
|
begin {Duplicate}
|
|
if ocp <> nil then begin
|
|
ncp := pointer(Malloc(sizeof(identifier)));
|
|
ncp^ := ocp^;
|
|
Duplicate(ncp^.llink, ocp^.llink);
|
|
Duplicate(ncp^.rlink, ocp^.rlink);
|
|
end; {if}
|
|
end; {Dulpicate}
|
|
|
|
|
|
procedure SimpleType (fsys:setofsys; var fsp:stp; var fsize:addrrange);
|
|
|
|
{ Compile a simple type }
|
|
{ }
|
|
{ parameters: }
|
|
{ fsys - }
|
|
{ fsp - }
|
|
{ fsize - }
|
|
|
|
var
|
|
lsp,lsp1: stp;
|
|
lcp,lcp1: ctp;
|
|
ttop: disprange;
|
|
lcnt: integer;
|
|
lvalu: valu;
|
|
len: integer; {string length}
|
|
|
|
begin {SimpleType}
|
|
fsize := 1;
|
|
if not (sy in simptypebegsys) then begin
|
|
Error(1);
|
|
Skip(fsys + simptypebegsys);
|
|
end; {if}
|
|
if sy in simptypebegsys then begin
|
|
|
|
{enumerations}
|
|
if sy = lparent then begin
|
|
ttop := top; {decl. consts local to innermost block}
|
|
while display[top].occur <> blck do
|
|
top := top - 1;
|
|
lsp := pointer(Malloc(sizeof(structure)));
|
|
with lsp^ do begin
|
|
size := intsize;
|
|
form := scalar;
|
|
hasSFile := false;
|
|
scalkind := declared;
|
|
end; {with}
|
|
lcp1 := nil;
|
|
lcnt := 0;
|
|
repeat
|
|
InSymbol;
|
|
if sy = ident then begin
|
|
lcp := pointer(Malloc(sizeof(identifier)));
|
|
with lcp^ do begin
|
|
len := ord(id[0])+2;
|
|
name := pointer(Malloc(len));
|
|
CopyString(name^,id,len);
|
|
idtype := lsp;
|
|
next := lcp1;
|
|
values.ival := lcnt;
|
|
klass := konst;
|
|
hasIFile := idtype^.hasSFile;
|
|
end;
|
|
CheckUses(lcp^.name^,constsy);
|
|
EnterId(lcp);
|
|
lcnt := lcnt + 1;
|
|
lcp1 := lcp; InSymbol
|
|
end
|
|
else Error(2);
|
|
if not (sy in fsys + [comma,rparent]) then begin
|
|
Error(6);
|
|
Skip(fsys + [comma,rparent]);
|
|
end;
|
|
until sy <> comma;
|
|
lsp^.fconst := lcp1;
|
|
top := ttop;
|
|
Match(rparent,4);
|
|
end
|
|
|
|
{named types, subranges}
|
|
else begin
|
|
if sy = ident then begin
|
|
SearchID([types,konst],lcp);
|
|
if lcp^.name = thisType then
|
|
Error(10);
|
|
InSymbol;
|
|
if lcp^.klass = konst then begin
|
|
lsp := pointer(Malloc(sizeof(structure)));
|
|
with lsp^, lcp^ do begin
|
|
rangetype := idtype;
|
|
form := subrange;
|
|
hasSFile := false;
|
|
if rangetype = longptr then begin
|
|
min := values.valp^.lval;
|
|
size := longsize;
|
|
end {if}
|
|
else begin
|
|
min := values.ival;
|
|
size := intsize;
|
|
end; {else}
|
|
end;
|
|
Match(dotdot,83);
|
|
DoConstant(fsys,lsp1,lvalu);
|
|
if lsp1 = longptr then
|
|
lsp^.max := lvalu.valp^.lval
|
|
else
|
|
lsp^.max := lvalu.ival;
|
|
if lsp^.rangetype <> lsp1 then
|
|
if (lsp^.rangetype = intptr) and (lsp1 = longptr) then begin
|
|
lsp^.rangetype := longptr;
|
|
lsp^.size := longsize;
|
|
end {if}
|
|
else if (lsp^.rangetype <> longptr) or (lsp1 <> intptr) then
|
|
Error(36);
|
|
end
|
|
else begin
|
|
lsp := lcp^.idtype;
|
|
if lsp <> nil then fsize := lsp^.size;
|
|
if iso then
|
|
if (lsp = longptr) or (lsp = byteptr) then Error(112);
|
|
end
|
|
end {sy = ident}
|
|
else begin
|
|
lsp := pointer(Malloc(sizeof(structure)));
|
|
DoConstant(fsys + [dotdot],lsp1,lvalu);
|
|
with lsp^ do begin
|
|
form := subrange;
|
|
hasSFile := false;
|
|
rangetype:=lsp1;
|
|
if rangetype = longptr then begin
|
|
min := lvalu.valp^.lval;
|
|
size := longsize;
|
|
end {if}
|
|
else begin
|
|
min := lvalu.ival;
|
|
size := intsize;
|
|
end; {else}
|
|
end;
|
|
Match(dotdot,83);
|
|
DoConstant(fsys,lsp1,lvalu);
|
|
if lsp1 = longptr then
|
|
lsp^.max := lvalu.valp^.lval
|
|
else
|
|
lsp^.max := lvalu.ival;
|
|
if lsp^.rangetype <> lsp1 then
|
|
if (lsp^.rangetype = intptr) and (lsp1 = longptr) then begin
|
|
lsp^.rangetype := longptr;
|
|
lsp^.size := longsize;
|
|
end {if}
|
|
else if (lsp^.rangetype <> longptr) or (lsp1 <> intptr) then
|
|
Error(36);
|
|
end;
|
|
if lsp <> nil then
|
|
with lsp^ do
|
|
if form = subrange then
|
|
if rangetype <> nil then
|
|
if IsReal(rangetype) or IsString(rangetype) then
|
|
Error(73)
|
|
else if min > max then
|
|
Error(31)
|
|
end;
|
|
fsp := lsp;
|
|
if not (sy in fsys) then begin
|
|
Error(6);
|
|
Skip(fsys)
|
|
end; {if}
|
|
end
|
|
else fsp := nil
|
|
end; {SimpleType}
|
|
|
|
|
|
procedure FieldList (fsys: setofsys; var frecvar: stp; var hasFile: boolean;
|
|
isObject: boolean);
|
|
|
|
{ compile a field list }
|
|
{ }
|
|
{ parameters: }
|
|
{ fsys - following symbols }
|
|
{ frecvar - }
|
|
{ hasFile - }
|
|
{ isObject - is this an object? (or a record) }
|
|
|
|
label 1;
|
|
|
|
var
|
|
lcp,lcp1,nxt,nxt1,inst: ctp;
|
|
lsp,lsp1,lsp2,lsp3,lsp4: stp;
|
|
minsize,maxsize,lsize: addrrange;
|
|
lvalu: valu;
|
|
numcase: longint;
|
|
max,min: longint;
|
|
tHasFile: boolean; {tracks files in the field list}
|
|
len: integer; {length of a string}
|
|
hasId: boolean; {does the case have an attached id?}
|
|
|
|
begin {FieldList}
|
|
lsp := nil;
|
|
hasFile := false;
|
|
if not (sy in fsys+[ident,casesy]) then begin
|
|
Error(19);
|
|
Skip(fsys + [ident,casesy]);
|
|
end;
|
|
while sy = ident do begin
|
|
nxt := nil;
|
|
nxt1 := nil;
|
|
repeat
|
|
if sy = ident then begin
|
|
lcp := pointer(Malloc(sizeof(identifier)));
|
|
with lcp^ do begin
|
|
len := ord(id[0])+2;
|
|
name := pointer(Malloc(len));
|
|
CopyString(name^,id,len);
|
|
idtype := nil;
|
|
next := nil;
|
|
klass := field;
|
|
fldvar := false;
|
|
hasIFile := false;
|
|
end;
|
|
if nxt1 <> nil then
|
|
nxt1^.next := lcp;
|
|
nxt1 := lcp;
|
|
if nxt = nil then
|
|
nxt := lcp;
|
|
EnterId(lcp);
|
|
InSymbol;
|
|
end
|
|
else Error(2);
|
|
if not (sy in [comma,colon]) then begin
|
|
Error(6);
|
|
Skip(fsys + [comma,colon,semicolon,casesy])
|
|
end; {if}
|
|
test := sy <> comma;
|
|
if not test then InSymbol;
|
|
until test;
|
|
Match(colon,5);
|
|
Typ(fsys + [casesy,semicolon], lsp, lsize, false);
|
|
hasFile := hasFile or lsp^.hasSFile;
|
|
while nxt <> nil do
|
|
with nxt^ do begin
|
|
idtype := lsp;
|
|
fldaddr := disp1;
|
|
nxt := next;
|
|
disp1 := disp1 + lsize;
|
|
end;
|
|
while sy = semicolon do begin
|
|
InSymbol;
|
|
if not (sy in fsys + [ident,casesy,semicolon]) then begin
|
|
Error(19);
|
|
Skip(fsys + [ident,casesy]);
|
|
end;
|
|
end;
|
|
end; {while sy = ident}
|
|
if sy = casesy then begin
|
|
if isObject then
|
|
Error(123);
|
|
hasId := false;
|
|
lsp := pointer(Malloc(sizeof(structure)));
|
|
with lsp^ do begin
|
|
tagfieldp := nil;
|
|
fstvar := nil;
|
|
form := tagfld;
|
|
hasSFile := false;
|
|
end;
|
|
frecvar := lsp;
|
|
InSymbol;
|
|
if sy = ident then begin
|
|
lcp := pointer(Malloc(sizeof(identifier)));
|
|
with lcp^ do begin
|
|
len := ord(id[0])+2;
|
|
name := pointer(Malloc(len));
|
|
CopyString(name^,id,len);
|
|
idtype := nil;
|
|
klass:=field;
|
|
next := nil;
|
|
fldaddr := disp1;
|
|
fldvar := true;
|
|
hasIFile := false;
|
|
end;
|
|
InSymbol;
|
|
if sy = colon then begin
|
|
InSymbol;
|
|
hasId := true;
|
|
if sy <> ident then begin
|
|
Error(2);
|
|
Skip(fsys + [ofsy,lparent]);
|
|
goto 1;
|
|
end; {if sy <> ident}
|
|
EnterId(lcp);
|
|
end
|
|
else begin
|
|
id := lcp^.name^;
|
|
if sy <> ofsy then Error(8);
|
|
end;
|
|
SearchID([types], lcp1);
|
|
lsp1 := lcp1^.idtype;
|
|
if lsp1 <> nil then begin
|
|
lcp^.fldaddr := disp1;
|
|
if hasId then
|
|
disp1 := disp1+lsp1^.size;
|
|
if lsp1^.form <= subrange then begin
|
|
if IsReal(lsp1) then
|
|
Error(39)
|
|
else if (lsp1 = intptr) or (lsp1 = longptr) then begin
|
|
Error(111);
|
|
numcase := maxint;
|
|
end
|
|
else begin
|
|
GetBounds(lsp1,min,max);
|
|
if (max >= 0) and (min <= 0) then
|
|
if max < (maxint+min) then
|
|
numcase := max-min+1
|
|
else begin
|
|
Error(111);
|
|
numcase := maxint;
|
|
end
|
|
else
|
|
numcase := max-min+1
|
|
end;
|
|
lcp^.idtype := lsp1;
|
|
lsp^.tagfieldp := lcp;
|
|
end
|
|
else
|
|
Error(39);
|
|
end;
|
|
if sy = ident then InSymbol;
|
|
end
|
|
else begin
|
|
Error(2);
|
|
Skip(fsys + [ofsy,lparent]);
|
|
end;
|
|
1: lsp^.size := disp1;
|
|
Match(ofsy,8);
|
|
lsp1 := nil;
|
|
minsize := disp1;
|
|
maxsize := disp1;
|
|
repeat
|
|
lsp2 := nil;
|
|
if not (sy in fsys + [semicolon]) then begin
|
|
repeat
|
|
DoConstant(fsys + [comma,colon,lparent],lsp3,lvalu);
|
|
if lsp^.tagfieldp <> nil then
|
|
if not CompTypes(lsp^.tagfieldp^.idtype,lsp3) then
|
|
Error(40);
|
|
lsp3 := pointer(Malloc(sizeof(structure)));
|
|
numcase := numcase-1;
|
|
with lsp3^ do begin
|
|
nxtvar := lsp1;
|
|
subvar := lsp2;
|
|
varval := lvalu.ival;
|
|
form := variant;
|
|
hasSFile := false;
|
|
end;
|
|
lsp4 := lsp1;
|
|
while lsp4 <> nil do
|
|
with lsp4^ do begin
|
|
if varval = lvalu.ival then Error(94);
|
|
lsp4 := nxtvar;
|
|
end;
|
|
lsp1 := lsp3;
|
|
lsp2 := lsp3;
|
|
test := sy <> comma;
|
|
if not test then InSymbol;
|
|
until test;
|
|
Match(colon,5);
|
|
Match(lparent,9);
|
|
FieldList(fsys + [rparent, semicolon], lsp2, tHasFile, false);
|
|
hasFile := hasFile or tHasFile;
|
|
if disp1 > maxsize then maxsize := disp1;
|
|
while lsp3 <> nil do begin
|
|
lsp4 := lsp3^.subvar;
|
|
lsp3^.subvar := lsp2;
|
|
lsp3^.size := disp1;
|
|
lsp3 := lsp4;
|
|
end;
|
|
Match(rparent,4);
|
|
if not (sy in fsys + [semicolon]) then begin
|
|
Error(6);
|
|
Skip(fsys + [semicolon]);
|
|
end;
|
|
end;
|
|
test := sy <> semicolon;
|
|
if not test then begin
|
|
disp1 := minsize;
|
|
InSymbol;
|
|
end;
|
|
until test;
|
|
if numcase <> 0 then Error(98);
|
|
disp1 := maxsize;
|
|
lsp^.fstvar := lsp1;
|
|
frecVar^.hasSFile := hasFile;
|
|
end
|
|
else
|
|
frecvar := nil;
|
|
end; {FieldList}
|
|
|
|
|
|
procedure ProcList (fsys: setofsys);
|
|
|
|
{ compile a field list }
|
|
{ }
|
|
{ parameters: }
|
|
{ fsys - following symbols }
|
|
|
|
var
|
|
foundBody: boolean; {dummy var for ProcDeclaration}
|
|
lsy: symbol; {for recording type of subroutine}
|
|
|
|
begin {ProcList}
|
|
{make sure the initial symbol is valid}
|
|
if not (sy in fsys+[procsy,funcsy]) then begin
|
|
Error(19);
|
|
Skip(fsys + [procsy,funcsy]);
|
|
end; {if}
|
|
|
|
{process all procedures and functions}
|
|
while sy in [procsy,funcsy] do begin
|
|
nextLocalLabel := 1;
|
|
lsy := sy;
|
|
InSymbol;
|
|
nextLocalLabel := 1;
|
|
ProcDeclaration(lsy, fsys+[procsy,funcsy], true, true, foundbody);
|
|
if objectcp^.pfdirective = droverride then
|
|
objectcp^.pfdirective := drforw
|
|
else begin
|
|
objectcp^.pfaddr := disp1;
|
|
disp1 := disp1 + ptrsize;
|
|
end; {else}
|
|
while sy = semicolon do begin
|
|
InSymbol;
|
|
if not (sy in fsys + [procsy,funcsy,semicolon]) then begin
|
|
Error(19);
|
|
Skip(fsys + [procsy,funcsy]);
|
|
end; {if}
|
|
end; {while}
|
|
end; {while}
|
|
end; {ProcList}
|
|
|
|
|
|
begin {Typ}
|
|
if not (sy in typebegsys) then begin
|
|
Error(10);
|
|
Skip(fsys+typebegsys);
|
|
end;
|
|
if sy in typebegsys then begin
|
|
if sy in simptypebegsys then
|
|
SimpleType(fsys,fsp,fsize)
|
|
{^} else if sy = arrow then begin
|
|
lsp := pointer(Malloc(sizeof(structure)));
|
|
fsp := lsp;
|
|
with lsp^ do begin
|
|
eltype := nil;
|
|
size := ptrsize;
|
|
form := pointerStruct;
|
|
hasSFile := false;
|
|
end; {with}
|
|
InSymbol;
|
|
if sy = ident then begin
|
|
SearchSection(display[top].fname,lcp);
|
|
if lcp <> nil then
|
|
if lcp^.klass <> types then
|
|
lcp := nil;
|
|
if lcp = nil then begin
|
|
{forward reference type id}
|
|
lcp := pointer(Malloc(sizeof(identifier)));
|
|
with lcp^ do begin
|
|
len := ord(id[0])+2;
|
|
name := pointer(Malloc(len));
|
|
CopyString(name^,id,len);
|
|
idtype := lsp;
|
|
next := fwptr;
|
|
klass := types;
|
|
hasIFile := lsp^.hasSFile;
|
|
end; {with}
|
|
fwptr := lcp;
|
|
end {if}
|
|
else
|
|
with lcp^,lsp^ do begin
|
|
if {lcp^.}idtype <> nil then begin
|
|
{lsp^.}eltype := {lcp^.}idtype;
|
|
{lsp^.}hasSFile := {lcp^.}hasIFile;
|
|
end; {if}
|
|
if {lcp^.}name = thisType then
|
|
Error(10);
|
|
end; {with}
|
|
InSymbol;
|
|
end {if}
|
|
else Error(2);
|
|
end {else if}
|
|
else begin
|
|
if sy = packedsy then begin
|
|
InSymbol;
|
|
ispacked := pkpacked;
|
|
if not (sy in (typedels + [objectsy])) then begin
|
|
Error(10);
|
|
Skip(fsys + (typedels + [objectsy]));
|
|
end {if}
|
|
end {if}
|
|
else ispacked := pkunpacked;
|
|
{array}
|
|
if sy = arraysy then begin
|
|
InSymbol;
|
|
Match(lbrack,11);
|
|
lsp1 := nil;
|
|
repeat
|
|
lsp := pointer(Malloc(sizeof(structure)));
|
|
with lsp^ do begin
|
|
aeltype := lsp1;
|
|
inxtype := nil;
|
|
form := arrays;
|
|
hasSFile := lsp1^.hasSFile;
|
|
end;
|
|
lsp^.ispacked := ispacked;
|
|
lsp1 := lsp;
|
|
SimpleType(fsys + [comma,rbrack,ofsy],lsp2,lsize);
|
|
lsp1^.size := lsize;
|
|
if lsp2 <> nil then
|
|
if lsp2^.form <= subrange then begin
|
|
if IsReal(lsp2) then begin
|
|
Error(38);
|
|
lsp2 := nil;
|
|
end
|
|
else if lsp2 = longptr then begin
|
|
Error(74);
|
|
lsp2 := nil;
|
|
end; {else if}
|
|
lsp^.inxtype := lsp2
|
|
end {if}
|
|
else begin
|
|
Error(41);
|
|
lsp2 := nil;
|
|
end; {else}
|
|
test := sy <> comma;
|
|
if test then Match(rbrack,12) else InSymbol;
|
|
until test;
|
|
Match(ofsy,8);
|
|
Typ(fsys, lsp, lsize, false);
|
|
if lsp1^.ispacked = pkpacked then
|
|
if CompTypes(lsp,charptr) or CompTypes(lsp,boolptr) then
|
|
lsize := packedcharsize;
|
|
repeat
|
|
with lsp1^ do begin
|
|
lsp2 := aeltype;
|
|
aeltype := lsp;
|
|
hasSFile := lsp^.hasSFile;
|
|
if inxtype <> nil then begin
|
|
GetBounds(inxtype,lmin,lmax);
|
|
lsize := (lmax-lmin+1)*lsize;
|
|
size := lsize;
|
|
end; {if}
|
|
end; {with}
|
|
lsp := lsp1; lsp1 := lsp2;
|
|
until lsp1 = nil;
|
|
if lsize > $010000 then
|
|
if SmallMemoryModel then
|
|
Error(122);
|
|
end
|
|
{stringsy}
|
|
else if sy = stringsy then begin
|
|
InSymbol;
|
|
lmin := 80; {default string length is 80}
|
|
if sy = lbrack then begin
|
|
InSymbol;
|
|
DoConstant(fsys+[rbrack],lsp1,lvalu);
|
|
if lsp1 = intptr then
|
|
lmin := lvalu.ival
|
|
else
|
|
Error(15);
|
|
Match(rbrack,12);
|
|
end;
|
|
lsp1 := pointer(Malloc(sizeof(structure)));
|
|
with lsp1^ do begin
|
|
size := 2;
|
|
form := subrange;
|
|
hasSFile := false;
|
|
rangetype := intptr;
|
|
min := 0;
|
|
if lmin > 255 then
|
|
min := 1;
|
|
max := lmin;
|
|
end;
|
|
lsp := pointer(Malloc(sizeof(structure)));
|
|
with lsp^ do begin
|
|
aeltype := charptr;
|
|
inxtype := lsp1;
|
|
form := arrays;
|
|
hasSFile := false;
|
|
size := (lmin-lsp1^.min+1)*packedcharsize;
|
|
ispacked := pkpacked;
|
|
end;
|
|
end
|
|
{record}
|
|
else if sy = recordsy then begin
|
|
InSymbol;
|
|
oldtop := top;
|
|
if top < displimit then begin
|
|
top := top+1;
|
|
with display[top] do begin
|
|
fname := nil;
|
|
flabel := nil;
|
|
labsused := nil;
|
|
occur := rec;
|
|
end
|
|
end
|
|
else
|
|
Error(107);
|
|
disp1 := 0;
|
|
lsp := pointer(Malloc(sizeof(structure)));
|
|
FieldList(fsys-[semicolon]+[endsy], lsp1, lsp^.hasSFile, false);
|
|
if disp1 > $010000 then
|
|
if SmallMemoryModel then
|
|
Error(122);
|
|
with lsp^ do begin
|
|
fstfld := display[top].fname;
|
|
recvar := lsp1;
|
|
size := disp1;
|
|
form := records;
|
|
end; {with}
|
|
lsp^.ispacked := ispacked;
|
|
ExportUses;
|
|
top := oldtop;
|
|
Match(endsy,13);
|
|
end
|
|
{object}
|
|
else if sy = objectsy then begin
|
|
InSymbol;
|
|
|
|
{make sure we are declaring a type}
|
|
if not isType then
|
|
Error(127);
|
|
|
|
{set up a new display}
|
|
oldtop := top;
|
|
if top < displimit then begin
|
|
top := top+1;
|
|
with display[top] do begin
|
|
fname := nil;
|
|
flabel := nil;
|
|
labsused := nil;
|
|
occur := rec;
|
|
end
|
|
end
|
|
else
|
|
Error(107);
|
|
disp1 := 6;
|
|
|
|
{set up the type}
|
|
lsp := pointer(Malloc(sizeof(structure)));
|
|
with lsp^ do begin
|
|
form := objects;
|
|
objname := nil;
|
|
objsize := 6;
|
|
objlevel := 1;
|
|
objparent := nil;
|
|
size := ptrsize;
|
|
hasSFile := false;
|
|
end; {with}
|
|
|
|
{handle inheritance}
|
|
if sy = lparent then begin
|
|
InSymbol;
|
|
if sy = ident then begin
|
|
SearchId([types], lcp2);
|
|
if lcp2 <> nil then begin
|
|
if lcp2^.idtype <> nil then
|
|
if lcp2^.idtype^.form = objects then begin
|
|
Duplicate(display[top].fname, lcp2^.idtype^.objfld);
|
|
disp1 := lcp2^.idtype^.objsize;
|
|
lsp^.objparent := lcp2^.idtype;
|
|
lsp^.objlevel := lcp2^.idtype^.objlevel + 1;
|
|
end {if}
|
|
else
|
|
Error(129);
|
|
end {if}
|
|
else
|
|
Error(33);
|
|
InSymbol;
|
|
end {if}
|
|
else
|
|
Error(128);
|
|
Match(rparent,4);
|
|
end; {if}
|
|
|
|
{compile the fields and methods}
|
|
if sy in typebegsys then
|
|
FieldList(fsys-[semicolon]+[endsy,procsy,funcsy], lsp1,
|
|
lsp^.hasSFile, true);
|
|
objectType := lsp;
|
|
ttop := top;
|
|
top := oldtop;
|
|
EnterId(objectcp);
|
|
top := ttop;
|
|
objectcp^.idtype := lsp;
|
|
ProcList(fsys-[semicolon]+[endsy]);
|
|
if disp1 > $010000 then
|
|
if SmallMemoryModel then
|
|
Error(122);
|
|
lsp^.objfld := display[top].fname;
|
|
lsp^.objsize := disp1;
|
|
|
|
lsp^.ispacked := ispacked;
|
|
ExportUses;
|
|
top := oldtop;
|
|
Match(endsy,13);
|
|
end {else if}
|
|
{set} else if sy = setsy then begin
|
|
InSymbol;
|
|
Match(ofsy,8);
|
|
SimpleType(fsys,lsp1,lsize);
|
|
if lsp1 <> nil then
|
|
if lsp1^.form > subrange then begin
|
|
Error(43);
|
|
lsp1 := nil;
|
|
end
|
|
else if IsReal(lsp1) then begin
|
|
Error(42);
|
|
lsp1 := nil;
|
|
end
|
|
else if (lsp1 = intptr) or (lsp1 = longptr) then begin
|
|
Error(90);
|
|
lsp1 := nil;
|
|
end
|
|
else begin
|
|
GetBounds(lsp1,lmin,lmax);
|
|
if (lmin < setlow) or (lmax > sethigh) then
|
|
Error(90);
|
|
lmax := lmax div 8 + 1;
|
|
if lmax = 1 then
|
|
lmax := 2
|
|
else if lmax = 3 then
|
|
lmax := 4;
|
|
end;
|
|
lsp := pointer(Malloc(sizeof(structure)));
|
|
with lsp^ do begin
|
|
elset := lsp1;
|
|
size := lmax;
|
|
form := power;
|
|
hasSFile := false;
|
|
end;
|
|
lsp^.ispacked := ispacked;
|
|
end
|
|
{file} else if sy = filesy then begin
|
|
InSymbol;
|
|
Match(ofsy,8);
|
|
Typ(fsys, lsp1, lsize, false);
|
|
if lsp1^.hasSFile then Error(117);
|
|
fsize := lsize;
|
|
if (lsp1 = charptr) or (lsp1 = boolptr) then
|
|
fsize := packedcharsize;
|
|
lsp := pointer(Malloc(sizeof(structure)));
|
|
with lsp^ do begin
|
|
size := ptrsize;
|
|
form := files;
|
|
hasSFile := true;
|
|
filtype := lsp1;
|
|
filsize := lsize;
|
|
end;
|
|
lsp^.ispacked := ispacked;
|
|
end;
|
|
fsp := lsp
|
|
end;
|
|
if not (sy in fsys) then begin
|
|
Error(6);
|
|
Skip(fsys)
|
|
end; {if}
|
|
end
|
|
else
|
|
fsp := nil;
|
|
if fsp = nil then
|
|
fsize := 1
|
|
else
|
|
fsize := fsp^.size;
|
|
end {Typ} ;
|
|
|
|
procedure labeldeclaration(fsys: setofsys);
|
|
{Declare a user-defined label}
|
|
|
|
var
|
|
llp: lbp;
|
|
redef: boolean;
|
|
i: integer;
|
|
test: boolean;
|
|
|
|
begin {labeldeclaration}
|
|
repeat
|
|
if sy = intconst then
|
|
with display[top] do begin
|
|
llp := flabel; redef := false;
|
|
while (llp <> nil) and not redef do
|
|
if llp^.labval <> val.ival then llp := llp^.nextlab
|
|
else begin redef := true; Error(88); end;
|
|
if not redef then begin
|
|
llp := pointer(Malloc(sizeof(labl)));
|
|
with llp^ do begin
|
|
labval := val.ival; labname := GenLabel;
|
|
if top = 1 then firstlab := labname+1;
|
|
defined := false; nextlab := flabel;
|
|
lstlevel := 0;
|
|
end;
|
|
if (val.ival < 0) or (val.ival > 9999) then Error(105);
|
|
flabel := llp
|
|
end;
|
|
InSymbol;
|
|
end
|
|
else Error(15);
|
|
if not ( sy in fsys + [comma, semicolon] ) then begin
|
|
Error(6);
|
|
Skip(fsys+[comma,semicolon])
|
|
end;
|
|
test := sy <> comma;
|
|
if not test then InSymbol
|
|
until test;
|
|
Match(semicolon,14);
|
|
end; {labeldeclaration}
|
|
|
|
procedure ConstDeclaration(fsys: setofsys);
|
|
{compile a constant}
|
|
|
|
var
|
|
lcp: ctp;
|
|
lsp: stp;
|
|
lvalu: valu;
|
|
len: integer; {string length}
|
|
|
|
begin {ConstDeclaration}
|
|
if sy <> ident then begin
|
|
Error(2);
|
|
Skip(fsys + [ident]);
|
|
end;
|
|
while sy = ident do begin
|
|
lcp := pointer(Malloc(sizeof(identifier)));
|
|
with lcp^ do begin
|
|
len := ord(id[0])+2;
|
|
name := pointer(Malloc(len));
|
|
CopyString(name^,id,len);
|
|
idtype := nil;
|
|
next := nil;
|
|
klass:=konst;
|
|
hasIFile := false;
|
|
end;
|
|
InSymbol;
|
|
if (sy = relop) and (op = eqop) then
|
|
InSymbol
|
|
else
|
|
Error(16);
|
|
DoConstant(fsys + [semicolon],lsp,lvalu);
|
|
EnterId(lcp);
|
|
with lcp^ do begin
|
|
CheckUses({lcp^.}name^,constsy);
|
|
{lcp^.}idtype := lsp;
|
|
{lcp^.}values := lvalu;
|
|
end;
|
|
Match(semicolon,14);
|
|
if not (sy in fsys+[ident,implementationsy]) then begin
|
|
Error(6);
|
|
Skip(fsys + [ident,implementationsy]);
|
|
end;
|
|
end;
|
|
end; {ConstDeclaration}
|
|
|
|
procedure FwPtrCheck;
|
|
{Check all forward declared pointers to be sure they are resolved}
|
|
|
|
var
|
|
lcp: ctp;
|
|
|
|
begin {FwPtrCheck}
|
|
while fwptr <> nil do begin
|
|
id := fwptr^.name^;
|
|
prterr := false;
|
|
SearchId([types],lcp);
|
|
prterr := true;
|
|
if lcp = nil then begin
|
|
write('**** The pointer ',id,' cannot be resolved');
|
|
FlagError;
|
|
end
|
|
else if lcp^.idtype <> nil then
|
|
with fwptr^.idtype^, lcp^ do begin
|
|
eltype := idtype;
|
|
hasSFile := hasIFile;
|
|
end;
|
|
fwptr := fwptr^.next;
|
|
end;
|
|
end; {FwPtrCheck}
|
|
|
|
procedure TypeDeclaration (fsys: setofsys);
|
|
|
|
{ compile a type declaration }
|
|
{ }
|
|
{ parameters: }
|
|
{ fsys - }
|
|
|
|
var
|
|
lcp: ctp;
|
|
lsp: stp;
|
|
lsize: addrrange;
|
|
len: integer; {string length}
|
|
|
|
begin {TypeDeclaration}
|
|
if sy <> ident then begin {check for a bogus start}
|
|
Error(2);
|
|
Skip(fsys + [ident]);
|
|
end; {if}
|
|
while sy = ident do begin {scan all declarations}
|
|
{process the identifier}
|
|
lcp := pointer(Malloc(sizeof(identifier)));
|
|
with lcp^ do begin
|
|
len := ord(id[0])+2;
|
|
name := pointer(Malloc(len));
|
|
CopyString(name^,id,len);
|
|
thisType := name;
|
|
klass := types;
|
|
end; {with}
|
|
InSymbol;
|
|
{check for '='}
|
|
if (sy = relop) and (op = eqop) then
|
|
InSymbol
|
|
else
|
|
Error(16);
|
|
objectName := lcp^.name^;
|
|
objectCp := lcp;
|
|
Typ(fsys+[semicolon], lsp, lsize, true); {get the type}
|
|
if lsp^.form = objects then
|
|
lsp^.objname := lcp^.name;
|
|
thisType := nil;
|
|
if lsp^.form <> objects then {enter in symbol table}
|
|
EnterId(lcp);
|
|
with lcp^ do begin
|
|
{lcp^.}idtype := lsp;
|
|
{lcp^.}hasIFile := lsp^.hasSFile;
|
|
CheckUses({lcp^.}name^,typesy);
|
|
end; {with}
|
|
Match(semicolon,14); {get ready for another one}
|
|
if not (sy in fsys + [ident,implementationsy]) then begin
|
|
Error(6);
|
|
Skip(fsys + [ident,implementationsy]);
|
|
end; {if}
|
|
end; {while}
|
|
FwPtrCheck; {make sure forward declarations were resolved}
|
|
end; {TypeDeclaration}
|
|
|
|
procedure VarDeclaration(fsys: setofsys);
|
|
{declare variables}
|
|
|
|
var
|
|
isExtern: boolean; {is this an external variable declaration?}
|
|
lcp,nxt: ctp;
|
|
lsp: stp;
|
|
lsize: addrrange;
|
|
test: boolean;
|
|
len: integer; {string length}
|
|
|
|
begin {VarDeclaration}
|
|
nxt := nil;
|
|
repeat {loops over type part}
|
|
repeat {loops over all variable names}
|
|
if sy = ident then begin
|
|
{declare a new variable}
|
|
lcp := pointer(Malloc(sizeof(identifier)));
|
|
with lcp^ do begin
|
|
len := ord(id[0])+2;
|
|
name := pointer(Malloc(len));
|
|
CopyString(name^,id,len);
|
|
next := nxt;
|
|
klass := varsm;
|
|
vcontvar := false;
|
|
vrestrict := false;
|
|
idtype := nil;
|
|
vkind := actual;
|
|
vlev := level;
|
|
fromUses := inUses;
|
|
vPrivate := doingUnit and (not doingInterface);
|
|
end;
|
|
EnterId(lcp);
|
|
nxt := lcp;
|
|
InSymbol;
|
|
end
|
|
else Error(2);
|
|
if not (sy in fsys + [comma,colon] + typedels) then begin
|
|
Error(6); Skip(fsys+[comma,colon,semicolon]+typedels)
|
|
end;
|
|
test := sy <> comma;
|
|
if not test then InSymbol;
|
|
until test;
|
|
Match(colon,5);
|
|
|
|
{see if the variable is extern}
|
|
isExtern := false;
|
|
if not iso then
|
|
if sy = ident then
|
|
if (id = 'EXTERN') or (id = 'EXTERNAL') then begin
|
|
InSymbol;
|
|
isExtern := true;
|
|
end; {if}
|
|
{get the type for the variable list}
|
|
Typ(fsys + [semicolon] + typedels, lsp, lsize, false);
|
|
FwPtrCheck;
|
|
{loop over the variable list, filling in type based info}
|
|
while nxt <> nil do
|
|
with nxt^ do begin
|
|
CheckUses(name^,varsy);
|
|
idtype := lsp;
|
|
fromUses := fromUses or isExtern;
|
|
hasIFile := lsp^.hasSFile;
|
|
if level <> 1 then
|
|
vlabel := GetLocalLabel;
|
|
nxt := next;
|
|
end;
|
|
Match(semicolon,14);
|
|
if not (sy in fsys + [ident,implementationsy]) then begin
|
|
Error(6);
|
|
Skip(fsys + [ident,implementationsy]);
|
|
end;
|
|
until (sy <> ident) and not (sy in typedels);
|
|
end; {VarDeclaration}
|
|
|
|
|
|
procedure DoBlock (fsys: setofsys; fsy: symbol; fprocp: ctp;
|
|
isProgram: boolean); forward;
|
|
{compile a block}
|
|
|
|
|
|
procedure ProcDeclaration {fsy: symbol; fsys: setofsys;
|
|
isObject, compilebody: boolean; var foundbody: boolean};
|
|
|
|
{ Procedure/function declaration }
|
|
{ }
|
|
{ parameters: }
|
|
{ fsy - procedure or function symbol }
|
|
{ fsys - follow symbols }
|
|
{ isObject - is this declaration in an object? }
|
|
{ compilebody - Compile the body? (used for partial compile)}
|
|
{ foundbody - Was the body found (used for partial compile) }
|
|
|
|
var
|
|
forw: boolean;
|
|
i: integer;
|
|
lcp,lcp1,lcp2: ctp;
|
|
len: integer; {string length}
|
|
lisMethod: boolean; {copy of isMethod}
|
|
lpsize: integer; {for saving psize (nested declarations)}
|
|
lsp, lsp1: stp;
|
|
lvalu: valu; {constant from a directive}
|
|
needSemicolon: boolean; {for parsing interface files}
|
|
oldlev: 0..maxlevel;
|
|
oldtop: disprange;
|
|
override: boolean; {true if override is the only legal possibility}
|
|
|
|
|
|
procedure ParameterList (ssy: setofsys; var fpar: ctp;
|
|
forw,dummy: boolean);
|
|
|
|
{ Compile the parameter list }
|
|
{ }
|
|
{ parameters: }
|
|
{ ssy - }
|
|
{ fpar - list of parameter symbols }
|
|
{ forw - }
|
|
{ dummy - }
|
|
|
|
var
|
|
list,lcp,lcp1: ctp;
|
|
lsp: stp; lkind: idkind;
|
|
lsize: unsigned;
|
|
item: integer;
|
|
test: boolean;
|
|
len: integer; {string length}
|
|
universal: boolean; {is the parm universal?}
|
|
|
|
|
|
procedure FunProcParm (forp: idclass; var lcp: ctp; fsys: setofsys);
|
|
|
|
{ Compile a procedure or function parameter }
|
|
{ }
|
|
{ parameters: }
|
|
{ forp - function or procedure symbol }
|
|
{ lcp - }
|
|
{ fsys - }
|
|
|
|
var
|
|
lpsize: integer; {for saving psize}
|
|
len: integer; {string length}
|
|
|
|
begin {FunProcParm}
|
|
InSymbol;
|
|
if sy = ident then begin
|
|
|
|
{create a symbol table entry}
|
|
lcp := pointer(Malloc(sizeof(identifier)));
|
|
with lcp^ do begin
|
|
len := ord(id[0])+2;
|
|
name := pointer(Malloc(len));
|
|
CopyString(name^,id,len);
|
|
hasIFile := false;
|
|
idtype := nil;
|
|
pflev := level;
|
|
klass := forp;
|
|
pfdeckind := declared;
|
|
psize := psize+procsize;
|
|
pflabel := GetLocalLabel;
|
|
pfparms := nil;
|
|
pfkind := formal;
|
|
pfnext := nil;
|
|
next := nil;
|
|
end; {with}
|
|
if not dummy then
|
|
EnterId(lcp);
|
|
InSymbol;
|
|
|
|
item := item+1;
|
|
if list <> nil then
|
|
list^.next := lcp;
|
|
list := lcp;
|
|
if fpar = nil then
|
|
fpar := list;
|
|
lpsize := psize;
|
|
with lcp^ do
|
|
if forp = proc then begin
|
|
if not (sy in [semicolon,rparent]) then
|
|
ParameterList([semicolon,rparent], pfnext, false, true);
|
|
end
|
|
else if sy <> colon then
|
|
ParameterList([colon], pfnext, false, true);
|
|
psize := lpsize;
|
|
end {if}
|
|
else
|
|
Error(2);
|
|
end; {FunProcParm}
|
|
|
|
|
|
begin {ParameterList}
|
|
list := nil;
|
|
fpar := nil;
|
|
item := 1;
|
|
if isObject or (sy = lparent) then
|
|
psize := 0; {define parameters as offsets from 0}
|
|
|
|
{declare the 'self' parameter for methods}
|
|
if isObject then begin
|
|
lcp := pointer(Malloc(sizeof(identifier)));
|
|
with lcp^ do begin
|
|
name := @'SELF';
|
|
idtype := objectType;
|
|
next := nil;
|
|
hasIFile := false;
|
|
klass := varsm;
|
|
vkind := actual;
|
|
vlev := level;
|
|
vitem := item;
|
|
vlabel := GetLocalLabel;
|
|
vcontvar := false;
|
|
fromUses := false;
|
|
vrestrict := false;
|
|
vUniv := false;
|
|
vPrivate := true;
|
|
end; {with}
|
|
EnterId(lcp);
|
|
list := lcp;
|
|
fpar := list;
|
|
psize := {psize +} ptrsize;
|
|
item := 2 {item+1};
|
|
end; {if}
|
|
|
|
{handle standard parameters}
|
|
if not (sy in ssy+[lparent]) then begin
|
|
Error(7);
|
|
Skip(fsys+ssy+[lparent])
|
|
end; {if}
|
|
if sy = lparent then begin
|
|
if forw or override then
|
|
Error(45);
|
|
InSymbol;
|
|
if not (sy in [ident,varsy,funcsy,procsy]) then begin
|
|
Error(7);
|
|
Skip(fsys+[ident,rparent]);
|
|
end; {if}
|
|
while sy in [ident,varsy,funcsy,procsy] do begin
|
|
if sy = procsy then begin
|
|
FunProcParm(proc, lcp, fsys+[comma,semicolon,rparent]);
|
|
lcp^.idtype := nilptr;
|
|
end {if}
|
|
else if sy = funcsy then begin
|
|
FunProcParm(func, lcp, fsys+[comma,semicolon,rparent,colon]);
|
|
Match(colon,5);
|
|
if sy = ident then begin
|
|
SearchId([types],lcp1);
|
|
lsp := lcp1^.idtype;
|
|
if lsp <> nil then
|
|
if not (lsp^.form in [scalar,subrange,pointerStruct,objects])
|
|
then begin
|
|
Error(46);
|
|
lsp := nil;
|
|
end; {if}
|
|
lcp^.idtype := lsp;
|
|
InSymbol;
|
|
end
|
|
else Error(2);
|
|
end {else if}
|
|
|
|
{'normal' parameter}
|
|
else begin
|
|
|
|
{handle var declarations}
|
|
if sy = varsy then begin
|
|
lkind := formal;
|
|
InSymbol;
|
|
end
|
|
else
|
|
lkind := actual;
|
|
|
|
{process the list of names}
|
|
lcp1 := nil;
|
|
repeat
|
|
if sy = ident then begin
|
|
lcp := pointer(Malloc(sizeof(identifier)));
|
|
with lcp^ do begin
|
|
len := ord(id[0])+2;
|
|
name := pointer(Malloc(len));
|
|
CopyString(name^,id,len);
|
|
idtype := nil;
|
|
klass := varsm;
|
|
vkind := lkind;
|
|
next := nil;
|
|
vlev := level;
|
|
vcontvar := false;
|
|
vrestrict := false;
|
|
vitem := item;
|
|
fromUses := inUses;
|
|
end; {with}
|
|
if not dummy then
|
|
EnterId(lcp);
|
|
if list <> nil then
|
|
list^.next := lcp;
|
|
list := lcp;
|
|
if fpar = nil then
|
|
fpar := list;
|
|
if lcp1 = nil then
|
|
lcp1 := list;
|
|
InSymbol;
|
|
end {if}
|
|
else
|
|
Error(2);
|
|
if not (sy in [comma,colon]+fsys) then begin
|
|
Error(7);
|
|
Skip(fsys+[comma,semicolon,rparent]);
|
|
end;
|
|
test := sy <> comma;
|
|
if not test then InSymbol;
|
|
until test;
|
|
Match(colon,5);
|
|
|
|
{see if the symbol is universal}
|
|
if sy = univsy then begin
|
|
if iso then
|
|
Error(112);
|
|
universal := true;
|
|
InSymbol;
|
|
end {if}
|
|
else
|
|
universal := false;
|
|
|
|
{process the parameter type}
|
|
if sy = ident then begin
|
|
|
|
{find and check the type}
|
|
SearchId([types],lcp);
|
|
lsp := lcp^.idtype;
|
|
if lsp <> nil then
|
|
if lkind = actual then
|
|
if lsp^.form = files then
|
|
Error(47);
|
|
|
|
{record the type size}
|
|
lsize := ParmSize(lsp,lkind);
|
|
|
|
{scan the variables, adding type info}
|
|
while lcp1 <> nil do begin
|
|
with lcp1^ do begin
|
|
idtype := lsp;
|
|
psize := psize+lsize;
|
|
vlabel := GetLocalLabel;
|
|
vuniv := universal;
|
|
hasIFile := false;
|
|
end; {with}
|
|
|
|
{allocate local space for value parms passed as pointers}
|
|
if lsp <> nil then
|
|
if (lkind = actual) and (lsp^.form > power) then
|
|
if (lsp^.form <> records) or (lsp^.size > 4) then
|
|
lcp1^.vlabel := GetLocalLabel;
|
|
lcp1 := lcp1^.next;
|
|
end; {while}
|
|
InSymbol;
|
|
end {if}
|
|
else
|
|
Error(2);
|
|
item := item+1;
|
|
end; {else}
|
|
|
|
if not (sy in fsys+[semicolon,rparent]) then begin
|
|
Error(7);
|
|
Skip(fsys+[ident,rparent]);
|
|
end; {if}
|
|
if sy = semicolon then begin
|
|
InSymbol;
|
|
if not (sy in fsys+[ident,varsy,procsy,funcsy]) then begin
|
|
Error(7);
|
|
Skip(fsys+[ident,rparent]);
|
|
end; {if}
|
|
end; {if}
|
|
end; {while}
|
|
Match(rparent,4);
|
|
if not (sy in ssy+fsys) then begin
|
|
Error(6);
|
|
Skip(ssy+fsys);
|
|
end; {if}
|
|
end; {if}
|
|
display[top].labsused := nil;
|
|
end; {ParameterList}
|
|
|
|
|
|
begin {ProcDeclaration}
|
|
lpsize := psize;
|
|
psize := 0;
|
|
forw := false;
|
|
|
|
{see if this is the object name for a method}
|
|
override := false;
|
|
isMethod := false;
|
|
if sy = ident then begin
|
|
prterr := false;
|
|
SearchID([types], lcp);
|
|
prterr := true;
|
|
if lcp <> nil then
|
|
if lcp^.idtype <> nil then
|
|
if lcp^.idtype^.form = objects then begin
|
|
isMethod := true;
|
|
lisMethod := true;
|
|
objectName := id;
|
|
InSymbol;
|
|
Match(period, 21);
|
|
end; {if}
|
|
end; {if}
|
|
|
|
if sy = ident then begin
|
|
{check for forward declarations}
|
|
if isMethod then begin
|
|
if level <> 1 then
|
|
Error(126);
|
|
if lcp^.idtype = nil then
|
|
lcp := nil
|
|
else
|
|
SearchSection(lcp^.idtype^.objfld, lcp);
|
|
if lcp = nil then
|
|
Error(124)
|
|
else
|
|
if lcp^.pfdirective = drnone then
|
|
Error(30);
|
|
end {if}
|
|
else
|
|
SearchSection(display[top].fname, lcp);
|
|
if lcp <> nil then
|
|
with lcp^ do begin
|
|
if isObject then
|
|
override := true
|
|
else if klass = proc then
|
|
forw := ((pfdirective=drforw) or isMethod)
|
|
and (fsy=procsy) and (pfkind=actual)
|
|
else if klass = func then
|
|
forw:= ((pfdirective=drforw) or isMethod)
|
|
and (fsy=funcsy) and (pfkind=actual)
|
|
else
|
|
forw := false;
|
|
if not (forw or override) then
|
|
Error(84);
|
|
end; {with}
|
|
|
|
{if not forward, create a new identifier}
|
|
if override then begin
|
|
|
|
{override an ancestor method}
|
|
lcp^.pfoname := pointer(Malloc(length(objectName)+length(lcp^.name^)+2));
|
|
lcp^.pfoname^ := concat(objectName, '~', lcp^.name^);
|
|
objectcp := lcp;
|
|
|
|
{change the 'SELF' parameter type}
|
|
lcp2 := pointer(Malloc(sizeof(identifier)));
|
|
lcp2^ := lcp^.pfparms^;
|
|
lcp^.pfparms := lcp2;
|
|
lcp2^.idtype := objectType;
|
|
end {if}
|
|
else if not forw then begin
|
|
lcp := pointer(Malloc(sizeof(identifier)));
|
|
with lcp^ do begin
|
|
len := ord(id[0])+2;
|
|
name := pointer(Malloc(len));
|
|
CopyString(name^,id,len);
|
|
idtype := nilptr;
|
|
pflev := level;
|
|
pfname := GenLabel;
|
|
if isObject then begin
|
|
pfoname := pointer(Malloc(length(objectName)+length(name^)+2));
|
|
pfoname^ := concat(objectName, '~', name^);
|
|
end {if}
|
|
else
|
|
pfoname := name;
|
|
pfparms := nil;
|
|
pfdeckind := declared;
|
|
pfkind := actual;
|
|
pfPrivate := doingUnit and (not doingInterface);
|
|
if fsy = procsy then
|
|
klass := proc
|
|
else
|
|
klass := func;
|
|
hasIFile := false;
|
|
end; {if}
|
|
CheckUses(lcp^.name^, procsy);
|
|
EnterId(lcp);
|
|
objectcp := lcp;
|
|
end {if}
|
|
else begin
|
|
{forward - reset location counter}
|
|
psize := lcp^.pfactualsize;
|
|
|
|
{reset label counter}
|
|
lcp1 := lcp^.pfparms;
|
|
while lcp1 <> nil do begin
|
|
if lcp1^.klass = varsm then begin
|
|
if lcp1^.vlabel >= nextLocalLabel then
|
|
nextLocalLabel := lcp1^.vlabel + 1;
|
|
end {if}
|
|
else if lcp1^.klass in [proc,func] then
|
|
if lcp1^.pflabel >= nextLocalLabel then
|
|
nextLocalLabel := lcp1^.pflabel + 1;
|
|
lcp1 := lcp1^.next;
|
|
end; {while}
|
|
end; {else}
|
|
InSymbol;
|
|
|
|
{check for unexpected method}
|
|
if sy = period then begin
|
|
Error(125);
|
|
InSymbol;
|
|
if sy = ident then
|
|
InSymbol;
|
|
end; {if}
|
|
end {if}
|
|
else begin
|
|
|
|
{missing function identifier}
|
|
Error(2);
|
|
lcp := ufctptr;
|
|
end; {else}
|
|
|
|
{create a new stack frame level}
|
|
oldlev := level;
|
|
oldtop := top;
|
|
if level < maxlevel then
|
|
level := level + 1
|
|
else
|
|
Error(108);
|
|
if top < displimit then begin
|
|
top := top+1;
|
|
with display[top] do begin
|
|
if forw then
|
|
fname := lcp^.pfparms
|
|
else
|
|
fname := nil;
|
|
flabel := nil;
|
|
labsused := nil;
|
|
occur := blck;
|
|
ispacked := false;
|
|
end; {with}
|
|
end {if}
|
|
else
|
|
Error(107);
|
|
|
|
{assign function labels}
|
|
with lcp^ do
|
|
if klass = func then
|
|
pflabel := GetLocalLabel
|
|
else
|
|
pflabel := 0;
|
|
|
|
{compile the parameters}
|
|
if fsy = procsy then begin
|
|
ParameterList([semicolon], lcp1, forw, false);
|
|
if not (forw or override) then
|
|
with lcp^ do begin
|
|
pfparms := lcp1;
|
|
pfactualsize := psize;
|
|
end; {with}
|
|
end {if}
|
|
else begin
|
|
ParameterList([semicolon,colon], lcp1, forw, false);
|
|
if not (forw or override) then
|
|
with lcp^ do begin
|
|
pfparms := lcp1;
|
|
pfactualsize := psize;
|
|
end; {with}
|
|
if sy = colon then begin
|
|
InSymbol;
|
|
if sy = ident then begin
|
|
if forw or override then
|
|
Error(48);
|
|
SearchId([types], lcp1);
|
|
lsp := lcp1^.idtype;
|
|
lcp^.idtype := lsp;
|
|
if lsp <> nil then
|
|
if not (lsp^.form in [scalar,subrange,pointerStruct,objects]) then
|
|
begin
|
|
Error(46);
|
|
lcp^.idtype := nil;
|
|
end; {if}
|
|
InSymbol;
|
|
end {if}
|
|
else begin
|
|
Error(2);
|
|
Skip(fsys + [semicolon])
|
|
end; {else}
|
|
end {if}
|
|
else if not (forw or override) then
|
|
Error(49)
|
|
end; {else}
|
|
Match(semicolon,14);
|
|
|
|
{handle directives}
|
|
if (sy = ident) or doingInterface or inUses or isObject then begin
|
|
foundBody := false;
|
|
if sy <> ident then begin {special assumptions for uses, }
|
|
if inUses and (not isObject) then { interface files, methods }
|
|
lcp2 := externIdentifier
|
|
else
|
|
lcp2 := forwardIdentifier;
|
|
if override then
|
|
Error(30);
|
|
needSemicolon := false;
|
|
end {if}
|
|
else begin {normal identifier section}
|
|
SearchId([directive],lcp2); {find the identifier type}
|
|
InSymbol;
|
|
needSemicolon := true;
|
|
end; {else}
|
|
lcp^.pfdirective := lcp2^.drkind;
|
|
if override then begin
|
|
if lcp2^.drkind <> droverride then
|
|
Error(30);
|
|
end {if}
|
|
else if lcp2^.drkind = droverride then
|
|
Error(124);
|
|
with lcp^ do
|
|
case pfdirective of
|
|
drforw,droverride:
|
|
if forw then
|
|
Error(85);
|
|
drextern:
|
|
if level <> 2 then
|
|
Error(101);
|
|
drprodos: begin
|
|
if sy = lparent then
|
|
InSymbol;
|
|
if (sy = intconst) then begin
|
|
pfcallnum := val.ival;
|
|
InSymbol;
|
|
end {if}
|
|
else
|
|
Error(15);
|
|
if sy = rparent then
|
|
InSymbol;
|
|
end;
|
|
drtool1,drtool2: begin
|
|
if sy = lparent then
|
|
InSymbol;
|
|
DoConstant(fsys+[comma], lsp1, lvalu);
|
|
if lsp1 = intptr then
|
|
pftoolnum := lvalu.ival
|
|
else
|
|
Error(15);
|
|
Match(comma,20);
|
|
DoConstant(fsys+[rparent], lsp1, lvalu);
|
|
if lsp1 = intptr then
|
|
pfcallnum := lvalu.ival
|
|
else
|
|
Error(15);
|
|
if sy = rparent then
|
|
InSymbol;
|
|
end;
|
|
drvector: begin
|
|
if sy = lparent then
|
|
InSymbol;
|
|
DoConstant(fsys+[comma], lsp1, lvalu);
|
|
if lsp1 = longptr then
|
|
pfaddr := lvalu.valp^.lval
|
|
else if lsp1 = intptr then
|
|
pftoolnum := lvalu.ival
|
|
else
|
|
Error(15);
|
|
Match(comma,20);
|
|
DoConstant(fsys+[rparent], lsp1, lvalu);
|
|
if lsp1 = intptr then
|
|
pfcallnum := lvalu.ival
|
|
else
|
|
Error(15);
|
|
if sy = rparent then
|
|
InSymbol;
|
|
end;
|
|
otherwise: Error(6);
|
|
end; {case}
|
|
if needSemicolon then
|
|
Match(semicolon,14);
|
|
if not (sy in fsys) then begin
|
|
Error(6);
|
|
Skip(fsys);
|
|
end; {if}
|
|
end {if}
|
|
else
|
|
with lcp^ do begin
|
|
|
|
{if list is off, write the proc name}
|
|
foundBody := true;
|
|
if (not list) and progress and compilebody then
|
|
writeln(' ':level, {lcp^.}pfoname^);
|
|
|
|
{lcp^.}pfdirective := drnone;
|
|
{lcp^.}pfset := false;
|
|
if compilebody then begin
|
|
if level <= 2 then begin
|
|
mark({lcp^.}pfmark);
|
|
Gen2Name(dc_str, $4000*ord({lcp^.}pfPrivate)+$8000*ord(isDynamic), 0,
|
|
{lcp^.}pfoname);
|
|
inseg := true;
|
|
end; {if}
|
|
DoBlock(fsys,semicolon,lcp,false);
|
|
Match(semicolon,14);
|
|
if not (sy in [endsy,beginsy,procsy,funcsy]) then begin
|
|
Error(6);
|
|
Skip([beginsy,procsy,funcsy]);
|
|
end; {if}
|
|
if ({lcp^.}klass = func) and (not {lcp^.}pfset) then Error(96);
|
|
end; {if}
|
|
end; {with}
|
|
ExportUses;
|
|
level := oldlev;
|
|
top := oldtop;
|
|
psize := lpsize;
|
|
end; {ProcDeclaration}
|
|
|
|
|
|
procedure UsesDeclaration(fsys: setofsys);
|
|
{compile a uses statement}
|
|
|
|
var
|
|
done: boolean; {for detecting end of loop}
|
|
foundBody: boolean; {dummy var for ProcDeclaration}
|
|
lfsys: setofsys; {temp fsys}
|
|
lsy: symbol; {for recording type of subroutine}
|
|
|
|
begin {UsesDeclaration}
|
|
if level <> 1 then Error(115); {must be at program level}
|
|
repeat
|
|
if sy = ident then begin
|
|
inUses := true; {mark as in a uses file}
|
|
OpenUses; {open the uses file}
|
|
InSymbol; {get the first symbol in the uses file}
|
|
fsys := fsys+[implementationsy]; {allow implementation}
|
|
{compile the file}
|
|
while sy = usessy do begin {skip uses - assumes correct syntax,}
|
|
repeat { but will not hang if fooled }
|
|
InSymbol;
|
|
until (sy = semicolon) or eofl;
|
|
InSymbol;
|
|
end;
|
|
if sy = constsy then begin InSymbol; ConstDeclaration(fsys); end;
|
|
if sy = typesy then begin InSymbol; TypeDeclaration(fsys); end;
|
|
if sy = varsy then begin InSymbol; VarDeclaration(fsys); end;
|
|
{handle procedure, function declarations}
|
|
while sy in [procsy,funcsy] do begin
|
|
lsy := sy;
|
|
InSymbol;
|
|
nextLocalLabel := 1;
|
|
ProcDeclaration(lsy, fsys, false, true, foundbody);
|
|
if foundBody then Error(81);
|
|
end;
|
|
if sy <> implementationsy then begin
|
|
Error(116);
|
|
Skip([implementationsy]);
|
|
end
|
|
else
|
|
InSymbol;
|
|
inUses := false; {mark as out of uses file}
|
|
end
|
|
else
|
|
Error(2);
|
|
done := sy <> comma;
|
|
if not done then
|
|
InSymbol;
|
|
until done or eofl;
|
|
Match(semicolon,14);
|
|
end; {UsesDeclaration}
|
|
|
|
|
|
procedure Selector {fsys: setofsys; fcp,fprocp: ctp; var isMethod: boolean};
|
|
|
|
{ handle indexing arrays, field selection, dereferencing of }
|
|
{ pointers, windowing files }
|
|
{ }
|
|
{ parameters: }
|
|
{ fsys - }
|
|
{ fcp - }
|
|
{ fprocp - identifier for program or program-level }
|
|
{ subroutine contining this statement }
|
|
{ isMethod - (returned) Did the selection resolve to a }
|
|
{ method call? If so, take no further action. }
|
|
|
|
var
|
|
isFunction: boolean; {are we dereferencing a function?}
|
|
lattr: attr; {copy of an attribute}
|
|
lcp,lcp1: ctp;
|
|
lmin,lmax: longint;
|
|
lsize: addrrange;
|
|
lispacked: boolean;
|
|
|
|
|
|
procedure ArrayIndex;
|
|
|
|
{ Handles subscripting an array }
|
|
|
|
var
|
|
bt: baseTypeEnum; {index base type}
|
|
|
|
begin {ArrayIndex}
|
|
{track array packing}
|
|
gispacked := gispacked or lispacked;
|
|
|
|
{loop over subscripts, possibly separated by commas}
|
|
repeat
|
|
|
|
{get the type, and make sure it's an array}
|
|
lattr := gattr;
|
|
lcp1 := glcp;
|
|
with lattr do
|
|
if typtr <> nil then
|
|
if typtr^.form <> arrays then begin
|
|
Error(63);
|
|
typtr := nil;
|
|
end; {if}
|
|
LoadAddress;
|
|
InSymbol;
|
|
|
|
{get the array subscript value}
|
|
Expression(fsys + [comma,rbrack],fprocp);
|
|
Load;
|
|
glcp := lcp1;
|
|
if gattr.typtr <> nil then
|
|
if gattr.typtr^.form <> scalar then
|
|
Error(41);
|
|
if lattr.typtr <> nil then
|
|
with lattr.typtr^ do begin
|
|
|
|
{if needed, promote the index to long}
|
|
if CompTypes(inxtype, longptr) then
|
|
if CompTypes(gattr.typtr, intptr) then begin
|
|
Gen2(pc_cnv, ord(cgWord), ord(cgLong));
|
|
gattr.typtr := longptr;
|
|
end; {if}
|
|
|
|
{check the type of the subscript}
|
|
if CompTypes(inxtype,gattr.typtr) then begin
|
|
if inxtype <> nil then begin
|
|
|
|
{check the range of the subscript}
|
|
GetBounds(inxtype,lmin,lmax);
|
|
if debug then
|
|
if GetType(inxtype, false) in [cgLong,cgULong] then
|
|
GenL2t(pc_chk, lmin, lmax, cgULong)
|
|
else
|
|
Gen2t(pc_chk, ord(lmin), ord(lmax), cgWord);
|
|
|
|
{handle non-zero stating indexes for the array}
|
|
if lmin <> 0 then
|
|
if lmin > maxint then begin
|
|
GenLdcLong(lmin);
|
|
Gen0(pc_sbl);
|
|
end {if}
|
|
else
|
|
Gen1t(pc_dec, ord(lmin), GetType(inxtype, false));
|
|
end;
|
|
end
|
|
else
|
|
Error(64);
|
|
|
|
{set up the result type, after indexing}
|
|
bt := GetType(gattr.typtr, false);
|
|
with gattr do begin
|
|
typtr := aeltype;
|
|
isPacked := false;
|
|
kind := varbl;
|
|
access := indrct;
|
|
idplmt := 0;
|
|
end;
|
|
|
|
{index into the array}
|
|
if gattr.typtr <> nil then begin
|
|
lsize := gattr.typtr^.size;
|
|
if ((gattr.typtr = charptr) or (gattr.typtr = boolptr))
|
|
and (ispacked = pkpacked) then begin
|
|
lsize := packedcharsize;
|
|
gattr.isPacked := true;
|
|
end; {if}
|
|
if (size < $010000) and (inxtype^.size <= intsize) then begin
|
|
Gen1t(pc_ldc, long(lsize).lsw, cgUWord);
|
|
Gen0(pc_umi);
|
|
Gen0t(pc_ixa, cgUWord);
|
|
end {if}
|
|
else begin
|
|
if not (bt in [cgLong,cgULong]) then
|
|
Gen2(pc_cnv,ord(bt),ord(cgULong));
|
|
GenLdcLong(lsize);
|
|
Gen0(pc_uml);
|
|
Gen0(pc_adl);
|
|
end; {else}
|
|
end; {if}
|
|
end; {with}
|
|
until sy <> comma;
|
|
|
|
{make sure there is a matching ']'}
|
|
Match(rbrack,12);
|
|
end; {ArrayIndex}
|
|
|
|
|
|
procedure FieldSelection;
|
|
|
|
{ Compile a field selection }
|
|
|
|
var
|
|
form: structform; {records or objects (kind of variable)}
|
|
disp: addrrange; {disp in object for method}
|
|
|
|
begin {FieldSelection}
|
|
gispacked := gispacked or lispacked;
|
|
with gattr do begin
|
|
|
|
{get the variable kind}
|
|
if typtr <> nil then begin
|
|
form := typtr^.form;
|
|
if not (form in [records,objects]) then begin
|
|
Error(65);
|
|
typtr := nil;
|
|
end; {if}
|
|
end {if}
|
|
else
|
|
form := records;
|
|
|
|
{get the field id}
|
|
if sy = ident then begin
|
|
if typtr <> nil then begin
|
|
|
|
{find the field}
|
|
if form = records then
|
|
SearchSection(typtr^.fstfld, lcp)
|
|
else
|
|
SearchSection(typtr^.objfld, lcp);
|
|
if lcp = nil then begin
|
|
Error(77);
|
|
typtr := nil;
|
|
end {if}
|
|
else begin
|
|
|
|
{dereference the field}
|
|
glcp := lcp;
|
|
with lcp^ do begin
|
|
typtr := idtype;
|
|
lispacked := typtr^.ispacked = pkpacked;
|
|
case access of
|
|
drct: begin
|
|
if form = objects then begin
|
|
typtr := longptr;
|
|
Load;
|
|
if debug then
|
|
GenL2t(pc_chk, 1, maxaddr, cgULong);
|
|
typtr := idtype;
|
|
isPacked := lispacked;
|
|
kind := varbl;
|
|
access := indrct;
|
|
if klass = field then
|
|
idplmt := fldaddr
|
|
else
|
|
idplmt := pfaddr;
|
|
end {if}
|
|
else begin
|
|
dpdisp := dpdisp + fldaddr;
|
|
if dpdisp > maxint then
|
|
{use indirect access}
|
|
LoadAddress;
|
|
end; {else}
|
|
end;
|
|
indrct: if form = objects then begin
|
|
typtr := longptr;
|
|
Load;
|
|
if debug then
|
|
GenL2t(pc_chk, 1, maxaddr, cgULong);
|
|
typtr := idtype;
|
|
isPacked := lispacked;
|
|
kind := varbl;
|
|
access := indrct;
|
|
if klass = field then
|
|
idplmt := fldaddr
|
|
else
|
|
idplmt := pfaddr;
|
|
end {if}
|
|
else
|
|
idplmt := idplmt + fldaddr;
|
|
inxd: Error(113)
|
|
end; {case}
|
|
end; {with}
|
|
|
|
{skip the field name}
|
|
InSymbol;
|
|
|
|
{check for method calls}
|
|
if glcp^.klass = proc then begin
|
|
disp := gattr.idplmt;
|
|
gattr.idplmt := 0;
|
|
LoadAddress;
|
|
Gen0t(pc_stk, cgULong);
|
|
CallNonStandard(fsys, glcp, fprocp, disp, cMethod);
|
|
isMethod := true;
|
|
end {if}
|
|
else if glcp^.klass = func then begin
|
|
disp := gattr.idplmt;
|
|
gattr.idplmt := 0;
|
|
LoadAddress;
|
|
Gen0t(pc_stk, cgULong);
|
|
isFunction := true;
|
|
CallNonStandard(fsys, glcp, fprocp, disp, cMethod);
|
|
isMethod := true;
|
|
if sy <> arrow then
|
|
gattr.kind := expr;
|
|
if sy in [period,lbrack] then
|
|
Error(23);
|
|
end; {else if}
|
|
end; {else}
|
|
end {if}
|
|
else
|
|
|
|
{skip the field name}
|
|
InSymbol;
|
|
end {sy = ident}
|
|
else
|
|
Error(2)
|
|
end; {with gattr}
|
|
end; {FieldSelection}
|
|
|
|
|
|
begin {Selector}
|
|
isFunction := false;
|
|
isMethod := false;
|
|
if not doingCast then begin
|
|
|
|
{access the identifier}
|
|
with fcp^, gattr do begin
|
|
typtr := idtype;
|
|
isPacked := false;
|
|
kind := varbl;
|
|
case klass of
|
|
varsm:
|
|
if vkind = actual then begin
|
|
{for actual variables, pass back the info}
|
|
access := drct;
|
|
vlevel := vlev;
|
|
dpdisp := 0;
|
|
if vlevel = 1 then
|
|
aname := name
|
|
else
|
|
dplab := vlabel;
|
|
end
|
|
else begin
|
|
{for formal variables, load their addr and indicate indirection}
|
|
Gen3t(pc_lod, vlabel, 0, level-vlev, cgULong);
|
|
access := indrct;
|
|
idplmt := 0
|
|
end;
|
|
field:
|
|
with display[disx] do
|
|
if occur = crec {field is directly accessable} then begin
|
|
access := drct;
|
|
vlevel := clev;
|
|
if vlevel = 1 then
|
|
aname := cname;
|
|
dpdisp := cdspl+fldaddr;
|
|
dplab := clab;
|
|
end {if}
|
|
else {field must be accessed indirectly} begin
|
|
{for with only - access temp global variable from stack frame}
|
|
Gen3t(pc_lod, vdsplab, 0, 0, cgULong);
|
|
access := indrct;
|
|
idplmt := fldaddr
|
|
end;
|
|
func: begin
|
|
isFunction := true;
|
|
Call(fsys, fcp, fprocp);
|
|
if sy <> arrow then
|
|
gattr.kind := expr;
|
|
if sy in [period,lbrack] then
|
|
Error(23);
|
|
end;
|
|
otherwise:;
|
|
end; {case}
|
|
end; {with}
|
|
if not (sy in selectsys + fsys) then begin
|
|
Error(29);
|
|
Skip(selectsys + fsys);
|
|
end;
|
|
lispacked := false;
|
|
if glcp <> nil then
|
|
with glcp^ do
|
|
if {glcp^.}idtype <> nil then
|
|
lispacked := {glcp^.}idtype^.ispacked = pkpacked;
|
|
{handle selections}
|
|
end; {with}
|
|
|
|
{do selections}
|
|
while sy in selectsys do begin
|
|
{[} if sy = lbrack then {indexes}
|
|
ArrayIndex
|
|
{.} else if sy = period then begin {record or object fields}
|
|
InSymbol;
|
|
FieldSelection;
|
|
end {else if}
|
|
{^} else begin
|
|
gispacked := false;
|
|
if gattr.typtr <> nil then
|
|
with gattr,typtr^ do
|
|
if form in [pointerStruct,files] then begin
|
|
if not isFunction then
|
|
Load;
|
|
if form = pointerStruct then
|
|
typtr := eltype
|
|
else
|
|
typtr := filtype;
|
|
lispacked := typtr^.ispacked = pkpacked;
|
|
if debug then
|
|
GenL2t(pc_chk, 1, maxaddr, cgULong);
|
|
with gattr do begin
|
|
isPacked := false;
|
|
kind := varbl;
|
|
access := indrct;
|
|
idplmt := 0;
|
|
end;
|
|
end
|
|
else
|
|
Error(66);
|
|
InSymbol;
|
|
end;
|
|
if not (sy in fsys + selectsys) then begin
|
|
Error(6);
|
|
Skip(fsys + selectsys);
|
|
end; {if}
|
|
end {while}
|
|
end; {Selector}
|
|
|
|
|
|
procedure InheritedCall (fsys: setofsys; fprocp: ctp);
|
|
|
|
{ Compile an inherited call }
|
|
{ }
|
|
{ parameters: }
|
|
{ fsys - follow symbols }
|
|
{ fprocp - identifier for program or program-level }
|
|
{ subroutine contining this statement }
|
|
|
|
var
|
|
lcp, lcp2, lcp3: ctp; {work identifiers}
|
|
loc: unsigned; {position of '~' in object.method name}
|
|
lsp: stp; {superclass object type}
|
|
|
|
begin {InheritedCall}
|
|
if sy = ident then begin
|
|
|
|
{find the current method's object}
|
|
SearchId([proc,func], lcp);
|
|
if lcp <> nil then begin
|
|
id := lcp^.pfoname^;
|
|
loc := Pos('~', id);
|
|
if loc <> 0 then
|
|
id[0] := chr(loc-1);
|
|
SearchId([types], lcp2);
|
|
|
|
{find the parent object}
|
|
if lcp2 <> nil then
|
|
if lcp2^.idtype <> nil then
|
|
if lcp2^.idtype^.objparent <> nil then begin
|
|
lsp := lcp2^.idtype^.objparent;
|
|
|
|
{find the method to be inherited}
|
|
id := lcp^.name^;
|
|
SearchSection(lsp^.objfld, lcp2);
|
|
if lcp2 = nil then
|
|
Error(130)
|
|
else begin
|
|
{set up the 'SELF' parameter}
|
|
id := 'SELF';
|
|
SearchId([varsm,field], lcp3);
|
|
if lcp3 <> nil then
|
|
if (lcp3^.idtype <> nil) and (lcp3^.klass = varsm) then begin
|
|
gattr.typtr := lcp3^.idtype;
|
|
gattr.isPacked := false;
|
|
gattr.kind := varbl;
|
|
gattr.access := drct;
|
|
gattr.vlevel := lcp3^.vlev;
|
|
gattr.dplab := lcp3^.vlabel;
|
|
gattr.dpdisp := 0;
|
|
gattr.aname := lcp3^.name;
|
|
Load;
|
|
Gen0t(pc_stk, cgULong);
|
|
end; {if}
|
|
|
|
{call the inherited method}
|
|
InSymbol;
|
|
CallNonStandard(fsys, lcp2, fprocp, 0, cInherited);
|
|
end; {else}
|
|
end; {if}
|
|
end; {if}
|
|
end {if}
|
|
else begin
|
|
Error(2);
|
|
Skip(fsys);
|
|
end; {else}
|
|
end; {InheritedCall}
|
|
|
|
|
|
procedure Expression {fsys: setofsys; fprocp: ctp};
|
|
|
|
{ compile an expression }
|
|
{ }
|
|
{ parameters: }
|
|
{ fsys - follow symbols }
|
|
{ fprocp - identifier for program or program-level }
|
|
{ subroutine contining this statement }
|
|
|
|
var
|
|
lattr: attr;
|
|
lop: operator;
|
|
typind: basetypeenum;
|
|
lsize,rsize: integer; {size of string operands}
|
|
|
|
procedure FloatCheck(var first, second: stp);
|
|
{insure that both operands are real}
|
|
|
|
begin {FloatCheck}
|
|
if (second = intptr) or (second = byteptr) then begin
|
|
Gen2(pc_cnv,ord(cgWord),ord(cgReal));
|
|
second := realptr;
|
|
end
|
|
else if second = longptr then begin
|
|
Gen2(pc_cnv,ord(cgLong),ord(cgReal));
|
|
second := realptr;
|
|
end
|
|
else if IsReal(second) then
|
|
second := realptr;
|
|
if (first = intptr) or (first = byteptr) then begin
|
|
Gen2(pc_cnn,ord(cgWord),ord(cgReal));
|
|
first := realptr;
|
|
end
|
|
else if first = longptr then begin
|
|
Gen2(pc_cnn,ord(cgLong),ord(cgReal));
|
|
first := realptr;
|
|
end
|
|
else if IsReal(first) then
|
|
first := realptr;
|
|
end; {FloatCheck}
|
|
|
|
procedure MatchOpnd(var first, second: stp);
|
|
{insure that the operand types match}
|
|
|
|
begin {MatchOpnd}
|
|
{eliminate need for redundant checking}
|
|
if second = byteptr then
|
|
second := intptr
|
|
else if IsReal(second) then
|
|
second := realptr;
|
|
if first = byteptr then
|
|
first := intptr
|
|
else if IsReal(first) then
|
|
first := realptr;
|
|
{match second operand to first if first is of higher type}
|
|
if second = intptr then begin
|
|
if first = longptr then begin
|
|
Gen2(pc_cnv,ord(cgWord),ord(cgLong));
|
|
second := longptr;
|
|
end
|
|
else if first = realptr then begin
|
|
Gen2(pc_cnv,ord(cgWord),ord(cgReal));
|
|
second := realptr;
|
|
end;
|
|
end
|
|
else if second = longptr then
|
|
if first = realptr then begin
|
|
Gen2(pc_cnv,ord(cgLong),ord(cgReal));
|
|
second := realptr;
|
|
end;
|
|
{match first operand to second if second is of higher type}
|
|
if first = intptr then begin
|
|
if second = longptr then begin
|
|
Gen2(pc_cnn,ord(cgWord),ord(cgLong));
|
|
first := longptr;
|
|
end
|
|
else if second = realptr then begin
|
|
Gen2(pc_cnn,ord(cgWord),ord(cgReal));
|
|
first := realptr;
|
|
end;
|
|
end
|
|
else if first = longptr then
|
|
if second = realptr then begin
|
|
Gen2(pc_cnn,ord(cgLong),ord(cgReal));
|
|
first := realptr;
|
|
end;
|
|
end; {MatchOpnd}
|
|
|
|
procedure SimpleExpression(fsys: setofsys);
|
|
{compile a simple expression}
|
|
|
|
var
|
|
lattr: attr;
|
|
lop: operator;
|
|
signed,foundSign: boolean;
|
|
|
|
procedure Term (fsys: setofsys);
|
|
|
|
{ compile a term }
|
|
{ }
|
|
{ parameters: }
|
|
{ fsys - follow symbols }
|
|
|
|
var
|
|
lattr: attr;
|
|
lop: operator;
|
|
|
|
|
|
procedure Factor (fsys: setofsys);
|
|
|
|
{ compile a factor }
|
|
{ }
|
|
{ parameters: }
|
|
{ fsys - follow symbols }
|
|
|
|
var
|
|
isMethod: boolean; {dummy for selector call}
|
|
lvp: csp;
|
|
varpart: boolean;
|
|
cstmax: setlow..sethigh;
|
|
lsp: stp;
|
|
lowrange,i: integer;
|
|
test: boolean;
|
|
lcp: ctp; {used to form addresses via atsy}
|
|
cstpart: ^settype;
|
|
castType: stp; {type to cast to (for type casting)}
|
|
castSize: addrrange; {sizes (for type casting)}
|
|
|
|
begin {Factor}
|
|
if not (sy in facbegsys) then begin
|
|
Error(28);
|
|
Skip(fsys + facbegsys);
|
|
gattr.typtr := nil;
|
|
end; {if}
|
|
while sy in facbegsys do begin
|
|
case sy of
|
|
{id} ident: begin
|
|
SearchId([types,konst,varsm,field,func],glcp);
|
|
with glcp^ do begin
|
|
InSymbol;
|
|
if klass = types then begin
|
|
{handle a type cast}
|
|
if iso then Error(112);
|
|
castType := {glcp^.}idtype;
|
|
castSize := castType^.size;
|
|
Match(lparent,9);
|
|
Expression(fsys + [rparent],fprocp);
|
|
if (gattr.typtr^.form in
|
|
[power,arrays,records,files,tagfld,variant])
|
|
or (castType^.form in [power,files,tagfld,variant]) then
|
|
Error(121);
|
|
if castSize <> gattr.typtr^.size then begin
|
|
{type conversion}
|
|
Load;
|
|
gattr.typtr := castType;
|
|
if castSize = 2 then
|
|
Gen2(pc_cnv,ord(cgLong),ord(cgWord))
|
|
else
|
|
Gen2(pc_cnv,ord(cgWord),ord(cgLong));
|
|
Match(rparent,4);
|
|
end
|
|
else begin
|
|
{treat space as another type}
|
|
gattr.typtr := castType;
|
|
Match(rparent,4);
|
|
doingCast := true;
|
|
Selector(fsys, glcp, fprocp, isMethod);
|
|
doingCast := false;
|
|
end;
|
|
end
|
|
else if klass = konst then
|
|
with gattr do begin
|
|
typtr := {glcp^.}idtype;
|
|
isPacked := false;
|
|
kind := cst;
|
|
cval := {glcp^.}values;
|
|
end
|
|
else
|
|
Selector(fsys, glcp, fprocp, isMethod);
|
|
end;
|
|
end;
|
|
{inherited} inheritedsy: begin
|
|
InSymbol;
|
|
InheritedCall(fsys, fprocp);
|
|
if sy <> arrow then
|
|
gattr.kind := expr;
|
|
if sy in [period,lbrack] then
|
|
Error(23);
|
|
end;
|
|
{nil} nilsy: begin
|
|
with gattr do begin
|
|
typtr := nilptr;
|
|
isPacked := false;
|
|
kind := cst;
|
|
cval.ival := 0;
|
|
InSymbol;
|
|
end;
|
|
end;
|
|
{atsy} atsy: begin
|
|
InSymbol;
|
|
if sy = ident then begin
|
|
SearchId([konst,varsm,field,func,proc],lcp);
|
|
InSymbol;
|
|
if lcp^.klass in [func,proc] then
|
|
Gen0Name(pc_lad,lcp^.name)
|
|
else if lcp^.klass = konst then begin
|
|
if IsString(lcp^.idtype) then begin
|
|
val := lcp^.values;
|
|
lgth := length(val.valp^.sval);
|
|
LoadString(lengthString);
|
|
LoadAddress;
|
|
end {if}
|
|
else
|
|
Error(32);
|
|
end {else if}
|
|
else begin
|
|
if lcp^.klass = varsm then begin
|
|
if lcp^.vcontvar then Error(97);
|
|
if lcp^.vlev <> level then lcp^.vrestrict := true;
|
|
end;
|
|
Selector(fsys, lcp, fprocp, isMethod);
|
|
LoadAddress;
|
|
end;
|
|
end
|
|
else if sy = stringconst then begin
|
|
LoadString(lengthString);
|
|
InSymbol;
|
|
LoadAddress;
|
|
end
|
|
else Error(2);
|
|
gattr.kind := expr;
|
|
gattr.typtr := nilptr;
|
|
end;
|
|
{cst} intconst: begin
|
|
with gattr do begin
|
|
typtr := intptr;
|
|
isPacked := false;
|
|
kind := cst;
|
|
cval := val;
|
|
end;
|
|
InSymbol;
|
|
end;
|
|
longintconst: begin
|
|
with gattr do begin
|
|
typtr := longptr;
|
|
isPacked := false;
|
|
kind := cst;
|
|
cval := val;
|
|
end;
|
|
InSymbol;
|
|
end;
|
|
realconst: begin
|
|
with gattr do begin
|
|
typtr := realptr;
|
|
isPacked := false;
|
|
kind := cst;
|
|
cval := val;
|
|
end;
|
|
InSymbol;
|
|
end;
|
|
stringconst: begin
|
|
with gattr do begin
|
|
if lgth = 1 then
|
|
typtr := charptr
|
|
else begin
|
|
lsp := pointer(Malloc(sizeof(structure)));
|
|
with lsp^ do begin
|
|
aeltype := charptr;
|
|
form := arrays;
|
|
hasSFile := false;
|
|
ispacked := pkpacked;
|
|
inxtype := dummystring;
|
|
size := lgth*packedcharsize;
|
|
end; {with}
|
|
typtr := lsp
|
|
end; {else}
|
|
isPacked := false;
|
|
kind := cst;
|
|
cval := val;
|
|
end; {with}
|
|
InSymbol;
|
|
end;
|
|
{(} lparent: begin
|
|
InSymbol;
|
|
Expression(fsys + [rparent],fprocp);
|
|
Load;
|
|
Match(rparent,4);
|
|
end;
|
|
{not} notsy: begin
|
|
InSymbol;
|
|
Factor(fsys);
|
|
Load;
|
|
Gen0(pc_not);
|
|
if gattr.typtr <> nil then
|
|
if gattr.typtr <> boolptr then begin
|
|
Error(60); gattr.typtr := nil;
|
|
end;
|
|
end;
|
|
{~} bitnot: begin
|
|
InSymbol;
|
|
Factor(fsys);
|
|
Load;
|
|
if gattr.typtr <> nil then
|
|
if (gattr.typtr = intptr) or (gattr.typtr = byteptr) then
|
|
Gen0(pc_bnt)
|
|
else if gattr.typtr = longptr then
|
|
Gen0(pc_bnl)
|
|
else begin
|
|
Error(59);
|
|
gattr.typtr := nil;
|
|
end;
|
|
end;
|
|
{[} lbrack: begin
|
|
new(cstPart);
|
|
InSymbol;
|
|
cstpart^ := [ ];
|
|
varpart := false;
|
|
lsp := pointer(Malloc(sizeof(structure)));
|
|
cstmax := setlow;
|
|
with lsp^ do begin
|
|
ispacked := pkeither;
|
|
hasSFile := false;
|
|
form := power;
|
|
elset := nil;
|
|
end;
|
|
if sy = rbrack then begin
|
|
lsp^.size := cstmax div 8 + 1;
|
|
with gattr do begin
|
|
typtr := lsp;
|
|
isPacked := false;
|
|
kind := cst
|
|
end;
|
|
InSymbol;
|
|
end
|
|
else begin
|
|
repeat
|
|
Expression(fsys + [comma,rbrack,dotdot],fprocp);
|
|
if gattr.typtr <> nil then
|
|
if not (gattr.typtr^.form in [scalar,subrange]) then begin
|
|
Error(61);
|
|
gattr.typtr := nil;
|
|
end
|
|
else if CompTypes(lsp^.elset,gattr.typtr) then begin
|
|
if gattr.kind = cst then begin
|
|
if (gattr.cval.ival < setlow) or
|
|
(gattr.cval.ival > sethigh) then Error(110);
|
|
if sy = dotdot then begin
|
|
InSymbol;
|
|
lowrange := gattr.cval.ival;
|
|
Expression(fsys+[comma,rbrack],fprocp);
|
|
if gattr.typtr <> nil then
|
|
if not (gattr.typtr^.form in [scalar,subrange]) then
|
|
begin
|
|
Error(61);
|
|
gattr.typtr := nil;
|
|
end
|
|
else if CompTypes(lsp^.elset,gattr.typtr) then begin
|
|
if gattr.kind = cst then begin
|
|
if gattr.cval.ival>sethigh then Error(110);
|
|
for i := lowrange to gattr.cval.ival do
|
|
cstpart^ := cstpart^+[i];
|
|
if gattr.cval.ival > cstmax then
|
|
cstmax := gattr.cval.ival;
|
|
end
|
|
else begin
|
|
Gen1t(pc_ldc, lowRange, cgWord);
|
|
Load;
|
|
if debug then
|
|
Gen2t(pc_chk, setlow, sethigh, cgUWord);
|
|
Gen0(pc_sgs);
|
|
if varpart then Gen0(pc_uni)
|
|
else varpart := true
|
|
end;
|
|
end
|
|
else Error(62);
|
|
end
|
|
else begin
|
|
cstpart^ := cstpart^+[gattr.cval.ival];
|
|
if gattr.cval.ival > cstmax then
|
|
cstmax := gattr.cval.ival;
|
|
end
|
|
end
|
|
else begin
|
|
Load;
|
|
if debug then
|
|
Gen2t(pc_chk, setlow, sethigh, cgUWord);
|
|
if sy = dotdot then begin
|
|
InSymbol;
|
|
Expression(fsys+[comma,rbrack],fprocp);
|
|
if gattr.typtr <> nil then
|
|
if not (gattr.typtr^.form in [scalar,subrange]) then
|
|
begin
|
|
Error(61);
|
|
gattr.typtr := nil;
|
|
end
|
|
else if CompTypes(lsp^.elset,gattr.typtr) then begin
|
|
Load;
|
|
if debug then
|
|
Gen2t(pc_chk, setlow, sethigh, cgUWord);
|
|
end
|
|
else Error(62);
|
|
end
|
|
else
|
|
Gen1t(pc_ldc, $8000, cgUWord);
|
|
Gen0(pc_sgs);
|
|
if varpart then Gen0(pc_uni)
|
|
else varpart := true
|
|
end;
|
|
lsp^.elset := gattr.typtr;
|
|
gattr.typtr := lsp
|
|
end
|
|
else Error(62);
|
|
test := sy <> comma;
|
|
if not test then InSymbol
|
|
until test;
|
|
Match(rbrack,12);
|
|
end;
|
|
if varpart then begin
|
|
if cstpart^ <> [ ] then begin
|
|
lvp := pointer(Malloc(sizeof(constantRec)));
|
|
with lvp^ do begin
|
|
cclass := pset;
|
|
pval := cstpart^;
|
|
pmax := cstmax;
|
|
end;
|
|
GenLdcSet(lvp^);
|
|
Gen0(pc_uni);
|
|
gattr.kind := expr;
|
|
end
|
|
end
|
|
else begin
|
|
lvp := pointer(Malloc(sizeof(constantRec)));
|
|
with lvp^ do begin
|
|
cclass := pset;
|
|
pval := cstpart^;
|
|
pmax := cstmax;
|
|
end;
|
|
gattr.cval.valp := lvp;
|
|
gattr.isPacked := false;
|
|
gattr.kind := cst;
|
|
end;
|
|
dispose(cstPart);
|
|
end
|
|
end; {case}
|
|
if not (sy in (fsys+[powersy])) then begin
|
|
Error(6);
|
|
Skip(fsys + facbegsys);
|
|
end; {if}
|
|
end; {while}
|
|
if sy = powersy then begin
|
|
Load;
|
|
if (gattr.typtr = intptr) or (gattr.typtr = byteptr) then
|
|
Gen2(pc_cnv,ord(cgWord),ord(cgReal))
|
|
else if gattr.typtr = longptr then
|
|
Gen2(pc_cnv,ord(cgLong),ord(cgReal))
|
|
else if not IsReal(gattr.typtr) then
|
|
Error(59);
|
|
InSymbol;
|
|
Factor(fsys);
|
|
Load;
|
|
if (gattr.typtr = intptr) or (gattr.typtr = byteptr) then
|
|
Gen2(pc_cnv,ord(cgWord),ord(cgReal))
|
|
else if gattr.typtr = longptr then
|
|
Gen2(pc_cnv,ord(cgLong),ord(cgReal))
|
|
else if not IsReal(gattr.typtr) then
|
|
Error(59);
|
|
Gen0(pc_pwr);
|
|
gattr.typtr := realptr;
|
|
end;
|
|
end; {Factor}
|
|
|
|
begin {Term}
|
|
Factor(fsys + [mulop,powersy]);
|
|
while sy = mulop do begin
|
|
Load;
|
|
lattr := gattr;
|
|
lop := op;
|
|
InSymbol;
|
|
Factor(fsys + [mulop]);
|
|
Load;
|
|
if (lattr.typtr <> nil) and (gattr.typtr <> nil) then
|
|
case lop of
|
|
{*} mul: begin
|
|
MatchOpnd(lattr.typtr,gattr.typtr);
|
|
if lattr.typtr = intptr then
|
|
Gen0(pc_mpi)
|
|
else if lattr.typtr = longptr then
|
|
Gen0(pc_mpl)
|
|
else if lattr.typtr = realptr then
|
|
Gen0(pc_mpr)
|
|
else if(lattr.typtr^.form=power)
|
|
and CompTypes(lattr.typtr,gattr.typtr)then
|
|
Gen0(pc_int)
|
|
else begin
|
|
Error(59);
|
|
gattr.typtr:=nil;
|
|
end;
|
|
end;
|
|
{/} rdiv: begin
|
|
FloatCheck(lattr.typtr,gattr.typtr);
|
|
if lattr.typtr = realptr then
|
|
Gen0(pc_dvr)
|
|
else begin
|
|
Error(59);
|
|
gattr.typtr := nil;
|
|
end;
|
|
end;
|
|
{div} idiv: begin
|
|
MatchOpnd(lattr.typtr,gattr.typtr);
|
|
if lattr.typtr = intptr then
|
|
Gen0(pc_dvi)
|
|
else if lattr.typtr = longptr then
|
|
Gen0(pc_dvl)
|
|
else begin
|
|
Error(59);
|
|
gattr.typtr := nil;
|
|
end;
|
|
end;
|
|
{mod} imod: begin
|
|
MatchOpnd(lattr.typtr,gattr.typtr);
|
|
if lattr.typtr = intptr then
|
|
Gen0(pc_mod)
|
|
else if lattr.typtr = longptr then
|
|
Gen0(pc_mdl)
|
|
else begin
|
|
Error(59);
|
|
gattr.typtr := nil;
|
|
end;
|
|
end;
|
|
{and} andop:
|
|
if (lattr.typtr = boolptr) and (gattr.typtr = boolptr) then
|
|
Gen0(pc_and)
|
|
else begin
|
|
Error(59);
|
|
gattr.typtr := nil;
|
|
end;
|
|
{<<} lshift: begin
|
|
MatchOpnd(lattr.typtr,gattr.typtr);
|
|
if lattr.typtr=intptr then
|
|
Gen0(pc_shl)
|
|
else if lattr.typtr = longptr then
|
|
Gen0(pc_sll)
|
|
else begin
|
|
Error(59);
|
|
gattr.typtr:=nil;
|
|
end;
|
|
end;
|
|
{>>} rshift: begin
|
|
MatchOpnd(lattr.typtr,gattr.typtr);
|
|
if lattr.typtr=intptr then
|
|
Gen0(pc_shr)
|
|
else if lattr.typtr = longptr then
|
|
Gen0(pc_slr)
|
|
else begin
|
|
Error(59);
|
|
gattr.typtr:=nil;
|
|
end;
|
|
end;
|
|
{&} band: begin
|
|
MatchOpnd(lattr.typtr,gattr.typtr);
|
|
if lattr.typtr=intptr then
|
|
Gen0(pc_bnd)
|
|
else if lattr.typtr = longptr then
|
|
Gen0(pc_bal)
|
|
else begin
|
|
Error(59);
|
|
gattr.typtr:=nil;
|
|
end;
|
|
end;
|
|
end {case}
|
|
else
|
|
gattr.typtr := nil;
|
|
end; {while}
|
|
end; {Term}
|
|
|
|
begin {SimpleExpression}
|
|
signed := false;
|
|
foundSign := false;
|
|
if (sy = addop) and (op in [plus,minus]) then begin
|
|
signed := op = minus;
|
|
InSymbol;
|
|
foundSign := true;
|
|
end;
|
|
Term(fsys + [addop]);
|
|
if signed then begin
|
|
Load;
|
|
if (gattr.typtr = intptr) or (gattr.typtr = byteptr) then
|
|
Gen0(pc_ngi)
|
|
else if gattr.typtr = longptr then
|
|
Gen0(pc_ngl)
|
|
else if IsReal(gattr.typtr) then
|
|
Gen0(pc_ngr)
|
|
else begin
|
|
Error(59);
|
|
gattr.typtr := nil;
|
|
end;
|
|
end
|
|
else if foundSign then
|
|
if (gattr.typtr <> intptr) and (not IsReal(gattr.typtr))
|
|
and (gattr.typtr <> byteptr) and (gattr.typtr <> longptr) then
|
|
Error(34);
|
|
while sy = addop do begin
|
|
Load;
|
|
lattr := gattr;
|
|
lop := op;
|
|
InSymbol;
|
|
Term(fsys + [addop]);
|
|
Load;
|
|
if (lattr.typtr <> nil) and (gattr.typtr <> nil) then
|
|
case lop of
|
|
{+} plus: begin
|
|
MatchOpnd(lattr.typtr,gattr.typtr);
|
|
if lattr.typtr = intptr then
|
|
Gen0(pc_adi)
|
|
else if lattr.typtr = longptr then
|
|
Gen0(pc_adl)
|
|
else if lattr.typtr = realptr then
|
|
Gen0(pc_adr)
|
|
else if (lattr.typtr^.form=power)
|
|
and CompTypes(lattr.typtr,gattr.typtr) then
|
|
Gen0(pc_uni)
|
|
else begin
|
|
Error(59);
|
|
gattr.typtr:=nil;
|
|
end;
|
|
end;
|
|
{-} minus: begin
|
|
MatchOpnd(lattr.typtr,gattr.typtr);
|
|
if lattr.typtr = intptr then
|
|
Gen0(pc_sbi)
|
|
else if lattr.typtr = longptr then
|
|
Gen0(pc_sbl)
|
|
else if lattr.typtr = realptr then
|
|
Gen0(pc_sbr)
|
|
else if (lattr.typtr^.form = power)
|
|
and CompTypes(lattr.typtr,gattr.typtr) then
|
|
Gen0(pc_dif)
|
|
else begin
|
|
Error(59);
|
|
gattr.typtr := nil;
|
|
end;
|
|
end;
|
|
{or} orop:
|
|
if (lattr.typtr = boolptr) and (gattr.typtr = boolptr) then
|
|
Gen0(pc_ior)
|
|
else begin
|
|
Error(59);
|
|
gattr.typtr := nil;
|
|
end;
|
|
{|} bor: begin
|
|
MatchOpnd(lattr.typtr,gattr.typtr);
|
|
if lattr.typtr = intptr then
|
|
Gen0(pc_bor)
|
|
else if lattr.typtr = longptr then
|
|
Gen0(pc_blr)
|
|
else begin
|
|
Error(59);
|
|
gattr.typtr:=nil;
|
|
end;
|
|
end;
|
|
{!} xor: begin
|
|
MatchOpnd(lattr.typtr,gattr.typtr);
|
|
if lattr.typtr = intptr then
|
|
Gen0(pc_bxr)
|
|
else if lattr.typtr = longptr then
|
|
Gen0(pc_blx)
|
|
else begin
|
|
Error(59);
|
|
gattr.typtr:=nil;
|
|
end;
|
|
end;
|
|
end {case}
|
|
else gattr.typtr := nil
|
|
end; {while}
|
|
end; {SimpleExpression}
|
|
|
|
begin {Expression}
|
|
SimpleExpression(fsys + [relop]);
|
|
if sy = relop then begin
|
|
if gattr.typtr <> nil then
|
|
if gattr.typtr^.form in [scalar..power,objects] then
|
|
Load
|
|
else
|
|
LoadAddress;
|
|
lattr := gattr;
|
|
lop := op;
|
|
InSymbol;
|
|
SimpleExpression(fsys);
|
|
{set the size of the left operand}
|
|
if lattr.typtr <> nil then
|
|
if IsString(lattr.typtr) then
|
|
lsize := StrLen(lattr.typtr);
|
|
if gattr.typtr <> nil then begin
|
|
if IsString(gattr.typtr) then
|
|
if lattr.typtr = charptr then begin
|
|
lattr.typtr := stringptr;
|
|
lsize := -1;
|
|
end;
|
|
if gattr.typtr^.form in [scalar..power,objects] then
|
|
Load
|
|
else
|
|
LoadAddress;
|
|
end;
|
|
{set the size of the right operand}
|
|
if IsString(gattr.typtr) then
|
|
rsize := StrLen(gattr.typtr)
|
|
else begin
|
|
if lattr.typtr <> nil then
|
|
if IsString(lattr.typtr) then
|
|
if gattr.typtr = charptr then begin
|
|
gattr.typtr := stringptr;
|
|
rsize := -1;
|
|
end; {if}
|
|
end; {else}
|
|
|
|
if (lattr.typtr <> nil) and (gattr.typtr <> nil) then
|
|
if lop = inop then
|
|
if lattr.typtr^.form<power then
|
|
if gattr.typtr^.form = power then
|
|
if CompTypes(lattr.typtr,gattr.typtr^.elset) then
|
|
Gen0(pc_inn)
|
|
else begin Error(54); gattr.typtr := nil; end
|
|
else begin Error(55); gattr.typtr := nil; end
|
|
else begin Error(54); gattr.typtr := nil; end
|
|
else begin
|
|
MatchOpnd(lattr.typtr,gattr.typtr);
|
|
if CompTypes(lattr.typtr,gattr.typtr) then begin
|
|
case lattr.typtr^.form of
|
|
scalar:
|
|
if lattr.typtr = realptr then typind := cgReal
|
|
else if lattr.typtr = boolptr then typind := cgUWord
|
|
else if lattr.typtr = charptr then typind := cgUWord
|
|
else if lattr.typtr = doubleptr then typind := cgDouble
|
|
else if lattr.typtr = compptr then typind := cgComp
|
|
else if lattr.typtr = extendedptr then typind := cgExtended
|
|
else if lattr.typtr = longptr then typind := cgLong
|
|
else typind := cgWord;
|
|
pointerStruct,objects: begin
|
|
if lop in [ltop,leop,gtop,geop] then Error(56);
|
|
typind := cgULong;
|
|
end;
|
|
power: begin
|
|
if lop in [ltop,gtop] then Error(57);
|
|
typind := cgSet;
|
|
end;
|
|
arrays: begin
|
|
if not IsString(lattr.typtr) then Error(59);
|
|
typind := cgString;
|
|
end;
|
|
records: begin
|
|
Error(59);
|
|
typind := cgString;
|
|
end;
|
|
files: begin
|
|
Error(58);
|
|
typind := cgULong;
|
|
end
|
|
end;
|
|
if typind = cgString then begin
|
|
case lop of
|
|
ltop: Gen2t(pc_les, lsize, rsize, typind);
|
|
leop: Gen2t(pc_leq, lsize, rsize, typind);
|
|
gtop: Gen2t(pc_grt, lsize, rsize, typind);
|
|
geop: Gen2t(pc_geq, lsize, rsize, typind);
|
|
neop: Gen2t(pc_neq, lsize, rsize, typind);
|
|
eqop: Gen2t(pc_equ, lsize, rsize, typind);
|
|
end {case}
|
|
end
|
|
else
|
|
case lop of
|
|
ltop: Gen0t(pc_les, typind);
|
|
leop: Gen0t(pc_leq, typind);
|
|
gtop: Gen0t(pc_grt, typind);
|
|
geop: Gen0t(pc_geq, typind);
|
|
neop: Gen0t(pc_neq, typind);
|
|
eqop: Gen0t(pc_equ, typind);
|
|
end; {case}
|
|
end
|
|
else Error(54);
|
|
end;
|
|
gattr.typtr := boolptr;
|
|
gattr.kind := expr;
|
|
end; {sy = relop}
|
|
end; {Expression}
|
|
|
|
|
|
procedure Statement (fsys: setofsys; fprocp: ctp; var stlevel: integer;
|
|
var starray: starrtype);
|
|
|
|
{ Compile a statement }
|
|
{ }
|
|
{ parameters: }
|
|
{ fsys - }
|
|
{ fprocp - identifier for program or program-level }
|
|
{ subroutine contining this statement }
|
|
{ stlevel - }
|
|
{ starray - }
|
|
|
|
label 1;
|
|
|
|
var
|
|
lcp, fcp: ctp; {work identifier pointers}
|
|
llp: lbp; i: integer;
|
|
|
|
|
|
procedure MakeLab(var ml: ctp; n: integer);
|
|
{Change a numbered label into a named label}
|
|
|
|
var i: integer;
|
|
|
|
begin {MakeLab}
|
|
ml := pointer(Malloc(sizeof(identifier)));
|
|
with ml^ do begin
|
|
name := pointer(Malloc(6));
|
|
name^[0] := chr(5);
|
|
name^[1] := '~';
|
|
for i := 5 downto 2 do begin
|
|
name^[i] := chr(ord('0')+n mod 10);
|
|
n := n div 10;
|
|
end;
|
|
end;
|
|
end; {MakeLab}
|
|
|
|
|
|
procedure Assignment (fcp: ctp);
|
|
|
|
{ compile an assignment statement }
|
|
{ }
|
|
{ parameters: }
|
|
{ fcp - leading identifier in assignment statement }
|
|
|
|
label 1;
|
|
|
|
var
|
|
isMethod: boolean; {is this a method call?}
|
|
lattr: attr; {attr for left hand side}
|
|
tattr: attr; {for checking string types}
|
|
stringAssignment: boolean; {are we assigning a string?}
|
|
|
|
begin {Assignment}
|
|
isMethod := false;
|
|
stringAssignment := false;
|
|
if fcp <> nil then
|
|
with fcp^ do begin
|
|
if klass = func then begin
|
|
|
|
{function assignment}
|
|
pfset := true;
|
|
if pfdeckind = standard then begin
|
|
Error(75);
|
|
gattr.typtr := nil;
|
|
end
|
|
else begin
|
|
if pfkind = formal then
|
|
Error(76)
|
|
else if pflev+1 > level then
|
|
Error(93);
|
|
with gattr do begin
|
|
typtr := idtype;
|
|
isPacked := false;
|
|
kind := varbl;
|
|
access := drct;
|
|
vlevel := pflev+1;
|
|
dplab := pflabel;
|
|
dpdisp := 0;
|
|
end; {with}
|
|
end;
|
|
goto 1;
|
|
end {if}
|
|
else if klass = varsm then begin
|
|
|
|
{variable (non-function) assignment}
|
|
if vcontvar then
|
|
Error(97);
|
|
if vlev <> level then
|
|
vrestrict := true;
|
|
end; {else if}
|
|
end; {with}
|
|
Selector(fsys + [becomes], fcp, fprocp, isMethod);
|
|
|
|
{handle the right-hand side}
|
|
1: if not isMethod then
|
|
if sy = becomes then begin
|
|
if gattr.typtr <> nil then begin
|
|
stringAssignment := IsString(gattr.typtr);
|
|
if (gattr.access<>drct) or
|
|
(gattr.typtr^.form in [arrays,records,files]) then begin
|
|
LoadAddress;
|
|
if stringAssignment then
|
|
Gen0t(pc_stk, cgULong);
|
|
end; {if}
|
|
if stringAssignment then begin
|
|
Gen1t(pc_ldc, StrLen(gattr.typtr), cgWord);
|
|
Gen0t(pc_stk, cgWord);
|
|
Gen0t(pc_bno, cgWord);
|
|
end; {if}
|
|
end; {if}
|
|
lattr := gattr;
|
|
InSymbol;
|
|
Expression(fsys,fprocp);
|
|
tattr := gattr;
|
|
if gattr.typtr <> nil then
|
|
if gattr.typtr^.form = objects then begin
|
|
Load;
|
|
if debug then
|
|
GenL2t(pc_chk, 1, maxaddr, cgULong);
|
|
end {if}
|
|
else if gattr.typtr^.form in [scalar,subrange,pointerStruct,power] then
|
|
Load
|
|
else
|
|
LoadAddress;
|
|
|
|
if (lattr.typtr <> nil) and (gattr.typtr <> nil) then begin
|
|
if CompTypes(realptr, lattr.typtr) then begin
|
|
|
|
{convert a non-real rhs to a real before storing}
|
|
if (gattr.typtr = intptr) or (gattr.typtr = bytePtr) then begin
|
|
Gen2(pc_cnv, ord(cgWord), ord(cgReal));
|
|
gattr.typtr := realptr;
|
|
end
|
|
else if gattr.typtr = longptr then begin
|
|
Gen2(pc_cnv, ord(cgLong), ord(cgReal));
|
|
gattr.typtr := realptr;
|
|
end;
|
|
end
|
|
else if CompTypes(longptr, lattr.typtr) then
|
|
|
|
{convert a non-long rhs to a long before storing}
|
|
if (gattr.typtr = intptr) or (gattr.typtr = bytePtr) then begin
|
|
Gen2(pc_cnv, ord(cgWord), ord(cgLong));
|
|
gattr.typtr := longptr;
|
|
end; {if}
|
|
|
|
{convert a char rhs to a string before storing}
|
|
if gattr.typtr = charptr then begin
|
|
if IsString(lattr.typtr) then begin
|
|
stringAssignment := true;
|
|
gattr.typtr := stringptr;
|
|
Gen0t(pc_stk, cgUWord);
|
|
GenLdcLong(-1);
|
|
Gen0t(pc_stk, cgULong);
|
|
Gen0t(pc_bno, cgULong);
|
|
Gen0t(pc_bno, cgULong);
|
|
end;
|
|
end
|
|
else if IsString(tattr.typtr) then begin
|
|
if tattr.kind <> expr then begin
|
|
Gen0t(pc_stk, cgULong);
|
|
Gen1t(pc_ldc, StrLen(tattr.typtr), cgWord);
|
|
Gen0t(pc_stk, cgWord);
|
|
Gen0t(pc_bno, cgWord);
|
|
end; {if}
|
|
Gen0t(pc_bno, cgULong);
|
|
end;
|
|
|
|
{do the assignment}
|
|
if CompTypes(lattr.typtr, gattr.typtr) then begin
|
|
case lattr.typtr^.form of
|
|
scalar,subrange: begin
|
|
CheckBnds(lattr.typtr);
|
|
Store(lattr);
|
|
end;
|
|
pointerStruct, power, objects:
|
|
Store(lattr);
|
|
arrays,records:
|
|
if stringAssignment then
|
|
Gen1(pc_csp,91{mvs})
|
|
else
|
|
Gen2(pc_mov, long(lattr.typtr^.size).msw,
|
|
long(lattr.typtr^.size).lsw);
|
|
files: ;
|
|
end; {case}
|
|
if gattr.typtr^.hasSFile then
|
|
if lattr.typtr^.form <> pointerStruct then
|
|
Error(71);
|
|
end {if}
|
|
else if CompObjects(lattr.typtr, gattr.typtr) then
|
|
Store(lattr)
|
|
else
|
|
Error(54);
|
|
end {if}
|
|
end {sy = becomes}
|
|
else
|
|
Error(23);
|
|
end; {Assignment}
|
|
|
|
|
|
procedure GotoStatement;
|
|
{Compile a goto statement}
|
|
|
|
label 1;
|
|
|
|
var
|
|
llp: lbp;
|
|
ttop: disprange;
|
|
i: integer;
|
|
fcp: ctp;
|
|
|
|
begin {GotoStatement}
|
|
if sy = intconst then begin
|
|
ttop := level;
|
|
repeat
|
|
llp := display[ttop].flabel;
|
|
while llp <> nil do
|
|
with llp^ do
|
|
if labval = val.ival then begin
|
|
for i := ttop to level-1 do
|
|
Gen0(pc_prs);
|
|
if labname >= firstlab then
|
|
Gen1(pc_ujp, labname)
|
|
else begin
|
|
MakeLab(fcp,labname);
|
|
Gen0Name(pc_ujp, fcp^.name);
|
|
end;
|
|
if defined then begin
|
|
if lstlevel > stlevel then Error(99)
|
|
else begin
|
|
for i := 1 to lstlevel-1 do
|
|
if starray[i] <> lstarray[i] then begin
|
|
Error(99); goto 1;
|
|
end;
|
|
end;
|
|
end
|
|
else begin
|
|
if ttop<>level then lstlevel := 1
|
|
else if lstlevel = 0 then begin
|
|
lstlevel := stlevel; lstarray := starray;
|
|
end
|
|
else begin
|
|
if lstlevel > stlevel then lstlevel := stlevel;
|
|
for i := 1 to lstlevel do
|
|
if lstarray[i] <> starray[i] then begin
|
|
lstlevel := i; goto 1;
|
|
end;
|
|
end;
|
|
end;
|
|
goto 1;
|
|
end
|
|
else llp := nextlab;
|
|
ttop := ttop-1;
|
|
until ttop = 0;
|
|
Error(89);
|
|
1: InSymbol
|
|
end
|
|
else Error(15)
|
|
end; {GotoStatement}
|
|
|
|
procedure StartStruct;
|
|
|
|
begin {StartStruct}
|
|
if stlevel < maxgoto then starray[stlevel] := starray[stlevel]+1;
|
|
stlevel := stlevel+1;
|
|
end; {StartStruct}
|
|
|
|
procedure EndStruct;
|
|
|
|
begin {EndStruct}
|
|
if stlevel < maxgoto then starray[stlevel] := 0;
|
|
stlevel := stlevel-1;
|
|
end; {EndStruct}
|
|
|
|
procedure CompoundStatement;
|
|
{compile a compound statement}
|
|
|
|
var
|
|
test: boolean;
|
|
|
|
begin {CompoundStatement}
|
|
StartStruct;
|
|
repeat
|
|
repeat
|
|
Statement(fsys + [semicolon,endsy],fprocp,stlevel,starray);
|
|
until not (sy in statbegsys);
|
|
test := sy <> semicolon;
|
|
if not test then InSymbol
|
|
until test;
|
|
Match(endsy,13); EndStruct;
|
|
end; {CompoundStatement}
|
|
|
|
procedure IfStatement;
|
|
|
|
var
|
|
lcix1,lcix2: integer;
|
|
|
|
begin {IfStatement}
|
|
Expression(fsys + [thensy],fprocp);
|
|
lcix1 := GenLabel;
|
|
checkbool;
|
|
Gen1(pc_fjp, lcix1);
|
|
Match(thensy,24);
|
|
StartStruct;
|
|
Statement(fsys + [elsesy],fprocp,stlevel,starray);
|
|
EndStruct;
|
|
if sy = elsesy then begin
|
|
lcix2 := GenLabel;
|
|
Gen1(pc_ujp, lcix2);
|
|
Gen1(dc_lab, lcix1);
|
|
InSymbol; StartStruct;
|
|
Statement(fsys,fprocp,stlevel,starray);
|
|
EndStruct;
|
|
Gen1(dc_lab, lcix2)
|
|
end
|
|
else
|
|
Gen1(dc_lab, lcix1)
|
|
end {IfStatement} ;
|
|
|
|
procedure CaseStatement;
|
|
{compile a case statement}
|
|
|
|
label 1;
|
|
|
|
const
|
|
sparse = 5; {label to tableSize ratio for sparse table}
|
|
|
|
var
|
|
foundlab: boolean; {was a label found?}
|
|
fstptr,lpt1,lpt2,lpt3: cip;
|
|
isotherwise: boolean; {was the last label 'otherwise'?}
|
|
laddr, lcix, lcix1: integer;
|
|
lcount: unsigned; {number of case labels}
|
|
lmin, lmax: integer; {low, high case label}
|
|
llb: unsigned; {used to allocate temporary space}
|
|
lsp,lsp1: stp;
|
|
lval: valu;
|
|
otherlab: unsigned; {otherwise label number}
|
|
test: boolean;
|
|
|
|
begin {CaseStatement}
|
|
{evaluate the case expression}
|
|
otherlab := 0;
|
|
Expression(fsys + [ofsy,comma,colon],fprocp);
|
|
Load;
|
|
llb := GetTemp(intsize);
|
|
Gen3t(pc_str, llb, 0, 0, cgWord);
|
|
lcix := GenLabel;
|
|
lsp := gattr.typtr;
|
|
if lsp <> nil then
|
|
if (lsp^.form <> scalar) or IsReal(lsp) then begin
|
|
Error(69);
|
|
lsp := nil;
|
|
end; {if}
|
|
Gen1(pc_ujp, lcix);
|
|
Match(ofsy,8);
|
|
fstptr := nil;
|
|
laddr := GenLabel;
|
|
|
|
{collect the labeled statements}
|
|
lmax := -maxint;
|
|
lcount := 0;
|
|
repeat
|
|
StartStruct;
|
|
lpt3 := nil;
|
|
lcix1 := GenLabel;
|
|
foundlab := false;
|
|
if not(sy in [semicolon,endsy]) then begin
|
|
repeat
|
|
if sy = otherwisesy then begin
|
|
if otherlab <> 0 then
|
|
Error(80)
|
|
else begin
|
|
foundlab := true;
|
|
otherlab := lcix1;
|
|
end;
|
|
InSymbol;
|
|
isotherwise := true;
|
|
end {if}
|
|
else begin
|
|
isotherwise := false;
|
|
DoConstant(fsys + [comma,colon],lsp1,lval);
|
|
if lval.ival > lmax then
|
|
lmax := lval.ival;
|
|
if lsp <> nil then
|
|
if CompTypes(lsp,lsp1) then begin
|
|
lpt1 := fstptr;
|
|
lpt2 := nil;
|
|
while lpt1 <> nil do
|
|
with lpt1^ do begin
|
|
if cslab >= lval.ival then begin
|
|
if cslab = lval.ival then
|
|
Error(80);
|
|
goto 1;
|
|
end; {if}
|
|
lpt2 := lpt1;
|
|
lpt1 := next;
|
|
end; {with}
|
|
1: lpt3 := pointer(Malloc(sizeof(caseInfo)));
|
|
foundlab := true;
|
|
with lpt3^ do begin
|
|
next := lpt1;
|
|
cslab := lval.ival;
|
|
csstart := lcix1;
|
|
end; {with}
|
|
lcount := lcount+1;
|
|
if lpt2 = nil then
|
|
fstptr := lpt3
|
|
else
|
|
lpt2^.next := lpt3
|
|
end {if}
|
|
else
|
|
Error(72);
|
|
end;
|
|
test := sy <> comma;
|
|
if not test then InSymbol;
|
|
until test;
|
|
if sy = colon then
|
|
InSymbol
|
|
else if not isotherwise then
|
|
Error(5);
|
|
Gen1(dc_lab, lcix1);
|
|
repeat
|
|
Statement(fsys + [semicolon],fprocp,stlevel,starray);
|
|
until not (sy in statbegsys);
|
|
if foundlab then
|
|
Gen1(pc_ujp, laddr);
|
|
end;
|
|
test := sy <> semicolon;
|
|
if not test then InSymbol;
|
|
EndStruct;
|
|
until test;
|
|
|
|
{generate the branch code}
|
|
Gen1(dc_lab, lcix);
|
|
if fstptr <> nil then begin {if there are labels...}
|
|
lmin := fstptr^.cslab;
|
|
if (lmax - lmin) div lcount > sparse then begin
|
|
|
|
{use if-else for sparse case statements}
|
|
while fstptr <> nil do begin
|
|
Gen1t(pc_ldc, fstptr^.cslab, cgWord);
|
|
Gen3t(pc_lod, llb, 0, 0, cgWord);
|
|
Gen0t(pc_equ, cgWord);
|
|
Gen1(pc_tjp, fstptr^.csstart);
|
|
fstptr := fstptr^.next;
|
|
end; {while}
|
|
{handle untrapped values}
|
|
if otherlab <> 0 then
|
|
Gen1(pc_ujp, otherlab)
|
|
else begin
|
|
Gen0(pc_nop);
|
|
Gen1tName(pc_cup, 0, cgVoid, @'~XJPERROR');
|
|
end; {if}
|
|
end {if}
|
|
else begin
|
|
|
|
{use a jump table for compact case statements}
|
|
Gen3t(pc_lod, llb, 0, 0, cgWord); {do the indexed jump}
|
|
Gen1t(pc_dec, lmin, cgWord);
|
|
Gen1(pc_xjp, lmax-lmin+1);
|
|
repeat {generate the jump table}
|
|
with fstptr^ do begin
|
|
while cslab > lmin do begin {generate default labels for gaps in }
|
|
Gen1(pc_add, otherlab); { the table }
|
|
lmin := lmin+1;
|
|
end; {while}
|
|
Gen1(pc_add, csstart); {generate an entry for a label that }
|
|
fstptr := next; {was specified }
|
|
lmin := lmin+1;
|
|
end; {with}
|
|
until fstptr = nil;
|
|
Gen1(pc_add, otherlab); {generate a label for overflows}
|
|
end; {else}
|
|
|
|
Gen1(dc_lab, laddr); {for branching around the table}
|
|
end; {if}
|
|
Match(endsy,13);
|
|
FreeTemp(llb, intsize); {free the temp label}
|
|
end; {CaseStatement}
|
|
|
|
procedure RepeatStatement;
|
|
|
|
var
|
|
laddr: integer;
|
|
|
|
begin {RepeatStatement}
|
|
laddr := GenLabel;
|
|
Gen1(dc_lab, laddr);
|
|
StartStruct;
|
|
repeat
|
|
Statement(fsys + [semicolon,untilsy],fprocp,stlevel,starray);
|
|
if sy in statbegsys then Error(14)
|
|
until not(sy in statbegsys);
|
|
while sy = semicolon do
|
|
begin InSymbol;
|
|
repeat
|
|
Statement(fsys + [semicolon,untilsy],fprocp,stlevel,starray);
|
|
if sy in statbegsys then Error(14)
|
|
until not (sy in statbegsys);
|
|
end;
|
|
Match(untilsy,25);
|
|
Expression(fsys,fprocp);
|
|
checkbool;
|
|
Gen1(pc_fjp, laddr);
|
|
EndStruct;
|
|
end {RepeatStatement} ;
|
|
|
|
procedure WhileStatement;
|
|
|
|
var
|
|
laddr, lcix: integer;
|
|
|
|
begin {WhileStatement}
|
|
laddr := GenLabel;
|
|
Gen1(dc_lab, laddr);
|
|
StartStruct;
|
|
Expression(fsys + [dosy],fprocp);
|
|
lcix := GenLabel;
|
|
checkbool;
|
|
Gen1(pc_fjp, lcix);
|
|
Match(dosy,26);
|
|
Statement(fsys,fprocp,stlevel,starray);
|
|
Gen1(pc_ujp, laddr);
|
|
Gen1(dc_lab, lcix);
|
|
EndStruct;
|
|
end; {WhileStatement}
|
|
|
|
procedure ForStatement;
|
|
{compile a for loop}
|
|
|
|
var
|
|
firstExpr: boolean; {was the first thing an expression?}
|
|
lattr,lattr2: attr; {local attributes for start, stop}
|
|
ldattr: attr; {lattr without subranges removed}
|
|
lsy: symbol; {preserve symbol past InSymbol call}
|
|
lab1, lab2: integer; {top, bottom labels}
|
|
llb,llb2: unsigned; {used to allocate temporary space}
|
|
llb1Used,llb2Used: boolean; {was work space used?}
|
|
lcp,cvlcp: ctp; {temp ptr to identifier}
|
|
sattr: attr; {attr for start expr}
|
|
isunsigned: boolean; {is the loop variable unsigned?}
|
|
|
|
startConst,endConst: boolean; {are start,stop points constant?}
|
|
startVal,endVal: integer; { if so, these are the values}
|
|
|
|
|
|
begin {ForStatement}
|
|
{no work space reserved yet}
|
|
llb1Used := false;
|
|
llb2Used := false;
|
|
firstExpr := false;
|
|
|
|
{set up the top and bottom loop points}
|
|
lab1 := GenLabel;
|
|
lab2 := GenLabel;
|
|
|
|
{set up a default control variable}
|
|
with lattr do begin
|
|
typtr := nil;
|
|
isPacked := false;
|
|
kind := varbl;
|
|
aName := pointer(ord4(@' ')+1);
|
|
access := drct;
|
|
vlevel := level;
|
|
dpdisp := 0;
|
|
end;
|
|
|
|
{find and check the control variable}
|
|
isunsigned := false;
|
|
if sy = ident then begin
|
|
SearchId([varsm],lcp);
|
|
if lcp <> nil then
|
|
if lcp^.idtype <> nil then
|
|
if lcp^.idtype^.form = subrange then
|
|
isunsigned := lcp^.idtype^.min >= 0;
|
|
with lattr do begin
|
|
isPacked := false;
|
|
kind := varbl;
|
|
with lcp^ do begin
|
|
typtr := idtype;
|
|
if vcontvar or vrestrict then
|
|
Error(97);
|
|
{prohibit use of this var as a control var}
|
|
vcontvar := true;
|
|
if vkind = actual then
|
|
if vlev = level then begin
|
|
access := drct;
|
|
aname := name;
|
|
vlevel := level;
|
|
dpdisp := 0;
|
|
if level <> 1 then
|
|
dplab := vlabel;
|
|
end
|
|
else begin
|
|
Error(79);
|
|
typtr := nil;
|
|
end
|
|
else begin
|
|
Error(95);
|
|
typtr := nil;
|
|
end;{else}
|
|
end; {with}
|
|
end; {with}
|
|
cvlcp := lcp;
|
|
ldattr := lattr;
|
|
if lattr.typtr <> nil then
|
|
if (lattr.typtr^.form > subrange)
|
|
or CompTypes(realptr,lattr.typtr)
|
|
or CompTypes(longptr,lattr.typtr) then begin
|
|
Error(68);
|
|
lattr.typtr := nil;
|
|
end;
|
|
InSymbol;
|
|
end
|
|
else begin
|
|
Error(2);
|
|
Skip(fsys + [becomes,tosy,downtosy,dosy]);
|
|
end;
|
|
{evaluate the start value for the loop}
|
|
if sy = becomes then begin
|
|
InSymbol;
|
|
Expression(fsys + [tosy,downtosy,dosy],fprocp);
|
|
if gattr.typtr <> nil then begin
|
|
if gattr.typtr^.form = subrange then
|
|
gattr.typtr := gattr.typtr^.rangetype;
|
|
if gattr.typtr^.form <> scalar then
|
|
Error(69)
|
|
else if CompTypes(lattr.typtr,gattr.typtr) then begin
|
|
lattr2 := lattr;
|
|
if gattr.kind = cst then begin
|
|
startConst := true;
|
|
startVal := gattr.cval.ival;
|
|
end {if}
|
|
else begin
|
|
startConst := false;
|
|
with gattr do
|
|
if (kind = expr) or ((kind = varbl) and (access <> drct)) then
|
|
begin
|
|
Load;
|
|
llb := GetTemp(intsize);
|
|
llb1Used := true;
|
|
Gen3t(pc_str, llb, 0, 0, cgWord);
|
|
isPacked := false;
|
|
kind := varbl;
|
|
access := drct;
|
|
vlevel := level;
|
|
dplab := llb;
|
|
firstExpr := true;
|
|
end; {with}
|
|
end; {else}
|
|
sattr := gattr;
|
|
end {else if}
|
|
else
|
|
Error(70);
|
|
end; {if}
|
|
{evaluate the loop condition and stop point}
|
|
if sy in [tosy,downtosy] then begin
|
|
lsy := sy;
|
|
InSymbol;
|
|
Expression(fsys + [dosy],fprocp);
|
|
if gattr.typtr <> nil then begin
|
|
if gattr.typtr^.form = subrange then
|
|
gattr.typtr := gattr.typtr^.rangetype;
|
|
if gattr.typtr^.form <> scalar then
|
|
Error(69)
|
|
else if CompTypes(lattr.typtr,gattr.typtr) then begin
|
|
if gattr.kind = cst then begin
|
|
endConst := true;
|
|
endVal := gattr.cval.ival;
|
|
end
|
|
else begin
|
|
endConst := false;
|
|
Load;
|
|
{make room for the end value on the stack frame}
|
|
llb2 := GetTemp(intsize);
|
|
llb2Used := true;
|
|
Gen3t(pc_str, llb2, 0, 0, cgWord);
|
|
end;
|
|
{initialize the loop variable}
|
|
gattr := sattr;
|
|
if firstExpr then
|
|
Gen3t(pc_lod, gattr.dplab, 0, 0, cgWord)
|
|
else
|
|
Load;
|
|
Store(lattr);
|
|
if (not startConst) or (not endConst) then begin
|
|
{check for a skip of the entire body}
|
|
gattr := ldattr;
|
|
Load;
|
|
if endConst then
|
|
Gen1t(pc_ldc, endVal, cgWord)
|
|
else
|
|
Gen3t(pc_lod, llb2, 0, 0, cgWord);
|
|
if lsy = downtosy then
|
|
if isunsigned then
|
|
Gen0t(pc_geq, cgUWord)
|
|
else
|
|
Gen0t(pc_geq, cgWord)
|
|
else
|
|
if isunsigned then
|
|
Gen0t(pc_leq, cgUWord)
|
|
else
|
|
Gen0t(pc_leq, cgWord);
|
|
Gen1(pc_fjp, lab2);
|
|
end {if}
|
|
else if lsy = tosy then begin
|
|
if endVal < startVal then
|
|
Gen1(pc_ujp, lab2);
|
|
end {else if}
|
|
else
|
|
if endVal > startVal then
|
|
Gen1(pc_ujp, lab2);
|
|
Gen1(dc_lab, lab1);
|
|
end {else if}
|
|
else
|
|
Error(70);
|
|
end {if}
|
|
end
|
|
else begin
|
|
Error(27);
|
|
Skip(fsys + [dosy]);
|
|
end; {else}
|
|
{must find the closing do}
|
|
Match(dosy,26);
|
|
{compile the body of the loop}
|
|
StartStruct;
|
|
Statement(fsys,fprocp,stlevel,starray);
|
|
EndStruct;
|
|
if endConst then begin
|
|
{handle a constant stop condition}
|
|
{update the control var}
|
|
gattr := lattr;
|
|
Load;
|
|
if lsy = tosy then
|
|
Gen1t(pc_inc, 1, cgWord)
|
|
else
|
|
Gen1t(pc_dec, 1, cgWord);
|
|
Store(lattr);
|
|
{branch if not done}
|
|
gattr := lattr;
|
|
Load;
|
|
if lsy = tosy then
|
|
Gen1t(pc_ldc, endVal+1, cgWord)
|
|
else
|
|
Gen1t(pc_ldc, endVal-1, cgWord);
|
|
Gen0t(pc_equ, cgWord);
|
|
Gen1(pc_fjp, lab1);
|
|
end
|
|
else begin
|
|
{handle a constant end condition}
|
|
{branch if done}
|
|
gattr := lattr;
|
|
Load;
|
|
Gen3t(pc_lod, llb2, 0, 0, cgWord);
|
|
Gen0t(pc_neq, cgWord);
|
|
Gen1(pc_fjp, lab2);
|
|
{update the control var}
|
|
gattr := lattr;
|
|
Load;
|
|
if lsy = tosy then
|
|
Gen1t(pc_inc, 1, cgWord)
|
|
else
|
|
Gen1t(pc_dec, 1, cgWord);
|
|
Store(lattr);
|
|
{back to the top}
|
|
Gen1(pc_ujp, lab1);
|
|
end;
|
|
Gen1(dc_lab, lab2);
|
|
{remove the end value's space from the used part of the stack frame}
|
|
if llb1Used then
|
|
FreeTemp(llb, intsize);
|
|
if llb2Used then
|
|
FreeTemp(llb2, intsize);
|
|
{allow reuse of this var as a control var}
|
|
cvlcp^.vcontvar := false;
|
|
end
|
|
else begin
|
|
Error(23);
|
|
Skip(fsys + [semicolon]);
|
|
end;
|
|
end; {ForStatement}
|
|
|
|
procedure WithStatement;
|
|
{compile the with statement}
|
|
|
|
var
|
|
form: structform; {kind of with (records or objects)}
|
|
isMethod: boolean; {dummy for selector call}
|
|
lcp: ctp;
|
|
llb: unsigned; {for reserving work space}
|
|
llbUsed: boolean; {was llc used?}
|
|
name: pStringPtr; {name of the record being with-ed}
|
|
test: boolean; {test for loop termination}
|
|
len: integer; {string length}
|
|
oldtop: integer; {old top value}
|
|
|
|
begin {WithStatement}
|
|
llbUsed := false;
|
|
oldtop := top;
|
|
repeat
|
|
if sy = ident then begin
|
|
len := ord(id[0])+2;
|
|
name := pointer(Malloc(len));
|
|
CopyString(name^,id,len);
|
|
SearchId([varsm,field],lcp);
|
|
InSymbol;
|
|
end
|
|
else begin
|
|
Error(2);
|
|
lcp := uvarptr;
|
|
name := nil;
|
|
end;
|
|
Selector(fsys + [comma,dosy], lcp, fprocp, isMethod);
|
|
if gattr.typtr <> nil then begin
|
|
form := gattr.typtr^.form;
|
|
if form in [records,objects] then
|
|
if top < displimit then begin
|
|
top := top+1;
|
|
with display[top] do begin
|
|
cname := pointer(ord4(@' ')+1);
|
|
if form = records then
|
|
fname := gattr.typtr^.fstfld
|
|
else
|
|
fname := gattr.typtr^.objfld;
|
|
flabel := nil;
|
|
ispacked := gattr.typtr^.ispacked = pkpacked;
|
|
end; {with}
|
|
if (gattr.access = drct) and (form = records) then
|
|
with display[top] do begin
|
|
occur := crec;
|
|
labsused := nil;
|
|
clev := gattr.vlevel;
|
|
if display[disx].occur = crec then
|
|
cname := display[disx].cname
|
|
else
|
|
cname := name;
|
|
name := nil;
|
|
cdspl := gattr.dpdisp;
|
|
clab := gattr.dplab;
|
|
end
|
|
else begin
|
|
if gattr.access = drct {and (form = objects)} then
|
|
Load
|
|
else
|
|
LoadAddress;
|
|
llb := GetTemp(ptrsize);
|
|
llbUsed := true;
|
|
if level <= 1 then
|
|
Gen3t(pc_str, llb, 0, level-1, cgULong)
|
|
else
|
|
Gen3t(pc_str, llb, 0, 0, cgULong);
|
|
with display[top] do begin
|
|
labsused := nil;
|
|
occur := vrec;
|
|
vdsplab := llb;
|
|
end; {with}
|
|
end; {else}
|
|
end {if}
|
|
else
|
|
Error(107)
|
|
else
|
|
Error(65);
|
|
end; {if}
|
|
test := sy <> comma;
|
|
if not test then
|
|
InSymbol;
|
|
until test;
|
|
Match(dosy,26);
|
|
StartStruct;
|
|
Statement(fsys,fprocp,stlevel,starray);
|
|
EndStruct;
|
|
if llbUsed then
|
|
FreeTemp(llb, ptrsize);
|
|
top := oldtop;
|
|
end; {WithStatement}
|
|
|
|
|
|
begin {Statement}
|
|
if sy = intconst then begin
|
|
{define a label for gotos}
|
|
llp := display[level].flabel;
|
|
while llp <> nil do
|
|
with llp^ do
|
|
if labval = val.ival then begin
|
|
if defined then Error(87);
|
|
if labname > firstlab then
|
|
Gen1(dc_lab, labname)
|
|
else begin
|
|
MakeLab(fcp,labname);
|
|
Gen0name(dc_lab, fcp^.name);
|
|
end;
|
|
defined := true;
|
|
if lstlevel <> 0 then
|
|
if stlevel > lstlevel then Error(99)
|
|
else
|
|
for i := 1 to stlevel-1 do
|
|
if starray[i] <> lstarray[i] then begin
|
|
Error(99);
|
|
goto 1;
|
|
end;
|
|
lstlevel := stlevel;
|
|
lstarray := starray;
|
|
goto 1;
|
|
end
|
|
else llp := nextlab;
|
|
Error(89);
|
|
1: InSymbol; Match(colon,5);
|
|
end;
|
|
if not (sy in fsys + [ident]) then begin
|
|
Error(6);
|
|
Skip(fsys);
|
|
end;
|
|
|
|
{if trace names are enabled and a line # is due, generate it}
|
|
if debugFlag or traceBack then
|
|
if lastline<>linecount then
|
|
if namFound then begin
|
|
lastline := linecount;
|
|
Gen2(pc_lnm, linecount, ord(debugType));
|
|
end;
|
|
if sy in statbegsys + [ident] then begin
|
|
case sy of
|
|
beginsy: begin InSymbol; CompoundStatement; end;
|
|
gotosy: begin InSymbol; GotoStatement; end;
|
|
ifsy: begin InSymbol; IfStatement; end;
|
|
casesy: begin InSymbol; CaseStatement; end;
|
|
whilesy: begin InSymbol; WhileStatement; end;
|
|
repeatsy: begin InSymbol; RepeatStatement; end;
|
|
forsy: begin InSymbol; ForStatement; end;
|
|
withsy: begin InSymbol; WithStatement; end;
|
|
inheritedsy: begin InSymbol; InheritedCall(fsys, fprocp); end;
|
|
ident: begin
|
|
SearchId([varsm,field,func,proc], lcp);
|
|
InSymbol;
|
|
if lcp^.klass = proc then
|
|
Call(fsys, lcp, fprocp)
|
|
else
|
|
Assignment(lcp);
|
|
end;
|
|
end;
|
|
{if the string heap was used, purge it}
|
|
if stringHeap then begin
|
|
stringHeap := false;
|
|
Gen0(pc_nop);
|
|
Gen1(pc_csp,92{dsh});
|
|
end;
|
|
{make sure the next token is legal}
|
|
if not (sy in [semicolon,endsy,elsesy,untilsy]) then begin
|
|
Error(6);
|
|
Skip(fsys);
|
|
end;
|
|
end;
|
|
end; {Statement}
|
|
|
|
procedure Body (fsys: setofsys; fprocp: ctp);
|
|
|
|
{ Compile the body of a procedure, function or program }
|
|
{ }
|
|
{ parameters: }
|
|
{ fsys - follow symbols }
|
|
{ fprocp - identifier for program or program-level }
|
|
{ subroutine contining this statement }
|
|
|
|
var
|
|
llcp: ctp;
|
|
saveId: pStringPtr; {program identifier name}
|
|
i: integer;
|
|
llbl: unsigned;
|
|
lcp: ctp;
|
|
llp: lbp;
|
|
fcp: csp;
|
|
fsp: stp;
|
|
plabel: unsigned; {largest parameter label number}
|
|
size: unsigned; {temp size}
|
|
stlevel: integer;
|
|
starray: starrtype;
|
|
test: boolean;
|
|
hasFiles: boolean; {are there any files in the block?}
|
|
|
|
procedure GenLocals (lcp: ctp; pLab: unsigned);
|
|
|
|
{ define non-array global variables }
|
|
{ }
|
|
{ parameters: }
|
|
{ lcp - symbol table node }
|
|
{ pLab - largest parameter label }
|
|
|
|
begin {GenLocals}
|
|
if lcp <> nil then
|
|
with lcp^ do begin
|
|
GenLocals(rlink, pLab);
|
|
GenLocals(llink, pLab);
|
|
if klass = varsm then
|
|
if vlabel > pLab then
|
|
Gen2(dc_loc, vlabel, long(idtype^.size).lsw);
|
|
end; {with}
|
|
end; {GenLocals}
|
|
|
|
|
|
procedure OpenFiles (lcp: ctp);
|
|
|
|
{ open all files in the block }
|
|
{ }
|
|
{ parameters: }
|
|
{ lcp - symbol table node }
|
|
|
|
begin {OpenFiles}
|
|
if lcp <> nil then
|
|
with lcp^ do begin
|
|
OpenFiles(rlink);
|
|
OpenFiles(llink);
|
|
if hasIFile then
|
|
if klass = varsm then begin
|
|
hasFiles := true;
|
|
Gen1t(pc_ldc, ord(idtype^.size), cgUWord);
|
|
Gen0t(pc_stk, cgWord);
|
|
with gattr do begin
|
|
typtr := idtype;
|
|
access := drct;
|
|
isPacked := false;
|
|
kind := varbl;
|
|
vlevel := vlev;
|
|
dpdisp := 0;
|
|
if vlev <> 1 then
|
|
dplab := vlabel;
|
|
aname := name;
|
|
end; {with}
|
|
LoadAddress;
|
|
Gen0t(pc_stk, cgULong);
|
|
Gen0t(pc_bno, cgULong);
|
|
Gen1(pc_csp,35{clr});
|
|
end; {if}
|
|
end; {with}
|
|
end; {OpenFiles}
|
|
|
|
|
|
procedure WithSelf;
|
|
|
|
{ Fake a "with self do begin" for methods }
|
|
|
|
var
|
|
form: structform; {kind of with (records or objects)}
|
|
lid: pString; {copy of id}
|
|
lcp: ctp; {object type}
|
|
|
|
begin {WithSelf}
|
|
lid := id;
|
|
id := 'SELF';
|
|
SearchId([varsm,field],lcp);
|
|
if lcp <> nil then
|
|
if lcp^.idtype <> nil then begin
|
|
form := lcp^.idtype^.form;
|
|
if form in [records,objects] then
|
|
if top < displimit then begin
|
|
top := top+1;
|
|
with display[top] do begin
|
|
isPacked := lcp^.idtype^.ispacked = pkpacked;
|
|
labsused := nil;
|
|
if form = records then
|
|
fname := lcp^.idtype^.fstfld
|
|
else
|
|
fname := lcp^.idtype^.objfld;
|
|
flabel := nil;
|
|
occur := vrec;
|
|
vdsplab := lcp^.vlabel;
|
|
end; {with}
|
|
end {if}
|
|
else
|
|
Error(107)
|
|
else
|
|
Error(65);
|
|
end; {if}
|
|
id := lid;
|
|
end; {WithSelf}
|
|
|
|
|
|
begin {Body}
|
|
namFound := false; {turn line #s off}
|
|
for stlevel := 1 to maxgoto do
|
|
starray[stlevel] := 0;
|
|
stlevel := 1;
|
|
if level = 1 {program block} then begin
|
|
Gen2Name(dc_str, $4000+$8000*ord(isDynamic), 0, fprocp^.name);
|
|
inseg := true;
|
|
end
|
|
else if level = 2 {entry of level 1 procedure} then
|
|
Gen0(dc_pin)
|
|
else {imbeded procedure}
|
|
Gen1(dc_lab, fprocp^.pfname);
|
|
Gen0(pc_ent); {create a stack frame}
|
|
ResetTemp; {forget old temporary variables}
|
|
|
|
lcp := fprocp^.pfparms; {generate code for passed parameters}
|
|
plabel := 0;
|
|
while lcp <> nil do
|
|
with lcp^ do begin
|
|
if klass = varsm then begin
|
|
if idtype <> nil then
|
|
if idtype^.form > power then begin
|
|
{handle variables always passed as pointers}
|
|
if vkind = actual then begin
|
|
if (idtype^.form = records) and (idtype^.size <= 4) then begin
|
|
{short records are passed by value}
|
|
if idtype^.size <= 2 then
|
|
size := 2
|
|
else
|
|
size := 4;
|
|
psize := psize-size;
|
|
Gen3(dc_prm, vlabel, size, psize);
|
|
end {if}
|
|
else if idtype^.form = objects then begin
|
|
psize := psize-ptrsize;
|
|
Gen3(dc_prm, vlabel, ptrsize, psize);
|
|
end {else if}
|
|
else begin
|
|
psize := psize-ptrsize;
|
|
size := long(idtype^.size).lsw;
|
|
Gen3(dc_prm, vlabel-1, ptrsize, psize);
|
|
Gen2(dc_loc, vlabel, size);
|
|
Gen3(pc_lda, vlabel, 0, 0);
|
|
Gen3t(pc_lod, vlabel-1, 0, 0, cgULong);
|
|
Gen2(pc_mov, 0, size);
|
|
end; {else}
|
|
end {if}
|
|
else begin
|
|
psize := psize-ptrsize;
|
|
Gen3(dc_prm, vlabel, ptrsize, psize);
|
|
end; {else}
|
|
end {else if}
|
|
else if vkind = actual then begin
|
|
if IsReal(idtype) then begin
|
|
psize := psize-extSize;
|
|
Gen3(dc_prm, vlabel, extSize, psize);
|
|
if GetType(idtype, false) <> cgExtended then
|
|
Gen1t(pc_fix, vlabel, GetType(idtype, false));
|
|
end
|
|
else if idtype = byteptr then begin
|
|
psize := psize-intSize;
|
|
Gen3(dc_prm, vlabel, intSize, psize);
|
|
end {else if}
|
|
else begin
|
|
size := long(idtype^.size).lsw;
|
|
psize := psize-size;
|
|
Gen3(dc_prm, vlabel, size, psize);
|
|
end; {else}
|
|
end
|
|
else begin
|
|
psize := psize-ptrsize;
|
|
Gen3(dc_prm, vlabel, ptrsize, psize);
|
|
end; {else}
|
|
if vlabel > plabel then
|
|
plabel := vlabel;
|
|
end {if}
|
|
else if klass in [proc,func] then begin
|
|
psize := psize-procsize;
|
|
Gen3(dc_prm, pflabel, procsize, psize);
|
|
if pflabel > plabel then
|
|
plabel := pflabel;
|
|
end; {else if}
|
|
lcp := lcp^.next;
|
|
end; {with}
|
|
if fprocp^.klass = func then begin {generate the function label}
|
|
case GetType(fprocp^.idtype, false) of
|
|
cgByte,cgUByte,
|
|
cgWord,cgUWord: size := cgWordSize;
|
|
cgLong,cgULong: size := cgLongSize;
|
|
cgReal: size := cgRealSize;
|
|
cgDouble: size := cgDoubleSize;
|
|
cgComp: size := cgCompSize;
|
|
cgExtended: size := cgExtendedSize;
|
|
otherwise: size := 0;
|
|
end; {case}
|
|
Gen2(dc_fun, fprocp^.pflabel, size);
|
|
if fprocp^.pflabel > plabel then
|
|
plabel := fprocp^.pflabel;
|
|
end; {if}
|
|
if level <> 1 then {generate space for local variables}
|
|
GenLocals(display[top].fname, plabel);
|
|
|
|
{record the current procedure name}
|
|
if debugFlag or profileFlag or traceBack then begin
|
|
fcp := pointer(Malloc(sizeof(constantRec)));
|
|
with fcp^ do begin
|
|
cclass := strg;
|
|
sval := fprocp^.name^;
|
|
end; {with}
|
|
GenPS(pc_nam, fprocp^.pfoname);
|
|
namFound := true; {turn line #s on}
|
|
end; {if}
|
|
{give the symbol table to the code }
|
|
{ generator. }
|
|
if debugFlag then
|
|
Gen1Name(dc_sym, 0, pointer(display[top].fname));
|
|
if fprocp^.klass = prog then begin
|
|
new(saveId);
|
|
saveId^ := id;
|
|
while fextfilep <> nil do begin
|
|
with fextfilep^ do
|
|
if not ((CompNames(filename^,inputid) = 0) or
|
|
(CompNames(filename^,outputid) = 0) or
|
|
(CompNames(filename^,erroroutputid) = 0)) then begin
|
|
id := filename^;
|
|
SearchSection(display[1].fname,llcp);
|
|
if llcp = nil then begin
|
|
write('**** Undeclared external variable: ', filename^);
|
|
FlagError;
|
|
end
|
|
else if llcp^.klass in [proc,func] then begin
|
|
write('**** External variable cannot be procedure or function: ',
|
|
filename^);
|
|
FlagError;
|
|
end;
|
|
end;
|
|
fextfilep := fextfilep^.nextfile;
|
|
end;
|
|
id := saveId^;
|
|
dispose(saveId);
|
|
end;
|
|
if isMethod then {do "with self do begin"}
|
|
WithSelf;
|
|
hasFiles := false; {initialize all file variables}
|
|
OpenFiles(display[top].fname);
|
|
if hasFiles then begin
|
|
{create a new file record level}
|
|
Gen0(pc_nop);
|
|
Gen1(pc_csp,96{orc});
|
|
end;
|
|
repeat {compile the statements in the body}
|
|
repeat
|
|
Statement(fsys+[semicolon,endsy],fprocp,stlevel,starray);
|
|
until not (sy in statbegsys);
|
|
test := sy <> semicolon;
|
|
if not test then
|
|
InSymbol;
|
|
until test;
|
|
Match(endsy,13);
|
|
llp := display[top].flabel; {test for undefined labels}
|
|
while llp <> nil do
|
|
with llp^ do begin
|
|
if not defined then begin
|
|
write('**** undefined label: ',labval:1);
|
|
FlagError;
|
|
end;
|
|
llp := nextlab;
|
|
end;
|
|
if hasFiles then begin {close all files opened in this block}
|
|
Gen0(pc_nop);
|
|
Gen1(pc_csp,97{crc});
|
|
end;
|
|
if fprocp^.klass <> func then {return to caller}
|
|
Gen0t(pc_ret, cgVoid)
|
|
else
|
|
Gen0t(pc_ret, GetType(fprocp^.idtype, false));
|
|
if level <= 2 then begin {finish the segment}
|
|
Gen0(dc_enp);
|
|
intlabel := firstlab;
|
|
inseg := false;
|
|
if fprocp^.klass in [proc,func] then begin
|
|
release(fprocp^.pfmark);
|
|
code := pointer(Calloc(sizeof(intermediate_code)));
|
|
end;
|
|
end;
|
|
if isMethod then {do "end" for "with self do begin"}
|
|
top := top-1;
|
|
end; {Body}
|
|
|
|
procedure DoBlock {fsys: setofsys; fsy: symbol; fprocp: ctp;
|
|
isProgram: boolean};
|
|
{compile a block}
|
|
|
|
label 1;
|
|
|
|
const
|
|
returnSize = 3; {size of a return address}
|
|
|
|
var
|
|
actuallc: addrrange; {used when updating actual parm locs}
|
|
lsy: symbol; {temp symbol}
|
|
foundBody: boolean; {dummy var for ProcDeclaration}
|
|
lisMethod: boolean; {copy of isMethod}
|
|
lcp: ctp; {work pointer}
|
|
procName: pStringPtr; {name of proc being compiled}
|
|
|
|
|
|
procedure CheckForw(lcp: ctp);
|
|
|
|
begin {CheckForw}
|
|
if lcp<>nil then with lcp^ do begin
|
|
CheckForw(rlink);
|
|
CheckForw(llink);
|
|
if (klass in [proc,func]) and (pfkind = actual) then
|
|
if pfdirective = drforw then begin
|
|
write('**** forward ref not resolved: ', name^);
|
|
FlagError;
|
|
end;
|
|
end;
|
|
end; {CheckForw}
|
|
|
|
|
|
function ShouldBeCompiled(fsy: symbol): boolean;
|
|
{check to see if a level 1 proc should be compiled; skip if not}
|
|
|
|
var
|
|
foundBody: boolean; {did the proc have a body}
|
|
llist: boolean; {local list flag}
|
|
|
|
|
|
function InPartialList(var name: pString): boolean;
|
|
|
|
{ see if a name is in the partial compile list }
|
|
{ }
|
|
{ parameters: }
|
|
{ name - name to check }
|
|
{ }
|
|
{ returns: True if the name is in the list, else false }
|
|
{ }
|
|
{ Note: name is var to save space - it is not changed }
|
|
|
|
label 1;
|
|
|
|
var
|
|
ptr,lptr: partialptr;
|
|
|
|
begin {InPartialList}
|
|
InPartialList := true;
|
|
ptr := partialList;
|
|
lptr := nil;
|
|
while ptr <> nil do begin
|
|
with ptr^ do
|
|
if CompNames(name, pname^) = 0 then goto 1;
|
|
lptr := ptr;
|
|
ptr := ptr^.next;
|
|
end; {while}
|
|
InPartialList := false;
|
|
1:
|
|
end; {InPartialList}
|
|
|
|
|
|
procedure SkipProc;
|
|
{skip a procedure or function}
|
|
|
|
var
|
|
cnt: integer; {# ends needed}
|
|
lcp: ctp; {work pointer for skipping forwards}
|
|
|
|
begin {SkipProc}
|
|
{skip to the first function or procedure, or the body}
|
|
while (not eofl) and (not(sy in [beginsy,procsy,funcsy])) do
|
|
InSymbol;
|
|
{skip all of the procedure and function declarations}
|
|
while sy in [procsy,funcsy] do begin
|
|
{skip to the parameter list or the end of the header}
|
|
while (not eofl) and (not (sy in [lparent,semicolon])) do InSymbol;
|
|
{if there is a header, skip it}
|
|
if sy = lparent then begin
|
|
InSymbol;
|
|
cnt := 1;
|
|
while (cnt > 0) and (not eofl) do begin
|
|
if sy = lparent then cnt := cnt+1
|
|
else if sy = rparent then cnt := cnt-1;
|
|
InSymbol;
|
|
end;
|
|
end;
|
|
{skip the function return type, if any}
|
|
while (sy <> semicolon) and (not eofl) do InSymbol;
|
|
InSymbol;
|
|
{if the declaration has no block, skip the identifiers (forward, etc)}
|
|
if sy = ident then begin
|
|
SearchId([directive],lcp);
|
|
InSymbol;
|
|
if sy = lparent then begin
|
|
while (sy <> rparent) and (not eofl) do InSymbol;
|
|
InSymbol;
|
|
end;
|
|
Match(semicolon,14);
|
|
end
|
|
{for procedures with a block, skip it here}
|
|
else
|
|
SkipProc;
|
|
end;
|
|
{skip the body}
|
|
Match(beginsy,17);
|
|
cnt := 1;
|
|
while (cnt > 0) and (not eofl) do begin
|
|
if sy in [beginsy,casesy] then
|
|
cnt := cnt+1
|
|
else if sy = endsy then
|
|
cnt := cnt-1;
|
|
InSymbol;
|
|
end;
|
|
Match(semicolon,14);
|
|
end; {SkipProc}
|
|
|
|
begin {ShouldBeCompiled}
|
|
if InPartialList(id) then
|
|
ShouldBeCompiled := true
|
|
else begin
|
|
ShouldBeCompiled := false;
|
|
{compile the header}
|
|
ProcDeclaration(fsy, fsys, false, false, foundBody);
|
|
{if there is a body, skip it}
|
|
if foundBody then begin
|
|
llist := list;
|
|
list := false;
|
|
SkipProc;
|
|
list := llist;
|
|
end;
|
|
end;
|
|
end; {ShouldBeCompiled}
|
|
|
|
|
|
procedure Remove(var name: pString);
|
|
|
|
{ remove a name from the partial compile list }
|
|
{ }
|
|
{ parameters: }
|
|
{ name - name to remove }
|
|
{ }
|
|
{ Note: name is var to save space - it is not changed }
|
|
|
|
label 1;
|
|
|
|
var
|
|
ptr,lptr: partialptr;
|
|
|
|
begin {Remove}
|
|
ptr := partialList;
|
|
lptr := nil;
|
|
while ptr <> nil do begin
|
|
with ptr^ do
|
|
if CompNames(name,pname^) = 0 then begin
|
|
if lptr = nil then
|
|
partialList := next
|
|
else
|
|
lptr^.next := next;
|
|
goto 1;
|
|
end; {if}
|
|
lptr := ptr;
|
|
ptr := ptr^.next;
|
|
end; {while}
|
|
1:
|
|
end; {Remove}
|
|
|
|
|
|
begin {DoBlock}
|
|
{save the methods object, if any}
|
|
lisMethod := isMethod;
|
|
|
|
{handle declarations}
|
|
repeat
|
|
while sy = usessy do begin
|
|
InSymbol;
|
|
UsesDeclaration(fsys);
|
|
end; {while}
|
|
if sy = labelsy then begin
|
|
InSymbol;
|
|
LabelDeclaration(fsys);
|
|
if isProgram then
|
|
noGlobalLabels := false;
|
|
end; {if}
|
|
if sy = constsy then begin
|
|
InSymbol;
|
|
ConstDeclaration(fsys);
|
|
end; {if}
|
|
if sy = typesy then begin
|
|
InSymbol;
|
|
TypeDeclaration(fsys);
|
|
end; {if}
|
|
if sy = varsy then begin
|
|
InSymbol;
|
|
VarDeclaration(fsys);
|
|
end; {if}
|
|
{handle procedure, function declarations}
|
|
while sy in [procsy,funcsy] do begin
|
|
if level = 1 then
|
|
nextLocalLabel := 1;
|
|
lsy := sy;
|
|
InSymbol;
|
|
new(procName);
|
|
procName^ := id;
|
|
if (level > 1) or (not partial) then
|
|
ProcDeclaration(lsy, fsys, false, true, foundBody)
|
|
else if ShouldBeCompiled(lsy) then begin
|
|
{compile the header}
|
|
ProcDeclaration(lsy, fsys, false, true, foundBody);
|
|
{remove the name from the list of names to compile}
|
|
if foundBody and (not isMethod) then
|
|
Remove(procName^);
|
|
if partialList = nil then begin
|
|
eofl := true;
|
|
sy := period;
|
|
goto 1;
|
|
end;
|
|
end;
|
|
dispose(procName);
|
|
end;
|
|
CheckForw(display[top].fname);
|
|
if not ((sy = beginsy) or (doingUnit and (sy = endsy))) then begin
|
|
Error(18);
|
|
Skip(fsys);
|
|
end;
|
|
until (sy in statbegsys) or (doingUnit and (sy = endsy)) or eofl;
|
|
|
|
{compile the body of the block}
|
|
if (not doingUnit) or (level > 1) then begin
|
|
if level = 1 then
|
|
nextLocalLabel := 1;
|
|
Match(beginsy,17);
|
|
repeat
|
|
isMethod := lisMethod;
|
|
Body(fsys + [casesy],fprocp);
|
|
if sy <> fsy then begin
|
|
Error(6);
|
|
Skip(fsys);
|
|
end;
|
|
until (sy = fsy) or (sy in blockbegsys) or eofl;
|
|
end; {if}
|
|
1:
|
|
end; {DoBlock}
|
|
|
|
procedure Programme{fsys:setofsys};
|
|
{Compile a program}
|
|
|
|
var
|
|
fp,extfp,nextfp: extfilep;
|
|
lcp: ctp;
|
|
idname: pStringPtr; {segment name}
|
|
noStart: boolean; {has a start been generated?}
|
|
len: integer; {string length}
|
|
|
|
procedure DoGlobals;
|
|
{declare the ~globals and ~arrays segments}
|
|
|
|
var
|
|
didone: boolean; {did we generate at least one label?}
|
|
|
|
procedure GenArrays(lcp: ctp);
|
|
|
|
{ define global arrays }
|
|
{ }
|
|
{ parameters: }
|
|
{ lcp - stack frame to check for arrays }
|
|
|
|
var
|
|
size: addrrange; {size of the array}
|
|
|
|
begin {GenArrays}
|
|
if lcp <> nil then with lcp^ do begin
|
|
GenArrays(rlink);
|
|
GenArrays(llink);
|
|
if klass = varsm then
|
|
if idtype^.form in [arrays,records] then
|
|
if not fromUses then begin
|
|
if noStart then begin
|
|
idName := @'~ARRAYS';
|
|
if smallMemoryModel then
|
|
NextSegName(' ')
|
|
else
|
|
NextSegName('~ARRAYS ');
|
|
Gen2Name(dc_str, $4000, 1, idname);
|
|
noStart := false;
|
|
end;
|
|
Gen2Name(dc_glb, 0, ord(vPrivate), name);
|
|
size := idtype^.size;
|
|
while size > maxint do begin
|
|
Gen1(dc_dst, $4000);
|
|
size := size-$4000;
|
|
end; {while}
|
|
Gen1(dc_dst, long(size).lsw);
|
|
end;
|
|
end;
|
|
end; {GenArrays}
|
|
|
|
procedure GenGlobals(lcp: ctp);
|
|
{define non-array global variables}
|
|
|
|
begin {GenGlobals}
|
|
if lcp <> nil then with lcp^ do begin
|
|
GenGlobals(rlink);
|
|
GenGlobals(llink);
|
|
if klass = varsm then
|
|
if not (idtype^.form in [arrays,records]) then
|
|
if not fromUses then begin
|
|
Gen2Name(dc_glb, long(idtype^.size).lsw, ord(vPrivate), name);
|
|
didone := true;
|
|
end; {if}
|
|
end;
|
|
end; {GenGlobals}
|
|
|
|
begin {DoGlobals}
|
|
{declare the ~globals segment, which holds non-array data types}
|
|
idName := @'~GLOBALS';
|
|
if smallMemoryModel then
|
|
NextSegName(' ')
|
|
else
|
|
NextSegName('~GLOBALS ');
|
|
Gen2Name(dc_str, $4000, 0, idname);
|
|
didone := false;
|
|
GenGlobals(display[1].fname);
|
|
if not didone then
|
|
if not smallMemoryModel then
|
|
Gen2Name(dc_glb, 1{byte}, 1{private}, @'~');
|
|
Gen0(dc_enp);
|
|
{declare the ~arrays segment, which holds global arrays}
|
|
noStart := true;
|
|
GenArrays(display[1].fname);
|
|
if not noStart then
|
|
Gen0(dc_enp);
|
|
end; {DoGlobals}
|
|
|
|
procedure InterfacePart;
|
|
{compile the interface part of a unit}
|
|
|
|
var
|
|
lsy: symbol; {temp symbol}
|
|
foundBody: boolean; {dummy var for ProcDeclaration}
|
|
|
|
begin {InterfacePart}
|
|
repeat
|
|
{handle declarations}
|
|
while sy = usessy do begin InSymbol; UsesDeclaration(fsys); end;
|
|
if sy = constsy then begin InSymbol; ConstDeclaration(fsys); end;
|
|
if sy = typesy then begin InSymbol; TypeDeclaration(fsys); end;
|
|
if sy = varsy then begin InSymbol; VarDeclaration(fsys); end;
|
|
{handle procedure, function declarations}
|
|
while sy in [procsy,funcsy] do begin
|
|
lsy := sy;
|
|
InSymbol;
|
|
{compile the header}
|
|
nextLocalLabel := 1;
|
|
ProcDeclaration(lsy, fsys+[implementationsy], false, true, foundBody);
|
|
if foundBody then
|
|
Error(120);
|
|
end;
|
|
if sy <> implementationsy then begin
|
|
Skip([period]);
|
|
InSymbol;
|
|
end;
|
|
until (sy = implementationsy) or eofl;
|
|
end; {InterfacePart}
|
|
|
|
begin {Programme}
|
|
progfound := true;
|
|
{create the main program name}
|
|
lcp := pointer(Malloc(sizeof(identifier)));
|
|
with lcp^ do begin
|
|
name := @'~_PASMAIN';
|
|
idtype := nil;
|
|
next := nil;
|
|
klass := prog;
|
|
pfname := 0;
|
|
pfoname := name;
|
|
pfactualsize := 0;
|
|
pfparms := nil;
|
|
hasIFile := false;
|
|
end;
|
|
EnterId(lcp);
|
|
if sy = progsy then begin {compilation of a program}
|
|
if kNameGS.theString.size <> 0 then {start output files}
|
|
CodeGenInit(kNameGS, keepflag, partial);
|
|
InSymbol;
|
|
Match(ident,2);
|
|
{compile the program's parameter list}
|
|
if sy = lparent then begin
|
|
nextfp := nil;
|
|
repeat
|
|
InSymbol;
|
|
if sy = ident then begin
|
|
extfp := pointer(Malloc(sizeof(filerec)));
|
|
with extfp^ do begin
|
|
len := ord(id[0])+2;
|
|
filename := pointer(Malloc(len));
|
|
CopyString(filename^,id,len);
|
|
nextfile := nil;
|
|
end;
|
|
fp := fextfilep;
|
|
while fp <> nil do begin
|
|
if CompNames(fp^.filename^,id) = 0 then
|
|
Error(30);
|
|
fp := fp^.nextfile;
|
|
end;
|
|
if nextfp <> nil then nextfp^.nextfile := extfp;
|
|
nextfp := extfp;
|
|
if fextfilep = nil then fextfilep := extfp;
|
|
if CompNames(id,inputid) = 0 then noinput := false;
|
|
if CompNames(id,outputid) = 0 then nooutput := false;
|
|
if CompNames(id,erroroutputid) = 0 then noerroroutput := false;
|
|
InSymbol;
|
|
if not (sy in [comma,rparent]) then Error(20);
|
|
end
|
|
else Error(2);
|
|
until sy <> comma;
|
|
if sy <> rparent then Error(4);
|
|
InSymbol;
|
|
end;
|
|
Match(semicolon,14);
|
|
{compile the block}
|
|
repeat DoBlock(fsys,period,lcp,true);
|
|
if sy <> period then Error(21);
|
|
until (sy = period) or eofl;
|
|
end
|
|
else begin {compilation of a unit}
|
|
noInput := false; {allow all I/O}
|
|
noOutput := false;
|
|
noErrorOutput := false;
|
|
doingUnit := true; {note that this is a unit}
|
|
if kNameGS.theString.size <> 0 then {start output files}
|
|
CodeGenInit(kNameGS, keepflag, partial);
|
|
Match(unitsy,3); {compile the header}
|
|
Match(ident,2);
|
|
Match(semicolon,14);
|
|
doingInterface := true; {compile the interface part}
|
|
Match(interfacesy,119);
|
|
InterfacePart;
|
|
doingInterface := false;
|
|
CloseToken;
|
|
Match(implementationsy,118); {compile the implementation part}
|
|
DoBlock(fsys,period,lcp,true);
|
|
if not ((sy = period) and eofl) then begin
|
|
Match(endsy,13);
|
|
if sy <> period then begin
|
|
Error(21);
|
|
if allTerm then
|
|
while (errinx <> 0) and (not eofl) do
|
|
InSymbol;
|
|
end; {if}
|
|
end;
|
|
end;
|
|
DoGlobals; {declare the global variables}
|
|
end; {Programme}
|
|
|
|
{----Initialization-------------------------------------------------------}
|
|
|
|
procedure InitScalars;
|
|
{Initialize global scalars}
|
|
|
|
var
|
|
i: integer;
|
|
|
|
begin {InitScalars}
|
|
level := 0; top := 0; {set up level 0 frame}
|
|
with display[0] do begin
|
|
fname := nil;
|
|
flabel := nil;
|
|
labsused := nil;
|
|
occur := blck;
|
|
ispacked := false;
|
|
end; {with}
|
|
display[1] := display[0];
|
|
|
|
code := pointer(Calloc(sizeof(intermediate_code)));
|
|
{code^.lab := nil;}
|
|
fwptr := nil;
|
|
fextfilep := nil;
|
|
thisType := nil; {not declaring a type}
|
|
tempList := nil; {no temp variables}
|
|
nextLocalLabel := 1; {reset local label count}
|
|
numerr := 0; {no errors found}
|
|
errinx := 0;
|
|
intlabel := 0;
|
|
linecount := 0; {no lines processed}
|
|
lastline := 0;
|
|
firstlab := 0;
|
|
eofl := false; {not at end of file}
|
|
iso := false; {don't enforce iso}
|
|
progfound := false; {program symbol not found}
|
|
inseg := false;
|
|
debug := false; {don't generate check code}
|
|
inUses := false;
|
|
stringHeap := false;
|
|
namFound := false;
|
|
isDynamic := false; {segments are not dynamic}
|
|
isMethod := false; {not doing a method}
|
|
doingInterface := false; {not doing interface part}
|
|
doingUnit := false; {not doing a unit}
|
|
doingCast := false; {not casting an expression}
|
|
noGlobalLabels := true; {no program level labels found so far}
|
|
prterr := true;
|
|
noinput := true;
|
|
nooutput := true;
|
|
noerroroutput := true;
|
|
psize := 0; {no parameters at the program level}
|
|
ch := ' ';
|
|
code^.optype := cgWord;
|
|
gattr.aname := pointer(Malloc(maxCnt+1));
|
|
|
|
inputid := 'INPUT';
|
|
outputid := 'OUTPUT';
|
|
erroroutputid := 'ERROROUTPUT';
|
|
end; {InitScalars}
|
|
|
|
procedure InitSets;
|
|
{initialize structured set constants}
|
|
|
|
begin {InitSets}
|
|
constbegsys := [addop,intconst,realconst,stringconst,ident,nilsy,
|
|
longintconst];
|
|
simptypebegsys := [lparent] + constbegsys;
|
|
typebegsys:=[stringsy,arrow,packedsy,arraysy,recordsy,setsy,filesy,objectsy]
|
|
+simptypebegsys;
|
|
typedels := [arraysy,recordsy,setsy,filesy];
|
|
blockbegsys := [labelsy,constsy,typesy,varsy,procsy,funcsy,beginsy];
|
|
selectsys := [arrow,period,lbrack];
|
|
facbegsys := [intconst,realconst,stringconst,ident,lparent,bitnot,
|
|
nilsy,lbrack,notsy,atsy,longintconst,inheritedsy];
|
|
statbegsys := [beginsy,gotosy,ifsy,whilesy,repeatsy,forsy,withsy,casesy,
|
|
inheritedsy];
|
|
end {InitSets};
|
|
|
|
end.
|