mirror of
https://github.com/byteworksinc/ORCA-C.git
synced 2024-10-31 17:04:42 +00:00
8077a248a4
This gives a clearer pattern of matching ORCA/C's historical behavior if loose type checks are used, and the documentation is updated accordingly. It also avoids breaking existing code that may be relying on the old behavior. I am aware of at least one place that does (conflicting declarations of InstallNetDriver in GNO's <gno/gno.h>).
1946 lines
65 KiB
ObjectPascal
1946 lines
65 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: }
|
|
{ }
|
|
{ noDeclarations - have we declared anything at this level? }
|
|
{ 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 }
|
|
{ stringTypePtr - pointer to the base type for string }
|
|
{ constants }
|
|
{ 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'}
|
|
|
|
{---------------------------------------------------------------}
|
|
|
|
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}
|
|
staticNum: packed array[1..6] of char; {staticNum at start of table}
|
|
end;
|
|
|
|
var
|
|
noDeclarations: boolean; {have we declared anything at this level?}
|
|
table: symbolTablePtr; {current symbol table}
|
|
globalTable: symbolTablePtr; {global symbol table}
|
|
functionTable: symbolTablePtr; {table for top level of current function}
|
|
|
|
{base types}
|
|
charPtr,sCharPtr,uCharPtr,shortPtr,uShortPtr,intPtr,uIntPtr,int32Ptr,
|
|
uInt32Ptr,longPtr,uLongPtr,longLongPtr,uLongLongPtr,boolPtr,
|
|
floatPtr,doublePtr,compPtr,extendedPtr,stringTypePtr,voidPtr,
|
|
voidPtrPtr,constCharPtr,defaultStruct: typePtr;
|
|
|
|
{---------------------------------------------------------------}
|
|
|
|
procedure CheckStaticFunctions;
|
|
|
|
{ check for undefined functions }
|
|
|
|
|
|
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 }
|
|
|
|
|
|
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 LabelToDisp (lab: integer): integer; extern;
|
|
|
|
{ convert a local label number to a stack frame displacement }
|
|
{ }
|
|
{ parameters: }
|
|
{ lab - label number }
|
|
|
|
|
|
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): 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 }
|
|
|
|
{---------------------------------------------------------------}
|
|
|
|
implementation
|
|
|
|
var
|
|
staticNum, {static variable number}
|
|
firstStaticNum: packed array[1..6] of char; {staticNum at start of function}
|
|
|
|
{- Imported from expression.pas --------------------------------}
|
|
|
|
procedure GenerateCode (tree: tokenPtr); extern;
|
|
|
|
{ generate code from a fully formed expression tree }
|
|
{ }
|
|
{ parameters: }
|
|
{ tree - top of the expression tree to generate code from }
|
|
{ }
|
|
{ variables: }
|
|
{ expressionType - result type of the expression }
|
|
|
|
|
|
function UsualUnaryConversions: baseTypeEnum; extern;
|
|
|
|
{ performs the usual unary conversions }
|
|
{ }
|
|
{ inputs: }
|
|
{ expressionType - type of the operand }
|
|
{ }
|
|
{ result: }
|
|
{ The base type of the operation to perform is returned. }
|
|
{ Any conversion code necessary has been generated. }
|
|
{ }
|
|
{ outputs: }
|
|
{ expressionType - set to result type }
|
|
|
|
{---------------------------------------------------------------}
|
|
|
|
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 }
|
|
|
|
{---------------------------------------------------------------}
|
|
|
|
procedure ClearTable (table: symbolTable); extern;
|
|
|
|
{ clear the symbol table to all zeros }
|
|
|
|
{---------------------------------------------------------------}
|
|
|
|
|
|
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 begin
|
|
numErrors := numErrors+1;
|
|
new(msg);
|
|
msg^ := concat('The static function ', sp^.name^,
|
|
' was not 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}
|
|
|
|
|
|
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)}
|
|
p1, p2: parameterPtr; {for tracing parameter lists}
|
|
pt1,pt2: typePtr; {pointer types}
|
|
|
|
|
|
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}
|
|
|
|
|
|
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 := cgLongSize;
|
|
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 := cgLongSize;
|
|
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 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 ';
|
|
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);
|
|
ip := sp^.iPtr;
|
|
while ip <> nil do begin
|
|
case ip^.itype of
|
|
cgByte,cgUByte,cgWord,cgUWord: begin
|
|
lval := ip^.ival;
|
|
Gen2t(dc_cns, long(lval).lsw, ip^.count, ip^.itype);
|
|
end;
|
|
cgLong,cgULong:
|
|
GenL1(dc_cns, ip^.ival, ip^.count);
|
|
cgQuad,cgUQuad:
|
|
GenQ1(dc_cns, ip^.qval, ip^.count);
|
|
cgReal,cgDouble,cgComp,cgExtended:
|
|
GenR1t(dc_cns, ip^.rval, ip^.count, ip^.itype);
|
|
cgString:
|
|
GenS(dc_cns, ip^.sval);
|
|
ccPointer: begin
|
|
code^.optype := ccPointer;
|
|
code^.r := ord(ip^.pPlus);
|
|
code^.q := ip^.count;
|
|
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}
|
|
ip := ip^.next;
|
|
end; {while}
|
|
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^.itype of
|
|
cgByte,cgUByte,cgWord,cgUWord: begin
|
|
lval := ip^.ival;
|
|
Gen2t(dc_cns, long(lval).lsw, 1, ip^.itype);
|
|
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^.itype);
|
|
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}
|
|
|
|
{these segments are not dynamic!}
|
|
segmentKind := 0;
|
|
|
|
{declare the ~globals segment, which holds non-array data types}
|
|
if smallMemoryModel then
|
|
currentSegment := ' '
|
|
else
|
|
currentSegment := '~GLOBALS ';
|
|
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;
|
|
|
|
var
|
|
doTagSpace: boolean; {do we still need to do the tags?}
|
|
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}
|
|
match: boolean; {for comparing substrings}
|
|
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}
|
|
sPtr := table; {initialize the address of the sym. tbl}
|
|
FindSymbol := nil; {assume we won't find it}
|
|
np := nil; {no string buffer, yet}
|
|
|
|
{check for the variable}
|
|
while sPtr <> nil do begin
|
|
iHandle := pointer(hashDisp+ord4(sPtr));
|
|
if class = tagSpace then
|
|
iHandle := pointer(ord4(iHandle) + (hashSize+1)*4);
|
|
doTagSpace := class = allSpaces;
|
|
iPtr := iHandle^;
|
|
if iPtr = nil then
|
|
if doTagSpace then begin
|
|
iHandle := pointer(ord4(iHandle) + (hashSize+1)*4);
|
|
iPtr := iHandle^;
|
|
doTagSpace := false;
|
|
end; {if}
|
|
|
|
{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;
|
|
if iPtr = nil then
|
|
if doTagSpace then begin
|
|
iHandle := pointer(ord4(iHandle) + (hashSize+1)*4);
|
|
iPtr := iHandle^;
|
|
doTagSpace := false;
|
|
end; {if}
|
|
end; {while}
|
|
|
|
{rescan for a static variable}
|
|
if staticAllowed 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}
|
|
|
|
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 }
|
|
|
|
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}
|
|
|
|
begin {GenParameters}
|
|
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
|
|
Gen3(dc_prm, pln, cgPointerSize, sp^.pdisp)
|
|
else begin
|
|
size := long(sp^.itype^.size).lsw;
|
|
if (size = 1) and (sp^.itype^.kind = scalarType) then
|
|
size := 2;
|
|
Gen3(dc_prm, pln, size, sp^.pdisp);
|
|
end; {else}
|
|
sp^.pln := pln;
|
|
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
|
|
sp^.pln := GetLocalLabel;
|
|
if sp^.itype^.kind = arrayType then
|
|
Gen3(dc_prm, sp^.lln, cgPointerSize, sp^.pdisp)
|
|
else begin
|
|
size := long(sp^.itype^.size).lsw;
|
|
if (size = 1) and (sp^.itype^.kind = scalarType) then
|
|
size := 2;
|
|
Gen3(dc_prm, sp^.lln, size, sp^.pdisp);
|
|
end; {else}
|
|
end; {if}
|
|
sp := sp^.next;
|
|
end; {while}
|
|
end; {for}
|
|
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
|
|
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}
|
|
PushTable;
|
|
globalTable := table;
|
|
noDeclarations := false;
|
|
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 := 1;
|
|
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 := 4;
|
|
saveDisp := 0;
|
|
qualifiers := [];
|
|
kind := pointerType;
|
|
pType := voidPtr;
|
|
end; {with}
|
|
new(defaultStruct); {default structure}
|
|
with defaultStruct^ do begin {(for structures with errors)}
|
|
size := cgWordSize;
|
|
saveDisp := 0;
|
|
qualifiers := [];
|
|
kind := structType;
|
|
sName := nil;
|
|
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 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): 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}
|
|
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}
|
|
|
|
begin {NewSymbol}
|
|
needSymbol := true; {assume we need a symbol}
|
|
cs := nil; {no current symbol found}
|
|
isGlobal := false; {set up defaults}
|
|
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
|
|
isGlobal := true;
|
|
useGlobalPool := true;
|
|
if class in [autosy, ident] then
|
|
class := externsy;
|
|
if not lUseGlobalPool then begin
|
|
np := pointer(Malloc(length(name^)+1));
|
|
CopyString(pointer(np), pointer(name));
|
|
tk.name := np;
|
|
name := np;
|
|
end; {if}
|
|
cs := FindSymbol(tk, space, false, true);
|
|
if cs <> nil then begin
|
|
if cs^.state = defined then
|
|
if state = defined then
|
|
Error(42);
|
|
p := cs;
|
|
needSymbol := false;
|
|
if not itype^.prototyped then begin
|
|
itype^.prototyped := cs^.itype^.prototyped;
|
|
itype^.parameterList := cs^.itype^.parameterList;
|
|
end; {if}
|
|
end; {if}
|
|
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}
|
|
if noDeclarations then begin {if we need a symbol table, create it}
|
|
if not isGlobal then
|
|
noDeclarations := false;
|
|
end {if}
|
|
else begin {check for duplicates}
|
|
cs := FindSymbol(tk, space, true, false);
|
|
if cs <> nil then begin
|
|
if (not CompTypes(cs^.itype, itype))
|
|
or ((cs^.state = initialized) and (state = initialized))
|
|
or (globalTable <> table) then
|
|
if (not doingParameters) or (cs^.state <> declared) then
|
|
Error(42);
|
|
p := cs;
|
|
needSymbol := false;
|
|
end; {if}
|
|
end; {else}
|
|
end; {if}
|
|
if class = staticsy then {statics go in the global symbol table}
|
|
if not isGLobal then
|
|
if globalTable <> table then begin
|
|
cs := FindSymbol(tk, space, true, true);
|
|
if cs <> nil then begin {check for duplicates}
|
|
if (not CompTypes(cs^.itype, itype))
|
|
or ((cs^.state = defined) and (state <> initialized))
|
|
or (cs^.state = initialized) then
|
|
Error(42);
|
|
p := cs;
|
|
needSymbol := false;
|
|
end; {if}
|
|
isGlobal := true; {note that we will use the global table}
|
|
useGlobalPool := true;
|
|
np := pointer(GMalloc(length(name^)+6));
|
|
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}
|
|
if needSymbol then begin
|
|
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}
|
|
if space <> fieldListSpace then {insert the symbol in the hash bucket}
|
|
begin
|
|
if itype = nil then
|
|
hashPtr := pointer(ord4(table)+Hash(name))
|
|
else if isGlobal then
|
|
hashPtr := pointer(ord4(globalTable)+Hash(name))
|
|
else
|
|
hashPtr := pointer(ord4(table)+Hash(name));
|
|
if space = tagSpace then
|
|
hashPtr := pointer(ord4(hashPtr) + 4*(hashSize+1));
|
|
p^.next := hashPtr^;
|
|
hashPtr^ := p;
|
|
end {if}
|
|
else
|
|
p^.next := nil;
|
|
end; {if}
|
|
if class in [autosy,registersy] then {check and set the storage class}
|
|
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
|
|
p^.storage := external
|
|
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 tPtr^.next <> nil then begin
|
|
table := table^.next;
|
|
dispose(tPtr);
|
|
end; {if}
|
|
end; {PopTable}
|
|
|
|
|
|
{ copy 'symbol.print'} {debug}
|
|
|
|
|
|
procedure PushTable;
|
|
|
|
{ Create a new symbol table, pushing the old one }
|
|
|
|
var
|
|
done: boolean; {loop termination}
|
|
i: integer; {loop index}
|
|
tPtr: symbolTablePtr; {work pointer}
|
|
|
|
begin {PushTable}
|
|
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;
|
|
if table = globalTable then {update fistStaticNum}
|
|
firstStaticNum := staticNum;
|
|
new(tPtr); {create a new symbol table}
|
|
ClearTable(tPtr^);
|
|
tPtr^.next := table;
|
|
table := tPtr;
|
|
tPtr^.staticNum := staticNum; {record the static symbol table number}
|
|
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}
|
|
|
|
end.
|
|
|
|
{$append 'symbol.asm'}
|