Browse Source

* storenumber works
* fixed some typos in double_checksum
+ incompatible types type1 and type2 message (with storenumber)

peter 26 years ago
parent
commit
cb70b62a82

+ 9 - 4
compiler/aasm.pas

@@ -83,7 +83,7 @@ unit aasm;
        TAsmsymtype=(AS_EXTERNAL,AS_LOCAL,AS_GLOBAL);
 
        pasmsymbol = ^tasmsymbol;
-       tasmsymbol = object(tdictionaryobject)
+       tasmsymbol = object(tnamedindexobject)
          idx     : longint;
          section : tsection;
          address,
@@ -806,7 +806,7 @@ uses
 
     constructor tasmsymbol.init(const s:string);
       begin;
-        inherited init(s);
+        inherited initname(s);
         reset;
       end;
 
@@ -880,7 +880,7 @@ uses
       end;
 
 
-    procedure ResetAsmSym(p:Pdictionaryobject);{$ifndef FPC}far;{$endif}
+    procedure ResetAsmSym(p:Pnamedindexobject);{$ifndef FPC}far;{$endif}
       begin
         pasmsymbol(p)^.reset;
       end;
@@ -1013,7 +1013,12 @@ uses
 end.
 {
   $Log$
-  Revision 1.39  1999-04-16 11:49:36  peter
+  Revision 1.40  1999-04-21 09:43:28  peter
+    * storenumber works
+    * fixed some typos in double_checksum
+    + incompatible types type1 and type2 message (with storenumber)
+
+  Revision 1.39  1999/04/16 11:49:36  peter
     + tempalloc
     + -at to show temp alloc info in .s file
 

+ 10 - 1
compiler/cg386flw.pas

@@ -710,7 +710,11 @@ do_jmp:
 
          { what a hack ! }
          if assigned(p^.exceptsymtable) then
+{$ifdef STORENUMBER}
+           pvarsym(p^.exceptsymtable^.symindex^.first)^.address:=ref.offset;
+{$else}
            pvarsym(p^.exceptsymtable^.searchroot)^.address:=ref.offset;
+{$endif}
 
          exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L,
            R_EAX,newreference(ref))));
@@ -798,7 +802,12 @@ do_jmp:
 end.
 {
   $Log$
-  Revision 1.32  1999-04-17 13:10:58  peter
+  Revision 1.33  1999-04-21 09:43:29  peter
+    * storenumber works
+    * fixed some typos in double_checksum
+    + incompatible types type1 and type2 message (with storenumber)
+
+  Revision 1.32  1999/04/17 13:10:58  peter
     * fixed exit()
 
   Revision 1.31  1999/04/14 09:14:46  peter

+ 137 - 96
compiler/cobjects.pas

@@ -163,43 +163,47 @@ unit cobjects;
        end;
 
 
-       Pdictionary=^Tdictionary;
-
-       Pdictionaryobject=^Tdictionaryobject;
-       Tdictionaryobject=object
+       Pnamedindexobject=^Tnamedindexobject;
+       Tnamedindexobject=object
+         indexnr    : longint;
          _name      : Pstring;
+         next,
+         left,right : Pnamedindexobject;
          speedvalue : longint;
-         left,right : Pdictionaryobject;
-         owner      : Pdictionary;
-         constructor init(const n:string);
+         constructor init;
+         constructor initname(const n:string);
          destructor  done;virtual;
-         function name:string;
+         procedure setname(const n:string);
+         function  name:string;
        end;
 
        Pdictionaryhasharray=^Tdictionaryhasharray;
-       Tdictionaryhasharray=array[0..hasharraysize-1] of Pdictionaryobject;
+       Tdictionaryhasharray=array[0..hasharraysize-1] of Pnamedindexobject;
 
-       Tdictionarycallback = procedure(p:Pdictionaryobject);
+       Tnamedindexcallback = procedure(p:Pnamedindexobject);
 
+       Pdictionary=^Tdictionary;
        Tdictionary=object
          noclear   : boolean;
          replace_existing : boolean;
-         constructor init(usehash:boolean);
-         procedure clear;virtual;
-         procedure foreach(proc2call:Tdictionarycallback);
-         function insert(obj:Pdictionaryobject):Pdictionaryobject;virtual;
-         function rename(const olds,news : string):pdictionaryobject;
-         function search(const s:string):Pdictionaryobject;
-         function speedsearch(const s:string;speedvalue:longint):Pdictionaryobject;virtual;
-         destructor done;virtual;
+         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      : Pdictionaryobject;
+         root      : Pnamedindexobject;
          hasharray : Pdictionaryhasharray;
-         function  insertnode(newnode:pdictionaryobject;var currnode:pdictionaryobject):pdictionaryobject;
-         procedure inserttree(currtree,currroot:pdictionaryobject);
+         procedure cleartree(obj:Pnamedindexobject);
+         function  insertnode(newnode:Pnamedindexobject;var currnode:Pnamedindexobject):Pnamedindexobject;
+         procedure inserttree(currtree,currroot:Pnamedindexobject);
        end;
 
-
        pdynamicarray = ^tdynamicarray;
        tdynamicarray = object
          posn,
@@ -221,35 +225,25 @@ unit cobjects;
          procedure readpos(pos:longint;var d;len:longint);
        end;
 
-      pindexobject=^tindexobject;
-      tindexobject=object
-        indexnr : longint;
-        next    : pindexobject;
-        constructor init;
-        destructor  done;virtual;
-      end;
-
-      tindexcallback=procedure(p:pindexobject);
-
-      tindexobjectarray=array[1..16000] of pindexobject;
-      pindexobjectarray=^tindexobjectarray;
+      tindexobjectarray=array[1..16000] of Pnamedindexobject;
+      Pnamedindexobjectarray=^tindexobjectarray;
 
       pindexarray=^tindexarray;
       tindexarray=object
-        first : pindexobject;
+        first : Pnamedindexobject;
         count : longint;
         constructor init(Agrowsize:longint);
         destructor  done;
-        procedure clear1;
-        procedure foreach(proc2call : tindexcallback);
-        procedure deleteindex(p:pindexobject);
-        procedure delete(p:pindexobject);
-        procedure insert(p:pindexobject);
-        function  search(nr:longint):pindexobject;
+        procedure clear;
+        procedure foreach(proc2call : Tnamedindexcallback);
+        procedure deleteindex(p:Pnamedindexobject);
+        procedure delete(p:Pnamedindexobject);
+        procedure insert(p:Pnamedindexobject);
+        function  search(nr:longint):Pnamedindexobject;
       private
         growsize,
         size  : longint;
-        data  : pindexobjectarray;
+        data  : Pnamedindexobjectarray;
         procedure grow(gsize:longint);
       end;
 
@@ -943,30 +937,56 @@ end;
         empty:=(first=nil);
       end;
 
+
 {****************************************************************************
-                               Tdictionaryobject
+                               Tnamedindexobject
  ****************************************************************************}
 
-constructor Tdictionaryobject.init(const n:string);
+constructor Tnamedindexobject.init;
+begin
+  { index }
+  indexnr:=-1;
+  next:=nil;
+  { dictionary }
+  left:=nil;
+  right:=nil;
+  _name:=nil;
+  speedvalue:=-1;
+end;
+
+constructor Tnamedindexobject.initname(const n:string);
 begin
+  { index }
+  indexnr:=-1;
+  next:=nil;
+  { dictionary }
   left:=nil;
   right:=nil;
+  speedvalue:=-1;
   _name:=stringdup(n);
-  speedvalue:=getspeedvalue(n);
 end;
 
-destructor Tdictionaryobject.done;
+destructor Tnamedindexobject.done;
 begin
   stringdispose(_name);
-  if assigned(left) then
-    dispose(left,done);
-  if assigned(right) then
-    dispose(right,done);
 end;
 
-function Tdictionaryobject.name:string;
+procedure Tnamedindexobject.setname(const n:string);
 begin
-  name:=_name^;
+  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;
 
 
@@ -974,13 +994,19 @@ end;
                                TDICTIONARY
 ****************************************************************************}
 
-    constructor Tdictionary.init(usehash:boolean);
+    constructor Tdictionary.init;
       begin
         root:=nil;
         hasharray:=nil;
         noclear:=false;
         replace_existing:=false;
-        if usehash then
+      end;
+
+
+    procedure Tdictionary.usehash;
+      begin
+        if not(assigned(root)) and
+           not(assigned(hasharray)) then
          begin
            new(hasharray);
            fillchar(hasharray^,sizeof(hasharray^),0);
@@ -990,31 +1016,57 @@ end;
 
     destructor Tdictionary.done;
       begin
-        clear;
+        if not noclear then
+         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
-          dispose(root,done);
+          cleartree(root);
         if assigned(hasharray) then
          for w:=0 to hasharraysize-1 do
           if assigned(hasharray^[w]) then
-           begin
-             dispose(hasharray^[w],done);
-             hasharray^[w]:=nil;
-           end;
+           cleartree(hasharray^[w]);
+      end;
+
+
+    function Tdictionary.empty:boolean;
+      var
+        w : longint;
+      begin
+        if assigned(hasharray) then
+         begin
+           empty:=false;
+           for w:=0 to hasharraysize-1 do
+            if assigned(hasharray^[w]) then
+             exit;
+           empty:=true;
+         end
+        else
+         empty:=(root=nil);
       end;
 
 
-    procedure Tdictionary.foreach(proc2call:Tdictionarycallback);
+    procedure Tdictionary.foreach(proc2call:Tnamedindexcallback);
 
-        procedure a(p:Pdictionaryobject);
+        procedure a(p:Pnamedindexobject);
         begin
           proc2call(p);
           if assigned(p^.left) then
@@ -1038,9 +1090,8 @@ end;
       end;
 
 
-    function Tdictionary.insert(obj:Pdictionaryobject):Pdictionaryobject;
+    function Tdictionary.insert(obj:Pnamedindexobject):Pnamedindexobject;
       begin
-        obj^.owner:=@self;
         obj^.speedvalue:=getspeedvalue(obj^._name^);
         if assigned(hasharray) then
          insert:=insertnode(obj,hasharray^[obj^.speedvalue mod hasharraysize])
@@ -1049,7 +1100,7 @@ end;
       end;
 
 
-    function tdictionary.insertnode(newnode:pdictionaryobject;var currnode:pdictionaryobject):pdictionaryobject;
+    function tdictionary.insertnode(newnode:Pnamedindexobject;var currnode:Pnamedindexobject):Pnamedindexobject;
       var
         s1,s2:^string;
       begin
@@ -1103,7 +1154,7 @@ end;
       end;
 
 
-    procedure tdictionary.inserttree(currtree,currroot:pdictionaryobject);
+    procedure tdictionary.inserttree(currtree,currroot:Pnamedindexobject);
       begin
         if assigned(currtree) then
          begin
@@ -1114,11 +1165,11 @@ end;
       end;
 
 
-    function tdictionary.rename(const olds,news : string):pdictionaryobject;
+    function tdictionary.rename(const olds,news : string):Pnamedindexobject;
       var
         spdval : longint;
         lasthp,
-        hp,hp2,hp3 : pdictionaryobject;
+        hp,hp2,hp3 : Pnamedindexobject;
       begin
         spdval:=getspeedvalue(olds);
         if assigned(hasharray) then
@@ -1194,15 +1245,15 @@ end;
       end;
 
 
-    function Tdictionary.search(const s:string):Pdictionaryobject;
+    function Tdictionary.search(const s:string):Pnamedindexobject;
       begin
         search:=speedsearch(s,getspeedvalue(s));
       end;
 
 
-    function Tdictionary.speedsearch(const s:string;speedvalue:longint):Pdictionaryobject;
+    function Tdictionary.speedsearch(const s:string;speedvalue:longint):Pnamedindexobject;
       var
-        newnode:Pdictionaryobject;
+        newnode:Pnamedindexobject;
       begin
         if assigned(hasharray) then
          newnode:=hasharray^[speedvalue mod hasharraysize]
@@ -1251,7 +1302,7 @@ end;
 
     destructor tindexarray.done;
       begin
-{        clear1; }
+        clear;
         if assigned(data) then
          freemem(data,size*4);
       end;
@@ -1354,21 +1405,6 @@ end;
       end;
 
 
