mirror of
https://github.com/byteworksinc/ORCA-C.git
synced 2024-11-15 07:06:05 +00:00
05ecf5eef3
This differs from the usual ORCA/C behavior of treating all floating-point parameters as extended. With the option enabled, they will still be passed in the extended format, but will be converted to their declared type at the start of the function. This is needed for strict standards conformance, because you should be able to take the address of a parameter and get a usable pointer to its declared type. The difference in types can also affect the behavior of _Generic expressions. The implementation of this is based on ORCA/Pascal, which already did the same thing (unconditionally) with real/double/comp parameters.
2273 lines
78 KiB
ObjectPascal
2273 lines
78 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 }
|
|
{ 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'}
|
|
|
|
{---------------------------------------------------------------}
|
|
|
|
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}
|
|
|
|
{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 }
|
|
|
|
|
|
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): 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
|
|
|
|
var
|
|
staticNum: packed array[1..6] of char; {static variable number}
|
|
|
|
{- 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}
|
|
|
|
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 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 }
|
|
{ }
|
|
{ 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
|
|
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 := 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): 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;
|
|
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}
|
|
|
|
|
|
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'}
|