ORCA-C/Symbol.pas

{$optimize 7}
{---------------------------------------------------------------}
{                                                               }
{  Symbol Table                                                 }
{                                                               }
{  Handle the symbol table.                                     }
{                                                               }
{  External Subroutines:                                        }
{                                                               }
{  CheckStaticFunctions - check for undefined functions         }
{  CompTypes - Determine if the two types are compatible        }
{  DoGlobals - declare the ~globals and ~arrays segments        }
{  FindSymbol - locate a symbol in the symbol table             }
{  GenParameters - Generate labels and space for the parameters }
{  GenSymbols - generate a symbol table for the debugger        }
{  InitSymbol - initialize the symbol table handler             }
{  NewSymbol - insert a new symbol in the symbol table          }
{  PopTable - Pop a symbol table (remove definitions local to a }
{       block)                                                  }
{  PushTable - Create a new symbol table, pushing the old one   }
{  ResolveForwardReference - resolve a forward reference        }
{                                                               }
{  External Variables:                                          }
{                                                               }
{  noDeclarations - have we declared anything at this level?    }
{  table - current symbol table                                 }
{                                                               }
{  charPtr - pointer to the base type for char                  }
{  sCharPtr - pointer to the base type for signed char          }
{  uCharPtr - pointer to the base type for unsigned char        }
{  shortPtr - pointer to the base type for short                }
{  uShortPtr - pointer to the base type for unsigned short      }
{  intPtr - pointer to the base type for int                    }
{  uIntPtr - pointer to the base type for unsigned int          }
{  int32Ptr - pointer to the base type for 32-bit int           }
{  uInt32Ptr - pointer to the base type for 32-bit unsigned int }
{  longPtr - pointer to the base type for long                  }
{  uLongPtr - pointer to the base type for unsigned long        }
{  longLongPtr - pointer to the base type for long long         }
{  uLongLongPtr - pointer to base type for unsigned long long   }
{  floatPtr - pointer to the base type for float                }
{  doublePtr - pointer to the base type for double              }
{  compPtr - pointer to the base type for comp                  }
{  extendedPtr - pointer to the base type for extended          }
{  boolPtr - pointer to the base type for _Bool                 }
{  voidPtr - pointer to the base type for void                  }
{  voidPtrPtr - typeless pointer, for some type casting         }
{  stringTypePtr - pointer to the base type for string          }
{       constants                                               }
{  constCharPtr - pointer to the type const char                }
{  defaultStruct - default for structures with errors           }
{                                                               }
{---------------------------------------------------------------}

unit Symbol;

{$LibPrefix '0/obj/'}

interface

uses CCommon, CGI, MM, Scanner;

{$segment 'CC'}

{---------------------------------------------------------------}

type
   symbolTablePtr = ^symbolTable;
   symbolTable = record                 {a symbol table}
      {NOTE: the array of buckets must come first in the record!}
      buckets: array[0..hashSize2] of identPtr; {hash buckets}
      next: symbolTablePtr;             {next symbol table}
      staticNum: packed array[1..6] of char; {staticNum at start of table}
      end;

var
   noDeclarations: boolean;             {have we declared anything at this level?}
   table: symbolTablePtr;               {current symbol table}
   globalTable: symbolTablePtr;         {global symbol table}
   functionTable: symbolTablePtr;       {table for top level of current function}

                                        {base types}
   charPtr,sCharPtr,uCharPtr,shortPtr,uShortPtr,intPtr,uIntPtr,int32Ptr,
      uInt32Ptr,longPtr,uLongPtr,longLongPtr,uLongLongPtr,boolPtr,
      floatPtr,doublePtr,compPtr,extendedPtr,stringTypePtr,voidPtr,
      voidPtrPtr,constCharPtr,defaultStruct: typePtr;

{---------------------------------------------------------------}

procedure CheckStaticFunctions;

{ check for undefined functions                                 }


function CompTypes (t1, t2: typePtr): boolean;

{ Determine if the two types are compatible                     }


function StrictCompTypes (t1, t2: typePtr): boolean;

{ Determine if the two types are compatible, strictly following }
{ C standard rules.                                             }


procedure DoGlobals;

{ declare the ~globals and ~arrays segments                     }


function FindSymbol (var tk: tokenType; class: spaceType; oneLevel: boolean;
                     staticAllowed: boolean): identPtr;

{ locate a symbol in the symbol table                           }
{                                                               }
{ parameters:                                                   }
{       tk - token record for the identifier to find            }
{       class - the kind of variable space to search            }
{       oneLevel - search one level only? (used to check for    }
{               duplicate symbols)                              }
{       staticAllowed - can we check for static variables?      }
{                                                               }
{ returns:                                                      }
{       A pointer to the symbol table entry is returned.  If    }
{       there is no entry, nil is returned.                     }


procedure GenParameters (pp: parameterPtr);

{ Generate labels and space for the parameters                  }
{								}
{ parameters:							}
{    pp - pointer to first parameter				}
          

procedure GenSymbols (sym: symbolTablePtr; doGlobals: boolean);

{ generate a symbol table for the debugger                      }
{                                                               }
{ parameters:                                                   }
{       sym - symbol table to generate                          }
{       doGlobals - include global symbols in the table         }
{                                                               }
{ outputs:                                                      }
{       symLength - length of debug symbol table                }


procedure InitSymbol;

{ Initialize the symbol table module                            }


function LabelToDisp (lab: integer): integer; extern;

{ convert a local label number to a stack frame displacement    }
{                                                               }
{ parameters:                                                   }
{       lab - label number                                      }


function MakeQualifiedType (origType: typePtr; qualifiers: typeQualifierSet):
   typePtr;

{ make a qualified version of a type                            }
{                                                               }
{ parameters:                                                   }
{       origType - the original type                            }
{       qualifiers - the type qualifier(s) to add               }
{                                                               }
{ returns: pointer to the qualified type                        }


function Unqualify (tp: typePtr): typePtr;

{ returns the unqualified version of a type                     }
{                                                               }
{ parameters:                                                   }
{       tp - the original type                                  }
{                                                               }
{ returns: pointer to the unqualified type                      }


function NewSymbol (name: stringPtr; itype: typePtr; class: tokenEnum;
                   space: spaceType; state: stateKind): identPtr;

{ insert a new symbol in the symbol table                       }
{                                                               }
{ parameters:                                                   }
{       name - pointer to the symbol name                       }
{       itype - pointer to the symbol type                      }
{       class - storage class                                   }
{       space - the kind of variable space to put the           }
{               identifier in                                   }
{       state - variable declaration state                      }
{                                                               }
{ returns: pointer to the inserted symbol                       }


procedure PopTable;

{ Pop a symbol table (remove definitions local to a block)      }