-{****************************************************************************
-                               tindexobject
- ****************************************************************************}
-
-    constructor tindexobject.init;
-      begin
-        indexnr:=-1;
-        next:=nil;
-      end;
-
-    destructor tindexobject.done;
-      begin
-      end;
-
-
 {****************************************************************************
                                tindexarray
  ****************************************************************************}
@@ -1384,7 +1420,7 @@ end;
       end;
 
 
-    function tindexarray.search(nr:longint):pindexobject;
+    function tindexarray.search(nr:longint):Pnamedindexobject;
       begin
         if nr<=count then
          search:=data^[nr]
@@ -1393,7 +1429,7 @@ end;
       end;
 
 
-    procedure tindexarray.clear1;
+    procedure tindexarray.clear;
       var
         i : longint;
       begin
@@ -1407,7 +1443,7 @@ end;
       end;
 
 
-    procedure tindexarray.foreach(proc2call : tindexcallback);
+    procedure tindexarray.foreach(proc2call : Tnamedindexcallback);
       var
         i : longint;
       begin
@@ -1420,7 +1456,7 @@ end;
     procedure tindexarray.grow(gsize:longint);
       var
         osize : longint;
-        odata : pindexobjectarray;
+        odata : Pnamedindexobjectarray;
       begin
         osize:=size;
         odata:=data;
@@ -1435,7 +1471,7 @@ end;
       end;
 
 
-    procedure tindexarray.deleteindex(p:pindexobject);
+    procedure tindexarray.deleteindex(p:Pnamedindexobject);
       var
         i : longint;
       begin
@@ -1458,14 +1494,14 @@ end;
       end;
 
 
-    procedure tindexarray.delete(p:pindexobject);
+    procedure tindexarray.delete(p:Pnamedindexobject);
       begin
         deleteindex(p);
         dispose(p,done);
       end;
 
 
-    procedure tindexarray.insert(p:pindexobject);
+    procedure tindexarray.insert(p:Pnamedindexobject);
       var
         i  : longint;
       begin
