ORCA-C/Symbol.pas
Kelvin Sherlock 6bd600157d Debugger symbol table fix
const structs are wrapped in definedType.  The debugger symbol table code is unaware of this, which results in missing or incomplete entries.

example:

const struct { int a; int b; } cs;

cs:  isForwardDeclared =    false; class = ident
    4 byte constant defined type of
    4 byte struct: 223978

const struct { int a; int b; } *pcs;

pcs:  isForwardDeclared =    false; class = ident
    4 byte  pointer to
    4 byte constant defined type of
    4 byte struct: 224145

const struct { const struct { const int a; } a[2]; } csa[5];

csa:  isForwardDeclared =    false; class = ident
    20 byte 5 element array of
    4 byte constant defined type of
    4 byte struct: 225155

const struct { const struct { const int a; } a[2]; } *cspa[5];

cspa:  isForwardDeclared =    false; class = ident
    20 byte 5 element array of
    4 byte  pointer to
    4 byte constant defined type of
    4 byte struct: 224850

This change unwraps the definedType so the underlying type info can be placed in the debugger symbol table.
2019-01-13 21:11:00 -05:00

1584 lines
53 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 }
{ }
{ bytePtr - pointer to the base type for bytes }
{ uBytePtr - pointer to the base type for unsigned bytes }
{ wordPtr - pointer to the base type for words }
{ uWordPtr - pointer to the base type for unsigned words }
{ longPtr - pointer to the base type for long words }
{ uLongPtr - pointer to the base type for unsigned long words }
{ realPtr - pointer to the base type for reals }
{ doublePtr - pointer to the base type for double precision }
{ reals }
{ compPtr - pointer to the base type for comp reals }
{ extendedPtr - pointer to the base type for extended reals }
{ voidPtr - pointer to the base type for void }
{ voidPtrPtr - typeless pointer, for some type casting }
{ stringTypePtr - pointer to the base type for string }
{ constants }
{ defaultStruc - 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}
bytePtr,uBytePtr,wordPtr,uWordPtr, {base types}
longPtr,uLongPtr,realPtr,doublePtr,compPtr,extendedPtr,
stringTypePtr,voidPtr,voidPtrPtr,defaultStruct: typePtr;
{---------------------------------------------------------------}
procedure CheckStaticFunctions;
{ check for undefined functions }
function CompTypes (t1, t2: typePtr): boolean;
{ Determine if the two types are compatible }
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 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
CompTypes := t1^.baseType = t2^.baseType
else if kind2 = enumType then
CompTypes := t1^.baseType = cgWord;
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
CompTypes := CompTypes(t1^.ftype,t2^.ftype)
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
else if kind2 = enumType then
CompTypes := true;
structType,unionType:
CompTypes := t1 = t2;
otherwise: ;
end; {case t1^.kind}
1:
end; {CompTypes}
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);
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);
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 subscipt field }
{ }
{ parameters: }
{ tp - type pointer }
{ modifiers - value to or with the type code }
{ subscripts - number of subscripts }
var
val: integer; {type value}
begin {WriteScalarType}
case tp^.baseType of
cgByte: val := $40;
cgUByte: val := $00;
cgWord: val := $01;
cgUWord: val := $41;
cgLong: val := $02;
cgULong: val := $42;
cgReal: val := $03;
cgDouble: val := $04;
cgComp: val := $0A;
cgExtended: val := $05;
otherwise: val := $01;
end; {case}
CnOut(val | modifiers); {write the format byte}
CnOut2(subscripts); {write the # of subscripts}
end; {WriteScalarType}
procedure WritePointerType (tp: 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(wordPtr, $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(wordPtr, 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(wordPtr, 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;
{declare base types}
new(bytePtr); {byte}
with bytePtr^ do begin
size := cgByteSize;
saveDisp := 0;
isConstant := false;
kind := scalarType;
baseType := cgByte;
end; {with}
new(uBytePtr); {unsigned byte}
with uBytePtr^ do begin
size := cgByteSize;
saveDisp := 0;
isConstant := false;
kind := scalarType;
baseType := cgUByte;
end; {with}
new(wordPtr); {word}
with wordPtr^ do begin
size := cgWordSize;
saveDisp := 0;
isConstant := false;
kind := scalarType;
baseType := cgWord;
end; {with}
new(uWordPtr); {unsigned word}
with uWordPtr^ do begin
size := cgWordSize;
saveDisp := 0;
isConstant := false;
kind := scalarType;
baseType := cgUWord;
end; {with}
new(longPtr); {long}
with longPtr^ do begin
size := cgLongSize;
saveDisp := 0;
isConstant := false;
kind := scalarType;
baseType := cgLong;
end; {with}
new(uLongPtr); {unsigned long}
with uLongPtr^ do begin
size := cgLongSize;
saveDisp := 0;
isConstant := false;
kind := scalarType;
baseType := cgULong;
end; {with}
new(realPtr); {real}
with realPtr^ do begin
size := cgRealSize;
saveDisp := 0;
isConstant := false;
kind := scalarType;
baseType := cgReal;
end; {with}
new(doublePtr); {double}
with doublePtr^ do begin
size := cgDoubleSize;
saveDisp := 0;
isConstant := false;
kind := scalarType;
baseType := cgDouble;
end; {with}
new(compPtr); {comp}
with compPtr^ do begin
size := cgCompSize;
saveDisp := 0;
isConstant := false;
kind := scalarType;
baseType := cgComp;
end; {with}
new(extendedPtr); {extended}
with extendedPtr^ do begin
size := cgExtendedSize;
saveDisp := 0;
isConstant := false;
kind := scalarType;
baseType := cgExtended;
end; {with}
new(stringTypePtr); {string constant type}
with stringTypePtr^ do begin
size := 0;
saveDisp := 0;
isConstant := false;
kind := arrayType;
aType := uBytePtr;
elements := 1;
end; {with}
new(voidPtr); {void}
with voidPtr^ do begin
size := 0;
saveDisp := 0;
isConstant := false;
kind := scalarType;
baseType := cgVoid;
end; {with}
new(voidPtrPtr); {typeless pointer}
with voidPtrPtr^ do begin
size := 4;
saveDisp := 0;
isConstant := false;
kind := pointerType;
pType := voidPtr;
end; {with}
new(defaultStruct); {default structure}
with defaultStruct^ do begin {(for structures with errors)}
size := cgWordSize;
saveDisp := 0;
isConstant := false;
kind := structType;
sName := nil;
new(fieldList);
with fieldlist^ do begin
next := nil;
name := @'field';
itype := wordPtr;
class := ident;
state := declared;
disp := 0;
bitdisp := 0;
end; {with}
end; {with}
end; {InitSymbol}
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^.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^.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 succeeed 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'}