{procedure PrintOneSymbol (ip: identPtr); {debug}

{ Print a symbol						}
{								}
{ Parameters:							}
{    ip - identifier to print					}


{procedure PrintTable (sym: symbolTablePtr);  {debug}

{ print a symbol table                                          }
{                                                               }
{ parameters:                                                   }
{       sym - symbol table to print                             }


procedure PushTable;

{ Create a new symbol table, pushing the old one                }


procedure ResolveForwardReference (iPtr: identPtr);

{ resolve a forward reference                                   }
{                                                               }
{ parameters:                                                   }
{       iPtr - ptr to the forward declared identifier           }

{---------------------------------------------------------------}

implementation

var
   staticNum,                             {static variable number}
   firstStaticNum: packed array[1..6] of char; {staticNum at start of function}

{- Imported from expression.pas --------------------------------}

procedure GenerateCode (tree: tokenPtr); extern;

{ generate code from a fully formed expression tree             }
{                                                               }
{ parameters:                                                   }
{     tree - top of the expression tree to generate code from   }
{                                                               }
{ variables:                                                    }
{     expressionType - result type of the expression            }


function UsualUnaryConversions: baseTypeEnum; extern;

{ performs the usual unary conversions                          }
{                                                               }
{ inputs:                                                       }
{       expressionType - type of the operand                    }
{                                                               }
{ result:                                                       }
{       The base type of the operation to perform is returned.  }
{       Any conversion code necessary has been generated.       }
{                                                               }
{ outputs:                                                      }
{       expressionType - set to result type                     }

{---------------------------------------------------------------}

procedure CnOut (i: integer); extern;

{ write a byte to the constant buffer                           }
{                                                               }
{ parameters:                                                   }
{       i - byte to write                                       }


procedure CnOut2 (i: integer); extern;

{ write a word to the constant buffer                           }
{                                                               }
{ parameters:                                                   }
{       i - word to write                                       }


procedure Out (b: integer); extern;

{ write a byte to the output file                               }
{                                                               }
{ parameters:                                                   }
{       b - byte to write                                       }


procedure Out2 (w: integer); extern;

{ write a word to the output file                               }
{                                                               }
{ parameters:                                                   }
{       w - word to write                                       }


procedure RefName (lab: stringPtr; disp, len, shift: integer); extern;

{ handle a reference to a named label                           }
{                                                               }
{ parameters:                                                   }
{       lab - label name                                        }
{       disp - displacement past the label                      }
{       len - number of bytes in the reference                  }
{       shift - shift factor                                    }


procedure LabelSearch (lab: integer; len, shift, disp: integer); extern;

{ resolve a label reference                                     }
{                                                               }
{ parameters:                                                   }
{       lab - label number                                      }
{       len - # bytes for the generated code                    }
{       shift - shift factor                                    }
{       disp - disp past the label                              }
{                                                               }
{ Note 1: maxlabel is reserved for use as the start of the      }
{       string space                                            }
{ Note 2: negative length indicates relative branch             }
{ Note 3: zero length indicates 2 byte addr -1                  }


procedure Purge; extern;

{ write any constant bytes to the output buffer                 }

{---------------------------------------------------------------}

procedure ClearTable (table: symbolTable); extern;

{ clear the symbol table to all zeros                           }

{---------------------------------------------------------------}


procedure CheckStaticFunctions;

{ check for undefined functions                                 }

var
   i: 0..hashSize;                      {loop variable}
   sp: identPtr;                        {pointer to a symbol table entry}

   msg: stringPtr;                      {error message ptr}

begin {CheckStaticFunctions}
for i := 0 to hashSize do begin
   sp := globalTable^.buckets[i];
   while sp <> nil do begin
      if sp^.storage = private then
         if sp^.itype^.kind = functionType then
            if sp^.state <> defined then begin
               numErrors := numErrors+1;
               new(msg);
               msg^ := concat('The static function ', sp^.name^,
                  ' was not defined.');
               writeln('*** ', msg^);
               if terminalErrors then begin
                  if enterEditor then
                     ExitToEditor(msg, ord4(firstPtr)-ord4(bofPtr))
                  else
                     TermError(0);
                  end; {if}
               liDCBGS.merrf := 16;
               end; {if}
      sp := sp^.next;
      end; {while}
   end; {for}
end; {CheckStaticFunctions}


function CompTypes {t1, t2: typePtr): boolean};

{ Determine if the two types are compatible                     }

label 1;

var
   el1,el2: longint;                    {array sizes}
   kind1,kind2: typeKind;               {temp variables (for speed)}
   p1, p2: parameterPtr;                {for tracing parameter lists}
   pt1,pt2: typePtr;                    {pointer types}


   function IsVoid (tp: typePtr): boolean;

   { Check to see if a type is void				}
   {								}
   { Parameters:						}
   {    tp - type to check					}
   {								}
   { Returns: True if the type is void, else false		}

   begin {IsVoid}
   IsVoid := false;
   if tp = voidPtr then
      IsVoid := true
   else if tp^.kind = scalarType then
      if tp^.baseType = cgVoid then
         IsVoid := true;
   end; {IsVoid}


begin {CompTypes}
CompTypes := false;                     {assume the types are not compatible}
kind1 := t1^.kind;                      {get these for efficiency}
kind2 := t2^.kind;
if kind2 = definedType then             {scan past type definitions}
   CompTypes := CompTypes(t1, t2^.dType)
else if kind1 = definedType then
   CompTypes := CompTypes(t1^.dType, t2)

else
   case kind1 of

      scalarType:
         if kind2 = scalarType then begin
            CompTypes := t1^.baseType = t2^.baseType;
            if t1^.cType <> t2^.cType then
               if (not looseTypeChecks) 
                  or (t1^.cType = ctBool) or (t2^.cType = ctBool) then
                  CompTypes := false;
            end {if}
         else if kind2 = enumType then
            CompTypes := (t1^.baseType = cgWord) and (t1^.cType = ctInt);

      arrayType:
         if kind2 = arrayType then begin
            el1 := t1^.elements;
            el2 := t2^.elements;
            if el1 = 0 then
               el1 := el2
            else if el2 = 0 then
               el2 := el1;
            if el1 = el2 then
               CompTypes := CompTypes(t1^.atype, t2^.atype);
            end; {if}

      functionType:
         if kind2 = functionType then begin
            if looseTypeChecks or (t1^.prototyped <> t2^.prototyped) then
               CompTypes := CompTypes(t1^.ftype,t2^.ftype)
            else
               CompTypes := StrictCompTypes(t1, t2);
            end {if}
         else if kind2 = pointerType then
            if t2^.ptype^.kind = functionType then
               CompTypes := CompTypes(t1, t2^.ptype);

      pointerType: begin
         if IsVoid(t1^.ptype) or IsVoid(t2^.ptype) then begin
            CompTypes := true;
            goto 1;
            end; {if}
         if kind2 = pointertype then
            CompTypes := CompTypes(t1^.ptype, t2^.ptype)
         else if kind2 = functionType then
            CompTypes := CompTypes(t1^.ptype, t2);
         end;

      enumType:
         if kind2 = scalarType then
            CompTypes := (t2^.baseType = cgWord) and (t2^.cType = ctInt)
         else if kind2 = enumType then
            CompTypes := true;

      structType,unionType:
         CompTypes := t1 = t2;

      otherwise: ;

      end; {case t1^.kind}
1:
end; {CompTypes}


function StrictCompTypes {t1, t2: typePtr): boolean};

{ Determine if the two types are compatible, strictly following }
{ C standard rules.                                             }

label 1;

var
   el1,el2: longint;                    {array sizes}
   kind1,kind2: typeKind;               {temp variables (for speed)}
   p1, p2: parameterPtr;                {for tracing parameter lists}
   tp1,tp2: typeRecord;                 {temporary types used in comparison}


begin {StrictCompTypes}
if t1 = t2 then begin                   {shortcut}
   StrictCompTypes := true;
   goto 1;
   end; {if}
StrictCompTypes := false;               {assume the types are not compatible}
if t1^.qualifiers <> t2^.qualifiers then {qualifiers must be the same}
   goto 1;
while t1^.kind = definedType do         {scan past type definitions}
   t1 := t1^.dType;
while t2^.kind = definedType do
   t2 := t2^.dType;
kind1 := t1^.kind;                      {get these for efficiency}
kind2 := t2^.kind;

case kind1 of

   scalarType:
      if kind2 = scalarType then begin
         StrictCompTypes :=
            (t1^.baseType = t2^.baseType) and (t1^.cType = t2^.cType);
         end {if}
      else if kind2 = enumType then
         StrictCompTypes := (t1^.baseType = cgWord) and (t1^.cType = ctInt);

   arrayType:
      if kind2 = arrayType then begin
         el1 := t1^.elements;
         el2 := t2^.elements;
         if el1 = 0 then
            el1 := el2
         else if el2 = 0 then
            el2 := el1;
         if el1 = el2 then
            StrictCompTypes := StrictCompTypes(t1^.atype, t2^.atype);
         end; {if}

   functionType:
      if kind2 = functionType then begin
         if not StrictCompTypes(t1^.ftype, t2^.ftype) then
            goto 1;
         if t1^.varargs <> t2^.varargs then
            goto 1;
         if t1^.prototyped and t2^.prototyped then begin
            p1 := t1^.parameterList;
            p2 := t2^.parameterList;
            while (p1 <> nil) and (p2 <> nil) do begin
               tp1 := p1^.parameterType^;
               tp2 := p2^.parameterType^;
               if p1^.parameterType = p2^.parameterType then
                  {these parameters are compatible}
               else begin
                  tp1.qualifiers := [];
                  tp2.qualifiers := [];
                  if tp1.kind = arrayType then
                     tp1.kind := pointerType
                  else if tp1.kind = functionType then begin
                     tp1.size := cgLongSize;
                     tp1.qualifiers := [];
                     tp1.saveDisp := 0;
                     tp1.kind := pointerType;
                     tp1.pType := p1^.parameterType;
                     end; {else if}
                  if tp2.kind = arrayType then
                     tp2.kind := pointerType
                  else if tp2.kind = functionType then begin
                     tp2.size := cgLongSize;
                     tp2.qualifiers := [];
                     tp2.saveDisp := 0;
                     tp2.kind := pointerType;
                     tp2.pType := p2^.parameterType;
                     end; {else if}
                  if not StrictCompTypes(@tp1, @tp2) then
                     goto 1;
                  end; {else}
                  p1 := p1^.next;
                  p2 := p2^.next;
               end; {while}
            if p1 <> p2 then
               goto 1;
            end {if}
         else if t1^.prototyped then begin
            p1 := t1^.parameterList;
            while p1 <> nil do begin
               if p1^.parameterType^.kind = scalarType then
                  if p1^.parameterType^.cType in [ctChar,ctSChar,ctUChar,
                     ctShort,ctUShort,ctFloat,ctBool] then
                     goto 1;
               p1 := p1^.next;
               end; {while}
            end {else if}
         else if t2^.prototyped then begin
            p2 := t2^.parameterList;
            while p2 <> nil do begin
               if p2^.parameterType^.kind = scalarType then
                  if p2^.parameterType^.cType in [ctChar,ctSChar,ctUChar,
                     ctShort,ctUShort,ctFloat,ctBool] then
                     goto 1;
               p2 := p2^.next;
               end; {while}
            end; {else if}
         StrictCompTypes := true;
         end; {if}

   pointerType:
      if kind2 = pointertype then
         StrictCompTypes := StrictCompTypes(t1^.ptype, t2^.ptype);

   enumType:
      if kind2 = scalarType then
         StrictCompTypes := (t2^.baseType = cgWord) and (t2^.cType = ctInt)
      else if kind2 = enumType then
         StrictCompTypes := true;

   structType,unionType:
      StrictCompTypes := t1 = t2;

   otherwise: ;

   end; {case}
1:
end; {StrictCompTypes}


procedure DoGlobals;

{ declare the ~globals and ~arrays segments                     }


   procedure GenArrays;

   { define global arrays                                       }

   var
      didOne: boolean;                  {have we found an array yet?}
      i: 0..hashSize;                   {loop variable}
      ip: initializerPtr;               {used to trace initializer lists}
      lval: longint;                    {for converting types}
      size: longint;                    {size of the array}
      sp: identPtr;                     {pointer to a symbol table entry}
      tPtr: typePtr;                    {type of global array/struct/union}
      msg: stringPtr;                   {error message ptr}

   begin {GenArrays}
   didOne := false;
   for i := 0 to hashSize do begin
      sp := table^.buckets[i];
      while sp <> nil do begin
         if sp^.storage in [global,private] then begin
            tPtr := sp^.itype;
            while tPtr^.kind = definedType do
               tPtr := tPtr^.dType;
            if tPtr^.kind in [arrayType,structType,unionType] then begin
               if not didOne then begin
                  if smallMemoryModel then
                     currentSegment := '          '
                  else
                     currentSegment := '~ARRAYS   ';
                  Gen2Name(dc_str, $4000, 1, @'~ARRAYS');
                  didOne := true;
                  end; {if}
               if sp^.state = initialized then begin
                  Gen2Name(dc_glb, 0, ord(sp^.storage = private), sp^.name);
                  ip := sp^.iPtr;
                  while ip <> nil do begin
                     case ip^.itype of
                        cgByte,cgUByte,cgWord,cgUWord: begin
                           lval := ip^.ival;
                           Gen2t(dc_cns, long(lval).lsw, ip^.count, ip^.itype);
                           end;
                        cgLong,cgULong:
                           GenL1(dc_cns, ip^.ival, ip^.count);
                        cgQuad,cgUQuad:
                           GenQ1(dc_cns, ip^.qval, ip^.count);
                        cgReal,cgDouble,cgComp,cgExtended:
                           GenR1t(dc_cns, ip^.rval, ip^.count, ip^.itype);
                        cgString:
                           GenS(dc_cns, ip^.sval);
                        ccPointer: begin
                           code^.optype := ccPointer;
                           code^.r := ord(ip^.pPlus);
                           code^.q := ip^.count;
                           code^.pVal := ip^.pVal;
                           if ip^.isName then begin
                              code^.lab := ip^.pName;
                              code^.pstr := nil;
                              end {if}
                           else
                              code^.pstr := ip^.pstr;
                           Gen0(dc_cns);
                           end;
                        otherwise: Error(57);
                        end; {case}
                     ip := ip^.next;
                     end; {while}
                  end {if}
               else begin
                  size := sp^.itype^.size;
                  if size = 0 then begin
                     if sp^.itype^.kind = arrayType then begin
                                        {implicitly initialize with one element}
                        size := sp^.itype^.aType^.size;
                        end {if}
                     else begin
                        numErrors := numErrors+1;
                        new(msg);
                        msg^ := concat('The struct or union ''', sp^.name^,
                           ''' has incomplete type that was never completed.');
                        writeln('*** ', msg^);
                        if terminalErrors then begin
                           if enterEditor then
                              ExitToEditor(msg, ord4(firstPtr)-ord4(bofPtr))
                           else
                              TermError(0);
                           end; {if}
                        liDCBGS.merrf := 16;
                        end; {else}
                     end; {if}
                  Gen2Name(dc_glb, long(size).lsw & $7FFF,
                     ord(sp^.storage = private), sp^.name);
        	  size := size & $FFFF8000;
        	  while size <> 0 do begin
                     Gen1(dc_dst, 16384);
                     size := size-16384;
                     end; {while}
                  end; {else}
               end; {if}
            end; {if}
         sp := sp^.next;
         end; {while}
      end; {for}
   if didOne then
      Gen0(dc_enp);
   end; {GenArrays}


   procedure GenGlobals;

   { define non-array global variables                          }

   var
      i: 0..hashSize;                   {loop variable}
      ip: initializerPtr;               {used to trace initializer lists}
      lval: longint;                    {for extracting lsw}
      sp: identPtr;                     {pointer to a symbol table entry}

   begin {GenGlobals}
   Gen2t(dc_cns, 0, 1, cgByte);
   for i := 0 to hashSize do begin
      sp := table^.buckets[i];
      while sp <> nil do begin
         if sp^.storage in [global,private] then
            if sp^.itype^.kind in [scalarType,pointerType] then begin
               if sp^.state = initialized then begin
                  Gen2Name(dc_glb, 0, ord(sp^.storage = private), sp^.name);
                  ip := sp^.iPtr;
                  case ip^.itype of
                     cgByte,cgUByte,cgWord,cgUWord: begin
                        lval := ip^.ival;
                        Gen2t(dc_cns, long(lval).lsw, 1, ip^.itype);
                        end;
                     cgLong,cgULong:
                        GenL1(dc_cns, ip^.ival, 1);
                     cgQuad,cgUQuad:
                        GenQ1(dc_cns, ip^.qval, 1);
                     cgReal,cgDouble,cgComp,cgExtended:
                        GenR1t(dc_cns, ip^.rval, 1, ip^.itype);
                     cgString:
                        GenS(dc_cns, ip^.sval);
                     ccPointer: begin
                        code^.optype := ccPointer;
                        code^.q := 1;
                        code^.r := ord(ip^.pPlus);
                        code^.pVal := ip^.pVal;
                        if ip^.isName then begin
                           code^.lab := ip^.pName;
                           code^.pstr := nil;
                           end {if}
                        else
                           code^.pstr := ip^.pstr;
                        Gen0(dc_cns);
                        end;
                     otherwise: Error(57);
                     end; {case}
                  end {if}
               {else if sp^.itype^.size = 0 then begin
                  Error(57);
                  end {else if}
               else
                  Gen2Name(dc_glb, ord(sp^.itype^.size),
                     ord(sp^.storage = private), sp^.name);
               end;
         sp := sp^.next;
         end; {while}
      end; {for}
   end; {GenGlobals}

begin {DoGlobals}
{print the global symbol table}
{if printSymbols then                 {debug}
{   PrintTable(globalTable);          {debug}

{these segments are not dynamic!}
segmentKind := 0;

{declare the ~globals segment, which holds non-array data types}
if smallMemoryModel then
   currentSegment := '          '
else
   currentSegment := '~GLOBALS  ';
Gen2Name(dc_str, $4000, 0, @'~GLOBALS');
GenGlobals;
Gen0(dc_enp);

{declare the ~arrays segment, which holds global arrays}
GenArrays;
end; {DoGlobals}


function FindSymbol {var tk: tokenType; class: spaceType; oneLevel: boolean;
                     staticAllowed: boolean): identPtr};

{ locate a symbol in the symbol table                           }
{                                                               }
{ parameters:                                                   }
{       tk - token record for the identifier to find            }
{       class - the kind of variable space to search            }
{       oneLevel - search one level only? (used to check for    }
{               duplicate symbols)                              }
{       staticAllowed - can we check for static variables?      }
{                                                               }
{ returns:                                                      }
{       A pointer to the symbol table entry is returned.  If    }
{       there is no entry, nil is returned.                     }

label 1;

var
   doTagSpace: boolean;                 {do we still need to do the tags?}
   hashDisp: longint;                   {disp into the hash table}
   i: integer;                          {loop variable}
   iHandle: ^identPtr;                  {pointer to start of hash bucket}
   iPtr: identPtr;                      {pointer to the current symbol}
   match: boolean;                      {for comparing substrings}
   name: stringPtr;                     {name to search for}
   np: stringPtr;                       {for searching for static variables}
   sPtr: symbolTablePtr;                {^ to current symbol table}

begin {FindSymbol}
{get ready to search}
staticAllowed := staticAllowed and (staticNum <> '~0000');
name := tk.name;                        {use a local variable}
hashDisp := Hash(name);                 {get the disp into the symbol table}
sPtr := table;                          {initialize the address of the sym. tbl}
FindSymbol := nil;                      {assume we won't find it}
np := nil;                              {no string buffer, yet}

{check for the variable}
while sPtr <> nil do begin
   iHandle := pointer(hashDisp+ord4(sPtr));
   if class = tagSpace then
      iHandle := pointer(ord4(iHandle) + (hashSize+1)*4);
   doTagSpace := class = allSpaces;
   iPtr := iHandle^;
   if iPtr = nil then
      if doTagSpace then begin
         iHandle := pointer(ord4(iHandle) + (hashSize+1)*4);
         iPtr := iHandle^;
         doTagSpace := false;
         end; {if}

   {scan the hash bucket for a global or auto variable}
   while iPtr <> nil do begin
      if iPtr^.name^ = name^ then begin
         FindSymbol := iPtr;
         if iPtr^.isForwardDeclared then
            ResolveForwardReference(iPtr);
         tk.symbolPtr := iPtr;
         goto 1;
         end; {if}
      iPtr := iPtr^.next;
      if iPtr = nil then
         if doTagSpace then begin
            iHandle := pointer(ord4(iHandle) + (hashSize+1)*4);
            iPtr := iHandle^;
            doTagSpace := false;
            end; {if}
      end; {while}

   {rescan for a static variable}
   if staticAllowed then begin
      if np = nil then begin            {form the static name}
         if length(name^) < 251 then begin
            new(np);
            np^[0] := chr(5+length(name^));
            for i := 1 to 5 do
               np^[i] := sPtr^.staticNum[i];
            for i := 1 to length(name^) do
               np^[i+5] := name^[i];
            end; {if}
         end {if}
      else
         for i := 2 to 5 do
            np^[i] := sPtr^.StaticNum[i];

      {scan the hash bucket for the identifier}
      iHandle := pointer(hashDisp+ord4(globalTable));
      if class = tagSpace then
         iHandle := pointer(ord4(iHandle) + (hashSize+1)*4);
      iPtr := iHandle^;

      while iPtr <> nil do begin
         if iPtr^.name^ = np^ then begin
            FindSymbol := iPtr;
            if iPtr^.isForwardDeclared then
               ResolveForwardReference(iPtr);
            tk.symbolPtr := iPtr;
            goto 1;
            end; {if}
         iPtr := iPtr^.next;
         end; {while}
      end; {if staticAllowed}

   if oneLevel then
      sPtr := nil
   else
      sPtr := sPtr^.next;
   end; {while}

1:
if np <> nil then
   dispose(np);
end; {FindSymbol}


procedure GenParameters {pp: parameterPtr};

{ Generate labels and space for the parameters                  }
{								}
{ parameters:							}
{    pp - pointer to first parameter				}

var
   i: 0..hashSize;                      {loop variable}
   pln: integer;			{label number}
   size: integer;                       {size of the parameter}
   sp: identPtr;			{symbol pointer}
   tk: tokenType;			{symbol name token}

begin {GenParameters}
if pp <> nil then begin			{prototyped parameters}
   tk.kind := ident;
   tk.numString := nil;
   tk.class := identifier;
   while pp <> nil do begin
      pln := GetLocalLabel;
      tk.name := pp^.parameter^.name;
      tk.symbolPtr := nil;
      sp := FindSymbol(tk, variableSpace, true, false);
      if sp = nil then
         sp := pp^.parameter;
      if sp^.itype^.kind = arrayType then
	 Gen3(dc_prm, pln, cgPointerSize, sp^.pdisp)
      else begin
	 size := long(sp^.itype^.size).lsw;
	 if (size = 1) and (sp^.itype^.kind = scalarType) then
            size := 2;
	 Gen3(dc_prm, pln, size, sp^.pdisp);
	 end; {else}
      sp^.pln := pln;
      pp := pp^.next;
      end; {while}
   end {if}
else begin				{K&R parameters}
   for i := 0 to hashSize do begin              
      sp := table^.buckets[i];
      while sp <> nil do begin
	 if sp^.storage = parameter then begin
            sp^.pln := GetLocalLabel;
            if sp^.itype^.kind = arrayType then
               Gen3(dc_prm, sp^.lln, cgPointerSize, sp^.pdisp)
            else begin
               size := long(sp^.itype^.size).lsw;
               if (size = 1) and (sp^.itype^.kind = scalarType) then
        	  size := 2;
               Gen3(dc_prm, sp^.lln, size, sp^.pdisp);
               end; {else}
            end; {if}
	 sp := sp^.next;
	 end; {while}
      end; {for}
   end; {else}
end; {GenParameters}


procedure GenSymbols {sym: symbolTablePtr; doGlobals: boolean};

{ generate a symbol table for the debugger                      }
{                                                               }
{ parameters:                                                   }
{       sym - symbol table to generate                          }
{       doGlobals - include global symbols in the table         }
{                                                               }
{ outputs:                                                      }
{       symLength - length of debug symbol table                }

const
   noDisp = -1;				{disp returned by GetTypeDisp if the type was not found}

type
   tpPtr = ^tpRecord;			{type list displacements}
   tpRecord = record
      next: tpPtr;
      tp: typePtr;
      disp: integer;
      end;

var
   i: 0..hashSize;			{loop/index variable}
   ip: identPtr;			{used to trace identifier lists}
   tpList,tp2: tpPtr;			{type displacement list}


   function GetTypeDisp (tp: typePtr): integer;

   { Look for an existing entry for this type			}
   {								}
   { Parameters:						}
   {    tp - type to look for					}
   {								}
   { Returns: Disp to a variable of the same type, or noDisp if	}
   {    there is no such entry.					}
   {								}
   { Notes: If the type is not in the type list, it is entered	}
   {   in the list by this call.				}

   var
      tp1, tp2: tpPtr;			{used to manipulate type list}

   begin {GetTypeDisp}
   tp1 := tpList;			{look for the type}
   tp2 := nil;
   while tp1 <> nil do 
      if tp1^.tp = tp then begin
         tp2 := tp1;
         tp1 := nil;
         end {if}
      else
         tp1 := tp1^.next;
   if tp2 <> nil then            
      GetTypeDisp := tp2^.disp		{return disp to entry}
   else begin
      GetTypeDisp := noDisp;		{no entry}
      new(tp1);				{create a new entry}
      tp1^.next := tpList;
      tpList := tp1;
      tp1^.tp := tp;
      tp1^.disp := symLength-12;
      end; {else}
   end; {GetTypeDisp}


   procedure GenSymbol (ip: identPtr; storage: storageType);

   { Generate a single symbol or struct field			}
   {								}
   { parameters:						}
   {    ip - identifier to generate				}
   {    storage - storage type; none for struct/union fields	}

   var
      disp: integer;			{disp to symbol of same type}
      tPtr: typePtr;


      procedure WriteAddress (ip: identPtr);

      { Write the address and DP flag				}
      {								}
      { parameters:						}
      {    ip - identifier					}

      var
         size: longint;			{used to break apart longints}

      begin {WriteAddress}
      if storage in [external,global,private] then begin
         RefName(ip^.name, 0, 4, 0);
         CnOut(1);
         end {if}
      else if storage = none then begin
         size := ip^.disp;
         CnOut2(long(size).lsw);
         CnOut2(long(size).msw);
         CnOut(ord(ip^.next <> nil));
         end {else if}
      else begin
         CnOut2(LabelToDisp(ip^.lln));
         CnOut2(0);
         CnOut(0);
         end; {else}
      end; {WriteAddress}


      procedure WriteName (ip: identPtr);

      { Write the name field for an identifier			}
      {								}
      { parameters:						}
      {    ip - identifier					}

      var
         len: 0..maxint;		{string length}
         j: 0..maxint;			{loop/index variable}

      begin {WriteName}
      Purge;				{generate the address of the variable  }
      Out(235); Out(4);			{ name                                 }
      LabelSearch(maxLabel, 4, 0, 0);
      if stringsize <> 0 then begin
         Out(129);
         Out2(stringsize); Out2(0);
         Out(1);
         end; {if}
      Out(0);
      len := length(ip^.name^);		{place the name in the string buffer}
      if maxstring-stringsize >= len+1 then begin
         stringspace[stringsize+1] := chr(len);
         for j := 1 to len do
            stringspace[j+stringsize+1] := ip^.name^[j];
         stringsize := stringsize+len+1;
         end {if}
      else
         Error(60);
      end; {WriteName}


      procedure WriteScalarType (tp: typePtr; modifiers, subscripts: integer);

      { Write a scalar type and subscript field			}
      {								}
      { parameters:						}
      {    tp - type pointer					}
      {    modifiers - value to or with the type code		}
      {    subscripts - number of subscripts			}

      var
         val: integer;			{type value}

      begin {WriteScalarType}
      case tp^.baseType of
	 cgByte:	val := $40;
         cgUByte:	val := $00;
         cgWord:	if tp^.cType = ctBool then
                	   val := $09
                	else
                	   val := $01;
         cgUWord:	val := $41;
         cgLong:	val := $02;
         cgULong:	val := $42;
         cgReal:	val := $03;
         cgDouble:	val := $04;
         cgComp:	val := $0A;
         cgExtended:	val := $05;
         cgQuad:	val := $0A; {same as comp}
         cgUQuad:	val := $4A;
         otherwise:	val := $01;
         end; {case}
      CnOut(val | modifiers);		{write the format byte}
      CnOut2(subscripts);		{write the # of subscripts}
      end; {WriteScalarType}


      procedure WritePointerType (tp: typePtr; subscripts: integer);

      { write a pointer type field				}
      {								}
      { parameters:						}
      {    tp - pointer type					}
      {    subscripts - number of subscript fields		}

      begin {WritePointerType}
      tp := tp^.ptype;
      while tp^.kind = definedType do
         tp := tp^.dType;
      case tp^.kind of
         scalarType:	WriteScalarType(tp, $80, subscripts);
         enumType,
         functionType:  WriteScalarType(intPtr, $80, subscripts);
         otherwise:	begin
        		CnOut(11);
        		CnOut2(subscripts);
                        end;
         end; {case}
      end; {WritePointerType}


      procedure ExpandPointerType (tp: typePtr); forward;
      

      procedure ExpandStructType (tp: typePtr);

      { write the type entries for a struct or union		}
      {								}
      { parameters:						}
      {    tp - struct/union type				}

      var
         ip: identPtr;			{used to trace the field list}

      begin {ExpandStructType}
      ip := tp^.fieldList;
      { fieldList is nil if this is a forward declared struct. }
      if ip = nil then ip := defaultStruct^.fieldList;

      while ip <> nil do begin
         GenSymbol(ip, none);
         ip := ip^.next;
         end; {while}
      end; {ExpandStructType}


      procedure WriteArrays (tp: typePtr);

      { handle an array type					}
      {								}
      { parameters:						}
      {    tp - array type					}

      var
         count: 0..maxint;		{# of subscripts}
         size: longint;			{for converting long numbers}
         tp2: typePtr;			{used to trace array type list}

      begin {WriteArrays}
      count := 0;			{count the subscripts}
      tp2 := tp;
      while tp2^.kind = arrayType do begin
         count := count+1;
         tp2 := tp2^.aType;
         end; {while}
      while tp2^.kind = definedType do
         tp2 := tp2^.dType;         
      if tp2^.kind = scalarType then	{write the type code}
         if tp2^.baseType in [cgByte,cgUByte] then begin
            count := count-1;
            CnOut(6);
            CnOut2(count);
            end {if}
         else
            WriteScalarType(tp2, 0, count)
      else if tp2^.kind = enumType then
         WriteScalarType(intPtr, 0, count)
      else if tp2^.kind = pointerType then
         WritePointerType(tp2, count)
      else begin
         CnOut(12);
         CnOut2(count);
         end; {else if}
      while count <> 0 do begin		{write the subscript entries}
         CnOut2(0); CnOut2(0);
         if tp^.elements = 0 then
            size := $00FFFFFF
         else
            size := tp^.elements-1;
         CnOut2(long(size).lsw); CnOut2(long(size).msw);
         size := tp^.aType^.size;
         CnOut2(long(size).lsw); CnOut2(long(size).msw);
         symLength := symLength+12;
         tp := tp^.aType;
         count := count-1;
         end; {while}
      if tp2^.kind = pointerType then	{expand complex types}
         ExpandPointerType(tp2)
      else if tp2^.kind in [structtype,uniontype] then
         ExpandStructType(tp2);
      end; {WriteArrays}


      procedure ExpandPointerType {tp: typePtr};

      { write the type entries for complex pointer types	}
      {								}
      { parameters:						}
      {    tp - pointer type					}

      var
	 disp: integer;			{disp to symbol of same type}

      begin {ExpandPointerType}
      tp := tp^.ptype;
      while tp^.kind = definedType do
         tp := tp^.dType;
      if tp^.kind in [pointerType,arrayType,structType,unionType] then
         begin
         symLength := symLength+12;
         CnOut2(0); CnOut2(0);
         CnOut2(0); CnOut2(0);
         CnOut(0);
	 case tp^.kind of
            pointerType:	begin
         		   	WritePointerType(tp, 0);
                           	ExpandPointerType(tp);
                           	end;
            arrayType:		WriteArrays(tp);
            structType,
            unionType:		begin
				disp := GetTypeDisp(tp);
                                if disp = noDisp then begin
        		   	   CnOut(12);
        		   	   CnOut2(0);
                           	   ExpandStructType(tp);
                                   end {if}
                                else begin
        		   	   CnOut(13);
        		   	   CnOut2(disp);
                                   end; {else}
                           	end;
            end; {case}
         end; {if}
      end; {ExpandPointerType}


   begin {GenSymbol}
   tPtr := ip^.itype;
   while tPtr^.kind = definedType do
      tPtr := tPtr^.dType;
   if tPtr^.kind in
      [scalarType,arrayType,pointerType,enumType,structType,unionType]
      then begin
      symLength := symLength+12;        {update length of symbol table}
      WriteName(ip);			{write the name field}
      WriteAddress(ip);			{write the address field}
      case tPtr^.kind of
         scalarType:	WriteScalarType(tPtr, 0, 0);
         enumType:	WriteScalarType(intPtr, 0, 0);
         pointerType:	begin
         		WritePointerType(tPtr, 0);
                        ExpandPointerType(tPtr);
                        end;
         arrayType:	WriteArrays(tPtr);
         structType,
         unionType:	begin
			disp := GetTypeDisp(tPtr);
                        if disp = noDisp then begin
        		   CnOut(12);
        		   CnOut2(0);
                           ExpandStructType(tPtr);
                           end {if}
                        else begin
        		   CnOut(13);
        		   CnOut2(disp);
                           end; {else}
                        end;
         end; {case}
      end; {if}
   end; {GenSymbol}


begin {GenSymbols}
tpList := nil;				{no types so far}
if sym <> nil then
   for i := 0 to hashSize do begin      {loop over all hash buckets}
      ip := sym^.buckets[i];            {trace through all symbols in this bucket}
      while ip <> nil do begin
         if ip^.storage <> none then
            GenSymbol(ip, ip^.storage);
         ip := ip^.next;                {next symbol}
         end; {while}
      end; {for}
while tpList <> nil do begin		{dispose of type list}
   tp2 := tpList;
   tpList := tp2^.next;
   dispose(tp2);
   end; {while}
if doGlobals then			{do globals}
   GenSymbols(globalTable, false);
end; {GenSymbols}


procedure InitSymbol;

{ Initialize the symbol table module                            }

var
   i: 0..hashSize;                      {loop variable}

begin {InitSymbol}
staticNum := '~0000';                   {no functions processed}
table := nil;                           {initialize the global symbol table}
PushTable;
globalTable := table;
noDeclarations := false;
functionTable := nil;
                                        {declare base types}
new(sCharPtr);                          {signed char}
with sCharPtr^ do begin
   size := cgByteSize;
   saveDisp := 0;
   qualifiers := [];
   kind := scalarType;
   baseType := cgByte;
   cType := ctSChar;
   end; {with}
new(charPtr);                           {char}
with charPtr^ do begin
   size := cgByteSize;
   saveDisp := 0;
   qualifiers := [];
   kind := scalarType;
   baseType := cgUByte;
   cType := ctChar;
   end; {with}
new(uCharPtr);                          {unsigned char}
with uCharPtr^ do begin
   size := cgByteSize;
   saveDisp := 0;
   qualifiers := [];
   kind := scalarType;
   baseType := cgUByte;
   cType := ctUChar;
   end; {with}
new(shortPtr);                          {short}
with shortPtr^ do begin
   size := cgWordSize;
   saveDisp := 0;
   qualifiers := [];
   kind := scalarType;
   baseType := cgWord;
   cType := ctShort;
   end; {with}
new(uShortPtr);                         {unsigned short}
with uShortPtr^ do begin
   size := cgWordSize;
   saveDisp := 0;
   qualifiers := [];
   kind := scalarType;
   baseType := cgUWord;
   cType := ctUShort;
   end; {with}
new(intPtr);                            {int}
with intPtr^ do begin
   size := cgWordSize;
   saveDisp := 0;
   qualifiers := [];
   kind := scalarType;
   baseType := cgWord;
   cType := ctInt;
   end; {with}
new(uIntPtr);                           {unsigned int}
with uIntPtr^ do begin
   size := cgWordSize;
   saveDisp := 0;
   qualifiers := [];
   kind := scalarType;
   baseType := cgUWord;
   cType := ctUInt;
   end; {with}
new(int32Ptr);                          {int (32-bit)}
with int32Ptr^ do begin
   size := cgLongSize;
   saveDisp := 0;
   qualifiers := [];
   kind := scalarType;
   baseType := cgLong;
   cType := ctInt32;
   end; {with}
new(uInt32Ptr);                         {unsigned int (32-bit)}
with uInt32Ptr^ do begin
   size := cgLongSize;
   saveDisp := 0;
   qualifiers := [];
   kind := scalarType;
   baseType := cgULong;
   cType := ctUInt32;
   end; {with}
new(longPtr);                           {long}
with longPtr^ do begin
   size := cgLongSize;
   saveDisp := 0;
   qualifiers := [];
   kind := scalarType;
   baseType := cgLong;
   cType := ctLong;
   end; {with}
new(uLongPtr);                          {unsigned long}
with uLongPtr^ do begin
   size := cgLongSize;
   saveDisp := 0;
   qualifiers := [];
   kind := scalarType;
   baseType := cgULong;
   cType := ctULong;
   end; {with}
new(longLongPtr);                       {long long}
with longLongPtr^ do begin
   size := cgQuadSize;
   saveDisp := 0;
   qualifiers := [];
   kind := scalarType;
   baseType := cgQuad;
   cType := ctLongLong;
   end; {with}
new(uLongLongPtr);                      {unsigned long long}
with uLongLongPtr^ do begin
   size := cgQuadSize;
   saveDisp := 0;
   qualifiers := [];
   kind := scalarType;
   baseType := cgUQuad;
   cType := ctULongLong;
   end; {with}
new(floatPtr);                          {real}
with floatPtr^ do begin
   size := cgRealSize;
   saveDisp := 0;
   qualifiers := [];
   kind := scalarType;
   baseType := cgReal;
   cType := ctFloat;
   end; {with}
new(doublePtr);                         {double}
with doublePtr^ do begin
   size := cgDoubleSize;
   saveDisp := 0;
   qualifiers := [];
   kind := scalarType;
   baseType := cgDouble;
   cType := ctDouble;
   end; {with}
new(compPtr);                           {comp}
with compPtr^ do begin
   size := cgCompSize;
   saveDisp := 0;
   qualifiers := [];
   kind := scalarType;
   baseType := cgComp;
   cType := ctComp;
   end; {with}
new(extendedPtr);                       {extended, aka long double}
with extendedPtr^ do begin
   size := cgExtendedSize;
   saveDisp := 0;
   qualifiers := [];
   kind := scalarType;
   baseType := cgExtended;
   cType := ctLongDouble;
   end; {with}
new(boolPtr);                           {_Bool}
with boolPtr^ do begin
   size := cgWordSize;
   saveDisp := 0;
   qualifiers := [];
   kind := scalarType;
   baseType := cgWord;
   cType := ctBool;
   end; {with}
new(stringTypePtr);                     {string constant type}
with stringTypePtr^ do begin
   size := 0;
   saveDisp := 0;
   qualifiers := [];
   kind := arrayType;
   aType := charPtr;
   elements := 1;
   end; {with}
new(voidPtr);                           {void}
with voidPtr^ do begin
   size := 0;
   saveDisp := 0;
   qualifiers := [];
   kind := scalarType;
   baseType := cgVoid;
   cType := ctVoid;
   end; {with}
new(voidPtrPtr);                        {typeless pointer}
with voidPtrPtr^ do begin
   size := 4;
   saveDisp := 0;
   qualifiers := [];
   kind := pointerType;
   pType := voidPtr;
   end; {with}
new(defaultStruct);                     {default structure}
with defaultStruct^ do begin            {(for structures with errors)}
   size := cgWordSize;
   saveDisp := 0;
   qualifiers := [];
   kind := structType;
   sName := nil;
   new(fieldList);
   with fieldlist^ do begin
      next := nil;
      name := @'field';
      itype := intPtr;
      class := ident;
      state := declared;
      disp := 0;
      bitdisp := 0;
      end; {with}
   end; {with}
new(constCharPtr);                      {const char}
constCharPtr^ := charPtr^;
constCharPtr^.qualifiers := [tqConst];
end; {InitSymbol}


function MakeQualifiedType {origType: typePtr; qualifiers: typeQualifierSet):
   typePtr};

{ make a qualified version of a type                            }
{                                                               }
{ parameters:                                                   }
{       origType - the original type                            }
{       qualifiers - the type qualifier(s) to add               }
{                                                               }
{ returns: pointer to the qualified type                        }

var
   tp: typePtr;                         {the qualified type}
   elemType: typePtr;                   {array element type}

begin {MakeQualifiedType}
if qualifiers <> [] then begin          {make qualified version of type}
   tp := pointer(Malloc(sizeof(typeRecord)));
   if origType^.kind in [structType,unionType] then begin
      tp^.size := origType^.size;
      tp^.kind := definedType;
      tp^.dType := origType;
      tp^.saveDisp := 0;
      tp^.qualifiers := qualifiers;
      end {if}
   else begin
      tp^ := origType^;
      tp^.qualifiers := tp^.qualifiers + qualifiers;
      end; {else}
   MakeQualifiedType := tp;
                                        {move array type quals to element type}
   while tp^.kind = arrayType do begin
      elemType := pointer(Malloc(sizeof(typeRecord)));
      if tp^.aType^.kind in [structType,unionType] then begin
         elemType^.size := tp^.aType^.size;
         elemType^.kind := definedType;
         elemType^.dType := tp^.aType;
         elemType^.saveDisp := 0;
         elemType^.qualifiers := qualifiers;
         end {if}
      else begin
         elemType^ := tp^.aType^;
         elemType^.qualifiers := elemType^.qualifiers + qualifiers;
         end; {else}
      tp^.aType := elemType;
      tp^.qualifiers := [];             {remove for C23}
      tp := elemType;
      end; {if}
   end {if}
else
   MakeQualifiedType := origType;
end; {MakeQualifiedType}


function Unqualify {tp: typePtr): typePtr};

{ returns the unqualified version of a type                     }
{                                                               }
{ parameters:                                                   }
{       tp - the original type                                  }
{                                                               }
{ returns: pointer to the unqualified type                      }

var
   tp2: typePtr;                        {unqualified type}

begin {Unqualify}
while tp^.kind = definedType do
   tp := tp^.dType;
Unqualify := tp;
if tp^.qualifiers <> [] then
   if not (tp^.kind in [structType,unionType]) then begin
      tp2 := pointer(Malloc(sizeof(typeRecord)));
      tp2^ := tp^;
      tp2^.qualifiers := [];
      Unqualify := tp2;
      end;
end; {Unqualify}


function NewSymbol {name: stringPtr; itype: typePtr; class: tokenEnum;
                   space: spaceType; state: stateKind): identPtr};

{ insert a new symbol in the symbol table                       }
{                                                               }
{ parameters:                                                   }
{       name - pointer to the symbol name                       }
{       itype - pointer to the symbol type                      }
{       class - storage class                                   }
{       space - the kind of variable space to put the           }
{               identifier in                                   }
{       state - variable declaration state                      }
{                                                               }
{ returns: pointer to the inserted symbol                       }

var
   cs: identPtr;                        {current symbol}
   hashPtr: ^identPtr;                  {pointer to hash bucket in symbol table}
   i: integer;                          {loop variable}
   isGlobal: boolean;                   {are we using the global table?}
   lUseGlobalPool: boolean;             {use the global symbol pool?}
   needSymbol: boolean;                 {do we need to declare it?}
   np: stringPtr;                       {for forming static name}
   p: identPtr;                         {work pointer}
   tk: tokenType;                       {fake token; for FindSymbol}

begin {NewSymbol}
needSymbol := true;                     {assume we need a symbol}
cs := nil;                              {no current symbol found}
isGlobal := false;                      {set up defaults}
lUseGlobalPool := useGlobalPool;
tk.name := name;
tk.symbolPtr := nil;
if space <> fieldListSpace then begin   {are we defining a function?}
   if (itype <> nil) and (itype^.kind = functionType) then begin
      isGlobal := true;
      useGlobalPool := true;
      if class in [autosy, ident] then
         class := externsy;
      if not lUseGlobalPool then begin
         np := pointer(Malloc(length(name^)+1));
         CopyString(pointer(np), pointer(name));
         tk.name := np;
         name := np;
         end; {if}
      cs := FindSymbol(tk, space, false, true);
      if cs <> nil then begin
         if cs^.state = defined then
            if state = defined then
               Error(42);
         p := cs;
         needSymbol := false;
         if not itype^.prototyped then begin
            itype^.prototyped := cs^.itype^.prototyped;
            itype^.parameterList := cs^.itype^.parameterList;
            end; {if}
         end; {if}
      end {if}
   else if (itype <> nil) and (itype^.kind in [structType,unionType])
      and (itype^.fieldList = nil) and doingParameters then begin
      useGlobalPool := true;
      end; {else if}
   if noDeclarations then begin         {if we need a symbol table, create it}
      if not isGlobal then 
         noDeclarations := false;
      end {if}
   else begin                           {check for duplicates}
      cs := FindSymbol(tk, space, true, false);
      if cs <> nil then begin
         if (not CompTypes(cs^.itype, itype))
            or ((cs^.state = initialized) and (state = initialized))
            or (globalTable <> table) then
            if (not doingParameters) or (cs^.state <> declared) then
               Error(42);
         p := cs;
         needSymbol := false;
         end; {if}
      end; {else}
   end; {if}
if class = staticsy then                {statics go in the global symbol table}
   if not isGLobal then
      if globalTable <> table then begin
         cs := FindSymbol(tk, space, true, true);
         if cs <> nil then begin        {check for duplicates}
            if (not CompTypes(cs^.itype, itype))
               or ((cs^.state = defined) and (state <> initialized))
               or (cs^.state = initialized) then
               Error(42);
            p := cs;
            needSymbol := false;
            end; {if}
         isGlobal := true;              {note that we will use the global table}
         useGlobalPool := true;
         np := pointer(GMalloc(length(name^)+6));
         np^[0] := chr(5+length(name^));
         for i := 1 to 5 do
            np^[i] := table^.staticNum[i];
         for i := 1 to length(name^) do
            np^[i+5] := name^[i];
         name := np;
         end; {if}
if needSymbol then begin
   p := pointer(Calloc(sizeof(identRecord))); {get space for the record}
   {p^.iPtr := nil;}                    {no initializers, yet}
   {p^.saved := 0;}			{not saved}
   p^.state := state;                   {set the state}
   {p^.isForwardDeclared := false;}     {assume no forward declarations are used}
   p^.name := name;                     {record the name}
   if space <> fieldListSpace then      {insert the symbol in the hash bucket}
      begin
      if itype = nil then
         hashPtr := pointer(ord4(table)+Hash(name))
      else if isGlobal then
         hashPtr := pointer(ord4(globalTable)+Hash(name))
      else
         hashPtr := pointer(ord4(table)+Hash(name));
      if space = tagSpace then
         hashPtr := pointer(ord4(hashPtr) + 4*(hashSize+1));
      p^.next := hashPtr^;
      hashPtr^ := p;
      end {if}
   else
      p^.next := nil;
   end; {if}
if class in [autosy,registersy] then    {check and set the storage class}
   begin
   if doingFunction or doingParameters then begin
      p^.storage := stackFrame;
      class := ident;
      end {if}
   else begin
      p^.storage := global;
      Error(62);
      end; {else}
   end {if}
else if class = ident then begin
   if doingFunction then begin
      p^.storage := stackFrame;
      class := autosy;
      end {if}
   else
      p^.storage := global;
   end {else if}
else if class = externsy then
   p^.storage := external
else if class = staticsy then
   p^.storage := private
else
   p^.storage := none;
p^.class := class;
p^.itype := itype;                      {set the symbol field values}
NewSymbol := p;                         {return a pointer to the new entry}
useGlobalPool := lUseGlobalPool;        {restore the useGlobalPool variable}
end; {NewSymbol}


procedure PopTable;

{ Pop a symbol table (remove definitions local to a block)      }

var
   tPtr: symbolTablePtr;                {work pointer}

begin {PopTable}
tPtr := table;
{if printSymbols then                 {debug}
{   PrintTable(tPtr);                 {debug}
if tPtr^.next <> nil then begin
   table := table^.next;
   dispose(tPtr);
   end; {if}
end; {PopTable}


{ copy 'symbol.print'} {debug}


procedure PushTable;

{ Create a new symbol table, pushing the old one                }

var
   done: boolean;                       {loop termination}
   i: integer;                          {loop index}
   tPtr: symbolTablePtr;                {work pointer}

begin {PushTable}
i := 5;                                 {increment the static var number}
repeat
   staticNum[i] := succ(staticNum[i]);
   done := staticNum[i] <> succ('9');
   if not done then begin
      staticNum[i] := '0';
      i := i-1;
      done := i = 1;
      end; {if}
until done;
if table = globalTable then             {update fistStaticNum}
   firstStaticNum := staticNum;
new(tPtr);                              {create a new symbol table}
ClearTable(tPtr^);
tPtr^.next := table;
table := tPtr;
tPtr^.staticNum := staticNum;           {record the static symbol table number}
end; {PushTable}


procedure ResolveForwardReference {iPtr: identPtr};

{ resolve a forward reference                                   }
{                                                               }
{ parameters:                                                   }
{       iPtr - ptr to the forward declared identifier           }

var
   fl: identPtr;			{for tracing field lists}
   ltk: tokenType;                      {for searching for forward refs}
   sym: identPtr;                       {for finding forward refs}
   lPtr,tPtr: typePtr;                  {for tracing forward declared types}

begin {ResolveForwardReference}
iPtr^.isForwardDeclared := false;	{we will succeed or flag an error...}
tPtr := iPtr^.itype;			{skip to the struct/union type}
lPtr := nil;
while tPtr^.kind in [pointerType,arrayType,functionType,definedType] do begin
   lPtr := tPtr;
   tPtr := tPtr^.pType;
   end;
if tPtr^.sName <> nil then begin	{resolve the forward reference}
   ltk.name := tPtr^.sName;
   ltk.symbolPtr := nil;
   sym := FindSymbol(ltk,tagSpace,false,true);
   if sym <> nil then begin
      if sym^.itype^.kind <> tPtr^.kind then
	 Error(107)
      else begin
         if sym^.itype = tPtr then
            tPtr^.sName := nil
         else begin
            tPtr := sym^.itype;
            if lPtr <> nil then
               lPtr^.ptype := tPtr;
            end; {else}
         end; {else}
      end; {if}
   end; {if}
if lPtr <> nil then
   tPtr := lPtr^.pType;			{check the field list for other fwd refs}
while tPtr^.kind in [pointerType,arrayType,functionType,definedType] do
   tPtr := tPtr^.pType;
if tPtr^.kind in [structType,unionType] then begin
   fl := tPtr^.fieldList;
   while fl <> nil do begin
      if fl^.isForwardDeclared then
         ResolveForwardReference(fl);
      fl := fl^.next;
      end; {while}
   end; {if}
end; {ResolveForwardReference}

end.

{$append 'symbol.asm'}