@@ -1896,7 +1932,12 @@ end;
 end.
 {
   $Log$
-  Revision 1.25  1999-04-15 10:01:44  peter
+  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
@@ -1912,7 +1953,7 @@ end.
     * assembler inlining working for ag386bin
 
   Revision 1.21  1999/03/19 16:35:29  pierre
-   * Tdictionaryobject done also removed left and right
+   * Tnamedindexobject done also removed left and right
 
   Revision 1.20  1999/03/18 20:30:45  peter
     + .a writer

+ 7 - 2
compiler/compiler.pas

@@ -77,7 +77,7 @@ uses
 {$ifdef fpc}
   {$ifdef GO32V2}
     emu387,
-    dpmiexcp,
+{    dpmiexcp, }
   {$endif GO32V2}
   {$ifdef LINUX}
     catch,
@@ -266,7 +266,12 @@ end;
 end.
 {
   $Log$
-  Revision 1.19  1999-03-09 11:52:06  pierre
+  Revision 1.20  1999-04-21 09:43:33  peter
+    * storenumber works
+    * fixed some typos in double_checksum
+    + incompatible types type1 and type2 message (with storenumber)
+
+  Revision 1.19  1999/03/09 11:52:06  pierre
    * compilation after a failure longjumped directly to end
 
   Revision 1.18  1999/02/26 00:48:16  peter

+ 12 - 8
compiler/files.pas

@@ -202,7 +202,7 @@ unit files;
           is_stab_written : boolean;
           u               : pmodule;
           constructor init(_u : pmodule;intface:boolean);
-          constructor init_to_load(const n:string;c:longint;intface:boolean);
+          constructor init_to_load(const n:string;c,intfc:longint;intface:boolean);
           destructor done;virtual;
        end;
 
@@ -763,6 +763,9 @@ uses
         Message1(unit_u_ppu_time,filetimestring(ppufiletime));
         Message1(unit_u_ppu_flags,tostr(flags));
         Message1(unit_u_ppu_crc,tostr(ppufile^.header.checksum));
+{$ifdef Double_checksum}
+        Message1(unit_u_ppu_crc,tostr(ppufile^.header.interface_checksum)+' (intfc)');
+{$endif}
       { check the object and assembler file to see if we need only to
         assemble, only if it's not in a library }
         do_compile:=false;
@@ -1156,7 +1159,7 @@ uses
       end;
 
 
-    constructor tused_unit.init_to_load(const n:string;c:longint;intface:boolean);
+    constructor tused_unit.init_to_load(const n:string;c,intfc:longint;intface:boolean);
       begin
         u:=nil;
         in_interface:=intface;
@@ -1166,11 +1169,7 @@ uses
         name:=stringdup(n);
         checksum:=c;
 {$ifdef Double_checksum}
-        if not in_interface then
-          begin
-             interface_checksum:=c;
-             checksum:=0;
-          end;
+        interface_checksum:=intfc;
 {$endif def Double_checksum}
         unitid:=0;
       end;
@@ -1194,7 +1193,12 @@ uses
 end.
 {
   $Log$
-  Revision 1.90  1999-04-14 09:14:48  peter
+  Revision 1.91  1999-04-21 09:43:36  peter
+    * storenumber works
+    * fixed some typos in double_checksum
+    + incompatible types type1 and type2 message (with storenumber)
+
+  Revision 1.90  1999/04/14 09:14:48  peter
     * first things to store the symbol/def number in the ppu
 
   Revision 1.89  1999/04/07 15:39:29  pierre

+ 21 - 16
compiler/hcgdata.pas

@@ -93,14 +93,14 @@ implementation
          dispose(p);
       end;
 
-    procedure insertmsgstr(p : psym);{$ifndef FPC}far;{$endif FPC}
+    procedure insertmsgstr(p : {$ifdef STORENUMBER}pnamedindexobject{$else}psym{$endif});{$ifndef FPC}far;{$endif FPC}
 
       var
          hp : pprocdef;
          pt : pprocdeftree;
 
       begin
-         if p^.typ=procsym then
+         if psym(p)^.typ=procsym then
            begin
               hp:=pprocsym(p)^.definition;
               while assigned(hp) do
@@ -141,14 +141,14 @@ implementation
            end;
       end;
 
-    procedure insertmsgint(p : psym);{$ifndef FPC}far;{$endif FPC}
+    procedure insertmsgint(p : {$ifdef STORENUMBER}pnamedindexobject{$else}psym{$endif});{$ifndef FPC}far;{$endif FPC}
 
       var
          hp : pprocdef;
          pt : pprocdeftree;
 
       begin
-         if p^.typ=procsym then
+         if psym(p)^.typ=procsym then
            begin
               hp:=pprocsym(p)^.definition;
               while assigned(hp) do
@@ -288,7 +288,7 @@ implementation
        _c : pobjectdef;
        has_constructor,has_virtual_method : boolean;
 
-    procedure eachsym(sym : psym);{$ifndef FPC}far;{$endif FPC}
+    procedure eachsym(sym : {$ifdef STORENUMBER}pnamedindexobject{$else}psym{$endif});{$ifndef FPC}far;{$endif FPC}
 
       var
          procdefcoll : pprocdefcoll;
@@ -332,7 +332,7 @@ implementation
 
                 { check, if a method should be overridden }
                 if (hp^.options and pooverridingmethod)<>0 then
-                  Message1(parser_e_nothing_to_be_overridden,_c^.name^+'.'+_name);
+                  Message1(parser_e_nothing_to_be_overridden,_c^.objname^+'.'+_name);
                 { next overloaded method }
                 hp:=hp^.nextoverloaded;
              end;
@@ -340,7 +340,7 @@ implementation
 
       begin
          { put only sub routines into the VMT }
-         if sym^.typ=procsym then
+         if psym(sym)^.typ=procsym then
            begin
               _name:=sym^.name;
               symcoll:=wurzel;
@@ -377,7 +377,7 @@ implementation
                                                  { warn only if it is the first time,
                                                    we hide the method }
                                                  if _c=hp^._class then
-                                                   Message1(parser_w_should_use_override,_c^.name^+'.'+_name);
+                                                   Message1(parser_w_should_use_override,_c^.objname^+'.'+_name);
                                                  newentry;
                                                  exit;
                                               end
@@ -385,10 +385,10 @@ implementation
                                               if _c=hp^._class then
                                                 begin
                                                    if (procdefcoll^.data^.options and povirtualmethod)<>0 then
-                                                     Message1(parser_w_overloaded_are_not_both_virtual,_c^.name^+'.'+_name)
+                                                     Message1(parser_w_overloaded_are_not_both_virtual,_c^.objname^+'.'+_name)
                                                    else
                                                      Message1(parser_w_overloaded_are_not_both_non_virtual,
-                                                       _c^.name^+'.'+_name);
+                                                       _c^.objname^+'.'+_name);
                                                    newentry;
                                                    exit;
                                                 end;
@@ -404,7 +404,7 @@ implementation
                                             { warn only if it is the first time,
                                               we hide the method }
                                             if _c=hp^._class then
-                                              Message1(parser_w_should_use_override,_c^.name^+'.'+_name);
+                                              Message1(parser_w_should_use_override,_c^.objname^+'.'+_name);
                                             newentry;
                                             exit;
                                          end;
@@ -416,14 +416,14 @@ implementation
                                            (pobjectdef(procdefcoll^.data^.retdef)^.isclass) and
                                            (pobjectdef(hp^.retdef)^.isclass) and
                                            (pobjectdef(hp^.retdef)^.isrelated(pobjectdef(procdefcoll^.data^.retdef)))) then
-                                         Message1(parser_e_overloaded_methodes_not_same_ret,_c^.name^+'.'+_name);
+                                         Message1(parser_e_overloaded_methodes_not_same_ret,_c^.objname^+'.'+_name);
 
 
                                        { the flags have to match      }
                                        { except abstract and override }
                                        if (procdefcoll^.data^.options and not(poabstractmethod or pooverridingmethod))<>
                                          (hp^.options and not(poabstractmethod or pooverridingmethod)) then
-                                            Message1(parser_e_header_dont_match_forward,_c^.name^+'.'+_name);
+                                            Message1(parser_e_header_dont_match_forward,_c^.objname^+'.'+_name);
 
                                        { now set the number }
                                        hp^.extnumber:=procdefcoll^.data^.extnumber;
@@ -450,7 +450,7 @@ implementation
                                     end;
                                   { check, if a method should be overridden }
                                   if (hp^.options and pooverridingmethod)<>0 then
-                                   Message1(parser_e_nothing_to_be_overridden,_c^.name^+'.'+_name);
+                                   Message1(parser_e_nothing_to_be_overridden,_c^.objname^+'.'+_name);
                                end;
                              hp:=hp^.nextoverloaded;
                           end;
@@ -496,7 +496,7 @@ implementation
          do_genvmt(_class);
 
          if has_virtual_method and not(has_constructor) then
-            Message1(parser_w_virtual_without_constructor,_class^.name^);
+            Message1(parser_w_virtual_without_constructor,_class^.objname^);
 
 
          { generates the VMT }
@@ -566,7 +566,12 @@ implementation
 end.
 {
   $Log$
-  Revision 1.1  1999-03-24 23:17:00  peter
+  Revision 1.2  1999-04-21 09:43:37  peter
+    * storenumber works
+    * fixed some typos in double_checksum
+    + incompatible types type1 and type2 message (with storenumber)
+
+  Revision 1.1  1999/03/24 23:17:00  peter
     * fixed bugs 212,222,225,227,229,231,233
 
 }

+ 8 - 2
compiler/hcodegen.pas

@@ -279,7 +279,8 @@ implementation
          importssection:=nil;
          exportssection:=nil;
          resourcesection:=nil;
-         asmsymbollist:=new(pasmsymbollist,init(true));
+         asmsymbollist:=new(pasmsymbollist,init);
+         asmsymbollist^.usehash;
       end;
 
 
@@ -320,7 +321,12 @@ end.
 
 {
   $Log$
-  Revision 1.28  1999-03-24 23:17:00  peter
+  Revision 1.29  1999-04-21 09:43:38  peter
+    * storenumber works
+    * fixed some typos in double_checksum
+    + incompatible types type1 and type2 message (with storenumber)
+
+  Revision 1.28  1999/03/24 23:17:00  peter
     * fixed bugs 212,222,225,227,229,231,233
 
   Revision 1.27  1999/02/25 21:02:37  peter

+ 2 - 0
compiler/msgidx.inc

@@ -195,6 +195,7 @@ type tmsgconst=(
   parser_e_ill_msg_param,
   parser_e_duplicate_message_label,
   type_e_mismatch,
+  type_e_incompatible_types,
   type_e_integer_expr_expected,
   type_e_ordinal_expr_expected,
   type_e_type_id_expected,
@@ -214,6 +215,7 @@ type tmsgconst=(
   type_w_maybe_wrong_hi_lo,
   type_e_integer_or_real_expr_expected,
   type_e_wrong_type_in_array_constructor,
+  type_e_wrong_parameter_type,
   sym_e_id_not_found,
   sym_f_internal_error_in_symtablestack,
   sym_e_duplicate_id,

+ 146 - 144
compiler/msgtxt.inc

@@ -203,271 +203,273 @@ const msgtxt : array[0..00101,1..240] of char=(
   'E_Message handlers can take only one call by ref. parameter'#000+
   'E_Duplicate message label: %1'#000+
   'E_Type mismatch'#000+
+  'E_Incompatible types $1 and $2'#000,+
   'E_Integer expression expected'#000+
-  'E','_Ordinal expression expected'#000+
+  'E_Ordinal expression expected'#000+
   'E_Type identifier expected'#000+
   'E_Variable identifier expected'#000+
   'E_pointer type expected'#000+
   'E_class type expected'#000+
   'E_Variable or type indentifier expected'#000+
-  'E_Can'#039't evaluate constant expression'#000+
-  'E_Set elements are not compati','ble'#000+
+  'E_Can'#039't evaluate constant expression',#000+
+  'E_Set elements are not compatible'#000+
   'E_Operation not implemented for sets'#000+
   'W_Automatic type conversion from floating type to COMP which is an int'+
   'eger type'#000+
   'H_use DIV instead to get an integer result'#000+
-  'E_string types doesn'#039't match, because of $V+ mode'#000+
-  'E_succ or pred on enums wi','th assignments not possible'#000+
+  'E_string types doesn'#039't match, because of $V+ ','mode'#000+
+  'E_succ or pred on enums with assignments not possible'#000+
   'E_Can'#039't read or write variables of this type'#000+
   'E_Type conflict between set elements'#000+
   'W_lo/hi(longint/dword) returns the upper/lower word'#000+
   'E_Integer or real expression expected'#000+
-  'E_Wrong type in array constructor'#000+
-  'E_Iden','tifier not found $1'#000+
+  'E_Wrong t','ype in array constructor'#000+
+  'E_Incompatible type for arg #$1, $2 and $3'#000+
+  'E_Identifier not found $1'#000+
   'F_Internal Error in SymTableStack()'#000+
   'E_Duplicate identifier $1'#000+
   'E_Unknown identifier $1'#000+
   'E_Forward declaration not solved $1'#000+
-  'F_Identifier type already defined as type'#000+
+  'F_Identifier type alread','y defined as type'#000+
   'E_Error in type definition'#000+
-  'E_Type identifier not defined',#000+
+  'E_Type identifier not defined'#000+
   'E_Forward type not resolved $1'#000+
   'E_Only static variables can be used in static methods or outside metho'+
   'ds'#000+
   'E_Invalid call to tvarsym.mangledname()'#000+
-  'F_record or class type expected'#000+
-  'E_Instances of classes or objects with an abtsract method are n','ot al'+
-  'lowed'#000+
+  'F_record or class typ','e expected'#000+
+  'E_Instances of classes or objects with an abtsract method are not allo'+
+  'wed'#000+
   'W_Label not defined $1'#000+
   'E_Illegal label declaration'#000+
   'E_GOTO und LABEL are not supported (use command line switch -Sg)'#000+
   'E_Label not found'#000+
-  'E_identifier isn'#039't a label'#000+
+  'E_identifier isn'#039't a ','label'#000+
   'E_label already defined'#000+
   'E_illegal type declaration of set elements'#000+
-  'E','_Forward class definition not resolved $1'#000+
+  'E_Forward class definition not resolved $1'#000+
   'H_Parameter not used $1'#000+
   'N_Local variable not used $1'#000+
   'E_Set type expected'#000+
   'W_Function result does not seem to be set'#000+
-  'E_Unknown record field identifier $1'#000+
-  'W_Local variable $1 does not seem to be initia','lized'#000+
+  'E_Unknown',' record field identifier $1'#000+
+  'W_Local variable $1 does not seem to be initialized'#000+
   'E_identifier idents no member $1'#000+
   'B_Found declaration: $1'#000+
   'E_BREAK not allowed'#000+
   'E_CONTINUE not allowed'#000+
   'E_Expression too complicated - FPU stack overflow'#000+
-  'E_Illegal expression'#000+
+  'E_Illegal ','expression'#000+
   'E_Invalid integer'#000+
   'E_Illegal qualifier'#000+
-  'E_High range limit < low ','range limit'#000+
+  'E_High range limit < low range limit'#000+
   'E_Illegal counter variable'#000+
   'E_Can'#039't determine which overloaded function to call'#000+
   'E_Parameter list size exceeds 65535 bytes'#000+
   'E_Illegal type conversion'#000+
-  'E_File types must be var parameters'#000+
-  'E_The use of a far pointer isn'#039't allowed ther','e'#000+
+  'E_File ','types must be var parameters'#000+
+  'E_The use of a far pointer isn'#039't allowed there'#000+
   'E_illegal call by reference parameters'#000+
   'E_EXPORT declared functions can'#039't be called'#000+
   'W_Possible illegal call of constructor or destructor (doesn'#039't matc'+
-  'h to this context)'#000+
+  'h to this conte','xt)'#000+
   'N_Inefficient code'#000+
   'W_unreachable code'#000+
-  'E_procedure call with stackframe',' ESP/SP'#000+
+  'E_procedure call with stackframe ESP/SP'#000+
   'E_Abstract methods can'#039't be called directly'#000+
   'F_Internal Error in getfloatreg(), allocation failure'#000+
   'F_Unknown float type'#000+
   'F_SecondVecn() base defined twice'#000+
-  'F_Extended cg68k not supported'#000+
-  'F_32-bit unsigned not supported in MC68000 mode'#000,+
+  'F_Ext','ended cg68k not supported'#000+
+  'F_32-bit unsigned not supported in MC68000 mode'#000+
   'F_Internal Error in secondinline()'#000+
   'D_Register $1 weight $2 $3'#000+
   'E_Stack limit excedeed in local routine'#000+
   'D_Stack frame is omited'#000+
   'E_Unable to inline object methods'#000+
-  'E_Unable to inline procvar calls'#000+
+  'E_Unab','le to inline procvar calls'#000+
   'E_No code for inline procedure stored'#000+
-  'E_Element',' zero of an ansi/wide- or longstring can'#039't be accessed,'+
-  ' use (set)length instead'#000+
+  'E_Element zero of an ansi/wide- or longstring can'#039't be accessed, u'+
+  'se (set)length instead'#000+
   'E_Include or exclude not implemented in this case'#000+
-  'Constructors or destructors can not be called inside with here'#000+
+  'Constructors or destructors can not ','be called inside with here'#000+
   'F_Divide by zero in asm evaluator'#000+
-  'F_Evaluator s','tack overflow'#000+
+  'F_Evaluator stack overflow'#000+
   'F_Evaluator stack underflow'#000+
   'F_Invalid numeric format in asm evaluator'#000+
   'F_Invalid Operator in asm evaluator'#000+
   'F_Unknown error in asm evaluator'#000+
-  'W_Invalid numeric value'#000+
+  'W_Invalid num','eric value'#000+
   'E_escape sequence ignored: $1'#000+
-  'E_Asm syntax error - Prefix not f','ound'#000+
+  'E_Asm syntax error - Prefix not found'#000+
   'E_Asm syntax error - Trying to add more than one prefix'#000+
   'E_Asm syntax error - Opcode not found'#000+
   'E_Invalid symbol reference'#000+
-  'W_Calling an overload function in an asm'#000+
+  'W_Calling an overload function in an asm',#000+
   'E_Constant value out of bounds'#000+
   'E_Non-label pattern contains @'#000+
-  'E_Invalid O','perand: $1'#000+
+  'E_Invalid Operand: $1'#000+
   'W_Override operator not supported'#000+
   'E_Error in binary constant: $1'#000+
   'E_Error in octal constant: $1'#000+
   'E_Error in hexadecimal constant: $1'#000+
-  'E_Error in integer constant: $1'#000+
+  'E_Error in integer const','ant: $1'#000+
   'E_Invalid labeled opcode'#000+
   'F_Internal error in Findtype()'#000+
-  'E_Invalid ','size for MOVSX/MOVZX'#000+
+  'E_Invalid size for MOVSX/MOVZX'#000+
   'E_16-bit base in 32-bit segment'#000+
   'E_16-bit index in 32-bit segment'#000+
   'E_Invalid Opcode'#000+
   'E_Constant reference not allowed'#000+
-  'W_Fwait can cause emulation problems with emu387'#000+
+  'W_Fwait can cause emulation pr','oblems with emu387'#000+
   'E_Invalid combination of opcode and operands'#000+
-  'E_Unsuppor','ted combination of opcode and operands'#000+
+  'E_Unsupported combination of opcode and operands'#000+
   'W_Opcode $1 not in table, operands not checked'#000+
   'F_Internal Error in ConcatOpcode()'#000+
   'E_Invalid size in reference'#000+
-  'E_Invalid middle sized operand'#000+
+  'E_Invalid middle ','sized operand'#000+
   'E_Invalid three operand opcode'#000+
   'E_Assembler syntax error'#000+
-  'E_In','valid operand type'#000+
+  'E_Invalid operand type'#000+
   'E_Segment overrides not supported'#000+
   'E_Invalid constant symbol $1'#000+
   'F_Internal Errror converting binary'#000+
   'F_Internal Errror converting hexadecimal'#000+
-  'F_Internal Errror converting octal'#000+
+  'F_Inter','nal Errror converting octal'#000+
   'E_Invalid constant expression'#000+
-  'E_Unknown identi','fier: $1'#000+
+  'E_Unknown identifier: $1'#000+
   'E_Trying to define an index register more than once'#000+
   'E_Invalid field specifier'#000+
   'F_Internal Error in BuildScaling()'#000+
   'E_Invalid scaling factor'#000+
-  'E_Invalid scaling value'#000+
+  'E_Invalid scaling v','alue'#000+
   'E_Scaling value only allowed with index'#000+
-  'E_Invalid assembler syntax. N','o ref with brackets)'#000+
+  'E_Invalid assembler syntax. No ref with brackets)'#000+
   'E_Expressions of the form [sreg:reg...] are currently not supported'#000+
   'E_Trying to define a segment register twice'#000+
-  'E_Trying to define a base register twice'#000+
+  'E_Trying to define a base registe','r twice'#000+
   'E_Trying to use a negative index register'#000+
-  'E_Asm syntax error - err','or in reference'#000+
+  'E_Asm syntax error - error in reference'#000+
   'E_Local symbols not allowed as references'#000+
   'E_Invalid operand in bracket expression'#000+
   'E_Invalid symbol name: $1'#000+
   'E_Invalid Reference syntax'#000+
-  'E_Invalid string as opcode operand: $1'#000+
+  'E_Invalid strin','g as opcode operand: $1'#000+
   'W_@CODE and @DATA not supported'#000+
-  'E_Null label refer','ences are not allowed'#000+
+  'E_Null label references are not allowed'#000+
   'W_Calling of an overloaded function in direct assembler'#000+
   'E_Cannot use SELF outside a method'#000+
   'E_Asm syntax error - Should start with bracket'#000+
-  'E_Asm syntax error - register: $1'#000+
+  'E_Asm ','syntax error - register: $1'#000+
   'E_SEG and OFFSET not supported'#000+
-  'E_Asm syntax er','ror - in opcode operand'#000+
+  'E_Asm syntax error - in opcode operand'#000+
   'E_Invalid String expression'#000+
   'E_Constant expression out of bounds'#000+
   'F_Internal Error in BuildConstant()'#000+
-  'W_A repeat prefix and a segment override on <= i386 may result in erro'+
-  'rs if an interrupt occurs'#000+
-  'E_Invalid or missing',' opcode'#000+
+  'W_A repeat prefix and a segment override o','n <= i386 may result in er'+
+  'rors if an interrupt occurs'#000+
+  'E_Invalid or missing opcode'#000+
   'E_Invalid combination of prefix and opcode: $1'#000+
   'E_Invalid combination of override and opcode: $1'#000+
   'E_Too many operands on line'#000+
   'E_Duplicate local symbol: $1'#000+
-  'E_Unknown label identifer: $1'#000+
+  'E_Unk','nown label identifer: $1'#000+
   'E_Assemble node syntax error'#000+
-  'E_Undefined local sy','mbol: $1'#000+
+  'E_Undefined local symbol: $1'#000+
   'D_Starting intel styled assembler parsing...'#000+
   'D_Finished intel styled assembler parsing...'#000+
   'E_Not a directive or local symbol: $1'#000+
-  'E_/ at beginning of line not allowed'#000+
+  'E_/ at beginning of line not ','allowed'#000+
   'E_NOR not supported'#000+
   'E_Invalid floating point register name'#000+
-  'W_Modul','o not supported'#000+
+  'W_Modulo not supported'#000+
   'E_Invalid floating point constant: $1'#000+
   'E_Size suffix and destination register do not match'#000+
   'E_Size suffix and destination or source size do not match'#000+
-  'W_Size suffix and destination or source size do not match'#000+
-  'E_Internal error i','n ConcatLabeledInstr()'#000+
+  'W_','Size suffix and destination or source size do not match'#000+
+  'E_Internal error in ConcatLabeledInstr()'#000+
   'W_Floating point binary representation ignored'#000+
   'W_Floating point hexadecimal representation ignored'#000+
-  'W_Floating point octal representation ignored'#000+
+  'W_Floating point octal representation ignore','d'#000+
   'E_Invalid real constant expression'#000+
   'E_Parenthesis are not allowed'#000+
-  'E_Inval','id Reference'#000+
+  'E_Invalid Reference'#000+
   'E_Cannot use __SELF outside a method'#000+
   'E_Cannot use __OLDEBP outside a nested procedure'#000+
   'W_Identifier $1 supposed external'#000+
-  'E_Invalid segment override expression'#000+
+  'E_Invalid segment override expres','sion'#000+
   'E_Strings not allowed as constants'#000+
-  'D_Starting AT&T styled assembler p','arsing...'#000+
+  'D_Starting AT&T styled assembler parsing...'#000+
   'D_Finished AT&T styled assembler parsing...'#000+
   'E_Switching sections is not allowed in an assembler block'#000+
   'E_Invalid global definition'#000+
-  'E_Line separator expected'#000+
+  'E_Line separator expected'#000,+
   'W_globl not supported'#000+
   'W_align not supported'#000+
   'W_lcomm not supported'#000+
-  'W_comm n','ot supported'#000+
+  'W_comm not supported'#000+
   'E_Invalid local common definition'#000+
   'E_Invalid global common definition'#000+
   'E_local symbol: $1 not found inside asm statement'#000+
-  'E_assembler code not returned to text'#000+
+  'E_assembler code not returned to t','ext'#000+
   'F_internal error in BuildReference()'#000+
   'E_invalid opcode size'#000+
-  'W_NEAR igno','red'#000+
+  'W_NEAR ignored'#000+
   'W_FAR ignored'#000+
   'D_Creating inline asm lookup tables'#000+
   'E_Using a defined name as a local label'#000+
   'F_internal error in HandleExtend()'#000+
   'E_Invalid character: <'#000+
-  'E_Invalid character: >'#000+
+  'E_Invalid char','acter: >'#000+
   'E_Unsupported opcode'#000+
-  'E_Increment and Decrement mode not allowed t','ogether'#000+
+  'E_Increment and Decrement mode not allowed together'#000+
   'E_Invalid Register list in movem/fmovem'#000+
   'E_Invalid Register list for opcode'#000+
   'E_68020+ mode required to assemble'#000+
-  'D_Starting Motorola styled assembler parsing...'#000+
+  'D_Starting Motorola styled assembler parsing...'#000,+
   'D_Finished Motorola styled assembler parsing...'#000+
   'W_XDEF not supported'#000+
-  'W_Fun','ctions with void return value can'#039't return any value in asm'+
-  ' code'#000+
+  'W_Functions with void return value can'#039't return any value in asm c'+
+  'ode'#000+
   'E_Invalid suffix for intel assembler'#000+
   'E_Extended not supported in this mode'#000+
-  'E_Comp not supported in this mode'#000+
+  'E_Comp not supported in th','is mode'#000+
   'W_You need GNU as version >= 2.81 to compile this MMX code'#000+
-  'F_Too m','any assembler files'#000+
+  'F_Too many assembler files'#000+
   'F_Selected assembler output not supported'#000+
   'E_Unsupported symbol type for operand'#000+
   'E_Cannot index a local var or parameter with a register'#000+
-  'H_$1 translated to $2'#000+
+  'H_$1 trans','lated to $2'#000+
   'W_$1 is associated to an overloaded function'#000+
-  'W_Source operatin','g system redefined'#000+
+  'W_Source operating system redefined'#000+
   'I_Assembling (pipe) $1'#000+
   'E_Can'#039't create assember file $1'#000+
   'W_Assembler $1 not found, switching to external assembling'#000+
   'T_Using assembler: $1'#000+
-  'W_Error while assembling exitcode $1'#000+
-  'W_Can'#039't call the assembler, error $1 switching t','o external assem'+
-  'bling'#000+
+  'W_Error whi','le assembling exitcode $1'#000+
+  'W_Can'#039't call the assembler, error $1 switching to external assembl'+
+  'ing'#000+
   'I_Assembling $1'#000+
   'W_Linker $1 not found, switching to external linking'#000+
   'T_Using linker: $1'#000+
   'W_Object $1 not found, Linking may fail !'#000+
-  'W_Library $1 not found, Linking may fail !'#000+
+  'W_Library $1 n','ot found, Linking may fail !'#000+
   'W_Error while linking'#000+
-  'W_Can'#039't call the linker',', switching to external linking'#000+
+  'W_Can'#039't call the linker, switching to external linking'#000+
   'I_Linking $1'#000+
   'W_binder not found, switching to external binding'#000+
   'W_ar not found, switching to external ar'#000+
-  'E_Dynamic Libraries not supported'#000+
+  'E_Dynamic Libraries not suppor','ted'#000+
   'I_Closing script $1'#000+
-  'W_resource compiler not found, switching to extern','al mode'#000+
+  'W_resource compiler not found, switching to external mode'#000+
   'I_Compiling resource $1'#000+
   'F_Can'#039't post process executable $1'#000+
   'F_Can'#039't open executable $1'#000+
   'X_Size of Code: $1 bytes'#000+
   'X_Size of initialized data: $1 bytes'#000+
-  'X_Size of uninitialized data: $1 bytes'#000+
+  'X_Size of ','uninitialized data: $1 bytes'#000+
   'X_Stack space reserved: $1 bytes'#000+
-  'X_Stack spac','e commited: $1 bytes'#000+
+  'X_Stack space commited: $1 bytes'#000+
   'T_Unitsearch: $1'#000+
   'T_PPU Loading $1'#000+
   'U_PPU Name: $1'#000+
@@ -475,199 +477,199 @@ const msgtxt : array[0..00101,1..240] of char=(
   'U_PPU Crc: $1'#000+
   'U_PPU Time: $1'#000+
   'U_PPU File too short'#000+
-  'U_PPU Invalid Header (no PPU at the begin)'#000+
+  'U_PPU Invalid Header (no PPU a','t the begin)'#000+
   'U_PPU Invalid Version $1'#000+
-  'U_PPU is compiled for an other proce','ssor'#000+
+  'U_PPU is compiled for an other processor'#000+
   'U_PPU is compiled for an other target'#000+
   'U_PPU Source: $1'#000+
   'U_Writing $1'#000+
   'F_Can'#039't Write PPU-File'#000+
   'F_reading PPU-File'#000+
   'F_unexpected end of PPU-File'#000+
-  'F_Invalid PPU-File entry: $1'#000+
+  'F_Invalid PPU-File ent','ry: $1'#000+
   'F_PPU Dbx count problem'#000+
   'E_Illegal unit name: $1'#000+
   'F_Too much units'#000+
-  'F_','Circular unit reference between $1 and $2'#000+
+  'F_Circular unit reference between $1 and $2'#000+
   'F_Can'#039't compile unit $1, no sources available'#000+
   'W_Compiling the system unit requires the -Us switch'#000+
-  'F_There were $1 errors compiling module, stopping'#000+
+  'F_There were $1 errors com','piling module, stopping'#000+
   'U_Load from $1 ($2) unit $3'#000+
-  'U_Recompiling $1, chec','ksum changed for $2'#000+
+  'U_Recompiling $1, checksum changed for $2'#000+
   'U_Recompiling $1, source found only'#000+
   'U_Recompiling unit, static lib is older than ppufile'#000+
   'U_Recompiling unit, shared lib is older than ppufile'#000+
-  'U_Recompiling unit, obj and asm are older than ppufile'#000+
-  'U_Recompiling unit, obj',' is older than asm'#000+
+  'U_Re','compiling unit, obj and asm are older than ppufile'#000+
+  'U_Recompiling unit, obj is older than asm'#000+
   'U_Parsing interface of $1'#000+
   'U_Parsing implementation of $1'#000+
   'U_Second load for unit $1'#000+
   'U_PPU Check file $1 time $2'#000+
   '$1 [options] <inputfile> [options]'#000+
-  'W_Only one source file supported'#000+
+  'W','_Only one source file supported'#000+
   'W_DEF file can be created only for OS/2'#000+
-  'E_','nested response files are not supported'#000+
+  'E_nested response files are not supported'#000+
   'F_No source file name in command line'#000+
   'E_Illegal parameter: $1'#000+
   'H_-? writes help pages'#000+
   'F_Too many config files nested'#000+
-  'F_Unable to open file $1'#000+
+  'F_Unable t','o open file $1'#000+
   'N_Reading further options from $1'#000+
-  'W_Target is already set t','o: $1'#000+
+  'W_Target is already set to: $1'#000+
   'W_Shared libs not supported on DOS platform, reverting to static'#000+
   'F_too many IF(N)DEFs'#000+
   'F_too many ENDIFs'#000+
   'F_open conditional at the end of the file'#000+
-  'W_Debug information generation is not supported by this executable'#000+
-  'H_Try recompiling wit','h -dGDB'#000+
+  'W_Debug inform','ation generation is not supported by this executable'#000+
+  'H_Try recompiling with -dGDB'#000+
   'W_You are using the obsolete switch $1'#000+
   'Free Pascal Compiler version $FPCVER [$FPCDATE] for $FPCTARGET'#000+
   'Copyright (c) 1993-98 by Florian Klaempfl'#000+
-  'Free Pascal Compiler version $FPCVER'#000+
+  'Free Pascal Co','mpiler version $FPCVER'#000+
   #000+
   'Compiler Date  : $FPCDATE'#000+
-  'Compiler Target: $FPCTAR','GET'#000+
+  'Compiler Target: $FPCTARGET'#000+
   #000+
   'This program comes under the GNU General Public Licence'#000+
   'For more information read COPYING.FPC'#000+
   #000+
   'Report bugs,suggestions etc to:'#000+
-  '                 [email protected]'#000+
-  '**0*_put + after a boolean switch option to enable it, - ','to disable '+
-  'it'#000+
+  '                 fpc-devel@vekoll.','saturnus.vein.hu'#000+
+  '**0*_put + after a boolean switch option to enable it, - to disable it'+
+  #000+
   '**1a_the compiler doesn'#039't delete the generated assembler file'#000+
   '**2al_list sourcecode lines in assembler file'#000+
   '**1b_generate browser info'#000+
-  '**2bl_generate local symbol info'#000+
+  '**2bl_generate lo','cal symbol info'#000+
   '**1B_build all modules'#000+
   '**1C_code generation options'#000+
-  '3*2CD_','create dynamic library'#000+
+  '3*2CD_create dynamic library'#000+
   '**2Ch<n>_<n> bytes heap (between 1023 and 67107840)'#000+
   '**2Ci_IO-checking'#000+
   '**2Cn_omit linking stage'#000+
   '**2Co_check overflow of integer operations'#000+
-  '**2Cr_range checking'#000+
+  '**2Cr','_range checking'#000+
   '**2Cs<n>_set stack size to <n>'#000+
   '**2Ct_stack checking'#000+
-  '3*2CS_','create static library'#000+
+  '3*2CS_create static library'#000+
   '3*2Cx_use smartlinking'#000+
   '**1d<x>_defines the symbol <x>'#000+
   '*O1D_generate a DEF file'#000+
   '*O2Dd<x>_set description to <x>'#000+
   '*O2Dw_PM application'#000+
-  '**1e<x>_set path to executable'#000+
+  '**1e<x>_set ','path to executable'#000+
   '**1E_same as -Cn'#000+
   '**1F_set file names and paths'#000+
-  '**2FD<x>','_sets the directory where to search for compiler utilities'#000+
+  '**2FD<x>_sets the directory where to search for compiler utilities'#000+
   '**2Fe<x>_redirect error output to <x>'#000+
   '**2FE<x>_set exe/unit output path to <x>'#000+
   '*L2Fg<x>_same as -Fl'#000+
-  '**2Fi<x>_adds <x> to include path'#000+
+  '**2Fi<x','>_adds <x> to include path'#000+
   '**2Fl<x>_adds <x> to library path'#000+
-  '*L2FL<x>_uses',' <x> as dynamic linker'#000+
+  '*L2FL<x>_uses <x> as dynamic linker'#000+
   '**2Fo<x>_adds <x> to object path'#000+
   '**2Fr<x>_load error message file <x>'#000+
   '**2Fu<x>_adds <x> to unit path'#000+
-  '**2FU<x>_set unit output path to <x>, overrides -FE'#000+
+  '**2FU<x>_set unit output path to <x>, over','rides -FE'#000+
   '*g1g_generate debugger information'#000+
   '*g2gg_use gsym'#000+
-  '*g2gd_use dbx'#000,+
+  '*g2gd_use dbx'#000+
   '*g2gh_use heap trace unit'#000+
   '**1i_information'#000+
   '**2iD_return compiler date'#000+
   '**2iV_return compiler version'#000+
   '**2iSO_return source OS'#000+
   '**2iSP_return source processor'#000+
-  '**2iTO_return target OS'#000+
+  '**2iTO_retu','rn target OS'#000+
   '**2iTP_return target processor'#000+
-  '**1I<x>_adds <x> to include pa','th'#000+
+  '**1I<x>_adds <x> to include path'#000+
   '**1k<x>_Pass <x> to the linker'#000+
   '**1l_write logo'#000+
   '**1n_don'#039't read the default config file'#000+
   '**1o<x>_change the name of the executable produced to <x>'#000+
-  '**1pg_generate profile code for gprof'#000+
-  '*L1P_use pipes instead of creating temporary assembler',' files'#000+
+  '**1pg_generate pro','file code for gprof'#000+
+  '*L1P_use pipes instead of creating temporary assembler files'#000+
   '**1S_syntax options'#000+
   '**2S2_switch some Delphi 2 extensions on'#000+
   '**2Sc_supports operators like C (*=,+=,/= and -=)'#000+
   '**2Sd_tries to be Delphi compatible'#000+
-  '**2Se_compiler stops after the first error'#000+
+  '**2Se_compil','er stops after the first error'#000+
   '**2Sg_allow LABEL and GOTO'#000+
-  '**2Sh_Use ansist','rings'#000+
+  '**2Sh_Use ansistrings'#000+
   '**2Si_support C++ stlyed INLINE'#000+
   '**2Sm_support macros like C (global)'#000+
   '**2So_tries to be TP/BP 7.0 compatible'#000+
   '**2Sp_tries to be gpc compatible'#000+
-  '**2Ss_constructor name must be init (destructor must be done)'#000+
-  '**2St_allow static keyword in o','bjects'#000+
+  '**2Ss_constructor n','ame must be init (destructor must be done)'#000+
+  '**2St_allow static keyword in objects'#000+
   '**1s_don'#039't call assembler and linker (only with -a)'#000+
   '**1u<x>_undefines the symbol <x>'#000+
   '**1U_unit options'#000+
   '**2Un_don'#039't check the unit name'#000+
-  '**2Up<x>_same as -Fu<x>'#000+
+  '**2Up<x>_same as -Fu<x>'#000,+
   '**2Us_compile a system unit'#000+
-  '**1v<x>_Be verbose. <x> is a combination of th','e following letters :'#000+
+  '**1v<x>_Be verbose. <x> is a combination of the following letters :'#000+
   '**2*_e : Show errors (default)       d : Show debug info'#000+
   '**2*_w : Show warnings               u : Show unit info'#000+
-  '**2*_n : Show notes                  t : Show tried/used files'#000+
-  '**2*_h : Show hints                  m : S','how defined macros'#000+
+  '**2*_n : Show notes            ','      t : Show tried/used files'#000+
+  '**2*_h : Show hints                  m : Show defined macros'#000+
   '**2*_i : Show general info           p : Show compiled procedures'#000+
   '**2*_l : Show linenumbers            c : Show conditionals'#000+
-  '**2*_a : Show everything             0 : Show nothing (except errors)'#000+
-  '**2*_b : Show all procedur','e          r : Rhide/GCC compatibility mod'+
-  'e'#000+
+  '**2*_a : Show everythi','ng             0 : Show nothing (except errors'+
+  ')'#000+
+  '**2*_b : Show all procedure          r : Rhide/GCC compatibility mode'#000+
   '**2*_    declarations if an error    x : Executable info (Win32 only)'#000+
   '**2*_    occurs'#000+
   '**1X_executable options'#000+
-  '*L2Xc_link with the c library'#000+
-  '**2XD_link with dynamic libraries (defines FPC_LINK_DYNA','MIC)'#000+
+  '*L2Xc_link w','ith the c library'#000+
+  '**2XD_link with dynamic libraries (defines FPC_LINK_DYNAMIC)'#000+
   '**2Xs_strip all symbols from executable'#000+
   '**2XS_link with static libraries (defines FPC_LINK_STATIC)'#000+
   '**0*_Processor specific options:'#000+
   '3*1A<x>_output format'#000+
-  '3*2Ao_coff file using GNU AS'#000+
+  '3*2Ao_c','off file using GNU AS'#000+
   '3*2Anasmcoff_coff file using Nasm'#000+
-  '3*2Anasmelf_elf32 ','(linux) file using Nasm'#000+
+  '3*2Anasmelf_elf32 (linux) file using Nasm'#000+
   '3*2Anasmobj_obj file using Nasm'#000+
   '3*2Amasm_obj using Masm (Mircosoft)'#000+
   '3*2Atasm_obj using Tasm (Borland)'#000+
   '3*1R<x>_assembler reading style'#000+
-  '3*2Ratt_read AT&T style assembler'#000+
+  '3*2Ratt_','read AT&T style assembler'#000+
   '3*2Rintel_read Intel style assembler'#000+
-  '3*2Rdirect_','copy assembler text directly to assembler file'#000+
+  '3*2Rdirect_copy assembler text directly to assembler file'#000+
   '3*1O<x>_optimizations'#000+
   '3*2Og_generate smaller code'#000+
   '3*2OG_generate faster code (default)'#000+
-  '3*2Or_keep certain variables in registers (still BUGGY!!!)'#000+
-  '3*2Ou_enable uncertain optimizations (see docs)',#000+
+  '3*2Or_keep certain variables in ','registers (still BUGGY!!!)'#000+
+  '3*2Ou_enable uncertain optimizations (see docs)'#000+
   '3*2O1_level 1 optimizations (quick optimizations)'#000+
   '3*2O2_level 2 optimizations (-O1 + slower optimizations)'#000+
   '3*2O3_level 3 optimizations (same as -O2u)'#000+
-  '3*2Op_target processor'#000+
+  '3*2Op_target pr','ocessor'#000+
   '3*3Op1_set target processor to 386/486'#000+
-  '3*3Op2_set target processor',' to Pentium/PentiumMMX (tm)'#000+
+  '3*3Op2_set target processor to Pentium/PentiumMMX (tm)'#000+
   '3*3Op3_set target processor to PPro/PII/c6x86/K6 (tm)'#000+
   '3*1T<x>_Target operating system'#000+
   '3*2TGO32V1_version 1 of DJ Delorie DOS extender'#000+
-  '3*2TGO32V2_version 2 of DJ Delorie DOS extender'#000+
+  '3*2T','GO32V2_version 2 of DJ Delorie DOS extender'#000+
   '3*2TLINUX_Linux'#000+
-  '3*2TOS2_OS/2 2','.x'#000+
+  '3*2TOS2_OS/2 2.x'#000+
   '3*2TWin32_Windows 32 Bit'#000+
   '6*1A<x>_output format'#000+
   '6*2Ao_Unix o-file using GNU AS'#000+
   '6*2Agas_GNU Motorola assembler'#000+
   '6*2Amit_MIT Syntax (old GAS)'#000+
-  '6*2Amot_Standard Motorola assembler'#000+
+  '6*2Amot_Standard Motorola',' assembler'#000+
   '6*1O_optimizations'#000+
   '6*2Oa_turn on the optimizer'#000+
-  '6*2Og_generate s','maller code'#000+
+  '6*2Og_generate smaller code'#000+
   '6*2OG_generate faster code (default)'#000+
   '6*2Ox_optimize maximum (still BUGGY!!!)'#000+
   '6*2O2_set target processor to a MC68020+'#000+
   '6*1R<x>_assembler reading style'#000+
-  '6*2RMOT_read motorola style assembler'#000+
+  '6*2R','MOT_read motorola style assembler'#000+
   '6*1T<x>_Target operating system'#000+
-  '6*2TAMIG','A_Commodore Amiga'#000+
+  '6*2TAMIGA_Commodore Amiga'#000+
   '6*2TATARI_Atari ST/STe/TT'#000+
   '6*2TMACOS_Macintosh m68k'#000+
   '6*2TLINUX_Linux-68k'#000+

+ 16 - 11
compiler/pdecl.pas

@@ -80,22 +80,22 @@ unit pdecl;
     function read_type(const name : stringid) : pdef;forward;
 
     { search in symtablestack used, but not defined type }
-    procedure testforward_type(p : psym);{$ifndef FPC}far;{$endif}
+    procedure testforward_type(p : {$ifdef STORENUMBER}pnamedindexobject{$else}psym{$endif});{$ifndef FPC}far;{$endif}
       var
         reaktvarsymtable : psymtable;
         oldaktfilepos : tfileposinfo;
       begin
-         if not(p^.typ=typesym) then
+         if not(psym(p)^.typ=typesym) then
           exit;
-         if ((p^.properties and sp_forwarddef)<>0) then
+         if ((psym(p)^.properties and sp_forwarddef)<>0) then
            begin
              oldaktfilepos:=aktfilepos;
-             aktfilepos:=p^.fileinfo;
+             aktfilepos:=psym(p)^.fileinfo;
              Message1(sym_e_forward_type_not_resolved,p^.name);
              aktfilepos:=oldaktfilepos;
              { try to recover }
              ptypesym(p)^.definition:=generrordef;
-             p^.properties:=p^.properties and (not sp_forwarddef);
+             psym(p)^.properties:=psym(p)^.properties and (not sp_forwarddef);
            end
          else
           if (ptypesym(p)^.definition^.deftype in [recorddef,objectdef]) then
@@ -1047,7 +1047,7 @@ unit pdecl;
                      p2:=search_default_property(aktclass);
                      if assigned(p2) then
                        message1(parser_e_only_one_default_property,
-                         pobjectdef(p2^.owner^.defowner)^.name^)
+                         pobjectdef(p2^.owner^.defowner)^.objname^)
                      else
                        begin
                           p^.options:=p^.options or ppo_defaultproperty;
@@ -1215,7 +1215,7 @@ unit pdecl;
                      correct field addresses
                    }
                    if (childof^.options and oo_isforward)<>0 then
-                     Message1(parser_e_forward_declaration_must_be_resolved,childof^.name^);
+                     Message1(parser_e_forward_declaration_must_be_resolved,childof^.objname^);
                    aktclass:=fd;
                    { we must inherit several options !!
                      this was missing !!
@@ -1249,7 +1249,7 @@ unit pdecl;
                           correct field addresses
                         }
                         if (childof^.options and oo_isforward)<>0 then
-                          Message1(parser_e_forward_declaration_must_be_resolved,childof^.name^);
+                          Message1(parser_e_forward_declaration_must_be_resolved,childof^.objname^);
                         aktclass:=fd;
                         aktclass^.set_parent(childof);
                      end
@@ -1498,8 +1498,8 @@ unit pdecl;
               { write class name }
               getlabel(classnamelabel);
               datasegment^.concat(new(pai_label,init(classnamelabel)));
-              datasegment^.concat(new(pai_const,init_8bit(length(aktclass^.name^))));
-              datasegment^.concat(new(pai_string,init(aktclass^.name^)));
+              datasegment^.concat(new(pai_const,init_8bit(length(aktclass^.objname^))));
+              datasegment^.concat(new(pai_string,init(aktclass^.objname^)));
 
               { generate message and dynamic tables }
               { why generate those if empty ??? }
@@ -2222,7 +2222,12 @@ unit pdecl;
 end.
 {
   $Log$
-  Revision 1.108  1999-04-17 13:16:19  peter
+  Revision 1.109  1999-04-21 09:43:45  peter
+    * storenumber works
+    * fixed some typos in double_checksum
+    + incompatible types type1 and type2 message (with storenumber)
+
+  Revision 1.108  1999/04/17 13:16:19  peter
     * fixes for storenumber
 
   Revision 1.107  1999/04/14 09:14:50  peter

+ 18 - 2
compiler/pmodules.pas

@@ -307,6 +307,7 @@ unit pmodules;
                begin
                  Message2(unit_u_recompile_crc_change,current_module^.modulename^,pu^.name^);
                  current_module^.do_compile:=true;
+{$ifdef STRANGERECOMPILE}
                  { if the checksum was known but has changed then
                    we should also recompile the loaded unit ! }
                  if (pu^.checksum<>0) and (loaded_unit^.sources_avail) then
@@ -314,6 +315,7 @@ unit pmodules;
                       Message2(unit_u_recompile_crc_change,loaded_unit^.modulename^,current_module^.modulename^);
                       loaded_unit^.do_compile:=true;
                    end;
+{$endif}
                  dispose(current_module^.map);
                  current_module^.map:=nil;
                  exit;
@@ -361,6 +363,7 @@ unit pmodules;
               { checksum change whereas it was already known
                 loade_unit was changed so we need to recompile this unit }
                 begin
+{$ifdef STRANGERECOMPILE}
                   {if (loaded_unit^.sources_avail) then
                    begin
                       loaded_unit^.do_compile:=true;
@@ -369,7 +372,15 @@ unit pmodules;
                   loaded_unit^.do_compile:=true;
                   if(pu^.interface_checksum<>0) then
                     load_refs:=false;
-                 end;
+{$else}
+writeln('loaded intfc: ',loaded_unit^.interface_crc,' pu intfc ',pu^.interface_checksum);
+                  Message2(unit_u_recompile_crc_change,current_module^.modulename^,pu^.name^);
+                  current_module^.do_compile:=true;
+                  dispose(current_module^.map);
+                  current_module^.map:=nil;
+                  exit;
+{$endif}
+                end;
 {$endif def Double_checksum}
             { setup the map entry for deref }
 {$ifndef NEWMAP}
@@ -1386,7 +1397,12 @@ unit pmodules;
 end.
 {
   $Log$
-  Revision 1.110  1999-04-17 13:14:52  peter
+  Revision 1.111  1999-04-21 09:43:46  peter
+    * storenumber works
+    * fixed some typos in double_checksum
+    + incompatible types type1 and type2 message (with storenumber)
+
+  Revision 1.110  1999/04/17 13:14:52  peter
     * concat_external added for new init/final
 
   Revision 1.109  1999/04/15 12:19:59  peter

+ 18 - 1
compiler/pstatmnt.pas

@@ -373,7 +373,11 @@ unit pstatmnt;
              objectdef : begin
                            obj:=pobjectdef(p^.resulttype);
                            withsymtable:=new(pwithsymtable,init);
+{$ifdef STORENUMBER}
+                           withsymtable^.symsearch:=obj^.publicsyms^.symsearch;
+{$else}
                            withsymtable^.searchroot:=obj^.publicsyms^.searchroot;
+{$endif}
                            withsymtable^.defowner:=obj;
                            symtab:=withsymtable;
 {$ifndef NODIRECTWITH}
@@ -389,7 +393,11 @@ unit pstatmnt;
                             begin
                               symtab^.next:=new(pwithsymtable,init);
                               symtab:=symtab^.next;
+{$ifdef STORENUMBER}
+                              symtab^.symsearch:=obj^.publicsyms^.symsearch;
+{$else}
                               symtab^.searchroot:=obj^.publicsyms^.searchroot;
+{$endif}
 {$ifndef NODIRECTWITH}
                               if (p^.treetype=loadn) and
                                  (p^.symtable=aktprocsym^.definition^.localst) then
@@ -408,7 +416,11 @@ unit pstatmnt;
                            symtab:=precdef(p^.resulttype)^.symtable;
                            levelcount:=1;
                            withsymtable:=new(pwithsymtable,init);
+{$ifdef STORENUMBER}
+                           withsymtable^.symsearch:=symtab^.symsearch;
+{$else}
                            withsymtable^.searchroot:=symtab^.searchroot;
+{$endif}
                            withsymtable^.next:=symtablestack;
 {$ifndef NODIRECTWITH}
                               if (p^.treetype=loadn) and
@@ -1271,7 +1283,12 @@ unit pstatmnt;
 end.
 {
   $Log$
-  Revision 1.79  1999-04-16 12:14:49  pierre
+  Revision 1.80  1999-04-21 09:43:48  peter
+    * storenumber works
+    * fixed some typos in double_checksum
+    + incompatible types type1 and type2 message (with storenumber)
+
+  Revision 1.79  1999/04/16 12:14:49  pierre
    * void pointer accepted with warning in tp and delphi mode
 
   Revision 1.78  1999/04/15 12:58:14  pierre

+ 83 - 75
compiler/symdef.inc

@@ -188,7 +188,7 @@
     function tdef.typename:string;
       begin
         if assigned(sym) then
-         typename:=sym^.name
+         typename:=Upper(sym^.name)
         else
          typename:='unknown';
       end;
@@ -315,7 +315,7 @@
     function tdef.allstabstring : pchar;
     var stabchar : string[2];
         ss,st : pchar;
-        name : string;
+        sname : string;
         sym_line_no : longint;
       begin
       ss := stabstring;
@@ -325,15 +325,15 @@
         stabchar := 'Tt';
       if assigned(sym) then
         begin
-           name := sym^.name;
+           sname := sym^.name;
            sym_line_no:=sym^.fileinfo.line;
         end
       else
         begin
-           name := ' ';
+           sname := ' ';
            sym_line_no:=0;
         end;
-      strpcopy(st,'"'+name+':'+stabchar+numberstring+'=');
+      strpcopy(st,'"'+sname+':'+stabchar+numberstring+'=');
       strpcopy(strecopy(strend(st),ss),'",'+tostr(N_LSYM)+',0,'+tostr(sym_line_no)+',0');
       allstabstring := strnew(st);
       freemem(st,strlen(ss)+512);
@@ -1636,8 +1636,8 @@
          rangenr:=0;
       end;
 
-    function tarraydef.getrangecheckstring : string;
 
+    function tarraydef.getrangecheckstring : string;
       begin
          if (cs_smartlink in aktmoduleswitches) then
            getrangecheckstring:='R_'+current_module^.modulename^+tostr(rangenr)
@@ -1781,12 +1781,12 @@
     var
        binittable : boolean;
 
-    procedure check_rec_inittable(s : psym);
+    procedure check_rec_inittable(s : {$ifdef STORENUMBER}pnamedindexobject{$else}psym{$endif});
 
       begin
-         if (s^.typ=varsym) and
-            ((pvarsym(s)^.definition^.deftype<>objectdef)
-              or not(pobjectdef(pvarsym(s)^.definition)^.isclass)) then
+         if (psym(s)^.typ=varsym) and
+            ((pvarsym(s)^.definition^.deftype<>objectdef) or
+             not(pobjectdef(pvarsym(s)^.definition)^.isclass)) then
             binittable:=pvarsym(s)^.definition^.needs_inittable;
       end;
 
@@ -1809,17 +1809,18 @@
 
     procedure trecdef.deref;
       var
+{$ifndef STORENUMBER}
          hp : pdef;
+{$endif}
          oldrecsyms : psymtable;
       begin
          oldrecsyms:=aktrecordsymtable;
          aktrecordsymtable:=symtable;
          { now dereference the definitions }
 {$ifdef STORENUMBER}
-         hp:=pdef(symtable^.defindex^.first);
+         symtable^.deref;
 {$else}
          hp:=symtable^.rootdef;
-{$endif}
          while assigned(hp) do
            begin
               hp^.deref;
@@ -1827,11 +1828,9 @@
               hp^.owner:=symtable;
               hp:=pdef(hp^.next);
            end;
-         {$ifdef tp}
-           symtable^.foreach(derefsym);
-         {$else}
-           symtable^.foreach(@derefsym);
-         {$endif}
+
+         symtable^.foreach({$ifdef fpc}@{$endif}derefsym);
+{$endif}
          aktrecordsymtable:=oldrecsyms;
       end;
 
@@ -1855,23 +1854,23 @@
           StabRecSize : longint = 0;
           RecOffset : Longint = 0;
 
-    procedure addname(p : psym);
+    procedure addname(p : {$ifdef STORENUMBER}pnamedindexobject{$else}psym{$endif});
     var
       news, newrec : pchar;
       spec : string[2];
       size : longint;
     begin
     { static variables from objects are like global objects }
-    if ((p^.properties and sp_static)<>0) then
+    if ((psym(p)^.properties and sp_static)<>0) then
       exit;
-    if ((p^.properties and sp_protected)<>0) then
+    if ((psym(p)^.properties and sp_protected)<>0) then
       spec:='/1'
-    else if ((p^.properties and sp_private)<>0) then
+    else if ((psym(p)^.properties and sp_private)<>0) then
       spec:='/0'
     else
       spec:='';
 
-    If p^.typ = varsym then
+    If psym(p)^.typ = varsym then
        begin
        size:=pvarsym(p)^.definition^.size;
        { open arrays made overflows !! }
@@ -1899,7 +1898,9 @@
     function trecdef.stabstring : pchar;
       Var oldrec : pchar;
           oldsize : longint;
+{$ifndef STORENUMBER}
           cur : psym;
+{$endif}
       begin
         oldrec := stabrecstring;
         oldsize:=stabrecsize;
@@ -1908,11 +1909,7 @@
         strpcopy(stabRecString,'s'+tostr(savesize));
         RecOffset := 0;
 {$ifdef nonextfield}
-        {$ifdef tp}
-          symtable^.foreach(addname);
-        {$else}
-          symtable^.foreach(@addname);
-        {$endif}
+        symtable^.foreach({$ifdef fpc}@{$endif}addname);
 {$else nonextfield}
          cur:=symtable^.searchroot;
          while assigned(cur) do
@@ -1942,22 +1939,24 @@
 
     var
        count : longint;
-    procedure count_inittable_fields(sym : psym);{$ifndef fpc}far;{$endif}
+    procedure count_inittable_fields(sym : {$ifdef STORENUMBER}pnamedindexobject{$else}psym{$endif});{$ifndef fpc}far;{$endif}
       begin
-         if (sym^.typ=varsym) and (pvarsym(sym)^.definition^.needs_inittable) then
+         if (psym(sym)^.typ=varsym) and
+            (pvarsym(sym)^.definition^.needs_inittable) then
            inc(count);
       end;
 
 
-    procedure count_fields(sym : psym);{$ifndef fpc}far;{$endif}
+    procedure count_fields(sym : {$ifdef STORENUMBER}pnamedindexobject{$else}psym{$endif});{$ifndef fpc}far;{$endif}
       begin
          inc(count);
       end;
 
 
-    procedure write_field_inittable(sym : psym);{$ifndef fpc}far;{$endif}
+    procedure write_field_inittable(sym : {$ifdef STORENUMBER}pnamedindexobject{$else}psym{$endif});{$ifndef fpc}far;{$endif}
       begin
-         if (sym^.typ=varsym) and pvarsym(sym)^.definition^.needs_inittable then
+         if (psym(sym)^.typ=varsym) and
+            pvarsym(sym)^.definition^.needs_inittable then
            begin
               rttilist^.concat(new(pai_const_symbol,init(lab2str(pvarsym(sym)^.definition^.get_inittable_label))));
               rttilist^.concat(new(pai_const,init_32bit(pvarsym(sym)^.address)));
@@ -1965,22 +1964,23 @@
       end;
 
 
-    procedure write_field_rtti(sym : psym);{$ifndef fpc}far;{$endif}
+    procedure write_field_rtti(sym : {$ifdef STORENUMBER}pnamedindexobject{$else}psym{$endif});{$ifndef fpc}far;{$endif}
       begin
          rttilist^.concat(new(pai_const_symbol,init(pvarsym(sym)^.definition^.get_rtti_label)));
          rttilist^.concat(new(pai_const,init_32bit(pvarsym(sym)^.address)));
       end;
 
 
-    procedure generate_child_inittable(sym : psym);{$ifndef fpc}far;{$endif}
+    procedure generate_child_inittable(sym:{$ifdef STORENUMBER}pnamedindexobject{$else}psym{$endif});{$ifndef fpc}far;{$endif}
       begin
-         if (sym^.typ=varsym) and pvarsym(sym)^.definition^.needs_inittable then
+         if (psym(sym)^.typ=varsym) and
+            pvarsym(sym)^.definition^.needs_inittable then
          { force inittable generation }
            pvarsym(sym)^.definition^.get_inittable_label;
       end;
 
 
-    procedure generate_child_rtti(sym : psym);{$ifndef fpc}far;{$endif}
+    procedure generate_child_rtti(sym : {$ifdef STORENUMBER}pnamedindexobject{$else}psym{$endif});{$ifndef fpc}far;{$endif}
       begin
          pvarsym(sym)^.definition^.get_rtti_label;
       end;
@@ -2658,7 +2658,7 @@ Const local_symtable_index : longint = $8001;
       s := sym^.name;
       if _class <> nil then
         begin
-        s2 := _class^.name^;
+        s2 := _class^.objname^;
         s := s+'__'+tostr(length(s2))+s2;
         end else s := s + '_';
       param := para1;
@@ -2834,7 +2834,7 @@ Const local_symtable_index : longint = $8001;
 {$endif }
         publicsyms^.defowner:=@self;
         set_parent(c);
-        name:=stringdup(n);
+        objname:=stringdup(n);
      end;
 
 
@@ -2877,7 +2877,7 @@ Const local_symtable_index : longint = $8001;
          deftype:=objectdef;
          savesize:=readlong;
          vmt_offset:=readlong;
-         name:=stringdup(readstring);
+         objname:=stringdup(readstring);
          childof:=pobjectdef(readdefref);
          options:=readlong;
          oldread_member:=read_member;
@@ -2888,12 +2888,12 @@ Const local_symtable_index : longint = $8001;
          read_member:=oldread_member;
          publicsyms^.defowner:=@self;
          { publicsyms^.datasize:=savesize; }
-         publicsyms^.name := stringdup(name^);
+         publicsyms^.name := stringdup(objname^);
 
          { handles the predefined class tobject  }
          { the last TOBJECT which is loaded gets }
          { it !                                  }
-         if (name^='TOBJECT') and not(cs_compilesystem in aktmoduleswitches) and
+         if (objname^='TOBJECT') and not(cs_compilesystem in aktmoduleswitches) and
            isclass and (childof=pointer($ffffffff)) then
            class_tobject:=@self;
          has_rtti:=true;
@@ -2929,7 +2929,7 @@ Const local_symtable_index : longint = $8001;
         if (options and oo_isforward)<>0 then
           begin
              { ok, in future, the forward can be resolved }
-             Message1(sym_e_class_forward_not_resolved,name^);
+             Message1(sym_e_class_forward_not_resolved,objname^);
              options:=options and not(oo_isforward);
           end;
      end;
@@ -2945,8 +2945,8 @@ Const local_symtable_index : longint = $8001;
         if assigned(publicsyms) then
           dispose(publicsyms,done);
         if (options and oo_isforward)<>0 then
-         Message1(sym_e_class_forward_not_resolved,name^);
-        stringdispose(name);
+         Message1(sym_e_class_forward_not_resolved,objname^);
+        stringdispose(objname);
         tdef.done;
      end;
 
@@ -2982,18 +2982,19 @@ Const local_symtable_index : longint = $8001;
 
     procedure tobjectdef.deref;
       var
+{$ifndef STORENUMBER}
          hp : pdef;
+{$endif}
          oldrecsyms : psymtable;
       begin
          resolvedef(pdef(childof));
          oldrecsyms:=aktrecordsymtable;
          aktrecordsymtable:=publicsyms;
-         { nun die Definitionen dereferenzieren }
+
 {$ifdef STORENUMBER}
-         hp:=pdef(publicsyms^.defindex^.first);
+         publicsyms^.deref;
 {$else}
          hp:=publicsyms^.rootdef;
-{$endif}
          while assigned(hp) do
            begin
               hp^.deref;
@@ -3001,10 +3002,7 @@ Const local_symtable_index : longint = $8001;
               hp^.owner:=publicsyms;
               hp:=pdef(hp^.next);
            end;
-{$ifdef tp}
-         publicsyms^.foreach(derefsym);
-{$else}
-         publicsyms^.foreach(@derefsym);
+         publicsyms^.foreach({$ifdef fpc}@{$endif}derefsym);
 {$endif}
          aktrecordsymtable:=oldrecsyms;
       end;
@@ -3019,15 +3017,15 @@ Const local_symtable_index : longint = $8001;
     begin
         if (options and oo_hasvmt)=0 then
           {internalerror(12346);}
-          Message1(parser_object_has_no_vmt,name^);
+          Message1(parser_object_has_no_vmt,objname^);
         if owner^.name=nil then
             s1:=''
         else
             s1:=owner^.name^;
-        if name=nil then
+        if objname=nil then
             s2:=''
         else
-            s2:=name^;
+            s2:=objname^;
         vmt_mangledname:='VMT_'+s1+'$_'+s2;
     end;
 
@@ -3040,10 +3038,10 @@ Const local_symtable_index : longint = $8001;
          s1:=''
        else
          s1:=owner^.name^;
-       if name=nil then
+       if objname=nil then
          s2:=''
        else
-         s2:=name^;
+         s2:=objname^;
        rtti_name:='RTTI_'+s1+'$_'+s2;
     end;
 
@@ -3061,7 +3059,7 @@ Const local_symtable_index : longint = $8001;
          tdef.write;
          writelong(size);
          writelong(vmt_offset);
-         writestring(name^);
+         writestring(objname^);
          writedefref(childof);
          writelong(options);
          current_ppu^.writeentry(ibobjectdef);
@@ -3076,7 +3074,7 @@ Const local_symtable_index : longint = $8001;
 
 
 {$ifdef GDB}
-    procedure addprocname(p :psym);
+    procedure addprocname(p :{$ifdef STORENUMBER}pnamedindexobject{$else}psym{$endif});
     var virtualind,argnames : string;
         news, newrec : pchar;
         pd,ipd : pprocdef;
@@ -3086,7 +3084,7 @@ Const local_symtable_index : longint = $8001;
         sp : char;
 
     begin
-      If p^.typ = procsym then
+      If psym(p)^.typ = procsym then
        begin
                 pd := pprocsym(p)^.definition;
                 { this will be used for full implementation of object stabs
@@ -3139,8 +3137,8 @@ Const local_symtable_index : longint = $8001;
                 ipd^.is_def_stab_written := true;
                 { here 2A must be changed for private and protected }
                 { 0 is private 1 protected and 2 public }
-                if (p^.properties and sp_private)<>0 then sp:='0'
-                else if (p^.properties and sp_protected)<>0 then sp:='1'
+                if (psym(p)^.properties and sp_private)<>0 then sp:='0'
+                else if (psym(p)^.properties and sp_protected)<>0 then sp:='1'
                 else sp:='2';
                 newrec := strpnew(p^.name+'::'+ipd^.numberstring
                      +'=##'+pd^.retdef^.numberstring+';:'+argnames+';'+sp+'A'
@@ -3194,7 +3192,7 @@ Const local_symtable_index : longint = $8001;
          while assigned(cur) do
            begin
               addname(cur);
-              cur:=cur^.nextsym;
+              cur:=psym(cur)^.nextsym;
            end;
 {$endif nonextfield}
       if (options and oo_hasvmt) <> 0 then
@@ -3214,7 +3212,7 @@ Const local_symtable_index : longint = $8001;
          while assigned(cur) do
            begin
               addprocname(cur);
-              cur:=cur^.nextsym;
+              cur:=psym(cur)^.nextsym;
            end;
 {$endif nonextfield}
         if (options and oo_hasvmt) <> 0  then
@@ -3248,8 +3246,8 @@ Const local_symtable_index : longint = $8001;
            rttilist^.concat(new(pai_const,init_8bit(tkobject)));
 
          { generate the name }
-         rttilist^.concat(new(pai_const,init_8bit(length(name^))));
-         rttilist^.concat(new(pai_string,init(name^)));
+         rttilist^.concat(new(pai_const,init_8bit(length(objname^))));
+         rttilist^.concat(new(pai_string,init(objname^)));
 
          rttilist^.concat(new(pai_const,init_32bit(size)));
          count:=0;
@@ -3275,14 +3273,15 @@ Const local_symtable_index : longint = $8001;
       end;
 
 
-    procedure count_published_properties(sym : psym);{$ifndef fpc}far;{$endif}
+    procedure count_published_properties(sym:{$ifdef STORENUMBER}pnamedindexobject{$else}psym{$endif});
+      {$ifndef fpc}far;{$endif}
       begin
-         if (sym^.typ=propertysym) and ((sym^.properties and sp_published)<>0) then
+         if (psym(sym)^.typ=propertysym) and ((psym(sym)^.properties and sp_published)<>0) then
            inc(count);
       end;
 
 
-    procedure write_property_info(sym : psym);{$ifndef fpc}far;{$endif}
+    procedure write_property_info(sym : {$ifdef STORENUMBER}pnamedindexobject{$else}psym{$endif});{$ifndef fpc}far;{$endif}
       var
          proctypesinfo : byte;
 
@@ -3320,11 +3319,13 @@ Const local_symtable_index : longint = $8001;
 
       begin
 
-         if (ppropertysym(sym)^.options and ppo_indexed)<>0 then
+         if (psym(sym)^.typ=propertysym) and
+            ((ppropertysym(sym)^.options and ppo_indexed)<>0) then
            proctypesinfo:=$40
          else
            proctypesinfo:=0;
-         if (sym^.typ=propertysym) and ((sym^.properties and sp_published)<>0) then
+         if (psym(sym)^.typ=propertysym) and
+            ((psym(sym)^.properties and sp_published)<>0) then
            begin
               rttilist^.concat(new(pai_const_symbol,init(ppropertysym(sym)^.proptype^.get_rtti_label)));
               writeproc(ppropertysym(sym)^.readaccesssym,ppropertysym(sym)^.readaccessdef,0);
@@ -3348,9 +3349,11 @@ Const local_symtable_index : longint = $8001;
       end;
 
 
-    procedure generate_published_child_rtti(sym : psym);{$ifndef fpc}far;{$endif}
+    procedure generate_published_child_rtti(sym : {$ifdef STORENUMBER}pnamedindexobject{$else}psym{$endif});
+      {$ifndef fpc}far;{$endif}
       begin
-         if (sym^.typ=propertysym) and ((sym^.properties and sp_published)<>0) then
+         if (psym(sym)^.typ=propertysym) and
+            ((psym(sym)^.properties and sp_published)<>0) then
            ppropertysym(sym)^.proptype^.get_rtti_label;
       end;
 
@@ -3394,8 +3397,8 @@ Const local_symtable_index : longint = $8001;
            rttilist^.concat(new(pai_const,init_8bit(tkobject)));
 
          { generate the name }
-         rttilist^.concat(new(pai_const,init_8bit(length(name^))));
-         rttilist^.concat(new(pai_string,init(name^)));
+         rttilist^.concat(new(pai_const,init_8bit(length(objname^))));
+         rttilist^.concat(new(pai_string,init(objname^)));
 
          { write class type }
          rttilist^.concat(new(pai_const_symbol,init(vmt_mangledname)));
@@ -3473,7 +3476,12 @@ Const local_symtable_index : longint = $8001;
 
 {
   $Log$
-  Revision 1.103  1999-04-19 09:28:20  peter
+  Revision 1.104  1999-04-21 09:43:50  peter
+    * storenumber works
+    * fixed some typos in double_checksum
+    + incompatible types type1 and type2 message (with storenumber)
+
+  Revision 1.103  1999/04/19 09:28:20  peter
     * fixed crash when writing overload operator to ppu
 
   Revision 1.102  1999/04/17 22:01:28  pierre

+ 8 - 3
compiler/symdefh.inc

@@ -32,7 +32,7 @@
 
        pdef = ^tdef;
 {$ifdef STORENUMBER}
-       tdef = object(tindexobject)
+       tdef = object(tnamedindexobject)
 {$else}
        tdef = object
           indexnb  : longint;
@@ -179,7 +179,7 @@
        pobjectdef = ^tobjectdef;
        tobjectdef = object(tdef)
           childof : pobjectdef;
-          name : pstring;
+          objname : pstring;
           { privatesyms : psymtable;
           protectedsyms : psymtable; }
           publicsyms : psymtable;
@@ -512,7 +512,12 @@
 
 {
   $Log$
-  Revision 1.20  1999-04-14 09:15:00  peter
+  Revision 1.21  1999-04-21 09:43:52  peter
+    * storenumber works
+    * fixed some typos in double_checksum
+    + incompatible types type1 and type2 message (with storenumber)
+
+  Revision 1.20  1999/04/14 09:15:00  peter
     * first things to store the symbol/def number in the ppu
 
   Revision 1.19  1999/04/08 15:57:52  peter

+ 18 - 11
compiler/symppu.inc

@@ -179,15 +179,11 @@
            current_ppu^.do_interface_crc:=hp^.in_interface;
 {$endif Double_checksum}
            current_ppu^.putstring(hp^.name^);
-           current_ppu^.do_crc:=false;
-{$ifndef Double_checksum}
            { the checksum should not affect the crc of this unit ! (PFV) }
+           current_ppu^.do_crc:=false;
            current_ppu^.putlongint(hp^.checksum);
-{$else Double_checksum}
-           if hp^.in_interface then
-             current_ppu^.putlongint(hp^.checksum)
-           else
-             current_ppu^.putlongint(hp^.interface_checksum);
+{$ifdef Double_checksum}
+           current_ppu^.putlongint(hp^.interface_checksum);
 {$endif def Double_checksum}
            current_ppu^.do_crc:=true;
            current_ppu^.putbyte(byte(hp^.in_interface));
@@ -265,7 +261,7 @@
          current_ppu^.header.size:=current_ppu^.size;
          current_ppu^.header.checksum:=current_ppu^.crc;
 {$ifdef Double_checksum}
-        current_module^.interface_crc:=current_ppu^.interface_crc;
+         current_ppu^.header.interface_checksum:=current_ppu^.interface_crc;
 {$endif def Double_checksum}
          current_ppu^.header.compiler:=wordversion;
          current_ppu^.header.cpu:=word(target_cpu);
@@ -275,7 +271,7 @@
        { save crc in current_module also }
          current_module^.crc:=current_ppu^.crc;
 {$ifdef Double_checksum}
-        current_module^.interface_crc:=current_ppu^.interface_crc;
+         current_module^.interface_crc:=current_ppu^.interface_crc;
         if only_crc then
           begin
 {$ifdef Test_Double_checksum}
@@ -476,6 +472,7 @@
     procedure readloadunit;
       var
         hs : string;
+        intfchecksum,
         checksum : longint;
         in_interface : boolean;
       begin
@@ -483,8 +480,13 @@
          begin
            hs:=current_ppu^.getstring;
            checksum:=current_ppu^.getlongint;
+{$ifdef DOUBLE_CHECKSUM}
+           intfchecksum:=current_ppu^.getlongint;
+{$else}
+           intfchecksum:=0;
+{$endif}
            in_interface:=(current_ppu^.getbyte<>0);
-           current_module^.used_units.concat(new(pused_unit,init_to_load(hs,checksum,in_interface)));
+           current_module^.used_units.concat(new(pused_unit,init_to_load(hs,checksum,intfchecksum,in_interface)));
          end;
       end;
 
@@ -516,7 +518,12 @@
 
 {
   $Log$
-  Revision 1.36  1999-04-14 09:15:01  peter
+  Revision 1.37  1999-04-21 09:43:53  peter
+    * storenumber works
+    * fixed some typos in double_checksum
+    + incompatible types type1 and type2 message (with storenumber)
+
+  Revision 1.36  1999/04/14 09:15:01  peter
     * first things to store the symbol/def number in the ppu
 
   Revision 1.35  1999/04/07 15:39:35  pierre

+ 17 - 5
compiler/symsym.inc

@@ -161,13 +161,15 @@
 
     destructor tsym.done;
       begin
+         if assigned(defref) then
+           dispose(defref,done);
+{$ifdef STORENUMBER}
+        inherited done;
+{$else}
 {$ifdef tp}
          if not(use_big) then
 {$endif tp}
            strdispose(_name);
-         if assigned(defref) then
-           dispose(defref,done);
-{$ifndef STORENUMBER}
          if assigned(left) then
            dispose(left,done);
          if assigned(right) then
@@ -192,6 +194,7 @@
       end;
 
 
+{$ifndef STORENUMBER}
     function tsym.name : string;
 {$ifdef tp}
       var
@@ -215,16 +218,20 @@
         else
          name:='';
       end;
+{$endif}
 
     function tsym.mangledname : string;
       begin
          mangledname:=name;
       end;
 
+{$ifndef STORENUMBER}
     procedure tsym.setname(const s : string);
       begin
          setstring(_name,s);
       end;
+{$endif}
+
 
     { for most symbol types there is nothing to do at all }
     procedure tsym.insert_in_data;
@@ -433,7 +440,7 @@
                    oldaktfilepos:=aktfilepos;
                    aktfilepos:=fileinfo;
                    if assigned(pd^._class) then
-                     Message1(sym_e_forward_not_resolved,pd^._class^.name^+'.'+name+demangledparas(pd^.demangled_paras))
+                     Message1(sym_e_forward_not_resolved,pd^._class^.objname^+'.'+name+demangledparas(pd^.demangled_paras))
                    else
                      Message1(sym_e_forward_not_resolved,name+pd^.demangled_paras);
                    aktfilepos:=oldaktfilepos;
@@ -1936,7 +1943,12 @@
 
 {
   $Log$
-  Revision 1.79  1999-04-17 13:16:21  peter
+  Revision 1.80  1999-04-21 09:43:54  peter
+    * storenumber works
+    * fixed some typos in double_checksum
+    + incompatible types type1 and type2 message (with storenumber)
+
+  Revision 1.79  1999/04/17 13:16:21  peter
     * fixes for storenumber
 
   Revision 1.78  1999/04/14 09:15:02  peter

+ 13 - 6
compiler/symsymh.inc

@@ -35,18 +35,18 @@
        { this object is the base for all symbol objects }
        psym = ^tsym;
 {$ifdef STORENUMBER}
-       tsym = object(tindexobject)
+       tsym = object(tnamedindexobject)
 {$else}
        tsym = object
           indexnb    : longint;
-{$endif}
-          typ        : tsymtyp;
           _name      : pchar;
           left,right : psym;
+          speedvalue : longint;
 {$ifndef nonextfield}
           nextsym    : psym;
 {$endif nextfield}
-          speedvalue : longint;
+{$endif}
+          typ        : tsymtyp;
           properties : symprop;
           owner      : psymtable;
           fileinfo   : tfileposinfo;
@@ -62,9 +62,11 @@
           destructor done;virtual;
           procedure write;virtual;
           procedure deref;virtual;
+{$ifndef STORENUMBER}
           function name : string;
-          function mangledname : string;virtual;
           procedure setname(const s : string);
+{$endif}
+          function mangledname : string;virtual;
           procedure insert_in_data;virtual;
 {$ifdef GDB}
           function stabstring : pchar;virtual;
@@ -343,7 +345,12 @@
 
 {
   $Log$
-  Revision 1.19  1999-04-17 13:16:23  peter
+  Revision 1.20  1999-04-21 09:43:56  peter
+    * storenumber works
+    * fixed some typos in double_checksum
+    + incompatible types type1 and type2 message (with storenumber)
+
+  Revision 1.19  1999/04/17 13:16:23  peter
     * fixes for storenumber
 
   Revision 1.18  1999/04/14 09:15:03  peter

+ 27 - 8
compiler/tccal.pas

@@ -318,7 +318,8 @@ implementation
          def_from,def_to,conv_to : pdef;
          pt,inlinecode : ptree;
          exactmatch,inlined : boolean;
-         paralength,l : longint;
+         paralength,l,lastpara : longint;
+         lastparatype : pdef;
          pdc : pdefcoll;
 {$ifdef TEST_PROCSYMS}
          symt : psymtable;
@@ -563,10 +564,11 @@ implementation
                 { now we can compare parameter after parameter }
                    pt:=p^.left;
                    { we start with the last parameter }
-                   l:=paralength+1;
+                   lastpara:=paralength+1;
+                   lastparatype:=nil;
                    while assigned(pt) do
                      begin
-                        dec(l);
+                        dec(lastpara);
                         { walk all procedures and determine how this parameter matches and set:
                            1. pt^.exact_match_found if one parameter has an exact match
                            2. exactmatch if an equal or exact match is found
@@ -640,7 +642,11 @@ implementation
                                     procs:=hp;
                                   end
                                  else
-                                  dispose(hp);
+                                  begin
+                                    { save the type for nice error message }
+                                    lastparatype:=hp^.nextpara^.data;
+                                    dispose(hp);
+                                  end;
                                  hp:=hp2;
                               end;
                           end;
@@ -651,11 +657,11 @@ implementation
                              hp^.nextpara:=hp^.nextpara^.next;
                              hp:=hp^.next;
                           end;
-                        { load next parameter }
+                        { load next parameter or quit loop if no procs left }
                         if assigned(procs) then
                           pt:=pt^.right
                         else
-                          pt:=nil;
+                          break;
                      end;
 
                  { All parameters are checked, check if there are any
@@ -667,7 +673,15 @@ implementation
                       if ((parsing_para_level=0) or (p^.left<>nil)) and
                          (nextprocsym=nil) then
                        begin
-                          CGMessage1(parser_e_wrong_parameter_type,tostr(l));
+{$ifdef STORENUMBER}
+                         if (not assigned(lastparatype)) and (not assigned(pt^.resulttype)) then
+                          internalerror(39393)
+                         else
+                          CGMessage3(type_e_wrong_parameter_type,tostr(lastpara),
+                             lastparatype^.typename,pt^.resulttype^.typename);
+{$else}
+                          CGMessage1(parser_e_wrong_parameter_type,tostr(lastpara));
+{$endif}
                           aktcallprocsym^.write_parameter_lists;
                           goto errorexit;
                        end
@@ -1125,7 +1139,12 @@ implementation
 end.
 {
   $Log$
-  Revision 1.32  1999-04-14 09:11:22  peter
+  Revision 1.33  1999-04-21 09:44:00  peter
+    * storenumber works
+    * fixed some typos in double_checksum
+    + incompatible types type1 and type2 message (with storenumber)
+
+  Revision 1.32  1999/04/14 09:11:22  peter
     * fixed tp proc -> procvar
 
   Revision 1.31  1999/04/01 21:59:56  peter

+ 10 - 1
compiler/tccnv.pas

@@ -839,7 +839,11 @@ implementation
                        CGMessage(cg_e_illegal_type_conversion);
                 end
               else
+{$ifdef STORENUMBER}
+                CGMessage2(type_e_incompatible_types,p^.resulttype^.typename,p^.left^.resulttype^.typename);
+{$else}
                 CGMessage(type_e_mismatch);
+{$endif}
            end
          end;
         { ordinal contants can be directly converted }
@@ -936,7 +940,12 @@ implementation
 end.
 {
   $Log$
-  Revision 1.23  1999-04-15 08:56:24  peter
+  Revision 1.24  1999-04-21 09:44:01  peter
+    * storenumber works
+    * fixed some typos in double_checksum
+    + incompatible types type1 and type2 message (with storenumber)
+
+  Revision 1.23  1999/04/15 08:56:24  peter
     * fixed bool-bool conversion
 
   Revision 1.22  1999/04/08 09:47:31  pierre