mirror of
https://github.com/byteworksinc/ORCA-Pascal.git
synced 2024-12-06 16:51:31 +00:00
5116 lines
130 KiB
ObjectPascal
5116 lines
130 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}
|
|
objptr: ctp; {linked list of objects}
|
|
|
|
{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; {Duplicate}
|
|
|
|
|
|
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);
|
|
|
|
{ check for previous foward declaration }
|
|
lsp := nil;
|
|
lcp := objptr;
|
|
while (lcp <> nil) and (CompNames(objectName, lcp^.name^) <> 0)
|
|
do lcp := lcp^.next;
|
|
|
|
if lcp <> nil then lsp := lcp^.idtype;
|
|
if (sy <> semicolon) and (lsp <> nil) and (lsp^.objdef) then lsp := nil;
|
|
|
|
if lsp = nil then begin
|
|
{set up the type}
|
|
lsp := pointer(Malloc(sizeof(structure)));
|
|
with lsp^ do begin
|
|
form := objects;
|
|
objname := nil;
|
|
objsize := 6;
|
|
objlevel := 1;
|
|
objparent := nil;
|
|
objdef := true;
|
|
size := ptrsize;
|
|
hasSFile := false;
|
|
end; {with}
|
|
end;
|
|
|
|
{ handle forward declaration }
|
|
if sy = semicolon then begin
|
|
{ if lcp is defined, then we're already inserted, nothing to do}
|
|
if lcp = nil then begin
|
|
lsp^.objdef := false;
|
|
objectcp^.idtype := lsp;
|
|
EnterId(objectcp);
|
|
objectcp^.next := objptr;
|
|
objptr := objectcp;
|
|
end;
|
|
end else begin
|
|
|
|
{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;
|
|
|
|
|
|
{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) and (lcp2^.idtype^.objdef)
|
|
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;
|
|
if lsp^.objdef then begin
|
|
ttop := top;
|
|
top := oldtop;
|
|
objectcp^.idtype := lsp;
|
|
EnterId(objectcp);
|
|
objectcp^.next := objptr;
|
|
objptr := objectcp;
|
|
top := ttop;
|
|
end;
|
|
lsp^.objdef := true;
|
|
|
|
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; {if not forward declaration}
|
|
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 |