* fixed bugs 212,222,225,227,229,231,233

compiler/assemble.pas

@@ -79,7 +79,7 @@ var
 Implementation
 
 uses
-  script,files,systems,verbose,comphook
+  script,files,systems,verbose
 {$ifdef linux}
   ,linux
 {$endif}
@@ -229,7 +229,7 @@ begin
   else
    begin
       DoAssemble:=false;
-      inc(status.errorcount);
+      GenerateError;
    end;
 end;
 
@@ -541,7 +541,10 @@ end;
 end.
 {
   $Log$
-  Revision 1.40  1999-03-18 20:30:44  peter
+  Revision 1.41  1999-03-24 23:16:42  peter
+    * fixed bugs 212,222,225,227,229,231,233
+
+  Revision 1.40  1999/03/18 20:30:44  peter
     + .a writer
 
   Revision 1.39  1999/03/01 15:43:48  peter

compiler/browcol.pas

@@ -116,7 +116,7 @@ implementation
 
 uses
   Drivers,Views,App,
-  aasm,globtype,globals,files,comphook;
+  aasm,globtype,globals,files;
 
 {****************************************************************************
                                    Helpers
@@ -900,7 +900,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.8  1999-03-03 01:38:11  pierre
+  Revision 1.9  1999-03-24 23:16:44  peter
+    * fixed bugs 212,222,225,227,229,231,233
+
+  Revision 1.8  1999/03/03 01:38:11  pierre
    * avoid infinite recursion in ProcessDefIfStruct
 
   Revision 1.7  1999/02/22 11:51:32  peter

compiler/cg386cal.pas

@@ -57,20 +57,12 @@ implementation
                 push_from_left_to_right,inlined : boolean;para_offset : longint);
 
       procedure maybe_push_high;
-{$ifdef OLDHIGH}
-        var
-           r    : preference;
-           hreg : tregister;
-           href : treference;
-           len  : longint;
-{$endif}
         begin
            { open array ? }
            { defcoll^.data can be nil for read/write }
            if assigned(defcoll^.data) and
               push_high_param(defcoll^.data) then
              begin
-{$ifndef OLDHIGH}
                if assigned(p^.hightree) then
                 begin
                   secondpass(p^.hightree);
@@ -78,89 +70,6 @@ implementation
                 end
                else
                 internalerror(432645);
-{$else}
-               { push high }
-               case p^.left^.resulttype^.deftype of
-                arraydef : begin
-                             if is_open_array(p^.left^.resulttype) then
-                              begin
-                                   p^.location.reference.base:=procinfo.framepointer;
-                                   p^.location.reference.offset:=pvarsym(p^.symtableentry)^.address;
-                                r:=new_reference(highframepointer,highoffset+4);
-                                len:=-1;
-                              end
-                             else
-                              len:=parraydef(p^.left^.resulttype)^.highrange-
-                                   parraydef(p^.left^.resulttype)^.lowrange
-                           end;
-               stringdef : begin
-                             if is_open_string(defcoll^.data) then
-                               begin
-                                 if is_open_string(p^.left^.resulttype) then
-                                  begin
-                                    r:=new_reference(highframepointer,highoffset+4);
-                                    exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,R_EDI)));
-                                    hreg:=R_EDI;
-                                    len:=-2;
-                                  end
-                                 else
-                                  len:=pstringdef(p^.left^.resulttype)^.len
-                               end
-                             else
-                             { passing a string to an array of char }
-                               begin
-                                 if (p^.left^.treetype=stringconstn) then
-                                   len:=str_length(p^.left)
-                                 else
-                                   begin
-                                     href:=p^.location.reference;
-                                     exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVZX,S_BL,newreference(href),R_EDI)));
-                                     hreg:=R_EDI;
-                                     len:=-2;
-                                   end;
-                               end;
-                           end;
-               else
-                len:=0;
-               end;
-             { Push from the reference? }
-               if len=-1 then
-                begin
-                  if inlined then
-                   begin
-                     exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,R_EDI)));
-                     r:=new_reference(procinfo.framepointer,para_offset-pushedparasize);
-                     exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L,R_EDI,r)));
-                   end
-                  else
-                   exprasmlist^.concat(new(pai386,op_ref(A_PUSH,S_L,r)));
-                end
-               else
-               { Push from a register? }
-                if len=-2 then
-                 begin
-                   if inlined then
-                    begin
-                      r:=new_reference(procinfo.framepointer,para_offset-pushedparasize);
-                      exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L,hreg,r)));
-                    end
-                   else
-                    exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,hreg)));
-                   ungetregister32(hreg);
-                 end
-               else
-               { Push direct value }
-                begin
-                  if inlined then
-                    begin
-                       r:=new_reference(procinfo.framepointer,para_offset-pushedparasize);
-                       exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,S_L,len,r)));
-                    end
-                  else
-                    push_int(len);
-                end;
-               inc(pushedparasize,4);
-{$endif OLDHIGH}
              end;
         end;
 
@@ -1308,7 +1217,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.69  1999-02-25 21:02:21  peter
+  Revision 1.70  1999-03-24 23:16:46  peter
+    * fixed bugs 212,222,225,227,229,231,233
+
+  Revision 1.69  1999/02/25 21:02:21  peter
     * ag386bin updates
     + coff writer
 

compiler/cg386inl.pas

@@ -903,78 +903,39 @@ implementation
                    exprasmlist^.concat(new(pai386,op_const_reg(A_SHR,S_W,8,p^.location.register)));
                  p^.location.register:=reg16toreg8(p^.location.register);
               end;
-{$ifdef OLDHIGH}
-            in_high_x :
+            in_sizeof_x,
+            in_typeof_x :
               begin
-                 if is_open_array(p^.left^.resulttype) or
-                    is_open_string(p^.left^.resulttype) then
+                 { for both cases load vmt }
+                 if p^.left^.treetype=typen then
+                   begin
+                      p^.location.register:=getregister32;
+                      exprasmlist^.concat(new(pai386,op_sym_ofs_reg(A_MOV,
+                        S_L,newasmsymbol(pobjectdef(p^.left^.resulttype)^.vmt_mangledname),0,
+                        p^.location.register)));
+                   end
+                 else
                    begin
                       secondpass(p^.left);
                       del_reference(p^.left^.location.reference);
+                      p^.location.loc:=LOC_REGISTER;
                       p^.location.register:=getregister32;
-                      r:=new_reference(highframepointer,highoffset+4);
+                      { load VMT pointer }
+                      inc(p^.left^.location.reference.offset,
+                        pobjectdef(p^.left^.resulttype)^.vmt_offset);
                       exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,
-                        r,p^.location.register)));
-                   end
-              end;
-{$endif OLDHIGH}
-            in_sizeof_x,
-            in_typeof_x :
-              begin
-{$ifdef OLDHIGH}
-               { sizeof(openarray) handling }
-                 if (p^.inlinenumber=in_sizeof_x) and
-                    (is_open_array(p^.left^.resulttype) or
-                     is_open_string(p^.left^.resulttype)) then
-                  begin
-                  { sizeof(openarray)=high(openarray)+1 }
-                    secondpass(p^.left);
-                    del_reference(p^.left^.location.reference);
-                    p^.location.register:=getregister32;
-                    r:=new_reference(highframepointer,highoffset+4);
-                    exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,
-                      r,p^.location.register)));
-                    exprasmlist^.concat(new(pai386,op_reg(A_INC,S_L,
-                      p^.location.register)));
-                    if (p^.left^.resulttype^.deftype=arraydef) and
-                       (parraydef(p^.left^.resulttype)^.elesize<>1) then
-                      exprasmlist^.concat(new(pai386,op_const_reg(A_IMUL,S_L,
-                        parraydef(p^.left^.resulttype)^.elesize,p^.location.register)));
-                  end
-                 else
-{$endif OLDHIGH}
-                  begin
-                    { for both cases load vmt }
-                    if p^.left^.treetype=typen then
-                      begin
-                         p^.location.register:=getregister32;
-                         exprasmlist^.concat(new(pai386,op_sym_ofs_reg(A_MOV,
-                           S_L,newasmsymbol(pobjectdef(p^.left^.resulttype)^.vmt_mangledname),0,
-                           p^.location.register)));
-                      end
-                    else
-                      begin
-                         secondpass(p^.left);
-                         del_reference(p^.left^.location.reference);
-                         p^.location.loc:=LOC_REGISTER;
-                         p^.location.register:=getregister32;
-                         { load VMT pointer }
-                         inc(p^.left^.location.reference.offset,
-                           pobjectdef(p^.left^.resulttype)^.vmt_offset);
-                         exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,
-                         newreference(p^.left^.location.reference),
-                           p^.location.register)));
-                      end;
-                    { in sizeof load size }
-                    if p^.inlinenumber=in_sizeof_x then
-                      begin
-                         new(r);
-                         reset_reference(r^);
-                         r^.base:=p^.location.register;
-                         exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,
-                           p^.location.register)));
-                      end;
-                  end;
+                      newreference(p^.left^.location.reference),
+                        p^.location.register)));
+                   end;
+                 { in sizeof load size }
+                 if p^.inlinenumber=in_sizeof_x then
+                   begin
+                      new(r);
+                      reset_reference(r^);
+                      r^.base:=p^.location.register;
+                      exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,
+                        p^.location.register)));
+                   end;
               end;
             in_lo_long,
             in_hi_long :
@@ -1309,7 +1270,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.30  1999-03-16 17:52:56  jonas
+  Revision 1.31  1999-03-24 23:16:49  peter
+    * fixed bugs 212,222,225,227,229,231,233
+
+  Revision 1.30  1999/03/16 17:52:56  jonas
     * changes for internal Val code (do a "make cycle OPT=-dvalintern" to test)
     * in cgi386inl: also range checking for subrange types (compile with "-dreadrangecheck")
     * in cgai386: also small fixes to emitrangecheck

compiler/cg386ld.pas

@@ -83,7 +83,7 @@ implementation
                       begin
                          p^.location.reference.symbol:=newasmsymbol(p^.symtableentry^.mangledname);
                          if (pvarsym(p^.symtableentry)^.var_options and vo_is_external)<>0 then
-                           maybe_concat_external(p^.symtableentry^.owner,p^.symtableentry^.mangledname);
+                           concat_external(p^.symtableentry^.mangledname,EXT_NEAR);
                       end
                     { DLL variable }
                     else if (pvarsym(p^.symtableentry)^.var_options and vo_is_dll_var)<>0 then
@@ -93,9 +93,14 @@ implementation
                          exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.location.reference),hregister)));
                          p^.location.reference.symbol:=nil;
                          p^.location.reference.base:=hregister;
-                         if (pvarsym(p^.symtableentry)^.var_options and vo_is_external)<>0 then
-                           maybe_concat_external(p^.symtableentry^.owner,p^.symtableentry^.mangledname);
                       end
+                    { external variable }
+                    else if (pvarsym(p^.symtableentry)^.var_options and vo_is_external)<>0 then
+                      begin
+                         p^.location.reference.symbol:=newasmsymbol(p^.symtableentry^.mangledname);
+                         concat_external(p^.symtableentry^.mangledname,EXT_NEAR);
+                      end
+                    { normal variable }
                     else
                       begin
                          symtabletype:=p^.symtable^.symtabletype;
@@ -797,7 +802,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.45  1999-02-25 21:02:28  peter
+  Revision 1.46  1999-03-24 23:16:52  peter
+    * fixed bugs 212,222,225,227,229,231,233
+
+  Revision 1.45  1999/02/25 21:02:28  peter
     * ag386bin updates
     + coff writer
 

compiler/cg386mem.pas

@@ -46,7 +46,7 @@ implementation
       globtype,systems,
       cobjects,verbose,globals,
       symtable,aasm,types,
-      hcodegen,temp_gen,pass_2,
+      hcodegen,temp_gen,pass_2,pass_1,
 {$ifdef ag386bin}
       i386base,i386asm,
 {$else}
@@ -408,9 +408,10 @@ implementation
          rl : pdef;
          t   : ptree;
          hp  : preference;
+         href : treference;
          tai : Pai386;
          pushed : tpushed;
-
+         hightree : ptree;
 
       begin
          secondpass(p^.left);
@@ -553,6 +554,7 @@ implementation
               p:=_p;
            end
          else
+         { not treetype=ordconstn }
            begin
               { quick hack, to overcome Delphi 2 }
               if (cs_regalloc in aktglobalswitches) and
@@ -606,7 +608,8 @@ implementation
                 CGMessage(cg_e_illegal_expression);
               is_pushed:=maybe_push(p^.right^.registers32,p);
               secondpass(p^.right);
-              if is_pushed then restore(p);
+              if is_pushed then
+                restore(p);
               case p^.right^.location.loc of
                  LOC_REGISTER:
                    begin
@@ -651,25 +654,33 @@ implementation
                        { Booleans are stored in an 8 bit memory location, so
                          the use of MOVL is not correct }
                        case p^.right^.resulttype^.size of
-                         1:
-                           tai:=new(pai386,op_ref_reg(A_MOVZX,S_BL,newreference(p^.right^.location.reference),ind));
-                         2:
-                           tai:=new(Pai386,op_ref_reg(A_MOVZX,S_WL,newreference(p^.right^.location.reference),ind));
-                         4:
-                           tai:=new(Pai386,op_ref_reg(A_MOV,S_L,newreference(p^.right^.location.reference),ind));
+                        1 : tai:=new(pai386,op_ref_reg(A_MOVZX,S_BL,newreference(p^.right^.location.reference),ind));
+                        2 : tai:=new(Pai386,op_ref_reg(A_MOVZX,S_WL,newreference(p^.right^.location.reference),ind));
+                        4 : tai:=new(Pai386,op_ref_reg(A_MOV,S_L,newreference(p^.right^.location.reference),ind));
                        end;
                        exprasmlist^.concat(tai);
                     end;
               end;
+
             { produce possible range check code: }
-            if cs_check_range in aktlocalswitches then
-              begin
+              if cs_check_range in aktlocalswitches then
+               begin
                  if p^.left^.resulttype^.deftype=arraydef then
                    begin
-                      hp:=new_reference(R_NO,0);
-                      parraydef(p^.left^.resulttype)^.genrangecheck;
-                      hp^.symbol:=newasmsymbol(parraydef(p^.left^.resulttype)^.getrangecheckstring);
-                      exprasmlist^.concat(new(pai386,op_reg_ref(A_BOUND,S_L,ind,hp)));
+                     if is_open_array(p^.left^.resulttype) then
+                      begin
+                        reset_reference(href);
+                        parraydef(p^.left^.resulttype)^.genrangecheck;
+                        href.symbol:=newasmsymbol(parraydef(p^.left^.resulttype)^.getrangecheckstring);
+                        href.offset:=4;
+                        getsymonlyin(p^.left^.symtable,'high'+pvarsym(p^.left^.symtableentry)^.name);
+                        hightree:=genloadnode(pvarsym(srsym),p^.left^.symtable);
+                        firstpass(hightree);
+                        secondpass(hightree);
+                        emit_mov_loc_ref(hightree^.location,href);
+                        disposetree(hightree);
+                      end;
+                     emitrangecheck(p^.right,p^.left^.resulttype);
                    end
                  else if (p^.left^.resulttype^.deftype=stringdef) then
                    begin
@@ -687,56 +698,55 @@ implementation
                               popusedregisters(pushed);
                               maybe_loadesi;
                            end;
-
                          st_shortstring:
                            begin
                               {!!!!!!!!!!!!!!!!!}
                            end;
-
                          st_longstring:
                            begin
                               {!!!!!!!!!!!!!!!!!}
                            end;
                       end;
                    end;
+               end;
 
-              end;
-            if p^.location.reference.index=R_NO then
-              begin
+              if p^.location.reference.index=R_NO then
+               begin
                  p^.location.reference.index:=ind;
                  calc_emit_mul;
-              end
-            else
-              begin
+               end
+              else
+               begin
                  if p^.location.reference.base=R_NO then
