mirror of
https://github.com/byteworksinc/ORCA-C.git
synced 2024-12-28 16:30:59 +00:00
e5c7aebb3f
When the lint check for undefined variables was enabled, a "lint: unused variable: @struct" would be produced for any function returning a struct or union, due to the special static variable that is created to hold the return value. That spurious lint message is now suppressed.
2606 lines
88 KiB
ObjectPascal
2606 lines
88 KiB
ObjectPascal
{$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;
|
|
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
|
|
if not (ip^.name^[staticNumLen+1] in ['~','@']) 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'}
|