Apple-2gs-SW/ORCA-C
1
0
Fork 0
mirror of https://github.com/byteworksinc/ORCA-C.git synced 2024-11-19 03:07:00 +00:00
Code Issues Projects Releases Wiki Activity
74cec68dac
ORCA-C/Symbol.pas
Stephen Heumann cc36e9929f Remove some unused variables.
2023-03-20 11:12:48 -05:00

2605 lines
88 KiB
ObjectPascal
Raw Blame History

{$optimize 7}
{---------------------------------------------------------------}
{ }
{ Symbol Table }
{ }
{ Handle the symbol table. }
{ }
{ External Subroutines: }
{ }
{ CheckStaticFunctions - check for undefined functions }
{ CompTypes - Determine if the two types are compatible }
{ DoGlobals - declare the ~globals and ~arrays segments }
{ FindSymbol - locate a symbol in the symbol table }
{ GenParameters - Generate labels and space for the parameters }
{ GenSymbols - generate a symbol table for the debugger }
{ InitSymbol - initialize the symbol table handler }
{ NewSymbol - insert a new symbol in the symbol table }
{ PopTable - Pop a symbol table (remove definitions local to a }
{ block) }
{ PushTable - Create a new symbol table, pushing the old one }
{ ResolveForwardReference - resolve a forward reference }
{ }
{ External Variables: }
{ }
{ table - current symbol table }
{ }
{ charPtr - pointer to the base type for char }
{ sCharPtr - pointer to the base type for signed char }
{ uCharPtr - pointer to the base type for unsigned char }
{ shortPtr - pointer to the base type for short }
{ uShortPtr - pointer to the base type for unsigned short }
{ intPtr - pointer to the base type for int }
{ uIntPtr - pointer to the base type for unsigned int }
{ int32Ptr - pointer to the base type for 32-bit int }
{ uInt32Ptr - pointer to the base type for 32-bit unsigned int }
{ longPtr - pointer to the base type for long }
{ uLongPtr - pointer to the base type for unsigned long }
{ longLongPtr - pointer to the base type for long long }
{ uLongLongPtr - pointer to base type for unsigned long long }
{ floatPtr - pointer to the base type for float }
{ doublePtr - pointer to the base type for double }
{ compPtr - pointer to the base type for comp }
{ extendedPtr - pointer to the base type for extended }
{ boolPtr - pointer to the base type for _Bool }
{ voidPtr - pointer to the base type for void }
{ voidPtrPtr - typeless pointer, for some type casting }
{ charPtrPtr - pointer to type record for char * }
{ vaInfoPtr - pointer to type record for internal va info type }
{ stringTypePtr - pointer to the base type for string literals }
{ utf16StringTypePtr - pointer to the base type for UTF-16 }
{ string literals }
{ utf32StringTypePtr - pointer to the base type for UTF-32 }
{ string literals }
{ constCharPtr - pointer to the type const char }
{ defaultStruct - default for structures with errors }
{ }
{---------------------------------------------------------------}
unit Symbol;
{$LibPrefix '0/obj/'}
interface
uses CCommon, CGI, MM, Scanner;
{$segment 'CC'}
{---------------------------------------------------------------}
const
staticNumLen = 5; {length of staticNum name prefix}
type
symbolTablePtr = ^symbolTable;
symbolTable = record {a symbol table}
{NOTE: the array of buckets must come first in the record!}
buckets: array[0..hashSize2] of identPtr; {hash buckets}
next: symbolTablePtr; {next symbol table}
isEmpty: boolean; {is the pool empty (nothing in buckets)?}
case noStatics: boolean of {no statics/staticNum for this table?}
false: (staticNum: packed array[1..6] of char); {staticNum for this table}
true: ();
end;
var
table: symbolTablePtr; {current symbol table}
globalTable: symbolTablePtr; {global symbol table}
functionTable: symbolTablePtr; {table for top level of current function}
{output from GenParameters}
lastParameterLLN: integer; {label number of last parameter (0 if none)}
lastParameterSize: integer; {size of last parameter}
{base types}
charPtr,sCharPtr,uCharPtr,shortPtr,uShortPtr,intPtr,uIntPtr,int32Ptr,
uInt32Ptr,longPtr,uLongPtr,longLongPtr,uLongLongPtr,boolPtr,
floatPtr,doublePtr,compPtr,extendedPtr,stringTypePtr,utf16StringTypePtr,
utf32StringTypePtr,voidPtr,voidPtrPtr,charPtrPtr,vaInfoPtr,constCharPtr,
defaultStruct: typePtr;
{---------------------------------------------------------------}
procedure CheckStaticFunctions;
{ check for undefined functions }
procedure CheckUnused (tPtr: symbolTablePtr);
{ check for unused variables in symbol table }
function CompTypes (t1, t2: typePtr): boolean;
{ Determine if the two types are compatible }
function StrictCompTypes (t1, t2: typePtr): boolean;
{ Determine if the two types are compatible, strictly following }
{ C standard rules. }
procedure DoGlobals;
{ declare the ~globals and ~arrays segments }
function FindSymbol (var tk: tokenType; class: spaceType; oneLevel: boolean;
staticAllowed: boolean): identPtr;
{ locate a symbol in the symbol table }
{ }
{ parameters: }
{ tk - token record for the identifier to find }
{ class - the kind of variable space to search }
{ oneLevel - search one level only? (used to check for }
{ duplicate symbols) }
{ staticAllowed - can we check for static variables? }
{ }
{ returns: }
{ A pointer to the symbol table entry is returned. If }
{ there is no entry, nil is returned. }
procedure GenParameters (pp: parameterPtr);
{ Generate labels and space for the parameters }
{ }
{ parameters: }
{ pp - pointer to first parameter }
{ }
{ variables: }
{ lastParameterLLN - label number of last parameter }
{ lastParameterSize - size of last parameter }
procedure GenSymbols (sym: symbolTablePtr; doGlobals: boolean);
{ generate a symbol table for the debugger }
{ }
{ parameters: }
{ sym - symbol table to generate }
{ doGlobals - include global symbols in the table }
{ }
{ outputs: }
{ symLength - length of debug symbol table }
procedure InitSymbol;
{ Initialize the symbol table module }
function IsVoid (tp: typePtr): boolean;
{ Check to see if a type is void }
{ }
{ Parameters: }
{ tp - type to check }
{ }
{ Returns: True if the type is void, else false }
function LabelToDisp (lab: integer): integer; extern;
{ convert a local label number to a stack frame displacement }
{ }
{ parameters: }
{ lab - label number }
function MakePascalType (origType: typePtr): typePtr;
{ make a version of a type with the pascal qualifier applied }
{ }
{ parameters: }
{ origType - the original type }
{ }
{ returns: pointer to the pascal-qualified type }
function MakePointerTo (pType: typePtr): typePtr;
{ make a pointer type }
{ }
{ parameters: }
{ pType - the type pointed to }
{ }
{ returns: the pointer type }
function MakeCompositeType (t1, t2: typePtr): typePtr;
{ Make the composite type of two compatible types. }
{ See C17 section 6.2.7. }
{ }
{ parameters: }
{ t1,t2 - the input types (must be compatible) }
{ }
{ returns: pointer to the composite type }
function MakeQualifiedType (origType: typePtr; qualifiers: typeQualifierSet):
typePtr;
{ make a qualified version of a type }
{ }
{ parameters: }
{ origType - the original type }
{ qualifiers - the type qualifier(s) to add }
{ }
{ returns: pointer to the qualified type }
function Unqualify (tp: typePtr): typePtr;
{ returns the unqualified version of a type }
{ }
{ parameters: }
{ tp - the original type }
{ }
{ returns: pointer to the unqualified type }
function NewSymbol (name: stringPtr; itype: typePtr; class: tokenEnum;
space: spaceType; state: stateKind; isInline: boolean):
identPtr;
{ insert a new symbol in the symbol table }
{ }
{ parameters: }
{ name - pointer to the symbol name }
{ itype - pointer to the symbol type }
{ class - storage class }
{ space - the kind of variable space to put the }
{ identifier in }
{ state - variable declaration state }
{ }
{ returns: pointer to the inserted symbol }
procedure PopTable;
{ Pop a symbol table (remove definitions local to a block) }
{procedure PrintOneSymbol (ip: identPtr); {debug}
{ Print a symbol }
{ }
{ Parameters: }
{ ip - identifier to print }
{procedure PrintTable (sym: symbolTablePtr); {debug}
{ print a symbol table }
{ }
{ parameters: }
{ sym - symbol table to print }
procedure PushTable;
{ Create a new symbol table, pushing the old one }
procedure ResolveForwardReference (iPtr: identPtr);
{ resolve a forward reference }
{ }
{ parameters: }
{ iPtr - ptr to the forward declared identifier }
function StringType(prefix: charStrPrefixEnum): typePtr;
{ returns the type of a string literal with specified prefix }
{ }
{ parameters: }
{ prefix - the prefix }
{---------------------------------------------------------------}
implementation
type
{From CGC.pas}
realrec = record {used to convert from real to in-SANE}
itsReal: extended;
inSANE: packed array[1..10] of byte;
inCOMP: packed array[1..8] of byte;
end;
var
staticNum: packed array[1..6] of char; {static variable number}
tablePool: symbolTablePtr; {pool of reusable empty symbol tables}
tablePoolSize: 0..maxint; {number of tables in pool}
tablePoolMaxSize: 0..maxint; {max number of tables in pool}
{- Imported from CGC.pas ---------------------------------------}
procedure CnvSC (rec: realrec); extern;
{ convert a real number to SANE comp format }
{ }
{ parameters: }
{ rec - record containing the value to convert; also }
{ has space for the result }
{---------------------------------------------------------------}
procedure CnOut (i: integer); extern;
{ write a byte to the constant buffer }
{ }
{ parameters: }
{ i - byte to write }
procedure CnOut2 (i: integer); extern;
{ write a word to the constant buffer }
{ }
{ parameters: }
{ i - word to write }
procedure Out (b: integer); extern;
{ write a byte to the output file }
{ }
{ parameters: }
{ b - byte to write }
procedure Out2 (w: integer); extern;
{ write a word to the output file }
{ }
{ parameters: }
{ w - word to write }
procedure RefName (lab: stringPtr; disp, len, shift: integer); extern;
{ handle a reference to a named label }
{ }
{ parameters: }
{ lab - label name }
{ disp - displacement past the label }
{ len - number of bytes in the reference }
{ shift - shift factor }
procedure LabelSearch (lab: integer; len, shift, disp: integer); extern;
{ resolve a label reference }
{ }
{ parameters: }
{ lab - label number }
{ len - # bytes for the generated code }
{ shift - shift factor }
{ disp - disp past the label }
{ }
{ Note 1: maxlabel is reserved for use as the start of the }
{ string space }
{ Note 2: negative length indicates relative branch }
{ Note 3: zero length indicates 2 byte addr -1 }
procedure Purge; extern;
{ write any constant bytes to the output buffer }
{- Imported from IIGS Memory Manager ---------------------------}
function MaxBlock: longint; tool ($02, $1C);
{---------------------------------------------------------------}
procedure ClearTable (table: symbolTable); extern;
{ clear the symbol table to all zeros }
procedure SaveBF (addr: ptr; bitdisp, bitsize: integer; val: longint); extern;
{ save a value to a bit-field }
{ }
{ parameters: }
{ addr - address to copy to }
{ bitdisp - displacement past the address }
{ bitsize - number of bits }
{ val - value to copy }
{---------------------------------------------------------------}
procedure CheckStaticFunctions;
{ check for undefined functions }
var
i: 0..hashSize; {loop variable}
sp: identPtr; {pointer to a symbol table entry}
msg: stringPtr; {error message ptr}
begin {CheckStaticFunctions}
for i := 0 to hashSize do begin
sp := globalTable^.buckets[i];
while sp <> nil do begin
if sp^.storage = private then
if sp^.itype^.kind = functionType then
if sp^.state <> defined then
if sp^.used then begin
numErrors := numErrors+1;
new(msg);
msg^ := concat('The static function ', sp^.name^,
' was used but never defined.');
writeln('*** ', msg^);
if terminalErrors then begin
if enterEditor then
ExitToEditor(msg, ord4(firstPtr)-ord4(bofPtr))
else
TermError(0);
end; {if}
liDCBGS.merrf := 16;
end; {if}
sp := sp^.next;
end; {while}
end; {for}
end; {CheckStaticFunctions}
procedure CheckUnused {tPtr: symbolTablePtr};
{ check for unused variables in symbol table }
var
i: integer; {loop variable}
ip: identPtr; {current symbol}
nameStr: stringPtr;
begin {CheckUnused}
if not tPtr^.isEmpty or not tPtr^.noStatics then
for i := 0 to hashSize do begin {loop over all hash buckets}
if not tPtr^.isEmpty then begin
ip := tPtr^.buckets[i]; {trace through non-static symbols}
while ip <> nil do begin
if not ip^.used then
if ip^.itype <> nil then
if not (ip^.itype^.kind in [functionType,enumConst]) then
if ip^.storage in [stackFrame,private] then
if not (ip^.name^[1] in ['~','@']) then begin
new(nameStr);
nameStr^ := ip^.name^;
ErrorWithExtraString(185, nameStr);
end; {if}
ip := ip^.next;
end; {while}
end; {if}
if not tPtr^.noStatics then begin
ip := globalTable^.buckets[i]; {trace through static symbols}
while ip <> nil do begin
if not ip^.used then
if ip^.itype <> nil then
if not (ip^.itype^.kind in [functionType,enumConst]) then
if ip^.storage = private then
if copy(ip^.name^,1,staticNumLen) = tPtr^.staticNum then
begin
new(nameStr);
nameStr^ := copy(ip^.name^, staticNumLen+1, maxint);
ErrorWithExtraString(185, nameStr);
end; {if}
ip := ip^.next;
end; {while}
end; {if}
end; {for}
end; {CheckUnused}
function CompTypes {t1, t2: typePtr): boolean};
{ Determine if the two types are compatible }
label 1;
var
el1,el2: longint; {array sizes}
kind1,kind2: typeKind; {temp variables (for speed)}
begin {CompTypes}
CompTypes := false; {assume the types are not compatible}
kind1 := t1^.kind; {get these for efficiency}
kind2 := t2^.kind;
if kind2 = definedType then {scan past type definitions}
CompTypes := CompTypes(t1, t2^.dType)
else if kind1 = definedType then
CompTypes := CompTypes(t1^.dType, t2)
else
case kind1 of
scalarType:
if kind2 = scalarType then begin
CompTypes := t1^.baseType = t2^.baseType;
if t1^.cType <> t2^.cType then
if (not looseTypeChecks)
or (t1^.cType = ctBool) or (t2^.cType = ctBool) then
CompTypes := false;
end {if}
else if kind2 = enumType then
CompTypes := (t1^.baseType = cgWord) and (t1^.cType = ctInt);
arrayType:
if kind2 = arrayType then begin
el1 := t1^.elements;
el2 := t2^.elements;
if el1 = 0 then
el1 := el2
else if el2 = 0 then
el2 := el1;
if el1 = el2 then
CompTypes := CompTypes(t1^.atype, t2^.atype);
end; {if}
functionType:
if kind2 = functionType then begin
if looseTypeChecks or (t1^.prototyped <> t2^.prototyped) then
CompTypes := CompTypes(t1^.ftype,t2^.ftype)
else
CompTypes := StrictCompTypes(t1, t2);
end {if}
else if kind2 = pointerType then
if t2^.ptype^.kind = functionType then
CompTypes := CompTypes(t1, t2^.ptype);
pointerType: begin
if IsVoid(t1^.ptype) or IsVoid(t2^.ptype) then begin
CompTypes := true;
goto 1;
end; {if}
if kind2 = pointertype then
CompTypes := CompTypes(t1^.ptype, t2^.ptype)
else if kind2 = functionType then
CompTypes := CompTypes(t1^.ptype, t2);
end;
enumType:
if kind2 = scalarType then
CompTypes := (t2^.baseType = cgWord) and (t2^.cType = ctInt)
else if kind2 = enumType then
CompTypes := true;
structType,unionType:
CompTypes := t1 = t2;
otherwise: ;
end; {case t1^.kind}
1:
end; {CompTypes}
function StrictCompTypes {t1, t2: typePtr): boolean};
{ Determine if the two types are compatible, strictly following }
{ C standard rules. }
label 1;
var
el1,el2: longint; {array sizes}
kind1,kind2: typeKind; {temp variables (for speed)}
p1, p2: parameterPtr; {for tracing parameter lists}
tp1,tp2: typeRecord; {temporary types used in comparison}
begin {StrictCompTypes}
if t1 = t2 then begin {shortcut}
StrictCompTypes := true;
goto 1;
end; {if}
StrictCompTypes := false; {assume the types are not compatible}
if t1^.qualifiers <> t2^.qualifiers then {qualifiers must be the same}
goto 1;
while t1^.kind = definedType do {scan past type definitions}
t1 := t1^.dType;
while t2^.kind = definedType do
t2 := t2^.dType;
kind1 := t1^.kind; {get these for efficiency}
kind2 := t2^.kind;
case kind1 of
scalarType:
if kind2 = scalarType then begin
StrictCompTypes :=
(t1^.baseType = t2^.baseType) and (t1^.cType = t2^.cType);
end {if}
else if kind2 = enumType then
StrictCompTypes := (t1^.baseType = cgWord) and (t1^.cType = ctInt);
arrayType:
if kind2 = arrayType then begin
el1 := t1^.elements;
el2 := t2^.elements;
if el1 = 0 then
el1 := el2
else if el2 = 0 then
el2 := el1;
if el1 = el2 then
StrictCompTypes := StrictCompTypes(t1^.atype, t2^.atype);
end; {if}
functionType:
if kind2 = functionType then begin
if not StrictCompTypes(t1^.ftype, t2^.ftype) then
goto 1;
if t1^.varargs <> t2^.varargs then
goto 1;
if t1^.prototyped and t2^.prototyped then begin
p1 := t1^.parameterList;
p2 := t2^.parameterList;
while (p1 <> nil) and (p2 <> nil) do begin
tp1 := p1^.parameterType^;
tp2 := p2^.parameterType^;
if p1^.parameterType = p2^.parameterType then
{these parameters are compatible}
else begin
tp1.qualifiers := [];
tp2.qualifiers := [];
if tp1.kind = arrayType then
tp1.kind := pointerType
else if tp1.kind = functionType then begin
tp1.size := cgPointerSize;
tp1.qualifiers := [];
tp1.saveDisp := 0;
tp1.kind := pointerType;
tp1.pType := p1^.parameterType;
end; {else if}
if tp2.kind = arrayType then
tp2.kind := pointerType
else if tp2.kind = functionType then begin
tp2.size := cgPointerSize;
tp2.qualifiers := [];
tp2.saveDisp := 0;
tp2.kind := pointerType;
tp2.pType := p2^.parameterType;
end; {else if}
if not StrictCompTypes(@tp1, @tp2) then
goto 1;
end; {else}
p1 := p1^.next;
p2 := p2^.next;
end; {while}
if p1 <> p2 then
goto 1;
end {if}
else if t1^.prototyped then begin
p1 := t1^.parameterList;
while p1 <> nil do begin
if p1^.parameterType^.kind = scalarType then
if p1^.parameterType^.cType in [ctChar,ctSChar,ctUChar,
ctShort,ctUShort,ctFloat,ctBool] then
goto 1;
p1 := p1^.next;
end; {while}
end {else if}
else if t2^.prototyped then begin
p2 := t2^.parameterList;
while p2 <> nil do begin
if p2^.parameterType^.kind = scalarType then
if p2^.parameterType^.cType in [ctChar,ctSChar,ctUChar,
ctShort,ctUShort,ctFloat,ctBool] then
goto 1;
p2 := p2^.next;
end; {while}
end; {else if}
StrictCompTypes := true;
end; {if}
pointerType:
if kind2 = pointertype then
StrictCompTypes := StrictCompTypes(t1^.ptype, t2^.ptype);
enumType:
if kind2 = scalarType then
StrictCompTypes := (t2^.baseType = cgWord) and (t2^.cType = ctInt)
else if kind2 = enumType then
StrictCompTypes := true;
structType,unionType:
StrictCompTypes := t1 = t2;
otherwise: ;
end; {case}
1:
end; {StrictCompTypes}
procedure DoGlobals;
{ declare the ~globals and ~arrays segments }
procedure FreeTablePool;
{ free the symbol table pool }
var
tPtr: symbolTablePtr;
begin {FreeTablePool}
while tablePool <> nil do begin
tPtr := tablePool;
tablePool := tPtr^.next;
dispose(tPtr);
end;
end; {FreeTablePool}
procedure StaticInit (variable: identPtr);
{ statically initialize a variable }
type
{record of pointer initializers}
relocPtr = ^relocationRecord;
relocationRecord = record
next: relocPtr; {next record}
initializer: initializerPtr; {the initializer}
disp: longint; {disp in overall data structure}
end;
{pointers to each type}
bytePtr = ^byte;
wordPtr = ^integer;
longPtr = ^longint;
quadPtr = ^longlong;
realPtr = ^real;
doublePtr = ^double;
extendedPtr = ^extended;
var
buffPtr: ptr; {pointer to data buffer}
count: integer; {# of duplicate records}
disp: longint; {disp into buffer (for output)}
endDisp: longint; {ending disp for current chunk}
i: integer; {loop counter}
ip: initializerPtr; {used to trace initializer lists}
lastReloc, nextReloc: relocPtr; {for reversing relocs list}
realVal: realRec; {used for extended-to-comp conversion}
relocs: relocPtr; {list of records needing relocation}
{pointers used to write data}
bp: bytePtr;
wp: wordPtr;
lp: longPtr;
qp: quadPtr;
rp: realPtr;
dp: doublePtr;
ep: extendedPtr;
procedure UpdateRelocs;
{ update relocation records to account for an initializer }
var
disp: longint; {disp of current initializer}
done: boolean; {done with loop?}
endDisp: longint; {disp at end of current initializer}
last: ^relocPtr; {the pointer referring to rp}
rp: relocPtr; {reloc record being processed}
begin {UpdateRelocs}
disp := ip^.disp;
if ip^.bitsize <> 0 then begin
endDisp := disp + (ip^.bitdisp + ip^.bitsize + 7) div 8;
disp := disp + ip^.bitdisp div 8;
end {if}
else if ip^.basetype = cgString then
endDisp := disp + ip^.sVal^.length
else
endDisp := disp + TypeSize(ip^.baseType);
last := @relocs;
rp := relocs;
done := false;
while (rp <> nil) and not done do begin
if rp^.disp + cgPointerSize <= disp then begin
{initializer is entirely after this reloc: no conflicts}
done := true;
end {if}
else if endDisp <= rp^.disp then begin
{initializer is entirely before this reloc}
last := @rp^.next;
rp := rp^.next;
end {else if}
else begin
{conflict: remove the conflicting reloc record}
last^ := rp^.next;
lp := pointer(ord4(buffPtr) + rp^.disp);
lp^ := 0;
dispose(rp);
rp := last^;
end; {else}
end; {while}
if ip^.basetype = ccPointer then begin
new(rp);
rp^.next := last^;
last^ := rp;
rp^.disp := ip^.disp;
rp^.initializer := ip;
end; {if}
end; {UpdateRelocs}
begin {StaticInit}
{allocate buffer}
{(+3 for possible bitfield overhang)}
buffPtr := GLongMalloc(variable^.itype^.size+3);
relocs := nil; {evaluate initializers}
ip := variable^.iPtr;
while ip <> nil do begin
count := 0;
while count < ip^.count do begin
UpdateRelocs;
if ip^.bitsize <> 0 then begin
bp := pointer(ord4(buffPtr) + ip^.disp + count);
SaveBF(bp, ip^.bitdisp, ip^.bitsize, ip^.iVal);
end {if}
else
case ip^.basetype of
cgByte,cgUByte: begin
bp := pointer(ord4(buffPtr) + ip^.disp + count);
bp^ := ord(ip^.iVal) & $ff;
end;
cgWord,cgUWord: begin
wp := pointer(ord4(buffPtr) + ip^.disp + count);
wp^ := ord(ip^.iVal);
end;
cgLong,cgULong: begin
lp := pointer(ord4(buffPtr) + ip^.disp + count);
lp^ := ip^.iVal;
end;
cgQuad,cgUQuad: begin
qp := pointer(ord4(buffPtr) + ip^.disp + count);
qp^ := ip^.qVal;
end;
cgReal: begin
rp := pointer(ord4(buffPtr) + ip^.disp + count);
rp^ := ip^.rVal;
end;
cgDouble: begin
dp := pointer(ord4(buffPtr) + ip^.disp + count);
dp^ := ip^.rVal;
end;
cgExtended: begin
ep := pointer(ord4(buffPtr) + ip^.disp + count);
ep^ := ip^.rVal;
end;
cgComp: begin
realVal.itsReal := ip^.rVal;
CnvSC(realVal);
for i := 1 to 8 do begin
bp := pointer(ord4(buffPtr) + ip^.disp + count + i-1);
bp^ := realVal.inCOMP[i];
end; {for}
end;
cgString: begin
for i := 1 to ip^.sVal^.length do begin
bp := pointer(ord4(buffPtr) + ip^.disp + count + i-1);
bp^ := ord(ip^.sVal^.str[i]);
end; {for}
end;
ccPointer: ; {handled by UpdateRelocs}
cgVoid: Error(57);
end; {case}
count := count + 1; {assumes count > 1 only for bytes}
end; {while}
ip := ip^.next;
end; {while}
lastReloc := nil; {reverse the relocs list}
while relocs <> nil do begin
nextReloc := relocs^.next;
relocs^.next := lastReloc;
lastReloc := relocs;
relocs := nextReloc;
end; {while}
relocs := lastReloc;
disp := 0; {generate the initialization data}
while disp < variable^.itype^.size do begin
if relocs = nil then
endDisp := variable^.itype^.size
else
endDisp := relocs^.disp;
if disp <> endDisp then begin
GenBS(dc_cns, pointer(ord4(buffPtr) + disp), endDisp - disp);
disp := endDisp;
end; {if}
if relocs <> nil then begin
code^.optype := ccPointer;
code^.r := ord(relocs^.initializer^.pPlus);
code^.q := 1;
code^.pVal := relocs^.initializer^.pVal;
if relocs^.initializer^.isName then begin
code^.lab := relocs^.initializer^.pName;
code^.pstr := nil;
end {if}
else
code^.pstr := relocs^.initializer^.pstr;
Gen0(dc_cns);
lastReloc := relocs;
relocs := relocs^.next;
dispose(lastReloc);
disp := disp + cgPointerSize;
end; {if}
end; {while}
end; {StaticInit}
procedure GenArrays;
{ define global arrays }
var
didOne: boolean; {have we found an array yet?}
i: 0..hashSize; {loop variable}
ip: initializerPtr; {used to trace initializer lists}
lval: longint; {for converting types}
size: longint; {size of the array}
sp: identPtr; {pointer to a symbol table entry}
tPtr: typePtr; {type of global array/struct/union}
msg: stringPtr; {error message ptr}
begin {GenArrays}
didOne := false;
for i := 0 to hashSize do begin
sp := table^.buckets[i];
while sp <> nil do begin
if sp^.storage in [global,private] then begin
tPtr := sp^.itype;
while tPtr^.kind = definedType do
tPtr := tPtr^.dType;
if tPtr^.kind in [arrayType,structType,unionType] then begin
if not didOne then begin
if smallMemoryModel then
currentSegment := ' '
else
currentSegment := '~ARRAYS ';
segmentKind := 0; {this segment is not dynamic!}
Gen2Name(dc_str, $4000, 1, @'~ARRAYS');
didOne := true;
end; {if}
if sp^.state = initialized then begin
Gen2Name(dc_glb, 0, ord(sp^.storage = private), sp^.name);
StaticInit(sp);
end {if}
else begin
size := sp^.itype^.size;
if size = 0 then begin
if sp^.itype^.kind = arrayType then begin
{implicitly initialize with one element}
size := sp^.itype^.aType^.size;
end {if}
else begin
numErrors := numErrors+1;
new(msg);
msg^ := concat('The struct or union ''', sp^.name^,
''' has incomplete type that was never completed.');
writeln('*** ', msg^);
if terminalErrors then begin
if enterEditor then
ExitToEditor(msg, ord4(firstPtr)-ord4(bofPtr))
else
TermError(0);
end; {if}
liDCBGS.merrf := 16;
end; {else}
end; {if}
Gen2Name(dc_glb, long(size).lsw & $7FFF,
ord(sp^.storage = private), sp^.name);
size := size & $FFFF8000;
while size <> 0 do begin
Gen1(dc_dst, 16384);
size := size-16384;
end; {while}
end; {else}
end; {if}
end; {if}
sp := sp^.next;
end; {while}
end; {for}
if didOne then
Gen0(dc_enp);
end; {GenArrays}
procedure GenGlobals;
{ define non-array global variables }
var
i: 0..hashSize; {loop variable}
ip: initializerPtr; {used to trace initializer lists}
lval: longint; {for extracting lsw}
sp: identPtr; {pointer to a symbol table entry}
begin {GenGlobals}
Gen2t(dc_cns, 0, 1, cgByte);
for i := 0 to hashSize do begin
sp := table^.buckets[i];
while sp <> nil do begin
if sp^.storage in [global,private] then
if sp^.itype^.kind in [scalarType,pointerType] then begin
if sp^.state = initialized then begin
Gen2Name(dc_glb, 0, ord(sp^.storage = private), sp^.name);
ip := sp^.iPtr;
case ip^.basetype of
cgByte,cgUByte,cgWord,cgUWord: begin
lval := ip^.ival;
Gen2t(dc_cns, long(lval).lsw, 1, ip^.basetype);
end;
cgLong,cgULong:
GenL1(dc_cns, ip^.ival, 1);
cgQuad,cgUQuad:
GenQ1(dc_cns, ip^.qval, 1);
cgReal,cgDouble,cgComp,cgExtended:
GenR1t(dc_cns, ip^.rval, 1, ip^.basetype);
cgString:
GenS(dc_cns, ip^.sval);
ccPointer: begin
code^.optype := ccPointer;
code^.q := 1;
code^.r := ord(ip^.pPlus);
code^.pVal := ip^.pVal;
if ip^.isName then begin
code^.lab := ip^.pName;
code^.pstr := nil;
end {if}
else
code^.pstr := ip^.pstr;
Gen0(dc_cns);
end;
otherwise: Error(57);
end; {case}
end {if}
{else if sp^.itype^.size = 0 then begin
Error(57);
end {else if}
else
Gen2Name(dc_glb, ord(sp^.itype^.size),
ord(sp^.storage = private), sp^.name);
end;
sp := sp^.next;
end; {while}
end; {for}
end; {GenGlobals}
begin {DoGlobals}
{print the global symbol table}
{if printSymbols then {debug}
{ PrintTable(globalTable); {debug}
FreeTablePool; {dispose of unneeded symbol tables}
{declare the ~globals segment, which holds non-array data types}
if smallMemoryModel then
currentSegment := ' '
else
currentSegment := '~GLOBALS ';
segmentKind := 0; {this segment is not dynamic!}
Gen2Name(dc_str, $4000, 0, @'~GLOBALS');
GenGlobals;
Gen0(dc_enp);
{declare the ~arrays segment, which holds global arrays}
GenArrays;
end; {DoGlobals}
function FindSymbol {var tk: tokenType; class: spaceType; oneLevel: boolean;
staticAllowed: boolean): identPtr};
{ locate a symbol in the symbol table }
{ }
{ parameters: }
{ tk - token record for the identifier to find }
{ class - the kind of variable space to search }
{ oneLevel - search one level only? (used to check for }
{ duplicate symbols) }
{ staticAllowed - can we check for static variables? }
{ }
{ returns: }
{ A pointer to the symbol table entry is returned. If }
{ there is no entry, nil is returned. }
label 1,2;
var
hashDisp: longint; {disp into the hash table}
i: integer; {loop variable}
iHandle: ^identPtr; {pointer to start of hash bucket}
iPtr: identPtr; {pointer to the current symbol}
name: stringPtr; {name to search for}
np: stringPtr; {for searching for static variables}
sPtr: symbolTablePtr; {^ to current symbol table}
begin {FindSymbol}
{get ready to search}
staticAllowed := staticAllowed and (staticNum <> '~0000');
name := tk.name; {use a local variable}
hashDisp := Hash(name); {get the disp into the symbol table}
np := nil; {no string buffer, yet}
{check for the variable}
2:
sPtr := table; {initialize the address of the sym. tbl}
while sPtr <> nil do begin
iHandle := pointer(hashDisp+ord4(sPtr));
if class = tagSpace then
iHandle := pointer(ord4(iHandle) + (hashSize+1)*4);
iPtr := iHandle^;
{scan the hash bucket for a global or auto variable}
while iPtr <> nil do begin
if iPtr^.name^ = name^ then begin
FindSymbol := iPtr;
if iPtr^.isForwardDeclared then
ResolveForwardReference(iPtr);
tk.symbolPtr := iPtr;
goto 1;
end; {if}
iPtr := iPtr^.next;
end; {while}
{rescan for a static variable}
if staticAllowed and not sPtr^.noStatics then begin
if np = nil then begin {form the static name}
if length(name^) < 251 then begin
new(np);
np^[0] := chr(5+length(name^));
for i := 1 to 5 do
np^[i] := sPtr^.staticNum[i];
for i := 1 to length(name^) do
np^[i+5] := name^[i];
end; {if}
end {if}
else
for i := 2 to 5 do
np^[i] := sPtr^.StaticNum[i];
{scan the hash bucket for the identifier}
iHandle := pointer(hashDisp+ord4(globalTable));
if class = tagSpace then
iHandle := pointer(ord4(iHandle) + (hashSize+1)*4);
iPtr := iHandle^;
while iPtr <> nil do begin
if iPtr^.name^ = np^ then begin
FindSymbol := iPtr;
if iPtr^.isForwardDeclared then
ResolveForwardReference(iPtr);
tk.symbolPtr := iPtr;
goto 1;
end; {if}
iPtr := iPtr^.next;
end; {while}
end; {if staticAllowed}
if oneLevel then
sPtr := nil
else
sPtr := sPtr^.next;
end; {while}
{we only get here if a symbol was not found}
if class = allSpaces then begin
class := tagSpace;
goto 2;
end; {if}
FindSymbol := nil;
1:
if np <> nil then
dispose(np);
end; {FindSymbol}
procedure GenParameters {pp: parameterPtr};
{ Generate labels and space for the parameters }
{ }
{ parameters: }
{ pp - pointer to first parameter }
{ }
{ variables: }
{ lastParameterLLN - label number of last parameter }
{ lastParameterSize - size of last parameter }
var
i: 0..hashSize; {loop variable}
pln: integer; {label number}
size: integer; {size of the parameter}
sp: identPtr; {symbol pointer}
tk: tokenType; {symbol name token}
first: boolean; {first iteration of loop over params?}
begin {GenParameters}
first := true;
if pp <> nil then begin {prototyped parameters}
tk.kind := ident;
tk.numString := nil;
tk.class := identifier;
while pp <> nil do begin
pln := GetLocalLabel;
tk.name := pp^.parameter^.name;
tk.symbolPtr := nil;
sp := FindSymbol(tk, variableSpace, true, false);
if sp = nil then
sp := pp^.parameter;
if sp^.itype^.kind = arrayType then begin
size := cgPointerSize;
Gen3(dc_prm, pln, cgPointerSize, sp^.pdisp);
end {if}
else begin
size := long(sp^.itype^.size).lsw;
if (size = 1) and (sp^.itype^.kind = scalarType) then
size := 2;
if sp^.itype^.kind = scalarType then
if sp^.itype^.baseType in [cgReal,cgDouble,cgComp] then begin
{convert floating-point parameters to declared type}
Gen1t(pc_fix, pln, sp^.itype^.baseType);
size := cgExtendedSize;
end; {if}
Gen3(dc_prm, pln, size, sp^.pdisp);
end; {else}
sp^.pln := pln;
if first then begin
first := false;
lastParameterLLN := pln;
lastParameterSize := size;
end; {if}
pp := pp^.next;
end; {while}
end {if}
else begin {K&R parameters}
for i := 0 to hashSize do begin
sp := table^.buckets[i];
while sp <> nil do begin
if sp^.storage = parameter then begin
pln := GetLocalLabel;
sp^.pln := pln;
if sp^.itype^.kind = arrayType then begin
size := cgPointerSize;
Gen3(dc_prm, sp^.lln, cgPointerSize, sp^.pdisp);
end {if}
else begin
size := long(sp^.itype^.size).lsw;
if (size = 1) and (sp^.itype^.kind = scalarType) then
size := 2;
if sp^.itype^.kind = scalarType then
if sp^.itype^.baseType in [cgReal,cgDouble,cgComp] then begin
{convert floating-point parameters to declared type}
Gen1t(pc_fix, pln, sp^.itype^.baseType);
size := cgExtendedSize;
end; {if}
Gen3(dc_prm, sp^.lln, size, sp^.pdisp);
end; {else}
if first then begin
first := false;
lastParameterLLN := pln;
lastParameterSize := size;
end; {if}
end; {if}
sp := sp^.next;
end; {while}
end; {for}
if first then begin
lastParameterLLN := 0;
lastParameterSize := 0;
end; {if}
end; {else}
end; {GenParameters}
procedure GenSymbols {sym: symbolTablePtr; doGlobals: boolean};
{ generate a symbol table for the debugger }
{ }
{ parameters: }
{ sym - symbol table to generate }
{ doGlobals - include global symbols in the table }
{ }
{ outputs: }
{ symLength - length of debug symbol table }
const
noDisp = -1; {disp returned by GetTypeDisp if the type was not found}
type
tpPtr = ^tpRecord; {type list displacements}
tpRecord = record
next: tpPtr;
tp: typePtr;
disp: integer;
end;
var
i: 0..hashSize; {loop/index variable}
ip: identPtr; {used to trace identifier lists}
tpList,tp2: tpPtr; {type displacement list}
function GetTypeDisp (tp: typePtr): 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 noDisp 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 (ip: identPtr; storage: storageType);
{ Generate a single symbol or struct field }
{ }
{ parameters: }
{ ip - identifier to generate }
{ storage - storage type; none for struct/union fields }
var
disp: integer; {disp to symbol of same type}
tPtr: typePtr;
procedure WriteAddress (ip: identPtr);
{ Write the address and DP flag }
{ }
{ parameters: }
{ ip - identifier }
var
size: longint; {used to break apart longints}
begin {WriteAddress}
if storage in [external,global,private] then begin
RefName(ip^.name, 0, 4, 0);
CnOut(1);
end {if}
else if storage = none then begin
size := ip^.disp;
CnOut2(long(size).lsw);
CnOut2(long(size).msw);
CnOut(ord(ip^.next <> nil));
end {else if}
else begin
CnOut2(LabelToDisp(ip^.lln));
CnOut2(0);
CnOut(0);
end; {else}
end; {WriteAddress}
procedure WriteName (ip: identPtr);
{ Write the name field for an identifier }
{ }
{ parameters: }
{ ip - 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(ip^.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] := ip^.name^[j];
stringsize := stringsize+len+1;
end {if}
else
Error(60);
end; {WriteName}
procedure WriteScalarType (tp: typePtr; modifiers, subscripts: integer);
{ Write a scalar type and subscript 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 tp^.baseType of
cgByte: val := $40;
cgUByte: val := $00;
cgWord: if tp^.cType = ctBool then
val := $09
else
val := $01;
cgUWord: val := $41;
cgLong: val := $02;
cgULong: val := $42;
cgReal: val := $03;
cgDouble: val := $04;
cgComp: val := $0A;
cgExtended: val := $05;
cgQuad: val := $0A; {same as comp}
cgUQuad: val := $4A;
otherwise: val := $01;
end; {case}
CnOut(val | modifiers); {write the format byte}
CnOut2(subscripts); {write the # of subscripts}
end; {WriteScalarType}
procedure WritePointerType (tp: typePtr; subscripts: integer);
{ write a pointer type field }
{ }
{ parameters: }
{ tp - pointer type }
{ subscripts - number of subscript fields }
begin {WritePointerType}
tp := tp^.ptype;
while tp^.kind = definedType do
tp := tp^.dType;
case tp^.kind of
scalarType: WriteScalarType(tp, $80, subscripts);
enumType,
functionType: WriteScalarType(intPtr, $80, subscripts);
otherwise: begin
CnOut(11);
CnOut2(subscripts);
end;
end; {case}
end; {WritePointerType}
procedure ExpandPointerType (tp: typePtr); forward;
procedure ExpandStructType (tp: typePtr);
{ write the type entries for a struct or union }
{ }
{ parameters: }
{ tp - struct/union type }
var
ip: identPtr; {used to trace the field list}
begin {ExpandStructType}
ip := tp^.fieldList;
{ fieldList is nil if this is a forward declared struct. }
if ip = nil then ip := defaultStruct^.fieldList;
while ip <> nil do begin
if ip^.name^[1] <> '~' then
GenSymbol(ip, none);
ip := ip^.next;
end; {while}
end; {ExpandStructType}
procedure WriteArrays (tp: typePtr);
{ handle an array type }
{ }
{ parameters: }
{ tp - array type }
var
count: 0..maxint; {# of subscripts}
size: longint; {for converting long numbers}
tp2: typePtr; {used to trace array type list}
begin {WriteArrays}
count := 0; {count the subscripts}
tp2 := tp;
while tp2^.kind = arrayType do begin
count := count+1;
tp2 := tp2^.aType;
end; {while}
while tp2^.kind = definedType do
tp2 := tp2^.dType;
if tp2^.kind = scalarType then {write the type code}
if tp2^.baseType in [cgByte,cgUByte] then begin
count := count-1;
CnOut(6);
CnOut2(count);
end {if}
else
WriteScalarType(tp2, 0, count)
else if tp2^.kind = enumType then
WriteScalarType(intPtr, 0, count)
else if tp2^.kind = pointerType then
WritePointerType(tp2, count)
else begin
CnOut(12);
CnOut2(count);
end; {else if}
while count <> 0 do begin {write the subscript entries}
CnOut2(0); CnOut2(0);
if tp^.elements = 0 then
size := $00FFFFFF
else
size := tp^.elements-1;
CnOut2(long(size).lsw); CnOut2(long(size).msw);
size := tp^.aType^.size;
CnOut2(long(size).lsw); CnOut2(long(size).msw);
symLength := symLength+12;
tp := tp^.aType;
count := count-1;
end; {while}
if tp2^.kind = pointerType then {expand complex types}
ExpandPointerType(tp2)
else if tp2^.kind in [structtype,uniontype] then
ExpandStructType(tp2);
end; {WriteArrays}
procedure ExpandPointerType {tp: typePtr};
{ write the type entries for complex pointer types }
{ }
{ parameters: }
{ tp - pointer type }
var
disp: integer; {disp to symbol of same type}
begin {ExpandPointerType}
tp := tp^.ptype;
while tp^.kind = definedType do
tp := tp^.dType;
if tp^.kind in [pointerType,arrayType,structType,unionType] then
begin
symLength := symLength+12;
CnOut2(0); CnOut2(0);
CnOut2(0); CnOut2(0);
CnOut(0);
case tp^.kind of
pointerType: begin
WritePointerType(tp, 0);
ExpandPointerType(tp);
end;
arrayType: WriteArrays(tp);
structType,
unionType: begin
disp := GetTypeDisp(tp);
if disp = noDisp then begin
CnOut(12);
CnOut2(0);
ExpandStructType(tp);
end {if}
else begin
CnOut(13);
CnOut2(disp);
end; {else}
end;
end; {case}
end; {if}
end; {ExpandPointerType}
begin {GenSymbol}
tPtr := ip^.itype;
while tPtr^.kind = definedType do
tPtr := tPtr^.dType;
if tPtr^.kind in
[scalarType,arrayType,pointerType,enumType,structType,unionType]
then begin
symLength := symLength+12; {update length of symbol table}
WriteName(ip); {write the name field}
WriteAddress(ip); {write the address field}
case tPtr^.kind of
scalarType: WriteScalarType(tPtr, 0, 0);
enumType: WriteScalarType(intPtr, 0, 0);
pointerType: begin
WritePointerType(tPtr, 0);
ExpandPointerType(tPtr);
end;
arrayType: WriteArrays(tPtr);
structType,
unionType: begin
disp := GetTypeDisp(tPtr);
if disp = noDisp then begin
CnOut(12);
CnOut2(0);
ExpandStructType(tPtr);
end {if}
else begin
CnOut(13);
CnOut2(disp);
end; {else}
end;
end; {case}
end; {if}
end; {GenSymbol}
begin {GenSymbols}
tpList := nil; {no types so far}
if sym <> nil then
for i := 0 to hashSize do begin {loop over all hash buckets}
ip := sym^.buckets[i]; {trace through all symbols in this bucket}
while ip <> nil do begin
if ip^.storage <> none then
GenSymbol(ip, ip^.storage);
ip := ip^.next; {next symbol}
end; {while}
end; {for}
while tpList <> nil do begin {dispose of type list}
tp2 := tpList;
tpList := tp2^.next;
dispose(tp2);
end; {while}
if doGlobals then {do globals}
GenSymbols(globalTable, false);
end; {GenSymbols}
procedure InitSymbol;
{ Initialize the symbol table module }
var
i: 0..hashSize; {loop variable}
begin {InitSymbol}
staticNum := '~0000'; {no functions processed}
table := nil; {initialize the global symbol table}
tablePool := nil; {table pool is initially empty}
tablePoolSize := 0;
tablePoolMaxSize := ord(MaxBlock div 150000); {limit size of pool based on RAM}
PushTable;
globalTable := table;
globalTable^.isEmpty := false; {global table is never treated as empty}
functionTable := nil;
{declare base types}
new(sCharPtr); {signed char}
with sCharPtr^ do begin
size := cgByteSize;
saveDisp := 0;
qualifiers := [];
kind := scalarType;
baseType := cgByte;
cType := ctSChar;
end; {with}
new(charPtr); {char}
with charPtr^ do begin
size := cgByteSize;
saveDisp := 0;
qualifiers := [];
kind := scalarType;
baseType := cgUByte;
cType := ctChar;
end; {with}
new(uCharPtr); {unsigned char}
with uCharPtr^ do begin
size := cgByteSize;
saveDisp := 0;
qualifiers := [];
kind := scalarType;
baseType := cgUByte;
cType := ctUChar;
end; {with}
new(shortPtr); {short}
with shortPtr^ do begin
size := cgWordSize;
saveDisp := 0;
qualifiers := [];
kind := scalarType;
baseType := cgWord;
cType := ctShort;
end; {with}
new(uShortPtr); {unsigned short}
with uShortPtr^ do begin
size := cgWordSize;
saveDisp := 0;
qualifiers := [];
kind := scalarType;
baseType := cgUWord;
cType := ctUShort;
end; {with}
new(intPtr); {int}
with intPtr^ do begin
size := cgWordSize;
saveDisp := 0;
qualifiers := [];
kind := scalarType;
baseType := cgWord;
cType := ctInt;
end; {with}
new(uIntPtr); {unsigned int}
with uIntPtr^ do begin
size := cgWordSize;
saveDisp := 0;
qualifiers := [];
kind := scalarType;
baseType := cgUWord;
cType := ctUInt;
end; {with}
new(int32Ptr); {int (32-bit)}
with int32Ptr^ do begin
size := cgLongSize;
saveDisp := 0;
qualifiers := [];
kind := scalarType;
baseType := cgLong;
cType := ctInt32;
end; {with}
new(uInt32Ptr); {unsigned int (32-bit)}
with uInt32Ptr^ do begin
size := cgLongSize;
saveDisp := 0;
qualifiers := [];
kind := scalarType;
baseType := cgULong;
cType := ctUInt32;
end; {with}
new(longPtr); {long}
with longPtr^ do begin
size := cgLongSize;
saveDisp := 0;
qualifiers := [];
kind := scalarType;
baseType := cgLong;
cType := ctLong;
end; {with}
new(uLongPtr); {unsigned long}
with uLongPtr^ do begin
size := cgLongSize;
saveDisp := 0;
qualifiers := [];
kind := scalarType;
baseType := cgULong;
cType := ctULong;
end; {with}
new(longLongPtr); {long long}
with longLongPtr^ do begin
size := cgQuadSize;
saveDisp := 0;
qualifiers := [];
kind := scalarType;
baseType := cgQuad;
cType := ctLongLong;
end; {with}
new(uLongLongPtr); {unsigned long long}
with uLongLongPtr^ do begin
size := cgQuadSize;
saveDisp := 0;
qualifiers := [];
kind := scalarType;
baseType := cgUQuad;
cType := ctULongLong;
end; {with}
new(floatPtr); {real}
with floatPtr^ do begin
size := cgRealSize;
saveDisp := 0;
qualifiers := [];
kind := scalarType;
baseType := cgReal;
cType := ctFloat;
end; {with}
new(doublePtr); {double}
with doublePtr^ do begin
size := cgDoubleSize;
saveDisp := 0;
qualifiers := [];
kind := scalarType;
baseType := cgDouble;
cType := ctDouble;
end; {with}
new(compPtr); {comp}
with compPtr^ do begin
size := cgCompSize;
saveDisp := 0;
qualifiers := [];
kind := scalarType;
baseType := cgComp;
cType := ctComp;
end; {with}
new(extendedPtr); {extended, aka long double}
with extendedPtr^ do begin
size := cgExtendedSize;
saveDisp := 0;
qualifiers := [];
kind := scalarType;
baseType := cgExtended;
cType := ctLongDouble;
end; {with}
new(boolPtr); {_Bool}
with boolPtr^ do begin
size := cgWordSize;
saveDisp := 0;
qualifiers := [];
kind := scalarType;
baseType := cgWord;
cType := ctBool;
end; {with}
new(stringTypePtr); {string constant type}
with stringTypePtr^ do begin
size := 0;
saveDisp := 0;
qualifiers := [];
kind := arrayType;
aType := charPtr;
elements := 0;
end; {with}
new(utf16StringTypePtr); {UTF-16 string constant type}
with utf16StringTypePtr^ do begin
size := 0;
saveDisp := 0;
qualifiers := [];
kind := arrayType;
aType := uShortPtr;
elements := 0;
end; {with}
new(utf32StringTypePtr); {UTF-32 string constant type}
with utf32StringTypePtr^ do begin
size := 0;
saveDisp := 0;
qualifiers := [];
kind := arrayType;
aType := uLongPtr;
elements := 0;
end; {with}
new(voidPtr); {void}
with voidPtr^ do begin
size := 0;
saveDisp := 0;
qualifiers := [];
kind := scalarType;
baseType := cgVoid;
cType := ctVoid;
end; {with}
new(voidPtrPtr); {typeless pointer}
with voidPtrPtr^ do begin
size := cgPointerSize;
saveDisp := 0;
qualifiers := [];
kind := pointerType;
pType := voidPtr;
end; {with}
new(charPtrPtr); {char *}
with charPtrPtr^ do begin
size := cgPointerSize;
saveDisp := 0;
qualifiers := [];
kind := pointerType;
pType := charPtr;
end; {with}
new(vaInfoPtr); {internal varargs info type (char*[2])}
with vaInfoPtr^ do begin
size := cgPointerSize*2;
saveDisp := 0;
qualifiers := [];
kind := arrayType;
aType := charPtrPtr;
elements := 2;
end; {with}
new(defaultStruct); {default structure}
with defaultStruct^ do begin {(for structures with errors)}
size := cgWordSize;
saveDisp := 0;
qualifiers := [];
kind := structType;
sName := nil;
constMember := false;
flexibleArrayMember := false;
new(fieldList);
with fieldlist^ do begin
next := nil;
name := @'field';
itype := intPtr;
class := ident;
state := declared;
disp := 0;
bitdisp := 0;
end; {with}
end; {with}
new(constCharPtr); {const char}
constCharPtr^ := charPtr^;
constCharPtr^.qualifiers := [tqConst];
end; {InitSymbol}
function IsVoid {tp: typePtr): boolean};
{ Check to see if a type is void }
{ }
{ Parameters: }
{ tp - type to check }
{ }
{ Returns: True if the type is void, else false }
begin {IsVoid}
IsVoid := false;
if tp = voidPtr then
IsVoid := true
else if tp^.kind = scalarType then
if tp^.baseType = cgVoid then
IsVoid := true;
end; {IsVoid}
function CopyType (tp: typePtr): typePtr;
{ Make a new copy of a type, so it can be modified. }
{ }
{ Parameters: }
{ tp - type to copy }
{ }
{ Returns: The new copy of the type }
var
tType: typePtr; {the new copy of the type}
p1,p2: parameterPtr; {parameter ptrs for copying prototypes}
pPtr: ^parameterPtr; {temp for copying prototypes}
begin {CopyType}
if tp^.kind in [structType,unionType] then
Error(57);
tType := pointer(Malloc(sizeof(typeRecord)));
tType^ := tp^; {copy type record}
tType^.saveDisp := 0;
if tp^.kind = functionType then {copy prototype parameter list}
if tp^.prototyped then begin
p1 := tp^.parameterList;
pPtr := @tType^.parameterList;
while p1 <> nil do begin
p2 := pointer(Malloc(sizeof(parameterRecord)));
p2^ := p1^;
pPtr^ := p2;
pPtr := @p2^.next;
p1 := p1^.next;
end; {while}
end; {if}
CopyType := tType;
end; {CopyType}
function MakeCompositeType {t1, t2: typePtr): typePtr};
{ Make the composite type of two compatible types. }
{ See C17 section 6.2.7. }
{ }
{ parameters: }
{ t1,t2 - the input types (should be compatible) }
{ }
{ returns: pointer to the composite type }
var
compType: typePtr; {the composite type}
tType: typePtr; {temp type}
p1,p2: parameterPtr; {parameter ptrs for handling prototypes}
begin {MakeCompositeType}
compType := t2; {default to t2}
if t1 <> t2 then
if t1^.kind = t2^.kind then begin
if t2^.kind = functionType then {switch fn types if only t1 is prototyped}
if not t2^.prototyped then
if t1^.prototyped then begin
compType := t1;
t1 := t2;
t2 := compType;
end; {if}
{apply recursively for derived types}
if t2^.kind in [arrayType,pointerType,functionType] then begin
tType := MakeCompositeType(t1^.aType,t2^.aType);
if tType <> t2^.aType then begin
compType := CopyType(compType);
compType^.aType := tType;
end; {if}
end; {if}
if t2^.kind = arrayType then {get array size from t1 if needed}
if t2^.size = 0 then
if t1^.size <> 0 then
if t1^.aType^.size = t2^.aType^.size then begin
if compType = t2 then
compType := CopyType(t2);
CompType^.size := t1^.size;
CompType^.elements := t1^.elements;
end; {if}
if t2^.kind = functionType then {compose function parameter types}
if t1^.prototyped and t2^.prototyped then begin
if compType = t2 then
compType := CopyType(t2);
p1 := t1^.parameterList;
p2 := compType^.parameterList;
while (p1 <> nil) and (p2 <> nil) do begin
p2^.parameterType :=
MakeCompositeType(p1^.parameterType,p2^.parameterType);
p1 := p1^.next;
p2 := p2^.next;
end; {while}
end;
end; {if}
MakeCompositeType := compType;
end; {MakeCompositeType}
function MakePascalType {origType: typePtr): typePtr};
{ make a version of a type with the pascal qualifier applied }
{ }
{ parameters: }
{ origType - the original type }
{ }
{ returns: pointer to the pascal-qualified type }
var
pascalType: typePtr; {the modified type}
tp,tp2: typePtr; {work pointers}
p1,p2,p3: parameterPtr; {for reversing prototyped parameters}
begin {MakePascalType}
pascalType := pointer(Malloc(sizeof(typeRecord)));
pascalType^ := origType^;
MakePascalType := pascalType;
tp := pascalType;
while tp <> nil do
case tp^.kind of
arrayType,
pointerType: begin
tp2 := pointer(Malloc(sizeof(typeRecord)));
tp2^ := tp^.pType^;
tp^.pType := tp2;
tp := tp2;
end;
functionType: begin
if not tp^.isPascal then begin
{reverse the parameter list}
p1 := tp^.parameterList;
if p1 <> nil then begin
p2 := nil;
while p1 <> nil do begin
p3 := pointer(Malloc(sizeof(parameterRecord)));
p3^ := p1^;
p1 := p1^.next;
p3^.next := p2;
p2 := p3;
end; {while}
tp^.parameterList := p2;
end; {if}
tp^.isPascal := true;
end; {if}
tp := nil;
end;
otherwise: begin
Error(94);
MakePascalType := origType;
tp := nil;
end;
end; {case}
end; {MakePascalType}
function MakePointerTo {pType: typePtr): typePtr};
{ make a pointer type }
{ }
{ parameters: }
{ pType - the type pointed to }
{ }
{ returns: the pointer type }
var
tp: typePtr; {the pointer type}
begin {MakePointerTo}
tp := pointer(Malloc(sizeof(typeRecord)));
tp^.size := cgPointerSize;
tp^.saveDisp := 0;
tp^.qualifiers := [];
tp^.kind := pointerType;
tp^.pType := pType;
MakePointerTo := tp;
end; {MakePointerTo}
function MakeQualifiedType {origType: typePtr; qualifiers: typeQualifierSet):
typePtr};
{ make a qualified version of a type }
{ }
{ parameters: }
{ origType - the original type }
{ qualifiers - the type qualifier(s) to add }
{ }
{ returns: pointer to the qualified type }
var
tp: typePtr; {the qualified type}
elemType: typePtr; {array element type}
begin {MakeQualifiedType}
if qualifiers <> [] then begin {make qualified version of type}
tp := pointer(Malloc(sizeof(typeRecord)));
if origType^.kind in [structType,unionType] then begin
tp^.size := origType^.size;
tp^.kind := definedType;
tp^.dType := origType;
tp^.saveDisp := 0;
tp^.qualifiers := qualifiers;
end {if}
else begin
tp^ := origType^;
tp^.qualifiers := tp^.qualifiers + qualifiers;
end; {else}
MakeQualifiedType := tp;
{move array type quals to element type}
while tp^.kind = arrayType do begin
elemType := pointer(Malloc(sizeof(typeRecord)));
if tp^.aType^.kind in [structType,unionType] then begin
elemType^.size := tp^.aType^.size;
elemType^.kind := definedType;
elemType^.dType := tp^.aType;
elemType^.saveDisp := 0;
elemType^.qualifiers := qualifiers;
end {if}
else begin
elemType^ := tp^.aType^;
elemType^.qualifiers := elemType^.qualifiers + qualifiers;
end; {else}
tp^.aType := elemType;
tp^.qualifiers := []; {remove for C23}
tp := elemType;
end; {if}
end {if}
else
MakeQualifiedType := origType;
end; {MakeQualifiedType}
function Unqualify {tp: typePtr): typePtr};
{ returns the unqualified version of a type }
{ }
{ parameters: }
{ tp - the original type }
{ }
{ returns: pointer to the unqualified type }
var
tp2: typePtr; {unqualified type}
begin {Unqualify}
while tp^.kind = definedType do
tp := tp^.dType;
Unqualify := tp;
if tp^.qualifiers <> [] then
if not (tp^.kind in [structType,unionType]) then begin
tp2 := pointer(Malloc(sizeof(typeRecord)));
tp2^ := tp^;
tp2^.qualifiers := [];
Unqualify := tp2;
end;
end; {Unqualify}
function NewSymbol {name: stringPtr; itype: typePtr; class: tokenEnum;
space: spaceType; state: stateKind; isInline: boolean):
identPtr};
{ insert a new symbol in the symbol table }
{ }
{ parameters: }
{ name - pointer to the symbol name }
{ itype - pointer to the symbol type }
{ class - storage class }
{ space - the kind of variable space to put the }
{ identifier in }
{ state - variable declaration state }
{ }
{ returns: pointer to the inserted symbol }
var
cs: identPtr; {current symbol}
hashPtr: ^identPtr; {pointer to hash bucket in symbol table}
i: integer; {loop variable}
isFunction: boolean; {is this the symbol for a function?}
isGlobal: boolean; {are we using the global table?}
lUseGlobalPool: boolean; {use the global symbol pool?}
needSymbol: boolean; {do we need to declare it?}
np: stringPtr; {for forming static name}
p: identPtr; {work pointer}
tk: tokenType; {fake token; for FindSymbol}
procedure AllocateStaticNum;
{ Allocate a staticNum value for the current table. }
var
done: boolean; {loop termination}
i: integer; {loop index}
begin {AllocateStaticNum}
i := 5; {increment the static var number}
repeat
staticNum[i] := succ(staticNum[i]);
done := staticNum[i] <> succ('9');
if not done then begin
staticNum[i] := '0';
i := i-1;
done := i = 1;
end; {if}
until done;
table^.staticNum := staticNum; {record the static symbol table number}
end; {AllocateStaticNum}
procedure UnInline;
{ Generate a non-inline definition for a function previously }
{ defined with an (apparent) inline definition. }
var
fName: stringPtr; {name of function}
i: integer; {loop variable}
begin {UnInline}
if cs^.iType^.isPascal then begin
fName := pointer(Malloc(length(name^)+1));
CopyString(pointer(fName), pointer(name));
for i := 1 to length(fName^) do
if fName^[i] in ['a'..'z'] then
fName^[i] := chr(ord(fName^[i]) & $5F);
end {if}
else
fName := name;
Gen2Name(dc_str, 0, 0, fName);
code^.s := m_jml;
code^.q := 0;
code^.r := ord(longabsolute);
new(code^.lab);
code^.lab^ := concat('~inline~',name^);
Gen0(pc_nat);
Gen0(dc_enp);
end; {UnInline}
begin {NewSymbol}
needSymbol := true; {assume we need a symbol}
isGlobal := false; {set up defaults}
isFunction := false;
lUseGlobalPool := useGlobalPool;
tk.name := name;
tk.symbolPtr := nil;
if space <> fieldListSpace then begin {are we defining a function?}
if (itype <> nil) and (itype^.kind = functionType) then begin
isFunction := true;
if class in [autosy, ident] then
class := externsy
else {If explicit storage class is given,}
isInline := false; {this is not an inline definition. }
end {if}
else if (itype <> nil) and (itype^.kind in [structType,unionType])
and (itype^.fieldList = nil) and doingParameters then begin
useGlobalPool := true;
end; {else if}
cs := FindSymbol(tk, space, true, true); {check for duplicates}
if cs <> nil then begin
if ((itype = nil)
or (cs^.itype = nil)
or (not CompTypes(cs^.itype, itype))
or ((cs^.state = initialized) and (state = initialized))
or ((class = typedefsy) <> (cs^.class = typedefsy))
or ((globalTable <> table)
and (not (class in [externsy,typedefsy])
or not (cs^.class in [externsy,typedefsy]))))
and ((not doingParameters) or (cs^.state <> declared))
then
Error(42)
else begin
itype := MakeCompositeType(cs^.itype, itype);
if class = externsy then
if cs^.class = staticsy then
class := staticsy;
if cs^.storage = external then
if isInline then
isInline := cs^.inlineDefinition
else if cs^.inlineDefinition then
if iType^.kind = functionType then
if cs^.state = defined then
if table = globalTable then
UnInline;
p := cs;
needSymbol := false;
end; {else}
end {if}
else if class = externsy then {check for outer decl of same object/fn}
if table <> globalTable then begin
cs := FindSymbol(tk, space, false, true);
if cs <> nil then
if cs^.name^[1] <> '~' then {exclude block-scope statics}
if cs^.storage in [global,external,private] then begin
if not CompTypes(cs^.itype, itype) then
Error(47);
itype := MakeCompositeType(cs^.itype, itype);
end; {if}
end; {if}
end; {if}
if needSymbol then begin
if class = staticsy then {statics go in the global symbol table}
if not isFunction then
if globalTable <> table then begin
isGlobal := true; {note that we will use the global table}
useGlobalPool := true;
if table^.noStatics then begin
table^.noStatics := false;
AllocateStaticNum;
end; {if}
np := pointer(GMalloc(length(name^)+6)); {form static name}
np^[0] := chr(5+length(name^));
for i := 1 to 5 do
np^[i] := table^.staticNum[i];
for i := 1 to length(name^) do
np^[i+5] := name^[i];
name := np;
end; {if}
p := pointer(Calloc(sizeof(identRecord))); {get space for the record}
{p^.iPtr := nil;} {no initializers, yet}
{p^.saved := 0;} {not saved}
p^.state := state; {set the state}
{p^.isForwardDeclared := false;} {assume no forward declarations are used}
p^.name := name; {record the name}
{p^.next := nil;}
{p^.used := false;} {unused for now}
if space <> fieldListSpace then {insert the symbol in the hash bucket}
begin
if (itype = nil) or not isGlobal then begin
hashPtr := pointer(ord4(table)+Hash(name));
table^.isEmpty := false;
end {if}
else
hashPtr := pointer(ord4(globalTable)+Hash(name));
if space = tagSpace then
hashPtr := pointer(ord4(hashPtr) + 4*(hashSize+1));
p^.next := hashPtr^;
hashPtr^ := p;
end; {if}
end; {if}
if space = fieldListSpace then {check and set the storage class}
p^.storage := none
else if class in [autosy,registersy] then
begin
if doingFunction or doingParameters then begin
p^.storage := stackFrame;
class := ident;
end {if}
else begin
p^.storage := global;
Error(62);
end; {else}
end {if}
else if class = ident then begin
if doingFunction then begin
p^.storage := stackFrame;
class := autosy;
end {if}
else
p^.storage := global;
end {else if}
else if class = externsy then begin
p^.storage := external;
p^.inlineDefinition := isInline;
end {else if}
else if class = staticsy then
p^.storage := private
else
p^.storage := none;
p^.class := class;
p^.itype := itype; {set the symbol field values}
NewSymbol := p; {return a pointer to the new entry}
useGlobalPool := lUseGlobalPool; {restore the useGlobalPool variable}
end; {NewSymbol}
procedure PopTable;
{ Pop a symbol table (remove definitions local to a block) }
var
tPtr: symbolTablePtr; {work pointer}
begin {PopTable}
tPtr := table;
{if printSymbols then {debug}
{ PrintTable(tPtr); {debug}
if (lint & lintUnused) <> 0 then
CheckUnused(tPtr);
if tPtr^.next <> nil then begin
table := table^.next;
if not tPtr^.isEmpty then begin
dispose(tPtr);
if token.kind = ident then
if FindSymbol(token,variableSpace,false,false) <> nil then
if token.symbolPtr^.class = typedefsy then
token.kind := typedef;
end {if}
else if (tablePoolSize = tablePoolMaxSize) then
dispose(tPtr)
else begin
tPtr^.next := tablePool;
tablePool := tPtr;
tablePoolSize := tablePoolSize + 1;
end; {else}
end; {if}
end; {PopTable}
{ copy 'symbol.print'} {debug}
procedure PushTable;
{ Create a new symbol table, pushing the old one }
var
tPtr: symbolTablePtr; {work pointer}
begin {PushTable}
if tablePool <> nil then begin {use existing empty table if available}
tPtr := tablePool;
tablePool := tPtr^.next;
tablePoolSize := tablePoolSize - 1;
end {if}
else begin
new(tPtr); {...or create a new symbol table}
ClearTable(tPtr^);
tPtr^.isEmpty := true;
end; {else}
tPtr^.next := table;
table := tPtr;
tPtr^.noStatics := true;
end; {PushTable}
procedure ResolveForwardReference {iPtr: identPtr};
{ resolve a forward reference }
{ }
{ parameters: }
{ iPtr - ptr to the forward declared identifier }
var
fl: identPtr; {for tracing field lists}
ltk: tokenType; {for searching for forward refs}
sym: identPtr; {for finding forward refs}
lPtr,tPtr: typePtr; {for tracing forward declared types}
begin {ResolveForwardReference}
iPtr^.isForwardDeclared := false; {we will succeed or flag an error...}
tPtr := iPtr^.itype; {skip to the struct/union type}
lPtr := nil;
while tPtr^.kind in [pointerType,arrayType,functionType,definedType] do begin
lPtr := tPtr;
tPtr := tPtr^.pType;
end;
if tPtr^.sName <> nil then begin {resolve the forward reference}
ltk.name := tPtr^.sName;
ltk.symbolPtr := nil;
sym := FindSymbol(ltk,tagSpace,false,true);
if sym <> nil then begin
if sym^.itype^.kind <> tPtr^.kind then
Error(107)
else begin
if sym^.itype = tPtr then
tPtr^.sName := nil
else begin
tPtr := sym^.itype;
if lPtr <> nil then
lPtr^.ptype := tPtr;
end; {else}
end; {else}
end; {if}
end; {if}
if lPtr <> nil then
tPtr := lPtr^.pType; {check the field list for other fwd refs}
while tPtr^.kind in [pointerType,arrayType,functionType,definedType] do
tPtr := tPtr^.pType;
if tPtr^.kind in [structType,unionType] then begin
fl := tPtr^.fieldList;
while fl <> nil do begin
if fl^.isForwardDeclared then
ResolveForwardReference(fl);
fl := fl^.next;
end; {while}
end; {if}
end; {ResolveForwardReference}
function StringType{prefix: charStrPrefixEnum): typePtr};
{ returns the type of a string literal with specified prefix }
{ }
{ parameters: }
{ prefix - the prefix }
begin {StringType}
if prefix in [prefix_none,prefix_u8] then
StringType := stringTypePtr
else if prefix in [prefix_u16,prefix_L] then
StringType := utf16StringTypePtr
else
StringType := utf32StringTypePtr;
end; {StringType}
end.
{$append 'symbol.asm'}
Reference in New Issue View Git Blame Copy Permalink