-                   begin
-                      case p^.location.reference.scalefactor of
-                         2 : exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L,1,p^.location.reference.index)));
-                         4 : exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L,2,p^.location.reference.index)));
-                         8 : exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L,3,p^.location.reference.index)));
-                      end;
-                      calc_emit_mul;
-                      p^.location.reference.base:=p^.location.reference.index;
-                      p^.location.reference.index:=ind;
-                   end
+                  begin
+                    case p^.location.reference.scalefactor of
+                     2 : exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L,1,p^.location.reference.index)));
+                     4 : exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L,2,p^.location.reference.index)));
+                     8 : exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L,3,p^.location.reference.index)));
+                    end;
+                    calc_emit_mul;
+                    p^.location.reference.base:=p^.location.reference.index;
+                    p^.location.reference.index:=ind;
+                  end
                  else
-                   begin
-                      exprasmlist^.concat(new(pai386,op_ref_reg(
-                        A_LEA,S_L,newreference(p^.location.reference),
-                        p^.location.reference.index)));
-                      ungetregister32(p^.location.reference.base);
-                      { the symbol offset is loaded,               }
-                      { so release the symbol name and set symbol  }
-                      { to nil                                     }
-                      p^.location.reference.symbol:=nil;
-                      p^.location.reference.offset:=0;
-                      calc_emit_mul;
-                      p^.location.reference.base:=p^.location.reference.index;
-                      p^.location.reference.index:=ind;
-                   end;
-              end;
-             if p^.memseg then
-               p^.location.reference.segment:=R_FS;
+                  begin
+                    exprasmlist^.concat(new(pai386,op_ref_reg(
+                      A_LEA,S_L,newreference(p^.location.reference),
+                      p^.location.reference.index)));
+                    ungetregister32(p^.location.reference.base);
+                    { the symbol offset is loaded,               }
+                    { so release the symbol name and set symbol  }
+                    { to nil                                     }
+                    p^.location.reference.symbol:=nil;
+                    p^.location.reference.offset:=0;
+                    calc_emit_mul;
+                    p^.location.reference.base:=p^.location.reference.index;
+                    p^.location.reference.index:=ind;
+                  end;
+               end;
+
+              if p^.memseg then
+                p^.location.reference.segment:=R_FS;
            end;
 
          { have we to remove a temp. wide/ansistring ?
@@ -859,7 +869,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.31  1999-02-25 21:02:29  peter
+  Revision 1.32  1999-03-24 23:16:53  peter
+    * fixed bugs 212,222,225,227,229,231,233
+
+  Revision 1.31  1999/02/25 21:02:29  peter
     * ag386bin updates
     + coff writer
 

compiler/hcgdata.pas

@@ -0,0 +1,572 @@
+{
+    $Id$
+    Copyright (c) 1996-98 by Florian Klaempfl
+
+    Routines for the code generation of data structures
+    like VMT,Messages
+
+    This program is free software; you can redistribute it and/or modify
+    it under the terms of the GNU General Public License as published by
+    the Free Software Foundation; either version 2 of the License, or
+    (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU General Public License for more details.
+
+    You should have received a copy of the GNU General Public License
+    along with this program; if not, write to the Free Software
+    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ ****************************************************************************
+}
+unit hcgdata;
+interface
+
+    uses
+       symtable,aasm;
+
+    { generates the message tables for a class }
+    function genstrmsgtab(_class : pobjectdef) : plabel;
+    function genintmsgtab(_class : pobjectdef) : plabel;
+
+    { generates a VMT for _class }
+    procedure genvmt(_class : pobjectdef);
+
+
+implementation
+
+    uses
+       strings,cobjects,
+       globtype,globals,verbose,
+       types,
+       hcodegen;
+
+
+{*****************************************************************************
+                                Message
+*****************************************************************************}
+
+    type
+       pprocdeftree = ^tprocdeftree;
+       tprocdeftree = record
+          p   : pprocdef;
+          nl  : plabel;
+          l,r : pprocdeftree;
+       end;
+
+    var
+       root : pprocdeftree;
+       count : longint;
+
+    procedure insertstr(p : pprocdeftree;var at : pprocdeftree);
+
+      var
+         i : longint;
+
+      begin
+         if at=nil then
+           begin
+              at:=p;
+              inc(count);
+           end
+         else
+           begin
+              i:=strcomp(p^.p^.messageinf.str,at^.p^.messageinf.str);
+              if i<0 then
+                insertstr(p,at^.l)
+              else if i>0 then
+                insertstr(p,at^.r)
+              else
+                Message1(parser_e_duplicate_message_label,strpas(p^.p^.messageinf.str));
+           end;
+      end;
+
+    procedure disposeprocdeftree(p : pprocdeftree);
+
+      begin
+         if assigned(p^.l) then
+           disposeprocdeftree(p^.l);
+         if assigned(p^.r) then
+           disposeprocdeftree(p^.r);
+         dispose(p);
+      end;
+
+    procedure insertmsgstr(p : psym);{$ifndef FPC}far;{$endif FPC}
+
+      var
+         hp : pprocdef;
+         pt : pprocdeftree;
+
+      begin
+         if p^.typ=procsym then
+           begin
+              hp:=pprocsym(p)^.definition;
+              while assigned(hp) do
+                begin
+                   if (hp^.options and pomsgstr)<>0 then
+                     begin
+                        new(pt);
+                        pt^.p:=hp;
+                        pt^.l:=nil;
+                        pt^.r:=nil;
+                        insertstr(pt,root);
+                     end;
+                   hp:=hp^.nextoverloaded;
+                end;
+           end;
+      end;
+
+    procedure insertint(p : pprocdeftree;var at : pprocdeftree);
+
+      var
+         i : longint;
+
+      begin
+         if at=nil then
+           begin
+              at:=p;
+              inc(count);
+           end
+         else
+           begin
+              i:=strcomp(p^.p^.messageinf.str,at^.p^.messageinf.str);
+              if p^.p^.messageinf.i<at^.p^.messageinf.i then
+                insertstr(p,at^.l)
+              else if p^.p^.messageinf.i>at^.p^.messageinf.i then
+                insertstr(p,at^.r)
+              else
+                Message1(parser_e_duplicate_message_label,tostr(p^.p^.messageinf.i));
+           end;
+      end;
+
+    procedure insertmsgint(p : psym);{$ifndef FPC}far;{$endif FPC}
+
+      var
+         hp : pprocdef;
+         pt : pprocdeftree;
+
+      begin
+         if p^.typ=procsym then
+           begin
+              hp:=pprocsym(p)^.definition;
+              while assigned(hp) do
+                begin
+                   if (hp^.options and pomsgint)<>0 then
+                     begin
+                        new(pt);
+                        pt^.p:=hp;
+                        pt^.l:=nil;
+                        pt^.r:=nil;
+                        insertint(pt,root);
+                     end;
+                   hp:=hp^.nextoverloaded;
+                end;
+           end;
+      end;
+
+    procedure writenames(p : pprocdeftree);
+
+      begin
+         getlabel(p^.nl);
+         if assigned(p^.l) then
+           writenames(p^.l);
+         datasegment^.concat(new(pai_label,init(p^.nl)));
+         datasegment^.concat(new(pai_const,init_8bit(strlen(p^.p^.messageinf.str))));
+         datasegment^.concat(new(pai_string,init_pchar(p^.p^.messageinf.str)));
+         if assigned(p^.r) then
+           writenames(p^.r);
+      end;
+
+    procedure writestrentry(p : pprocdeftree);
+
+      begin
+         if assigned(p^.l) then
+           writestrentry(p^.l);
+
+         { write name label }
+         datasegment^.concat(new(pai_const_symbol,init(lab2str(p^.nl))));
+         datasegment^.concat(new(pai_const_symbol,init(p^.p^.mangledname)));
+         maybe_concat_external(p^.p^.owner,p^.p^.mangledname);
+
+         if assigned(p^.r) then
+           writestrentry(p^.r);
+      end;
+
+    function genstrmsgtab(_class : pobjectdef) : plabel;
+
+
+      var
+         r : plabel;
+
+      begin
+         root:=nil;
+         count:=0;
+         { insert all message handlers into a tree, sorted by name }
+         _class^.publicsyms^.foreach(insertmsgstr);
+
+         { write all names }
+         if assigned(root) then
+           writenames(root);
+
+         { now start writing of the message string table }
+         getlabel(r);
+         datasegment^.concat(new(pai_label,init(r)));
+         genstrmsgtab:=r;
+         datasegment^.concat(new(pai_const,init_32bit(count)));
+         if assigned(root) then
+           begin
+              writestrentry(root);
+              disposeprocdeftree(root);
+           end;
+      end;
+
+
+    procedure writeintentry(p : pprocdeftree);
+
+      begin
+         if assigned(p^.l) then
+           writeintentry(p^.l);
+
+         { write name label }
+         datasegment^.concat(new(pai_const,init_32bit(p^.p^.messageinf.i)));
+         datasegment^.concat(new(pai_const_symbol,init(p^.p^.mangledname)));
+         maybe_concat_external(p^.p^.owner,p^.p^.mangledname);
+
+         if assigned(p^.r) then
+           writeintentry(p^.r);
+      end;
+
+    function genintmsgtab(_class : pobjectdef) : plabel;
+
+      var
+         r : plabel;
+
+      begin
+         root:=nil;
+         count:=0;
+         { insert all message handlers into a tree, sorted by name }
+         _class^.publicsyms^.foreach(insertmsgint);
+
+         { now start writing of the message string table }
+         getlabel(r);
+         datasegment^.concat(new(pai_label,init(r)));
+         genintmsgtab:=r;
+         datasegment^.concat(new(pai_const,init_32bit(count)));
+         if assigned(root) then
+           begin
+              writeintentry(root);
+              disposeprocdeftree(root);
+           end;
+      end;
+
+
+{*****************************************************************************
+                                    VMT
+*****************************************************************************}
+
+    type
+       pprocdefcoll = ^tprocdefcoll;
+
+       tprocdefcoll = record
+          next : pprocdefcoll;
+          data : pprocdef;
+       end;
+
+       psymcoll = ^tsymcoll;
+
+       tsymcoll = record
+          next : psymcoll;
+          name : pstring;
+          data : pprocdefcoll;
+       end;
+
+    var
+       wurzel : psymcoll;
+       nextvirtnumber : longint;
+       _c : pobjectdef;
+       has_constructor,has_virtual_method : boolean;
+
+    procedure eachsym(sym : psym);{$ifndef FPC}far;{$endif FPC}
+
+      var
+         procdefcoll : pprocdefcoll;
+         hp : pprocdef;
+         symcoll : psymcoll;
+         _name : string;
+         stored : boolean;
+
+      { creates a new entry in the procsym list }
+      procedure newentry;
+
+        begin
+           { if not, generate a new symbol item }
+           new(symcoll);
+           symcoll^.name:=stringdup(sym^.name);
+           symcoll^.next:=wurzel;
+           symcoll^.data:=nil;
+           wurzel:=symcoll;
+           hp:=pprocsym(sym)^.definition;
+
+           { inserts all definitions }
+           while assigned(hp) do
+             begin
+                new(procdefcoll);
+                procdefcoll^.data:=hp;
+                procdefcoll^.next:=symcoll^.data;
+                symcoll^.data:=procdefcoll;
+
+                { if it's a virtual method }
+                if (hp^.options and povirtualmethod)<>0 then
+                  begin
+                     { then it gets a number ... }
+                     hp^.extnumber:=nextvirtnumber;
+                     { and we inc the number }
+                     inc(nextvirtnumber);
+                     has_virtual_method:=true;
+                  end;
+
+                if (hp^.options and poconstructor)<>0 then
+                  has_constructor:=true;
+
+                { check, if a method should be overridden }
+                if (hp^.options and pooverridingmethod)<>0 then
+                  Message1(parser_e_nothing_to_be_overridden,_c^.name^+'.'+_name);
+                { next overloaded method }
+                hp:=hp^.nextoverloaded;
+             end;
+        end;
+
+      begin
+         { put only sub routines into the VMT }
+         if sym^.typ=procsym then
+           begin
+              _name:=sym^.name;
+              symcoll:=wurzel;
+              while assigned(symcoll) do
+                begin
+                   { does the symbol already exist in the list ? }
+                   if _name=symcoll^.name^ then
+                     begin
+                        { walk through all defs of the symbol }
+                        hp:=pprocsym(sym)^.definition;
+                        while assigned(hp) do
+                          begin
+                             { compare with all stored definitions }
+                             procdefcoll:=symcoll^.data;
+                             stored:=false;
+                             while assigned(procdefcoll) do
+                               begin
+                                  { compare parameters }
+                                  if equal_paras(procdefcoll^.data^.para1,hp^.para1,false) and
+                                     (
+                                       ((procdefcoll^.data^.options and povirtualmethod)<>0) or
+                                       ((hp^.options and povirtualmethod)<>0)
+                                     ) then
+                                    begin
+                                       { wenn sie gleich sind }
+                                       { und eine davon virtual deklariert ist }
+                                       { Fehler falls nur eine VIRTUAL }
+                                       if (procdefcoll^.data^.options and povirtualmethod)<>
+                                          (hp^.options and povirtualmethod) then
+                                         begin
+                                            { in classes, we hide the old method }
+                                            if _c^.isclass then
+                                              begin
+                                                 { 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);
+                                                 newentry;
+                                                 exit;
+                                              end
+                                            else
+                                              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)
+                                                   else
+                                                     Message1(parser_w_overloaded_are_not_both_non_virtual,
+                                                       _c^.name^+'.'+_name);
+                                                   newentry;
+                                                   exit;
+                                                end;
+                                         end;
+
+                                       { check, if the overridden directive is set }
+                                       { (povirtualmethod is set! }
+
+                                       { class ? }
+                                       if _c^.isclass and
+                                         ((hp^.options and pooverridingmethod)=0) then
+                                         begin
+                                            { 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);
+                                            newentry;
+                                            exit;
+                                         end;
+
+                                       { error, if the return types aren't equal }
+                                       if not(is_equal(procdefcoll^.data^.retdef,hp^.retdef)) and
+                                         not((procdefcoll^.data^.retdef^.deftype=objectdef) and
+                                           (hp^.retdef^.deftype=objectdef) and
+                                           (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);
+
+
+                                       { 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);
+
+                                       { now set the number }
+                                       hp^.extnumber:=procdefcoll^.data^.extnumber;
+                                       { and exchange }
+                                       procdefcoll^.data:=hp;
+                                       stored:=true;
+                                    end;
+                                  procdefcoll:=procdefcoll^.next;
+                               end;
+                             { if it isn't saved in the list }
+                             { we create a new entry         }
+                             if not(stored) then
+                               begin
+                                  new(procdefcoll);
+                                  procdefcoll^.data:=hp;
+                                  procdefcoll^.next:=symcoll^.data;
+                                  symcoll^.data:=procdefcoll;
+                                  { if the method is virtual ... }
+                                  if (hp^.options and povirtualmethod)<>0 then
+                                    begin
+                                       { ... it will get a number }
+                                       hp^.extnumber:=nextvirtnumber;
+                                       inc(nextvirtnumber);
+                                    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);
+                               end;
+                             hp:=hp^.nextoverloaded;
+                          end;
+                        exit;
+                     end;
+                   symcoll:=symcoll^.next;
+                end;
+             newentry;
+           end;
+      end;
+
+    procedure genvmt(_class : pobjectdef);
+
+      procedure do_genvmt(p : pobjectdef);
+
+        begin
+           { start with the base class }
+           if assigned(p^.childof) then
+             do_genvmt(p^.childof);
+
+           { walk through all public syms }
+           _c:=_class;
+{$ifdef tp}
+           p^.publicsyms^.foreach(eachsym);
+{$else}
+           p^.publicsyms^.foreach(@eachsym);
+{$endif}
+        end;
+
+      var
+         symcoll : psymcoll;
+         procdefcoll : pprocdefcoll;
+         i : longint;
+
+      begin
+         wurzel:=nil;
+         nextvirtnumber:=0;
+
+         has_constructor:=false;
+         has_virtual_method:=false;
+
+         { generates a tree of all used methods }
+         do_genvmt(_class);
+
+         if has_virtual_method and not(has_constructor) then
+            Message1(parser_w_virtual_without_constructor,_class^.name^);
+
+
+         { generates the VMT }
+
+         { walk trough all numbers for virtual methods and search }
+         { the method                                             }
+         for i:=0 to nextvirtnumber-1 do
+           begin
+              symcoll:=wurzel;
+
+              { walk trough all symbols }
+              while assigned(symcoll) do
+                begin
+
+                   { walk trough all methods }
+                   procdefcoll:=symcoll^.data;
+                   while assigned(procdefcoll) do
+                     begin
+                        { writes the addresses to the VMT }
+                        { but only this which are declared as virtual }
+                        if procdefcoll^.data^.extnumber=i then
+                          begin
+                             if (procdefcoll^.data^.options and povirtualmethod)<>0 then
+                               begin
+                                  { if a method is abstract, then is also the }
+                                  { class abstract and it's not allow to      }
+                                  { generates an instance                     }
+                                  if (procdefcoll^.data^.options and poabstractmethod)<>0 then
+                                    begin
+                                       _class^.options:=_class^.options or oo_is_abstract;
+                                       datasegment^.concat(new(pai_const_symbol,
+                                         init('FPC_ABSTRACTERROR')));
+                                    end
+                                  else
+                                    begin
+                                      datasegment^.concat(new(pai_const_symbol,
+                                        init(procdefcoll^.data^.mangledname)));
+                                      maybe_concat_external(procdefcoll^.data^.owner,
+                                        procdefcoll^.data^.mangledname);
+                                    end;
+                               end;
+                          end;
+                        procdefcoll:=procdefcoll^.next;
+                     end;
+                   symcoll:=symcoll^.next;
+                end;
+           end;
+         { disposes the above generated tree }
+         symcoll:=wurzel;
+         while assigned(symcoll) do
+           begin
+              wurzel:=symcoll^.next;
+              stringdispose(symcoll^.name);
+              procdefcoll:=symcoll^.data;
+              while assigned(procdefcoll) do
+                begin
+                   symcoll^.data:=procdefcoll^.next;
+                   dispose(procdefcoll);
+                   procdefcoll:=symcoll^.data;
+                end;
+              dispose(symcoll);
+              symcoll:=wurzel;
+           end;
+      end;
+
+
+end.
+{
+  $Log$
+  Revision 1.1  1999-03-24 23:17:00  peter
+    * fixed bugs 212,222,225,227,229,231,233
+
+}

compiler/hcodegen.pas

@@ -25,7 +25,9 @@ unit hcodegen;
   interface
 
     uses
-      verbose,aasm,tree,symtable,cobjects
+      cobjects,
+      tokens,verbose,
+      aasm,symtable
 {$ifdef i386}
 {$ifdef ag386bin}
       ,i386base
@@ -139,17 +141,8 @@ unit hcodegen;
        { save the size of pushed parameter, needed for aligning }
        pushedparasize : longint;
 
-{$ifdef OLDHIGH}
-       { this is for open arrays and strings        }
-       { but be careful, this data is in the        }
-       { generated code destroyed quick, and also   }
-       { the next call of secondload destroys this  }
-       { data                                       }
-       { So be careful using the informations       }
-       { provided by this variables                 }
-       highframepointer : tregister;
-       highoffset : longint;
-{$endif}
+       make_const_global : boolean;
+       temptoremove : plinkedlist;
 
     { message calls with codegenerror support }
     procedure cgmessage(const t : tmsgconst);
@@ -157,6 +150,8 @@ unit hcodegen;
     procedure cgmessage2(const t : tmsgconst;const s1,s2 : string);
     procedure cgmessage3(const t : tmsgconst;const s1,s2,s3 : string);
 
+    { helpers }
+    procedure maybe_concat_external(symt : psymtable;const name : string);
 
     { initialize respectively terminates the code generator }
     { for a new module or procedure                         }
@@ -165,21 +160,11 @@ unit hcodegen;
     procedure codegen_newmodule;
     procedure codegen_newprocedure;
 
-    { counts the labels }
-    function case_count_labels(root : pcaserecord) : longint;
-    { searches the highest label }
-    function case_get_max(root : pcaserecord) : longint;
-    { searches the lowest label }
-    function case_get_min(root : pcaserecord) : longint;
-
-    var
-       make_const_global : boolean;
-       temptoremove : plinkedlist;
 
 implementation
 
      uses
-        systems,comphook,globals,files,strings;
+        systems,globals,files,strings;
 
 {*****************************************************************************
             override the message calls to set codegenerror
@@ -191,9 +176,9 @@ implementation
       begin
          if not(codegenerror) then
            begin
-              olderrorcount:=status.errorcount;
+              olderrorcount:=Errorcount;
               verbose.Message(t);
-              codegenerror:=olderrorcount<>status.errorcount;
+              codegenerror:=olderrorcount<>Errorcount;
            end;
       end;
 
@@ -203,9 +188,9 @@ implementation
       begin
          if not(codegenerror) then
            begin
-              olderrorcount:=status.errorcount;
+              olderrorcount:=Errorcount;
               verbose.Message1(t,s);
-              codegenerror:=olderrorcount<>status.errorcount;
+              codegenerror:=olderrorcount<>Errorcount;
            end;
       end;
 
@@ -215,9 +200,9 @@ implementation
       begin
          if not(codegenerror) then
            begin
-              olderrorcount:=status.errorcount;
+              olderrorcount:=Errorcount;
               verbose.Message2(t,s1,s2);
-              codegenerror:=olderrorcount<>status.errorcount;
+              codegenerror:=olderrorcount<>Errorcount;
            end;
       end;
 
@@ -227,13 +212,28 @@ implementation
       begin
          if not(codegenerror) then
            begin
-              olderrorcount:=status.errorcount;
+              olderrorcount:=Errorcount;
               verbose.Message3(t,s1,s2,s3);
-              codegenerror:=olderrorcount<>status.errorcount;
+              codegenerror:=olderrorcount<>Errorcount;
            end;
       end;
 
 
+{*****************************************************************************
+                                    Helpers
+*****************************************************************************}
+
+    procedure maybe_concat_external(symt : psymtable;const name : string);
+      begin
+         if (symt^.symtabletype=unitsymtable) or
+            ((symt^.symtabletype in [recordsymtable,objectsymtable]) and
+             (symt^.defowner^.owner^.symtabletype=unitsymtable)) or
+            ((symt^.symtabletype=withsymtable) and
+             (symt^.defowner^.owner^.symtabletype=unitsymtable)) then
+           concat_external(name,EXT_NEAR);
+      end;
+
+
 {*****************************************************************************
          initialize/terminate the codegen for procedure and modules
 *****************************************************************************}
@@ -305,52 +305,6 @@ implementation
       end;
 
 
-{*****************************************************************************
-                              Case Helpers
-*****************************************************************************}
-
-    function case_count_labels(root : pcaserecord) : longint;
-      var
-         _l : longint;
-
-      procedure count(p : pcaserecord);
-        begin
-           inc(_l);
-           if assigned(p^.less) then
-             count(p^.less);
-           if assigned(p^.greater) then
-             count(p^.greater);
-        end;
-
-      begin
-         _l:=0;
-         count(root);
-         case_count_labels:=_l;
-      end;
-
-
-    function case_get_max(root : pcaserecord) : longint;
-      var
-         hp : pcaserecord;
-      begin
-         hp:=root;
-         while assigned(hp^.greater) do
-           hp:=hp^.greater;
-         case_get_max:=hp^._high;
-      end;
-
-
-    function case_get_min(root : pcaserecord) : longint;
-      var
-         hp : pcaserecord;
-      begin
-         hp:=root;
-         while assigned(hp^.less) do
-           hp:=hp^.less;
-         case_get_min:=hp^._low;
-      end;
-
-
 {*****************************************************************************
                               TTempToDestroy
 *****************************************************************************}
@@ -366,7 +320,10 @@ end.
 
 {
   $Log$
-  Revision 1.27  1999-02-25 21:02:37  peter
+  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
     * ag386bin updates
     + coff writer
 

compiler/htypechk.pas

@@ -29,6 +29,7 @@ interface
     const
     { firstcallparan without varspez we don't count the ref }
        count_ref : boolean = true;
+       get_para_resulttype : boolean = false;
        allow_array_constructor : boolean = false;
 
 
@@ -55,7 +56,7 @@ implementation
     uses
        globtype,systems,tokens,
        cobjects,verbose,globals,
-       aasm,types,
+       types,
        hcodegen;
 
 {****************************************************************************
@@ -649,7 +650,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.18  1999-03-06 17:25:19  peter
+  Revision 1.19  1999-03-24 23:17:02  peter
+    * fixed bugs 212,222,225,227,229,231,233
+
+  Revision 1.18  1999/03/06 17:25:19  peter
     * moved comp<->real warning so it doesn't occure everytime that
       isconvertable is called with
 

compiler/msgidx.inc

@@ -419,6 +419,8 @@ type tmsgconst=(
   assem_f_assembler_output_not_supported,
   assem_e_unsupported_symbol_type,
   assem_e_cannot_index_relative_var,
+  assem_h_direct_global_to_mangled,
+  assem_w_direct_global_is_overloaded_func,
   exec_w_source_os_redefined,
   exec_i_assembling_pipe,
   exec_d_cant_create_asmfile,

compiler/msgtxt.inc

@@ -434,35 +434,37 @@ const msgtxt : array[0..00100,1..240] of char=(
   '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+
-  'W_Source operatin','g system redefined'#000+
+  'H_$1 translated t','o $2'#000+
+  'W_$1 is associated to an overloaded function'#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 while asse','mbling 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 not foun','d, 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+
-  'I_Closing script $1'#000+
-  'W_resource compiler not found, switching to extern','al mode'#000+
+  'I_C','losing script $1'#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 uniniti','alized 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+
@@ -470,199 +472,199 @@ const msgtxt : array[0..00100,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 at the b','egin)'#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 entry: $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 compiling ','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 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 and asm are older than ','ppufile'#000+
   'U_Recompiling unit, obj is older than asm'#000+
-  'U_Parsing interfa','ce of $1'#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_DEF file can be created only for OS/2'#000+
-  'E_nested response files are not suppor','ted'#000+
+  'W_DEF file ','can be created only for OS/2'#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+
-  'N_Reading further options from $1'#000+
+  'N_Reading further options fr','om $1'#000+
   'W_Target is already set to: $1'#000+
-  'W_Shared libs not supported on',' DOS platform, reverting to static'#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+
+  'W_Debug information generation is not supported by this e','xecutable'#000+
   'H_Try recompiling with -dGDB'#000+
-  'W_You are using the obsolete',' switch $1'#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+
   #000+
-  'Compiler Date  : $FPCDATE'#000+
+  'Compiler Date  : $F','PCDATE'#000+
   'Compiler Target: $FPCTARGET'#000+
   #000+
-  'This program comes under the GN','U General Public Licence'#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+
-  '**1a_the compiler does','n'#039't delete the generated assembler file'#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+
   '**1B_build all modules'#000+
-  '**1C_code generation options'#000+
+  '**1C','_code generation options'#000+
   '3*2CD_create dynamic library'#000+
-  '**2Ch<n>_<n> ','bytes heap (between 1023 and 67107840)'#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+
-  '**2Cs<n>_set stack size to <n>'#000+
+  '**2Cs<n>_set stack size to ','<n>'#000+
   '**2Ct_stack checking'#000+
   '3*2CS_create static library'#000+
-  '3*2Cx_use smar','tlinking'#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_same as -Cn'#000+
-  '**1F_set file names and paths'#000+
-  '**2FD<x>_sets the directory where to search ','for compiler utilities'#000+
+  '**1F_se','t file names and paths'#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+
-  '**2Fl<x>_adds <x> to library path'#000+
+  '**2Fl<x>_adds <x','> to library path'#000+
   '*L2FL<x>_uses <x> as dynamic linker'#000+
-  '**2Fo<x>_adds',' <x> to object path'#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+
-  '*g1g_generate debugger information'#000+
+  '*g1g_generate debugger informatio','n'#000+
   '*g2gg_use gsym'#000+
   '*g2gd_use dbx'#000+
   '*g2gh_use heap trace unit'#000+
-  '**1i_infor','mation'#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+
-  '**2iTP_return target processor'#000+
+  '**2iTP_return target processor',#000+
   '**1I<x>_adds <x> to include path'#000+
   '**1k<x>_Pass <x> to the linker'#000+
-  '**','1l_write logo'#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+
+  '*L1P_use pipes instead ','of creating temporary assembler files'#000+
   '**1S_syntax options'#000+
-  '**2S2_swi','tch some Delphi 2 extensions on'#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+
-  '**2Sg_allow LABEL and GOTO'#000+
+  '**2Sg_allow ','LABEL and GOTO'#000+
   '**2Sh_Use ansistrings'#000+
-  '**2Si_support C++ stlyed INLIN','E'#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+
+  '**2Ss_constructor name 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+
+  '**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+
   '**2Us_compile a system unit'#000+
-  '**1v<x>_Be verbose. <x> is a combination of the following letters :'#000+
-  '**2*_e : Show ','errors (default)       d : Show debug info'#000+
+  '**1v<x>_Be verb','ose. <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 : Show defined macros'#000+
-  '**2*_i : Show gen','eral info           p : Show compiled procedures'#000+
+  '**2*_h : Sh','ow 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 procedure          r : Rhide/GCC compatibili','ty mod'+
-  'e'#000+
+  '**2*_a : Show everything             0 : Show nothing (except err','ors'+
+  ')'#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_DYNAMIC)'#000+
-  '**2Xs_strip all symbols from ex','ecutable'#000+
+  '**2XD_link with dynamic l','ibraries (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*2Anasmcoff_coff file using Nasm'#000+
+  '3*2Anasmcoff_coff fil','e using Nasm'#000+
   '3*2Anasmelf_elf32 (linux) file using Nasm'#000+
-  '3*2Anasmobj_','obj 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*2Rintel_read Intel style assembler'#000+
-  '3*2Rdirect_copy assembler text directly to asse','mbler file'#000+
+  '3*2Rintel_read In','tel style assembler'#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*2O1_level 1 optimizations (quick ','optimizations)'#000+
+  '3*2Ou_enable unc','ertain 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*3Op1_set target processor to 386/486'#000+
+  '3*3Op1_set target processor to 386/','486'#000+
   '3*3Op2_set target processor to Pentium/PentiumMMX (tm)'#000+
-  '3*3Op3_s','et target processor to PPro/PII/c6x86/K6 (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*2TGO32V2_version 2 of DJ Delorie DOS extender',#000+
   '3*2TLINUX_Linux'#000+
   '3*2TOS2_OS/2 2.x'#000+
   '3*2TWin32_Windows 32 Bit'#000+
-  '6*1A<x>_','output format'#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*1O_optimizations'#000+
-  '6*2Oa_turn on the optimizer'#000+
+  '6*2Oa_turn on',' the optimizer'#000+
   '6*2Og_generate smaller code'#000+
-  '6*2OG_generate faster co','de (default)'#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*1T<x>_Target operating system'#000+
+  '6*1T<x>_T','arget operating system'#000+
   '6*2TAMIGA_Commodore Amiga'#000+
-  '6*2TATARI_Atari ST','/STe/TT'#000+
+  '6*2TATARI_Atari ST/STe/TT'#000+
   '6*2TMACOS_Macintosh m68k'#000+
   '6*2TLINUX_Linux-68k'#000+
   '**1*_'#000+

compiler/parser.pas

@@ -46,7 +46,7 @@ unit parser;
 
     uses
       globtype,version,tokens,systems,
-      cobjects,comphook,globals,verbose,
+      cobjects,globals,verbose,
       symtable,files,aasm,hcodegen,
       assemble,link,script,gendef,
 {$ifdef BrowserLog}
@@ -452,7 +452,10 @@ unit parser;
 end.
 {
   $Log$
-  Revision 1.69  1999-02-25 21:02:40  peter
+  Revision 1.70  1999-03-24 23:17:10  peter
+    * fixed bugs 212,222,225,227,229,231,233
+
+  Revision 1.69  1999/02/25 21:02:40  peter
     * ag386bin updates
     + coff writer
 

compiler/pass_2.pas

@@ -42,7 +42,7 @@ implementation
 
    uses
      globtype,systems,
-     cobjects,verbose,comphook,globals,files,
+     cobjects,comphook,verbose,globals,files,
      symtable,types,aasm,scanner,
      pass_1,hcodegen,temp_gen
 {$ifdef GDB}
@@ -500,7 +500,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.15  1999-02-22 02:15:25  peter
+  Revision 1.16  1999-03-24 23:17:11  peter
+    * fixed bugs 212,222,225,227,229,231,233
+
+  Revision 1.15  1999/02/22 02:15:25  peter
     * updates for ag386bin
 
   Revision 1.14  1999/01/23 23:29:37  florian

compiler/pdecl.pas

@@ -56,7 +56,7 @@ unit pdecl;
 
     uses
        cobjects,scanner,aasm,tree,pass_1,strings,
-       files,types,hcodegen,verbose,systems,import
+       files,types,verbose,systems,import
 {$ifdef GDB}
        ,gdb
 {$endif GDB}
@@ -73,6 +73,8 @@ unit pdecl;
 {$ifdef m68k}
        ,m68k
 {$endif}
+       { codegen }
+       ,hcodegen,hcgdata
        ;
 
     function read_type(const name : stringid) : pdef;forward;
@@ -121,8 +123,7 @@ unit pdecl;
          old_block_type : tblock_type;
          ps : pconstset;
          pd : pbestreal;
-         sp : pstring;
-         l  : longint;
+         sp : pchar;
       begin
          consume(_CONST);
          old_block_type:=block_type;
@@ -143,52 +144,38 @@ unit pdecl;
                       ordconstn:
                         begin
                            if is_constintnode(p) then
-                             symtablestack^.insert(new(pconstsym,init(name,constint,p^.value,nil)))
+                             symtablestack^.insert(new(pconstsym,init_def(name,constint,p^.value,nil)))
                            else if is_constcharnode(p) then
-                             symtablestack^.insert(new(pconstsym,init(name,constchar,p^.value,nil)))
+                             symtablestack^.insert(new(pconstsym,init_def(name,constchar,p^.value,nil)))
                            else if is_constboolnode(p) then
-                             symtablestack^.insert(new(pconstsym,init(name,constbool,p^.value,nil)))
+                             symtablestack^.insert(new(pconstsym,init_def(name,constbool,p^.value,nil)))
                            else if p^.resulttype^.deftype=enumdef then
-                             symtablestack^.insert(new(pconstsym,init(name,constord,p^.value,p^.resulttype)))
+                             symtablestack^.insert(new(pconstsym,init_def(name,constord,p^.value,p^.resulttype)))
                            else if p^.resulttype^.deftype=pointerdef then
-                             symtablestack^.insert(new(pconstsym,init(name,constord,p^.value,p^.resulttype)))
+                             symtablestack^.insert(new(pconstsym,init_def(name,constord,p^.value,p^.resulttype)))
                            else internalerror(111);
                         end;
                       stringconstn:
                         begin
-                           if p^.length>255 then
-                            l:=255
-                           else
-                            l:=p^.length;
-                           { value_str is disposed with p so I need a copy }
-                           getmem(sp,l+1);
-                           move(p^.value_str^,sp^[1],l);
-                           {$ifndef TP}
-                             {$ifopt H+}
-                               setlength(sp^,l);
-                             {$else}
-                               sp^[0]:=chr(l);
-                             {$endif}
-                           {$else}
-                             sp^[0]:=chr(l);
-                           {$endif}
-                           symtablestack^.insert(new(pconstsym,init(name,conststring,longint(sp),nil)));
+                           getmem(sp,p^.length+1);
+                           move(p^.value_str^,sp^,p^.length+1);
+                           symtablestack^.insert(new(pconstsym,init_string(name,conststring,sp,p^.length)));
                         end;
                       realconstn :
                         begin
                            new(pd);
                            pd^:=p^.value_real;
-                           symtablestack^.insert(new(pconstsym,init(name,constreal,longint(pd),nil)));
+                           symtablestack^.insert(new(pconstsym,init(name,constreal,longint(pd))));
                         end;
                       setconstn :
                         begin
                           new(ps);
                           ps^:=p^.value_set^;
-                          symtablestack^.insert(new(pconstsym,init(name,constset,longint(ps),p^.resulttype)));
+                          symtablestack^.insert(new(pconstsym,init_def(name,constset,longint(ps),p^.resulttype)));
                         end;
                       niln :
                         begin
-                          symtablestack^.insert(new(pconstsym,init(name,constnil,0,p^.resulttype)));
+                          symtablestack^.insert(new(pconstsym,init_def(name,constnil,0,p^.resulttype)));
                         end;
                       else
                         Message(cg_e_illegal_expression);
@@ -644,7 +631,8 @@ unit pdecl;
                    s:=pattern;
                    consume(ID);
                 end;
-              if srsym^.typ<>typesym then
+              if not assigned(srsym) or
+                 (srsym^.typ<>typesym) then
                 begin
                    Message(type_e_type_id_expected);
                    lasttypesym:=ptypesym(srsym);
@@ -915,8 +903,26 @@ unit pdecl;
                      consume(_READ);
                      sym:=search_class_member(aktclass,pattern);
                      if not(assigned(sym)) then
-                       Message1(sym_e_unknown_id,pattern)
+                       begin
+                         Message1(sym_e_unknown_id,pattern);
+                         consume(ID);
+                       end
                      else
+                       begin
+                          consume(ID);
+                          if (token=POINT) and
+                             ((sym^.typ=varsym) and (pvarsym(sym)^.definition^.deftype=recorddef)) then
+                           begin
+                             consume(POINT);
+                             getsymonlyin(precdef(pvarsym(sym)^.definition)^.symtable,pattern);
+                             if not assigned(srsym) then
+                               Message1(sym_e_illegal_field,pattern);
+                             sym:=srsym;
+                             consume(ID);
+                           end;
+                       end;
+
+                     if assigned(sym) then
                        begin
                           { varsym aren't allowed for an indexed property
                             or an property with parameters }
@@ -945,15 +951,32 @@ unit pdecl;
                             end;
                           p^.readaccesssym:=sym;
                        end;
-                     consume(ID);
                   end;
                 if (idtoken=_WRITE) then
                   begin
                      consume(_WRITE);
                      sym:=search_class_member(aktclass,pattern);
                      if not(assigned(sym)) then
-                       Message1(sym_e_unknown_id,pattern)
+                       begin
+                         Message1(sym_e_unknown_id,pattern);
+                         consume(ID);
+                       end
                      else
+                       begin
+                          consume(ID);
+                          if (token=POINT) and
+                             ((sym^.typ=varsym) and (pvarsym(sym)^.definition^.deftype=recorddef)) then
+                           begin
+                             consume(POINT);
+                             getsymonlyin(precdef(pvarsym(sym)^.definition)^.symtable,pattern);
+                             if not assigned(srsym) then
+                               Message1(sym_e_illegal_field,pattern);
+                             sym:=srsym;
+                             consume(ID);
+                           end;
+                       end;
+
+                     if assigned(sym) then
                        begin
                           if ((sym^.typ=varsym) and
                              assigned(propertyparas)) or
@@ -981,7 +1004,6 @@ unit pdecl;
                             end;
                           p^.writeaccesssym:=sym;
                        end;
-                     consume(ID);
                   end;
                 if (idtoken=_STORED) then
                   begin
@@ -2218,7 +2240,10 @@ unit pdecl;
 end.
 {
   $Log$
-  Revision 1.103  1999-03-22 22:10:25  florian
+  Revision 1.104  1999-03-24 23:17:13  peter
+    * fixed bugs 212,222,225,227,229,231,233
+
+  Revision 1.103  1999/03/22 22:10:25  florian
     * typecanbeforward wasn't always restored in object_dec which
       sometimes caused strange effects
 

compiler/pexpr.pas

@@ -88,7 +88,6 @@ unit pexpr;
            begin
               p1:=comp_expr(true);
               p2:=gencallparanode(p1,p2);
-
               { it's for the str(l:5,s); }
               if _colon and (token=COLON) then
                 begin
@@ -813,6 +812,9 @@ unit pexpr;
          ---------------------------------------------}
 
        procedure factor_read_id;
+         var
+           pc : pchar;
+           len : longint;
          begin
            { allow post fix operators }
            again:=true;
@@ -1014,16 +1016,32 @@ unit pexpr;
                             end;
                  constsym : begin
                               case pconstsym(srsym)^.consttype of
-                               constint : p1:=genordinalconstnode(pconstsym(srsym)^.value,s32bitdef);
-                            conststring : p1:=genstringconstnode(pstring(pconstsym(srsym)^.value)^);
-                              constchar : p1:=genordinalconstnode(pconstsym(srsym)^.value,cchardef);
-                              constreal : p1:=genrealconstnode(pbestreal(pconstsym(srsym)^.value)^);
-                              constbool : p1:=genordinalconstnode(pconstsym(srsym)^.value,booldef);
-                               constset : p1:=gensetconstnode(pconstset(pconstsym(srsym)^.value),
-                                                psetdef(pconstsym(srsym)^.definition));
-                               constord : p1:=genordinalconstnode(pconstsym(srsym)^.value,
-                                                pconstsym(srsym)^.definition);
-                               constnil : p1:=genzeronode(niln);
+                                constint :
+                                  p1:=genordinalconstnode(pconstsym(srsym)^.value,s32bitdef);
+                                conststring :
+                                  begin
+                                    len:=pconstsym(srsym)^.len;
+                                    if not(cs_ansistrings in aktlocalswitches) and (len>255) then
+                                     len:=255;
+                                    getmem(pc,len+1);
+                                    move(pchar(pconstsym(srsym)^.value)^,pc^,len);
+                                    pc[len]:=#0;
+                                    p1:=genpcharconstnode(pc,len);
+                                  end;
+                                constchar :
+                                  p1:=genordinalconstnode(pconstsym(srsym)^.value,cchardef);
+                                constreal :
+                                  p1:=genrealconstnode(pbestreal(pconstsym(srsym)^.value)^);
+                                constbool :
+                                  p1:=genordinalconstnode(pconstsym(srsym)^.value,booldef);
+                                constset :
+                                  p1:=gensetconstnode(pconstset(pconstsym(srsym)^.value),
+                                        psetdef(pconstsym(srsym)^.definition));
+                                constord :
+                                  p1:=genordinalconstnode(pconstsym(srsym)^.value,
+                                        pconstsym(srsym)^.definition);
+                                constnil :
+                                  p1:=genzeronode(niln);
                               end;
                               pd:=p1^.resulttype;
                             end;
@@ -1959,7 +1977,10 @@ unit pexpr;
 end.
 {
   $Log$
-  Revision 1.87  1999-03-16 17:52:52  jonas
+  Revision 1.88  1999-03-24 23:17:15  peter
+    * fixed bugs 212,222,225,227,229,231,233
+
+  Revision 1.87  1999/03/16 17:52:52  jonas
     * changes for internal Val code (do a "make cycle OPT=-dvalintern" to test)
     * in cgi386inl: also range checking for subrange types (compile with "-dreadrangecheck")
     * in cgai386: also small fixes to emitrangecheck

compiler/pmodules.pas

@@ -738,7 +738,7 @@ unit pmodules;
 
       function is_assembler_generated:boolean;
       begin
-        is_assembler_generated:=(status.errorcount=0) and
+        is_assembler_generated:=(Errorcount=0) and
           not(
           codesegment^.empty and
           datasegment^.empty and
@@ -884,9 +884,9 @@ unit pmodules;
          read_interface_declarations;
 
          { leave when we got an error }
-         if (status.errorcount>0) and not status.skip_error then
+         if (Errorcount>0) and not status.skip_error then
           begin
-            Message1(unit_f_errors_in_unit,tostr(status.errorcount));
+            Message1(unit_f_errors_in_unit,tostr(Errorcount));
             status.skip_error:=true;
             exit;
           end;
@@ -1001,7 +1001,7 @@ unit pmodules;
          { absence does not matter here !! }
          aktprocsym^.definition^.forwarddef:=false;
          { test static symtable }
-         if (status.errorcount=0) then
+         if (Errorcount=0) then
            st^.allsymbolsused;
 
          { size of the static data }
@@ -1033,7 +1033,7 @@ unit pmodules;
          reset_global_defs;
 
          { tests, if all (interface) forwards are resolved }
-         if (status.errorcount=0) then
+         if (Errorcount=0) then
            symtablestack^.check_forwards;
 
          { now we have a correct unit, change the symtable type }
@@ -1044,9 +1044,9 @@ unit pmodules;
 {$endif GDB}
 
          { leave when we got an error }
-         if (status.errorcount>0) and not status.skip_error then
+         if (Errorcount>0) and not status.skip_error then
           begin
-            Message1(unit_f_errors_in_unit,tostr(status.errorcount));
+            Message1(unit_f_errors_in_unit,tostr(Errorcount));
             status.skip_error:=true;
             exit;
           end;
@@ -1063,7 +1063,7 @@ unit pmodules;
          if cs_local_browser in aktmoduleswitches then
            current_module^.localsymtable:=refsymtable;
          { Write out the ppufile }
-         if (status.errorcount=0) then
+         if (Errorcount=0) then
            writeunitas(current_module^.ppufilename^,punitsymtable(symtablestack));
 
           { must be done only after local symtable ref stores !! }
@@ -1213,9 +1213,9 @@ unit pmodules;
          write_gdb_info;
 {$endIf Def New_GDB}
          { leave when we got an error }
-         if (status.errorcount>0) and not status.skip_error then
+         if (Errorcount>0) and not status.skip_error then
           begin
-            Message1(unit_f_errors_in_unit,tostr(status.errorcount));
+            Message1(unit_f_errors_in_unit,tostr(Errorcount));
             status.skip_error:=true;
             exit;
           end;
@@ -1259,7 +1259,10 @@ unit pmodules;
 end.
 {
   $Log$
-  Revision 1.103  1999-03-18 20:30:46  peter
+  Revision 1.104  1999-03-24 23:17:17  peter
+    * fixed bugs 212,222,225,227,229,231,233
+
+  Revision 1.103  1999/03/18 20:30:46  peter
     + .a writer
 
   Revision 1.102  1999/03/16 21:07:25  peter

compiler/ptconst.pas

@@ -36,7 +36,7 @@ unit ptconst;
     uses
        globtype,systems,tokens,
        cobjects,globals,scanner,aasm,tree,pass_1,
-       hcodegen,types,verbose
+       types,verbose
        { parser specific stuff }
        ,pbase,pexpr
        { processor specific stuff }
@@ -50,8 +50,11 @@ unit ptconst;
 {$ifdef m68k}
        ,m68k
 {$endif}
+       { codegen }
+       ,hcodegen,hcgdata
        ;
 
+
     { this procedure reads typed constants }
     procedure readtypedconst(def : pdef;sym : ptypedconstsym);
 
@@ -704,7 +707,10 @@ unit ptconst;
 end.
 {
   $Log$
-  Revision 1.38  1999-02-25 21:02:45  peter
+  Revision 1.39  1999-03-24 23:17:21  peter
+    * fixed bugs 212,222,225,227,229,231,233
+
+  Revision 1.38  1999/02/25 21:02:45  peter
     * ag386bin updates
     + coff writer
 

compiler/ra386dir.pas

@@ -32,7 +32,7 @@ unit Ra386dir;
   implementation
 
      uses
-        comphook,files,hcodegen,globals,scanner,aasm
+        files,hcodegen,globals,scanner,aasm
 {$ifdef Ag386Bin}
         ,i386base,i386asm
 {$else}
@@ -169,7 +169,10 @@ unit Ra386dir;
                                              else
                                              if (pos('MOV',upper(s)) > 0) and (pvarsym(sym)^.is_valid=0) then
                                               Message1(sym_n_uninitialized_local_variable,hs);
-                                             hs:='-'+tostr(pvarsym(sym)^.address)+'('+att_reg2str[procinfo.framepointer]+')';
+                                             if ((pvarsym(sym)^.var_options and vo_is_external)<>0) then
+                                               hs:=pvarsym(sym)^.mangledname
+                                             else
+                                               hs:='-'+tostr(pvarsym(sym)^.address)+'('+att_reg2str[procinfo.framepointer]+')';
                                              end
                                            else
                                            { call to local function }
@@ -212,20 +215,18 @@ unit Ra386dir;
                                              begin
                                                 if (sym^.typ = varsym) or (sym^.typ = typedconstsym) then
                                                   begin
-                                                     Do_comment(V_Warning,hs+' translated to '+sym^.mangledname);
+                                                     Message2(assem_h_direct_global_to_mangled,hs,sym^.mangledname);
                                                      hs:=sym^.mangledname;
                                                      if sym^.typ=varsym then
                                                        inc(pvarsym(sym)^.refs);
                                                   end;
                                                 { procs can be called or the address can be loaded }
-                                                if (sym^.typ=procsym) and ((pos('CALL',upper(s))>0) or
-                                                   (pos('LEA',upper(s))>0)) then
+                                                if (sym^.typ=procsym) and
+                                                   ((pos('CALL',upper(s))>0) or (pos('LEA',upper(s))>0)) then
                                                   begin
                                                      if assigned(pprocsym(sym)^.definition^.nextoverloaded) then
-                                                       begin
-                                                          Do_comment(V_Warning,hs+' is associated to an overloaded function');
-                                                       end;
-                                                     Do_comment(V_Warning,hs+' translated to '+sym^.mangledname);
+                                                       Message1(assem_w_direct_global_is_overloaded_func,hs);
+                                                     Message2(assem_h_direct_global_to_mangled,hs,sym^.mangledname);
                                                      hs:=sym^.mangledname;
                                                   end;
                                              end
@@ -242,11 +243,9 @@ unit Ra386dir;
                                              begin
                                                 if assigned(procinfo.retdef) and
                                                   (procinfo.retdef<>pdef(voiddef)) then
-                                                  begin
-                                                  hs:=retstr;
-                                                  end
+                                                  hs:=retstr
                                                 else
-                                                 Message(assem_w_void_function);
+                                                  Message(assem_w_void_function);
                                              end
                                            else if upper(hs)='__OLDEBP' then
                                              begin
@@ -257,7 +256,7 @@ unit Ra386dir;
                                                     +'('+att_reg2str[procinfo.framepointer]+')'
                                                 else
                                                   Message(assem_e_cannot_use___OLDEBP_outside_nested_procedure);
-                                                end;
+                                             end;
                                            end;
                                         end;
                                    end;
@@ -296,7 +295,10 @@ unit Ra386dir;
 end.
 {
   $Log$
-  Revision 1.15  1999-03-01 13:22:26  pierre
+  Revision 1.16  1999-03-24 23:17:22  peter
+    * fixed bugs 212,222,225,227,229,231,233
+
+  Revision 1.15  1999/03/01 13:22:26  pierre
    * varsym refs incremented
 
   Revision 1.14  1999/02/22 02:15:36  peter

compiler/rautils.pas

@@ -1345,7 +1345,8 @@ end;
                     { that the variable is valid.                 }
                     pvarsym(sym)^.is_valid:=1;
                     inc(pvarsym(sym)^.refs);
-                    if pvarsym(sym)^.owner^.symtabletype=staticsymtable then
+                    if (pvarsym(sym)^.owner^.symtabletype=staticsymtable) or
+                       ((pvarsym(sym)^.var_options and vo_is_external)<>0) then
                      begin
                        instr.operands[operandnum].ref.symbol:=newasmsymbol(pvarsym(sym)^.mangledname);
                      end
@@ -1790,7 +1791,10 @@ end;
 end.
 {
   $Log$
-  Revision 1.6  1999-03-01 13:22:25  pierre
+  Revision 1.7  1999-03-24 23:17:23  peter
+    * fixed bugs 212,222,225,227,229,231,233
+
+  Revision 1.6  1999/03/01 13:22:25  pierre
    * varsym refs incremented
 
   Revision 1.5  1999/02/25 21:02:51  peter

compiler/scanner.pas

@@ -795,27 +795,33 @@ implementation
          found:=0;
          repeat
            case c of
-            #26 : Message(scan_f_end_of_file);
-            '{' : begin
-                    if comment_level=0 then
-                     found:=1;
-                    inc_comment_level;
-                  end;
-            '}' : begin
-                    dec_comment_level;
-                    found:=0;
-                  end;
-            '$' : begin
-                    if found=1 then
-                     found:=2;
-                  end;
-            '(' : begin
-                    readchar;
-                    if c='*' then
-                     skipoldtpcomment;
-                  end;
-           else
-            found:=0;
+             #26 :
+               Message(scan_f_end_of_file);
+             '{' :
+               begin
+                 if comment_level=0 then
+                  found:=1;
+                 inc_comment_level;
+               end;
+             '}' :
+               begin
+                 dec_comment_level;
+                 found:=0;
+               end;
+             '$' :
+               begin
+                 if found=1 then
+                  found:=2;
+               end;
+             '(' :
+               if (m_tp in aktmodeswitches) then
+                begin
+                  readchar;
+                  if c='*' then
+                  skipoldtpcomment;
+                end;
+             else
+                found:=0;
            end;
            c:=inputpointer^;
            if c=#0 then
@@ -1575,7 +1581,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.75  1999-03-16 21:00:27  peter
+  Revision 1.76  1999-03-24 23:17:24  peter
+    * fixed bugs 212,222,225,227,229,231,233
+
+  Revision 1.75  1999/03/16 21:00:27  peter
     * fixed old tp comment behaviour within directives
 
   Revision 1.74  1999/03/11 10:46:29  daniel

compiler/symsym.inc

@@ -409,7 +409,7 @@
          oldaktfilepos : tfileposinfo;
       begin
          { don't check if errors !! }
-         if status.errorcount>0 then
+         if Errorcount>0 then
            exit;
          pd:=definition;
          while assigned(pd) do
@@ -747,14 +747,14 @@
 
     procedure tfuncretsym.write;
       begin
-      
+
          (*
           Normally all references are
           transfered to the function symbol itself !! PM *)
          tsym.write;
          writedefref(funcretdef);
          writelong(address);
-         
+
          current_ppu^.writeentry(ibfuncretsym);
       end;
 
@@ -770,6 +770,30 @@
       end;
 {$endif GDB}
 
+    procedure tfuncretsym.insert_in_data;
+      var
+        l : longint;
+      begin
+        { allocate space in local if ret in acc or in fpu }
+        if ret_in_acc(procinfo.retdef) or (procinfo.retdef^.deftype=floatdef) then
+          begin
+             l:=funcretdef^.size;
+             inc(owner^.datasize,l);
+{$ifdef m68k}
+             { word alignment required for motorola }
+             if (l=1) then
+              inc(owner^.datasize,1)
+             else
+{$endif}
+             if (l>=4) and ((owner^.datasize and 3)<>0) then
+               inc(owner^.datasize,4-(owner^.datasize and 3))
+             else if (l>=2) and ((owner^.datasize and 1)<>0) then
+               inc(owner^.datasize,2-(owner^.datasize and 1));
+             address:=owner^.datasize;
+             procinfo.retoffset:=-owner^.datasize;
+          end;
+      end;
+
 
 {****************************************************************************
                                   TABSOLUTESYM
@@ -792,15 +816,18 @@
          abstyp:=absolutetyp(readbyte);
          absseg:=false;
          case abstyp of
-       tovar : begin
-                 asmname:=stringdup(readstring);
-                 ref:=srsym;
-               end;
-       toasm : asmname:=stringdup(readstring);
-      toaddr : begin
-                 address:=readlong;
-                 absseg:=boolean(readbyte);
-               end;
+           tovar :
+             begin
+               asmname:=stringdup(readstring);
+               ref:=srsym;
+             end;
+           toasm :
+             asmname:=stringdup(readstring);
+           toaddr :
+             begin
+               address:=readlong;
+               absseg:=boolean(readbyte);
+             end;
          end;
       end;
 
@@ -815,12 +842,15 @@
          writebyte(var_options and (not vo_regable));
          writebyte(byte(abstyp));
          case abstyp of
-           tovar : writestring(ref^.name);
-           toasm : writestring(asmname^);
-          toaddr : begin
-                     writelong(address);
-                     writebyte(byte(absseg));
-                   end;
+           tovar :
+             writestring(ref^.name);
+           toasm :
+             writestring(asmname^);
+           toaddr :
+             begin
+               writelong(address);
+               writebyte(byte(absseg));
+             end;
          end;
         current_ppu^.writeentry(ibabsolutesym);
       end;
@@ -846,9 +876,12 @@
     function tabsolutesym.mangledname : string;
       begin
          case abstyp of
-           tovar : mangledname:=ref^.mangledname;
-           toasm : mangledname:=asmname^;
-          toaddr : mangledname:='$'+tostr(address);
+           tovar :
+             mangledname:=ref^.mangledname;
+           toasm :
+             mangledname:=asmname^;
+           toaddr :
+             mangledname:='$'+tostr(address);
          else
            internalerror(10002);
          end;
@@ -890,17 +923,17 @@
          case p^.deftype of
            pointerdef,
            enumdef,
-           procvardef:
+           procvardef :
              var_options:=var_options or vo_regable;
-
-           orddef: case porddef(p)^.typ of
-                       u8bit,u16bit,u32bit,
-                       bool8bit,bool16bit,bool32bit,
-                       s8bit,s16bit,s32bit :
-                         var_options:=var_options or vo_regable;
-                     else
-                       var_options:=var_options and not vo_regable;
-                     end;
+           orddef :
+             case porddef(p)^.typ of
+               bool8bit,bool16bit,bool32bit,
+               u8bit,u16bit,u32bit,
+               s8bit,s16bit,s32bit :
+                 var_options:=var_options or vo_regable;
+               else
+                 var_options:=var_options and not vo_regable;
+             end;
            setdef:
              if psetdef(p)^.settype=smallset then
                var_options:=var_options or vo_regable;
@@ -989,15 +1022,17 @@
               exit;
            end;
          case owner^.symtabletype of
-           staticsymtable : if (cs_smartlink in aktmoduleswitches) then
-                              prefix:='_'+owner^.name^+'$$$_'
-                            else
-                              prefix:='_';
-             unitsymtable,
-           globalsymtable : prefix:='U_'+owner^.name^+'_';
+           staticsymtable :
+             if (cs_smartlink in aktmoduleswitches) then
+               prefix:='_'+owner^.name^+'$$$_'
+             else
+               prefix:='_';
+           unitsymtable,
+           globalsymtable :
+             prefix:='U_'+owner^.name^+'_';
            else
              Message(sym_e_invalid_call_tvarsymmangledname);
-           end;
+         end;
          mangledname:=prefix+name;
       end;
 
@@ -1017,35 +1052,17 @@
            begin
               case varspez of
                 vs_var :
-                  begin
-{$ifdef OLDHIGH}
-                    { open arrays push also the high valye }
-                    if is_open_array(definition) or
-                       is_open_string(definition) then
-                      getpushsize:=target_os.size_of_pointer+target_os.size_of_longint
-                    else
-{$endif}
-                      getpushsize:=target_os.size_of_pointer;
-                  end;
+                  getpushsize:=target_os.size_of_pointer;
                 vs_value,
                 vs_const :
                   begin
                     case definition^.deftype of
-{$ifndef OLDHIGH}
                       arraydef,
-{$endif OLDHIGH}
                       setdef,
                       stringdef,
                       recorddef,
                       objectdef :
                         getpushsize:=target_os.size_of_pointer;
-{$ifdef OLDHIGH}
-                      arraydef :
-                        if is_open_array(definition) then
-                          getpushsize:=target_os.size_of_pointer+target_os.size_of_longint
-                        else
-                          getpushsize:=target_os.size_of_pointer;
-{$endif OLDHIGH}
                       else
                         getpushsize:=definition^.size;
                     end;
@@ -1424,13 +1441,36 @@
                                   TCONSTSYM
 ****************************************************************************}
 
-    constructor tconstsym.init(const n : string;t : tconsttype;v : longint;def : pdef);
+    constructor tconstsym.init(const n : string;t : tconsttype;v : longint);
       begin
-         tsym.init(n);
+         inherited init(n);
          typ:=constsym;
-         definition:=def;
          consttype:=t;
          value:=v;
+         definition:=nil;
+         len:=0;
+      end;
+
+
+    constructor tconstsym.init_def(const n : string;t : tconsttype;v : longint;def : pdef);
+      begin
+         inherited init(n);
+         typ:=constsym;
+         consttype:=t;
+         value:=v;
+         definition:=def;
+         len:=0;
+      end;
+
+
+    constructor tconstsym.init_string(const n : string;t : tconsttype;str:pchar;l:longint);
+      begin
+         inherited init(n);
+         typ:=constsym;
+         consttype:=t;
+         value:=longint(str);
+         definition:=nil;
+         len:=l;
       end;
 
 
@@ -1443,28 +1483,36 @@
          typ:=constsym;
          consttype:=tconsttype(readbyte);
          case consttype of
-            constint,
+           constint,
            constbool,
            constchar : value:=readlong;
-            constord : begin
-                          definition:=readdefref;
-                          value:=readlong;
-                       end;
-         conststring : value:=longint(stringdup(readstring));
-           constreal : begin
-                         new(pd);
-                         pd^:=readreal;
-                         value:=longint(pd);
-                       end;
-            constset : begin
-                         definition:=readdefref;
-                         new(ps);
-                         readnormalset(ps^);
-                         value:=longint(ps);
-                       end;
-            constnil : ;
-         else
-           Message1(unit_f_ppu_invalid_entry,tostr(ord(consttype)));
+           constord :
+             begin
+               definition:=readdefref;
+               value:=readlong;
+             end;
+           conststring :
+             begin
+               len:=readlong;
+               getmem(pchar(value),len+1);
+               current_ppu^.getdata(pchar(value)^,len);
+             end;
+           constreal :
+             begin
+               new(pd);
+               pd^:=readreal;
+               value:=longint(pd);
+             end;
+           constset :
+             begin
+               definition:=readdefref;
+               new(ps);
+               readnormalset(ps^);
+               value:=longint(ps);
+             end;
+           constnil : ;
+           else
+             Message1(unit_f_ppu_invalid_entry,tostr(ord(consttype)));
          end;
       end;
 
@@ -1472,9 +1520,12 @@
     destructor tconstsym.done;
       begin
         case consttype of
-         conststring : stringdispose(pstring(value));
-           constreal : dispose(pbestreal(value));
-            constset : dispose(pnormalset(value));
+          conststring :
+            freemem(pchar(value),len+1);
+          constreal :
+            dispose(pbestreal(value));
+          constset :
+            dispose(pnormalset(value));
         end;
         inherited done;
       end;
@@ -1498,20 +1549,28 @@
          tsym.write;
          writebyte(byte(consttype));
          case consttype of
-            constnil : ;
+           constnil : ;
            constint,
            constbool,
-           constchar : writelong(value);
-            constord : begin
-                         writedefref(definition);
-                         writelong(value);
-                       end;
-         conststring : writestring(pstring(value)^);
-           constreal : writereal(pbestreal(value)^);
-            constset : begin
-                         writedefref(definition);
-                         writenormalset(pointer(value)^);
-                       end;
+           constchar :
+             writelong(value);
+           constord :
+             begin
+               writedefref(definition);
+               writelong(value);
+             end;
+           conststring :
+             begin
+               writelong(len);
+               current_ppu^.putdata(pchar(value)^,len);
+             end;
+           constreal :
+             writereal(pbestreal(value)^);
+           constset :
+             begin
+               writedefref(definition);
+               writenormalset(pointer(value)^);
+             end;
          else
            internalerror(13);
          end;
@@ -1811,7 +1870,10 @@
 
 {
   $Log$
-  Revision 1.74  1999-02-23 18:29:27  pierre
+  Revision 1.75  1999-03-24 23:17:27  peter
+    * fixed bugs 212,222,225,227,229,231,233
+
+  Revision 1.74  1999/02/23 18:29:27  pierre
     * win32 compilation error fix
     + some work for local browser (not cl=omplete yet)
 

compiler/symsymh.inc

@@ -234,6 +234,7 @@
           constructor load;
           procedure write;virtual;
           procedure deref;virtual;
+          procedure insert_in_data;virtual;
 {$ifdef GDB}
           procedure concatstabto(asmlist : paasmoutput);virtual;
 {$endif GDB}
@@ -287,11 +288,14 @@
        tconstsym = object(tsym)
           definition : pdef;
           consttype  : tconsttype;
-          value      : longint;
-          constructor init(const n : string;t : tconsttype;v : longint;def : pdef);
+          value,
+          len        : longint; { len is needed for string length }
+          constructor init(const n : string;t : tconsttype;v : longint);
+          constructor init_def(const n : string;t : tconsttype;v : longint;def : pdef);
+          constructor init_string(const n : string;t : tconsttype;str:pchar;l:longint);
           constructor load;
+          destructor  done;virtual;
           function  mangledname : string;virtual;
-          destructor done;virtual;
           procedure deref;virtual;
           procedure write;virtual;
 {$ifdef GDB}
@@ -331,7 +335,10 @@
 
 {
   $Log$
-  Revision 1.15  1999-02-22 13:07:11  pierre
+  Revision 1.16  1999-03-24 23:17:29  peter
+    * fixed bugs 212,222,225,227,229,231,233
+
+  Revision 1.15  1999/02/22 13:07:11  pierre
     + -b and -bl options work !
     + cs_local_browser ($L+) is disabled if cs_browser ($Y+)
       is not enabled when quitting global section

compiler/systems.pas

@@ -277,7 +277,7 @@ implementation
             stackalignment : 2;
             size_of_pointer : 4;
             size_of_longint : 4;
-            use_bound_instruction : true;
+            use_bound_instruction : false;
             use_function_relative_addresses : true
           ),
           (
@@ -337,7 +337,7 @@ implementation
             stackalignment : 4;
             size_of_pointer : 4;
             size_of_longint : 4;
-            use_bound_instruction : true;
+            use_bound_instruction : false;
             use_function_relative_addresses : true
           ),
           (
@@ -1358,7 +1358,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.63  1999-03-09 11:54:09  pierre
+  Revision 1.64  1999-03-24 23:17:33  peter
+    * fixed bugs 212,222,225,227,229,231,233
+
+  Revision 1.63  1999/03/09 11:54:09  pierre
    * pecoff default assem for win32 with ag386bin
 
   Revision 1.62  1999/03/04 13:55:48  pierre

compiler/tccal.pas

@@ -27,9 +27,7 @@ interface
       symtable,tree;
 
 
-{$ifndef OLDHIGH}
     procedure gen_high_tree(p:ptree;openstring:boolean);
-{$endif}
 
     procedure firstcallparan(var p : ptree;defcoll : pdefcoll);
     procedure firstcalln(var p : ptree);
@@ -60,7 +58,6 @@ implementation
                              FirstCallParaN
 *****************************************************************************}
 
-{$ifndef OLDHIGH}
     procedure gen_high_tree(p:ptree;openstring:boolean);
       var
         len : longint;
@@ -120,11 +117,11 @@ implementation
           p^.hightree:=genordinalconstnode(len,s32bitdef);
         firstpass(p^.hightree);
       end;
-{$endif OLDHIGH}
 
 
     procedure firstcallparan(var p : ptree;defcoll : pdefcoll);
       var
+        old_get_para_resulttype : boolean;
         old_array_constructor : boolean;
         store_valid : boolean;
         oldtype     : pdef;
@@ -146,10 +143,13 @@ implementation
          if defcoll=nil then
            begin
               old_array_constructor:=allow_array_constructor;
+              old_get_para_resulttype:=get_para_resulttype;
+              get_para_resulttype:=true;
               allow_array_constructor:=true;
               if not(assigned(p^.resulttype)) or
                 (p^.left^.treetype=typeconvn) then
                 firstpass(p^.left);
+              get_para_resulttype:=old_get_para_resulttype;
               allow_array_constructor:=old_array_constructor;
               if codegenerror then
                 begin
@@ -176,17 +176,18 @@ implementation
                  must_be_valid:=(defcoll^.paratyp<>vs_var);
                  { only process typeconvn, else it will break other trees }
                  old_array_constructor:=allow_array_constructor;
+                 old_get_para_resulttype:=get_para_resulttype;
                  allow_array_constructor:=true;
+                 get_para_resulttype:=false;
                  if (p^.left^.treetype=typeconvn) then
                    firstpass(p^.left);
+                 get_para_resulttype:=old_get_para_resulttype;
                  allow_array_constructor:=old_array_constructor;
                  must_be_valid:=store_valid;
                end;
               { generate the high() value tree }
               if push_high_param(defcoll^.data) then
-{$ifndef OLDHIGH}
                 gen_high_tree(p,is_open_string(defcoll^.data));
-{$endif}
               if not(is_shortstring(p^.left^.resulttype) and
                      is_shortstring(defcoll^.data)) and
                      (defcoll^.data^.deftype<>formaldef) then
@@ -870,7 +871,7 @@ implementation
                    if make_ref then
                      begin
                         procs^.data^.lastref:=new(pref,init(procs^.data^.lastref,@p^.fileinfo));
-                        inc(procs^.data^.refcount); 
+                        inc(procs^.data^.refcount);
                         if procs^.data^.defref=nil then
                           procs^.data^.defref:=procs^.data^.lastref;
                      end;
@@ -1119,7 +1120,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.28  1999-03-23 14:43:03  peter
+  Revision 1.29  1999-03-24 23:17:34  peter
+    * fixed bugs 212,222,225,227,229,231,233
+
+  Revision 1.28  1999/03/23 14:43:03  peter
     * fixed crash with array of const in procvar
 
   Revision 1.27  1999/03/19 17:31:54  pierre

compiler/tcflw.pas

@@ -235,7 +235,7 @@ implementation
 
       var
          old_t_times : longint;
-
+         hp : ptree;
       begin
          { Calc register weight }
          old_t_times:=t_times;
@@ -250,6 +250,8 @@ implementation
              exit;
           end;
 
+         { save counter var }
+         p^.t2:=getcopy(p^.left^.left);
 
          p^.registers32:=p^.t1^.registers32;
          p^.registersfpu:=p^.t1^.registersfpu;
@@ -260,16 +262,6 @@ implementation
          if p^.left^.treetype<>assignn then
            CGMessage(cg_e_illegal_expression);
 
-         { Laufvariable retten }
-         p^.t2:=getcopy(p^.left^.left);
-
-         { Check count var }
-         if (p^.t2^.treetype<>loadn) then
-          CGMessage(cg_e_illegal_count_var)
-         else
-          if (not(is_ordinal(p^.t2^.resulttype))) then
-           CGMessage(type_e_ordinal_expr_expected);
-
          cleartempgen;
          must_be_valid:=false;
          firstpass(p^.left);
@@ -282,8 +274,23 @@ implementation
          if p^.left^.registersmmx>p^.registersmmx then
            p^.registersmmx:=p^.left^.registersmmx;
 {$endif SUPPORT_MMX}
+
+         { process count var }
          cleartempgen;
          firstpass(p^.t2);
+         if codegenerror then
+          exit;
+
+         { Check count var, record fields are also allowed in tp7 }
+         hp:=p^.t2;
+         while (hp^.treetype=subscriptn) do
+          hp:=hp^.left;
+         if (hp^.treetype<>loadn) then
+          CGMessage(cg_e_illegal_count_var)
+         else
+          if (not(is_ordinal(p^.t2^.resulttype))) then
+           CGMessage(type_e_ordinal_expr_expected);
+
          if p^.t2^.registers32>p^.registers32 then
            p^.registers32:=p^.t2^.registers32;
          if p^.t2^.registersfpu>p^.registersfpu then
@@ -493,7 +500,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.7  1999-03-09 19:24:42  peter
+  Revision 1.8  1999-03-24 23:17:36  peter
+    * fixed bugs 212,222,225,227,229,231,233
+
+  Revision 1.7  1999/03/09 19:24:42  peter
     * type check the exit()
 
   Revision 1.6  1999/02/22 02:15:48  peter

compiler/tcinl.pas

@@ -320,7 +320,6 @@ implementation
                end;
              in_sizeof_x:
                begin
-{$ifndef OLDHIGH}
                  if push_high_param(p^.left^.resulttype) then
                   begin
                     getsymonlyin(p^.left^.symtable,'high'+pvarsym(p^.left^.symtableentry)^.name);
@@ -333,7 +332,6 @@ implementation
                     p:=hp;
                     firstpass(p);
                   end;
-{$endif OLDHIGH}
                  if p^.registers32<1 then
                     p^.registers32:=1;
                  p^.resulttype:=s32bitdef;
@@ -945,17 +943,11 @@ implementation
                                begin
                                  if is_open_array(p^.left^.resulttype) then
                                   begin
-{$ifndef OLDHIGH}
                                     getsymonlyin(p^.left^.symtable,'high'+pvarsym(p^.left^.symtableentry)^.name);
                                     hp:=genloadnode(pvarsym(srsym),p^.left^.symtable);
                                     disposetree(p);
                                     p:=hp;
                                     firstpass(p);
-{$else OLDHIGH}
-                                    p^.resulttype:=s32bitdef;
-                                    p^.registers32:=max(1,p^.registers32);
-                                    p^.location.loc:=LOC_REGISTER;
-{$endif OLDHIGH}
                                   end
                                  else
                                   begin
@@ -979,17 +971,11 @@ implementation
                                begin
                                  if is_open_string(p^.left^.resulttype) then
                                   begin
-{$ifndef OLDHIGH}
                                     getsymonlyin(p^.left^.symtable,'high'+pvarsym(p^.left^.symtableentry)^.name);
                                     hp:=genloadnode(pvarsym(srsym),p^.left^.symtable);
                                     disposetree(p);
                                     p:=hp;
                                     firstpass(p);
-{$else OLDHIGH}
-                                    p^.resulttype:=s32bitdef;
-                                    p^.registers32:=max(1,p^.registers32);
-                                    p^.location.loc:=LOC_REGISTER;
-{$endif OLDHIGH}
                                   end
                                  else
                                   begin
@@ -1048,7 +1034,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.20  1999-03-16 17:52:55  jonas
+  Revision 1.21  1999-03-24 23:17:37  peter
+    * fixed bugs 212,222,225,227,229,231,233
+
+  Revision 1.20  1999/03/16 17:52:55  jonas
     * changes for internal Val code (do a "make cycle OPT=-dvalintern" to test)
     * in cgi386inl: also range checking for subrange types (compile with "-dreadrangecheck")
     * in cgai386: also small fixes to emitrangecheck

compiler/tcld.pas

@@ -392,34 +392,37 @@ implementation
            while assigned(hp) do
             begin
               firstpass(hp^.left);
-              case hp^.left^.resulttype^.deftype of
-                enumdef :
-                  begin
-                    hp^.left:=gentypeconvnode(hp^.left,s32bitdef);
-                    firstpass(hp^.left);
-                  end;
-                orddef :
-                  begin
-                    if is_integer(hp^.left^.resulttype) then
+              if not get_para_resulttype then
+               begin
+                 case hp^.left^.resulttype^.deftype of
+                   enumdef :
                      begin
                        hp^.left:=gentypeconvnode(hp^.left,s32bitdef);
                        firstpass(hp^.left);
                      end;
-                  end;
-                floatdef :
-                  begin
-                    hp^.left:=gentypeconvnode(hp^.left,s80floatdef);
-                    firstpass(hp^.left);
-                  end;
-                stringdef :
-                  begin
-                    if p^.cargs then
+                   orddef :
                      begin
-                       hp^.left:=gentypeconvnode(hp^.left,charpointerdef);
+                       if is_integer(hp^.left^.resulttype) then
+                        begin
+                          hp^.left:=gentypeconvnode(hp^.left,s32bitdef);
+                          firstpass(hp^.left);
+                        end;
+                     end;
+                   floatdef :
+                     begin
+                       hp^.left:=gentypeconvnode(hp^.left,s80floatdef);
                        firstpass(hp^.left);
                      end;
-                  end;
-              end;
+                   stringdef :
+                     begin
+                       if p^.cargs then
+                        begin
+                          hp^.left:=gentypeconvnode(hp^.left,charpointerdef);
+                          firstpass(hp^.left);
+                        end;
+                     end;
+                 end;
+               end;
               if (pd=nil) then
                pd:=hp^.left^.resulttype
               else
@@ -468,7 +471,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.19  1999-03-18 11:21:52  peter
+  Revision 1.20  1999-03-24 23:17:39  peter
+    * fixed bugs 212,222,225,227,229,231,233
+
+  Revision 1.19  1999/03/18 11:21:52  peter
     * convert only to s32bit if integer or enum
 
   Revision 1.18  1999/03/16 21:02:10  peter

compiler/todo.txt

@@ -66,14 +66,14 @@ compiler version and your short cut.
         - add strict var strings check $V switch ................ 0.99.1 (FK)
         - make dec/inc internal.................................. 0.99.6 (PFV)
         - make length internal................................... 0.99.7 (PFV)
+        - range checking for open arrays......................... 0.99.11 (PFV)
+        - method pointers (procedure of object) ................. 0.99.11 (FK)
+        - open strings, $P....................................... 0.99.10 (PFV)
+        - include/exclude........................................ 0.99.10 (PM)
 - fix all bugs of the bug directory
-- range checking for open arrays
-        - method pointers (procedure of object) ................ 0.99.11 (FK)
 - sysutils unit for go32v2 (excpetions!)
 - initialisation/finalization for units
 - fixed data type
 - add alignment $A switch
 - $B
-- open strings, $P
-- include/exclude
-  
+

compiler/tree.pas

@@ -313,6 +313,13 @@ unit tree;
     function str_length(p : ptree) : longint;
     function is_emptyset(p : ptree):boolean;
 
+    { counts the labels }
+    function case_count_labels(root : pcaserecord) : longint;
+    { searches the highest label }
+    function case_get_max(root : pcaserecord) : longint;
+    { searches the lowest label }
+    function case_get_min(root : pcaserecord) : longint;
+
 {$I innr.inc}
 
   implementation
@@ -820,7 +827,6 @@ unit tree;
             p^.stringtype:=st_shortstring;
             p^.resulttype:=cshortstringdef;
           end;
-
          genstringconstnode:=p;
       end;
 
@@ -851,8 +857,18 @@ unit tree;
 {$ifdef SUPPORT_MMX}
          p^.registersmmx:=0;
 {$endif SUPPORT_MMX}
-         p^.resulttype:=cshortstringdef;
          p^.length:=length;
+         if (cs_ansistrings in aktlocalswitches) or
+            (length>255) then
+          begin
+            p^.stringtype:=st_ansistring;
+            p^.resulttype:=cansistringdef;
+          end
+         else
+          begin
+            p^.stringtype:=st_shortstring;
+            p^.resulttype:=cshortstringdef;
+          end;
          p^.value_str:=s;
          p^.lab_str:=nil;
          genpcharconstnode:=p;
@@ -1642,10 +1658,61 @@ unit tree;
       end;
 
 
+{*****************************************************************************
+                              Case Helpers
+*****************************************************************************}
+
+    function case_count_labels(root : pcaserecord) : longint;
+      var
+         _l : longint;
+
+      procedure count(p : pcaserecord);
+        begin
+           inc(_l);
+           if assigned(p^.less) then
+             count(p^.less);
+           if assigned(p^.greater) then
+             count(p^.greater);
+        end;
+
+      begin
+         _l:=0;
+         count(root);
+         case_count_labels:=_l;
+      end;
+
+
+    function case_get_max(root : pcaserecord) : longint;
+      var
+         hp : pcaserecord;
+      begin
+         hp:=root;
+         while assigned(hp^.greater) do
+           hp:=hp^.greater;
+         case_get_max:=hp^._high;
+      end;
+
+
+    function case_get_min(root : pcaserecord) : longint;
+      var
+         hp : pcaserecord;
+      begin
+         hp:=root;
+         while assigned(hp^.less) do
+           hp:=hp^.less;
+         case_get_min:=hp^._low;
+      end;
+
+
+
+
 end.
 {
   $Log$
-  Revision 1.68  1999-03-02 18:24:25  peter
+  Revision 1.69  1999-03-24 23:17:41  peter
+    * fixed bugs 212,222,225,227,229,231,233
+
+  Revision 1.68  1999/03/02 18:24:25  peter
     * fixed overloading of array of char
 
   Revision 1.67  1999/02/25 21:02:56  peter

compiler/types.pas

@@ -21,16 +21,20 @@
  ****************************************************************************
 }
 unit types;
-
-  interface
+interface
 
     uses
-       cobjects,globals,symtable,aasm;
+       cobjects,symtable;
 
     type
        tmmxtype = (mmxno,mmxu8bit,mmxs8bit,mmxu16bit,mmxs16bit,
                    mmxu32bit,mmxs32bit,mmxfixed16,mmxsingle);
 
+    const
+       { true if we must never copy this parameter }
+       never_copy_const_param : boolean = false;
+
+
     { returns true, if def defines an ordinal type }
     function is_ordinal(def : pdef) : boolean;
 
@@ -96,10 +100,6 @@ unit types;
     { true if a parameter is too large to copy and only the address is pushed }
     function push_addr_param(def : pdef) : boolean;
 
-    { true if we must never copy this parameter }
-    const
-       never_copy_const_param : boolean = false;
-
     { true, if def1 and def2 are semantical the same }
     function is_equal(def1,def2 : pdef) : boolean;
 
@@ -123,23 +123,18 @@ unit types;
     { returns the range of def }
     procedure getrange(def : pdef;var l : longint;var h : longint);
 
-    { generates a VMT for _class }
-    procedure genvmt(_class : pobjectdef);
-
-    { generates the message tables for a class }
-    function genstrmsgtab(_class : pobjectdef) : plabel;
-    function genintmsgtab(_class : pobjectdef) : plabel;
-
     { some type helper routines for MMX support }
     function is_mmx_able_array(p : pdef) : boolean;
 
     { returns the mmx type }
     function mmx_type(p : pdef) : tmmxtype;
 
-  implementation
+
+implementation
 
     uses
-       strings,globtype,verbose;
+       strings,
+       globtype,globals,verbose;
 
 
     function equal_paras(def1,def2 : pdefcoll;value_equal_const : boolean) : boolean;
@@ -215,9 +210,9 @@ unit types;
          end;
       end;
 
+
     { returns the min. value of the type }
     function get_min_value(def : pdef) : longint;
-
       begin
          case def^.deftype of
             orddef:
@@ -354,7 +349,6 @@ unit types;
 
     { true if the return value is in accumulator (EAX for i386), D0 for 68k }
     function ret_in_acc(def : pdef) : boolean;
-
       begin
          ret_in_acc:=(def^.deftype in [orddef,pointerdef,enumdef,classrefdef]) or
                      ((def^.deftype=stringdef) and (pstringdef(def)^.string_typ in [st_ansistring,st_widestring])) or
@@ -364,13 +358,14 @@ unit types;
                      ((def^.deftype=floatdef) and (pfloatdef(def)^.typ=f32bit));
       end;
 
+
     { true, if def is a 64 bit int type }
     function is_64bitint(def : pdef) : boolean;
-
       begin
          is_64bitint:=(def^.deftype=orddef) and (porddef(def)^.typ in [u64bit,s64bitint])
       end;
 
+
     { true if uses a parameter as return value }
     function ret_in_param(def : pdef) : boolean;
       begin
@@ -393,15 +388,16 @@ unit types;
       begin
          push_addr_param:=never_copy_const_param or
            (def^.deftype = formaldef) or
-           ((def^.deftype in [arraydef,recorddef])
-           { copy directly small records or arrays unless
-             array of const ! PM }
-{$ifndef COPY_SMALL_RECORDS}
-           and ((def^.size>4) or
-           ((def^.deftype=arraydef) and
-           (parraydef(def)^.IsConstructor or
-            parraydef(def)^.isArrayOfConst)))
-{$endif def COPY_SMALL_RECORDS}
+           { copy directly small records or arrays unless array of const ! PM }
+           ((def^.deftype in [arraydef,recorddef]) and
+            ((def^.size>4) or
+             ((def^.deftype=arraydef) and
+              (parraydef(def)^.IsConstructor or
+               parraydef(def)^.isArrayOfConst or
+               is_open_array(def)
+              )
+             )
+            )
            ) or
            ((def^.deftype=objectdef) and not(pobjectdef(def)^.isclass)) or
            ((def^.deftype=stringdef) and (pstringdef(def)^.string_typ in [st_shortstring,st_longstring])) or
@@ -457,14 +453,21 @@ unit types;
     procedure getrange(def : pdef;var l : longint;var h : longint);
       begin
         case def^.deftype of
-         orddef : begin
-                    l:=porddef(def)^.low;
-                    h:=porddef(def)^.high;
-                  end;
-        enumdef : begin
-                    l:=penumdef(def)^.min;
-                    h:=penumdef(def)^.max;
-                  end;
+          orddef :
+            begin
+              l:=porddef(def)^.low;
+              h:=porddef(def)^.high;
+            end;
+          enumdef :
+            begin
+              l:=penumdef(def)^.min;
+              h:=penumdef(def)^.max;
+            end;
+          arraydef :
+            begin
+              l:=parraydef(def)^.lowrange;
+              h:=parraydef(def)^.highrange;
+            end;
         else
           internalerror(987);
         end;
@@ -501,8 +504,8 @@ unit types;
            end;
       end;
 
-    function is_mmx_able_array(p : pdef) : boolean;
 
+    function is_mmx_able_array(p : pdef) : boolean;
       begin
 {$ifdef SUPPORT_MMX}
          if (cs_mmx_saturation in aktlocalswitches) then
@@ -593,13 +596,12 @@ unit types;
 {$endif SUPPORT_MMX}
       end;
 
-    function is_equal(def1,def2 : pdef) : boolean;
 
+    function is_equal(def1,def2 : pdef) : boolean;
       var
          b : boolean;
          hd : pdef;
          hp1,hp2 : pdefcoll;
-
       begin
          { both types must exists }
          if not (assigned(def1) and assigned(def2)) then
@@ -623,9 +625,9 @@ unit types;
          else
          { pointer with an equal definition are equal }
            if (def1^.deftype=pointerdef) and (def2^.deftype=pointerdef) then
-         { here a problem detected in tabsolutesym }
-         { the types can be forward type !!        }
              begin
+                { here a problem detected in tabsolutesym }
+                { the types can be forward type !!        }
                 if assigned(def1^.sym) and ((def1^.sym^.properties and sp_forwarddef)<>0) then
                   b:=(def1^.sym=def2^.sym)
                 else
@@ -650,31 +652,23 @@ unit types;
            if (def1^.deftype=floatdef) and (def2^.deftype=floatdef) then
              b:=pfloatdef(def1)^.typ=pfloatdef(def2)^.typ
          else
-            { strings with the same length are equal }
-            if (def1^.deftype=stringdef) and (def2^.deftype=stringdef) and
-               (pstringdef(def1)^.string_typ=pstringdef(def2)^.string_typ) then
-               begin
-                  b:=not(is_shortstring(def1)) or
-                    (pstringdef(def1)^.len=pstringdef(def2)^.len);
-               end
-    { STRING[N] ist equivalent zu ARRAY[0..N] OF CHAR (N<256) }
-{
-         else if ((def1^.deftype=stringdef) and (def2^.deftype=arraydef)) and
-              (parraydef(def2)^.definition^.deftype=orddef) and
-              (porddef(parraydef(def1)^.definition)^.typ=uchar) and
-              (parraydef(def2)^.lowrange=0) and
-              (parraydef(def2)^.highrange=pstringdef(def1)^.len) then
-              b:=true }
-          else
-            if (def1^.deftype=formaldef) and (def2^.deftype=formaldef) then
-              b:=true
-          { file types with the same file element type are equal }
-          { this is a problem for assign !!                      }
-          { changed to allow if one is untyped                   }
-          { all typed files are equal to the special             }
-          { typed file that has voiddef as elemnt type           }
-          { but must NOT match for text file !!!                 }
-          else
+           { strings with the same length are equal }
+           if (def1^.deftype=stringdef) and (def2^.deftype=stringdef) and
+              (pstringdef(def1)^.string_typ=pstringdef(def2)^.string_typ) then
+             begin
+                b:=not(is_shortstring(def1)) or
+                   (pstringdef(def1)^.len=pstringdef(def2)^.len);
+             end
+         else
+           if (def1^.deftype=formaldef) and (def2^.deftype=formaldef) then
+             b:=true
+         { file types with the same file element type are equal }
+         { this is a problem for assign !!                      }
+         { changed to allow if one is untyped                   }
+         { all typed files are equal to the special             }
+         { typed file that has voiddef as elemnt type           }
+         { but must NOT match for text file !!!                 }
+         else
             if (def1^.deftype=filedef) and (def2^.deftype=filedef) then
               b:=(pfiledef(def1)^.filetype=pfiledef(def2)^.filetype) and
                  ((
@@ -688,612 +682,109 @@ unit types;
                  ( (pfiledef(def1)^.typed_as=pdef(voiddef)) or
                    (pfiledef(def2)^.typed_as=pdef(voiddef))
                  )))
-          { sets with the same element type are equal }
-          else
-            if (def1^.deftype=setdef) and (def2^.deftype=setdef) then
-              begin
-                 if assigned(psetdef(def1)^.setof) and
-                    assigned(psetdef(def2)^.setof) then
-                   b:=(psetdef(def1)^.setof^.deftype=psetdef(def2)^.setof^.deftype)
-                 else
-                   b:=true;
-              end
-          else
-            if (def1^.deftype=procvardef) and (def2^.deftype=procvardef) then
-              begin
-                 { poassembler isn't important for compatibility }
-                 { if a method is assigned to a methodpointer    }
-                 { is checked before                             }
-                 b:=((pprocvardef(def1)^.options and not(poassembler or pomethodpointer or
-                       povirtualmethod or pooverridingmethod))=
-                     (pprocvardef(def2)^.options and not(poassembler or pomethodpointer or
-                       povirtualmethod or pooverridingmethod))
-                    ) and
-                   is_equal(pprocvardef(def1)^.retdef,pprocvardef(def2)^.retdef);
-                 { now evalute the parameters }
-                 if b then
-                   begin
-                      hp1:=pprocvardef(def1)^.para1;
-                      hp2:=pprocvardef(def1)^.para1;
-                      while assigned(hp1) and assigned(hp2) do
-                        begin
-                           if not(is_equal(hp1^.data,hp2^.data)) or
-                             not(hp1^.paratyp=hp2^.paratyp) then
-                             begin
-                                b:=false;
-                                break;
-                             end;
-                           hp1:=hp1^.next;
-                           hp2:=hp2^.next;
-                        end;
-                      b:=(hp1=nil) and (hp2=nil);
-                   end;
-              end
-          else
-            if (def1^.deftype=arraydef) and (def2^.deftype=arraydef) and
-              (is_open_array(def1) or is_open_array(def2)) then
-              begin
-                if parraydef(def1)^.IsArrayOfConst or parraydef(def2)^.IsArrayOfConst then
-                 b:=true
-                else
-                 b:=is_equal(parraydef(def1)^.definition,parraydef(def2)^.definition);
-              end
-          else
-            if (def1^.deftype=classrefdef) and (def2^.deftype=classrefdef) then
-              begin
-                 { similar to pointerdef: }
-                 if assigned(def1^.sym) and ((def1^.sym^.properties and sp_forwarddef)<>0) then
-                   b:=(def1^.sym=def2^.sym)
-                 else
-                   b:=is_equal(pclassrefdef(def1)^.definition,pclassrefdef(def2)^.definition);
-              end;
-         is_equal:=b;
-      end;
-
-
-    function is_subequal(def1, def2: pdef): boolean;
-    Begin
-      if assigned(def1) and assigned(def2) then
-      Begin
-        is_subequal := FALSE;
-        if (def1^.deftype = orddef) and (def2^.deftype = orddef) then
-          Begin
-            { see p.47 of Turbo Pascal 7.01 manual for the separation of types }
-            { range checking for case statements is done with testrange        }
-            case porddef(def1)^.typ of
-           u8bit,u16bit,u32bit,
-           s8bit,s16bit,s32bit : is_subequal:=(porddef(def2)^.typ in [s32bit,u32bit,u8bit,s8bit,s16bit,u16bit]);
-  bool8bit,bool16bit,bool32bit : is_subequal:=(porddef(def2)^.typ in [bool8bit,bool16bit,bool32bit]);
-                         uchar : is_subequal:=(porddef(def2)^.typ=uchar);
-            end;
-          end
-        else
-          Begin
-            { I assume that both enumerations are equal when the first }
-            { pointers are equal.                                      }
-            if (def1^.deftype = enumdef) and (def2^.deftype =enumdef) then
-              Begin
-                if penumdef(def1)^.first = penumdef(def2)^.first then
-                   is_subequal := TRUE;
-              end;
-          end;
-      end; { endif assigned ... }
-    end;
-
-    type
-       pprocdeftree = ^tprocdeftree;
-
-       tprocdeftree = record
-          p : pprocdef;
-          nl : plabel;
-          l,r : pprocdeftree;
-       end;
-
-    var
-       root : pprocdeftree;
-       count : longint;
-
-    procedure insertstr(p : pprocdeftree;var at : pprocdeftree);
-
-      var
-         i : longint;
-
-      begin
-         if at=nil then
-           begin
-              at:=p;
-              inc(count);
-           end
+         { sets with the same element type are equal }
          else
-           begin
-              i:=strcomp(p^.p^.messageinf.str,at^.p^.messageinf.str);
-              if i<0 then
-                insertstr(p,at^.l)
-              else if i>0 then
-                insertstr(p,at^.r)
-              else
-                Message1(parser_e_duplicate_message_label,strpas(p^.p^.messageinf.str));
-           end;
-      end;
-
-    procedure disposeprocdeftree(p : pprocdeftree);
-
-      begin
-         if assigned(p^.l) then
-           disposeprocdeftree(p^.l);
-         if assigned(p^.r) then
-           disposeprocdeftree(p^.r);
-         dispose(p);
-      end;
-
-    procedure insertmsgstr(p : psym);{$ifndef FPC}far;{$endif FPC}
-
-      var
-         hp : pprocdef;
-         pt : pprocdeftree;
-
-      begin
-         if p^.typ=procsym then
-           begin
-              hp:=pprocsym(p)^.definition;
-              while assigned(hp) do
-                begin
-                   if (hp^.options and pomsgstr)<>0 then
-                     begin
-                        new(pt);
-                        pt^.p:=hp;
-                        pt^.l:=nil;
-                        pt^.r:=nil;
-                        insertstr(pt,root);
-                     end;
-                   hp:=hp^.nextoverloaded;
-                end;
-           end;
-      end;
-
-    procedure writenames(p : pprocdeftree);
-
-      begin
-         getlabel(p^.nl);
-         if assigned(p^.l) then
-           writenames(p^.l);
-         datasegment^.concat(new(pai_label,init(p^.nl)));
-         datasegment^.concat(new(pai_const,init_8bit(strlen(p^.p^.messageinf.str))));
-         datasegment^.concat(new(pai_string,init_pchar(p^.p^.messageinf.str)));
-         if assigned(p^.r) then
-           writenames(p^.r);
-      end;
-
-    procedure writestrentry(p : pprocdeftree);
-
-      begin
-         if assigned(p^.l) then
-           writestrentry(p^.l);
-
-         { write name label }
-         datasegment^.concat(new(pai_const_symbol,init(lab2str(p^.nl))));
-         datasegment^.concat(new(pai_const_symbol,init(p^.p^.mangledname)));
-         maybe_concat_external(p^.p^.owner,p^.p^.mangledname);
-
-         if assigned(p^.r) then
-           writestrentry(p^.r);
-      end;
-
-    function genstrmsgtab(_class : pobjectdef) : plabel;
-
-
-      var
-         r : plabel;
-
-      begin
-         root:=nil;
-         count:=0;
-         { insert all message handlers into a tree, sorted by name }
-         _class^.publicsyms^.foreach(insertmsgstr);
-
-         { write all names }
-         if assigned(root) then
-           writenames(root);
-
-         { now start writing of the message string table }
-         getlabel(r);
-         datasegment^.concat(new(pai_label,init(r)));
-         genstrmsgtab:=r;
-         datasegment^.concat(new(pai_const,init_32bit(count)));
-         if assigned(root) then
-           begin
-              writestrentry(root);
-              disposeprocdeftree(root);
-           end;
-      end;
-
-    procedure insertint(p : pprocdeftree;var at : pprocdeftree);
-
-      var
-         i : longint;
-
-      begin
-         if at=nil then
-           begin
-              at:=p;
-              inc(count);
-           end
+           if (def1^.deftype=setdef) and (def2^.deftype=setdef) then
+             begin
+                if assigned(psetdef(def1)^.setof) and
+                   assigned(psetdef(def2)^.setof) then
+                  b:=(psetdef(def1)^.setof^.deftype=psetdef(def2)^.setof^.deftype)
+                else
+                  b:=true;
+             end
          else
-           begin
-              i:=strcomp(p^.p^.messageinf.str,at^.p^.messageinf.str);
-              if p^.p^.messageinf.i<at^.p^.messageinf.i then
-                insertstr(p,at^.l)
-              else if p^.p^.messageinf.i>at^.p^.messageinf.i then
-                insertstr(p,at^.r)
-              else
-                Message1(parser_e_duplicate_message_label,tostr(p^.p^.messageinf.i));
-           end;
-      end;
-
-    procedure writeintentry(p : pprocdeftree);
-
-      begin
-         if assigned(p^.l) then
-           writeintentry(p^.l);
-
-         { write name label }
-         datasegment^.concat(new(pai_const,init_32bit(p^.p^.messageinf.i)));
-         datasegment^.concat(new(pai_const_symbol,init(p^.p^.mangledname)));
-         maybe_concat_external(p^.p^.owner,p^.p^.mangledname);
-
-         if assigned(p^.r) then
-           writeintentry(p^.r);
-      end;
-
-    procedure insertmsgint(p : psym);{$ifndef FPC}far;{$endif FPC}
-
-      var
-         hp : pprocdef;
-         pt : pprocdeftree;
-
-      begin
-         if p^.typ=procsym then
-           begin
-              hp:=pprocsym(p)^.definition;
-              while assigned(hp) do
-                begin
-                   if (hp^.options and pomsgint)<>0 then
-                     begin
-                        new(pt);
-                        pt^.p:=hp;
-                        pt^.l:=nil;
-                        pt^.r:=nil;
-                        insertint(pt,root);
-                     end;
-                   hp:=hp^.nextoverloaded;
-                end;
-           end;
-      end;
-
-    function genintmsgtab(_class : pobjectdef) : plabel;
-
-
-      var
-         r : plabel;
-
-      begin
-         root:=nil;
-         count:=0;
-         { insert all message handlers into a tree, sorted by name }
-         _class^.publicsyms^.foreach(insertmsgint);
-
-         { now start writing of the message string table }
-         getlabel(r);
-         datasegment^.concat(new(pai_label,init(r)));
-         genintmsgtab:=r;
-         datasegment^.concat(new(pai_const,init_32bit(count)));
-         if assigned(root) then
-           begin
-              writeintentry(root);
-              disposeprocdeftree(root);
-           end;
-      end;
-
-    type
-       pprocdefcoll = ^tprocdefcoll;
-
-       tprocdefcoll = record
-          next : pprocdefcoll;
-          data : pprocdef;
-       end;
-
-       psymcoll = ^tsymcoll;
-
-       tsymcoll = record
-          next : psymcoll;
-          name : pstring;
-          data : pprocdefcoll;
-       end;
-
-    var
-       wurzel : psymcoll;
-       nextvirtnumber : longint;
-       _c : pobjectdef;
-       has_constructor,has_virtual_method : boolean;
-
-    procedure eachsym(sym : psym);{$ifndef FPC}far;{$endif FPC}
-
-      var
-         procdefcoll : pprocdefcoll;
-         hp : pprocdef;
-         symcoll : psymcoll;
-         _name : string;
-         stored : boolean;
-
-      { creates a new entry in the procsym list }
-      procedure newentry;
-
-        begin
-           { if not, generate a new symbol item }
-           new(symcoll);
-           symcoll^.name:=stringdup(sym^.name);
-           symcoll^.next:=wurzel;
-           symcoll^.data:=nil;
-           wurzel:=symcoll;
-           hp:=pprocsym(sym)^.definition;
-
-           { inserts all definitions }
-           while assigned(hp) do
+           if (def1^.deftype=procvardef) and (def2^.deftype=procvardef) then
              begin
-                new(procdefcoll);
-                procdefcoll^.data:=hp;
-                procdefcoll^.next:=symcoll^.data;
-                symcoll^.data:=procdefcoll;
-
-                { if it's a virtual method }
-                if (hp^.options and povirtualmethod)<>0 then
+                { poassembler isn't important for compatibility }
+                { if a method is assigned to a methodpointer    }
+                { is checked before                             }
+                b:=((pprocvardef(def1)^.options and not(poassembler or pomethodpointer or
+                      povirtualmethod or pooverridingmethod))=
+                    (pprocvardef(def2)^.options and not(poassembler or pomethodpointer or
+                      povirtualmethod or pooverridingmethod))
+                   ) and
+                  is_equal(pprocvardef(def1)^.retdef,pprocvardef(def2)^.retdef);
+                { now evalute the parameters }
+                if b then
                   begin
-                     { then it gets a number ... }
-                     hp^.extnumber:=nextvirtnumber;
-                     { and we inc the number }
-                     inc(nextvirtnumber);
-                     has_virtual_method:=true;
+                     hp1:=pprocvardef(def1)^.para1;
+                     hp2:=pprocvardef(def1)^.para1;
+                     while assigned(hp1) and assigned(hp2) do
+                       begin
+                          if not(is_equal(hp1^.data,hp2^.data)) or
+                            not(hp1^.paratyp=hp2^.paratyp) then
+                            begin
+                               b:=false;
+                               break;
+                            end;
+                          hp1:=hp1^.next;
+                          hp2:=hp2^.next;
+                       end;
+                     b:=(hp1=nil) and (hp2=nil);
                   end;
-
-                if (hp^.options and poconstructor)<>0 then
-                  has_constructor:=true;
-
-                { check, if a method should be overridden }
-                if (hp^.options and pooverridingmethod)<>0 then
-                  Message1(parser_e_nothing_to_be_overridden,_c^.name^+'.'+_name);
-                { next overloaded method }
-                hp:=hp^.nextoverloaded;
+             end
+         else
+           if (def1^.deftype=arraydef) and (def2^.deftype=arraydef) and
+             (is_open_array(def1) or is_open_array(def2)) then
+             begin
+               if parraydef(def1)^.IsArrayOfConst or parraydef(def2)^.IsArrayOfConst then
+                b:=true
+               else
+                b:=is_equal(parraydef(def1)^.definition,parraydef(def2)^.definition);
+             end
+         else
+           if (def1^.deftype=classrefdef) and (def2^.deftype=classrefdef) then
+             begin
+                { similar to pointerdef: }
+                if assigned(def1^.sym) and ((def1^.sym^.properties and sp_forwarddef)<>0) then
+                  b:=(def1^.sym=def2^.sym)
+                else
+                  b:=is_equal(pclassrefdef(def1)^.definition,pclassrefdef(def2)^.definition);
              end;
-        end;
-
-      begin
-         { put only sub routines into the VMT }
-         if sym^.typ=procsym then
-           begin
-              _name:=sym^.name;
-              symcoll:=wurzel;
-              while assigned(symcoll) do
-                begin
-                   { does the symbol already exist in the list ? }
-                   if _name=symcoll^.name^ then
-                     begin
-                        { walk through all defs of the symbol }
-                        hp:=pprocsym(sym)^.definition;
-                        while assigned(hp) do
-                          begin
-                             { compare with all stored definitions }
-                             procdefcoll:=symcoll^.data;
-                             stored:=false;
-                             while assigned(procdefcoll) do
-                               begin
-                                  { compare parameters }
-                                  if equal_paras(procdefcoll^.data^.para1,hp^.para1,false) and
-                                     (
-                                       ((procdefcoll^.data^.options and povirtualmethod)<>0) or
-                                       ((hp^.options and povirtualmethod)<>0)
-                                     ) then
-                                    begin
-                                       { wenn sie gleich sind }
-                                       { und eine davon virtual deklariert ist }
-                                       { Fehler falls nur eine VIRTUAL }
-                                       if (procdefcoll^.data^.options and povirtualmethod)<>
-                                          (hp^.options and povirtualmethod) then
-                                         begin
-                                            { in classes, we hide the old method }
-                                            if _c^.isclass then
-                                              begin
-                                                 { 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);
-                                                 newentry;
-                                                 exit;
-                                              end
-                                            else
-                                              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)
-                                                   else
-                                                     Message1(parser_w_overloaded_are_not_both_non_virtual,
-                                                       _c^.name^+'.'+_name);
-                                                   newentry;
-                                                   exit;
-                                                end;
-                                         end;
-
-                                       { check, if the overridden directive is set }
-                                       { (povirtualmethod is set! }
-
-                                       { class ? }
-                                       if _c^.isclass and
-                                         ((hp^.options and pooverridingmethod)=0) then
-                                         begin
-                                            { 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);
-                                            newentry;
-                                            exit;
-                                         end;
-
-                                       { error, if the return types aren't equal }
-                                       if not(is_equal(procdefcoll^.data^.retdef,hp^.retdef)) and
-                                         not((procdefcoll^.data^.retdef^.deftype=objectdef) and
-                                           (hp^.retdef^.deftype=objectdef) and
-                                           (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);
-
-
-                                       { 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);
-
-                                       { now set the number }
-                                       hp^.extnumber:=procdefcoll^.data^.extnumber;
-                                       { and exchange }
-                                       procdefcoll^.data:=hp;
-                                       stored:=true;
-                                    end;
-                                  procdefcoll:=procdefcoll^.next;
-                               end;
-                             { if it isn't saved in the list }
-                             { we create a new entry         }
-                             if not(stored) then
-                               begin
-                                  new(procdefcoll);
-                                  procdefcoll^.data:=hp;
-                                  procdefcoll^.next:=symcoll^.data;
-                                  symcoll^.data:=procdefcoll;
-                                  { if the method is virtual ... }
-                                  if (hp^.options and povirtualmethod)<>0 then
-                                    begin
-                                       { ... it will get a number }
-                                       hp^.extnumber:=nextvirtnumber;
-                                       inc(nextvirtnumber);
-                                    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);
-                               end;
-                             hp:=hp^.nextoverloaded;
-                          end;
-                        exit;
-                     end;
-                   symcoll:=symcoll^.next;
-                end;
-             newentry;
-           end;
+         is_equal:=b;
       end;
 
-    procedure genvmt(_class : pobjectdef);
-
-      procedure do_genvmt(p : pobjectdef);
 
-        begin
-           { start with the base class }
-           if assigned(p^.childof) then
-             do_genvmt(p^.childof);
-
-           { walk through all public syms }
-           _c:=_class;
-{$ifdef tp}
-           p^.publicsyms^.foreach(eachsym);
-{$else}
-           p^.publicsyms^.foreach(@eachsym);
-{$endif}
-        end;
-
-      var
-         symcoll : psymcoll;
-         procdefcoll : pprocdefcoll;
-         i : longint;
-
-      begin
-         wurzel:=nil;
-         nextvirtnumber:=0;
-
-         has_constructor:=false;
-         has_virtual_method:=false;
-
-         { generates a tree of all used methods }
-         do_genvmt(_class);
-
-         if has_virtual_method and not(has_constructor) then
-            Message1(parser_w_virtual_without_constructor,_class^.name^);
-
-
-         { generates the VMT }
-
-         { walk trough all numbers for virtual methods and search }
-         { the method                                             }
-         for i:=0 to nextvirtnumber-1 do
-           begin
-              symcoll:=wurzel;
-
-              { walk trough all symbols }
-              while assigned(symcoll) do
-                begin
-
-                   { walk trough all methods }
-                   procdefcoll:=symcoll^.data;
-                   while assigned(procdefcoll) do
-                     begin
-                        { writes the addresses to the VMT }
-                        { but only this which are declared as virtual }
-                        if procdefcoll^.data^.extnumber=i then
-                          begin
-                             if (procdefcoll^.data^.options and povirtualmethod)<>0 then
-                               begin
-                                  { if a method is abstract, then is also the }
-                                  { class abstract and it's not allow to      }
-                                  { generates an instance                     }
-                                  if (procdefcoll^.data^.options and poabstractmethod)<>0 then
-                                    begin
-                                       _class^.options:=_class^.options or oo_is_abstract;
-                                       datasegment^.concat(new(pai_const_symbol,
-                                         init('FPC_ABSTRACTERROR')));
-                                    end
-                                  else
-                                    begin
-                                      datasegment^.concat(new(pai_const_symbol,
-                                        init(procdefcoll^.data^.mangledname)));
-                                      maybe_concat_external(procdefcoll^.data^.owner,
-                                        procdefcoll^.data^.mangledname);
-                                    end;
-                               end;
-                          end;
-                        procdefcoll:=procdefcoll^.next;
-                     end;
-                   symcoll:=symcoll^.next;
-                end;
-           end;
-         { disposes the above generated tree }
-         symcoll:=wurzel;
-         while assigned(symcoll) do
-           begin
-              wurzel:=symcoll^.next;
-              stringdispose(symcoll^.name);
-              procdefcoll:=symcoll^.data;
-              while assigned(procdefcoll) do
-                begin
-                   symcoll^.data:=procdefcoll^.next;
-                   dispose(procdefcoll);
-                   procdefcoll:=symcoll^.data;
+    function is_subequal(def1, def2: pdef): boolean;
+      Begin
+        if assigned(def1) and assigned(def2) then
+        Begin
+          is_subequal := FALSE;
+          if (def1^.deftype = orddef) and (def2^.deftype = orddef) then
+            Begin
+              { see p.47 of Turbo Pascal 7.01 manual for the separation of types }
+              { range checking for case statements is done with testrange        }
+              case porddef(def1)^.typ of
+                u8bit,u16bit,u32bit,
+                s8bit,s16bit,s32bit :
+                  is_subequal:=(porddef(def2)^.typ in [s32bit,u32bit,u8bit,s8bit,s16bit,u16bit]);
+                bool8bit,bool16bit,bool32bit :
+                  is_subequal:=(porddef(def2)^.typ in [bool8bit,bool16bit,bool32bit]);
+                uchar :
+                  is_subequal:=(porddef(def2)^.typ=uchar);
+              end;
+            end
+          else
+            Begin
+              { I assume that both enumerations are equal when the first }
+              { pointers are equal.                                      }
+              if (def1^.deftype = enumdef) and (def2^.deftype =enumdef) then
+                Begin
+                  if penumdef(def1)^.first = penumdef(def2)^.first then
+                     is_subequal := TRUE;
                 end;
-              dispose(symcoll);
-              symcoll:=wurzel;
-           end;
+            end;
+        end; { endif assigned ... }
       end;
 
+
 end.
 {
   $Log$
-  Revision 1.55  1999-03-09 11:45:42  pierre
+  Revision 1.56  1999-03-24 23:17:42  peter
+    * fixed bugs 212,222,225,227,229,231,233
+
+  Revision 1.55  1999/03/09 11:45:42  pierre
    * small arrays and records (size <=4) are copied directly
 
   Revision 1.54  1999/03/02 22:52:20  peter

compiler/verbose.pas

@@ -70,6 +70,9 @@ procedure UpdateReplacement(var s:string);
 
 procedure Stop;
 procedure ShowStatus;
+function  ErrorCount:longint;
+procedure SetMaxErrorCount(count:longint);
+procedure GenerateError;
 procedure Internalerror(i:longint);
 procedure Comment(l:longint;s:string);
 procedure Message(w:tmsgconst);
@@ -290,6 +293,24 @@ begin
 end;
 
 
+function ErrorCount:longint;
+begin
+  ErrorCount:=status.errorcount;
+end;
+
+
+procedure SetMaxErrorCount(count:longint);
+begin
+  status.maxerrorcount:=count;
+end;
+
+
+procedure GenerateError;
+begin
+  inc(status.errorcount);
+end;
+
+
 procedure internalerror(i : longint);
 begin
   UpdateStatus;
@@ -438,7 +459,10 @@ end.
 
 {
   $Log$
-  Revision 1.35  1999-02-09 17:15:53  florian
+  Revision 1.36  1999-03-24 23:17:44  peter
+    * fixed bugs 212,222,225,227,229,231,233
+
+  Revision 1.35  1999/02/09 17:15:53  florian
     * some false warnings "function result doesn't seems to be set" are
       avoided