* Current work of symtable integration committed. The symtable can be

  activated by defining 'newst', but doesn't compile yet. Changes in type
  checking and oop are completed. What is left is to write a new
  symtablestack and adapt the parser to use it.

compiler/aasm.pas

@@ -817,7 +817,11 @@ uses
 
     constructor tasmsymbol.init(const s:string;_typ:TAsmsymtype);
       begin;
+      {$IFDEF NEWST}
+        inherited init(s);
+      {$ELSE}
         inherited initname(s);
+      {$ENDIF NEWST}
         reset;
         orgtyp:=_typ;
         typ:=_typ;
@@ -1044,7 +1048,13 @@ uses
 end.
 {
   $Log$
-  Revision 1.78  2000-02-18 20:53:14  pierre
+  Revision 1.79  2000-02-28 17:23:56  daniel
+  * Current work of symtable integration committed. The symtable can be
+    activated by defining 'newst', but doesn't compile yet. Changes in type
+    checking and oop are completed. What is left is to write a new
+    symtablestack and adapt the parser to use it.
+
+  Revision 1.78  2000/02/18 20:53:14  pierre
     * fixes a stabs problem for functions
     + includes a stabs local var for with statements
       the name is with in lowercase followed by an index

compiler/export.pas

@@ -25,7 +25,7 @@ unit export;
 interface
 
 uses
-  cobjects,symtable;
+  cobjects{$IFDEF NEWST},objects{$ENDIF NEWST},symtable;
 
 const
    { export options }
@@ -213,7 +213,13 @@ end;
 end.
 {
   $Log$
-  Revision 1.11  2000-02-09 13:22:52  peter
+  Revision 1.12  2000-02-28 17:23:56  daniel
+  * Current work of symtable integration committed. The symtable can be
+    activated by defining 'newst', but doesn't compile yet. Changes in type
+    checking and oop are completed. What is left is to write a new
+    symtablestack and adapt the parser to use it.
+
+  Revision 1.11  2000/02/09 13:22:52  peter
     * log truncated
 
   Revision 1.10  2000/01/12 10:34:29  peter

compiler/files.pas

@@ -47,8 +47,8 @@ unit files;
   interface
 
     uses
-       globtype,
-       cobjects,globals,ppu;
+       globtype,cobjects,globals,ppu
+       {$IFDEF NEWST},objects{$ENDIF};
 
     const
 {$ifdef FPC}
@@ -126,6 +126,15 @@ unit files;
           function  get_file_path(l :longint):string;
        end;
 
+    {$IFDEF NEWST}
+       Plinkitem=^Tlinkitem;
+       Tlinkitem=object(Tobject)
+          data     : pstring;
+          needlink : longint;
+          constructor init(const s:string;m:longint);
+          destructor  done;virtual;
+       end;
+    {$ELSE}
        plinkcontaineritem=^tlinkcontaineritem;
        tlinkcontaineritem=object(tcontaineritem)
           data     : pstring;
@@ -142,6 +151,7 @@ unit files;
           function getusemask(mask:longint) : string;
           function find(const s:string):boolean;
        end;
+    {$ENDIF NEWST}
 
 {$ifndef NEWMAP}
        tunitmap = array[0..maxunits-1] of pointer;
@@ -190,12 +200,21 @@ unit files;
           sourcefiles   : pfilemanager;
           resourcefiles : tstringcontainer;
 
+       {$IFDEF NEWST}
+          linkunitofiles,
+          linkunitstaticlibs,
+          linkunitsharedlibs,
+          linkotherofiles,           { objects,libs loaded from the source }
+          linkothersharedlibs,       { using $L or $LINKLIB or import lib (for linux) }
+          linkotherstaticlibs  : Tcollection;
+       {$ELSE}
           linkunitofiles,
           linkunitstaticlibs,
           linkunitsharedlibs,
           linkotherofiles,           { objects,libs loaded from the source }
           linkothersharedlibs,       { using $L or $LINKLIB or import lib (for linux) }
           linkotherstaticlibs  : tlinkcontainer;
+       {$ENDIF NEWST}
 
           used_units           : tlinkedlist;
           dependent_units      : tlinkedlist;
@@ -275,7 +294,7 @@ uses
    dos,
 {$endif Delphi}
   verbose,systems,
-  symtable,scanner;
+  symtable,scanner{$IFDEF NEWST},symtablt{$ENDIF};
 
 {****************************************************************************
                                   TINPUTFILE
@@ -703,6 +722,20 @@ uses
                              TLinkContainerItem
  ****************************************************************************}
 
+{$IFDEF NEWST}
+constructor TLinkItem.Init(const s:string;m:longint);
+begin
+  inherited Init;
+  data:=stringdup(s);
+  needlink:=m;
+end;
+
+
+destructor TLinkItem.Done;
+begin
+  stringdispose(data);
+end;
+{$ELSE}
 constructor TLinkContainerItem.Init(const s:string;m:longint);
 begin
   inherited Init;
@@ -715,12 +748,14 @@ destructor TLinkContainerItem.Done;
 begin
   stringdispose(data);
 end;
+{$ENDIF NEWST}
 
 
 {****************************************************************************
                            TLinkContainer
  ****************************************************************************}
 
+ {$IFNDEF NEWST}
     constructor TLinkContainer.Init;
       begin
         inherited init;
@@ -791,6 +826,7 @@ end;
            newnode:=plinkcontaineritem(newnode^.next);
          end;
       end;
+    {$ENDIF NEWST}
 
 
 
@@ -1034,7 +1070,11 @@ end;
 
          Function SearchPathList(list:TSearchPathList):boolean;
          var
+         {$IFDEF NEWST}
+           hp : PStringItem;
+         {$ELSE NEWST}
            hp : PStringQueueItem;
+         {$ENDIF NEWST}
            found : boolean;
          begin
            found:=false;
@@ -1131,17 +1171,17 @@ end;
         resourcefiles.done;
         resourcefiles.init;
         linkunitofiles.done;
-        linkunitofiles.init;
+        linkunitofiles.init{$IFDEF NEWST}(8,4){$ENDIF};
         linkunitstaticlibs.done;
-        linkunitstaticlibs.init;
+        linkunitstaticlibs.init{$IFDEF NEWST}(8,4){$ENDIF};
         linkunitsharedlibs.done;
-        linkunitsharedlibs.init;
+        linkunitsharedlibs.init{$IFDEF NEWST}(8,4){$ENDIF};
         linkotherofiles.done;
-        linkotherofiles.init;
+        linkotherofiles.init{$IFDEF NEWST}(8,4){$ENDIF};
         linkotherstaticlibs.done;
-        linkotherstaticlibs.init;
+        linkotherstaticlibs.init{$IFDEF NEWST}(8,4){$ENDIF};
         linkothersharedlibs.done;
-        linkothersharedlibs.init;
+        linkothersharedlibs.init{$IFDEF NEWST}(8,4){$ENDIF};
         uses_imports:=false;
         do_assemble:=false;
         do_compile:=false;
@@ -1200,12 +1240,12 @@ end;
         dependent_units.init;
         new(sourcefiles,init);
         resourcefiles.init;
-        linkunitofiles.init;
-        linkunitstaticlibs.init;
-        linkunitsharedlibs.init;
-        linkotherofiles.init;
-        linkotherstaticlibs.init;
-        linkothersharedlibs.init;
+        linkunitofiles.init{$IFDEF NEWST}(8,4){$ENDIF};
+        linkunitstaticlibs.init{$IFDEF NEWST}(8,4){$ENDIF};
+        linkunitsharedlibs.init{$IFDEF NEWST}(8,4){$ENDIF};
+        linkotherofiles.init{$IFDEF NEWST}(8,4){$ENDIF};
+        linkotherstaticlibs.init{$IFDEF NEWST}(8,4){$ENDIF};
+        linkothersharedlibs.init{$IFDEF NEWST}(8,4){$ENDIF};
         ppufile:=nil;
         scanner:=nil;
         map:=nil;
@@ -1353,7 +1393,13 @@ end;
 end.
 {
   $Log$
-  Revision 1.116  2000-02-24 18:41:38  peter
+  Revision 1.117  2000-02-28 17:23:56  daniel
+  * Current work of symtable integration committed. The symtable can be
+    activated by defining 'newst', but doesn't compile yet. Changes in type
+    checking and oop are completed. What is left is to write a new
+    symtablestack and adapt the parser to use it.
+
+  Revision 1.116  2000/02/24 18:41:38  peter
     * removed warnings/notes
 
   Revision 1.115  2000/02/10 16:00:23  peter

compiler/globals.pas

@@ -1038,7 +1038,11 @@ implementation
        CurrentDir,
        CurrPath : string;
        dir      : searchrec;
+   {$IFDEF NEWST}
+       hp       : PStringItem;
+   {$ELSE}
        hp       : PStringQueueItem;
+   {$ENDIF}
 
        procedure addcurrpath;
        begin
@@ -1130,7 +1134,11 @@ implementation
      var
        s : string;
        hl : TSearchPathList;
+     {$IFDEF NEWST}
+       hp,hp2 : PStringItem;
+     {$ELSE}
        hp,hp2 : PStringQueueItem;
+     {$ENDIF}
      begin
        if list.empty then
         exit;
@@ -1169,7 +1177,11 @@ implementation
 
    function TSearchPathList.FindFile(const f : string;var b : boolean) : string;
      Var
+     {$IFDEF NEWST}
+       p : PStringItem;
+     {$ELSE}
        p : PStringQueueItem;
+     {$ENDIF}
      begin
        FindFile:='';
        b:=false;
@@ -1525,7 +1537,13 @@ begin
 end.
 {
   $Log$
-  Revision 1.53  2000-02-14 20:58:44  marco
+  Revision 1.54  2000-02-28 17:23:57  daniel
+  * Current work of symtable integration committed. The symtable can be
+    activated by defining 'newst', but doesn't compile yet. Changes in type
+    checking and oop are completed. What is left is to write a new
+    symtablestack and adapt the parser to use it.
+
+  Revision 1.53  2000/02/14 20:58:44  marco
    * Basic structures for new sethandling implemented.
 
   Revision 1.52  2000/02/10 11:45:48  peter

compiler/globtype.pas

@@ -164,6 +164,24 @@ interface
        pword      = ^word;
        plongint   = ^longint;
 
+    {$IFDEF TP}
+       Tconstant=record
+            case signed:boolean of
+                false:
+                    (valueu:longint);
+                true:
+                    (values:longint);
+       end;
+    {$ELSE}
+       Tconstant=record
+            case signed:boolean of
+                false:
+                    (valueu:cardinal);
+                true:
+                    (values:longint);
+       end;
+    {$ENDIF}
+
     const
        { link options }
        link_none    = $0;
@@ -180,7 +198,13 @@ begin
 end.
 {
   $Log$
-  Revision 1.28  2000-02-09 13:22:53  peter
+  Revision 1.29  2000-02-28 17:23:57  daniel
+  * Current work of symtable integration committed. The symtable can be
+    activated by defining 'newst', but doesn't compile yet. Changes in type
+    checking and oop are completed. What is left is to write a new
+    symtablestack and adapt the parser to use it.
+
+  Revision 1.28  2000/02/09 13:22:53  peter
     * log truncated
 
   Revision 1.27  2000/02/09 10:35:48  peter

compiler/import.pas

@@ -23,7 +23,7 @@ unit import;
 interface
 
 uses
-  cobjects;
+  cobjects{$IFDEF NEWST},objects{$ENDIF NEWST};
 
 type
    pimported_item = ^timported_item;
@@ -250,7 +250,13 @@ end;
 end.
 {
   $Log$
-  Revision 1.18  2000-02-09 13:22:54  peter
+  Revision 1.19  2000-02-28 17:23:57  daniel
+  * Current work of symtable integration committed. The symtable can be
+    activated by defining 'newst', but doesn't compile yet. Changes in type
+    checking and oop are completed. What is left is to write a new
+    symtablestack and adapt the parser to use it.
+
+  Revision 1.18  2000/02/09 13:22:54  peter
     * log truncated
 
   Revision 1.17  2000/01/12 10:34:29  peter

compiler/link.pas

@@ -159,6 +159,30 @@ end;
 procedure TLinker.AddModuleFiles(hp:pmodule);
 var
   mask : longint;
+
+  {$IFDEF NEWST}
+  procedure addobj(action:pointer);{$IFDEF TP}far;{$ENDIF}
+
+  begin
+    if Plinkitem(action)^.needlink and mask<>0 then
+        addobject(Plinkitem(action)^.data^);
+  end;
+
+  procedure addstat(action:pointer);{$IFDEF TP}far;{$ENDIF}
+
+  begin
+    if Plinkitem(action)^.needlink and mask<>0 then
+        addstaticlibrary(Plinkitem(action)^.data^);
+  end;
+
+  procedure addshar(action:pointer);{$IFDEF TP}far;{$ENDIF}
+
+  begin
+    if Plinkitem(action)^.needlink and mask<>0 then
+        addsharedlibrary(Plinkitem(action)^.data^);
+  end;
+  {$ENDIF NEWST}
+
 begin
   with hp^ do
    begin
@@ -227,21 +251,39 @@ begin
            mask:=mask or link_static;
          end;
         { unit files }
+      {$IFDEF NEWST}
+        linkunitofiles.foreach(@addobj);
+        linkunitofiles.freeall;
+        linkunitstaticlibs.foreach(@addstat);
+        linkunitstaticlibs.freeall;
+        linkunitsharedlibs.foreach(@addshar);
+        linkunitsharedlibs.freeall;
+      {$ELSE}
         while not linkunitofiles.empty do
          AddObject(linkunitofiles.getusemask(mask));
         while not linkunitstaticlibs.empty do
          AddStaticLibrary(linkunitstaticlibs.getusemask(mask));
         while not linkunitsharedlibs.empty do
          AddSharedLibrary(linkunitsharedlibs.getusemask(mask));
+      {$ENDIF NEWST}
       end;
    { Other needed .o and libs, specified using $L,$LINKLIB,external }
      mask:=link_allways;
+   {$IFDEF NEWST}
+     linkotherofiles.foreach(@addobj);
+     linkotherofiles.freeall;
+     linkotherstaticlibs.foreach(@addstat);
+     linkotherstaticlibs.freeall;
+     linkothersharedlibs.foreach(@addshar);
+     linkothersharedlibs.freeall;
+   {$ELSE}
      while not linkotherofiles.empty do
       AddObject(linkotherofiles.Getusemask(mask));
      while not linkotherstaticlibs.empty do
       AddStaticLibrary(linkotherstaticlibs.Getusemask(mask));
      while not linkothersharedlibs.empty do
       AddSharedLibrary(linkothersharedlibs.Getusemask(mask));
+   {$ENDIF NEWST}
    end;
 end;
 
@@ -521,7 +563,13 @@ end;
 end.
 {
   $Log$
-  Revision 1.84  2000-02-24 18:41:39  peter
+  Revision 1.85  2000-02-28 17:23:57  daniel
+  * Current work of symtable integration committed. The symtable can be
+    activated by defining 'newst', but doesn't compile yet. Changes in type
+    checking and oop are completed. What is left is to write a new
+    symtablestack and adapt the parser to use it.
+
+  Revision 1.84  2000/02/24 18:41:39  peter
     * removed warnings/notes
 
   Revision 1.83  2000/02/09 13:22:54  peter

compiler/new/cgbase.pas

@@ -25,7 +25,11 @@ unit cgbase;
   interface
 
     uses
-       globtype,cobjects,aasm,symconst,symtable,verbose,tree,cpuasm,cpubase;
+       globtype,cobjects,aasm,symconst,symtable,verbose,tree,
+       cpuasm,cpubase
+       {$IFDEF NEWST}
+       ,defs,symbols
+       {$ENDIF NEWST};
 
     const
        pi_uses_asm  = $1;       { set, if the procedure uses asm }
@@ -56,7 +60,9 @@ unit cgbase;
           { current class, if we are in a method }
           _class : pobjectdef;
           { return type }
+       {$IFNDEF NEWST}
           returntype : ttype;
+       {$ENDIF NEWST}
           { symbol of the function, and the sym for result variable }
           resultfuncretsym,
           funcretsym : pfuncretsym;
@@ -319,7 +325,9 @@ unit cgbase;
       begin
         parent:=nil;
         _class:=nil;
+        {$IFNDEF NEWST}
         returntype.reset;
+        {$ENDIF NEWST}
         resultfuncretsym:=nil;
         funcretsym:=nil;
         funcret_state:=vs_none;
@@ -515,7 +523,13 @@ unit cgbase;
 end.
 {
   $Log$
-  Revision 1.17  2000-02-20 20:49:46  florian
+  Revision 1.18  2000-02-28 17:23:58  daniel
+  * Current work of symtable integration committed. The symtable can be
+    activated by defining 'newst', but doesn't compile yet. Changes in type
+    checking and oop are completed. What is left is to write a new
+    symtablestack and adapt the parser to use it.
+
+  Revision 1.17  2000/02/20 20:49:46  florian
     * newcg is compiling
     * fixed the dup id problem reported by Paul Y.
 

compiler/new/symtable/cobjects.pas

@@ -0,0 +1,2099 @@
+{
+    $Id$
+    Copyright (c) 1993-98 by Florian Klaempfl
+
+    This module provides some basic objects
+
+    This program is free software; you can redistribute it and/or modify
+    it under the terms of the GNU General Public License as published by
+    the Free Software Foundation; either version 2 of the License, or
+    (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU General Public License for more details.
+
+    You should have received a copy of the GNU General Public License
+    along with this program; if not, write to the Free Software
+    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ ****************************************************************************
+}
+
+{$ifdef tp}
+  {$E+,N+,D+,F+}
+{$endif}
+{$I-}
+{$R-}{ necessary for crc calculation }
+
+unit cobjects;
+
+
+interface
+
+uses    strings,objects
+{$ifndef linux}
+       ,dos
+{$else}
+       ,linux
+{$endif}
+      ;
+
+    const
+       { the real size will be [-hasharray..hasharray] ! }
+{$ifdef TP}
+       hasharraysize = 127;
+{$else}
+       hasharraysize = 2047;
+{$endif}
+
+
+{$ifdef TP}
+       { redeclare dword only in case of emergency, some small things
+         of the compiler won't work then correctly (FK)
+       }
+type   dword = longint;
+{$endif TP}
+
+type   pfileposinfo = ^tfileposinfo;
+       tfileposinfo = record
+         line      : longint;
+         column    : word;
+         fileindex : word;
+       end;
+
+
+       { some help data types }
+       pstringitem = ^tstringitem;
+       tstringitem = record
+          data : pstring;
+          next : pstringitem;
+          fileinfo : tfileposinfo; { pointer to tinputfile }
+       end;
+
+       plinkedlist_item = ^tlinkedlist_item;
+       tlinkedlist_item = object(Tobject)
+          next,previous : plinkedlist_item;
+          function getcopy:plinkedlist_item;virtual;
+       end;
+
+       pstring_item = ^tstring_item;
+       tstring_item = object(tlinkedlist_item)
+          str : pstring;
+          constructor init(const s : string);
+          destructor done;virtual;
+       end;
+
+
+       { this implements a double linked list }
+       plinkedlist = ^tlinkedlist;
+       tlinkedlist = object(Tobject)
+          first,last : plinkedlist_item;
+          destructor done;virtual;
+
+          { disposes the items of the list }
+          procedure clear;
+
+          { concats a new item at the end }
+          procedure concat(p : plinkedlist_item);
+
+          { inserts a new item at the begin }
+          procedure insert(p : plinkedlist_item);
+
+          { inserts another list at the begin and make this list empty }
+          procedure insertlist(p : plinkedlist);
+
+          { concats another list at the end and make this list empty }
+          procedure concatlist(p : plinkedlist);
+
+          procedure concatlistcopy(p : plinkedlist);
+
+          { removes p from the list (p isn't disposed) }
+          { it's not tested if p is in the list !      }
+          procedure remove(p : plinkedlist_item);
+
+          { is the linkedlist empty ? }
+          function  empty:boolean;
+       end;
+
+
+       { String Queue}
+       PStringQueue=^TStringQueue;
+       TStringQueue=object(Tobject)
+         first,last : PStringItem;
+         destructor Done;virtual;
+         function Empty:boolean;
+         function Get:string;
+         function Find(const s:string):PStringItem;
+         function Delete(const s:string):boolean;
+         procedure Insert(const s:string);
+         procedure Concat(const s:string);
+         procedure Clear;
+       end;
+
+
+       { string container }
+       pstringcontainer = ^tstringcontainer;
+       tstringcontainer = object(Tobject)
+          root,
+          last    : pstringitem;
+          doubles : boolean;  { if this is set to true, doubles are allowed }
+          constructor init;
+          constructor init_no_double;
+          destructor done;virtual;
+
+          { true when the container is empty }
+          function empty:boolean;
+
+          { inserts a string }
+          procedure insert(const s : string);
+          procedure insert_with_tokeninfo(const s : string;const file_info : tfileposinfo);
+
+          { gets a string }
+          function get : string;
+          function get_with_tokeninfo(var file_info : tfileposinfo) : string;
+
+          { true if string is in the container }
+          function find(const s:string):boolean;
+
+          { deletes all strings }
+          procedure clear;
+       end;
+
+
+       Pnamedindexobject=^Tnamedindexobject;
+       Tnamedindexobject=object(Tobject)
+         indexnr    : longint;
+         _name      : Pstring;
+         next,
+         left,right : Pnamedindexobject;
+         speedvalue : longint;
+         {Note: Initname was changed to init. Init without a name is
+                undesired, the object is called _named_ index object.}
+         constructor init(const n:string);
+         destructor  done;virtual;
+         procedure setname(const n:string);virtual;
+         function  name:string;virtual;
+       end;
+
+       Pdictionaryhasharray=^Tdictionaryhasharray;
+       Tdictionaryhasharray=array[-hasharraysize..hasharraysize] of Pnamedindexobject;
+
+       Tnamedindexcallback = procedure(p:Pnamedindexobject);
+
+       Pdictionary=^Tdictionary;
+       Tdictionary=object(Tobject)
+         replace_existing : boolean;
+         constructor init;
+         destructor  done;virtual;
+         procedure usehash;
+         procedure clear;
+         function  empty:boolean;
+         procedure foreach(proc2call:Tnamedindexcallback);
+         function  insert(obj:Pnamedindexobject):Pnamedindexobject;
+         function  rename(const olds,news : string):Pnamedindexobject;
+         function  search(const s:string):Pnamedindexobject;
+         function  speedsearch(const s:string;speedvalue:longint):Pnamedindexobject;
+       private
+         root      : Pnamedindexobject;
+         hasharray : Pdictionaryhasharray;
+         procedure cleartree(obj:Pnamedindexobject);
+         function  insertnode(newnode:Pnamedindexobject;var currnode:Pnamedindexobject):Pnamedindexobject;
+         function delete(const s:string):Pnamedindexobject;
+         procedure inserttree(currtree,currroot:Pnamedindexobject);
+       end;
+
+       pdynamicarray = ^tdynamicarray;
+       tdynamicarray = object(Tobject)
+         posn,
+         count,
+         limit,
+         elemlen,
+         growcount : longint;
+         data      : pchar;
+         constructor init(Aelemlen,Agrow:longint);
+         destructor  done;virtual;
+         function  size:longint;
+         function  usedsize:longint;
+         procedure grow;
+         procedure align(i:longint);
+         procedure seek(i:longint);
+         procedure write(var d;len:longint);
+         procedure read(var d;len:longint);
+         procedure writepos(pos:longint;var d;len:longint);
+         procedure readpos(pos:longint;var d;len:longint);
+       end;
+
+{$ifdef BUFFEREDFILE}
+       { this is implemented to allow buffered binary I/O }
+       pbufferedfile = ^tbufferedfile;
+       tbufferedfile = object(Tobject)
+           f : file;
+           buf : pchar;
+           bufsize,buflast,bufpos : longint;
+
+           { 0 closed, 1 input, 2 output }
+           iomode : byte;
+
+           { true, if the compile should change the endian of the output }
+           change_endian : boolean;
+
+           { calcules a crc for the file,                                    }
+           { but it's assumed, that there no seek while do_crc is true       }
+           do_crc : boolean;
+           crc : longint;
+           { temporary closing feature }
+           tempclosed : boolean;
+           tempmode : byte;
+           temppos : longint;
+
+           { inits a buffer with the size bufsize which is assigned to }
+           { the file  filename                                        }
+           constructor init(const filename : string;_bufsize : longint);
+
+           { closes the file, if needed, and releases the memory }
+           destructor done;virtual;
+
+           { opens the file for input, other accesses are rejected }
+           function  reset:boolean;
+
+           { opens the file for output, other accesses are rejected }
+           procedure rewrite;
+
+           { reads or writes the buffer from or to disk }
+           procedure flush;
+
+           { writes a string to the file }
+           { the string is written without a length byte }
+           procedure write_string(const s : string);
+
+           { writes a zero terminated string }
+           procedure write_pchar(p : pchar);
+
+           { write specific data types, takes care of }
+           { byte order                               }
+           procedure write_byte(b : byte);
+           procedure write_word(w : word);
+           procedure write_long(l : longint);
+           procedure write_double(d : double);
+
+           { writes any data }
+           procedure write_data(var data;count : longint);
+
+           { reads any data }
+           procedure read_data(var data;bytes : longint;var count : longint);
+
+           { closes the file and releases the buffer }
+           procedure close;
+
+           { temporary closing }
+           procedure tempclose;
+           procedure tempreopen;
+
+           { goto the given position }
+           procedure seek(l : longint);
+
+           { installes an user defined buffer      }
+           { and releases the old one, but be      }
+           { careful, if the old buffer contains   }
+           { data, this data is lost               }
+           procedure setbuf(p : pchar;s : longint);
+
+           { reads the file time stamp of the file, }
+           { the file must be opened                }
+           function getftime : longint;
+
+           { returns filesize }
+           function getsize : longint;
+
+           { returns the path }
+           function getpath : string;
+
+           { resets the crc }
+           procedure clear_crc;
+
+           { returns the crc }
+           function getcrc : longint;
+       end;
+{$endif BUFFEREDFILE}
+
+    function getspeedvalue(const s : string) : longint;
+
+    { releases the string p and assignes nil to p }
+    { if p=nil then freemem isn't called          }
+    procedure stringdispose(var p : pstring);
+
+    { idem for ansistrings }
+    procedure ansistringdispose(var p : pchar;length : longint);
+
+    { allocates mem for a copy of s, copies s to this mem and returns }
+    { a pointer to this mem                                           }
+    function stringdup(const s : string) : pstring;
+
+    { allocates memory for s and copies s as zero terminated string
+      to that mem and returns a pointer to that mem }
+    function strpnew(const s : string) : pchar;
+
+    { makes a char lowercase, with spanish, french and german char set }
+    function lowercase(c : char) : char;
+
+    { makes zero terminated string to a pascal string }
+    { the data in p is modified and p is returned     }
+    function pchar2pstring(p : pchar) : pstring;
+
+    { ambivalent to pchar2pstring }
+    function pstring2pchar(p : pstring) : pchar;
+
+  implementation
+
+{$ifndef OLDSPEEDVALUE}
+
+{*****************************************************************************
+                                   Crc 32
+*****************************************************************************}
+
+var
+{$ifdef Delphi}
+  Crc32Tbl : array[0..255] of longword;
+{$else Delphi}
+  Crc32Tbl : array[0..255] of longint;
+{$endif Delphi}
+
+procedure MakeCRC32Tbl;
+var
+{$ifdef Delphi}
+  crc : longword;
+{$else Delphi}
+  crc : longint;
+{$endif Delphi}
+  i,n : byte;
+begin
+  for i:=0 to 255 do
+   begin
+     crc:=i;
+     for n:=1 to 8 do
+      if odd(crc) then
+       crc:=(crc shr 1) xor $edb88320
+      else
+       crc:=crc shr 1;
+     Crc32Tbl[i]:=crc;
+   end;
+end;
+
+
+{$ifopt R+}
+  {$define Range_check_on}
+{$endif opt R+}
+
+{$R- needed here }
+{CRC 32}
+Function GetSpeedValue(Const s:String):longint;
+var
+  i,InitCrc : longint;
+begin
+  if Crc32Tbl[1]=0 then
+   MakeCrc32Tbl;
+  InitCrc:=$ffffffff;
+  for i:=1to Length(s) do
+   InitCrc:=Crc32Tbl[byte(InitCrc) xor ord(s[i])] xor (InitCrc shr 8);
+  GetSpeedValue:=InitCrc;
+end;
+
+{$ifdef Range_check_on}
+  {$R+}
+  {$undef Range_check_on}
+{$endif Range_check_on}
+
+{$else}
+
+{$ifndef TP}
+    function getspeedvalue(const s : string) : longint;
+      var
+        p1,p2:^byte;
+        i : longint;
+
+      begin
+        p1:=@s;
+        longint(p2):=longint(p1)+p1^+1;
+        inc(longint(p1));
+        i:=0;
+        while p1<>p2 do
+         begin
+           i:=i + ord(p1^);
+           inc(longint(p1));
+         end;
+        getspeedvalue:=i;
+      end;
+{$else}
+    function getspeedvalue(const s : string) : longint;
+      type
+        ptrrec=record
+          ofs,seg:word;
+        end;
+      var
+        l,w   : longint;
+        p1,p2 : ^byte;
+      begin
+        p1:=@s;
+        ptrrec(p2).seg:=ptrrec(p1).seg;
+        ptrrec(p2).ofs:=ptrrec(p1).ofs+p1^+1;
+        inc(p1);
+        l:=0;
+        while p1<>p2 do
+         begin
+           l:=l + ord(p1^);
+           inc(p1);
+         end;
+        getspeedvalue:=l;
+      end;
+{$endif}
+
+{$endif OLDSPEEDVALUE}
+
+
+    function pchar2pstring(p : pchar) : pstring;
+      var
+         w,i : longint;
+      begin
+         w:=strlen(p);
+         for i:=w-1 downto 0 do
+           p[i+1]:=p[i];
+         p[0]:=chr(w);
+         pchar2pstring:=pstring(p);
+      end;
+
+
+    function pstring2pchar(p : pstring) : pchar;
+      var
+         w,i : longint;
+      begin
+         w:=length(p^);
+         for i:=1 to w do
+           p^[i-1]:=p^[i];
+         p^[w]:=#0;
+         pstring2pchar:=pchar(p);
+      end;
+
+
+    function lowercase(c : char) : char;
+       begin
+          case c of
+             #65..#90 : c := chr(ord (c) + 32);
+             #154 : c:=#129;  { german }
+             #142 : c:=#132;  { german }
+             #153 : c:=#148;  { german }
+             #144 : c:=#130;  { french }
+             #128 : c:=#135;  { french }
+             #143 : c:=#134;  { swedish/norge (?) }
+             #165 : c:=#164;  { spanish }
+             #228 : c:=#229;  { greek }
+             #226 : c:=#231;  { greek }
+             #232 : c:=#227;  { greek }
+          end;
+          lowercase := c;
+       end;
+
+
+    function strpnew(const s : string) : pchar;
+      var
+         p : pchar;
+      begin
+         getmem(p,length(s)+1);
+         strpcopy(p,s);
+         strpnew:=p;
+      end;
+
+
+    procedure stringdispose(var p : pstring);
+      begin
+         if assigned(p) then
+           freemem(p,length(p^)+1);
+         p:=nil;
+      end;
+
+
+    procedure ansistringdispose(var p : pchar;length : longint);
+      begin
+         if assigned(p) then
+           freemem(p,length+1);
+         p:=nil;
+      end;
+
+
+    function stringdup(const s : string) : pstring;
+      var
+         p : pstring;
+      begin
+         getmem(p,length(s)+1);
+         p^:=s;
+         stringdup:=p;
+      end;
+
+
+{****************************************************************************
+                                  TStringQueue
+****************************************************************************}
+
+function TStringQueue.Empty:boolean;
+begin
+  Empty:=(first=nil);
+end;
+
+
+function TStringQueue.Get:string;
+var
+  newnode : pstringitem;
+begin
+  if first=nil then
+   begin
+     Get:='';
+     exit;
+   end;
+  Get:=first^.data^;
+  stringdispose(first^.data);
+  newnode:=first;
+  first:=first^.next;
+  dispose(newnode);
+end;
+
+
+procedure TStringQueue.Insert(const s:string);
+var
+  newnode : pstringitem;
+begin
+  new(newnode);
+  newnode^.next:=first;
+  newnode^.data:=stringdup(s);
+  first:=newnode;
+  if last=nil then
+   last:=newnode;
+end;
+
+
+function TStringQueue.Delete(const s:string):boolean;
+var
+  prev,p : PStringItem;
+begin
+  Delete:=false;
+  prev:=nil;
+  p:=first;
+  while assigned(p) do
+   begin
+     if p^.data^=s then
+      begin
+        if p=last then
+          last:=prev;
+        if assigned(prev) then
+         prev^.next:=p^.next
+        else
+         first:=p^.next;
+        dispose(p);
+        Delete:=true;
+        exit;
+      end;
+     prev:=p;
+     p:=p^.next;
+   end;
+end;
+
+function TStringQueue.Find(const s:string):PStringItem;
+var
+  p : PStringItem;
+begin
+  p:=first;
+  while assigned(p) do
+   begin
+     if p^.data^=s then
+      break;
+     p:=p^.next;
+   end;
+  Find:=p;
+end;
+
+procedure TStringQueue.Concat(const s:string);
+var
+  newnode : pstringitem;
+begin
+  new(newnode);
+  newnode^.next:=nil;
+  newnode^.data:=stringdup(s);
+  if first=nil then
+   first:=newnode
+  else
+   last^.next:=newnode;
+  last:=newnode;
+end;
+
+
+procedure TStringQueue.Clear;
+var
+  newnode : pstringitem;
+begin
+  while (first<>nil) do
+   begin
+     newnode:=first;
+     stringdispose(first^.data);
+     first:=first^.next;
+     dispose(newnode);
+   end;
+end;
+
+
+destructor TStringQueue.Done;
+begin
+  Clear;
+end;
+
+{****************************************************************************
+                           TSTRINGCONTAINER
+ ****************************************************************************}
+
+    constructor tstringcontainer.init;
+      begin
+         inherited init;
+         doubles:=true;
+      end;
+
+
+    constructor tstringcontainer.init_no_double;
+      begin
+         doubles:=false;
+      end;
+
+
+    destructor tstringcontainer.done;
+      begin
+         clear;
+      end;
+
+
+    function tstringcontainer.empty:boolean;
+      begin
+        empty:=(root=nil);
+      end;
+
+
+    procedure tstringcontainer.insert(const s : string);
+      var
+        newnode : pstringitem;
+      begin
+         if not(doubles) then
+           begin
+              newnode:=root;
+              while assigned(newnode) do
+                begin
+                   if newnode^.data^=s then exit;
+                   newnode:=newnode^.next;
+                end;
+           end;
+         new(newnode);
+         newnode^.next:=nil;
+         newnode^.data:=stringdup(s);
+         if root=nil then root:=newnode
+           else last^.next:=newnode;
+         last:=newnode;
+      end;
+
+
+    procedure tstringcontainer.insert_with_tokeninfo(const s : string; const file_info : tfileposinfo);
+      var
+         newnode : pstringitem;
+      begin
+         if not(doubles) then
+           begin
+              newnode:=root;
+              while assigned(newnode) do
+                begin
+                   if newnode^.data^=s then exit;
+                   newnode:=newnode^.next;
+                end;
+           end;
+         new(newnode);
+         newnode^.next:=nil;
+         newnode^.data:=stringdup(s);
+         newnode^.fileinfo:=file_info;
+         if root=nil then root:=newnode
+           else last^.next:=newnode;
+         last:=newnode;
+      end;
+
+
+    procedure tstringcontainer.clear;
+      var
+         newnode : pstringitem;
+      begin
+         newnode:=root;
+         while assigned(newnode) do
+           begin
+              stringdispose(newnode^.data);
+              root:=newnode^.next;
+              dispose(newnode);
+              newnode:=root;
+           end;
+         last:=nil;
+         root:=nil;
+      end;
+
+
+    function tstringcontainer.get : string;
+      var
+         newnode : pstringitem;
+      begin
+         if root=nil then
+          get:=''
+         else
+          begin
+            get:=root^.data^;
+            newnode:=root;
+            root:=root^.next;
+            stringdispose(newnode^.data);
+            dispose(newnode);
+          end;
+      end;
+
+
+    function tstringcontainer.get_with_tokeninfo(var file_info : tfileposinfo) : string;
+      var
+         newnode : pstringitem;
+      begin
+         if root=nil then
+          begin
+             get_with_tokeninfo:='';
+             file_info.fileindex:=0;
+             file_info.line:=0;
+             file_info.column:=0;
+          end
+         else
+          begin
+            get_with_tokeninfo:=root^.data^;
+            newnode:=root;
+            root:=root^.next;
+            stringdispose(newnode^.data);
+            file_info:=newnode^.fileinfo;
+            dispose(newnode);
+          end;
+      end;
+
+
+    function tstringcontainer.find(const s:string):boolean;
+      var
+         newnode : pstringitem;
+      begin
+        find:=false;
+        newnode:=root;
+        while assigned(newnode) do
+         begin
+           if newnode^.data^=s then
+            begin
+              find:=true;
+              exit;
+            end;
+           newnode:=newnode^.next;
+         end;
+      end;
+
+
+{****************************************************************************
+                            TLINKEDLIST_ITEM
+ ****************************************************************************}
+
+
+    function tlinkedlist_item.getcopy:plinkedlist_item;
+      var
+        l : longint;
+        p : plinkedlist_item;
+      begin
+        l:=sizeof(self);
+        getmem(p,l);
+        move(self,p^,l);
+        getcopy:=p;
+      end;
+
+
+{****************************************************************************
+                            TSTRING_ITEM
+ ****************************************************************************}
+
+    constructor tstring_item.init(const s : string);
+      begin
+         inherited init;
+         str:=stringdup(s);
+      end;
+
+
+    destructor tstring_item.done;
+      begin
+         stringdispose(str);
+         inherited done;
+      end;
+
+
+{****************************************************************************
+                               TLINKEDLIST
+ ****************************************************************************}
+
+
+    destructor tlinkedlist.done;
+      begin
+         clear;
+      end;
+
+
+    procedure tlinkedlist.clear;
+      var
+         newnode : plinkedlist_item;
+      begin
+         newnode:=first;
+         while assigned(newnode) do
+           begin
+              first:=newnode^.next;
+              dispose(newnode,done);
+              newnode:=first;
+           end;
+      end;
+
+
+    procedure tlinkedlist.insertlist(p : plinkedlist);
+      begin
+         { empty list ? }
+         if not(assigned(p^.first)) then
+           exit;
+
+         p^.last^.next:=first;
+
+         { we have a double linked list }
+         if assigned(first) then
+           first^.previous:=p^.last;
+
+         first:=p^.first;
+
+         if not(assigned(last)) then
+           last:=p^.last;
+
+         { p becomes empty }
+         p^.first:=nil;
+         p^.last:=nil;
+      end;
+
+
+    procedure tlinkedlist.concat(p : plinkedlist_item);
+      begin
+        if not(assigned(first)) then
+         begin
+           first:=p;
+           p^.previous:=nil;
+           p^.next:=nil;
+         end
+        else
+         begin
+           last^.next:=p;
+           p^.previous:=last;
+           p^.next:=nil;
+         end;
+        last:=p;
+      end;
+
+
+    procedure tlinkedlist.insert(p : plinkedlist_item);
+      begin
+         if not(assigned(first)) then
+          begin
+            last:=p;
+            p^.previous:=nil;
+            p^.next:=nil;
+          end
+         else
+          begin
+            first^.previous:=p;
+            p^.previous:=nil;
+            p^.next:=first;
+          end;
+         first:=p;
+      end;
+
+
+    procedure tlinkedlist.remove(p : plinkedlist_item);
+      begin
+         if not(assigned(p)) then
+           exit;
+         if (first=p) and (last=p) then
+           begin
+              first:=nil;
+              last:=nil;
+           end
+         else if first=p then
+           begin
+              first:=p^.next;
+              if assigned(first) then
+                first^.previous:=nil;
+           end
+         else if last=p then
+           begin
+              last:=last^.previous;
+              if assigned(last) then
+                last^.next:=nil;
+           end
+         else
+           begin
+              p^.previous^.next:=p^.next;
+              p^.next^.previous:=p^.previous;
+           end;
+         p^.next:=nil;
+         p^.previous:=nil;
+      end;
+
+
+    procedure tlinkedlist.concatlist(p : plinkedlist);
+     begin
+         if not(assigned(p^.first)) then
+           exit;
+
+         if not(assigned(first)) then
+           first:=p^.first
+           else
+             begin
+                last^.next:=p^.first;
+                p^.first^.previous:=last;
+             end;
+
+         last:=p^.last;
+
+         { make p empty }
+         p^.last:=nil;
+         p^.first:=nil;
+      end;
+
+
+    procedure tlinkedlist.concatlistcopy(p : plinkedlist);
+      var
+        newnode,newnode2 : plinkedlist_item;
+      begin
+         newnode:=p^.first;
+         while assigned(newnode) do
+          begin
+            newnode2:=newnode^.getcopy;
+            if assigned(newnode2) then
+             begin
+               if not(assigned(first)) then
+                begin
+                  first:=newnode2;
+                  newnode2^.previous:=nil;
+                  newnode2^.next:=nil;
+                end
+               else
+                begin
+                  last^.next:=newnode2;
+                  newnode2^.previous:=last;
+                  newnode2^.next:=nil;
+                end;
+               last:=newnode2;
+             end;
+            newnode:=newnode^.next;
+          end;
+      end;
+
+    function tlinkedlist.empty:boolean;
+      begin
+        empty:=(first=nil);
+      end;
+
+
+{****************************************************************************
+                               Tnamedindexobject
+****************************************************************************}
+
+constructor Tnamedindexobject.init(const n:string);
+begin
+  inherited init;
+  { index }
+  indexnr:=-1;
+  { dictionary }
+  speedvalue:=-1;
+  _name:=stringdup(n);
+end;
+
+destructor Tnamedindexobject.done;
+begin
+  stringdispose(_name);
+end;
+
+procedure Tnamedindexobject.setname(const n:string);
+begin
+  if speedvalue=-1 then
+   begin
+     if assigned(_name) then
+       stringdispose(_name);
+     _name:=stringdup(n);
+   end;
+end;
+
+function Tnamedindexobject.name:string;
+begin
+  if assigned(_name) then
+   name:=_name^
+  else
+   name:='';
+end;
+
+
+{****************************************************************************
+                               TDICTIONARY
+****************************************************************************}
+
+    constructor Tdictionary.init;
+      begin
+        inherited init;
+        replace_existing:=false;
+      end;
+
+
+    procedure Tdictionary.usehash;
+      begin
+        if not(assigned(root)) and
+           not(assigned(hasharray)) then
+         begin
+           new(hasharray);
+           fillchar(hasharray^,sizeof(hasharray^),0);
+         end;
+      end;
+
+
+    destructor Tdictionary.done;
+      begin
+        clear;
+        if assigned(hasharray) then
+         dispose(hasharray);
+      end;
+
+
+    procedure Tdictionary.cleartree(obj:Pnamedindexobject);
+      begin
+        if assigned(obj^.left) then
+          cleartree(obj^.left);
+        if assigned(obj^.right) then
+          cleartree(obj^.right);
+        dispose(obj,done);
+        obj:=nil;
+      end;
+
+
+    procedure Tdictionary.clear;
+      var
+        w : longint;
+      begin
+        if assigned(root) then
+          cleartree(root);
+        if assigned(hasharray) then
+         for w:=-hasharraysize to hasharraysize do
+          if assigned(hasharray^[w]) then
+           cleartree(hasharray^[w]);
+      end;
+
+
+    function Tdictionary.empty:boolean;
+      var
+        w : longint;
+      begin
+        if assigned(hasharray) then
+         begin
+           empty:=false;
+           for w:=-hasharraysize to hasharraysize do
+            if assigned(hasharray^[w]) then
+             exit;
+           empty:=true;
+         end
+        else
+         empty:=(root=nil);
+      end;
+
+
+    procedure Tdictionary.foreach(proc2call:Tnamedindexcallback);
+
+        procedure a(p:Pnamedindexobject);
+        begin
+          proc2call(p);
+          if assigned(p^.left) then
+           a(p^.left);
+          if assigned(p^.right) then
+           a(p^.right);
+        end;
+
+      var
+        i : longint;
+      begin
+        if assigned(hasharray) then
+         begin
+           for i:=-hasharraysize to hasharraysize do
+            if assigned(hasharray^[i]) then
+             a(hasharray^[i]);
+         end
+        else
+         if assigned(root) then
+          a(root);
+      end;
+
+
+    function Tdictionary.insert(obj:Pnamedindexobject):Pnamedindexobject;
+      begin
+        obj^.speedvalue:=getspeedvalue(obj^._name^);
+        if assigned(hasharray) then
+         insert:=insertnode(obj,hasharray^[obj^.speedvalue mod hasharraysize])
+        else
+         insert:=insertnode(obj,root);
+      end;
+
+
+    function tdictionary.insertnode(newnode:Pnamedindexobject;var currnode:Pnamedindexobject):Pnamedindexobject;
+      var
+        s1,s2:^string;
+      begin
+        if currnode=nil then
+         begin
+           currnode:=newnode;
+           insertnode:=currnode;
+         end
+        { first check speedvalue, to allow a fast insert }
+        else
+         if currnode^.speedvalue>newnode^.speedvalue then
+          insertnode:=insertnode(newnode,currnode^.right)
+        else
+         if currnode^.speedvalue<newnode^.speedvalue then
+          insertnode:=insertnode(newnode,currnode^.left)
+        else
+         begin
+           new(s1);
+           new(s2);
+           s1^:=currnode^._name^;
+           s2^:=newnode^._name^;
+           if s1^>s2^ then
+            begin
+              dispose(s2);
+              dispose(s1);
+              insertnode:=insertnode(newnode,currnode^.right);
+            end
+           else
+            if s1^<s2^ then
+             begin
+               dispose(s2);
+               dispose(s1);
+               insertnode:=insertnode(newnode,currnode^.left);
+             end
+           else
+            begin
+              dispose(s2);
+              dispose(s1);
+              if replace_existing and
+                 assigned(currnode) then
+                begin
+                  newnode^.left:=currnode^.left;
+                  newnode^.right:=currnode^.right;
+                  currnode:=newnode;
+                  insertnode:=newnode;
+                end
+              else
+               insertnode:=currnode;
+             end;
+         end;
+      end;
+
+
+    procedure tdictionary.inserttree(currtree,currroot:Pnamedindexobject);
+      begin
+        if assigned(currtree) then
+         begin
+           inserttree(currtree^.left,currroot);
+           inserttree(currtree^.right,currroot);
+           currtree^.right:=nil;
+           currtree^.left:=nil;
+           insertnode(currtree,currroot);
+         end;
+      end;
+
+
+    function tdictionary.rename(const olds,news : string):Pnamedindexobject;
+      var
+        spdval : longint;
+        lasthp,
+        hp,hp2,hp3 : Pnamedindexobject;
+      begin
+        spdval:=getspeedvalue(olds);
+        if assigned(hasharray) then
+         hp:=hasharray^[spdval mod hasharraysize]
+        else
+         hp:=root;
+        lasthp:=nil;
+        while assigned(hp) do
+          begin
+            if spdval>hp^.speedvalue then
+             begin
+               lasthp:=hp;
+               hp:=hp^.left
+             end
+            else
+             if spdval<hp^.speedvalue then
+              begin
+                lasthp:=hp;
+                hp:=hp^.right
+              end
+            else
+             begin
+               if (hp^.name=olds) then
+                begin
+                  { get in hp2 the replacer for the root or hasharr }
+                  hp2:=hp^.left;
+                  hp3:=hp^.right;
+                  if not assigned(hp2) then
+                   begin
+                     hp2:=hp^.right;
+                     hp3:=hp^.left;
+                   end;
+                  { remove entry from the tree }
+                  if assigned(lasthp) then
+                   begin
+                     if lasthp^.left=hp then
+                      lasthp^.left:=hp2
+                     else
+                      lasthp^.right:=hp2;
+                   end
+                  else
+                   begin
+                     if assigned(hasharray) then
+                      hasharray^[spdval mod hasharraysize]:=hp2
+                     else
+                      root:=hp2;
+                   end;
+                  { reinsert the hp3 in the tree from hp2 }
+                  inserttree(hp3,hp2);
+                  { reset node with new values }
+                  stringdispose(hp^._name);
+                  hp^._name:=stringdup(news);
+                  hp^.speedvalue:=getspeedvalue(news);
+                  hp^.left:=nil;
+                  hp^.right:=nil;
+                  { reinsert }
+                  if assigned(hasharray) then
+                   rename:=insertnode(hp,hasharray^[hp^.speedvalue mod hasharraysize])
+                  else
+                   rename:=insertnode(hp,root);
+                  exit;
+                end
+               else
+                if olds>hp^.name then
+                 begin
+                   lasthp:=hp;
+                   hp:=hp^.left
+                 end
+                else
+                 begin
+                   lasthp:=hp;
+                   hp:=hp^.right;
+                 end;
+             end;
+          end;
+      end;
+    function Tdictionary.delete(const s:string):Pnamedindexobject;
+
+    var p,speedvalue:longint;
+        n:Pnamedindexobject;
+
+        procedure insert_right_bottom(var root,Atree:Pnamedindexobject);
+
+        begin
+            while root^.right<>nil do
+                root:=root^.right;
+            root^.right:=Atree;
+        end;
+
+        function delete_from_tree(root:Pnamedindexobject):Pnamedindexobject;
+
+        type    leftright=(left,right);
+
+        var lr:leftright;
+            oldroot:Pnamedindexobject;
+
+        begin
+            oldroot:=nil;
+            while (root<>nil) and (root^.speedvalue<>speedvalue) do
+                begin
+                    oldroot:=root;
+                    if speedvalue<root^.speedvalue then
+                        begin
+                            root:=root^.right;
+                            lr:=right;
+                        end
+                    else
+                        begin
+                            root:=root^.left;
+                            lr:=left;
+                        end;
+                end;
+            while (root<>nil) and (root^._name^<>s) do
+                begin
+                    oldroot:=root;
+                    if s<root^._name^ then
+                        begin
+                            root:=root^.right;
+                            lr:=right;
+                        end
+                    else
+                        begin
+                            root:=root^.left;
+                            lr:=left;
+                        end;
+                end;
+            if (oldroot=nil) or (root=nil) then
+                runerror(218); {Internalerror is not available...}
+            if root^.left<>nil then
+                begin
+                    {Now the node pointing to root must point to the left
+                     subtree of root. The right subtree of root must be
+                     connected to the right bottom of the left subtree.}
+                    if lr=left then
+                        oldroot^.left:=root^.left
+                    else
+                        oldroot^.right:=root^.left;
+                    if root^.right<>nil then
+                        insert_right_bottom(root^.left,root^.right);
+                end
+            else
+                {There is no left subtree. So we can just replace the node to
+                 delete with the right subtree.}
+                if lr=left then
+                    oldroot^.left:=root^.right
+                else
+                    oldroot^.right:=root^.right;
+            delete_from_tree:=root;
+        end;
+
+    begin
+        speedvalue:=getspeedvalue(s);
+        n:=root;
+        if assigned(hasharray) then
+            begin
+                {First, check if the node to delete directly located under
+                 the hasharray.}
+                p:=speedvalue mod hasharraysize;
+                n:=hasharray^[p];
+                if (n<>nil) and (n^.speedvalue=speedvalue) and
+                 (n^._name^=s) then
+                    begin
+                        {The node to delete is directly located under the
+                         hasharray. Make the hasharray point to the left
+                         subtree of the node and place the right subtree on
+                         the right-bottom of the left subtree.}
+                        if n^.left<>nil then
+                            begin
+                                hasharray^[p]:=n^.left;
+                                if n^.right<>nil then
+                                    insert_right_bottom(n^.left,n^.right);
+                            end
+                        else
+                            hasharray^[p]:=n^.right;
+                        delete:=n;
+                        exit;
+                    end;
+            end
+        else
+            begin
+                {First check if the node to delete is the root.}
+                if (root<>nil) and (n^.speedvalue=speedvalue)
+                 and (n^._name^=s) then
+                    begin
+                        if n^.left<>nil then
+                            begin
+                                root:=n^.left;
+                                if n^.right<>nil then
+                                    insert_right_bottom(n^.left,n^.right);
+                            end
+                        else
+                            root:=n^.right;
+                        delete:=n;
+                        exit;
+                    end;
+            end;
+        delete:=delete_from_tree(n);
+    end;
+
+    function Tdictionary.search(const s:string):Pnamedindexobject;
+      begin
+        search:=speedsearch(s,getspeedvalue(s));
+      end;
+
+
+    function Tdictionary.speedsearch(const s:string;speedvalue:longint):Pnamedindexobject;
+      var
+        newnode:Pnamedindexobject;
+      begin
+        if assigned(hasharray) then
+         newnode:=hasharray^[speedvalue mod hasharraysize]
+        else
+         newnode:=root;
+        while assigned(newnode) do
+         begin
+           if speedvalue>newnode^.speedvalue then
+            newnode:=newnode^.left
+           else
+            if speedvalue<newnode^.speedvalue then
+             newnode:=newnode^.right
+           else
+            begin
+              if (newnode^._name^=s) then
+               begin
+                 speedsearch:=newnode;
+                 exit;
+               end
+              else
+               if s>newnode^._name^ then
+                newnode:=newnode^.left
+              else
+               newnode:=newnode^.right;
+            end;
+         end;
+        speedsearch:=nil;
+      end;
+
+
+{****************************************************************************
+                                tdynamicarray
+****************************************************************************}
+
+    constructor tdynamicarray.init(Aelemlen,Agrow:longint);
+      begin
+        inherited init;
+        elemlen:=Aelemlen;
+        growcount:=Agrow;
+        grow;
+      end;
+
+    function  tdynamicarray.size:longint;
+      begin
+        size:=limit*elemlen;
+      end;
+
+    function  tdynamicarray.usedsize:longint;
+      begin
+        usedsize:=count*elemlen;
+      end;
+
+    procedure tdynamicarray.grow;
+      var
+        osize : longint;
+        odata : pchar;
+      begin
+        osize:=size;
+        odata:=data;
+        inc(limit,growcount);
+        getmem(data,size);
+        if assigned(odata) then
+         begin
+           move(odata^,data^,osize);
+           freemem(odata,osize);
+         end;
+        fillchar(data[osize],growcount*elemlen,0);
+      end;
+
+    procedure tdynamicarray.align(i:longint);
+      var
+        j : longint;
+      begin
+        j:=(posn*elemlen mod i);
+        if j<>0 then
+         begin
+           j:=i-j;
+           while limit<(posn+j) do
+            grow;
+           inc(posn,j);
+           if (posn>count) then
+            count:=posn;
+         end;
+      end;
+
+    procedure tdynamicarray.seek(i:longint);
+      begin
+        while limit<i do
+         grow;
+        posn:=i;
+        if (posn>count) then
+         count:=posn;
+      end;
+
+    procedure tdynamicarray.write(var d;len:longint);
+      begin
+        while limit<(posn+len) do
+         grow;
+        move(d,data[posn*elemlen],len*elemlen);
+        inc(posn,len);
+        if (posn>count) then
+         count:=posn;
+      end;
+
+    procedure tdynamicarray.read(var d;len:longint);
+      begin
+        move(data[posn*elemlen],d,len*elemlen);
+        inc(posn,len);
+        if (posn>count) then
+         count:=posn;
+      end;
+
+    procedure tdynamicarray.writepos(pos:longint;var d;len:longint);
+      begin
+        while limit<(pos+len) do
+         grow;
+        move(d,data[pos*elemlen],len*elemlen);
+        posn:=pos+len;
+        if (posn>count) then
+         count:=posn;
+      end;
+
+    procedure tdynamicarray.readpos(pos:longint;var d;len:longint);
+      begin
+        while limit<(pos+len) do
+         grow;
+        move(data[pos*elemlen],d,len*elemlen);
+        posn:=pos+len;
+        if (posn>count) then
+         count:=posn;
+      end;
+
+    destructor tdynamicarray.done;
+      begin
+        if assigned(data) then
+         freemem(data,size);
+      end;
+
+{$ifdef BUFFEREDFILE}
+
+{****************************************************************************
+                               TBUFFEREDFILE
+ ****************************************************************************}
+
+    Const
+       crcseed = $ffffffff;
+
+       crctable : array[0..255] of longint = (
+          $00000000,$77073096,$ee0e612c,$990951ba,$076dc419,$706af48f,
+          $e963a535,$9e6495a3,$0edb8832,$79dcb8a4,$e0d5e91e,$97d2d988,
+          $09b64c2b,$7eb17cbd,$e7b82d07,$90bf1d91,$1db71064,$6ab020f2,
+          $f3b97148,$84be41de,$1adad47d,$6ddde4eb,$f4d4b551,$83d385c7,
+          $136c9856,$646ba8c0,$fd62f97a,$8a65c9ec,$14015c4f,$63066cd9,
+          $fa0f3d63,$8d080df5,$3b6e20c8,$4c69105e,$d56041e4,$a2677172,
+          $3c03e4d1,$4b04d447,$d20d85fd,$a50ab56b,$35b5a8fa,$42b2986c,
+          $dbbbc9d6,$acbcf940,$32d86ce3,$45df5c75,$dcd60dcf,$abd13d59,
+          $26d930ac,$51de003a,$c8d75180,$bfd06116,$21b4f4b5,$56b3c423,
+          $cfba9599,$b8bda50f,$2802b89e,$5f058808,$c60cd9b2,$b10be924,
+          $2f6f7c87,$58684c11,$c1611dab,$b6662d3d,$76dc4190,$01db7106,
+          $98d220bc,$efd5102a,$71b18589,$06b6b51f,$9fbfe4a5,$e8b8d433,
+          $7807c9a2,$0f00f934,$9609a88e,$e10e9818,$7f6a0dbb,$086d3d2d,
+          $91646c97,$e6635c01,$6b6b51f4,$1c6c6162,$856530d8,$f262004e,
+          $6c0695ed,$1b01a57b,$8208f4c1,$f50fc457,$65b0d9c6,$12b7e950,
+          $8bbeb8ea,$fcb9887c,$62dd1ddf,$15da2d49,$8cd37cf3,$fbd44c65,
+          $4db26158,$3ab551ce,$a3bc0074,$d4bb30e2,$4adfa541,$3dd895d7,
+          $a4d1c46d,$d3d6f4fb,$4369e96a,$346ed9fc,$ad678846,$da60b8d0,
+          $44042d73,$33031de5,$aa0a4c5f,$dd0d7cc9,$5005713c,$270241aa,
+          $be0b1010,$c90c2086,$5768b525,$206f85b3,$b966d409,$ce61e49f,
+          $5edef90e,$29d9c998,$b0d09822,$c7d7a8b4,$59b33d17,$2eb40d81,
+          $b7bd5c3b,$c0ba6cad,$edb88320,$9abfb3b6,$03b6e20c,$74b1d29a,
+          $ead54739,$9dd277af,$04db2615,$73dc1683,$e3630b12,$94643b84,
+          $0d6d6a3e,$7a6a5aa8,$e40ecf0b,$9309ff9d,$0a00ae27,$7d079eb1,
+          $f00f9344,$8708a3d2,$1e01f268,$6906c2fe,$f762575d,$806567cb,
+          $196c3671,$6e6b06e7,$fed41b76,$89d32be0,$10da7a5a,$67dd4acc,
+          $f9b9df6f,$8ebeeff9,$17b7be43,$60b08ed5,$d6d6a3e8,$a1d1937e,
+          $38d8c2c4,$4fdff252,$d1bb67f1,$a6bc5767,$3fb506dd,$48b2364b,
+          $d80d2bda,$af0a1b4c,$36034af6,$41047a60,$df60efc3,$a867df55,
+          $316e8eef,$4669be79,$cb61b38c,$bc66831a,$256fd2a0,$5268e236,
+          $cc0c7795,$bb0b4703,$220216b9,$5505262f,$c5ba3bbe,$b2bd0b28,
+          $2bb45a92,$5cb36a04,$c2d7ffa7,$b5d0cf31,$2cd99e8b,$5bdeae1d,
+          $9b64c2b0,$ec63f226,$756aa39c,$026d930a,$9c0906a9,$eb0e363f,
+          $72076785,$05005713,$95bf4a82,$e2b87a14,$7bb12bae,$0cb61b38,
+          $92d28e9b,$e5d5be0d,$7cdcefb7,$0bdbdf21,$86d3d2d4,$f1d4e242,
+          $68ddb3f8,$1fda836e,$81be16cd,$f6b9265b,$6fb077e1,$18b74777,
+          $88085ae6,$ff0f6a70,$66063bca,$11010b5c,$8f659eff,$f862ae69,
+          $616bffd3,$166ccf45,$a00ae278,$d70dd2ee,$4e048354,$3903b3c2,
+          $a7672661,$d06016f7,$4969474d,$3e6e77db,$aed16a4a,$d9d65adc,
+          $40df0b66,$37d83bf0,$a9bcae53,$debb9ec5,$47b2cf7f,$30b5ffe9,
+          $bdbdf21c,$cabac28a,$53b39330,$24b4a3a6,$bad03605,$cdd70693,
+          $54de5729,$23d967bf,$b3667a2e,$c4614ab8,$5d681b02,$2a6f2b94,
+          $b40bbe37,$c30c8ea1,$5a05df1b,$2d02ef8d);
+
+    constructor tbufferedfile.init(const filename : string;_bufsize : longint);
+
+      begin
+         inherited init;
+         assign(f,filename);
+         bufsize:=_bufsize;
+         clear_crc;
+      end;
+
+    destructor tbufferedfile.done;
+
+      begin
+         close;
+      end;
+
+    procedure tbufferedfile.clear_crc;
+
+      begin
+         crc:=crcseed;
+      end;
+
+    procedure tbufferedfile.setbuf(p : pchar;s : longint);
+
+      begin
+         flush;
+         freemem(buf,bufsize);
+         bufsize:=s;
+         buf:=p;
+      end;
+
+    function tbufferedfile.reset:boolean;
+
+      var
+         ofm : byte;
+      begin
+         ofm:=filemode;
+         iomode:=1;
+         getmem(buf,bufsize);
+         filemode:=0;
+         {$I-}
+          system.reset(f,1);
+         {$I+}
+         reset:=(ioresult=0);
+         filemode:=ofm;
+      end;
+
+    procedure tbufferedfile.rewrite;
+
+      begin
+         iomode:=2;
+         getmem(buf,bufsize);
+         system.rewrite(f,1);
+      end;
+
+    procedure tbufferedfile.flush;
+
+      var
+{$ifdef FPC}
+         count : longint;
+{$else}
+         count : integer;
+{$endif}
+
+      begin
+         if iomode=2 then
+           begin
+              if bufpos=0 then
+                exit;
+              blockwrite(f,buf^,bufpos)
+           end
+         else if iomode=1 then
+            if buflast=bufpos then
+              begin
+                 blockread(f,buf^,bufsize,count);
+                 buflast:=count;
+              end;
+         bufpos:=0;
+      end;
+
+    function tbufferedfile.getftime : longint;
+
+      var
+         l : longint;
+{$ifdef linux}
+         Info : Stat;
+{$endif}
+      begin
+{$ifndef linux}
+         { this only works if the file is open !! }
+         dos.getftime(f,l);
+{$else}
+         Fstat(f,Info);
+         l:=info.mtime;
+{$endif}
+         getftime:=l;
+      end;
+
+    function tbufferedfile.getsize : longint;
+
+      begin
+        getsize:=filesize(f);
+      end;
+
+    procedure tbufferedfile.seek(l : longint);
+
+      begin
+         if iomode=2 then
+           begin
+              flush;
+              system.seek(f,l);
+           end
+         else if iomode=1 then
+           begin
+              { forces a reload }
+              bufpos:=buflast;
+              system.seek(f,l);
+              flush;
+           end;
+      end;
+
+    type
+{$ifdef tp}
+       bytearray1 = array [1..65535] of byte;
+{$else}
+       bytearray1 = array [1..10000000] of byte;
+{$endif}
+
+    procedure tbufferedfile.read_data(var data;bytes : longint;var count : longint);
+
+      var
+         p : pchar;
+         c,i : longint;
+
+      begin
+         p:=pchar(@data);
+         count:=0;
+         while bytes-count>0 do
+           begin
+              if bytes-count>buflast-bufpos then
+                begin
+                   move((buf+bufpos)^,(p+count)^,buflast-bufpos);
+                   inc(count,buflast-bufpos);
+                   bufpos:=buflast;
+                   flush;
+                   { can't we read anything ? }
+                   if bufpos=buflast then
+                     break;
+                end
+              else
+                begin
+                   move((buf+bufpos)^,(p+count)^,bytes-count);
+                   inc(bufpos,bytes-count);
+                   count:=bytes;
+                   break;
+                end;
+           end;
+         if do_crc then
+           begin
+              c:=crc;
+              for i:=1 to bytes do
+              c:=(c shr 8) xor crctable[byte(c) xor (bytearray1(data)[i])];
+              crc:=c;
+           end;
+      end;
+
+    procedure tbufferedfile.write_data(var data;count : longint);
+
+      var
+         c,i : longint;
+
+      begin
+         if bufpos+count>bufsize then
+           flush;
+         move(data,(buf+bufpos)^,count);
+         inc(bufpos,count);
+         if do_crc then
+           begin
+              c:=crc;
+              for i:=1 to count do
+                c:=(c shr 8) xor crctable[byte(c) xor (bytearray1(data)[i])];
+              crc:=c;
+           end;
+      end;
+
+    function tbufferedfile.getcrc : longint;
+
+      begin
+         getcrc:=crc xor crcseed;
+      end;
+
+    procedure tbufferedfile.write_string(const s : string);
+
+      begin
+        if bufpos+length(s)>bufsize then
+          flush;
+        { why is there not CRC here ??? }
+        move(s[1],(buf+bufpos)^,length(s));
+        inc(bufpos,length(s));
+         { should be
+        write_data(s[1],length(s)); }
+      end;
+
+    procedure tbufferedfile.write_pchar(p : pchar);
+
+      var
+         l : longint;
+
+      begin
+        l:=strlen(p);
+        if l>=bufsize then
+          runerror(222);
+        { why is there not CRC here ???}
+        if bufpos+l>bufsize then
+          flush;
+        move(p^,(buf+bufpos)^,l);
+        inc(bufpos,l);
+         { should be
+        write_data(p^,l); }
+      end;
+
+    procedure tbufferedfile.write_byte(b : byte);
+
+      begin
+         write_data(b,sizeof(byte));
+      end;
+
+    procedure tbufferedfile.write_long(l : longint);
+
+      var
+         w1,w2 : word;
+
+      begin
+         if change_endian then
+           begin
+              w1:=l and $ffff;
+              w2:=l shr 16;
+              l:=swap(w2)+(longint(swap(w1)) shl 16);
+           end;
+         write_data(l,sizeof(longint));
+      end;
+
+    procedure tbufferedfile.write_word(w : word);
+
+      begin
+         if change_endian then
+           begin
+              w:=swap(w);
+           end;
+         write_data(w,sizeof(word));
+      end;
+
+    procedure tbufferedfile.write_double(d : double);
+
+      begin
+         write_data(d,sizeof(double));
+      end;
+
+    function tbufferedfile.getpath : string;
+
+      begin
+{$ifdef dummy}
+         getpath:=strpas(filerec(f).name);
+{$endif}
+         getpath:='';
+      end;
+
+    procedure tbufferedfile.close;
+
+      begin
+         if iomode<>0 then
+           begin
+              flush;
+              system.close(f);
+              freemem(buf,bufsize);
+              buf:=nil;
+              iomode:=0;
+           end;
+      end;
+
+    procedure tbufferedfile.tempclose;
+
+      begin
+        if iomode<>0 then
+         begin
+           temppos:=system.filepos(f);
+           tempmode:=iomode;
+           tempclosed:=true;
+           system.close(f);
+           iomode:=0;
+         end
+        else
+         tempclosed:=false;
+      end;
+
+    procedure tbufferedfile.tempreopen;
+
+      var
+         ofm : byte;
+
+      begin
+         if tempclosed then
+           begin
+              case tempmode of
+               1 : begin
+                     ofm:=filemode;
+                     iomode:=1;
+                     filemode:=0;
+                     system.reset(f,1);
+                     filemode:=ofm;
+                   end;
+               2 : begin
+                     iomode:=2;
+                     system.rewrite(f,1);
+                   end;
+              end;
+              system.seek(f,temppos);
+              tempclosed:=false;
+           end;
+      end;
+
+{$endif BUFFEREDFILE}
+
+end.
+{
+  $Log$
+  Revision 1.1  2000-02-28 17:23:58  daniel
+  * Current work of symtable integration committed. The symtable can be
+    activated by defining 'newst', but doesn't compile yet. Changes in type
+    checking and oop are completed. What is left is to write a new
+    symtablestack and adapt the parser to use it.
+
+  Revision 1.1  1999/08/05 20:49:15  daniel
+  * Use objects unit.
+
+  Revision 1.36  1999/06/23 11:13:20  peter
+    * fixed linebreak
+
+  Revision 1.35  1999/06/23 11:07:23  daniel
+  * Tdictionary.delete
+
+  Revision 1.33.2.1  1999/06/15 10:12:22  peter
+    * fixed inserttree which didn't reset left,right
+
+  Revision 1.33.2.1  1999/06/15 10:12:22  peter
+    * fixed inserttree which didn't reset left,right
+
+  Revision 1.33  1999/05/31 23:33:21  peter
+    * fixed tdictionary rename which didn't reset left,right when
+      reinserting
+
+  Revision 1.32  1999/05/27 19:44:23  peter
+    * removed oldasm
+    * plabel -> pasmlabel
+    * -a switches to source writing automaticly
+    * assembler readers OOPed
+    * asmsymbol automaticly external
+    * jumptables and other label fixes for asm readers
+
+  Revision 1.31  1999/05/21 13:54:59  peter
+    * NEWLAB for label as symbol
+
+  Revision 1.30  1999/05/21 10:38:59  peter
+    * fixed deleteindex which didn't reset indexnr and set first wrong
+
+  Revision 1.29  1999/05/08 19:47:27  peter
+    * indexarray.delete resets pointer after dispose
+
+  Revision 1.28  1999/05/05 10:05:48  florian
+    * a delphi compiled compiler recompiles ppc
+
+  Revision 1.27  1999/05/05 09:19:03  florian
+    * more fixes to get it with delphi running
+
+  Revision 1.26  1999/04/21 09:43:31  peter
+    * storenumber works
+    * fixed some typos in double_checksum
+    + incompatible types type1 and type2 message (with storenumber)
+
+  Revision 1.25  1999/04/15 10:01:44  peter
+    * small update for storenumber
+
+  Revision 1.24  1999/04/14 09:14:47  peter
+    * first things to store the symbol/def number in the ppu
+
+  Revision 1.23  1999/04/08 20:59:39  florian
+    * fixed problem with default properties which are a class
+    * case bug (from the mailing list with -O2) fixed, the
+      distance of the case labels can be greater than the positive
+      range of a longint => it is now a dword for fpc
+
+  Revision 1.22  1999/03/31 13:55:10  peter
+    * assembler inlining working for ag386bin
+
+  Revision 1.21  1999/03/19 16:35:29  pierre
+   * Tnamedindexobject done also removed left and right
+
+  Revision 1.20  1999/03/18 20:30:45  peter
+    + .a writer
+
+  Revision 1.19  1999/03/01 13:32:00  pierre
+   * external used before implemented problem fixed
+
+  Revision 1.18  1999/02/24 00:59:13  peter
+    * small updates for ag386bin
+
+  Revision 1.17  1999/01/19 11:00:33  daniel
+  + Tdictionary object:  Tsymtable will become object(TTdictionary) in the
+    future
+  + Tnamed_item object:  Tsym will become object(Tnamed_item) in the future
+
+  Revision 1.16  1998/11/04 10:11:37  peter
+    * ansistring fixes
+
+  Revision 1.15  1998/10/19 18:04:40  peter
+    + tstringcontainer.init_no_doubles
+
+  Revision 1.14  1998/09/18 16:03:37  florian
+    * some changes to compile with Delphi
+
+  Revision 1.13  1998/08/12 19:28:16  peter
+    * better libc support
+
+  Revision 1.12  1998/07/14 14:46:47  peter
+    * released NEWINPUT
+
+  Revision 1.11  1998/07/07 11:19:54  peter
+    + NEWINPUT for a better inputfile and scanner object
+
+  Revision 1.10  1998/07/01 15:26:59  peter
+    * better bufferfile.reset error handling
+
+  Revision 1.9  1998/06/03 23:40:37  peter
+    + unlimited file support, release tempclose
+
+  Revision 1.8  1998/05/20 09:42:33  pierre
+    + UseTokenInfo now default
+    * unit in interface uses and implementation uses gives error now
+    * only one error for unknown symbol (uses lastsymknown boolean)
+      the problem came from the label code !
+    + first inlined procedures and function work
+      (warning there might be allowed cases were the result is still wrong !!)
+    * UseBrower updated gives a global list of all position of all used symbols
+      with switch -gb
+
+  Revision 1.7  1998/05/06 18:36:53  peter
+    * tai_section extended with code,data,bss sections and enumerated type
+    * ident 'compiled by FPC' moved to pmodules
+    * small fix for smartlink
+
+  Revision 1.6  1998/05/06 08:38:37  pierre
+    * better position info with UseTokenInfo
+      UseTokenInfo greatly simplified
+    + added check for changed tree after first time firstpass
+      (if we could remove all the cases were it happen
+      we could skip all firstpass if firstpasscount > 1)
+      Only with ExtDebug
+
+  Revision 1.5  1998/04/30 15:59:40  pierre
+    * GDB works again better :
+      correct type info in one pass
+    + UseTokenInfo for better source position
+    * fixed one remaining bug in scanner for line counts
+    * several little fixes
+
+  Revision 1.4  1998/04/29 10:33:50  pierre
+    + added some code for ansistring (not complete nor working yet)
+    * corrected operator overloading
+    * corrected nasm output
+    + started inline procedures
+    + added starstarn : use ** for exponentiation (^ gave problems)
+    + started UseTokenInfo cond to get accurate positions
+
+  Revision 1.3  1998/04/27 23:10:28  peter
+    + new scanner
+    * $makelib -> if smartlink
+    * small filename fixes pmodule.setfilename
+    * moved import from files.pas -> import.pas
+
+  Revision 1.2  1998/04/07 11:09:04  peter
+    + filemode is set correct in tbufferedfile.reset
+}

compiler/new/symtable/defs.pas

@@ -31,7 +31,7 @@ interface
 
 uses    symtable,objects,cobjects,symtablt,globtype
 {$ifdef i386}
-        ,i386base
+        ,cpubase
 {$endif}
 {$ifdef m68k}
         ,m68k
@@ -44,8 +44,7 @@ type    Targconvtyp=(act_convertable,act_equal,act_exact);
 
         Tvarspez=(vs_value,vs_const,vs_var);
 
-        Tobjprop=(sp_public,sp_private,sp_protected,
-                  sp_forwarddef,sp_static);
+        Tobjprop=(sp_public,sp_private,sp_protected,sp_published,sp_static);
         Tobjpropset=set of Tobjprop;
 
         Tobjoption=(oo_is_abstract,         {The object/class has
@@ -74,48 +73,59 @@ type    Targconvtyp=(act_convertable,act_equal,act_exact);
                                              then a C++ compatible vmt.}
         Tobjoptionset=set of Tobjoption;
 
-        {Options for Tprocdef and Tprocvardef}
-        Tprocoption=(povirtualmethod,   {Procedure is a virtual method.}
-                     poclearstack,      {Use IBM flat calling convention.
-                                         (Used by GCC.)}
-                     poconstructor,     {Procedure is a constructor.}
-                     podestructor,      {Procedure is a destructor.}
-                     pointernproc,      {Procedure has compiler magic.}
-                     poexports,         {Procedure is exported.}
-                     poiocheck,         {IO checking should be done after
-                                         a call to the procedure.}
-                     poabstractmethod,  {Procedure is an abstract method.}
-                     pointerrupt,       {Procedure is an interrupt handler.}
-                     poinline,          {Procedure is an assembler macro.}
-                     poassembler,       {Procedure is written in assembler.}
-                     pooperator,        {Procedure defines an operator.}
-                     poexternal,        {Procedure is external (in other
-                                         object or lib)}
-                     poleftright,       {Push parameters from left to right.}
-                     poprocinit,        {Program initialization.}
-                     postaticmethod,    {Static method.}
-                     pooveridingmethod, {Method with override directive }
-                     poclassmethod,     {Class method.}
-                     pounitinit,        {Unit initialization }
-                     pomethodpointer,   {Method pointer, only in procvardef,
-                                         also used for 'with object do' }
-                     pocdecl,           {Procedure uses C styled calling }
-                     popalmossyscall,   {Procedure is a PalmOS system call }
-                     pointernconst,     {Procedure has constant evaluator
-                                         intern.}
-                     poregister,        {Procedure uses register (fastcall)
-                                         calling }
-                     pounitfinalize,    {Unit finalization }
-                     postdcall,         {Procedure uses stdcall
-                                         call.}
-                     pomsgstr,          {Method for string message
-                                         handling.}
-                     pomsgint,          {Method for int message handling.}
-                     posavestdregs,     {Save std regs cdecl and stdcall
-                                         need that !}
-                     pocontainsself,    {Self is passed explicit to the
-                                         compiler.}
-                     posafecall);       {Safe call calling conventions }
+        {Calling convention for tprocdef and Tprocvardef.}
+        Tproccalloption=(pocall_none,
+                         pocall_clearstack,     {Use IBM flat calling
+                                                 convention. (Used by GCC.)}
+                         pocall_leftright,      {Push parameters from left to
+                                                 right.}
+                         pocall_cdecl,          {Procedure uses C styled
+                                                 calling.}
+                         pocall_register,       {Procedure uses register
+                                                 (fastcall) calling.}
+                         pocall_stdcall,        {Procedure uses stdcall
+                                                 call.}
+                         pocall_safecall,       {Safe call calling
+                                                 conventions.}
+                         pocall_palmossyscall,  {Procedure is a PalmOS
+                                                 system call.}
+                         pocall_system,
+                         pocall_inline,         {Procedure is an assembler
+                                                 macro.}
+                         pocall_internproc,     {Procedure has compiler
+                                                 magic.}
+                         pocall_internconst);   {Procedure has constant
+                                                 evaluator intern.}
+        Tproccalloptionset=set of Tproccalloption;
+
+        {Basic type for tprocdef and tprocvardef }
+        Tproctypeoption=(potype_none,
+                         potype_proginit,       {Program initialization.}
+                         potype_unitinit,       {Unit initialization.}
+                         potype_unitfinalize,   {Unit finalization.}
+                         potype_constructor,    {Procedure is a constructor.}
+                         potype_destructor,     {Procedure is a destructor.}
+                         potype_operator);      {Procedure defines an
+                                                 operator.}
+
+        {Other options for Tprocdef and Tprocvardef.}
+        Tprocoption=(po_none,
+            poclassmethod,          {Class method.}
+            povirtualmethod,        {Procedure is a virtual method.}
+            poabstractmethod,       {Procedure is an abstract method.}
+            postaticmethod,         {Static method.}
+            pooverridingmethod,     {Method with override directive.}
+            pomethodpointer,        {Method pointer, only in procvardef, also used for 'with object do'.}
+            pocontainsself,         {Self is passed explicit to the compiler.}
+            pointerrupt,            {Procedure is an interrupt handler.}
+            poiocheck,              {IO checking should be done after a call to the procedure.}
+            poassembler,            {Procedure is written in assembler.}
+            pomsgstr,               {Method for string message handling.}
+            pomsgint,               {Method for int message handling.}
+            poexports,              {Procedure has export directive (needed for OS/2).}
+            poexternal,             {Procedure is external (in other object or lib).}
+            posavestdregs,          {Save std regs cdecl and stdcall need that !}
+            posaveregisters);       {Save all registers }
         Tprocoptionset=set of Tprocoption;
 
         Tarrayoption=(ap_variant,ap_constructor,ap_arrayofconst);
@@ -135,7 +145,7 @@ type    Targconvtyp=(act_convertable,act_equal,act_exact);
         Pfiledef=^Tfiledef;
         Tfiledef=object(Tdef)
             filetype:Tfiletype;
-            typed_as:Pdef;
+            definition:Pdef;
             constructor init(Aowner:Pcontainingsymtable;
                              ft:Tfiletype;tas:Pdef);
             constructor load(var s:Tstream);
@@ -213,11 +223,11 @@ type    Targconvtyp=(act_convertable,act_equal,act_exact);
              and no vmt field for objects without virtuals }
             vmt_offset:longint;
             constructor init(const n:string;Aowner:Pcontainingsymtable;
-                             parent:Pobjectdef);
+                             parent:Pobjectdef;isclass:boolean);
             constructor load(var s:Tstream);
             procedure check_forwards;
             procedure insertvmt;
-            function isrelated(d:Pobjectdef):boolean;
+            function is_related(d:Pobjectdef):boolean;
             function search(const s:string):Psym;
             function speedsearch(const s:string;
                                  speedvalue:longint):Psym;virtual;
@@ -309,8 +319,8 @@ type    Targconvtyp=(act_convertable,act_equal,act_exact);
         Tbasetype=(uauto,uvoid,uchar,
                    u8bit,u16bit,u32bit,
                    s8bit,s16bit,s32bit,
-                   bool8bit,bool16bit,bool32bit { uwchar,bool1bit,bitfield},
-                   u64bit,s64bitint);
+                   bool8bit,bool16bit,bool32bit,
+                   s64bit,u64bit,s64bitint,uwidechar);
 
         Porddef=^Torddef;
         Torddef=object(Tdef)
@@ -367,7 +377,7 @@ type    Targconvtyp=(act_convertable,act_equal,act_exact);
 
         Psetdef=^Tsetdef;
         Tsetdef=object(Tdef)
-            setof:Pdef;
+            definition:Pdef;
             settype:Tsettype;
             constructor init(s:Pdef;high:longint;Aowner:Pcontainingsymtable);
             constructor load(var s:Tstream);
@@ -403,12 +413,49 @@ type    Targconvtyp=(act_convertable,act_equal,act_exact);
             destructor done;virtual;
         end;
 
+        {String types}
+        Tstringtype=(st_default,st_shortstring,st_longstring,
+                     st_ansistring,st_widestring);
+
+        {This object needs to be splitted into multiple objects,
+         one for each stringtype. This is because all code in this
+         object is different for all string types.}
+        Pstringdef=^Tstringdef;
+        Tstringdef=object(Tdef)
+            string_typ:Tstringtype;
+            len:longint;
+            constructor shortinit(l:byte;Aowner:Pcontainingsymtable);
+            constructor shortload(var s:Tstream);
+            constructor longinit(l:longint;Aowner:Pcontainingsymtable);
+            constructor longload(var s:Tstream);
+            constructor ansiinit(l:longint;Aowner:Pcontainingsymtable);
+            constructor ansiload(var s:Tstream);
+            constructor wideinit(l:longint;Aowner:Pcontainingsymtable);
+            constructor wideload(var s:Tstream);
+            function  stringtypname:string;
+            function  size:longint;virtual;
+            procedure store(var s:Tstream);virtual;
+            function  gettypename:string;virtual;
+            function  is_publishable : boolean;virtual;
+            { debug }
+        {$ifdef GDB}
+            function  stabstring:Pchar;virtual;
+            procedure concatstabto(asmlist : Paasmoutput);virtual;
+        {$endif GDB}
+            { init/final }
+            function  needs_inittable : boolean;virtual;
+            { rtti }
+            procedure write_rtti_data;virtual;
+        end;
+
         Pabstractprocdef=^Pabstractprocdef;
         Tabstractprocdef=object(Tdef)
             {Saves a definition to the return type }
             retdef:Pdef;
             fpu_used:byte;              {How many stack fpu must be empty.}
+            proctype:Tproctypeoption;
             options:Tprocoptionset;     {Save the procedure options.}
+            calloptions:Tproccalloptionset;
             parameters:Pcollection;
             constructor init(Aowner:Pcontainingsymtable);
             constructor load(var s:Tstream);
@@ -424,7 +471,7 @@ type    Targconvtyp=(act_convertable,act_equal,act_exact);
  {$endif GDB}
         end;
 
-        Pprocvardef=^Pprocvardef;
+        Pprocvardef=^Tprocvardef;
         Tprocvardef=object(Tabstractprocdef)
             function size:longint;virtual;
  {$ifdef GDB}
@@ -464,27 +511,74 @@ type    Targconvtyp=(act_convertable,act_equal,act_exact);
            constructor init(Aowner:Pcontainingsymtable);
            constructor load(var s:Tstream);
            procedure store(var s:Tstream);virtual;
- {$ifdef GDB}
+{$ifdef GDB}
            function cplusplusmangledname : string;
            function stabstring : pchar;virtual;
            procedure concatstabto(asmlist : paasmoutput);virtual;
- {$endif GDB}
+{$endif GDB}
            procedure deref;virtual;
            function mangledname:string;
            procedure setmangledname(const s:string);
            procedure load_references;
-           function  write_references : boolean;
+           function  write_references:boolean;
            destructor done;virtual;
         end;
 
-var     cformaldef:Pformaldef;  {Unique formal definition.}
-        voiddef:Porddef;        {Pointer to void (procedure) type      }
-        cchardef:Porddef;       {Pointer to char type.}
-        booldef:Porddef;        {Pointer to boolean type.}
-        u8bitdef:Porddef;       {Pointer to 8-bit unsigned type.}
-        u16bitdef:Porddef;      {Pointer to 16-bit unsigned type.}
-        u32bitdef:Porddef;      {Pointer to 32-bit unsigned type.}
-        s32bitdef:Porddef;      {Pointer to 32-bit signed type.}
+        Pforwarddef=^Tforwarddef;
+        Tforwarddef=object(Tdef)
+           tosymname:string;
+           forwardpos:Tfileposinfo;
+           constructor init(Aowner:Pcontainingsymtable;
+                            const s:string;const pos:Tfileposinfo);
+           function gettypename:string;virtual;
+        end;
+
+        {Relevant options for assigning a proc or a procvar to a procvar.}
+const   po_compatibility_options=[
+          poclassmethod,
+          postaticmethod,
+          pomethodpointer,
+          pocontainsself,
+          pointerrupt,
+          poiocheck,
+          poexports
+        ];
+
+var     cformaldef:Pformaldef;      {Unique formal definition.}
+        voiddef:Porddef;            {Pointer to void (procedure) type.}
+        cchardef:Porddef;           {Pointer to char type.}
+        booldef:Porddef;            {Pointer to boolean type.}
+        u8bitdef:Porddef;           {Pointer to 8-bit unsigned type.}
+        u16bitdef:Porddef;          {Pointer to 16-bit unsigned type.}
+        u32bitdef:Porddef;          {Pointer to 32-bit unsigned type.}
+        s32bitdef:Porddef;          {Pointer to 32-bit signed type.}
+        cu64bitdef:Porddef;         {Pointer to 64 bit unsigned def.}
+        cs64bitdef:Porddef;         {Pointer to 64 bit signed def.}
+
+        voidpointerdef,             {Pointer for Void-Pointerdef.}
+        charpointerdef,             {Pointer for Char-Pointerdef.}
+        voidfarpointerdef:ppointerdef;
+
+
+        s32floatdef : pfloatdef;    {Pointer for realconstn.}
+        s64floatdef : pfloatdef;    {Pointer for realconstn.}
+        s80floatdef : pfloatdef;    {Pointer to type of temp. floats.}
+        s32fixeddef : pfloatdef;    {Pointer to type of temp. fixed.}
+
+        cshortstringdef,            {Pointer to type of short string const.}
+        openshortstringdef,         {Pointer to type of an openshortstring,
+                                     needed for readln().}
+        clongstringdef,             {Pointer to type of long string const.}
+        cansistringdef,             {Pointer to type of ansi string const.}
+        cwidestringdef:Pstringdef;  {Pointer to type of wide string const.}
+        openchararraydef:Parraydef; {Pointer to type of an open array of
+                                     char, needed for readln().}
+
+        cfiledef:Pfiledef;          {Get the same definition for all files
+                                     used for stabs.}
+
+        generrordef:Pdef;           {Jokersymbol for eine fehlerhafte
+                                     typdefinition.}
 
 implementation
 
@@ -538,7 +632,7 @@ constructor Tfiledef.init(Aowner:Pcontainingsymtable;ft:Tfiletype;tas:Pdef);
 begin
     inherited init(Aowner);
     filetype:=ft;
-    typed_as:=tas;
+    definition:=tas;
     setsize;
 end;
 
@@ -593,7 +687,7 @@ begin
         ft_untyped:
             gettypename:='File';
         ft_typed:
-            gettypename:='File Of '+typed_as^.typename;
+            gettypename:='File Of '+definition^.typename;
         ft_text:
             gettypename:='Text'
     end;
@@ -652,6 +746,7 @@ constructor Tabstractpointerdef.init(Aowner:Pcontainingsymtable;def:Pdef);
 
 begin
     inherited init(Aowner);
+    include(properties,dp_ret_in_acc);
     definition:=def;
     savesize:=target_os.size_of_pointer;
 end;
@@ -728,7 +823,7 @@ end;
 ***************************************************************************}
 
 constructor Tobjectdef.init(const n:string;Aowner:Pcontainingsymtable;
-                            parent:Pobjectdef);
+                            parent:Pobjectdef;isclass:boolean);
 
 begin
     inherited init(Aowner);
@@ -737,6 +832,11 @@ begin
     publicsyms^.defowner:=@self;
     set_parent(parent);
     objname:=stringdup(n);
+    if isclass then
+        begin
+            include(properties,dp_ret_in_acc);
+            include(options,oo_is_class);
+        end;
 end;
 
 
@@ -823,7 +923,7 @@ begin
         begin
             {First round up to aktpakrecords.}
             publicsyms^.datasize:=align(publicsyms^.datasize,
-             aktpackrecords);
+             packrecordalignment[aktpackrecords]);
             vmt_offset:=publicsyms^.datasize;
             publicsyms^.datasize:=publicsyms^.datasize+
              target_os.size_of_pointer;
@@ -844,18 +944,18 @@ begin
 end;
 
 { true, if self inherits from d (or if they are equal) }
-function Tobjectdef.isrelated(d:Pobjectdef):boolean;
+function Tobjectdef.is_related(d:Pobjectdef):boolean;
 
 var hp:Pobjectdef;
 
 begin
     hp:=@self;
-    isrelated:=false;
+    is_related:=false;
     while assigned(hp) do
         begin
             if hp=d then
                 begin
-                    isrelated:=true;
+                    is_related:=true;
                     break;
                 end;
             hp:=hp^.childof;
@@ -1225,7 +1325,7 @@ end;
 function Tarraydef.getrangecheckstring:string;
 
 begin
-    if (cs_smartlink in aktmoduleswitches) then
+    if (cs_create_smart in aktmoduleswitches) then
         getrangecheckstring:='R_'+current_module^.modulename^+tostr(rangenr)
     else
         getrangecheckstring:='R_'+tostr(rangenr);
@@ -1239,12 +1339,12 @@ begin
         begin
             {Generates the data for range checking }
             getlabelnr(rangenr);
-            if (cs_smartlink in aktmoduleswitches) then
+            if (cs_create_smart in aktmoduleswitches) then
                 datasegment^.concat(new(pai_symbol,
-                 initname_global(getrangecheckstring)))
+                 initname_global(getrangecheckstring,10)))
             else
                 datasegment^.concat(new(pai_symbol,
-                 initname(getrangecheckstring)));
+                 initname(getrangecheckstring,10)));
             datasegment^.concat(new(Pai_const,
              init_8bit(byte(lowrange.signed))));
             datasegment^.concat(new(Pai_const,
@@ -1388,6 +1488,7 @@ constructor Tenumdef.init(Aowner:Pcontainingsymtable);
 
 begin
     inherited init(Aowner);
+    include(properties,dp_ret_in_acc);
     new(symbols,init(8,8));
     calcsavesize;
 end;
@@ -1465,7 +1566,7 @@ end;
 
 function tenumdef.getrangecheckstring : string;
 begin
-   if (cs_smartlink in aktmoduleswitches) then
+   if (cs_create_smart in aktmoduleswitches) then
      getrangecheckstring:='R_'+current_module^.modulename^+tostr(rangenr)
    else
      getrangecheckstring:='R_'+tostr(rangenr);
@@ -1478,10 +1579,12 @@ begin
      begin
         { generate two constant for bounds }
         getlabelnr(rangenr);
-        if (cs_smartlink in aktmoduleswitches) then
-          datasegment^.concat(new(pai_symbol,initname_global(getrangecheckstring)))
+        if (cs_create_smart in aktmoduleswitches) then
+          datasegment^.concat(new(Pai_symbol,
+                              initname_global(getrangecheckstring,8)))
         else
-          datasegment^.concat(new(pai_symbol,initname(getrangecheckstring)));
+          datasegment^.concat(new(Pai_symbol,
+                              initname(getrangecheckstring,8)));
         datasegment^.concat(new(pai_const,init_32bit(minval)));
         datasegment^.concat(new(pai_const,init_32bit(maxval)));
      end;
@@ -1561,6 +1664,7 @@ constructor Torddef.init(t:Tbasetype;l,h:Tconstant;
 
 begin
     inherited init(Aowner);
+    include(properties,dp_ret_in_acc);
     low:=l;
     high:=h;
     typ:=t;
@@ -1618,7 +1722,7 @@ end;
 function Torddef.getrangecheckstring:string;
 
 begin
-    if (cs_smartlink in aktmoduleswitches) then
+    if (cs_create_smart in aktmoduleswitches) then
         getrangecheckstring:='R_'+current_module^.modulename^+tostr(rangenr)
     else
         getrangecheckstring:='R_'+tostr(rangenr);
@@ -1631,12 +1735,12 @@ begin
         begin
             {Generate two constant for bounds.}
             getlabelnr(rangenr);
-            if (cs_smartlink in aktmoduleswitches) then
+            if (cs_create_smart in aktmoduleswitches) then
               datasegment^.concat(new(Pai_symbol,
-               initname_global(getrangecheckstring)))
+               initname_global(getrangecheckstring,10)))
             else
               datasegment^.concat(new(Pai_symbol,
-               initname(getrangecheckstring)));
+               initname(getrangecheckstring,10)));
             datasegment^.concat(new(Pai_const,init_8bit(byte(low.signed))));
             datasegment^.concat(new(Pai_const,init_32bit(low.values)));
             datasegment^.concat(new(Pai_const,init_8bit(byte(high.signed))));
@@ -1688,7 +1792,7 @@ function Torddef.gettypename:string;
 const   names:array[Tbasetype] of string[20]=('<unknown type>',
                 'untyped','char','byte','word','dword','shortInt',
                 'smallint','longInt','boolean','wordbool',
-                'longbool','qword','int64');
+                'longbool','qword','int64','card64','widechar');
 
 begin
     gettypename:=names[typ];
@@ -1702,6 +1806,8 @@ constructor Tfloatdef.init(t:Tfloattype;Aowner:Pcontainingsymtable);
 
 begin
     inherited init(Aowner);
+    if t=f32bit then
+        include(properties,dp_ret_in_acc);
     typ:=t;
     setsize;
 end;
@@ -1786,11 +1892,12 @@ constructor Tsetdef.init(s:Pdef;high:longint;Aowner:Pcontainingsymtable);
 
 begin
     inherited init(Aowner);
-    setof:=s;
+    definition:=s;
     if high<32 then
         begin
             settype:=smallset;
             savesize:=4;
+            include(properties,dp_ret_in_acc);
         end
     else if high<256 then
             begin
@@ -1851,14 +1958,14 @@ begin
     rttilist^.concat(new(pai_const,init_8bit(tkset)));
     write_rtti_name;
     rttilist^.concat(new(pai_const,init_8bit(otuLong)));
-    rttilist^.concat(new(pai_const_symbol,initname(setof^.get_rtti_label)));
+    rttilist^.concat(new(pai_const_symbol,initname(definition^.get_rtti_label)));
 end;
 
 
 procedure Tsetdef.write_child_rtti_data;
 
 begin
-    setof^.get_rtti_label;
+    definition^.get_rtti_label;
 end;
 
 
@@ -1871,7 +1978,7 @@ end;
 function Tsetdef.gettypename:string;
 
 begin
-   gettypename:='set of '+setof^.typename;
+   gettypename:='set of '+definition^.typename;
 end;
 {***************************************************************************
                                   Trecorddef
@@ -2071,6 +2178,234 @@ begin
     gettypename:='<record type>'
 end;
 
+{***************************************************************************
+                             Tstringprocdef
+***************************************************************************}
+
+constructor Tstringdef.shortinit(l:byte;Aowner:Pcontainingsymtable);
+
+begin
+    inherited init(Aowner);
+    string_typ:=st_shortstring;
+    len:=l;
+    savesize:=len+1;
+end;
+
+
+constructor Tstringdef.shortload(var s:Tstream);
+
+begin
+    inherited load(s);
+    string_typ:=st_shortstring;
+{   len:=readbyte;
+    savesize:=len+1;}
+end;
+
+
+constructor Tstringdef.longinit(l:longint;Aowner:Pcontainingsymtable);
+
+begin
+    inherited init(Aowner);
+    string_typ:=st_longstring;
+    len:=l;
+    savesize:=target_os.size_of_pointer;
+end;
+
+
+constructor Tstringdef.longload(var s:Tstream);
+
+begin
+    inherited load(s);
+    string_typ:=st_longstring;
+{   len:=readlong;
+    savesize:=target_os.size_of_pointer;}
+end;
+
+
+constructor tstringdef.ansiinit(l:longint;Aowner:Pcontainingsymtable);
+
+begin
+    inherited init(Aowner);
+    include(properties,dp_ret_in_acc);
+    string_typ:=st_ansistring;
+    len:=l;
+    savesize:=target_os.size_of_pointer;
+end;
+
+
+constructor Tstringdef.ansiload(var s:Tstream);
+
+begin
+    inherited load(s);
+    string_typ:=st_ansistring;
+{   len:=readlong;
+    savesize:=target_os.size_of_pointer;}
+end;
+
+
+constructor Tstringdef.wideinit(l:longint;Aowner:Pcontainingsymtable);
+begin
+    inherited init(Aowner);
+    include(properties,dp_ret_in_acc);
+    string_typ:=st_widestring;
+    len:=l;
+    savesize:=target_os.size_of_pointer;
+end;
+
+
+constructor Tstringdef.wideload(var s:Tstream);
+
+begin
+    inherited load(s);
+    string_typ:=st_widestring;
+{   len:=readlong;
+    savesize:=target_os.size_of_pointer;}
+end;
+
+
+function Tstringdef.stringtypname:string;
+
+const   typname:array[tstringtype] of string[8]=
+            ('','SHORTSTR','LONGSTR','ANSISTR','WIDESTR');
+
+begin
+    stringtypname:=typname[string_typ];
+end;
+
+
+function tstringdef.size:longint;
+
+begin
+    size:=savesize;
+end;
+
+
+procedure Tstringdef.store(var s:Tstream);
+
+begin
+    inherited store(s);
+{   if string_typ=st_shortstring then
+        writebyte(len)
+    else
+        writelong(len);
+    case string_typ of
+        st_shortstring:
+            current_ppu^.writeentry(ibshortstringdef);
+        st_longstring:
+            current_ppu^.writeentry(iblongstringdef);
+        st_ansistring:
+            current_ppu^.writeentry(ibansistringdef);
+        st_widestring:
+            current_ppu^.writeentry(ibwidestringdef);
+    end;}
+end;
+
+
+{$ifdef GDB}
+function tstringdef.stabstring : pchar;
+var
+  bytest,charst,longst : string;
+begin
+  case string_typ of
+     st_shortstring:
+       begin
+         charst := typeglobalnumber('char');
+         { this is what I found in stabs.texinfo but
+           gdb 4.12 for go32 doesn't understand that !! }
+       {$IfDef GDBknowsstrings}
+         stabstring := strpnew('n'+charst+';'+tostr(len));
+       {$else}
+         bytest := typeglobalnumber('byte');
+         stabstring := strpnew('s'+tostr(len+1)+'length:'+bytest
+            +',0,8;st:ar'+bytest
+            +';1;'+tostr(len)+';'+charst+',8,'+tostr(len*8)+';;');
+       {$EndIf}
+       end;
+     st_longstring:
+       begin
+         charst := typeglobalnumber('char');
+         { this is what I found in stabs.texinfo but
+           gdb 4.12 for go32 doesn't understand that !! }
+       {$IfDef GDBknowsstrings}
+         stabstring := strpnew('n'+charst+';'+tostr(len));
+       {$else}
+         bytest := typeglobalnumber('byte');
+         longst := typeglobalnumber('longint');
+         stabstring := strpnew('s'+tostr(len+5)+'length:'+longst
+            +',0,32;dummy:'+bytest+',32,8;st:ar'+bytest
+            +';1;'+tostr(len)+';'+charst+',40,'+tostr(len*8)+';;');
+       {$EndIf}
+       end;
+     st_ansistring:
+       begin
+         { an ansi string looks like a pchar easy !! }
+         stabstring:=strpnew('*'+typeglobalnumber('char'));
+       end;
+     st_widestring:
+       begin
+         { an ansi string looks like a pchar easy !! }
+         stabstring:=strpnew('*'+typeglobalnumber('char'));
+       end;
+end;
+end;
+
+
+procedure tstringdef.concatstabto(asmlist : paasmoutput);
+begin
+  inherited concatstabto(asmlist);
+end;
+{$endif GDB}
+
+
+function tstringdef.needs_inittable : boolean;
+begin
+   needs_inittable:=string_typ in [st_ansistring,st_widestring];
+end;
+
+function tstringdef.gettypename : string;
+
+const
+   names : array[tstringtype] of string[20] = ('',
+     'ShortString','LongString','AnsiString','WideString');
+
+begin
+   gettypename:=names[string_typ];
+end;
+
+procedure tstringdef.write_rtti_data;
+begin
+   case string_typ of
+      st_ansistring:
+        begin
+           rttilist^.concat(new(pai_const,init_8bit(tkAString)));
+           write_rtti_name;
+        end;
+      st_widestring:
+        begin
+           rttilist^.concat(new(pai_const,init_8bit(tkWString)));
+           write_rtti_name;
+        end;
+      st_longstring:
+        begin
+           rttilist^.concat(new(pai_const,init_8bit(tkLString)));
+           write_rtti_name;
+        end;
+      st_shortstring:
+        begin
+           rttilist^.concat(new(pai_const,init_8bit(tkSString)));
+           write_rtti_name;
+           rttilist^.concat(new(pai_const,init_8bit(len)));
+        end;
+   end;
+end;
+
+
+function tstringdef.is_publishable : boolean;
+begin
+   is_publishable:=true;
+end;
+
+
 {***************************************************************************
                             Tabstractprocdef
 ***************************************************************************}
@@ -2079,6 +2414,7 @@ constructor Tabstractprocdef.init(Aowner:Pcontainingsymtable);
 
 begin
     inherited init(Aowner);
+    include(properties,dp_ret_in_acc);
     retdef:=voiddef;
     savesize:=target_os.size_of_pointer;
 end;
@@ -2543,4 +2879,31 @@ begin
    gettypename:='<procedure variable type>'
 end;
 
+{****************************************************************************
+                                Tforwarddef
+****************************************************************************}
+
+constructor tforwarddef.init(Aowner:Pcontainingsymtable;
+                             const s:string;const pos:Tfileposinfo);
+
+var oldregisterdef:boolean;
+
+begin
+    { never register the forwarddefs, they are disposed at the
+      end of the type declaration block }
+{   oldregisterdef:=registerdef;
+    registerdef:=false;}
+    inherited init(Aowner);
+{   registerdef:=oldregisterdef;}
+    tosymname:=s;
+    forwardpos:=pos;
+end;
+
+
+function tforwarddef.gettypename:string;
+
+begin
+    gettypename:='unresolved forward to '+tosymname;
+end;
+
 end.

compiler/new/symtable/htypechk.pas

@@ -0,0 +1,973 @@
+{
+    $Id$
+    Copyright (c) 1998-2000 by Florian Klaempfl
+
+    This unit exports some help routines for the type checking
+
+    This program is free software; you can redistribute it and/or modify
+    it under the terms of the GNU General Public License as published by
+    the Free Software Foundation; either version 2 of the License, or
+    (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU General Public License for more details.
+
+    You should have received a copy of the GNU General Public License
+    along with this program; if not, write to the Free Software
+    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ ****************************************************************************
+}
+unit htypechk;
+
+{The isconvertable can better be handled inside the symtable, this
+ would result is much better maintenance possibilities.}
+
+interface
+
+    uses
+      tree,symtable,defs,symbols;
+
+    const
+    { firstcallparan without varspez we don't count the ref }
+{$ifdef extdebug}
+       count_ref : boolean = true;
+{$endif def extdebug}
+       get_para_resulttype : boolean = false;
+       allow_array_constructor : boolean = false;
+
+
+    { Conversion }
+    function isconvertable(def_from,def_to : pdef;
+             var doconv : tconverttype;fromtreetype : ttreetyp;
+             explicit : boolean) : byte;
+
+    { Register Allocation }
+    procedure make_not_regable(p : ptree);
+    procedure left_right_max(p : ptree);
+    procedure calcregisters(p : ptree;r32,fpu,mmx : word);
+
+    { subroutine handling }
+(*  procedure test_protected_sym(sym : psym);
+    procedure test_protected(p : ptree);*)
+    function  valid_for_formal_var(p : ptree) : boolean;
+    function  valid_for_formal_const(p : ptree) : boolean;
+    function  is_procsym_load(p:Ptree):boolean;
+    function  is_procsym_call(p:Ptree):boolean;
+    function  assignment_overloaded(from_def,to_def : pdef) : pprocdef;
+    procedure test_local_to_procvar(from_def:pprocvardef;to_def:pdef);
+    function  valid_for_assign(p:ptree;allowprop:boolean):boolean;
+
+
+implementation
+
+    uses
+       globtype,systems,tokens,
+       cobjects,verbose,globals,
+       types,pass_1,cpubase,symtablt,
+{$ifdef newcg}
+       cgbase
+{$else}
+       hcodegen
+{$endif}
+       ;
+
+{****************************************************************************
+                             Convert
+****************************************************************************}
+
+    { Returns:
+       0 - Not convertable
+       1 - Convertable
+       2 - Convertable, but not first choice }
+    function isconvertable(def_from,def_to : pdef;
+             var doconv : tconverttype;fromtreetype : ttreetyp;
+             explicit : boolean) : byte;
+
+      { Tbasetype:  uauto,uvoid,uchar,
+                    u8bit,u16bit,u32bit,
+                    s8bit,s16bit,s32,
+                    bool8bit,bool16bit,bool32bit,
+                    u64bit,s64bitint }
+      type
+        tbasedef=(bvoid,bchar,bint,bbool);
+      const
+        basedeftbl:array[tbasetype] of tbasedef =
+          (bvoid,bvoid,bchar,
+           bint,bint,bint,
+           bint,bint,bint,
+           bbool,bbool,bbool,bint,bint,bint,bchar);
+
+        basedefconverts : array[tbasedef,tbasedef] of tconverttype =
+         ((tc_not_possible,tc_not_possible,tc_not_possible,tc_not_possible),
+          (tc_not_possible,tc_equal,tc_not_possible,tc_not_possible),
+          (tc_not_possible,tc_not_possible,tc_int_2_int,tc_int_2_bool),
+          (tc_not_possible,tc_not_possible,tc_bool_2_int,tc_bool_2_bool));
+
+      var
+         b : byte;
+         hd1,hd2 : pdef;
+         hct : tconverttype;
+      begin
+    {!!!! This code should never be called with nil parameters. If you really
+     want to check this, make it an internalerror instead of an exit!! (DM)
+        if not(assigned(def_from) and assigned(def_to)) then
+          begin
+            isconvertable:=0;
+            exit;
+          end;}
+
+       { tp7 procvar def support, in tp7 a procvar is always called, if the
+         procvar is passed explicit a addrn would be there }
+         if (m_tp_procvar in aktmodeswitches) and
+            (typeof(def_from^)=typeof(Tprocvardef)) and
+            (fromtreetype=loadn) then
+          begin
+            def_from:=pprocvardef(def_from)^.retdef;
+          end;
+
+       { we walk the wanted (def_to) types and check then the def_from
+         types if there is a conversion possible }
+         b:=0;
+         if typeof(def_to^)=typeof(Torddef) then
+            begin
+              if typeof(def_from^)=typeof(Torddef) then
+                 begin
+                   doconv:=basedefconverts[basedeftbl[Tbasetype(porddef(def_from)^.typ)],basedeftbl[porddef(def_to)^.typ]];
+                   b:=1;
+                   if (doconv=tc_not_possible) or
+                      ((doconv=tc_int_2_bool) and
+                       (not explicit) and
+                       (not is_boolean(def_from))) or
+                      ((doconv=tc_bool_2_int) and
+                       (not explicit) and
+                       (not is_boolean(def_to))) then
+                     b:=0;
+                 end
+              else if typeof(def_from^)=typeof(Torddef) then
+                 begin
+                   { needed for char(enum) }
+                   if explicit then
+                    begin
+                      doconv:=tc_int_2_int;
+                      b:=1;
+                    end;
+                 end;
+            end
+         else if typeof(def_to^)=typeof(Tstringdef) then
+             begin
+               if typeof(def_from^)=typeof(Tstringdef) then
+                   begin
+                     doconv:=tc_string_2_string;
+                     b:=1;
+                   end
+               else if typeof(def_from^)=typeof(Torddef) then
+                   begin
+                   { char to string}
+                     if is_char(def_from) then
+                      begin
+                        doconv:=tc_char_2_string;
+                        b:=1;
+                      end;
+                   end
+               else if typeof(def_from^)=typeof(Tarraydef) then
+                   begin
+                   { array of char to string, the length check is done by the firstpass of this node }
+                     if is_chararray(def_from) then
+                      begin
+                        doconv:=tc_chararray_2_string;
+                        if (not(cs_ansistrings in aktlocalswitches) and
+                            is_shortstring(def_to)) or
+                           ((cs_ansistrings in aktlocalswitches) and
+                            is_ansistring(def_to)) then
+                         b:=1
+                        else
+                         b:=2;
+                      end;
+                   end
+               else if typeof(def_from^)=typeof(Tpointerdef) then
+                   begin
+                   { pchar can be assigned to short/ansistrings }
+                     if is_pchar(def_from) and not(m_tp in aktmodeswitches) then
+                      begin
+                        doconv:=tc_pchar_2_string;
+                        b:=1;
+                      end;
+                   end;
+             end
+         else if typeof(def_to^)=typeof(Tfloatdef) then
+             begin
+               if typeof(def_from^)=typeof(Torddef) then
+                   begin { ordinal to real }
+                     if is_integer(def_from) then
+                       begin
+                          if pfloatdef(def_to)^.typ=f32bit then
+                            doconv:=tc_int_2_fix
+                          else
+                            doconv:=tc_int_2_real;
+                          b:=1;
+                       end;
+                   end
+               else if typeof(def_from^)=typeof(Tfloatdef) then
+                   begin { 2 float types ? }
+                     if pfloatdef(def_from)^.typ=pfloatdef(def_to)^.typ then
+                       doconv:=tc_equal
+                     else
+                       begin
+                          if pfloatdef(def_from)^.typ=f32bit then
+                            doconv:=tc_fix_2_real
+                          else
+                            if pfloatdef(def_to)^.typ=f32bit then
+                              doconv:=tc_real_2_fix
+                            else
+                              doconv:=tc_real_2_real;
+                       end;
+                     b:=1;
+                   end;
+             end
+         else if typeof(def_to^)=typeof(Tenumdef) then
+             begin
+               if typeof(def_from^)=typeof(Tenumdef) then
+                begin
+                  if assigned(penumdef(def_from)^.basedef) then
+                   hd1:=penumdef(def_from)^.basedef
+                  else
+                   hd1:=def_from;
+                  if assigned(penumdef(def_to)^.basedef) then
+                   hd2:=penumdef(def_to)^.basedef
+                  else
+                   hd2:=def_to;
+                  if (hd1=hd2) then
+                   b:=1;
+                end;
+             end
+         else if typeof(def_to^)=typeof(Tarraydef) then
+             begin
+             { open array is also compatible with a single element of its base type }
+               if is_open_array(def_to) and
+                  is_equal(parraydef(def_to)^.definition,def_from) then
+                begin
+                  doconv:=tc_equal;
+                  b:=1;
+                end
+               else
+                begin
+                  if typeof(def_from^)=typeof(Tarraydef) then
+                      begin
+                        { array constructor -> open array }
+                        if is_open_array(def_to) and
+                           is_array_constructor(def_from) then
+                         begin
+                           if is_void(parraydef(def_from)^.definition) or
+                              is_equal(parraydef(def_to)^.definition,parraydef(def_from)^.definition) then
+                            begin
+                              doconv:=tc_equal;
+                              b:=1;
+                            end
+                           else
+                            if isconvertable(parraydef(def_to)^.definition,
+                                             parraydef(def_from)^.definition,hct,nothingn,false)<>0 then
+                             begin
+                               doconv:=hct;
+                               b:=2;
+                             end;
+                         end;
+                      end
+                  else if typeof(def_from^)=typeof(Tpointerdef) then
+                      begin
+                        if is_zero_based_array(def_to) and
+                           is_equal(ppointerdef(def_from)^.definition,parraydef(def_to)^.definition) then
+                         begin
+                           doconv:=tc_pointer_2_array;
+                           b:=1;
+                         end;
+                      end
+                  else if typeof(def_from^)=typeof(Tstringdef) then
+                      begin
+                        { string to array of char}
+                        if (not(is_special_array(def_to)) or is_open_array(def_to)) and
+                          is_equal(parraydef(def_to)^.definition,cchardef) then
+                         begin
+                           doconv:=tc_string_2_chararray;
+                           b:=1;
+                         end;
+                      end;
+                end;
+             end
+         else if typeof(def_to^)=typeof(Tpointerdef) then
+             begin
+               if typeof(def_from^)=typeof(Tstringdef) then
+                   begin
+                     { string constant to zero terminated string constant }
+                     if (fromtreetype=stringconstn) and
+                        is_pchar(def_to) then
+                      begin
+                        doconv:=tc_cstring_2_pchar;
+                        b:=1;
+                      end;
+                   end
+               else if typeof(def_from^)=typeof(Torddef) then
+                   begin
+                     { char constant to zero terminated string constant }
+                     if (fromtreetype=ordconstn) then
+                      begin
+                        if is_equal(def_from,cchardef) and
+                           is_pchar(def_to) then
+                         begin
+                           doconv:=tc_cchar_2_pchar;
+                           b:=1;
+                         end
+                        else
+                         if is_integer(def_from) then
+                          begin
+                            doconv:=tc_cord_2_pointer;
+                            b:=1;
+                          end;
+                      end;
+                   end
+               else if typeof(def_from^)=typeof(Tarraydef) then
+                   begin
+                     { chararray to pointer }
+                     if is_zero_based_array(def_from) and
+                        is_equal(parraydef(def_from)^.definition,ppointerdef(def_to)^.definition) then
+                      begin
+                        doconv:=tc_array_2_pointer;
+                        b:=1;
+                      end;
+                   end
+               else if typeof(def_from^)=typeof(Tpointerdef) then
+                   begin
+                     { child class pointer can be assigned to anchestor pointers }
+                     if (
+                            {Bug in TP: typeof(( )) required when typecasting.}
+                         (typeof((Ppointerdef(def_from)^.definition^))=typeof(Tobjectdef)) and
+                         (typeof((Ppointerdef(def_to)^.definition^))=typeof(Tobjectdef)) and
+                         pobjectdef(ppointerdef(def_from)^.definition)^.is_related(
+                           pobjectdef(ppointerdef(def_to)^.definition))
+                        ) or
+                        { all pointers can be assigned to void-pointer }
+                        is_equal(ppointerdef(def_to)^.definition,voiddef) or
+                        { in my opnion, is this not clean pascal }
+                        { well, but it's handy to use, it isn't ? (FK) }
+                        is_equal(ppointerdef(def_from)^.definition,voiddef) then
+                       begin
+                         doconv:=tc_equal;
+                         b:=1;
+                       end;
+                   end
+               else if typeof(def_from^)=typeof(Tprocvardef) then
+                   begin
+                     { procedure variable can be assigned to an void pointer }
+                     { Not anymore. Use the @ operator now.}
+                     if not(m_tp_procvar in aktmodeswitches) and
+                        (typeof((Ppointerdef(def_to)^.definition^))=typeof(Torddef)) and
+                        (porddef(ppointerdef(def_to)^.definition)^.typ=uvoid) then
+                      begin
+                        doconv:=tc_equal;
+                        b:=1;
+                      end;
+                   end
+               else if (typeof(def_from^)=typeof(Tclassrefdef)) or
+                (typeof(def_from^)=typeof(Tobjectdef)) then
+                   begin
+                     { class types and class reference type
+                       can be assigned to void pointers      }
+                     if (
+                         ((typeof(def_from^)=typeof(Tobjectdef)) and
+                         (oo_is_class in pobjectdef(def_from)^.options)) or
+                         (typeof(def_from^)=typeof(Tclassrefdef))
+                        ) and
+                        (typeof((ppointerdef(def_to)^.definition^))=typeof(Torddef)) and
+                        (porddef(ppointerdef(def_to)^.definition)^.typ=uvoid) then
+                       begin
+                         doconv:=tc_equal;
+                         b:=1;
+                       end;
+                   end;
+             end
+         else if typeof(def_to^)=typeof(Tsetdef) then
+             begin
+               { automatic arrayconstructor -> set conversion }
+               if is_array_constructor(def_from) then
+                begin
+                  doconv:=tc_arrayconstructor_2_set;
+                  b:=1;
+                end;
+             end
+         else if typeof(def_to^)=typeof(Tprocvardef) then
+             begin
+               { proc -> procvar }
+               if (typeof(def_from^)=typeof(Tprocdef)) then
+                begin
+                  doconv:=tc_proc_2_procvar;
+                  if proc_to_procvar_equal(pprocdef(def_from),pprocvardef(def_to)) then
+                   b:=1;
+                end
+               else
+                { for example delphi allows the assignement from pointers }
+                { to procedure variables                                  }
+                if (m_pointer_2_procedure in aktmodeswitches) and
+                  (typeof(def_from^)=typeof(Tpointerdef)) and
+                  (typeof((ppointerdef(def_from)^.definition^))=typeof(Torddef)) and
+                  (porddef(ppointerdef(def_from)^.definition)^.typ=uvoid) then
+                begin
+                   doconv:=tc_equal;
+                   b:=1;
+                end
+               else
+               { nil is compatible with procvars }
+                if (fromtreetype=niln) then
+                 begin
+                   doconv:=tc_equal;
+                   b:=1;
+                 end;
+             end
+         else if typeof(def_to^)=typeof(Tobjectdef) then
+             begin
+               { object pascal objects }
+               if typeof(def_from^)=typeof(Tobjectdef) then
+                begin
+                  doconv:=tc_equal;
+                  if pobjectdef(def_from)^.is_related(pobjectdef(def_to)) then
+                   b:=1;
+                end
+               else
+               { Class specific }
+                if (oo_is_class in pobjectdef(def_to)^.options) then
+                 begin
+                   { void pointer also for delphi mode }
+                   if (m_delphi in aktmodeswitches) and
+                      is_voidpointer(def_from) then
+                    begin
+                      doconv:=tc_equal;
+                      b:=1;
+                    end
+                   else
+                   { nil is compatible with class instances }
+                    if (fromtreetype=niln) and (oo_is_class in pobjectdef(def_to)^.options) then
+                     begin
+                       doconv:=tc_equal;
+                       b:=1;
+                     end;
+                 end;
+             end
+         else if typeof(def_to^)=typeof(Tclassrefdef) then
+             begin
+               { class reference types }
+               if typeof(def_from^)=typeof(Tclassrefdef) then
+                begin
+                  doconv:=tc_equal;
+                  if pobjectdef(pclassrefdef(def_from)^.definition)^.is_related(
+                       pobjectdef(pclassrefdef(def_to)^.definition)) then
+                   b:=1;
+                end
+               else
+                { nil is compatible with class references }
+                if (fromtreetype=niln) then
+                 begin
+                   doconv:=tc_equal;
+                   b:=1;
+                 end;
+             end
+         else if typeof(def_to^)=typeof(Tfiledef) then
+             begin
+               { typed files are all equal to the abstract file type
+               name TYPEDFILE in system.pp in is_equal in types.pas
+               the problem is that it sholud be also compatible to FILE
+               but this would leed to a problem for ASSIGN RESET and REWRITE
+               when trying to find the good overloaded function !!
+               so all file function are doubled in system.pp
+               this is not very beautiful !!}
+               if (typeof(def_from^)=typeof(Tfiledef)) and
+                  (
+                   (
+                    (pfiledef(def_from)^.filetype = ft_typed) and
+                    (pfiledef(def_to)^.filetype = ft_typed) and
+                    (
+                     (pfiledef(def_from)^.definition=pdef(voiddef)) or
+                     (pfiledef(def_to)^.definition=pdef(voiddef))
+                    )
+                   ) or
+                   (
+                    (
+                     (pfiledef(def_from)^.filetype = ft_untyped) and
+                     (pfiledef(def_to)^.filetype = ft_typed)
+                    ) or
+                    (
+                     (pfiledef(def_from)^.filetype = ft_typed) and
+                     (pfiledef(def_to)^.filetype = ft_untyped)
+                    )
+                   )
+                  ) then
+                 begin
+                    doconv:=tc_equal;
+                    b:=1;
+                 end
+             end
+
+           else
+             begin
+             { assignment overwritten ?? }
+               if assignment_overloaded(def_from,def_to)<>nil then
+                b:=2;
+             end;
+        isconvertable:=b;
+      end;
+
+
+{****************************************************************************
+                          Register Calculation
+****************************************************************************}
+
+    { marks an lvalue as "unregable" }
+    procedure make_not_regable(p : ptree);
+      begin
+         case p^.treetype of
+            typeconvn :
+              make_not_regable(p^.left);
+            loadn :
+              if typeof(p^.symtableentry^)=typeof(Tvarsym) then
+                pvarsym(p^.symtableentry)^.properties:=
+                 pvarsym(p^.symtableentry)^.properties-[vo_regable,vo_fpuregable];
+         end;
+      end;
+
+
+    procedure left_right_max(p : ptree);
+      begin
+        if assigned(p^.left) then
+         begin
+           if assigned(p^.right) then
+            begin
+              p^.registers32:=max(p^.left^.registers32,p^.right^.registers32);
+              p^.registersfpu:=max(p^.left^.registersfpu,p^.right^.registersfpu);
+{$ifdef SUPPORT_MMX}
+              p^.registersmmx:=max(p^.left^.registersmmx,p^.right^.registersmmx);
+{$endif SUPPORT_MMX}
+            end
+           else
+            begin
+              p^.registers32:=p^.left^.registers32;
+              p^.registersfpu:=p^.left^.registersfpu;
+{$ifdef SUPPORT_MMX}
+              p^.registersmmx:=p^.left^.registersmmx;
+{$endif SUPPORT_MMX}
+            end;
+         end;
+      end;
+
+    { calculates the needed registers for a binary operator }
+    procedure calcregisters(p : ptree;r32,fpu,mmx : word);
+
+      begin
+         left_right_max(p);
+
+      { Only when the difference between the left and right registers < the
+        wanted registers allocate the amount of registers }
+
+        if assigned(p^.left) then
+         begin
+           if assigned(p^.right) then
+            begin
+              if (abs(p^.left^.registers32-p^.right^.registers32)<r32) then
+               inc(p^.registers32,r32);
+              if (abs(p^.left^.registersfpu-p^.right^.registersfpu)<fpu) then
+               inc(p^.registersfpu,fpu);
+{$ifdef SUPPORT_MMX}
+              if (abs(p^.left^.registersmmx-p^.right^.registersmmx)<mmx) then
+               inc(p^.registersmmx,mmx);
+{$endif SUPPORT_MMX}
+              { the following is a little bit guessing but I think }
+              { it's the only way to solve same internalerrors:    }
+              { if the left and right node both uses registers     }
+              { and return a mem location, but the current node    }
+              { doesn't use an integer register we get probably    }
+              { trouble when restoring a node                      }
+              if (p^.left^.registers32=p^.right^.registers32) and
+                 (p^.registers32=p^.left^.registers32) and
+                 (p^.registers32>0) and
+                (p^.left^.location.loc in [LOC_REFERENCE,LOC_MEM]) and
+                (p^.right^.location.loc in [LOC_REFERENCE,LOC_MEM]) then
+                inc(p^.registers32);
+            end
+           else
+            begin
+              if (p^.left^.registers32<r32) then
+               inc(p^.registers32,r32);
+              if (p^.left^.registersfpu<fpu) then
+               inc(p^.registersfpu,fpu);
+{$ifdef SUPPORT_MMX}
+              if (p^.left^.registersmmx<mmx) then
+               inc(p^.registersmmx,mmx);
+{$endif SUPPORT_MMX}
+            end;
+         end;
+
+         { error CGMessage, if more than 8 floating point }
+         { registers are needed                         }
+         if p^.registersfpu>8 then
+          CGMessage(cg_e_too_complex_expr);
+      end;
+
+{****************************************************************************
+                          Subroutine Handling
+****************************************************************************}
+
+{ protected field handling
+  protected field can not appear in
+  var parameters of function !!
+  this can only be done after we have determined the
+  overloaded function
+  this is the reason why it is not in the parser, PM }
+
+(*  procedure test_protected_sym(sym : Pprocsym);
+      begin
+         if (sp_protected in sym^.symoptions) and
+            ((sym^.owner^.symtabletype=unitsymtable) or
+             ((sym^.owner^.symtabletype=objectsymtable) and
+             (pobjectdef(sym^.owner^.defowner)^.owner^.symtabletype=unitsymtable))
+            ) then
+          CGMessage(parser_e_cant_access_protected_member);
+      end;
+
+
+    procedure test_protected(p : ptree);
+      begin
+        case p^.treetype of
+         loadn : test_protected_sym(p^.symtableentry);
+     typeconvn : test_protected(p^.left);
+        derefn : test_protected(p^.left);
+    subscriptn : begin
+                 { test_protected(p^.left);
+                   Is a field of a protected var
+                   also protected ???  PM }
+                   test_protected_sym(p^.vs);
+                 end;
+        end;
+      end;*)
+
+   function  valid_for_formal_var(p : ptree) : boolean;
+     var
+        v : boolean;
+     begin
+        case p^.treetype of
+         loadn : v:=(typeof(p^.symtableentry^)=typeof(Ttypedconstsym)) or
+                      (typeof(p^.symtableentry^)=typeof(Tvarsym));
+     typeconvn : v:=valid_for_formal_var(p^.left);
+         typen : v:=false;
+     derefn,subscriptn,vecn,
+     funcretn,selfn : v:=true;
+        { procvars are callnodes first }
+         calln : v:=assigned(p^.right) and not assigned(p^.left);
+        { should this depend on mode ? }
+         addrn : v:=true;
+        { no other node accepted (PM) }
+        else v:=false;
+        end;
+        valid_for_formal_var:=v;
+     end;
+
+   function  valid_for_formal_const(p : ptree) : boolean;
+     var
+        v : boolean;
+     begin
+        { p must have been firstpass'd before }
+        { accept about anything but not a statement ! }
+        v:=true;
+        if (p^.treetype in [calln,statementn]) then
+      {  if not assigned(p^.resulttype) or (p^.resulttype=pdef(voiddef)) then }
+          v:=false;
+        valid_for_formal_const:=v;
+     end;
+
+    function is_procsym_load(p:Ptree):boolean;
+      begin
+         is_procsym_load:=((p^.treetype=loadn) and (typeof(p^.symtableentry^)=typeof(Tprocsym)) or
+                          ((p^.treetype=addrn) and (p^.left^.treetype=loadn)
+                          and (typeof(p^.left^.symtableentry^)=typeof(Tprocsym))));
+      end;
+
+   { change a proc call to a procload for assignment to a procvar }
+   { this can only happen for proc/function without arguments }
+    function is_procsym_call(p:Ptree):boolean;
+      begin
+        is_procsym_call:=(p^.treetype=calln) and (p^.left=nil) and
+             (((typeof(p^.symtableprocentry^)=typeof(Tprocsym)) and (p^.right=nil)) or
+             ((p^.right<>nil) and (typeof(p^.right^.symtableprocentry^)=typeof(Tvarsym))));
+      end;
+
+
+    function assignment_overloaded(from_def,to_def : pdef) : pprocdef;
+
+        function matches(item:pointer):boolean;{$IFDEF TP}far;{$ENDIF TP}
+
+        var first_param_def:Pdef;
+            convtyp:Tconverttype;
+
+        begin
+            {The right assignment overload had been found when:
+             - The retdef of item equals the to_def.
+             - The definition of the first parameter equals the from_def
+               or it can be converted to from_def.}
+            first_param_def:=Pparamsym(Pparameter(Pprocdef(item)^.
+             parameters^.at(0))^.data)^.definition;
+            if is_equal(Pprocdef(item)^.retdef,to_def) and
+             (is_equal(first_param_def,from_def) or
+             (isconvertable(from_def,first_param_def,
+              convtyp,ordconstn,false)=1)) then
+                matches:=true;
+        end;
+
+    var passproc:Pprocdef;
+
+    begin
+        assignment_overloaded:=nil;
+        if overloaded_operators[_assignment]<>nil then
+            assignment_overloaded:=overloaded_operators[_assignment]^.
+             firstthat(@matches);
+    end;
+
+
+    { local routines can't be assigned to procvars }
+    procedure test_local_to_procvar(from_def:pprocvardef;to_def:pdef);
+
+    begin
+        if (typeof(from_def^.owner^)=typeof(Tprocsymtable)) and
+         (typeof(to_def^)=typeof(Tprocvardef)) then
+            CGMessage(type_e_cannot_local_proc_to_procvar);
+    end;
+
+
+    function valid_for_assign(p:ptree;allowprop:boolean):boolean;
+      var
+        hp : ptree;
+        gotsubscript,
+        gotpointer,
+        gotclass,
+        gotderef : boolean;
+      begin
+        valid_for_assign:=false;
+        gotsubscript:=false;
+        gotderef:=false;
+        gotclass:=false;
+        gotpointer:=false;
+        hp:=p;
+        while assigned(hp) do
+         begin
+           { property allowed? calln has a property check itself }
+           if (not allowprop) and
+              (hp^.isproperty) and
+              (hp^.treetype<>calln) then
+            begin
+              CGMessagePos(hp^.fileinfo,type_e_argument_cant_be_assigned);
+              exit;
+            end;
+           case hp^.treetype of
+             derefn :
+               begin
+                 gotderef:=true;
+                 hp:=hp^.left;
+               end;
+             typeconvn :
+                begin
+                    if typeof(hp^.resulttype^)=typeof(Tpointerdef) then
+                        gotpointer:=true
+                    else if typeof(hp^.resulttype^)=typeof(Tobjectdef) then
+                        gotclass:=oo_is_class in Pobjectdef(hp^.resulttype)^.options
+                    else if typeof(hp^.resulttype^)=typeof(Tclassrefdef) then
+                        gotclass:=true
+                    else if (typeof(hp^.resulttype^)=typeof(Tarraydef)) and
+                     (typeof(hp^.left^.resulttype^)=typeof(Tpointerdef)) then
+                        gotderef:=true;
+                    hp:=hp^.left;
+                end;
+             vecn,
+             asn :
+               hp:=hp^.left;
+             subscriptn :
+               begin
+                 gotsubscript:=true;
+                 hp:=hp^.left;
+               end;
+             subn,
+             addn :
+               begin
+                 { Allow add/sub operators on a pointer, or an integer
+                   and a pointer typecast and deref has been found }
+                 if (typeof(hp^.resulttype^)=typeof(Tpointerdef)) or
+                    (is_integer(hp^.resulttype) and gotpointer and gotderef) then
+                  valid_for_assign:=true
+                 else
+                  CGMessagePos(hp^.fileinfo,type_e_variable_id_expected);
+                 exit;
+               end;
+             addrn :
+               begin
+                 if not(gotderef) and
+                    not(hp^.procvarload) then
+                  CGMessagePos(hp^.fileinfo,type_e_no_assign_to_addr);
+                 exit;
+               end;
+             selfn,
+             funcretn :
+               begin
+                 valid_for_assign:=true;
+                 exit;
+               end;
+             calln :
+               begin
+                    { check return type }
+                    if typeof(hp^.resulttype^)=typeof(Tpointerdef) then
+                        gotpointer:=true
+                    else if typeof(hp^.resulttype^)=typeof(Tobjectdef) then
+                        gotclass:=oo_is_class in Pobjectdef(hp^.resulttype)^.options
+                    else if typeof(hp^.resulttype^)=typeof(Tclassrefdef) then
+                        gotclass:=true;
+
+                    { 1. if it returns a pointer and we've found a deref,
+                      2. if it returns a class and a subscription is found,
+                      3. property is allowed }
+                    if (gotpointer and gotderef) or
+                     (gotclass and gotsubscript) or
+                     (hp^.isproperty and allowprop) then
+                        valid_for_assign:=true
+                    else
+                        CGMessagePos(hp^.fileinfo,type_e_argument_cant_be_assigned);
+                    exit;
+               end;
+             loadn :
+               begin
+                 if (typeof(hp^.symtableentry^)=typeof(Tabsolutesym)) or
+                  (typeof(hp^.symtableentry^)=typeof(Tparamsym)) or
+                  (typeof(hp^.symtableentry^)=typeof(Tvarsym)) then
+                     begin
+                       if (typeof(hp^.symtableentry^)=typeof(Tparamsym)) and
+                        (Pparamsym(hp^.symtableentry)^.varspez=vs_const) then
+                           begin
+                             { allow p^:= constructions with p is const parameter }
+                             if gotderef then
+                              valid_for_assign:=true
+                             else
+                              CGMessagePos(hp^.fileinfo,type_e_no_assign_to_const);
+                             exit;
+                           end;
+                       { Are we at a with symtable, then we need to process the
+                         withrefnode also to check for maybe a const load }
+                       if typeof(hp^.symtable^)=typeof(Twithsymtable) then
+                        begin
+                          { continue with processing the withref node }
+                          hp:=ptree(pwithsymtable(hp^.symtable)^.withrefnode);
+                        end
+                       else
+                        begin
+                          { set the assigned flag for varsyms }
+                          if (pvarsym(hp^.symtableentry)^.state=vs_declared) then
+                           pvarsym(hp^.symtableentry)^.state:=vs_assigned;
+                          valid_for_assign:=true;
+                          exit;
+                        end;
+                     end;
+                 if (typeof(hp^.symtableentry^)=typeof(Tfuncretsym)) or
+                  (typeof(hp^.symtableentry^)=typeof(Ttypedconstsym)) then
+                     begin
+                       valid_for_assign:=true;
+                       exit;
+                     end;
+               end;
+             else
+                 CGMessagePos(hp^.fileinfo,type_e_variable_id_expected);
+                 exit;
+            end;
+         end;
+      end;
+
+end.
+{
+  $Log$
+  Revision 1.1  2000-02-28 17:23:58  daniel
+  * Current work of symtable integration committed. The symtable can be
+    activated by defining 'newst', but doesn't compile yet. Changes in type
+    checking and oop are completed. What is left is to write a new
+    symtablestack and adapt the parser to use it.
+
+  Revision 1.59  2000/02/18 16:13:29  florian
+    * optimized ansistring compare with ''
+    * fixed 852
+
+  Revision 1.58  2000/02/09 13:22:53  peter
+    * log truncated
+
+  Revision 1.57  2000/02/05 12:11:50  peter
+    * property check for assigning fixed for calln
+
+  Revision 1.56  2000/02/01 09:41:27  peter
+    * allow class -> voidpointer for delphi mode
+
+  Revision 1.55  2000/01/07 01:14:27  peter
+    * updated copyright to 2000
+
+  Revision 1.54  1999/12/31 14:26:27  peter
+    * fixed crash with empty array constructors
+
+  Revision 1.53  1999/12/18 14:55:21  florian
+    * very basic widestring support
+
+  Revision 1.52  1999/12/16 19:12:04  peter
+    * allow constant pointer^ also for assignment
+
+  Revision 1.51  1999/12/09 09:35:54  peter
+    * allow assigning to self
+
+  Revision 1.50  1999/11/30 10:40:43  peter
+    + ttype, tsymlist
+
+  Revision 1.49  1999/11/18 15:34:45  pierre
+    * Notes/Hints for local syms changed to
+      Set_varstate function
+
+  Revision 1.48  1999/11/09 14:47:03  peter
+    * pointer->array is allowed for all pointer types in FPC, fixed assign
+      check for it.
+
+  Revision 1.47  1999/11/09 13:29:33  peter
+    * valid_for_assign allow properties with calln
+
+  Revision 1.46  1999/11/08 22:45:33  peter
+    * allow typecasting to integer within pointer typecast+deref
+
+  Revision 1.45  1999/11/06 14:34:21  peter
+    * truncated log to 20 revs
+
+  Revision 1.44  1999/11/04 23:11:21  peter
+    * fixed pchar and deref detection for assigning
+
+  Revision 1.43  1999/10/27 16:04:45  peter
+    * valid_for_assign support for calln,asn
+
+  Revision 1.42  1999/10/26 12:30:41  peter
+    * const parameter is now checked
+    * better and generic check if a node can be used for assigning
+    * export fixes
+    * procvar equal works now (it never had worked at least from 0.99.8)
+    * defcoll changed to linkedlist with pparaitem so it can easily be
+      walked both directions
+
+  Revision 1.41  1999/10/14 14:57:52  florian
+    - removed the hcodegen use in the new cg, use cgbase instead
+
+  Revision 1.40  1999/09/26 21:30:15  peter
+    + constant pointer support which can happend with typecasting like
+      const p=pointer(1)
+    * better procvar parsing in typed consts
+
+  Revision 1.39  1999/09/17 17:14:04  peter
+    * @procvar fixes for tp mode
+    * @<id>:= gives now an error
+
+  Revision 1.38  1999/08/17 13:26:07  peter
+    * arrayconstructor -> arrayofconst fixed when arraycosntructor was not
+      variant.
+
+}

compiler/new/symtable/symbols.pas

@@ -29,20 +29,14 @@ unit symbols;
 
 interface
 
-uses    symtable,aasm,objects,cobjects,defs
-{$ifdef i386}
-        ,i386base
-{$endif}
-{$ifdef m68k}
-        ,m68k
-{$endif}
-{$ifdef alpha}
-        ,alpha
-{$endif};
+uses    symtable,aasm,objects,cobjects,defs,cpubase,tokens;
 
 {Note: It is forbidden to add the symtablt unit. A symbol should not now in
  which symtable it is.}
 
+{The tokens unit is only needed for the overloaded operators array. This
+ array can better be moved into another unit.}
+
 type    Ttypeprop=(sp_primary_typesym);
         Ttypepropset=set of Ttypeprop;
 
@@ -50,10 +44,13 @@ type    Ttypeprop=(sp_primary_typesym);
                    ppo_stored,ppo_published);
         Tproppropset=set of Tpropprop;
 
-        Tvarprop=(vo_regable,vo_is_C_var,vo_is_external,vo_is_dll_var,
-                  vo_is_thread_var);
+        Tvarprop=(vo_regable,vo_fpuregable,vo_is_C_var,vo_is_external,
+                  vo_is_dll_var,vo_is_thread_var);
         Tvarpropset=set of Tvarprop;
 
+        {State of a variable, if it's declared, assigned or used.}
+        Tvarstate=(vs_none,vs_declared,vs_declared_and_first_found,
+                   vs_set_but_first_not_passed,vs_assigned,vs_used);
 
         Plabelsym=^Tlabelsym;
         Tlabelsym=object(Tsym)
@@ -93,6 +90,7 @@ type    Ttypeprop=(sp_primary_typesym);
             _class:Pobjectdef;
             constructor init(const n:string;Asub_of:Pprocsym);
             constructor load(var s:Tstream);
+            function firstthat(action:pointer):Pprocdef;
             procedure foreach(action:pointer);
             procedure insert(def:Pdef);
             function mangledname:string;virtual; {Causes internalerror.}
@@ -135,7 +133,7 @@ type    Ttypeprop=(sp_primary_typesym);
 
         Pmacrosym=^Tmacrosym;
         Tmacrosym=object(Tsym)
-            defined:boolean;
+            defined,is_used:boolean;
             buftext:Pchar;
             buflen:longint;
             {Macros aren't written to PPU files !}
@@ -167,6 +165,7 @@ type    Ttypeprop=(sp_primary_typesym);
             definition:Pdef;
             refs:longint;
             properties:Tvarpropset;
+            state:Tvarstate;
             objprop:Tobjpropset;
             _mangledname:Pstring;
             reg:Tregister;  {If reg<>R_NO, then the variable is an register
@@ -259,6 +258,7 @@ type    Ttypeprop=(sp_primary_typesym);
         Tpropertysym=object(Tsym)
             properties:Tproppropset;
             definition:Pdef;
+            objprop:Tobjpropset;
             readaccesssym,writeaccesssym,storedsym:Psym;
             readaccessdef,writeaccessdef,storeddef:Pdef;
             index,default:longint;
@@ -268,12 +268,34 @@ type    Ttypeprop=(sp_primary_typesym);
             procedure deref;virtual;
         end;
 
-var current_object_option:Tobjpropset;
+const   {Last and first operators which can be overloaded.}
+        first_overloaded = _PLUS;
+        last_overloaded  = _ASSIGNMENT;
+        overloaded_names : array [first_overloaded..
+                                  last_overloaded] of string[16] =
+             ('plus','minus','star','slash',
+              'equal','greater','lower','greater_or_equal',
+              'lower_or_equal','sym_diff','starstar','as',
+              'is','in','or','and',
+              'div','mod','shl','shr',
+              'xor','assign');
+
+var current_object_option:Tobjprop;
     current_type_option:Ttypepropset;
 
+    aktprocsym:Pprocsym;    {Pointer to the symbol for the
+                             currently be parsed procedure.}
+    aktvarsym:Pvarsym;      {Pointer to the symbol for the
+                             currently read var, only used
+                             for variable directives.}
+
+    overloaded_operators:array[first_overloaded..
+                               last_overloaded] of Pprocsym;
+       { unequal is not equal}
+
 implementation
 
-uses    callspec,verbose,globals,systems,globtype;
+uses    {callspec,}verbose,globals,systems,globtype;
 
 {****************************************************************************
                                  Tlabelsym
@@ -334,6 +356,17 @@ begin
 {   definition:=Pprocdef(readdefref);}
 end;
 
+function Tprocsym.firstthat(action:pointer):Pprocdef;
+
+begin
+    firstthat:=nil;
+    if definitions<>nil then
+        if typeof(definitions^)=typeof(Tcollection) then
+            firstthat:=Pcollection(definitions)^.firstthat(action)
+        else
+            {***callpointer};
+end;
+
 procedure Tprocsym.foreach(action:pointer);
 
 begin
@@ -342,7 +375,7 @@ begin
             if typeof(definitions^)=typeof(Tcollection) then
                 Pcollection(definitions)^.foreach(action)
             else
-                callpointerlocal(action,previousframepointer,definitions);
+                {***callpointerlocal(action,previousframepointer,definitions)};
         end;
 end;
 
@@ -366,6 +399,10 @@ end;
 
 function Tprocsym.mangledname:string;
 
+{This function calls internalerror, because procsyms can be overloaded.
+ Procedures should use the foreach to check for the right overloaded procsym
+ and then call mangledname on that procsym.}
+
 begin
     internalerror($99080201);
 end;
@@ -934,36 +971,25 @@ var storefilepos:Tfileposinfo;
 
 begin
     storefilepos:=aktfilepos;
-    {Handle static variables of objects especially }
-    if read_member and (sp_static in objprop) then
-        begin
-            {The data field is generated in parser.pas
-             with a tobject_FIELDNAME variable, so we do
-             not need to do it in this procedure.}
-
-            {This symbol can't be loaded to a register.}
-            exclude(properties,vo_regable);
-        end
+    if not(read_member) then
+        pushaddress:=owner^.varsymtodata(@self,getpushsize);
+    if (varspez=vs_var) then
+        address:=0
+    else if (varspez=vs_value) then
+        if dp_pointer_param in definition^.properties then
+            begin
+                {Allocate local space.}
+                address:=owner^.datasize;
+                inc(owner^.datasize,getsize);
+            end
+        else
+            address:=pushaddress
     else
-        if not(read_member) then
-            pushaddress:=owner^.varsymtodata(@self,getpushsize);
-        if (varspez=vs_var) then
+        {vs_const}
+        if dp_pointer_param in definition^.properties then
             address:=0
-        else if (varspez=vs_value) then
-            if dp_pointer_param in definition^.properties then
-                begin
-                    {Allocate local space.}
-                    address:=owner^.datasize;
-                    inc(owner^.datasize,getsize);
-                end
-            else
-                address:=pushaddress
         else
-            {vs_const}
-            if dp_pointer_param in definition^.properties then
-                address:=0
-            else
-                address:=pushaddress;
+            address:=pushaddress;
     aktfilepos:=storefilepos;
 end;
 

compiler/new/symtable/symtable.pas

@@ -29,7 +29,7 @@ unit symtable;
 
 interface
 
-uses    objects,cobjects,aasm,globtype,i386base;
+uses    objects,cobjects,aasm,globtype,cpubase;
 
 
 type    Tdefprop=(dp_regable,           {Can be stored into a register.}
@@ -162,6 +162,9 @@ type    Tdefprop=(dp_regable,           {Can be stored into a register.}
 
 const   systemunit:Psymtable            = nil; {Pointer to the system unit.}
         objpasunit:Psymtable            = nil; {Pointer to the objpas unit.}
+        macros:Psymtable                = nil; {Pointer to macro list.}
+
+const   defalignment=4;
 
 var     read_member : boolean;      {True, wenn Members aus einer PPU-
                                      Datei gelesen werden, d.h. ein
@@ -238,7 +241,7 @@ begin
     indexgrow:=index_growsize;
     new(defindex,init(2*indexgrow,indexgrow));
     new(symsearch,init);
-    alignment:=def_alignment;
+    alignment:=defalignment;
     index_growsize:=16;
 end;
 

compiler/new/symtable/symtablt.pas

@@ -38,6 +38,7 @@ type    Pglobalsymtable=^Tglobalsymtable;
         Pprocsymtable=^Tprocsymtable;
         Punitsymtable=^Tunitsymtable;
         Pobjectsymtable=^Tobjectsymtable;
+        Pwithsymtable=^Twithsymtable;
 
         Tglobalsymtable=object(Tcontainingsymtable)
             constructor init;
@@ -63,13 +64,13 @@ type    Pglobalsymtable=^Tglobalsymtable;
         end;
 
         Precordsymtable=^Trecordsymtable;
-        Trecordsymtable=object(Tabstractsymtable)
+        Trecordsymtable=object(Tabstractrecordsymtable)
         end;
 
         Tobjectsymtable=object(Tabstractrecordsymtable)
             defowner:Pobjectsymtable;
-            function speedsearch(const s:stringid;
-                                 speedvalue:longint):Psym;virtual;
+{           function speedsearch(const s:stringid;
+                                 speedvalue:longint):Psym;virtual;}
         end;
 
         Tprocsymtable=object(Tcontainingsymtable)
@@ -101,6 +102,9 @@ type    Pglobalsymtable=^Tglobalsymtable;
 
         Twithsymtable=object(Tsymtable)
             link:Pcontainingsymtable;
+            {If with a^.b.c is encountered, withrefnode points to a tree
+             a^.b.c .}
+            withrefnode:pointer;
             constructor init(Alink:Pcontainingsymtable);
             function speedsearch(const s:stringid;
                                  speedvalue:longint):Psym;virtual;
@@ -147,7 +151,7 @@ begin
         segment:=consts
     else
         segment:=datasegment;
-    if (cs_smartlink in aktmoduleswitches) then
+    if (cs_create_smart in aktmoduleswitches) then
         segment^.concat(new(Pai_cut,init));
     ali:=data_align(len);
     align(datasize,ali);
@@ -155,7 +159,7 @@ begin
     if cs_debuginfo in aktmoduleswitches then
         concatstabto(segment);
 {$endif GDB}
-    segment^.concat(new(Pai_symbol,initname_global(sym^.mangledname)));
+    segment^.concat(new(Pai_symbol,initname_global(sym^.mangledname,len)));
 end;
 
 function Tglobalsymtable.varsymtodata(sym:Psym;len:longint):longint;
@@ -163,7 +167,7 @@ function Tglobalsymtable.varsymtodata(sym:Psym;len:longint):longint;
 var ali:longint;
 
 begin
-    if (cs_smartlink in aktmoduleswitches) then
+    if (cs_create_smart in aktmoduleswitches) then
         bsssegment^.concat(new(Pai_cut,init));
     ali:=data_align(len);
     align(datasize,ali);
@@ -219,7 +223,8 @@ function Tabstractrecordsymtable.varsymtodata(sym:Psym;
                                              len:longint):longint;
 
 begin
-    datasize:=(datasize+(aktpackrecords-1)) and (not aktpackrecords-1);
+    datasize:=(datasize+(packrecordalignment[aktpackrecords]-1))
+     and (not packrecordalignment[aktpackrecords]-1);
     varsymtodata:=inherited varsymtodata(sym,len);
 end;
 
@@ -231,6 +236,10 @@ end;
                              Tobjectsymtable
 ****************************************************************************}
 
+{This is not going to work this way, because the definition isn't known yet
+ when the symbol hasn't been found. For procsyms the object properties
+ are stored in the definitions, because they can be overloaded.
+
 function Tobjectsymtable.speedsearch(const s:stringid;
                                      speedvalue:longint):Psym;
 
@@ -238,7 +247,7 @@ var r:Psym;
 
 begin
     r:=inherited speedsearch(s,speedvalue);
-    if (r<>nil) and (sp_static in Pprocdef(r)^.objprop) and
+    if (r<>nil) and (Pprocdef(r)^.objprop=sp_static) and
      allow_only_static then
         begin
             message(sym_e_only_static_in_static);
@@ -246,7 +255,7 @@ begin
         end
     else
         speedsearch:=r;
-end;
+end;}
 
 {****************************************************************************
                              Tprocsymsymtable
@@ -340,7 +349,7 @@ begin
         segment:=consts
     else
         segment:=datasegment;
-    if (cs_smartlink in aktmoduleswitches) then
+    if (cs_create_smart in aktmoduleswitches) then
         segment^.concat(new(Pai_cut,init));
     ali:=data_align(len);
     align(datasize,ali);
@@ -348,10 +357,12 @@ begin
     if cs_debuginfo in aktmoduleswitches then
         concatstabto(segment);
 {$endif GDB}
-    if (cs_smartlink in aktmoduleswitches) then
-        segment^.concat(new(Pai_symbol,initname_global(sym^.mangledname)))
+    if (cs_create_smart in aktmoduleswitches) then
+        segment^.concat(new(Pai_symbol,
+                        initname_global(sym^.mangledname,len)))
     else
-        segment^.concat(new(Pai_symbol,initname(sym^.mangledname)));
+        segment^.concat(new(Pai_symbol,
+                        initname(sym^.mangledname,len)));
 end;
 
 function Tunitsymtable.varsymprefix:string;

compiler/new/symtable/types.pas

@@ -0,0 +1,1037 @@
+{
+    $Id$
+    Copyright (C) 1998-2000 by Florian Klaempfl
+
+    This unit provides some help routines for type handling
+
+    This program is free software; you can redistribute it and/or modify
+    it under the terms of the GNU General Public License as published by
+    the Free Software Foundation; either version 2 of the License, or
+    (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU General Public License for more details.
+
+    You should have received a copy of the GNU General Public License
+    along with this program; if not, write to the Free Software
+    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ ****************************************************************************
+}
+unit types;
+interface
+
+    uses
+       objects,cobjects,symtable,defs;
+
+    type
+       tmmxtype = (mmxno,mmxu8bit,mmxs8bit,mmxu16bit,mmxs16bit,
+                   mmxu32bit,mmxs32bit,mmxfixed16,mmxsingle);
+
+    const
+       { true if we must never copy this parameter }
+       never_copy_const_param : boolean = false;
+
+{*****************************************************************************
+                          Basic type functions
+ *****************************************************************************}
+
+    { returns true, if def defines an ordinal type }
+    function is_ordinal(def : pdef) : boolean;
+
+    { returns the min. value of the type }
+    function get_min_value(def : pdef) : longint;
+
+    { returns true, if def defines an ordinal type }
+    function is_integer(def : pdef) : boolean;
+
+    { true if p is a boolean }
+    function is_boolean(def : pdef) : boolean;
+
+    { true if p is a char }
+    function is_char(def : pdef) : boolean;
+
+    { true if p is a void}
+    function is_void(def : pdef) : boolean;
+
+    { true if p is a smallset def }
+    function is_smallset(p : pdef) : boolean;
+
+    { returns true, if def defines a signed data type (only for ordinal types) }
+    function is_signed(def : pdef) : boolean;
+
+{*****************************************************************************
+                              Array helper functions
+ *****************************************************************************}
+
+    { true, if p points to a zero based (non special like open or
+      dynamic array def, mainly this is used to see if the array
+      is convertable to a pointer }
+    function is_zero_based_array(p : pdef) : boolean;
+
+    { true if p points to an open array def }
+    function is_open_array(p : pdef) : boolean;
+
+    { true, if p points to an array of const def }
+    function is_array_constructor(p : pdef) : boolean;
+
+    { true, if p points to a variant array }
+    function is_variant_array(p : pdef) : boolean;
+
+    { true, if p points to an array of const }
+    function is_array_of_const(p : pdef) : boolean;
+
+    { true, if p points any kind of special array }
+    function is_special_array(p : pdef) : boolean;
+
+    { true if p is a char array def }
+    function is_chararray(p : pdef) : boolean;
+
+{*****************************************************************************
+                          String helper functions
+ *****************************************************************************}
+
+    { true if p points to an open string def }
+    function is_open_string(p : pdef) : boolean;
+
+    { true if p is an ansi string def }
+    function is_ansistring(p : pdef) : boolean;
+
+    { true if p is a long string def }
+    function is_longstring(p : pdef) : boolean;
+
+    { true if p is a wide string def }
+    function is_widestring(p : pdef) : boolean;
+
+    { true if p is a short string def }
+    function is_shortstring(p : pdef) : boolean;
+
+    { true if p is a pchar def }
+    function is_pchar(p : pdef) : boolean;
+
+    { true if p is a voidpointer def }
+    function is_voidpointer(p : pdef) : boolean;
+
+    { returns true, if def uses FPU }
+    function is_fpu(def : pdef) : boolean;
+
+    { true, if def is a 64 bit int type }
+    function is_64bitint(def : pdef) : boolean;
+
+    function push_high_param(def : pdef) : boolean;
+
+    { true if a parameter is too large to copy and only the address is pushed }
+    function push_addr_param(def : pdef) : boolean;
+
+    { true, if def1 and def2 are semantical the same }
+    function is_equal(def1,def2 : pdef) : boolean;
+
+    { checks for type compatibility (subgroups of type)  }
+    { used for case statements... probably missing stuff }
+    { to use on other types                              }
+    function is_subequal(def1, def2: pdef): boolean;
+
+    { same as is_equal, but with error message if failed }
+    function CheckTypes(def1,def2 : pdef) : boolean;
+
+    { true, if two parameter lists are equal        }
+    { if value_equal_const is true, call by value   }
+    { and call by const parameter are assumed as    }
+    { equal                                         }
+    function equal_paras(paralist1,paralist2:Pcollection;value_equal_const:boolean):boolean;
+
+
+    { true if a type can be allowed for another one
+      in a func var }
+    function convertable_paras(paralist1,paralist2:Pcollection;value_equal_const:boolean):boolean;
+
+    { true if a function can be assigned to a procvar }
+    function proc_to_procvar_equal(def1:pprocdef;def2:pprocvardef) : boolean;
+
+    { if l isn't in the range of def a range check error is generated and
+      the value is placed within the range }
+    procedure testrange(def : pdef;var l : longint);
+
+    { returns the range of def }
+    procedure getrange(def : pdef;var l : longint;var h : longint);
+
+    { some type helper routines for MMX support }
+    function is_mmx_able_array(p : pdef) : boolean;
+
+    { returns the mmx type }
+    function mmx_type(p : pdef) : tmmxtype;
+
+    { returns true, if sym needs an entry in the proplist of a class rtti }
+    function needs_prop_entry(sym : psym) : boolean;
+
+implementation
+
+uses    strings,globtype,globals,htypechk,tree,verbose,symbols,symtablt;
+
+function needs_prop_entry(sym : psym) : boolean;
+
+begin
+    needs_prop_entry:=(((typeof(sym^)=typeof(Tpropertysym)) and
+     (sp_published in Ppropertysym(sym)^.objprop)) or
+     (((typeof(sym^)=typeof(Tvarsym)) and
+     (sp_published in Pvarsym(sym)^.objprop))));
+end;
+
+function equal_paras(paralist1,paralist2:Pcollection;
+                   value_equal_const:boolean):boolean;
+
+var def1,def2:Pparameter;
+    i:word;
+
+begin
+    equal_paras:=true;
+    if paralist1^.count=paralist2^.count then
+        for i:=1 to paralist1^.count do
+            begin
+                if (not is_equal(Pvarsym(def1^.data)^.definition,
+                                 Pvarsym(def2^.data)^.definition)) or
+                 (def1^.paratyp<>def2^.paratyp) then
+                    begin
+                        if (not value_equal_const) or
+                         ((def1^.paratyp<>vs_var) and
+                          (def2^.paratyp<>vs_var)) then
+                        equal_paras:=false;
+                        break;
+                    end;
+          end
+    else
+        equal_paras:=false;
+end;
+
+function convertable_paras(paralist1,paralist2:Pcollection;
+                           value_equal_const : boolean):boolean;
+
+var def1,def2:Pparameter;
+    doconv:Tconverttype;
+    i:word;
+
+begin
+    convertable_paras:=true;
+    if paralist1^.count=paralist2^.count then
+        for i:=1 to paralist1^.count do
+            begin
+                if (isconvertable(Pvarsym(def1^.data)^.definition,
+                                   Pvarsym(def2^.data)^.definition,
+                                   doconv,callparan,false)=0) or
+                 (def1^.paratyp<>def2^.paratyp) then
+                    begin
+                        if (not value_equal_const) or
+                         ((def1^.paratyp<>vs_var) and
+                          (def2^.paratyp<>vs_var)) then
+                        convertable_paras:=false;
+                        break;
+                    end;
+          end
+    else
+        convertable_paras:=false;
+end;
+
+
+{ true if a function can be assigned to a procvar }
+function proc_to_procvar_equal(def1:pprocdef;def2:pprocvardef):boolean;
+
+const   po_comp=po_compatibility_options-[pomethodpointer];
+
+var ismethod:boolean;
+
+begin
+    proc_to_procvar_equal:=false;
+    {!!!! This code should never be called with nil parameters. If you really
+     want to check this, make it an internalerror instead of an exit!! (DM)
+    if not(assigned(def1)) or not(assigned(def2)) then
+        exit;}
+    {Check for method pointer.}
+    ismethod:=(def1^.owner<>nil) and
+     (typeof(def1^.owner^)=typeof(Tobjectsymtable));
+    if (ismethod and not (pomethodpointer in def2^.options)) or
+     (not(ismethod) and (pomethodpointer in def2^.options)) then
+        begin
+            message(type_e_no_method_and_procedure_not_compatible);
+            exit;
+        end;
+    { check return value and para's and options, methodpointer is already checked
+      parameters may also be convertable }
+    proc_to_procvar_equal:=is_equal(def1^.retdef,def2^.retdef) and
+     (equal_paras(def1^.parameters,def2^.parameters,false) or
+      convertable_paras(def1^.parameters,def2^.parameters,false)) and
+     ((po_comp*def1^.options)=(po_comp*def2^.options));
+end;
+
+
+{ returns true, if def uses FPU }
+function is_fpu(def : pdef) : boolean;
+
+begin
+    is_fpu:=(typeof(def^)=typeof(Tfloatdef)) and (Pfloatdef(def)^.typ<>f32bit);
+end;
+
+
+{ true if p is an ordinal }
+function is_ordinal(def : pdef) : boolean;
+
+var dt : tbasetype;
+begin
+    if typeof(def^)=typeof(Torddef) then
+        begin
+            dt:=porddef(def)^.typ;
+            is_ordinal:=dt in [uchar,
+                               u8bit,u16bit,u32bit,u64bit,
+                               s8bit,s16bit,s32bit,s64bit,
+                               bool8bit,bool16bit,bool32bit];
+        end
+    else
+        is_ordinal:=typeof(def^)=typeof(Tenumdef);
+end;
+
+
+{ returns the min. value of the type }
+function get_min_value(def:pdef) : longint;
+
+begin
+    if typeof(def^)=typeof(Torddef) then
+        get_min_value:=porddef(def)^.low.values
+    else if typeof(def^)=typeof(Tenumdef) then
+        get_min_value:=penumdef(def)^.minval
+    else
+        internalerror($00022701);
+end;
+
+
+{ true if p is an integer }
+function is_integer(def : pdef) : boolean;
+
+begin
+    is_integer:=(typeof(Tdef)=typeof(Torddef)) and
+                (Porddef(def)^.typ in [uauto,u8bit,u16bit,u32bit,u64bit,
+                                       s8bit,s16bit,s32bit,s64bit]);
+end;
+
+
+{ true if p is a boolean }
+function is_boolean(def : pdef) : boolean;
+begin
+  is_boolean:=(typeof(def^)=typeof(Torddef)) and
+              (porddef(def)^.typ in [bool8bit,bool16bit,bool32bit]);
+end;
+
+
+{ true if p is a void }
+function is_void(def : pdef) : boolean;
+begin
+  is_void:=(typeof(def^)=typeof(Torddef)) and
+           (porddef(def)^.typ=uvoid);
+end;
+
+
+{ true if p is a char }
+function is_char(def : pdef):boolean;
+begin
+  is_char:=(typeof(def^)=typeof(Torddef)) and
+           (porddef(def)^.typ=uchar);
+end;
+
+
+{ true if p is signed (integer) }
+function is_signed(def : pdef) : boolean;
+
+var dt:Tbasetype;
+
+begin
+    if typeof(def^)=typeof(Torddef) then
+        begin
+            dt:=porddef(def)^.typ;
+            is_signed:=(dt in [s8bit,s16bit,s32bit,s64bit]);
+        end
+    else
+        is_signed:=false;
+end;
+
+
+{ true, if p points to an open string def }
+
+function is_open_string(p:Pdef):boolean;
+
+begin
+   is_open_string:=(typeof(p^)=typeof(Tstringdef)) and
+                   (pstringdef(p)^.string_typ=st_shortstring) and
+                   (pstringdef(p)^.len=0);
+end;
+
+
+{ true, if p points to a zero based array def }
+function is_zero_based_array(p : pdef) : boolean;
+begin
+   is_zero_based_array:=(typeof(p^)=typeof(Tarraydef)) and
+                        (parraydef(p)^.lowrange.values=0) and
+                        not(is_special_array(p));
+end;
+
+{ true, if p points to an open array def }
+function is_open_array(p : pdef) : boolean;
+begin
+   is_open_array:=(typeof(p^)=typeof(Tarraydef)) and
+                  (parraydef(p)^.lowrange.values=0) and
+                  (Parraydef(p)^.highrange.signed) and
+                  (parraydef(p)^.highrange.values=-1) and
+                  not(ap_constructor in Parraydef(p)^.options) and
+                  not(ap_variant in Parraydef(p)^.options) and
+                  not(ap_arrayofconst in Parraydef(p)^.options);
+end;
+
+{ true, if p points to an array of const def }
+function is_array_constructor(p : pdef) : boolean;
+
+begin
+    is_array_constructor:=(typeof(p^)=typeof(Tarraydef)) and
+                  (ap_constructor in Parraydef(p)^.options);
+end;
+
+{ true, if p points to a variant array }
+function is_variant_array(p : pdef) : boolean;
+
+begin
+    is_variant_array:=(typeof(p^)=typeof(Tarraydef)) and
+                  (ap_variant in Parraydef(p)^.options);
+end;
+
+{ true, if p points to an array of const }
+function is_array_of_const(p : pdef) : boolean;
+begin
+    is_array_of_const:=(typeof(p^)=typeof(Tarraydef)) and
+                  (ap_arrayofconst in Parraydef(p)^.options);
+end;
+
+{ true, if p points to a special array }
+
+function is_special_array(p : pdef) : boolean;
+
+begin
+    is_special_array:=(typeof(p^)=typeof(Tarraydef)) and
+                  ((ap_variant in Parraydef(p)^.options) or
+                   (ap_arrayofconst in Parraydef(p)^.options) or
+                   (ap_constructor in Parraydef(p)^.options) or
+                   is_open_array(p)
+                  );
+end;
+
+{ true if p is an ansi string def }
+function is_ansistring(p : pdef) : boolean;
+begin
+    is_ansistring:=(typeof(p^)=typeof(Tstringdef)) and
+                  (pstringdef(p)^.string_typ=st_ansistring);
+end;
+
+
+{ true if p is an long string def }
+function is_longstring(p : pdef) : boolean;
+begin
+    is_longstring:=(typeof(p^)=typeof(Tstringdef)) and
+                  (pstringdef(p)^.string_typ=st_longstring);
+end;
+
+
+{ true if p is an wide string def }
+function is_widestring(p : pdef) : boolean;
+begin
+    is_widestring:=(typeof(p^)=typeof(Tstringdef)) and
+                  (pstringdef(p)^.string_typ=st_widestring);
+end;
+
+
+{ true if p is an short string def }
+function is_shortstring(p : pdef) : boolean;
+begin
+    is_shortstring:=(typeof(p^)=typeof(Tstringdef)) and
+                   (pstringdef(p)^.string_typ=st_shortstring);
+end;
+
+{ true if p is a char array def }
+function is_chararray(p : pdef) : boolean;
+begin
+    is_chararray:=(typeof(p^)=typeof(Tarraydef)) and
+                is_equal(parraydef(p)^.definition,cchardef) and
+                not(is_special_array(p));
+end;
+
+
+{ true if p is a pchar def }
+function is_pchar(p : pdef) : boolean;
+begin
+    is_pchar:=(typeof(p^)=typeof(Tpointerdef)) and
+            is_equal(Ppointerdef(p)^.definition,cchardef);
+end;
+
+
+{ true if p is a voidpointer def }
+function is_voidpointer(p : pdef) : boolean;
+begin
+    is_voidpointer:=(typeof(p^)=typeof(Tpointerdef)) and
+                  is_equal(Ppointerdef(p)^.definition,voiddef);
+end;
+
+
+{ true if p is a smallset def }
+function is_smallset(p : pdef) : boolean;
+
+begin
+    is_smallset:=(typeof(p^)=typeof(Tsetdef)) and
+               (psetdef(p)^.settype=smallset);
+end;
+
+
+{ true, if def is a 64 bit int type }
+function is_64bitint(def : pdef) : boolean;
+
+begin
+    is_64bitint:=(typeof(def^)=typeof(Torddef)) and
+     (porddef(def)^.typ in [u64bit,s64bit])
+end;
+
+
+function push_high_param(def : pdef) : boolean;
+
+begin
+    push_high_param:=is_open_array(def) or
+                    is_open_string(def) or
+                    is_array_of_const(def);
+end;
+
+
+{ true if a parameter is too large to copy and only the address is pushed }
+function push_addr_param(def : pdef) : boolean;
+
+var r:boolean;
+
+begin
+    push_addr_param:=false;
+    if never_copy_const_param then
+     push_addr_param:=true
+    else
+     begin
+        if typeof(def^)=typeof(Tformaldef) then
+           push_addr_param:=true
+        else if typeof(def^)=typeof(Trecorddef) then
+           push_addr_param:=(def^.size>4)
+        else if typeof(def^)=typeof(Tarraydef) then
+            begin
+                r:=is_open_array(def) or is_array_of_const(def) or
+                 is_array_constructor(def);
+                if Parraydef(def)^.highrange.signed then
+                    r:=r or ((Parraydef(def)^.highrange.values>
+                     Parraydef(def)^.lowrange.values) and (def^.size>4))
+                else
+                    r:=r or ((Parraydef(def)^.highrange.valueu>
+                     Parraydef(def)^.lowrange.valueu) and (def^.size>4));
+            end
+        else if typeof(def^)=typeof(Tobjectdef) then
+           push_addr_param:=not (oo_is_class in Pobjectdef(def)^.options)
+        else if typeof(def^)=typeof(Tstringdef) then
+           push_addr_param:=pstringdef(def)^.string_typ in [st_shortstring,st_longstring]
+        else if typeof(def^)=typeof(Tprocvardef) then
+           push_addr_param:=(pomethodpointer in pprocvardef(def)^.options)
+        else if typeof(def^)=typeof(Tsetdef) then
+           push_addr_param:=(psetdef(def)^.settype<>smallset);
+     end;
+end;
+
+{ test if l is in the range of def, outputs error if out of range }
+procedure testrange(def : pdef;var l:longint);
+
+var lsv,hsv:longint;
+{$IFDEF TP}
+    luv:longint absolute lsv;
+    huv:longint absolute hsv;
+{$ELSE}
+    luv:cardinal absolute lsv;
+    huv:cardinal absolute hsv;
+{$ENDIF TP}
+
+begin
+   { for 64 bit types we need only to check if it is less than }
+   { zero, if def is a qword node                              }
+   if is_64bitint(def) then
+     begin
+        if (l<0) and (porddef(def)^.typ=u64bit) then
+          begin
+             l:=0;
+             if (cs_check_range in aktlocalswitches) then
+               Message(parser_e_range_check_error)
+             else
+               Message(parser_w_range_check_error);
+          end;
+     end
+   else
+     begin
+        getrange(def,lsv,hsv);
+        if (typeof(def^)=typeof(Torddef)) and
+           (porddef(def)^.typ=u32bit) then
+          begin
+              if (l<luv) or (l>huv) then
+                begin
+                   if (cs_check_range in aktlocalswitches) then
+                     Message(parser_e_range_check_error)
+                   else
+                     Message(parser_w_range_check_error);
+                end;
+          end
+        else if (l<lsv) or (l>hsv) then
+          begin
+             if (typeof(def^)=typeof(Tenumdef)) or
+                (cs_check_range in aktlocalswitches) then
+               Message(parser_e_range_check_error)
+             else
+               Message(parser_w_range_check_error);
+             { Fix the value to fit in the allocated space for this type of variable }
+               case def^.size of
+                 1: l := l and $ff;
+                 2: l := l and $ffff;
+               end
+          end;
+     end;
+end;
+
+
+{ return the range from def in l and h }
+procedure getrange(def : pdef;var l:longint;var h : longint);
+
+{Needs fixing for u32bit; low.signed etc....}
+
+begin
+    if typeof(def^)=typeof(Torddef) then
+        begin
+          l:=porddef(def)^.low.values;
+          h:=porddef(def)^.high.values;
+        end
+    else if typeof(def^)=typeof(Tenumdef) then
+        begin
+          l:=penumdef(def)^.minval;
+          h:=penumdef(def)^.maxval;
+        end
+    else if typeof(def^)=typeof(Tarraydef) then
+        begin
+          l:=parraydef(def)^.lowrange.values;
+          h:=parraydef(def)^.highrange.values;
+        end
+    else
+        internalerror(987);
+end;
+
+
+function mmx_type(p : pdef) : tmmxtype;
+begin
+   mmx_type:=mmxno;
+   if is_mmx_able_array(p) then
+     begin
+        if typeof((Parraydef(p)^.definition^))=typeof(Tfloatdef) then
+          case pfloatdef(parraydef(p)^.definition)^.typ of
+            s32real:
+              mmx_type:=mmxsingle;
+            f16bit:
+              mmx_type:=mmxfixed16
+          end
+        else
+          case porddef(parraydef(p)^.definition)^.typ of
+             u8bit:
+               mmx_type:=mmxu8bit;
+             s8bit:
+               mmx_type:=mmxs8bit;
+             u16bit:
+               mmx_type:=mmxu16bit;
+             s16bit:
+               mmx_type:=mmxs16bit;
+             u32bit:
+               mmx_type:=mmxu32bit;
+             s32bit:
+               mmx_type:=mmxs32bit;
+          end;
+     end;
+end;
+
+
+function is_mmx_able_array(p : pdef) : boolean;
+begin
+{$ifdef SUPPORT_MMX}
+   if (cs_mmx_saturation in aktlocalswitches) then
+     begin
+        is_mmx_able_array:=(p^.deftype=arraydef) and
+          not(is_special_array(p)) and
+          (
+           (
+            (parraydef(p)^.elementtype.def^.deftype=orddef) and
+            (
+             (
+              (parraydef(p)^.lowrange=0) and
+              (parraydef(p)^.highrange=1) and
+              (porddef(parraydef(p)^.elementtype.def)^.typ in [u32bit,s32bit])
+             )
+             or
+             (
+              (parraydef(p)^.lowrange=0) and
+              (parraydef(p)^.highrange=3) and
+              (porddef(parraydef(p)^.elementtype.def)^.typ in [u16bit,s16bit])
+             )
+            )
+           )
+           or
+          (
+           (
+            (parraydef(p)^.elementtype.def^.deftype=floatdef) and
+            (
+             (parraydef(p)^.lowrange=0) and
+             (parraydef(p)^.highrange=3) and
+             (pfloatdef(parraydef(p)^.elementtype.def)^.typ=f16bit)
+            ) or
+            (
+             (parraydef(p)^.lowrange=0) and
+             (parraydef(p)^.highrange=1) and
+             (pfloatdef(parraydef(p)^.elementtype.def)^.typ=s32real)
+            )
+           )
+          )
+        );
+     end
+   else
+     begin
+        is_mmx_able_array:=(p^.deftype=arraydef) and
+          (
+           (
+            (parraydef(p)^.elementtype.def^.deftype=orddef) and
+            (
+             (
+              (parraydef(p)^.lowrange=0) and
+              (parraydef(p)^.highrange=1) and
+              (porddef(parraydef(p)^.elementtype.def)^.typ in [u32bit,s32bit])
+             )
+             or
+             (
+              (parraydef(p)^.lowrange=0) and
+              (parraydef(p)^.highrange=3) and
+              (porddef(parraydef(p)^.elementtype.def)^.typ in [u16bit,s16bit])
+             )
+             or
+             (
+              (parraydef(p)^.lowrange=0) and
+              (parraydef(p)^.highrange=7) and
+              (porddef(parraydef(p)^.elementtype.def)^.typ in [u8bit,s8bit])
+             )
+            )
+           )
+           or
+           (
+            (parraydef(p)^.elementtype.def^.deftype=floatdef) and
+            (
+             (
+              (parraydef(p)^.lowrange=0) and
+              (parraydef(p)^.highrange=3) and
+              (pfloatdef(parraydef(p)^.elementtype.def)^.typ=f32bit)
+             )
+             or
+             (
+              (parraydef(p)^.lowrange=0) and
+              (parraydef(p)^.highrange=1) and
+              (pfloatdef(parraydef(p)^.elementtype.def)^.typ=s32real)
+             )
+            )
+           )
+          );
+     end;
+{$else SUPPORT_MMX}
+   is_mmx_able_array:=false;
+{$endif SUPPORT_MMX}
+end;
+
+
+function is_equal(def1,def2 : pdef) : boolean;
+
+var b : boolean;
+    hd : pdef;
+    d1type,d2type:pointer;
+
+begin
+    {!!!! This code should never be called with nil parameters. If you really
+     want to check this, make it an internalerror instead of an exit!! (DM)
+    if not (assigned(def1) and assigned(def2)) then
+     begin
+       is_equal:=false;
+       exit;
+     end;}
+
+    { be sure, that if there is a stringdef, that this is def1 }
+    if typeof(def2^)=typeof(Tstringdef) then
+        begin
+            hd:=def1;
+            def1:=def2;
+            def2:=hd;
+        end;
+    b:=false;
+    d1type:=typeof(def1^);
+    d2type:=typeof(def2^);
+
+    { both point to the same definition ? }
+    if def1=def2 then
+      b:=true
+    else
+    { pointer with an equal definition are equal }
+      if (d1type=typeof(Tpointerdef)) and (d1type=d2type) then
+        begin
+           { here a problem detected in tabsolutesym }
+           { the types can be forward type !!        }
+           if assigned(def1^.sym) and
+            (typeof((Ppointerdef(def1)^.definition^))=typeof(Tforwarddef)) then
+             b:=(def1^.sym=def2^.sym)
+           else
+             b:=ppointerdef(def1)^.definition=ppointerdef(def2)^.definition;
+        end
+    else
+    { ordinals are equal only when the ordinal type is equal }
+      if (d1type=typeof(Torddef)) and (d1type=d2type) then
+        begin
+           case porddef(def1)^.typ of
+           u8bit,u16bit,u32bit,
+           s8bit,s16bit,s32bit:
+             b:=((porddef(def1)^.typ=porddef(def2)^.typ) and
+              (porddef(def1)^.low.values=porddef(def2)^.low.values) and
+              (porddef(def1)^.high.values=porddef(def2)^.high.values));
+           uvoid,uchar,
+           bool8bit,bool16bit,bool32bit:
+             b:=(porddef(def1)^.typ=porddef(def2)^.typ);
+           end;
+        end
+    else
+      if (d1type=typeof(Tfloatdef)) and (d1type=d2type) then
+        b:=pfloatdef(def1)^.typ=pfloatdef(def2)^.typ
+    else
+      { strings with the same length are equal }
+      if (d1type=typeof(Tstringdef)) and (d1type=d2type) and
+         (pstringdef(def1)^.string_typ=pstringdef(def2)^.string_typ) then
+        begin
+           b:=not(is_shortstring(def1)) or
+              (pstringdef(def1)^.len=pstringdef(def2)^.len);
+        end
+    else
+      if (d1type=typeof(Tformaldef)) and (d1type=d2type) then
+        b:=true
+    { file types with the same file element type are equal }
+    { this is a problem for assign !!                      }
+    { changed to allow if one is untyped                   }
+    { all typed files are equal to the special             }
+    { typed file that has voiddef as elemnt type           }
+    { but must NOT match for text file !!!                 }
+    else
+       if (d1type=typeof(Tfiledef)) and (d1type=d2type) then
+         b:=(pfiledef(def1)^.filetype=pfiledef(def2)^.filetype) and
+            ((
+            ((pfiledef(def1)^.definition=nil) and
+             (pfiledef(def2)^.definition=nil)) or
+            (
+             (pfiledef(def1)^.definition<>nil) and
+             (pfiledef(def2)^.definition<>nil) and
+             is_equal(pfiledef(def1)^.definition,pfiledef(def2)^.definition)
+            ) or
+            ( (pfiledef(def1)^.definition=pdef(voiddef)) or
+              (pfiledef(def2)^.definition=pdef(voiddef))
+            )))
+    { sets with the same element type are equal }
+    else
+      if (d1type=typeof(Tsetdef)) and (d1type=d2type) then
+        begin
+            if assigned(psetdef(def1)^.definition) and
+            assigned(psetdef(def2)^.definition) then
+                b:=(typeof((psetdef(def1)^.definition^))=
+                 typeof((psetdef(def2)^.definition^)))
+            else
+                b:=true;
+        end
+    else
+      if (d1type=typeof(Tprocvardef)) and (d1type=d2type) then
+        begin
+           { poassembler isn't important for compatibility }
+           { if a method is assigned to a methodpointer    }
+           { is checked before                             }
+           b:=(pprocvardef(def1)^.options=pprocvardef(def2)^.options) and
+              (pprocvardef(def1)^.calloptions=pprocvardef(def2)^.calloptions) and
+              ((pprocvardef(def1)^.options*po_compatibility_options)=
+               (pprocvardef(def2)^.options*po_compatibility_options)) and
+              is_equal(pprocvardef(def1)^.retdef,pprocvardef(def2)^.retdef) and
+              equal_paras(pprocvardef(def1)^.parameters,pprocvardef(def2)^.parameters,false);
+        end
+    else
+      if (d1type=typeof(Tarraydef)) and (d1type=d2type) then
+        begin
+          if is_open_array(def1) or is_open_array(def2) or
+             is_array_of_const(def1) or is_array_of_const(def2) then
+           begin
+             if (ap_arrayofconst in parraydef(def1)^.options) or
+              (ap_arrayofconst in parraydef(def2)^.options) then
+                b:=true
+             else
+                b:=is_equal(parraydef(def1)^.definition,parraydef(def2)^.definition);
+           end
+          else
+           begin
+             b:=not(m_tp in aktmodeswitches) and
+                not(m_delphi in aktmodeswitches) and
+                (parraydef(def1)^.lowrange.values=parraydef(def2)^.lowrange.values) and
+                (parraydef(def1)^.highrange.values=parraydef(def2)^.highrange.values) and
+                is_equal(parraydef(def1)^.definition,parraydef(def2)^.definition) and
+                is_equal(parraydef(def1)^.rangedef,parraydef(def2)^.rangedef);
+           end;
+        end
+    else
+        if (d1type=typeof(Tclassrefdef)) and (d1type=d2type) then
+        begin
+            {Similar to pointerdef:}
+            if (def1^.sym<>nil) and (typeof((pclassrefdef(def1)^.definition^))=
+             typeof(Tforwarddef)) then
+                b:=(def1^.sym=def2^.sym)
+            else
+                b:=is_equal(pclassrefdef(def1)^.definition,pclassrefdef(def2)^.definition);
+        end;
+    is_equal:=b;
+end;
+
+
+function is_subequal(def1, def2: pdef): boolean;
+
+begin
+    is_subequal := false;
+    if (typeof(def1^)=typeof(Torddef)) and (typeof(def2^)=typeof(Torddef)) then
+        { see p.47 of Turbo Pascal 7.01 manual for the separation of types }
+        { range checking for case statements is done with testrange        }
+        case porddef(def1)^.typ of
+            u8bit,u16bit,u32bit,
+            s8bit,s16bit,s32bit:
+                is_subequal:=(porddef(def2)^.typ in
+                 [s32bit,u32bit,u8bit,s8bit,s16bit,u16bit]);
+            bool8bit,bool16bit,bool32bit :
+                is_subequal:=(porddef(def2)^.typ in
+                 [bool8bit,bool16bit,bool32bit]);
+            uchar:
+                is_subequal:=(porddef(def2)^.typ=uchar);
+        end
+    else
+        { I assume that both enumerations are equal when the first }
+        { pointers are equal.                                      }
+        if (typeof(def1^)=typeof(Tenumdef)) and (typeof(def2^)=typeof(Tenumdef)) then
+          Begin
+            if penumdef(def1)^.symbols=penumdef(def2)^.symbols then
+               is_subequal := TRUE;
+          end;
+end;
+
+function CheckTypes(def1,def2 : pdef) : boolean;
+
+var
+   s1,s2 : string;
+
+begin
+    if not is_equal(def1,def2) then
+        begin
+            s1:=def1^.typename;
+            s2:=def2^.typename;
+            if (s1<>'<unknown type>') and (s2<>'<unknown type>') then
+                Message2(type_e_not_equal_types,s1,s2)
+            else
+                Message(type_e_mismatch);
+            CheckTypes:=false;
+        end
+    else
+        CheckTypes:=true;
+end;
+
+end.
+{
+  $Log$
+  Revision 1.1  2000-02-28 17:23:58  daniel
+  * Current work of symtable integration committed. The symtable can be
+    activated by defining 'newst', but doesn't compile yet. Changes in type
+    checking and oop are completed. What is left is to write a new
+    symtablestack and adapt the parser to use it.
+
+  Revision 1.97  2000/02/09 13:23:09  peter
+    * log truncated
+
+  Revision 1.96  2000/02/01 09:44:03  peter
+    * is_voidpointer
+
+  Revision 1.95  2000/01/07 01:14:49  peter
+    * updated copyright to 2000
+
+  Revision 1.94  2000/01/04 16:35:58  jonas
+    * when range checking is off, constants that are out of bound are no longer
+      truncated to their max/min legal value but left alone (jsut an "and" is done to
+      make sure they fit in the allocated space if necessary)
+
+  Revision 1.93  1999/12/31 14:26:28  peter
+    * fixed crash with empty array constructors
+
+  Revision 1.92  1999/11/30 10:40:59  peter
+    + ttype, tsymlist
+
+  Revision 1.91  1999/11/06 14:34:31  peter
+    * truncated log to 20 revs
+
+  Revision 1.90  1999/10/26 12:30:46  peter
+    * const parameter is now checked
+    * better and generic check if a node can be used for assigning
+    * export fixes
+    * procvar equal works now (it never had worked at least from 0.99.8)
+    * defcoll changed to linkedlist with pparaitem so it can easily be
+      walked both directions
+
+  Revision 1.89  1999/10/01 10:04:07  peter
+    * fixed is_equal for proc -> procvar which didn't check the
+      callconvention and type anymore since the splitting of procoptions
+
+  Revision 1.88  1999/10/01 08:02:51  peter
+    * forward type declaration rewritten
+
+  Revision 1.87  1999/09/15 22:09:27  florian
+    + rtti is now automatically generated for published classes, i.e.
+      they are handled like an implicit property
+
+  Revision 1.86  1999/09/11 09:08:35  florian
+    * fixed bug 596
+    * fixed some problems with procedure variables and procedures of object,
+      especially in TP mode. Procedure of object doesn't apply only to classes,
+      it is also allowed for objects !!
+
+  Revision 1.85  1999/08/13 21:27:08  peter
+    * more fixes for push_addr
+
+  Revision 1.84  1999/08/13 15:38:23  peter
+    * fixed push_addr_param for records < 4, the array high<low range check
+      broke this code.
+
+  Revision 1.83  1999/08/07 14:21:06  florian
+    * some small problems fixed
+
+  Revision 1.82  1999/08/07 13:36:56  daniel
+  * Recommitted the arraydef overflow bugfix.
+
+  Revision 1.80  1999/08/05 22:42:49  daniel
+  * Fixed potential bug for open arrays (Their size is not known at
+    compilation time).
+
+  Revision 1.79  1999/08/03 22:03:41  peter
+    * moved bitmask constants to sets
+    * some other type/const renamings
+
+  Revision 1.78  1999/07/30 12:26:42  peter
+    * array is_equal disabled for tp,delphi mode
+
+  Revision 1.77  1999/07/29 11:41:51  peter
+    * array is_equal extended
+
+  Revision 1.76  1999/07/27 23:39:15  peter
+    * open array checks also for s32bitdef, because u32bit also has a
+      high range of -1
+
+}

compiler/scandir.inc

@@ -750,7 +750,13 @@ const
       begin
         current_scanner^.skipspace;
         s:=AddExtension(FixFileName(current_scanner^.readcomment),target_info.objext);
-        current_module^.linkotherofiles.insert(s,link_allways);
+      {$IFDEF NEWST}
+        current_module^.linkotherofiles.
+         insert(new(Plinkitem,init(s,link_allways)));
+      {$ELSE}
+        current_module^.linkotherofiles.
+         insert(s,link_allways);
+      {$ENDIF NEWST}
       end;
 
 
@@ -771,7 +777,13 @@ const
       begin
         current_scanner^.skipspace;
         current_scanner^.readstring;
-        current_module^.linkOtherSharedLibs.insert(orgpattern,link_allways);
+      {$IFDEF NEWST}
+        current_module^.linkOtherSharedLibs.
+         insert(new(Plinkitem,init(orgpattern,link_allways)));
+      {$ELSE}
+        current_module^.linkOtherSharedLibs.
+         insert(orgpattern,link_allways);
+      {$ENDIF}
       end;
 
 
@@ -1287,7 +1299,13 @@ const
 
 {
   $Log$
-  Revision 1.75  2000-02-14 20:58:43  marco
+  Revision 1.76  2000-02-28 17:23:57  daniel
+  * Current work of symtable integration committed. The symtable can be
+    activated by defining 'newst', but doesn't compile yet. Changes in type
+    checking and oop are completed. What is left is to write a new
+    symtablestack and adapt the parser to use it.
+
+  Revision 1.75  2000/02/14 20:58:43  marco
    * Basic structures for new sethandling implemented.
 
   Revision 1.74  2000/02/09 13:23:03  peter

compiler/scanner.pas

@@ -153,7 +153,10 @@ implementation
 {$ifndef delphi}
       dos,
 {$endif delphi}
-      systems,symtable,switches;
+      systems,symtable,switches
+{$IFDEF NEWST}
+      ,symbols
+{$ENDIF NEWST};
 
 {*****************************************************************************
                               Helper routines
@@ -1782,7 +1785,13 @@ exit_label:
 end.
 {
   $Log$
-  Revision 1.105  2000-02-09 13:23:03  peter
+  Revision 1.106  2000-02-28 17:23:57  daniel
+  * Current work of symtable integration committed. The symtable can be
+    activated by defining 'newst', but doesn't compile yet. Changes in type
+    checking and oop are completed. What is left is to write a new
+    symtablestack and adapt the parser to use it.
+
+  Revision 1.105  2000/02/09 13:23:03  peter
     * log truncated
 
   Revision 1.104  2000/01/30 19:28:25  peter

compiler/t_go32v1.pas

@@ -72,7 +72,11 @@ Function TLinkergo32v1.WriteResponseFile(isdll:boolean) : Boolean;
 Var
   linkres  : TLinkRes;
   i        : longint;
+{$IFDEF NEWST}
+  HPath    : PStringItem;
+{$ELSE}
   HPath    : PStringQueueItem;
+{$ENDIF}
   s        : string;
   linklibc : boolean;
 begin
@@ -186,7 +190,13 @@ end;
 end.
 {
   $Log$
-  Revision 1.8  2000-02-09 13:23:06  peter
+  Revision 1.9  2000-02-28 17:23:57  daniel
+  * Current work of symtable integration committed. The symtable can be
+    activated by defining 'newst', but doesn't compile yet. Changes in type
+    checking and oop are completed. What is left is to write a new
+    symtablestack and adapt the parser to use it.
+
+  Revision 1.8  2000/02/09 13:23:06  peter
     * log truncated
 
   Revision 1.7  2000/01/09 00:55:51  pierre

compiler/t_go32v2.pas

@@ -71,7 +71,11 @@ Function TLinkerGo32v2.WriteResponseFile(isdll:boolean) : Boolean;
 Var
   linkres  : TLinkRes;
   i        : longint;
+{$IFDEF NEWST}
+  HPath    : PStringItem;
+{$ELSE}
   HPath    : PStringQueueItem;
+{$ENDIF NEWST}
   s        : string;
   linklibc : boolean;
 begin
@@ -288,7 +292,13 @@ end;
 end.
 {
   $Log$
-  Revision 1.9  2000-02-09 13:23:06  peter
+  Revision 1.10  2000-02-28 17:23:57  daniel
+  * Current work of symtable integration committed. The symtable can be
+    activated by defining 'newst', but doesn't compile yet. Changes in type
+    checking and oop are completed. What is left is to write a new
+    symtablestack and adapt the parser to use it.
+
+  Revision 1.9  2000/02/09 13:23:06  peter
     * log truncated
 
   Revision 1.8  2000/01/09 00:55:51  pierre

compiler/t_linux.pas

@@ -63,7 +63,7 @@ implementation
   uses
     verbose,strings,cobjects,systems,globtype,globals,
     symconst,script,
-    files,aasm,cpuasm,cpubase,symtable;
+    files,aasm,cpuasm,cpubase,symtable{$IFDEF NEWST},symbols{$ENDIF NEWST};
 
 {*****************************************************************************
                                TIMPORTLIBLINUX
@@ -77,26 +77,42 @@ end;
 procedure timportliblinux.importprocedure(const func,module : string;index : longint;const name : string);
 begin
   { insert sharedlibrary }
-  current_module^.linkothersharedlibs.insert(SplitName(module),link_allways);
+{$IFDEF NEWST}
+  current_module^.linkothersharedlibs.
+   insert(new(Plinkitem,init(SplitName(module),link_allways)));
+{$ELSE}
+  current_module^.linkothersharedlibs.
+   insert(SplitName(module),link_allways);
+{$ENDIF NEWST}
   { do nothing with the procedure, only set the mangledname }
-  if name<>'' then
+{  if name<>'' then
     aktprocsym^.definition^.setmangledname(name)
   else
-    Message(parser_e_empty_import_name);
+    Message(parser_e_empty_import_name);}
 end;
 
 
 procedure timportliblinux.importvariable(const varname,module:string;const name:string);
 begin
   { insert sharedlibrary }
-  current_module^.linkothersharedlibs.insert(SplitName(module),link_allways);
+{$IFDEF NEWST}
+  current_module^.linkothersharedlibs.
+   insert(new(Plinkitem,init(SplitName(module),link_allways)));
+{$ELSE}
+  current_module^.linkothersharedlibs.
+   insert(SplitName(module),link_allways);
+{$ENDIF NEWST}
   { reset the mangledname and turn off the dll_var option }
   aktvarsym^.setmangledname(name);
+{$IFDEF NEWST}
+  exclude(aktvarsym^.properties,vo_is_dll_var);
+{$ELSE}
 {$ifdef INCLUDEOK}
   exclude(aktvarsym^.varoptions,vo_is_dll_var);
 {$else}
   aktvarsym^.varoptions:=aktvarsym^.varoptions-[vo_is_dll_var];
 {$endif}
+{$ENDIF NEWST}
 end;
 
 
@@ -235,7 +251,11 @@ Var
   cprtobj,
   gprtobj,
   prtobj       : string[80];
+{$IFDEF NEWST}
+  HPath        : PStringItem;
+{$ELSE}
   HPath        : PStringQueueItem;
+{$ENDIF NEWST}
   s            : string;
   found,
   linkdynamic,
@@ -447,7 +467,13 @@ end;
 end.
 {
   $Log$
-  Revision 1.10  2000-02-27 14:46:04  peter
+  Revision 1.11  2000-02-28 17:23:57  daniel
+  * Current work of symtable integration committed. The symtable can be
+    activated by defining 'newst', but doesn't compile yet. Changes in type
+    checking and oop are completed. What is left is to write a new
+    symtablestack and adapt the parser to use it.
+
+  Revision 1.10  2000/02/27 14:46:04  peter
     * check for ld-so.2.0.* then no glibc21 is used, else glibc21 is used
 
   Revision 1.9  2000/02/09 10:35:48  peter

compiler/t_os2.pas

@@ -279,7 +279,12 @@ const   ar_magic:array[1..8] of char='!<arch>'#10;
 begin
     seq_no:=1;
     if not (cs_create_smart in aktmoduleswitches) then
+{$IFDEF NEWST}
+      current_module^.linkotherstaticlibs.
+       insert(new(Plinkitem,init(s,link_allways)));
+{$ELSE}
       current_module^.linkotherstaticlibs.insert(s,link_allways);
+{$ENDIF NEWST}
     assign(out_file,current_module^.path^+s+'.ao2');
     rewrite(out_file,1);
     blockwrite(out_file,ar_magic,sizeof(ar_magic));
@@ -370,7 +375,11 @@ Function TLinkeros2.WriteResponseFile(isdll:boolean) : Boolean;
 Var
   linkres  : TLinkRes;
   i        : longint;
+{$IFDEF NEWST}
+  HPath    : PStringItem;
+{$ELSE}
   HPath    : PStringQueueItem;
+{$ENDIF NEWST}
   s        : string;
 begin
   WriteResponseFile:=False;
@@ -486,7 +495,13 @@ end;
 end.
 {
   $Log$
-  Revision 1.9  2000-02-09 13:23:06  peter
+  Revision 1.10  2000-02-28 17:23:57  daniel
+  * Current work of symtable integration committed. The symtable can be
+    activated by defining 'newst', but doesn't compile yet. Changes in type
+    checking and oop are completed. What is left is to write a new
+    symtablestack and adapt the parser to use it.
+
+  Revision 1.9  2000/02/09 13:23:06  peter
     * log truncated
 
   Revision 1.8  2000/01/09 00:55:51  pierre

compiler/t_win32.pas

@@ -646,7 +646,11 @@ Function TLinkerWin32.WriteResponseFile(isdll:boolean) : Boolean;
 Var
   linkres  : TLinkRes;
   i        : longint;
+{$IFDEF NEWST}
+  HPath    : PStringItem;
+{$ELSE}
   HPath    : PStringQueueItem;
+{$ENDIF NEWST}
   s        : string;
   linklibc : boolean;
 begin
@@ -1083,7 +1087,13 @@ end;
 end.
 {
   $Log$
-  Revision 1.19  2000-02-24 18:41:39  peter
+  Revision 1.20  2000-02-28 17:23:57  daniel
+  * Current work of symtable integration committed. The symtable can be
+    activated by defining 'newst', but doesn't compile yet. Changes in type
+    checking and oop are completed. What is left is to write a new
+    symtablestack and adapt the parser to use it.
+
+  Revision 1.19  2000/02/24 18:41:39  peter
     * removed warnings/notes
 
   Revision 1.18  2000/01/12 10:31:45  peter

compiler/tree.pas

@@ -28,8 +28,13 @@ unit tree;
   interface
 
     uses
-       globtype,cobjects,
-       symconst,symtable,aasm,cpubase;
+       globtype,cobjects
+       {$IFDEF NEWST}
+       ,objects,symtable,symbols,defs
+       {$ELSE}
+       ,symconst,symtable
+       {$ENDIF NEWST}
+       ,aasm,cpubase;
 
     type
        pconstset = ^tconstset;
@@ -226,7 +231,12 @@ unit tree;
              ordconstn : (value : longint);
              realconstn : (value_real : bestreal;lab_real : pasmlabel);
              fixconstn : (value_fix: longint);
-             funcretn : (funcretprocinfo : pointer;rettype : ttype;
+             funcretn : (funcretprocinfo : pointer;
+                       {$IFDEF NEWST}
+                       retsym:Psym;
+                       {$ELSE}
+                       rettype : ttype;
+                       {$ENDIF}
                        is_first_funcret : boolean);
              subscriptn : (vs : pvarsym);
              vecn : (memindex,memseg:boolean;callunique : boolean);
@@ -240,7 +250,16 @@ unit tree;
              asmn : (p_asm : paasmoutput;object_preserved : boolean);
              casen : (nodes : pcaserecord;elseblock : ptree);
              labeln,goton : (labelnr : pasmlabel;exceptionblock : ptree;labsym : plabelsym);
-             withn : (withsymtable : pwithsymtable;tablecount : longint;withreference:preference;islocal:boolean);
+        {$IFDEF NEWST}
+             withn : (withsymtables:Pcollection;
+                      withreference:preference;
+                      islocal:boolean);
+        {$ELSE}
+             withn : (withsymtable : pwithsymtable;
+                      tablecount : longint;
+                      withreference:preference;
+                      islocal:boolean);
+        {$ENDIF NEWST}
              onn : (exceptsymtable : psymtable;excepttype : pobjectdef);
              arrayconstructn : (cargs,cargswap,forcevaria,novariaallowed: boolean;constructdef:pdef);
            end;
@@ -279,7 +298,11 @@ unit tree;
     function genloopnode(t : ttreetyp;l,r,n1: ptree;back : boolean) : ptree;
     function genasmnode(p_asm : paasmoutput) : ptree;
     function gencasenode(l,r : ptree;nodes : pcaserecord) : ptree;
-    function genwithnode(symtable : pwithsymtable;l,r : ptree;count : longint) : ptree;
+{$IFDEF NEWST}
+    function genwithnode(symtables:Pcollection;l,r : ptree) : ptree;
+{$ELSE}
+    function genwithnode(symtable:pwithsymtable;l,r : ptree;count : longint) : ptree;
+{$ENDIF NEWST}
 
     function getcopy(p : ptree) : ptree;
 
@@ -358,6 +381,9 @@ unit tree;
 {$else newcg}
        hcodegen
 {$endif newcg}
+{$IFDEF NEWST}
+       ,symtablt
+{$ENDIF}
        ;
 
     function getnode : ptree;
@@ -507,7 +533,7 @@ unit tree;
     procedure disposetree(p : ptree);
 
       var
-         symt : pwithsymtable;
+         symt : psymtable;
          i : longint;
 
       begin
@@ -594,6 +620,9 @@ unit tree;
                    disposetree(p^.left);
                  if assigned(p^.right) then
                    disposetree(p^.right);
+              {$IFDEF NEWST}
+                 dispose(p^.withsymtables,done);
+              {$ELSE}
                  symt:=p^.withsymtable;
                  for i:=1 to p^.tablecount do
                    begin
@@ -604,6 +633,7 @@ unit tree;
                         end;
                       symt:=p^.withsymtable;
                    end;
+              {$ENDIF NEWST}
               end;
             else internalerror(12);
          end;
@@ -622,6 +652,30 @@ unit tree;
         p^.fileinfo:=filepos;
      end;
 
+{$IFDEF NEWST}
+   function genwithnode(symtables:Pcollection;l,r : ptree) : ptree;
+
+      var
+         p : ptree;
+
+      begin
+         p:=getnode;
+         p^.disposetyp:=dt_with;
+         p^.treetype:=withn;
+         p^.left:=l;
+         p^.right:=r;
+         p^.registers32:=0;
+{$ifdef SUPPORT_MMX}
+         p^.registersmmx:=0;
+{$endif SUPPORT_MMX}
+         p^.resulttype:=nil;
+         p^.withsymtables:=symtables;
+         p^.withreference:=nil;
+         p^.islocal:=false;
+         set_file_line(l,p);
+         genwithnode:=p;
+      end;
+{$ELSE}
    function genwithnode(symtable : pwithsymtable;l,r : ptree;count : longint) : ptree;
 
       var
@@ -634,9 +688,6 @@ unit tree;
          p^.left:=l;
          p^.right:=r;
          p^.registers32:=0;
-         { p^.registers16:=0;
-         p^.registers8:=0; }
-         p^.registersfpu:=0;
 {$ifdef SUPPORT_MMX}
          p^.registersmmx:=0;
 {$endif SUPPORT_MMX}
@@ -648,6 +699,7 @@ unit tree;
          set_file_line(l,p);
          genwithnode:=p;
       end;
+{$ENDIF NEWST}
 
     function genfixconstnode(v : longint;def : pdef) : ptree;
 
@@ -786,8 +838,13 @@ unit tree;
 {$endif SUPPORT_MMX}
          p^.resulttype:=def;
          p^.value:=v;
+      {$IFDEF NEWST}
+         if typeof(p^.resulttype^)=typeof(Torddef) then
+          testrange(p^.resulttype,p^.value);
+      {$ELSE NEWST}
          if p^.resulttype^.deftype=orddef then
           testrange(p^.resulttype,p^.value);
+      {$ENDIF}
          genordinalconstnode:=p;
       end;
 
@@ -1004,7 +1061,11 @@ unit tree;
          p^.registersmmx:=0;
 {$endif SUPPORT_MMX}
          p^.treetype:=loadn;
+      {$IFDEF NEWST}
+         p^.resulttype:=v^.definition;
+      {$ELSE}
          p^.resulttype:=v^.vartype.def;
+      {$ENDIF NEWST}
          p^.symtableentry:=v;
          p^.symtable:=st;
          p^.is_first := False;
@@ -1029,7 +1090,12 @@ unit tree;
 {$endif SUPPORT_MMX}
          p^.treetype:=loadn;
          p^.left:=nil;
+      {$IFDEF NEWST}
+         p^.resulttype:=nil; {We don't know which overloaded procedure is
+                              wanted...}
+      {$ELSE}
          p^.resulttype:=v^.definition;
+      {$ENDIF}
          p^.symtableentry:=v;
          p^.symtable:=st;
          p^.is_first := False;
@@ -1052,7 +1118,12 @@ unit tree;
 {$endif SUPPORT_MMX}
          p^.treetype:=loadn;
          p^.left:=nil;
+      {$IFDEF NEWST}
+         p^.resulttype:=nil; {We don't know which overloaded procedure is
+                              wanted...}
+      {$ELSE}
          p^.resulttype:=v^.definition;
+      {$ENDIF}
          p^.symtableentry:=v;
          p^.symtable:=st;
          p^.is_first := False;
@@ -1078,7 +1149,11 @@ unit tree;
 {$endif SUPPORT_MMX}
          p^.treetype:=loadn;
          p^.left:=nil;
+      {$IFDEF NEWST}
+         p^.resulttype:=sym^.definition;
+      {$ELSE}
          p^.resulttype:=sym^.typedconsttype.def;
+      {$ENDIF NEWST}
          p^.symtableentry:=sym;
          p^.symtable:=st;
          p^.disposetyp:=dt_nothing;
@@ -1306,9 +1381,14 @@ unit tree;
          p^.inlineprocsym:=callp^.symtableprocentry;
          p^.retoffset:=-4; { less dangerous as zero (PM) }
          p^.para_offset:=0;
+      {$IFDEF NEWST}
+         {Fixme!!}
+         internalerror($00022801);
+      {$ELSE}
          p^.para_size:=p^.inlineprocsym^.definition^.para_size(target_os.stackalignment);
          if ret_in_param(p^.inlineprocsym^.definition^.rettype.def) then
            p^.para_size:=p^.para_size+target_os.size_of_pointer;
+      {$ENDIF NEWST}
          { copy args }
          p^.inlinetree:=code;
          p^.registers32:=code^.registers32;
@@ -1316,7 +1396,11 @@ unit tree;
 {$ifdef SUPPORT_MMX}
          p^.registersmmx:=0;
 {$endif SUPPORT_MMX}
+      {$IFDEF NEWST}
+         {Fixme!!}
+      {$ELSE}
          p^.resulttype:=p^.inlineprocsym^.definition^.rettype.def;
+      {$ENDIF NEWST}
          genprocinlinenode:=p;
       end;
 
@@ -1708,10 +1792,18 @@ unit tree;
              set_varstate(p^.left,must_be_valid);
            vecn:
              begin
+             {$IFDEF NEWST}
+               if (typeof(p^.left^.resulttype^)=typeof(Tstringdef)) or
+                (typeof(p^.left^.resulttype^)=typeof(Tarraydef)) then
+                 set_varstate(p^.left,must_be_valid)
+               else
+                 set_varstate(p^.left,true);
+             {$ELSE}
                if (p^.left^.resulttype^.deftype in [stringdef,arraydef]) then
                  set_varstate(p^.left,must_be_valid)
                else
                  set_varstate(p^.left,true);
+             {$ENDIF NEWST}
                set_varstate(p^.right,true);
              end;
            { do not parse calln }
@@ -1929,7 +2021,13 @@ unit tree;
 end.
 {
   $Log$
-  Revision 1.113  2000-02-20 20:49:46  florian
+  Revision 1.114  2000-02-28 17:23:57  daniel
+  * Current work of symtable integration committed. The symtable can be
+    activated by defining 'newst', but doesn't compile yet. Changes in type
+    checking and oop are completed. What is left is to write a new
+    symtablestack and adapt the parser to use it.
+
+  Revision 1.113  2000/02/20 20:49:46  florian
     * newcg is compiling
     * fixed the dup id problem reported by Paul Y.
 
@@ -2018,4 +2116,4 @@ end.
       a same register is freed twice (happens in several part
       of current compiler like addn for strings and sets)
 
-}
+}

compiler/types.pas

@@ -24,7 +24,10 @@ unit types;
 interface
 
     uses
-       cobjects,symtable;
+       cobjects,symtable
+       {$IFDEF NEWST}
+       ,defs
+       {$ENDIF NEWST};
 
     type
        tmmxtype = (mmxno,mmxu8bit,mmxs8bit,mmxu16bit,mmxs16bit,
@@ -1011,7 +1014,13 @@ implementation
 end.
 {
   $Log$
-  Revision 1.97  2000-02-09 13:23:09  peter
+  Revision 1.98  2000-02-28 17:23:57  daniel
+  * Current work of symtable integration committed. The symtable can be
+    activated by defining 'newst', but doesn't compile yet. Changes in type
+    checking and oop are completed. What is left is to write a new
+    symtablestack and adapt the parser to use it.
+
+  Revision 1.97  2000/02/09 13:23:09  peter
     * log truncated
 
   Revision 1.96  2000/02/01 09:44:03  peter

compiler/verbose.pas

@@ -34,8 +34,7 @@ uses
   {$i msgtxt.inc}
 {$endif}
 
-{$i msgidx.inc}
-
+{$i msgidx.INC}
 
 Const
 { <$10000 will show file and line }
@@ -507,7 +506,13 @@ end.
 
 {
   $Log$
-  Revision 1.45  2000-02-09 13:23:09  peter
+  Revision 1.46  2000-02-28 17:23:57  daniel
+  * Current work of symtable integration committed. The symtable can be
+    activated by defining 'newst', but doesn't compile yet. Changes in type
+    checking and oop are completed. What is left is to write a new
+    symtablestack and adapt the parser to use it.
+
+  Revision 1.45  2000/02/09 13:23:09  peter
     * log truncated
 
   Revision 1.44  2000/01/07 01:14:49  peter