1330 lines
33 KiB
ObjectPascal
1330 lines
33 KiB
ObjectPascal
{$optimize -1}
|
|
{------------------------------------------------------------}
|
|
{ }
|
|
{ SymbolTables }
|
|
{ }
|
|
{ This unit implements the symbol table for ORCA/Pascal. }
|
|
{ Also included are many of the declarations that tie the }
|
|
{ various units together. The specialized memory manager }
|
|
{ used to make symbol table disposal more efficient is also }
|
|
{ included in this module. }
|
|
{ }
|
|
{ The interfaces for the scanner and object module output }
|
|
{ units are in this unit. This eliminates the need for a }
|
|
{ common module that would have most of the pertinant }
|
|
{ symbol table type information. }
|
|
{ }
|
|
{ By Mike Westerfield }
|
|
{ }
|
|
{ Copyright August 1987 }
|
|
{ By the Byte Works, Inc. }
|
|
{ }
|
|
{------------------------------------------------------------}
|
|
|
|
unit SymbolTables;
|
|
|
|
{$segment 'Pascal2'}
|
|
|
|
interface
|
|
|
|
{$libprefix '0/obj/'}
|
|
|
|
uses PCommon, CGI, CGC, ObjOut, Native, Scanner;
|
|
|
|
{---------------------------------------------------------------}
|
|
|
|
var
|
|
{pointers:}
|
|
{---------}
|
|
intptr,realptr,charptr,
|
|
byteptr,longptr,compptr,
|
|
doubleptr,extendedptr,stringptr,
|
|
boolptr,nilptr,textptr: stp; {pointers to entries of standard ids}
|
|
externIdentifier: ctp; {extern ID entry}
|
|
forwardIdentifier: ctp; {forward ID entry}
|
|
utypptr,ucstptr,uvarptr,
|
|
ufldptr,uprcptr,ufctptr, {pointers to entries for undeclared ids}
|
|
fwptr: ctp; {head of chain for forw decl type ids}
|
|
inptr,outptr,erroroutputptr: ctp; {standard I/O}
|
|
dummyString: stp; {index entry for string constants}
|
|
dummyField: ctp;
|
|
|
|
{---------------------------------------------------------------}
|
|
|
|
function CompObjects (fsp1, fsp2: stp): boolean;
|
|
|
|
{ See if two objects are assignment compatible }
|
|
{ }
|
|
{ parameters: }
|
|
{ fsp1 - object to assign to }
|
|
{ fsp2 - object to assign }
|
|
{ }
|
|
{ Returns: True if the structures are compatible, else false }
|
|
|
|
|
|
function CompTypes (fsp1, fsp2: stp): boolean;
|
|
|
|
{ determine if two structures are type compatible }
|
|
{ }
|
|
{ parameters: }
|
|
{ fsp1, fsp2 - structures to check }
|
|
{ }
|
|
{ Returns: True if the structures are compatible, else false }
|
|
|
|
|
|
procedure EnterStdTypes;
|
|
|
|
{ enter the base types }
|
|
|
|
|
|
procedure EntStdNames;
|
|
|
|
{ enter standard names in the program symbol table }
|
|
|
|
|
|
procedure EnterId (fcp: ctp); extern;
|
|
|
|
{ Enter an identifier at the current stack frame level }
|
|
{ }
|
|
{ parameters: }
|
|
{ fcp - identifier to enter }
|
|
|
|
|
|
procedure EnterUndecl;
|
|
|
|
{ enter fake identifiers for use when identifiers are }
|
|
{ undeclared }
|
|
|
|
|
|
procedure GenSymbols (sym: ctp; doGlobals: integer);
|
|
|
|
{ generate the symbol table }
|
|
{ }
|
|
{ Notes: Defined as extern in Native.pas }
|
|
|
|
|
|
procedure GetBounds (fsp: stp; var fmin,fmax: longint);
|
|
|
|
{ get internal bounds of subrange or scalar type }
|
|
{ (assume fsp<>longptr and fsp<>realptr) }
|
|
{ }
|
|
{ parameters: }
|
|
{ fsp - type to get the bounds for }
|
|
{ fmin, fmax - (output) bounds }
|
|
|
|
|
|
function GetType (tp: stp; isPacked: boolean): baseTypeEnum;
|
|
|
|
{ find the base type for a variable type }
|
|
{ }
|
|
{ parameters: }
|
|
{ tp - variable type }
|
|
{ isPacked - is the variable packed? }
|
|
{ }
|
|
{ returns: Variable base type }
|
|
|
|
|
|
function IsReal (fsp: stp): boolean;
|
|
|
|
{ determine if fsp is one of the real types }
|
|
{ }
|
|
{ parameters: }
|
|
{ fsp - structure to check }
|
|
{ }
|
|
{ Returns: True if fsp is a real, else false }
|
|
|
|
|
|
function IsString (fsp: stp): boolean;
|
|
|
|
{ determine if fsp is a string }
|
|
{ }
|
|
{ parameters: }
|
|
{ fsp - structure to check }
|
|
{ }
|
|
{ Returns: True if fsp is a string, else false }
|
|
|
|
|
|
procedure SearchSection (fcp: ctp; var fcpl: ctp); extern;
|
|
|
|
{ find record fields and forward declared procedure id's }
|
|
{ }
|
|
{ parameters: }
|
|
{ fcp - top of identifier tree }
|
|
{ fcpl - (outout) identifier }
|
|
|
|
|
|
procedure SearchId (fidcls: setofids; var fcp: ctp); extern;
|
|
|
|
{ find an identifier }
|
|
{ }
|
|
{ parameters: }
|
|
{ fidcls - kinds of identifiers to look for }
|
|
{ fcp - (output) identifier found }
|
|
|
|
|
|
function StrLen (tp: stp): integer;
|
|
|
|
{ Find the length of a string variable (for library calls) }
|
|
{ }
|
|
{ parameters: }
|
|
{ tp - string variable }
|
|
{ }
|
|
{ Returns: length of the string }
|
|
|
|
{---------------------------------------------------------------}
|
|
|
|
implementation
|
|
|
|
{---------------------------------------------------------------}
|
|
|
|
function CompObjects {fsp1, fsp2: stp): boolean};
|
|
|
|
{ See if two objects are assignment compatible }
|
|
{ }
|
|
{ parameters: }
|
|
{ fsp1 - object to assign to }
|
|
{ fsp2 - object to assign }
|
|
{ }
|
|
{ Returns: True if the structures are compatible, else false }
|
|
|
|
begin {CompObjects}
|
|
CompObjects := false;
|
|
if fsp1^.form = objects then begin
|
|
if fsp2^.form = objects then begin
|
|
while fsp2 <> nil do begin
|
|
if fsp1 = fsp2 then begin
|
|
fsp2 := nil;
|
|
CompObjects := true;
|
|
end {if}
|
|
else
|
|
fsp2 := fsp2^.objparent;
|
|
end; {while}
|
|
end {if}
|
|
else if fsp2 = nilptr then
|
|
CompObjects := true;
|
|
end; {if}
|
|
end; {CompObjects}
|
|
|
|
|
|
function CompTypes {fsp1,fsp2: stp): boolean};
|
|
|
|
{ determine if two structures are type compatible }
|
|
{ }
|
|
{ parameters: }
|
|
{ fsp1, fsp2 - structures to check }
|
|
{ }
|
|
{ Returns: True if the structures are compatible, else false }
|
|
|
|
var
|
|
lmin1,lmin2: integer;
|
|
comp: boolean;
|
|
|
|
begin {CompTypes}
|
|
if fsp1 = fsp2 then
|
|
CompTypes := true
|
|
else if (fsp1 <> nil) and (fsp2 <> nil) then begin
|
|
if fsp1^.form = subrange then begin
|
|
if fsp2^.form = subrange then
|
|
CompTypes := CompTypes(fsp1^.rangetype,fsp2^.rangetype)
|
|
else
|
|
CompTypes := CompTypes(fsp1^.rangetype,fsp2);
|
|
end {if}
|
|
else if fsp2^.form = subrange then
|
|
CompTypes := CompTypes(fsp1,fsp2^.rangetype)
|
|
else if fsp1 = byteptr then
|
|
CompTypes := CompTypes(fsp2,intptr)
|
|
else if fsp2 = byteptr then
|
|
CompTypes := CompTypes(fsp1,intptr)
|
|
else if fsp1^.form = fsp2^.form then begin
|
|
if fsp1^.form = power then
|
|
CompTypes := CompTypes(fsp1^.elset,fsp2^.elset) and
|
|
((fsp1^.ispacked = pkeither) or (fsp2^.ispacked = pkeither) or
|
|
(fsp1^.ispacked = fsp2^.ispacked))
|
|
else if fsp1^.form = arrays then begin
|
|
comp := IsString(fsp1) and IsString(fsp2);
|
|
if iso then
|
|
comp := comp and (fsp1^.size = fsp2^.size);
|
|
CompTypes := comp;
|
|
end {else if}
|
|
else if fsp1^.form = pointerStruct then
|
|
CompTypes := (fsp1 = nilptr) or (fsp2 = nilptr)
|
|
else
|
|
CompTypes := IsReal(fsp1) and IsReal(fsp2);
|
|
end {else if}
|
|
else if fsp1^.form = objects then
|
|
CompTypes := fsp2 = nilptr
|
|
else if fsp2^.form = objects then
|
|
CompTypes := fsp1 = nilptr
|
|
else
|
|
CompTypes := false
|
|
end
|
|
else
|
|
CompTypes := true
|
|
end; {CompTypes}
|
|
|
|
|
|
procedure EnterStdTypes;
|
|
|
|
{ enter the base types }
|
|
|
|
begin {EnterStdTypes}
|
|
byteptr := pointer(Malloc(sizeof(structure))); {byte}
|
|
with byteptr^ do begin
|
|
size := bytesize;
|
|
ispacked := pkunpacked;
|
|
form := scalar;
|
|
scalkind := standard;
|
|
hasSFile := false;
|
|
end; {with}
|
|
intptr := pointer(Malloc(sizeof(structure))); {integer}
|
|
with intptr^ do begin
|
|
size := intsize;
|
|
ispacked := pkunpacked;
|
|
form := scalar;
|
|
scalkind := standard;
|
|
hasSFile := false;
|
|
end; {with}
|
|
longptr := pointer(Malloc(sizeof(structure))); {long}
|
|
with longptr^ do begin
|
|
size := longsize;
|
|
ispacked := pkunpacked;
|
|
form := scalar;
|
|
scalkind := standard;
|
|
hasSFile := false;
|
|
end; {with}
|
|
realptr := pointer(Malloc(sizeof(structure))); {real}
|
|
with realptr^ do begin
|
|
size := realsize;
|
|
ispacked := pkunpacked;
|
|
form := scalar;
|
|
scalkind := standard;
|
|
hasSFile := false;
|
|
end; {with}
|
|
doubleptr := pointer(Malloc(sizeof(structure))); {double}
|
|
with doubleptr^ do begin
|
|
size := doublesize;
|
|
ispacked := pkunpacked;
|
|
form := scalar;
|
|
scalkind := standard;
|
|
hasSFile := false;
|
|
end; {with}
|
|
compptr := pointer(Malloc(sizeof(structure))); {comp}
|
|
with compptr^ do begin
|
|
size := compsize;
|
|
ispacked := pkunpacked;
|
|
form := scalar;
|
|
scalkind := standard;
|
|
hasSFile := false;
|
|
end; {with}
|
|
extendedptr := pointer(Malloc(sizeof(structure))); {extended}
|
|
with extendedptr^ do begin
|
|
size := extendedsize;
|
|
ispacked := pkunpacked;
|
|
form := scalar;
|
|
scalkind := standard;
|
|
hasSFile := false;
|
|
end; {with}
|
|
charptr := pointer(Malloc(sizeof(structure))); {char}
|
|
with charptr^ do begin
|
|
size := charsize;
|
|
ispacked := pkunpacked;
|
|
form := scalar;
|
|
scalkind := standard;
|
|
hasSFile := false;
|
|
end; {with}
|
|
stringptr := pointer(Malloc(sizeof(structure))); {string}
|
|
with stringptr^ do begin
|
|
size := packedcharsize*2;
|
|
ispacked := pkpacked;
|
|
form := arrays;
|
|
hasSFile := false;
|
|
aeltype := charptr;
|
|
inxtype := pointer(Malloc(sizeof(structure)));
|
|
with inxtype^ do begin
|
|
size := intsize;
|
|
form := subrange;
|
|
rangetype := intptr;
|
|
min := 1;
|
|
max := 2;
|
|
end; {with}
|
|
end; {with}
|
|
boolptr := pointer(Malloc(sizeof(structure))); {bool}
|
|
with boolptr^ do begin
|
|
size := boolsize;
|
|
ispacked := pkunpacked;
|
|
form := scalar;
|
|
scalkind := declared;
|
|
hasSFile := false;
|
|
end; {with}
|
|
nilptr := pointer(Malloc(sizeof(structure))); {nil}
|
|
with nilptr^ do begin
|
|
eltype := nil;
|
|
size := ptrsize;
|
|
ispacked := pkunpacked;
|
|
form := pointerStruct;
|
|
hasSFile := false;
|
|
end; {with}
|
|
textptr := pointer(Malloc(sizeof(structure))); {text}
|
|
with textptr^ do begin
|
|
filtype := charptr;
|
|
filsize := packedcharsize*2;
|
|
size := ptrsize;
|
|
ispacked := pkunpacked;
|
|
form := files;
|
|
hasSFile := true;
|
|
end; {with}
|
|
end; {EnterStdTypes}
|
|
|
|
|
|
procedure EntStdNames;
|
|
|
|
{ enter standard names in the program symbol table }
|
|
|
|
var
|
|
cp,cp1: ctp;
|
|
i: integer;
|
|
|
|
begin {EntStdNames}
|
|
cp := pointer(Malloc(sizeof(identifier))); {integer}
|
|
with cp^ do begin
|
|
name := @'INTEGER';
|
|
idtype := intptr;
|
|
klass := types;
|
|
hasIFile := false;
|
|
end; {with}
|
|
EnterId(cp);
|
|
cp := pointer(Malloc(sizeof(identifier))); {byte}
|
|
with cp^ do begin
|
|
name := @'BYTE';
|
|
idtype := byteptr;
|
|
klass := types;
|
|
hasIFile := false;
|
|
end; {with}
|
|
EnterId(cp);
|
|
cp := pointer(Malloc(sizeof(identifier))); {longint}
|
|
with cp^ do begin
|
|
name := @'LONGINT';
|
|
idtype := longptr;
|
|
klass := types;
|
|
hasIFile := false;
|
|
end; {with}
|
|
EnterId(cp);
|
|
cp := pointer(Malloc(sizeof(identifier))); {real}
|
|
with cp^ do begin
|
|
name := @'REAL';
|
|
idtype := realptr;
|
|
klass := types;
|
|
hasIFile := false;
|
|
end; {with}
|
|
EnterId(cp);
|
|
cp := pointer(Malloc(sizeof(identifier))); {double}
|
|
with cp^ do begin
|
|
name := @'DOUBLE';
|
|
idtype := doubleptr;
|
|
klass := types;
|
|
hasIFile := false;
|
|
end; {with}
|
|
EnterId(cp);
|
|
cp := pointer(Malloc(sizeof(identifier))); {comp}
|
|
with cp^ do begin
|
|
name := @'COMP';
|
|
idtype := compptr;
|
|
klass := types;
|
|
hasIFile := false;
|
|
end; {with}
|
|
EnterId(cp);
|
|
cp := pointer(Malloc(sizeof(identifier))); {extended}
|
|
with cp^ do begin
|
|
name := @'EXTENDED';
|
|
idtype := extendedptr;
|
|
klass := types;
|
|
hasIFile := false;
|
|
end; {with}
|
|
EnterId(cp);
|
|
cp := pointer(Malloc(sizeof(identifier))); {char}
|
|
with cp^ do begin
|
|
name := @'CHAR';
|
|
idtype := charptr;
|
|
klass := types;
|
|
hasIFile := false;
|
|
end; {with}
|
|
EnterId(cp);
|
|
cp := pointer(Malloc(sizeof(identifier))); {boolean}
|
|
with cp^ do begin
|
|
name := @'BOOLEAN';
|
|
idtype := boolptr;
|
|
klass := types;
|
|
hasIFile := false;
|
|
end; {with}
|
|
EnterId(cp);
|
|
cp := pointer(Malloc(sizeof(identifier))); {text}
|
|
with cp^ do begin
|
|
name := @'TEXT';
|
|
idtype := textptr;
|
|
klass := types;
|
|
hasIFile := true;
|
|
end; {with}
|
|
EnterId(cp);
|
|
cp1 := nil;
|
|
for i := 1 to 2 do begin
|
|
cp := pointer(Malloc(sizeof(identifier))); {false,true}
|
|
with cp^ do begin
|
|
name := na[i];
|
|
idtype := boolptr;
|
|
next := cp1;
|
|
values.ival := i-1;
|
|
klass := konst;
|
|
hasIFile := false;
|
|
end; {with}
|
|
EnterId(cp);
|
|
cp1 := cp
|
|
end; {with}
|
|
boolptr^.fconst := cp;
|
|
cp := pointer(Malloc(sizeof(identifier))); {forward}
|
|
with cp^ do begin
|
|
name := @'FORWARD';
|
|
next := nil;
|
|
klass := directive;
|
|
drkind := drforw;
|
|
hasIFile := false;
|
|
end; {with}
|
|
EnterId(cp);
|
|
forwardIdentifier := cp;
|
|
cp := pointer(Malloc(sizeof(identifier))); {extern}
|
|
with cp^ do begin
|
|
name := @'EXTERN';
|
|
next := nil;
|
|
klass := directive;
|
|
drkind := drextern;
|
|
hasIFile := false;
|
|
end; {with}
|
|
EnterId(cp);
|
|
externIdentifier := cp;
|
|
cp := pointer(Malloc(sizeof(identifier))); {external}
|
|
with cp^ do begin
|
|
name := @'EXTERNAL';
|
|
next := nil;
|
|
klass := directive;
|
|
drkind := drextern;
|
|
hasIFile := false;
|
|
end; {with}
|
|
EnterId(cp);
|
|
cp := pointer(Malloc(sizeof(identifier))); {override}
|
|
with cp^ do begin
|
|
name := @'OVERRIDE';
|
|
next := nil;
|
|
klass := directive;
|
|
drkind := droverride;
|
|
hasIFile := false;
|
|
end; {with}
|
|
EnterId(cp);
|
|
cp := pointer(Malloc(sizeof(identifier))); {prodos}
|
|
with cp^ do begin
|
|
name := @'PRODOS';
|
|
next := nil;
|
|
klass := directive;
|
|
drkind := drprodos;
|
|
hasIFile := false;
|
|
end; {with}
|
|
EnterId(cp);
|
|
cp := pointer(Malloc(sizeof(identifier))); {tool}
|
|
with cp^ do begin
|
|
name := @'TOOL';
|
|
next := nil;
|
|
klass := directive;
|
|
drkind := drtool1;
|
|
hasIFile := false;
|
|
end; {with}
|
|
EnterId(cp);
|
|
cp := pointer(Malloc(sizeof(identifier))); {usertool}
|
|
with cp^ do begin
|
|
name := @'USERTOOL';
|
|
next := nil;
|
|
klass := directive;
|
|
drkind := drtool2;
|
|
hasIFile := false;
|
|
end; {with}
|
|
EnterId(cp);
|
|
cp := pointer(Malloc(sizeof(identifier))); {vector}
|
|
with cp^ do begin
|
|
name := @'VECTOR';
|
|
next := nil;
|
|
klass := directive;
|
|
drkind := drvector;
|
|
hasIFile := false;
|
|
end; {with}
|
|
EnterId(cp);
|
|
cp := pointer(Malloc(sizeof(identifier))); {maxint}
|
|
with cp^ do begin
|
|
name := @'MAXINT';
|
|
idtype := intptr;
|
|
next := nil;
|
|
values.ival := maxint;
|
|
klass := konst;
|
|
hasIFile := false;
|
|
end; {with}
|
|
EnterId(cp);
|
|
cp := pointer(Malloc(sizeof(identifier))); {maxint4}
|
|
with cp^ do begin
|
|
name := @'MAXINT4';
|
|
idtype := longptr;
|
|
next := nil;
|
|
values.valp := pointer(Malloc(constantRec_longC));
|
|
values.valp^.lval := 2147483647;
|
|
values.valp^.cclass := longC;
|
|
klass := konst;
|
|
hasIFile := false;
|
|
end; {with}
|
|
EnterId(cp);
|
|
for i := 3 to 4 do begin {input,output}
|
|
cp := pointer(Malloc(sizeof(identifier)));
|
|
with cp^ do begin
|
|
name := na[i];
|
|
idtype := textptr;
|
|
klass := varsm;
|
|
vkind := actual;
|
|
next := nil;
|
|
vlev := 1;
|
|
vcontvar := false;
|
|
vrestrict := false;
|
|
fromUses := false;
|
|
hasIFile := true;
|
|
end; {with}
|
|
EnterId(cp);
|
|
if i = 3 then inptr := cp else outptr := cp;
|
|
end; {with}
|
|
cp := pointer(Malloc(sizeof(identifier))); {erroroutput}
|
|
with cp^ do begin
|
|
name := @'ERROROUTPUT';
|
|
idtype := textptr;
|
|
klass := varsm;
|
|
vkind := actual;
|
|
next := nil;
|
|
vlev := 1;
|
|
vcontvar := false;
|
|
vrestrict := false;
|
|
fromUses := false;
|
|
hasIFile := true;
|
|
end; {with}
|
|
EnterId(cp);
|
|
erroroutputptr := cp;
|
|
for i := 5 to 23 do begin
|
|
cp := pointer(Malloc(sizeof(identifier))); {std procs}
|
|
with cp^ do begin
|
|
name := na[i];
|
|
idtype := nil;
|
|
next := nil;
|
|
key := i-4;
|
|
klass := proc;
|
|
pfdeckind := standard;
|
|
hasIFile := false;
|
|
end; {with}
|
|
EnterId(cp)
|
|
end; {with}
|
|
for i := 24 to 40 do begin
|
|
cp := pointer(Malloc(sizeof(identifier))); {std funcs}
|
|
with cp^ do begin
|
|
name := na[i];
|
|
idtype := nil;
|
|
next := nil;
|
|
key := i-23;
|
|
klass := func;
|
|
pfdeckind := standard;
|
|
hasIFile := false;
|
|
end; {with}
|
|
EnterId(cp);
|
|
end; {with}
|
|
for i := 41 to 50 do begin
|
|
cp := pointer(Malloc(sizeof(identifier))); {more std procs}
|
|
with cp^ do begin
|
|
name := na[i];
|
|
idtype := nil;
|
|
next := nil;
|
|
key := i-21;
|
|
klass := proc;
|
|
pfdeckind := standard;
|
|
hasIFile := false;
|
|
end; {with}
|
|
EnterId(cp)
|
|
end; {with}
|
|
for i := 51 to 77 do begin
|
|
cp := pointer(Malloc(sizeof(identifier))); {more std funcs}
|
|
with cp^ do begin
|
|
name := na[i];
|
|
idtype := nil;
|
|
next := nil;
|
|
key := i-33;
|
|
klass := func;
|
|
pfdeckind := standard;
|
|
hasIFile := false;
|
|
end; {with}
|
|
EnterId(cp);
|
|
end; {with}
|
|
end; {EntStdNames}
|
|
|
|
|
|
procedure EnterUndecl;
|
|
|
|
{ enter fake identifiers for use when identifiers are }
|
|
{ undeclared }
|
|
|
|
begin {EnterUndecl}
|
|
utypptr := pointer(Malloc(sizeof(identifier)));
|
|
with utypptr^ do begin
|
|
name := @' ';
|
|
idtype := nil;
|
|
klass := types;
|
|
hasIFile := false;
|
|
end; {with}
|
|
ucstptr := pointer(Malloc(sizeof(identifier)));
|
|
with ucstptr^ do begin
|
|
name := @' ';
|
|
idtype := nil;
|
|
next := nil;
|
|
values.ival := 0;
|
|
klass := konst;
|
|
hasIFile := false;
|
|
end; {with}
|
|
uvarptr := pointer(Malloc(sizeof(identifier)));
|
|
with uvarptr^ do begin
|
|
name := @' ';
|
|
idtype := nil;
|
|
vkind := actual;
|
|
next := nil;
|
|
vlev := 0;
|
|
vlabel := 1;
|
|
vcontvar := false;
|
|
vrestrict := false;
|
|
klass := varsm;
|
|
fromUses := false;
|
|
hasIFile := false;
|
|
end; {with}
|
|
ufldptr := pointer(Malloc(sizeof(identifier)));
|
|
with ufldptr^ do begin
|
|
name := @' ';
|
|
idtype := nil;
|
|
next := nil;
|
|
fldaddr := 0;
|
|
klass := field;
|
|
hasIFile := false;
|
|
end; {with}
|
|
uprcptr := pointer(Malloc(sizeof(identifier)));
|
|
with uprcptr^ do begin
|
|
name := @' ';
|
|
idtype := nil;
|
|
pfdirective := drnone;
|
|
next := nil;
|
|
pflev := 0;
|
|
pfname := GenLabel;
|
|
fldvar := false;
|
|
klass := proc;
|
|
pfdeckind := declared;
|
|
pfkind := actual;
|
|
hasIFile := false;
|
|
end; {with}
|
|
ufctptr := pointer(Malloc(sizeof(identifier)));
|
|
with ufctptr^ do begin
|
|
name := @' ';
|
|
idtype := nil;
|
|
next := nil;
|
|
pfdirective := drnone;
|
|
pflev := 0;
|
|
pfname := GenLabel;
|
|
klass := func;
|
|
pfdeckind := declared;
|
|
pfkind := actual;
|
|
hasIFile := false;
|
|
end; {with}
|
|
dummyString := pointer(Malloc(sizeof(structure)));
|
|
with dummyString^ do begin
|
|
size := 2;
|
|
ispacked := pkpacked;
|
|
form := subrange;
|
|
hasSFile := false;
|
|
rangetype := intptr;
|
|
min := 1;
|
|
max := 2;
|
|
end; {with}
|
|
|
|
|
|
dummyField := pointer(Malloc(sizeof(identifier)));
|
|
with dummyField^ do begin
|
|
name := @'FIELD';
|
|
idtype := intptr;
|
|
next := nil;
|
|
fldaddr := 0;
|
|
klass := field;
|
|
hasIFile := false;
|
|
llink := nil;
|
|
rlink := nil;
|
|
fldaddr := 0;
|
|
end; {with}
|
|
|
|
end; {EnterUndecl}
|
|
|
|
|
|
procedure GenSymbols {sym: ctp; doGlobals: integer};
|
|
|
|
{ generate the symbol table }
|
|
{ }
|
|
{ Notes: Defined as extern in Native.pas }
|
|
|
|
const
|
|
noDisp = -1; {disp returned by GetTypeDisp if the type was not found}
|
|
|
|
type
|
|
tpPtr = ^tpRecord; {type list displacements}
|
|
tpRecord = record
|
|
next: tpPtr;
|
|
tp: stp;
|
|
disp: integer;
|
|
end;
|
|
|
|
var
|
|
tpList,tp2: tpPtr; {type displacement list}
|
|
|
|
|
|
function GetTypeDisp (tp: stp): integer;
|
|
|
|
{ Look for an existing entry for this type }
|
|
{ }
|
|
{ Parameters: }
|
|
{ tp - type to look for }
|
|
{ }
|
|
{ Returns: Disp to a variable of the same type, or 0 if }
|
|
{ there is no such entry. }
|
|
{ }
|
|
{ Notes: If the type is not in the type list, it is entered }
|
|
{ in the list by this call. }
|
|
|
|
var
|
|
tp1, tp2: tpPtr; {used to manipulate type list}
|
|
|
|
begin {GetTypeDisp}
|
|
tp1 := tpList; {look for the type}
|
|
tp2 := nil;
|
|
while tp1 <> nil do
|
|
if tp1^.tp = tp then begin
|
|
tp2 := tp1;
|
|
tp1 := nil;
|
|
end {if}
|
|
else
|
|
tp1 := tp1^.next;
|
|
if tp2 <> nil then
|
|
GetTypeDisp := tp2^.disp {return disp to entry}
|
|
else begin
|
|
GetTypeDisp := noDisp; {no entry}
|
|
new(tp1); {create a new entry}
|
|
tp1^.next := tpList;
|
|
tpList := tp1;
|
|
tp1^.tp := tp;
|
|
tp1^.disp := symLength - 12;
|
|
end; {else}
|
|
end; {GetTypeDisp}
|
|
|
|
|
|
procedure GenSymbol (sym: ctp; maybeLast: boolean);
|
|
|
|
{ generate one symbol entry }
|
|
{ }
|
|
{ parameters: }
|
|
{ sym - identifier to generate }
|
|
{ maybelast - true if this may be the last node in a }
|
|
{ record or object tree, false if not; unused for }
|
|
{ variables }
|
|
|
|
var
|
|
disp: integer; {disp to symbol of same type}
|
|
idtype: stp;
|
|
|
|
|
|
procedure WriteAddress (sym: ctp);
|
|
|
|
{ Write the address and DP flag }
|
|
{ }
|
|
{ parameters: }
|
|
{ sym - identifier }
|
|
{ maybeLast - true if this might be the last entry, }
|
|
{ else false }
|
|
|
|
var
|
|
size: longint; {used to break apart longints}
|
|
|
|
begin {WriteAddress}
|
|
if sym^.klass = field then begin
|
|
size := sym^.fldaddr;
|
|
CnOut2(long(size).lsw);
|
|
CnOut2(long(size).msw);
|
|
CnOut(ord(not(maybeLast and (sym^.rlink = nil))));
|
|
end {if}
|
|
else if sym^.vlev = 1 then begin
|
|
RefName(sym^.name, 0, 4, 0);
|
|
CnOut(1);
|
|
end {else if}
|
|
else begin
|
|
CnOut2(localLabel[sym^.vlabel]);
|
|
CnOut2(0);
|
|
CnOut(0);
|
|
end; {else}
|
|
end; {WriteAddress}
|
|
|
|
|
|
procedure WriteName (sym: ctp);
|
|
|
|
{ Write the name field for an identifier }
|
|
{ }
|
|
{ parameters: }
|
|
{ sym - identifier }
|
|
|
|
var
|
|
len: 0..maxint; {string length}
|
|
j: 0..maxint; {loop/index variable}
|
|
|
|
begin {WriteName}
|
|
Purge; {generate the address of the variable }
|
|
Out(235); Out(4); { name }
|
|
LabelSearch(maxLabel, 4, 0, 0);
|
|
if stringsize <> 0 then begin
|
|
Out(129);
|
|
Out2(stringsize); Out2(0);
|
|
Out(1);
|
|
end; {if}
|
|
Out(0);
|
|
len := length(sym^.name^); {place the name in the string buffer}
|
|
if maxstring-stringsize >= len+1 then begin
|
|
stringspace[stringsize+1] := chr(len);
|
|
for j := 1 to len do
|
|
stringspace[j+stringsize+1] := sym^.name^[j];
|
|
stringsize := stringsize+len+1;
|
|
end {if}
|
|
else
|
|
Error(132);
|
|
end; {WriteName}
|
|
|
|
|
|
procedure WriteScalarType (tp: stp; modifiers, subscripts: integer);
|
|
|
|
{ Write a scalar type and subscipt field }
|
|
{ }
|
|
{ parameters: }
|
|
{ tp - type pointer }
|
|
{ modifiers - value to or with the type code }
|
|
{ subscripts - number of subscripts }
|
|
|
|
var
|
|
val: integer; {type value}
|
|
|
|
begin {WriteScalarType}
|
|
case GetType(tp, tp^.isPacked) of
|
|
cgByte: val := $40;
|
|
cgUByte: val := $00;
|
|
cgWord: val := $01;
|
|
cgUWord: val := $41;
|
|
cgLong: val := $02;
|
|
cgULong: val := $42;
|
|
cgReal: val := $03;
|
|
cgDouble: val := $04;
|
|
cgComp: val := $0A;
|
|
cgExtended: val := $05;
|
|
otherwise: val := $01;
|
|
end; {case}
|
|
CnOut(val | modifiers); {write the format byte}
|
|
CnOut2(subscripts); {write the # of subscripts}
|
|
end; {WriteScalarType}
|
|
|
|
|
|
procedure WritePointerType (tp: stp; subscripts: integer);
|
|
|
|
{ write a pointer type field }
|
|
{ }
|
|
{ parameters: }
|
|
{ tp - pointer type }
|
|
{ subscripts - number of subscript fields }
|
|
|
|
begin {WritePointerType}
|
|
case tp^.eltype^.form of
|
|
scalar: WriteScalarType(tp^.eltype, $80, subscripts);
|
|
subrange: WriteScalarType(tp^.eltype^.rangetype, $80, subscripts);
|
|
otherwise: begin
|
|
CnOut(11);
|
|
CnOut2(subscripts);
|
|
end;
|
|
end; {case}
|
|
end; {WritePointerType}
|
|
|
|
|
|
procedure ExpandPointerType (tp: stp); forward;
|
|
|
|
|
|
procedure ExpandRecordType (tp: stp);
|
|
|
|
{ write the type entries for a record or object }
|
|
{ }
|
|
{ parameters: }
|
|
{ tp - record/object type }
|
|
|
|
var
|
|
ip: ctp; {used to trace the field list}
|
|
|
|
begin {ExpandRecordType}
|
|
if tp^.form = records then
|
|
ip := tp^.fstfld
|
|
else
|
|
ip := tp^.objfld;
|
|
if ip = nil then ip := dummyField;
|
|
GenSymbol(ip, true);
|
|
end; {ExpandRecordType}
|
|
|
|
|
|
procedure WriteArrays (tp: stp);
|
|
|
|
{ handle an array type }
|
|
{ }
|
|
{ parameters: }
|
|
{ tp - array type }
|
|
|
|
var
|
|
count: unsigned; {# of subscripts}
|
|
lmin, lmax: addrrange; {index range}
|
|
tp2: stp; {used to trace array type list}
|
|
tp3: stp;
|
|
|
|
begin {WriteArrays}
|
|
count := 0; {count the subscripts}
|
|
tp2 := tp;
|
|
tp3 := nil;
|
|
while tp2^.form = arrays do begin
|
|
count := count+1;
|
|
tp3 := tp2;
|
|
tp2 := tp2^.aeltype;
|
|
end; {while}
|
|
|
|
if tp2^.form = scalar then begin {write the type code}
|
|
{ cstring = packed array[1..x] of char }
|
|
{ pstring = packed array[0..x] of char }
|
|
if (boolean(tp2^.isPacked)) and (tp2 = charptr) then begin
|
|
GetBounds(tp3^.inxtype, lmin, lmax);
|
|
if (lmin = 0) or (lmin = 1) then begin
|
|
count := count-1;
|
|
{ 6 = cstring, 7 = pstring }
|
|
CnOut(7 - ord(lmin));
|
|
CnOut2(count);
|
|
end {if}
|
|
else WriteScalarType(tp2, 0, count);
|
|
end {if}
|
|
else
|
|
WriteScalarType(tp2, 0, count);
|
|
end {if}
|
|
else if tp2^.form = subrange then
|
|
WriteScalarType(tp2^.rangetype, 0, count)
|
|
else if tp2^.form = pointerStruct then
|
|
WritePointerType(tp2, count)
|
|
else begin
|
|
CnOut(12);
|
|
CnOut2(count);
|
|
end; {else if}
|
|
while count <> 0 do begin {write the subscript entries}
|
|
GetBounds(tp^.inxtype, lmin, lmax);
|
|
CnOut2(long(lmin).lsw); CnOut2(long(lmin).msw);
|
|
CnOut2(long(lmax).lsw); CnOut2(long(lmax).msw);
|
|
CnOut2(0); CnOut2(0);
|
|
symLength := symLength+12;
|
|
tp := tp^.aeltype;
|
|
count := count-1;
|
|
end; {while}
|
|
if tp2^.form = pointerStruct then {expand complex types}
|
|
ExpandPointerType(tp2)
|
|
else if tp2^.form in [records,objects] then
|
|
ExpandRecordType(tp2);
|
|
end; {WriteArrays}
|
|
|
|
|
|
procedure ExpandPointerType {tp: stp};
|
|
|
|
{ write the type entries for complex pointer types }
|
|
{ }
|
|
{ parameters: }
|
|
{ tp - pointer type }
|
|
|
|
var
|
|
disp: integer; {disp to symbol of same type}
|
|
|
|
begin {ExpandPointerType}
|
|
if tp^.eltype <> nil then
|
|
if tp^.eltype^.form in [pointerStruct,arrays,records,objects] then
|
|
begin
|
|
symLength := symLength+12;
|
|
CnOut2(0); CnOut2(0);
|
|
CnOut2(0); CnOut2(0);
|
|
CnOut(0);
|
|
case tp^.eltype^.form of
|
|
pointerStruct: begin
|
|
WritePointerType(tp^.eltype, 0);
|
|
ExpandPointerType(tp^.eltype);
|
|
end;
|
|
arrays: WriteArrays(tp^.aeltype);
|
|
records,
|
|
objects: begin
|
|
disp := GetTypeDisp(tp^.eltype);
|
|
if disp = noDisp then begin
|
|
if tp^.eltype^.form = records then
|
|
CnOut(12)
|
|
else
|
|
CnOut(14);
|
|
CnOut2(0);
|
|
ExpandRecordType(tp^.eltype);
|
|
end {if}
|
|
else begin
|
|
CnOut(13);
|
|
CnOut2(disp);
|
|
end; {else}
|
|
end;
|
|
end; {case}
|
|
end; {if}
|
|
end; {ExpandPointerType}
|
|
|
|
|
|
begin {GenSymbol}
|
|
if sym^.llink <> nil then
|
|
GenSymbol(sym^.llink, false);
|
|
|
|
if sym^.klass in [varsm,field] then begin
|
|
idtype := sym^.idtype;
|
|
if idtype <> nil then
|
|
if idtype^.form in
|
|
[scalar,subrange,pointerStruct,arrays,records,objects] then begin
|
|
symLength := symLength+12; {update length of symbol table}
|
|
WriteName(sym); {write the name field}
|
|
WriteAddress(sym); {write the address field}
|
|
|
|
if (sym^.klass = varsm) and (sym^.vkind = formal) then begin
|
|
{ add an extra pointer to var parameters. }
|
|
new(idtype);
|
|
idtype^.form := pointerStruct;
|
|
idtype^.eltype := sym^.idtype;
|
|
end;
|
|
|
|
case idtype^.form of
|
|
scalar: WriteScalarType(idtype, 0, 0);
|
|
subrange: WriteScalarType(idtype^.rangetype, 0, 0);
|
|
pointerStruct: begin
|
|
WritePointerType(idtype, 0);
|
|
ExpandPointerType(idtype);
|
|
end;
|
|
arrays: WriteArrays(idtype);
|
|
records,
|
|
objects: begin
|
|
disp := GetTypeDisp(idtype);
|
|
if disp = noDisp then begin
|
|
if idtype^.form = records then
|
|
CnOut(12)
|
|
else
|
|
CnOut(14);
|
|
CnOut2(0);
|
|
ExpandRecordType(idtype);
|
|
end {if}
|
|
else begin
|
|
CnOut(13);
|
|
CnOut2(disp);
|
|
end; {else}
|
|
end;
|
|
end; {case}
|
|
if idtype <> sym^.idtype then dispose(idtype);
|
|
end; {if}
|
|
end; {if}
|
|
|
|
if sym^.rlink <> nil then
|
|
GenSymbol(sym^.rlink, maybeLast);
|
|
end; {GenSymbol}
|
|
|
|
|
|
begin {GenSymbols}
|
|
tpList := nil; {no types so far}
|
|
if sym <> nil then {generate the symbols}
|
|
GenSymbol(sym, false);
|
|
while tpList <> nil do begin {dispose of type list}
|
|
tp2 := tpList;
|
|
tpList := tp2^.next;
|
|
dispose(tp2);
|
|
end; {while}
|
|
end; {GenSymbols}
|
|
|
|
|
|
procedure GetBounds {fsp: stp; var fmin,fmax: longint};
|
|
|
|
{ get internal bounds of subrange or scalar type }
|
|
{ (assume fsp<>longptr and fsp<>realptr) }
|
|
{ }
|
|
{ parameters: }
|
|
{ fsp - type to get the bounds for }
|
|
{ fmin, fmax - (output) bounds }
|
|
|
|
begin {GetBounds}
|
|
fmin := 0;
|
|
fmax := 0;
|
|
if fsp <> nil then
|
|
with fsp^ do
|
|
if form = subrange then begin
|
|
fmin := min;
|
|
fmax := max;
|
|
end {if}
|
|
else if fsp = charptr then begin
|
|
fmin := ordminchar;
|
|
fmax := ordmaxchar;
|
|
end {else if}
|
|
else if fsp = intptr then begin
|
|
fmin := -maxint;
|
|
fmax := maxint;
|
|
end {else if}
|
|
else if fsp = byteptr then
|
|
fmax := 255
|
|
else if fconst <> nil then
|
|
fmax := fconst^.values.ival
|
|
end; {GetBounds}
|
|
|
|
|
|
function GetType {tp: stp; isPacked: boolean): baseTypeEnum};
|
|
|
|
{ find the base type for a variable type }
|
|
{ }
|
|
{ parameters: }
|
|
{ tp - variable type }
|
|
{ isPacked - is the variable packed? }
|
|
{ }
|
|
{ returns: Variable base type }
|
|
|
|
begin {GetType}
|
|
case tp^.form of
|
|
scalar:
|
|
if tp=intptr then GetType := cgWord
|
|
else if (tp=boolptr) or (tp=charptr) then
|
|
if isPacked then
|
|
GetType := cgUByte
|
|
else
|
|
GetType := cgUWord
|
|
else if tp^.scalkind = declared then GetType := cgUWord
|
|
else if tp=realptr then GetType := cgReal
|
|
else if tp=byteptr then GetType := cgUByte
|
|
else if tp=longptr then GetType := cgLong
|
|
else if tp=doubleptr then GetType := cgDouble
|
|
else if tp=extendedptr then GetType := cgExtended
|
|
else if tp=compptr then GetType := cgComp
|
|
else begin
|
|
GetType := cgWord;
|
|
Error(113);
|
|
end; {else}
|
|
subrange: begin
|
|
if tp^.rangetype = intptr then
|
|
if tp^.min >= 0 then
|
|
GetType := cgUWord
|
|
else
|
|
GetType := cgWord
|
|
else if tp^.rangetype = longptr then
|
|
if tp^.min >= 0 then
|
|
GetType := cgULong
|
|
else
|
|
GetType := cgLong
|
|
else
|
|
GetType := GetType(tp^.rangetype, isPacked);
|
|
end;
|
|
pointerStruct,
|
|
files,
|
|
objects:
|
|
GetType := cgULong;
|
|
power:
|
|
GetType := cgSet;
|
|
arrays,
|
|
records:
|
|
GetType := cgString;
|
|
otherwise: begin
|
|
GetType := cgWord;
|
|
Error(113);
|
|
end;
|
|
end; {case}
|
|
end; {GetType}
|
|
|
|
|
|
function IsReal {fsp: stp): boolean};
|
|
|
|
{ determine if fsp is one of the real types }
|
|
{ }
|
|
{ parameters: }
|
|
{ fsp - structure to check }
|
|
{ }
|
|
{ Returns: True if fsp is a real, else false }
|
|
|
|
begin {IsReal}
|
|
if fsp = realptr then
|
|
IsReal := true
|
|
else if fsp = doubleptr then
|
|
IsReal := true
|
|
else if fsp = extendedptr then
|
|
IsReal := true
|
|
else if fsp = compptr then
|
|
IsReal := true
|
|
else
|
|
IsReal := false;
|
|
end; {IsReal}
|
|
|
|
|
|
function IsString {fsp: stp): boolean};
|
|
|
|
{ determine if fsp is a string }
|
|
{ }
|
|
{ parameters: }
|
|
{ fsp - structure to check }
|
|
{ }
|
|
{ Returns: True if fsp is a string, else false }
|
|
|
|
var
|
|
low,hi: longint; {range of index variable}
|
|
|
|
begin {IsString}
|
|
IsString := false;
|
|
if fsp <> nil then
|
|
with fsp^ do
|
|
if form = arrays then
|
|
if aeltype = charptr then
|
|
if CompTypes(inxtype,intptr) then
|
|
if ispacked = pkpacked then
|
|
if inxtype = nil then
|
|
{string constants have nil index types}
|
|
IsString := true
|
|
else begin
|
|
GetBounds(inxtype,low,hi);
|
|
IsString := ((low = 1) or ((low = 0) and (not iso)))
|
|
and (hi > 1);
|
|
end; {else}
|
|
end; {IsString}
|
|
|
|
|
|
function StrLen {tp: stp): integer};
|
|
|
|
{ Find the length of a string variable (for library calls) }
|
|
{ }
|
|
{ parameters: }
|
|
{ tp - string variable }
|
|
{ }
|
|
{ Returns: length of the string }
|
|
|
|
var
|
|
low,hi: longint; {range of index variable}
|
|
|
|
begin {StrLen}
|
|
if tp <> nil then
|
|
with tp^ do
|
|
if (inxType = dummyString) or (inxType = nil) then
|
|
StrLen := long(size).lsw
|
|
else begin
|
|
GetBounds(inxType,low,hi);
|
|
if low = 0 then
|
|
StrLen := -long(hi).lsw
|
|
else
|
|
StrLen := long(hi).lsw;
|
|
end; {else}
|
|
end; {StrLen}
|
|
|
|
end.
|
|
|
|
{$append 'symbols.asm'}
|