{                         P32 - 32bit Pascal Compiler                        }
{ -------------------------------------------------------------------------- }
{                       Johan Prins - jprins@knoware.nl                      }
{ ========================================================================== }
{ Routines for symboltable                                                   }
{                                                   (c) Copyright 1996-1998  }
{                                                                            }
{ -------------------------------------------------------------------------- }

unit P32_symb;

interface

uses P32_prep, P32_scan, P32_err;

const
   ConstantCount: integer=0;
   SymbolCount  : integer=0;

type
   int_proc =  (          no,
                    in_write,
                  in_writeln,
                     in_read,
                   in_readln,
                   in_sizeof,
                      in_dec,
                      in_inc,
                     in_succ,
                     in_pred,
                      in_ord,
                      in_chr,
                      in_new,
                  in_dispose);

   StandardType =( s8bit,             {signed  8bit}
                  s16bit,             {signed 16bit}
                  s32bit,             {signed 32bit}
                   u8bit,             {unsigned  8bit}
                  u16bit,             {unsigned 16bit}
                  u32bit,             {unsigned 32bit}
                   uchar,             {char 8bit}
                  f64bit);            {floating-point 64 bit}

                  {types that need to be implemented....}
                  {f32bit,            {floating-point 32 bit}
                  {f80bit,            {floating-point 80 bit}

                  {u64bit,            {unsigned 64 bit integer}
                  {s64bit,            {signed   64 bit integer}

   StringType = (_ShortString, _LongString);


   SymbolType = (_Label,
                 _Constant,
                 _Variable,
                 _Type,
                 _Proc,
                 _Func,
                 _Unit);

   ConstType  = ( _IntegerConst,
                     _CharConst,
                  _OrdinalConst,
                   _StringConst,
                     _RealConst);

   VarType    = (  _Global,
                    _Local,
                  _ParmVar,
                _ParmConst,
                _ParmValue);

   FileType   = ( _Text,
                  _Untyped,
                  _Typed  );

   TypeDefinition = (_EmptyDef,
                     _ConstDef,
                     _EnumeratedDef,
                     _BooleanDef,
                     _SubRangeDef,
                     _ArrayDef,
                     _RecordDef,
                     _StringDef,
                     _FileDef,
                     _PointerDef,
                     _SetDef,
                     _ProcedureDef,
                     _RealDef);

   pTypeRecord   =  ^TypeRecord;
   pSymbolRecord =  ^SymbolRecord;


     SymbolList  = record
                     First : pSymbolRecord;
                     Rear  : pSymbolRecord;
                   end;

   TypeRecord = record
                  case TypeDef: TypeDefinition of
                   _BooleanDef,
                   _SubRangeDef  : ( LowerLimit,
                                     UpperLimit  : Longint;
                                     SubRangeTyp : StandardType);
                   _StringDef,
                   _ArrayDef     : ( Length      : byte;
                                     Range,
                                     Definition  : pTypeRecord);
                   _RecordDef    : ( RecordSize  : longint;
                                     RecordTable : SymbolList;);
                   _EnumeratedDef: ( {Name        : string[32];}
                                     Number      : word);
                   _FileDef      : ( FileTyp     : FileType;
                                     FileTypeRec : pTypeRecord);
                   _PointerDef   : ( PointerTo   : pSymbolRecord);
                   _SetDef       : ( SetOf       : pTypeRecord;
                                     SetSize     : byte);
                   _RealDef      : ( FPU_LowerLimit,
                                     FPU_UpperLimit  : double;
                                     FPU_RealType    : StandardType);
                end;

SymbolRecord=   record
                   name       : string[64];         {should be pstring}
                   next, prev : pSymbolRecord;
                   dumped,
                   _extern,
                   _public    :boolean;
                   case Symbol: SymbolType of
                   _Label     : ();
                   _Constant  : (ConstTyp       : pTypeRecord;
                                 case c:ConstType of
                                 _IntegerConst,
                                 _OrdinalConst  : (n:longint);
                                 _CharConst     : (x:char);
                                 _StringConst   : (s:string[64]);
                                 _RealConst     : (d:double));
                   _Type,
                   _Variable  : (TypeDef      : pTypeRecord;
                                 Offset       : longint;
                                 vLevel       : longint;
                                 VarType      : VarType;
                                 AbsReference : boolean;
                                 Alias        : pSymbolRecord;
                                 TypedConst   : boolean;
                                 forwardtype  : boolean);
                   _Func,
                   _Proc      : (OverLoadedName: string[64{128}]; {should be pChar}
                                 NextOverloaded: pSymbolRecord;
                                 Parameter     : SymbolList;
                                 LocalSize,
                                 ParamSize     : longint;
                                 pLevel        : byte;
                                 ReturnType    : pTypeRecord;
                                 _assembler,
                                 _register,
                                 _forward,
                                 _inline,
                                 _underscore,
                                 _system,
                                 Used          : boolean;
                                 inlinetree    : pointer;
                                 internal      : int_proc);
                   _Unit       : (unitname:string[8]);
                 end;


     pConstantRecord    = ^ConstantRecord;

     ConstantList    = record
                         first : pConstantRecord;
                         rear  : pConstantRecord;
                       end;

     ConstantRecord = record
                        prev,
                        next           : pConstantRecord;
                        dumped         : boolean;
                        size           : longint;
                        id             : pstring;
                        case c         : ConstType of
                        _IntegerConst,
                        _OrdinalConst  : (n:longint);
                        _CharConst     : (x:char);
                        _StringConst   : (s:pstring);
                        _RealConst     : (d:double);
                      end;

var
   ConstantTable : ConstantList;
   GlobalTable   : SymbolList;

   LabelCount    : integer;

   vt            : vartype;

   StackSize,               {contains the stacksize that a procedure needs}
   LexLevel      : longint; {contains the lexlevel for nested procedures}

procedure CreateSymbolList(var l:SymbolList);
function NewSymbol:pSymbolRecord;
function NewType:pTypeRecord;
procedure DestroySymbolList(var L : SymbolList);
procedure DeleteSymbol(var L : SymbolList;var sym : pSymbolRecord);
procedure RemoveLastSymbol(var L : SymbolList);
procedure AddSymbol(var L:SymbolList;sym: pSymbolRecord);
function  GetPointer(l:SymbolList;name:string):pSymbolRecord;
function  GetSize(typ:pTypeRecord):longint;
function GetType(typ:pTypeRecord): TypeDefinition;

procedure CreateConstantList(var l:ConstantList);
function GetConstant(l :ConstantList; name: string):pConstantRecord;
function AddConstant(var l:ConstantList;con: pConstantRecord; dup:boolean):pstring;
procedure RemoveLastConstant(var L : ConstantList);
procedure DestroyConstantList(var L: ConstantList);

implementation

procedure CreateSymbolList(var l:SymbolList);
begin
  l.first:=NIL;
  l.rear :=NIL;
end;

function NewSymbol:pSymbolRecord;
var sym: pSymbolRecord;

begin
  new(sym);
  FillChar(sym^, sizeof(sym^), 0);
  NewSymbol:=sym;
end;

function NewType:pTypeRecord;
var typ: pTypeRecord;

begin
  new(typ);
  FillChar(typ^, sizeof(typ^), 0);
  NewType:=typ;
end;

procedure AddSymbol(var l:SymbolList;sym: pSymbolRecord);

var dummy, temp    : pSymbolRecord;
    lev: longint;
begin
  dummy:=GetPointer(l, sym^.name);
  if (dummy<>NIL) and
     (dummy^.vartype=vt) and
     (dummy^.vlevel=LexLevel) then LineError(LineCount, 'Duplicate identifier ('+sym^.name+')')
  else
   begin
     temp := sym;                {Update pointer to data}
     temp^.next := nil;
     temp^.prev := L.Rear;
     If (L.Rear = NIL) then      {If empty list...}
       begin
         L.First := temp;       {Add as first node}
         L.Rear := temp;
       end
     else                    {else add at end}
       begin
         L.Rear^.Next := temp;  {Make old rear of list point to new}
         L.Rear := temp;        {Make rear point to new node}
       end;
     inc(SymbolCount);
   end;
end;

procedure DeleteSymbol(var L : SymbolList;var sym : pSymbolRecord);
begin
  if (sym^.Next = nil) then       {If we're dealing with}
    RemoveLastSymbol(L)            {last node then that's easy}
  else                            {otherwise...}
    begin
      if (sym = L.First) then              {if we're deleting the first node}
        begin
          L.First := L.First^.Next;    {Start list from second node}
          L.First^.Prev := NIL;        {Set new starts previous link}
          Dispose(sym);                {Dispose of old first}
          sym:=NIL;
        end
      else
        begin
          sym^.prev^.next := sym^.next;     {Move pointers...}
          sym^.next^.prev := sym^.prev;
          Dispose(sym);          {Dispose of node}
          sym:=NIL;
        end;
    end;
  dec(SymbolCount); {make my managementsystem happy ;) }
end;

procedure RemoveLastSymbol(var L : SymbolList);

begin
  if (L.First <>NIL) and (L.Rear<>NIL) then     {If nodes in list}
    if L.First^.next = nil then
      begin
        Dispose(L.First);             {Dispose of first node}
        L.First := nil;
        L.Rear := nil;                  {Set rear to nil}
      end
    else
      begin                            {If more than one node}
        L.Rear := L.Rear^.prev;       {Set rear to second last}
        Dispose(L.Rear^.next);        {Remove last node}
        L.Rear^.next:=Nil;
      end;
   dec(SymbolCount); {make my managementsystem happy ;) }
end;

procedure DestroySymbolList(var L : SymbolList);
begin
  while L.First <> nil do  {While still nodes left}
    RemoveLastSymbol(L);   {Remove last node}

  l.first:=NIL;            {Reset values}
  l.rear:=NIL;
end;

function GetPointer(l:SymbolList;name:string):pSymbolRecord;
{searches backwards}
var sym: pSymbolRecord;

begin
  sym  := l.rear;
  GetPointer:=sym;
  if sym<>NIL then
    begin
      while (sym <> NIL) and (name<>sym^.name) and (sym<>l.first) do
      sym := sym^.prev;
      if sym^.name=name then GetPointer:=sym else GetPointer:=NIL;
    end;
end;

function GetSize(typ:pTypeRecord):longint;

var
   size:longint;

begin
  size:=0;
  case typ^.typedef of
  _SubRangeDef: case typ^.SubRangeTyp of
                uchar,
                s8bit,u8bit  : size:=1;
                s16bit,u16bit: size:=2;
                s32bit,u32bit: size:=4;
                end;
  _BooleanDef : size:=1;
  _EnumeratedDef,
  _PointerDef : size:=4;
  _StringDef  : size:=1+typ^.length;
  _ArrayDef   : if typ^.range^.typedef=_SubRangeDef then
                  size:=(typ^.range^.UpperLimit-typ^.range^.LowerLimit+1)*GetSize(typ^.definition);
  _RecordDef  : size:=typ^.recordsize;
  _RealDef    : begin
                  {case typ^.FPU_RealType of
                   f64bit: }size:=8;
                 {end;}
                end;
  _FileDef    : case typ^.filetyp of
                _text   : size:=512; {more logical value}
                _untyped: size:=256;
                end;
  _SetDef     : {size:=32;}
                size:=typ^.setsize;
  else          LineError(LineCount, 'GetSize: error determining type');
  end;
  GetSize:=size;
end;

function GetType(typ:pTypeRecord): TypeDefinition;

begin
   case typ^.typedef of
   _SubRangeDef  : GetType:=_SubRangeDef;
   _EnumeratedDef: GetType:=_EnumeratedDef;
   _ArrayDef     : GetType:=GetType(typ^.definition);
   _RealDef      : GetType:=_RealDef;
   _FileDef      : GetType:=_FileDef;
   _StringDef    : GetType:=_StringDef;
   _PointerDef   : GetType:=_PointerDef;
   _RecordDef    : GetType:=_RecordDef;
   else begin
          Error('[GetType] -> Cannot determine variable type');
        end;
   end;
end;

procedure CreateConstantList(var l:ConstantList);
begin
  l.first:=NIL;
  l.rear :=NIL;
end;

function GetConstant(l :ConstantList; name: string):pConstantRecord;
{searches backwards}
var con: pConstantRecord;

begin
  con := l.rear;
  GetConstant:=con;
  if con<>NIL then
  while (con <> NIL) and (name=con^.s^) and (con<>l.first) do
    begin
      con := con^.prev;
    end;
  if con^.s^=name then
    GetConstant:=con
  else
    GetConstant:=NIL;
end;


function AddConstant(var l:ConstantList;con: pConstantRecord; dup:boolean):pstring;

var dummy, temp : pConstantRecord;

begin
  dummy:=NIL;
  if con^.c=_StringConst then dummy:=GetConstant(l, con^.s^);

  if (dup=TRUE) and (dummy<>NIL) and (dummy^.id<>NIL) then
    AddConstant:=dummy^.id
  else
    begin
      temp := con;                {Update pointer to data}
      temp^.next := nil;
      temp^.prev := L.Rear;
      if (L.Rear = NIL) then      {If empty list...}
        begin
          L.First := temp;       {Add as first node}
          L.Rear := temp;
        end
      else                    {else add at end}
        begin
          L.Rear^.Next := temp;  {Make old rear of list point to new}
          L.Rear := temp;        {Make rear point to new node}
        end;
      inc(ConstantCount);
      if temp^.id=NIL then temp^.id:=getmemstring('C'+Numb(ConstantCount));
      AddConstant:=temp^.id;
    end;
end;

procedure RemoveLastConstant(var L: ConstantList);

begin
  if (L.First <>NIL) and (L.Rear<>NIL) then
    if L.First^.next = nil then
      begin
        if L.First^.id<>NIL then freememstring(L.First^.id);
        if (L.First^.c=_StringConst) and
           (L.First^.s<>NIL) then freememstring(L.First^.s);
        Dispose(L.First);
        L.First := nil;
        L.Rear := nil;
      end
    else
      begin
        L.Rear := L.Rear^.prev;
        if L.Rear^.next^.id<>NIL then freememstring(L.Rear^.next^.id);
        if (L.Rear^.next^.c=_StringConst) and
           (L.Rear^.next^.s<>NIL) then freememstring(L.Rear^.next^.s);
        Dispose(L.Rear^.next);
        L.Rear^.next:=Nil;
      end;
end;

procedure DestroyConstantList(var L: ConstantList);
begin
  while L.First <> nil do  {While still nodes left}
    RemoveLastConstant(L); {Remove last node}

  l.first:=NIL;            {Reset values}
  l.rear:=NIL;
end;

begin
end.