* resulttype rewrite

compiler/compiler.pas

@@ -97,7 +97,7 @@ uses
 {$endif Delphi}
   verbose,comphook,systems,
   cutils,cclasses,globals,options,fmodule,parser,symtable,
-  link,import,export,tokens,
+  link,import,export,tokens,pass_1,
   { cpu overrides }
   cpuswtch,cpunode
   ;
@@ -306,9 +306,8 @@ begin
     LostMemory:=system.HeapSize-MemAvail-EntryMemUsed;
     CheckMemory(LostMemory);
   {$endif FPC}
-  {$ifndef newcg}
-    Writeln('Repetitive firstpass = '+tostr(firstpass_several)+'/'+tostr(total_of_firstpass));
-  {$endif newcg}
+  Writeln('Repetitive firstpass = '+tostr(firstpass_several)+'/'+tostr(total_of_firstpass));
+  Writeln('Repetitive resulttypepass = ',multiresulttypepasscnt,'/',resulttypepasscnt);
 {$endif EXTDEBUG}
 {$ifdef MEMDEBUG}
   Writeln('Memory used: ',system.Heapsize);
@@ -321,7 +320,10 @@ end;
 end.
 {
   $Log$
-  Revision 1.15  2000-12-26 15:57:25  peter
+  Revision 1.16  2001-04-02 21:20:29  peter
+    * resulttype rewrite
+
+  Revision 1.15  2000/12/26 15:57:25  peter
     * use system.paramstr()
 
   Revision 1.14  2000/12/25 00:07:25  peter

compiler/fmodule.pas

@@ -508,7 +508,6 @@ uses
          Function SourceSearchPath(const s:string):boolean;
          var
            found   : boolean;
-           ext     : string[8];
            hs      : string;
          begin
            Found:=false;
@@ -523,8 +522,6 @@ uses
             begin
               { Check for .pas }
               Found:=UnitExists(target_os.pasext,hs);
-              if Found then
-               Ext:=target_os.pasext;
             end;
            stringdispose(mainsource);
            if Found then
@@ -881,7 +878,10 @@ uses
 end.
 {
   $Log$
-  Revision 1.9  2001-03-13 18:45:06  peter
+  Revision 1.10  2001-04-02 21:20:29  peter
+    * resulttype rewrite
+
+  Revision 1.9  2001/03/13 18:45:06  peter
     * fixed some memory leaks
 
   Revision 1.8  2001/03/06 18:28:02  peter

compiler/htypechk.pas

@@ -125,7 +125,7 @@ implementation
        globtype,systems,
        cutils,verbose,globals,
        symconst,symsym,symtable,
-       types,pass_1,cpubase,
+       types,cpubase,
        ncnv,nld,
        nmem,ncal,nmat,
 {$ifdef newcg}
@@ -288,6 +288,7 @@ implementation
           end;
       end;
 
+
     function isbinaryoverloaded(var t : tnode) : boolean;
 
      var
@@ -298,9 +299,9 @@ implementation
         isbinaryoverloaded:=false;
         { overloaded operator ? }
         { load easier access variables }
-        rd:=tbinarynode(t).right.resulttype;
-        ld:=tbinarynode(t).left.resulttype;
-        if isbinaryoperatoroverloadable(ld,rd,voiddef,t.nodetype) then
+        rd:=tbinarynode(t).right.resulttype.def;
+        ld:=tbinarynode(t).left.resulttype.def;
+        if isbinaryoperatoroverloadable(ld,rd,voidtype.def,t.nodetype) then
           begin
              isbinaryoverloaded:=true;
              {!!!!!!!!! handle paras }
@@ -346,7 +347,7 @@ implementation
              end;
              { the nil as symtable signs firstcalln that this is
                an overloaded operator }
-             ht:=gencallnode(overloaded_operators[optoken],nil);
+             ht:=ccallnode.create(nil,overloaded_operators[optoken],nil,nil);
              { we have to convert p^.left and p^.right into
               callparanodes }
              if tcallnode(ht).symtableprocentry=nil then
@@ -364,22 +365,24 @@ implementation
                   if assigned(tbinarynode(t).left) then
                     if assigned(tbinarynode(t).right) then
                       tcallnode(ht).left :=
-                        gencallparanode(tbinarynode(t).right.getcopy,
-                                          gencallparanode(tbinarynode(t).left.getcopy,nil))
+                        ccallparanode.create(tbinarynode(t).right.getcopy,
+                                             ccallparanode.create(tbinarynode(t).left.getcopy,nil))
                     else
                       tcallnode(ht).left :=
-                        gencallparanode(nil,gencallparanode(tbinarynode(t).left.getcopy,nil))
+                        ccallparanode.create(nil,
+                                             ccallparanode.create(tbinarynode(t).left.getcopy,nil))
                   else if assigned(tbinarynode(t).right) then
-                         gencallparanode(tbinarynode(t).right.getcopy,
-                                           gencallparanode(nil,nil));
+                      tcallnode(ht).left :=
+                         ccallparanode.create(tbinarynode(t).right.getcopy,
+                                              ccallparanode.create(nil,nil));
                   if t.nodetype=unequaln then
                     ht:=cnotnode.create(ht);
-                  firstpass(ht);
                   t:=ht;
                end;
           end;
       end;
 
+
 {****************************************************************************
                           Register Calculation
 ****************************************************************************}
@@ -584,7 +587,7 @@ implementation
         gotpointer:=false;
         gotwith:=false;
         hp:=p;
-        if is_void(hp.resulttype) then
+        if is_void(hp.resulttype.def) then
          begin
            CGMessagePos(hp.fileinfo,type_e_argument_cant_be_assigned);
            exit;
@@ -607,18 +610,18 @@ implementation
                end;
              typeconvn :
                begin
-                 case hp.resulttype^.deftype of
+                 case hp.resulttype.def^.deftype of
                    pointerdef :
                      gotpointer:=true;
                    objectdef :
-                     gotclass:=is_class_or_interface(hp.resulttype);
+                     gotclass:=is_class_or_interface(hp.resulttype.def);
                    classrefdef :
                      gotclass:=true;
                    arraydef :
                      begin
                        { pointer -> array conversion is done then we need to see it
                          as a deref, because a ^ is then not required anymore }
-                       if (ttypeconvnode(hp).left.resulttype^.deftype=pointerdef) then
+                       if (ttypeconvnode(hp).left.resulttype.def^.deftype=pointerdef) then
                         gotderef:=true;
                      end;
                  end;
@@ -633,7 +636,7 @@ implementation
                  { a class/interface access is an implicit }
                  { dereferencing                           }
                  hp:=tsubscriptnode(hp).left;
-                 if is_class_or_interface(hp.resulttype) then
+                 if is_class_or_interface(hp.resulttype.def) then
                    gotderef:=true;
                end;
              subn,
@@ -641,8 +644,8 @@ implementation
                begin
                  { Allow add/sub operators on a pointer, or an integer
                    and a pointer typecast and deref has been found }
-                 if (hp.resulttype^.deftype=pointerdef) or
-                    (is_integer(hp.resulttype) and gotpointer and gotderef) then
+                 if (hp.resulttype.def^.deftype=pointerdef) or
+                    (is_integer(hp.resulttype.def) and gotpointer and gotderef) then
                   valid_for_assign:=true
                  else
                   CGMessagePos(hp.fileinfo,type_e_variable_id_expected);
@@ -664,11 +667,11 @@ implementation
              calln :
                begin
                  { check return type }
-                 case hp.resulttype^.deftype of
+                 case hp.resulttype.def^.deftype of
                    pointerdef :
                      gotpointer:=true;
                    objectdef :
-                     gotclass:=is_class_or_interface(hp.resulttype);
+                     gotclass:=is_class_or_interface(hp.resulttype.def);
                    recorddef, { handle record like class it needs a subscription }
                    classrefdef :
                      gotclass:=true;
@@ -762,7 +765,7 @@ implementation
              vecn:
                begin
                  set_varstate(tbinarynode(p).right,true);
-                 if not(tunarynode(p).left.resulttype^.deftype in [stringdef,arraydef]) then
+                 if not(tunarynode(p).left.resulttype.def^.deftype in [stringdef,arraydef]) then
                   must_be_valid:=true;
                  p:=tunarynode(p).left;
                end;
@@ -814,11 +817,11 @@ implementation
                       begin
                         if (hsym^.varstate=vs_assigned) and
                            (must_be_valid or (parsing_para_level>0) or
-                            (p.resulttype^.deftype=procvardef)) then
+                            (p.resulttype.def^.deftype=procvardef)) then
                           hsym^.varstate:=vs_used;
                         if (hsym^.varstate=vs_declared_and_first_found) and
                            (must_be_valid or (parsing_para_level>0) or
-                           (p.resulttype^.deftype=procvardef)) then
+                           (p.resulttype.def^.deftype=procvardef)) then
                           hsym^.varstate:=vs_set_but_first_not_passed;
                       end;
                   end;
@@ -911,7 +914,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.22  2001-02-20 21:46:26  peter
+  Revision 1.23  2001-04-02 21:20:29  peter
+    * resulttype rewrite
+
+  Revision 1.22  2001/02/20 21:46:26  peter
     * don't allow assign to void type (merged)
 
   Revision 1.21  2001/02/04 11:12:17  jonas

compiler/i386/cgai386.pas

@@ -119,7 +119,7 @@ interface
     procedure floatloadops(t : tfloattype;var op : tasmop;var s : topsize);
     procedure floatstoreops(t : tfloattype;var op : tasmop;var s : topsize);
 
-    procedure maybe_loadesi;
+    procedure maybe_loadself;
     procedure emitloadord2reg(const location:Tlocation;orddef:Porddef;destreg:Tregister;delloc:boolean);
     procedure concatcopy(source,dest : treference;size : longint;delsource : boolean;loadref:boolean);
 
@@ -1023,7 +1023,7 @@ implementation
           emitpushreferenceaddr(sref);
          push_int(len);
          emitcall('FPC_SHORTSTR_COPY');
-         maybe_loadesi;
+         maybe_loadself;
       end;
 
     procedure copylongstring(const dref,sref : treference;len : longint;loadref:boolean);
@@ -1036,7 +1036,7 @@ implementation
          push_int(len);
          saveregvars($ff);
          emitcall('FPC_LONGSTR_COPY');
-         maybe_loadesi;
+         maybe_loadself;
       end;
 
 
@@ -1409,7 +1409,7 @@ implementation
                 ungetregister32(R_ECX);
 
               { loading SELF-reference again }
-              maybe_loadesi;
+              maybe_loadself;
            end;
          if delsource then
            ungetiftemp(source);
@@ -1479,7 +1479,7 @@ implementation
     end;
 
     { if necessary ESI is reloaded after a call}
-    procedure maybe_loadesi;
+    procedure maybe_loadself;
 
       var
          hp : preference;
@@ -2142,7 +2142,7 @@ implementation
 
          if assigned(procinfo^._class) and  { !!!!! shouldn't we load ESI always? }
             (lexlevel>normal_function_level) then
-           maybe_loadesi;
+           maybe_loadself;
 
       { When message method contains self as a parameter,
         we must load it into ESI }
@@ -2276,7 +2276,7 @@ implementation
           generate_interrupt_stackframe_entry;
 
       { initialize return value }
-      if (procinfo^.returntype.def<>pdef(voiddef)) and
+      if (not is_void(procinfo^.returntype.def)) and
          (procinfo^.returntype.def^.needs_inittable) then
         begin
            procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally;
@@ -2342,7 +2342,7 @@ implementation
             exprasmList.concat(Taicpu.op_reg_reg(A_TEST,S_L,R_EAX,R_EAX));
             emitjmp(C_NE,aktexitlabel);
             { probably we've to reload self here }
-            maybe_loadesi;
+            maybe_loadself;
         end;
 
       if not inlined then
@@ -2409,7 +2409,7 @@ implementation
   begin
       uses_eax:=false;
       uses_edx:=false;
-      if procinfo^.returntype.def<>pdef(voiddef) then
+      if not is_void(procinfo^.returntype.def) then
           begin
               {if ((procinfo^.flags and pi_operator)<>0) and
                  assigned(opsym) then
@@ -2602,7 +2602,7 @@ implementation
              end
            else
            { must be the return value finalized before reraising the exception? }
-           if (procinfo^.returntype.def<>pdef(voiddef)) and
+           if (not is_void(procinfo^.returntype.def)) and
              (procinfo^.returntype.def^.needs_inittable) and
              ((procinfo^.returntype.def^.deftype<>objectdef) or
               not is_class(procinfo^.returntype.def)) then
@@ -2776,7 +2776,7 @@ implementation
                        (po_staticmethod in aktprocsym^.definition^.procoptions) then
                       begin
                         exprasmList.concat(Tai_stabs.Create(strpnew(
-                         '"pvmt:p'+pvmtdef^.numberstring+'",'+
+                         '"pvmt:p'+pstoreddef(pvmttype.def)^.numberstring+'",'+
                          tostr(N_PSYM)+',0,0,'+tostr(procinfo^.selfpointer_offset))));
                       end
                     else
@@ -2805,10 +2805,10 @@ implementation
               { this enables test if the function is a local one !! }
               if  assigned(procinfo^.parent) and (lexlevel>normal_function_level) then
                 exprasmList.concat(Tai_stabs.Create(strpnew(
-                 '"parent_ebp:'+voidpointerdef^.numberstring+'",'+
+                 '"parent_ebp:'+pstoreddef(voidpointertype.def)^.numberstring+'",'+
                  tostr(N_LSYM)+',0,0,'+tostr(procinfo^.framepointer_offset))));
 
-              if (pdef(aktprocsym^.definition^.rettype.def) <> pdef(voiddef)) then
+              if (not is_void(aktprocsym^.definition^.rettype.def)) then
                 begin
                   if ret_in_param(aktprocsym^.definition^.rettype.def) then
                     exprasmList.concat(Tai_stabs.Create(strpnew(
@@ -2922,7 +2922,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.17  2001-01-05 17:36:58  florian
+  Revision 1.18  2001-04-02 21:20:35  peter
+    * resulttype rewrite
+
+  Revision 1.17  2001/01/05 17:36:58  florian
   * the info about exception frames is stored now on the stack
   instead on the heap
 

compiler/i386/csopt386.pas

@@ -1716,7 +1716,10 @@ End.
 
 {
   $Log$
-  Revision 1.13  2001-01-10 08:52:40  michael
+  Revision 1.14  2001-04-02 21:20:36  peter
+    * resulttype rewrite
+
+  Revision 1.13  2001/01/10 08:52:40  michael
   + Patch from jonas so 1.0.2 can be used to cycle
 
   Revision 1.12  2001/01/07 15:51:17  jonas
@@ -1818,7 +1821,7 @@ End.
       ignore labels who have is_addr set
     + daopt386/csopt386: remove loads of registers which are overwritten
        before their contents are used (especially usefull for removing superfluous
-      maybe_loadesi outputs and push/pops transformed by below optimization
+      maybe_loadself outputs and push/pops transformed by below optimization
     + popt386: transform pop/pop/pop/.../push/push/push to sequences of
       'movl x(%esp),%reg' (only active when compiling a go32v2 compiler
       currently because I don't know whether it's safe to do this under Win32/

compiler/i386/daopt386.pas

@@ -2454,7 +2454,10 @@ End.
 
 {
   $Log$
-  Revision 1.15  2000-12-31 11:00:31  jonas
+  Revision 1.16  2001-04-02 21:20:36  peter
+    * resulttype rewrite
+
+  Revision 1.15  2000/12/31 11:00:31  jonas
     * fixed potential bug in writeToMemDestroysContents
 
   Revision 1.14  2000/12/25 00:07:32  peter
@@ -2572,7 +2575,7 @@ End.
       ignore labels who have is_addr set
     + daopt386/csopt386: remove loads of registers which are overwritten
        before their contents are used (especially usefull for removing superfluous
-      maybe_loadesi outputs and push/pops transformed by below optimization
+      maybe_loadself outputs and push/pops transformed by below optimization
     + popt386: transform pop/pop/pop/.../push/push/push to sequences of
       'movl x(%esp),%reg' (only active when compiling a go32v2 compiler
       currently because I don't know whether it's safe to do this under Win32/

compiler/i386/n386add.pas

@@ -102,12 +102,12 @@ interface
       begin
          { remove temporary location if not a set or string }
          { that's a bad hack (FK) who did this ?            }
-         if (left.resulttype^.deftype<>stringdef) and
-            ((left.resulttype^.deftype<>setdef) or (psetdef(left.resulttype)^.settype=smallset)) and
+         if (left.resulttype.def^.deftype<>stringdef) and
+            ((left.resulttype.def^.deftype<>setdef) or (psetdef(left.resulttype.def)^.settype=smallset)) and
             (left.location.loc in [LOC_MEM,LOC_REFERENCE]) then
            ungetiftemp(left.location.reference);
-         if (right.resulttype^.deftype<>stringdef) and
-            ((right.resulttype^.deftype<>setdef) or (psetdef(right.resulttype)^.settype=smallset)) and
+         if (right.resulttype.def^.deftype<>stringdef) and
+            ((right.resulttype.def^.deftype<>setdef) or (psetdef(right.resulttype.def)^.settype=smallset)) and
             (right.location.loc in [LOC_MEM,LOC_REFERENCE]) then
            ungetiftemp(right.location.reference);
          { in case of comparison operation the put result in the flags }
@@ -142,7 +142,7 @@ interface
         { string operations are not commutative }
         if nf_swaped in flags then
           swapleftright;
-        case pstringdef(left.resulttype)^.string_typ of
+        case pstringdef(left.resulttype.def)^.string_typ of
            st_ansistring:
              begin
                 case nodetype of
@@ -165,7 +165,7 @@ interface
                         clear_location(location);
                         location.loc:=LOC_MEM;
                         gettempansistringreference(location.reference);
-                        decrstringref(cansistringdef,location.reference);
+                        decrstringref(cansistringtype.def,location.reference);
                         { release used registers }
                         del_location(right.location);
                         del_location(left.location);
@@ -178,7 +178,7 @@ interface
                         saveregvars($ff);
                         emitcall('FPC_ANSISTR_CONCAT');
                         popusedregisters(pushedregs);
-                        maybe_loadesi;
+                        maybe_loadself;
                         ungetiftempansi(left.location.reference);
                         ungetiftempansi(right.location.reference);
                      end;
@@ -249,7 +249,7 @@ interface
                              emitcall('FPC_ANSISTR_COMPARE');
                              emit_reg_reg(A_OR,S_L,R_EAX,R_EAX);
                              popusedregisters(pushedregs);
-                             maybe_loadesi;
+                             maybe_loadself;
                              ungetiftempansi(left.location.reference);
                              ungetiftempansi(right.location.reference);
                           end;
@@ -296,7 +296,7 @@ interface
                              { length of temp string = 255 (JM) }
                              { *** redefining a type is not allowed!! (thanks, Pierre) }
                              { also problem with constant string!                      }
-                             pstringdef(left.resulttype)^.len := 255;
+                             pstringdef(left.resulttype.def)^.len := 255;
 
 {$endif newoptimizations2}
                           end;
@@ -307,8 +307,8 @@ interface
                         { special case for string := string + char (JM) }
                         { needs string length stuff from above!         }
                         hreg := R_NO;
-                        if is_shortstring(left.resulttype) and
-                           is_char(right.resulttype) then
+                        if is_shortstring(left.resulttype.def) and
+                           is_char(right.resulttype.def) then
                           begin
                             getlabel(l);
                             getexplicitregister32(R_EDI);
@@ -317,7 +317,7 @@ interface
                               newreference(left.location.reference),R_EDI);
                             { is it already maximal? }
                             emit_const_reg(A_CMP,S_L,
-                              pstringdef(left.resulttype)^.len,R_EDI);
+                              pstringdef(left.resulttype.def)^.len,R_EDI);
                             emitjmp(C_E,l);
                             { no, so add the new character }
                             { is it a constant char? }
@@ -332,7 +332,7 @@ interface
                                   emit_ref_reg(A_MOV,S_B,
                                     newreference(right.location.reference),
                                     hreg);
-                                 { I don't think a temp char exists, but it won't hurt (JM)Ê}
+                                 { I don't think a temp char exists, but it won't hurt (JM) }
                                  ungetiftemp(right.location.reference);
                                 end
                               else hreg := right.location.register;
@@ -392,7 +392,7 @@ interface
 {$ifdef newoptimizations2}
                            { string (could be < 255 chars now) (JM)         }
                             emit_const(A_PUSH,S_L,
-                              pstringdef(left.resulttype)^.len);
+                              pstringdef(left.resulttype.def)^.len);
 {$endif newoptimizations2}
                             emitpushreferenceaddr(left.location.reference);
                            { the optimizer can more easily put the          }
@@ -408,7 +408,7 @@ interface
                             emitcall('FPC_SHORTSTR_CONCAT');
 {$endif newoptimizations2}
                             ungetiftemp(right.location.reference);
-                            maybe_loadesi;
+                            maybe_loadself;
                             popusedregisters(pushedregs);
 {$ifdef newoptimizations2}
                         end;
@@ -453,7 +453,7 @@ interface
                              del_reference(right.location.reference);
                              saveregvars($ff);
                              emitcall('FPC_SHORTSTR_COMPARE');
-                             maybe_loadesi;
+                             maybe_loadself;
                              popusedregisters(pushedregs);
                           end;
                         ungetiftemp(left.location.reference);
@@ -514,21 +514,16 @@ interface
         case nodetype of
           equaln,
         unequaln
-{$IfNDef NoSetInclusion}
         ,lten, gten
-{$EndIf NoSetInclusion}
                   : begin
                      cmpop:=true;
                      del_location(left.location);
                      del_location(right.location);
                      pushusedregisters(pushedregs,$ff);
-{$IfNDef NoSetInclusion}
                      If (nodetype in [equaln, unequaln, lten]) Then
                        Begin
-{$EndIf NoSetInclusion}
                          emitpushreferenceaddr(right.location.reference);
                          emitpushreferenceaddr(left.location.reference);
-{$IfNDef NoSetInclusion}
                        End
                      Else  {gten = lten, if the arguments are reversed}
                        Begin
@@ -538,9 +533,7 @@ interface
                      saveregvars($ff);
                      Case nodetype of
                        equaln, unequaln:
-{$EndIf NoSetInclusion}
                          emitcall('FPC_SET_COMP_SETS');
-{$IfNDef NoSetInclusion}
                        lten, gten:
                          Begin
                            emitcall('FPC_SET_CONTAINS_SETS');
@@ -548,8 +541,7 @@ interface
                            nodetype := equaln;
                         End;
                      End;
-{$EndIf NoSetInclusion}
-                     maybe_loadesi;
+                     maybe_loadself;
                      popusedregisters(pushedregs);
                      ungetiftemp(left.location.reference);
                      ungetiftemp(right.location.reference);
@@ -591,11 +583,7 @@ interface
                       { add a range or a single element? }
                         if right.nodetype=setelementn then
                          begin
-{$IfNDef regallocfix}
                            concatcopy(left.location.reference,href,32,false,false);
-{$Else regallocfix}
-                           concatcopy(left.location.reference,href,32,true,false);
-{$EndIf regallocfix}
                            if assigned(tbinarynode(right).right) then
                             begin
                               pushsetelement(tbinarynode(right).right);
@@ -617,18 +605,12 @@ interface
                          { must be an other set }
                            emitpushreferenceaddr(href);
                            emitpushreferenceaddr(right.location.reference);
-{$IfDef regallocfix}
-                           del_location(right.location);
-{$EndIf regallocfix}
                            emitpushreferenceaddr(left.location.reference);
-{$IfDef regallocfix}
-                           del_location(left.location);
-{$EndIf regallocfix}
                            saveregvars(regstopush);
                            emitcall('FPC_SET_ADD_SETS');
                          end;
                       end;
-                     maybe_loadesi;
+                     maybe_loadself;
                      popusedregisters(pushedregs);
                      ungetiftemp(left.location.reference);
                      ungetiftemp(right.location.reference);
@@ -661,7 +643,7 @@ interface
                    symdifn : emitcall('FPC_SET_SYMDIF_SETS');
                       muln : emitcall('FPC_SET_MUL_SETS');
                      end;
-                     maybe_loadesi;
+                     maybe_loadself;
                      popusedregisters(pushedregs);
                      ungetiftemp(left.location.reference);
                      ungetiftemp(right.location.reference);
@@ -781,14 +763,14 @@ interface
       begin
       { to make it more readable, string and set (not smallset!) have their
         own procedures }
-         case left.resulttype^.deftype of
+         case left.resulttype.def^.deftype of
          stringdef : begin
                        addstring;
                        exit;
                      end;
             setdef : begin
                      { normalsets are handled separate }
-                       if not(psetdef(left.resulttype)^.settype=smallset) then
+                       if not(psetdef(left.resulttype.def)^.settype=smallset) then
                         begin
                           addset;
                           exit;
@@ -805,21 +787,21 @@ interface
 
          { are we a (small)set, must be set here because the side can be
            swapped ! (PFV) }
-         is_set:=(left.resulttype^.deftype=setdef);
+         is_set:=(left.resulttype.def^.deftype=setdef);
 
          { calculate the operator which is more difficult }
          firstcomplex(self);
 
          { handling boolean expressions extra: }
-         if is_boolean(left.resulttype) and
-            is_boolean(right.resulttype) then
+         if is_boolean(left.resulttype.def) and
+            is_boolean(right.resulttype.def) then
            begin
-             if (porddef(left.resulttype)^.typ=bool8bit) or
-                (porddef(right.resulttype)^.typ=bool8bit) then
+             if (porddef(left.resulttype.def)^.typ=bool8bit) or
+                (porddef(right.resulttype.def)^.typ=bool8bit) then
                opsize:=S_B
              else
-               if (porddef(left.resulttype)^.typ=bool16bit) or
-                  (porddef(right.resulttype)^.typ=bool16bit) then
+               if (porddef(left.resulttype.def)^.typ=bool16bit) or
+                  (porddef(right.resulttype.def)^.typ=bool16bit) then
                  opsize:=S_W
              else
                opsize:=S_L;
@@ -926,36 +908,36 @@ interface
                 set_location(location,left.location);
 
               { are too few registers free? }
-              pushed:=maybe_push(right.registers32,self,is_64bitint(left.resulttype));
+              pushed:=maybe_push(right.registers32,self,is_64bitint(left.resulttype.def));
               secondpass(right);
               if pushed then
                 begin
-                  restore(self,is_64bitint(left.resulttype));
+                  restore(self,is_64bitint(left.resulttype.def));
                   set_location(left.location,location);
                 end;
 
-              if (left.resulttype^.deftype=pointerdef) or
+              if (left.resulttype.def^.deftype=pointerdef) or
 
-                 (right.resulttype^.deftype=pointerdef) or
+                 (right.resulttype.def^.deftype=pointerdef) or
 
-                 (is_class_or_interface(right.resulttype) and is_class_or_interface(left.resulttype)) or
+                 (is_class_or_interface(right.resulttype.def) and is_class_or_interface(left.resulttype.def)) or
 
-                 (left.resulttype^.deftype=classrefdef) or
+                 (left.resulttype.def^.deftype=classrefdef) or
 
-                 (left.resulttype^.deftype=procvardef) or
+                 (left.resulttype.def^.deftype=procvardef) or
 
-                 ((left.resulttype^.deftype=enumdef) and
-                  (left.resulttype^.size=4)) or
+                 ((left.resulttype.def^.deftype=enumdef) and
+                  (left.resulttype.def^.size=4)) or
 
-                 ((left.resulttype^.deftype=orddef) and
-                 (porddef(left.resulttype)^.typ=s32bit)) or
-                 ((right.resulttype^.deftype=orddef) and
-                 (porddef(right.resulttype)^.typ=s32bit)) or
+                 ((left.resulttype.def^.deftype=orddef) and
+                 (porddef(left.resulttype.def)^.typ=s32bit)) or
+                 ((right.resulttype.def^.deftype=orddef) and
+                 (porddef(right.resulttype.def)^.typ=s32bit)) or
 
-                ((left.resulttype^.deftype=orddef) and
-                 (porddef(left.resulttype)^.typ=u32bit)) or
-                 ((right.resulttype^.deftype=orddef) and
-                 (porddef(right.resulttype)^.typ=u32bit)) or
+                ((left.resulttype.def^.deftype=orddef) and
+                 (porddef(left.resulttype.def)^.typ=u32bit)) or
+                 ((right.resulttype.def^.deftype=orddef) and
+                 (porddef(right.resulttype.def)^.typ=u32bit)) or
 
                 { as well as small sets }
                  is_set then
@@ -963,8 +945,8 @@ interface
           do_normal:
                    mboverflow:=false;
                    cmpop:=false;
-                   unsigned := not(is_signed(left.resulttype)) or
-                               not(is_signed(right.resulttype));
+                   unsigned := not(is_signed(left.resulttype.def)) or
+                               not(is_signed(right.resulttype.def));
                    case nodetype of
                       addn : begin
                                { this is a really ugly hack!!!!!!!!!! }
@@ -1070,7 +1052,6 @@ interface
                   ltn,lten,
                   gtn,gten,
            equaln,unequaln : begin
-{$IfNDef NoSetInclusion}
                                If is_set Then
                                  Case nodetype of
                                    lten,gten:
@@ -1116,7 +1097,6 @@ interface
                            {no < or > support for sets}
                                    ltn,gtn: CGMessage(type_e_mismatch);
                                  End;
-{$EndIf NoSetInclusion}
                                op:=A_CMP;
                                cmpop:=true;
                              end;
@@ -1154,7 +1134,7 @@ interface
                            { constant (JM)                             }
                            release_loc(right.location);
                            location.register := getregister32;
-                           emitloadord2reg(right.location,u32bitdef,location.register,false);
+                           emitloadord2reg(right.location,porddef(u32bittype.def),location.register,false);
                            emit_const_reg(A_SHL,S_L,power,location.register)
                          End
                        Else
@@ -1180,13 +1160,13 @@ interface
                          { left.location can be R_EAX !!! }
                          getexplicitregister32(R_EDI);
                          { load the left value }
-                         emitloadord2reg(left.location,u32bitdef,R_EDI,true);
+                         emitloadord2reg(left.location,porddef(u32bittype.def),R_EDI,true);
                          release_loc(left.location);
                          { allocate EAX }
                          if R_EAX in unused then
                            exprasmList.concat(Tairegalloc.Alloc(R_EAX));
                          { load he right value }
-                         emitloadord2reg(right.location,u32bitdef,R_EAX,true);
+                         emitloadord2reg(right.location,porddef(u32bittype.def),R_EAX,true);
                          release_loc(right.location);
                          { allocate EAX if it isn't yet allocated (JM) }
                          if (R_EAX in unused) then
@@ -1449,11 +1429,11 @@ interface
               else
 
               { Char type }
-                if ((left.resulttype^.deftype=orddef) and
-                    (porddef(left.resulttype)^.typ=uchar)) or
+                if ((left.resulttype.def^.deftype=orddef) and
+                    (porddef(left.resulttype.def)^.typ=uchar)) or
               { enumeration type 16 bit }
-                   ((left.resulttype^.deftype=enumdef) and
-                    (left.resulttype^.size=1)) then
+                   ((left.resulttype.def^.deftype=enumdef) and
+                    (left.resulttype.def^.size=1)) then
                  begin
                    case nodetype of
                       ltn,lten,gtn,gten,
@@ -1527,8 +1507,8 @@ interface
                 end
               else
               { 16 bit enumeration type }
-                if ((left.resulttype^.deftype=enumdef) and
-                    (left.resulttype^.size=2)) then
+                if ((left.resulttype.def^.deftype=enumdef) and
+                    (left.resulttype.def^.size=2)) then
                  begin
                    case nodetype of
                       ltn,lten,gtn,gten,
@@ -1602,14 +1582,14 @@ interface
                 end
               else
               { 64 bit types }
-              if is_64bitint(left.resulttype) then
+              if is_64bitint(left.resulttype.def) then
                 begin
                    mboverflow:=false;
                    cmpop:=false;
-                   unsigned:=((left.resulttype^.deftype=orddef) and
-                       (porddef(left.resulttype)^.typ=u64bit)) or
-                      ((right.resulttype^.deftype=orddef) and
-                       (porddef(right.resulttype)^.typ=u64bit));
+                   unsigned:=((left.resulttype.def^.deftype=orddef) and
+                       (porddef(left.resulttype.def)^.typ=u64bit)) or
+                      ((right.resulttype.def^.deftype=orddef) and
+                       (porddef(right.resulttype.def)^.typ=u64bit));
                    case nodetype of
                       addn : begin
                                 begin
@@ -1678,7 +1658,7 @@ interface
                         clear_location(hloc);
                         emit_pushq_loc(right.location);
                         saveregvars($ff);
-                        if porddef(resulttype)^.typ=u64bit then
+                        if porddef(resulttype.def)^.typ=u64bit then
                           emitcall('FPC_MUL_QWORD')
                         else
                           emitcall('FPC_MUL_INT64');
@@ -1944,8 +1924,7 @@ interface
                 end
               else
               { Floating point }
-               if (left.resulttype^.deftype=floatdef) and
-                  (pfloatdef(left.resulttype)^.typ<>f32bit) then
+               if (left.resulttype.def^.deftype=floatdef) then
                  begin
                     { real constants to the right, but only if it
                       isn't on the FPU stack, i.e. 1.0 or 0.0! }
@@ -1975,7 +1954,7 @@ interface
                               inc(fpuvaroffset);
                             end
                          else
-                           floatload(pfloatdef(right.resulttype)^.typ,right.location.reference);
+                           floatload(pfloatdef(right.resulttype.def)^.typ,right.location.reference);
                          if (left.location.loc<>LOC_FPU) then
                            begin
                               if left.location.loc=LOC_CFPUREGISTER then
@@ -1985,7 +1964,7 @@ interface
                                    inc(fpuvaroffset);
                                 end
                               else
-                                floatload(pfloatdef(left.resulttype)^.typ,left.location.reference)
+                                floatload(pfloatdef(left.resulttype.def)^.typ,left.location.reference)
                            end
                          { left was on the stack => swap }
                          else
@@ -2004,7 +1983,7 @@ interface
                               inc(fpuvaroffset);
                            end
                          else
-                           floatload(pfloatdef(left.resulttype)^.typ,left.location.reference)
+                           floatload(pfloatdef(left.resulttype.def)^.typ,left.location.reference)
                       end
                     { fpu operands are always in the wrong order on the stack }
                     else
@@ -2091,10 +2070,10 @@ interface
                else
 
                { MMX Arrays }
-                if is_mmx_able_array(left.resulttype) then
+                if is_mmx_able_array(left.resulttype.def) then
                  begin
                    cmpop:=false;
-                   mmxbase:=mmx_type(left.resulttype);
+                   mmxbase:=mmx_type(left.resulttype.def);
                    case nodetype of
                       addn : begin
                                 if (cs_mmx_saturation in aktlocalswitches) then
@@ -2294,7 +2273,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.9  2000-12-31 11:14:11  jonas
+  Revision 1.10  2001-04-02 21:20:36  peter
+    * resulttype rewrite
+
+  Revision 1.9  2000/12/31 11:14:11  jonas
     + implemented/fixed docompare() mathods for all nodes (not tested)
     + nopt.pas, nadd.pas, i386/n386opt.pas: optimized nodes for adding strings
       and constant strings/chars together

compiler/i386/n386bas.pas

@@ -152,7 +152,7 @@ unit n386bas;
          if not (nf_object_preserved in flags) then
           begin
 {$ifdef i386}
-            maybe_loadesi;
+            maybe_loadself;
 {$endif}
 {$ifdef m68k}
             maybe_loada5;
@@ -204,7 +204,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.5  2000-12-25 00:07:32  peter
+  Revision 1.6  2001-04-02 21:20:36  peter
+    * resulttype rewrite
+
+  Revision 1.5  2000/12/25 00:07:32  peter
     + new tlinkedlist class (merge of old tstringqueue,tcontainer and
       tlinkedlist objects)
 

compiler/i386/n386cal.pas

@@ -106,7 +106,7 @@ implementation
          getlabel(falselabel);
          secondpass(left);
          { filter array constructor with c styled args }
-         if is_array_constructor(left.resulttype) and (nf_cargs in left.flags) then
+         if is_array_constructor(left.resulttype.def) and (nf_cargs in left.flags) then
            begin
              { nothing, everything is already pushed }
            end
@@ -178,7 +178,7 @@ implementation
            end
          else
            begin
-              tempdeftype:=resulttype^.deftype;
+              tempdeftype:=resulttype.def^.deftype;
               if tempdeftype=filedef then
                CGMessage(cg_e_file_must_call_by_reference);
               { open array must always push the address, this is needed to
@@ -189,7 +189,7 @@ implementation
                    is_array_of_const(defcoll.paratype.def))
                  ) or
                  (
-                  push_addr_param(resulttype) and
+                  push_addr_param(resulttype.def) and
                   not is_cdecl
                  ) then
                 begin
@@ -364,7 +364,7 @@ implementation
             (right=nil)) and
             (procdefinition^.proctypeoption=potype_constructor) and
             { quick'n'dirty check if it is a class or an object }
-            (resulttype^.deftype=orddef) then
+            (resulttype.def^.deftype=orddef) then
            pop_allowed:=false
          else
            pop_allowed:=true;
@@ -415,8 +415,8 @@ implementation
          else
 {$endif dummy}
            pop_esp:=false;
-         if (resulttype<>pdef(voiddef)) and
-            ret_in_param(resulttype) then
+         if (not is_void(resulttype.def)) and
+            ret_in_param(resulttype.def) then
            begin
               funcretref.symbol:=nil;
 {$ifdef test_dest_loc}
@@ -449,7 +449,7 @@ implementation
                 para_offset:=0;
               if not(inlined) and
                  assigned(right) then
-                tcallparanode(params).secondcallparan(TParaItem(pabstractprocdef(right.resulttype)^.Para.first),
+                tcallparanode(params).secondcallparan(TParaItem(pabstractprocdef(right.resulttype.def)^.Para.first),
                   (pocall_leftright in procdefinition^.proccalloptions),inlined,
                   (([pocall_cdecl,pocall_cppdecl]*procdefinition^.proccalloptions)<>[]),
                   para_alignment,para_offset)
@@ -461,7 +461,7 @@ implementation
            end;
          if inlined then
            inlinecode.retoffset:=gettempofsizepersistant(4);
-         if ret_in_param(resulttype) then
+         if ret_in_param(resulttype.def) then
            begin
               { This must not be counted for C code
                 complex return address is removed from stack
@@ -522,7 +522,7 @@ implementation
                    r^:=twithnode(pwithsymtable(symtableproc)^.withnode).withreference^;
                    if ((not(nf_islocal in twithnode(pwithsymtable(symtableproc)^.withnode).flags)) and
                        (not pwithsymtable(symtableproc)^.direct_with)) or
-                      is_class_or_interface(methodpointer.resulttype) then
+                      is_class_or_interface(methodpointer.resulttype.def) then
                      emit_ref_reg(A_MOV,S_L,r,R_ESI)
                    else
                      emit_ref_reg(A_LEA,S_L,r,R_ESI);
@@ -536,7 +536,7 @@ implementation
                    if assigned(methodpointer) then
                      begin
                         {
-                        if methodpointer^.resulttype=classrefdef then
+                        if methodpointer^.resulttype.def=classrefdef then
                           begin
                               two possibilities:
                                1. constructor
@@ -567,12 +567,12 @@ implementation
 {$ifndef noAllocEDI}
                                          getexplicitregister32(R_ESI);
 {$endif noAllocEDI}
-                                         if not(oo_has_vmt in pobjectdef(methodpointer.resulttype)^.objectoptions) then
+                                         if not(oo_has_vmt in pobjectdef(methodpointer.resulttype.def)^.objectoptions) then
                                            emit_const_reg(A_MOV,S_L,0,R_ESI)
                                          else
                                            begin
                                              emit_sym_ofs_reg(A_MOV,S_L,
-                                               newasmsymbol(pobjectdef(methodpointer.resulttype)^.vmt_mangledname),
+                                               newasmsymbol(pobjectdef(methodpointer.resulttype.def)^.vmt_mangledname),
                                                0,R_ESI);
                                            end;
                                          { emit_reg(A_PUSH,S_L,R_ESI);
@@ -583,7 +583,7 @@ implementation
                                       loadesi:=false;
 
                                     { a class destructor needs a flag }
-                                    if is_class(pobjectdef(methodpointer.resulttype)) and
+                                    if is_class(pobjectdef(methodpointer.resulttype.def)) and
                                        {assigned(aktprocsym) and
                                        (aktprocsym^.definition^.proctypeoption=potype_destructor)}
                                        (procdefinition^.proctypeoption=potype_destructor) then
@@ -593,7 +593,7 @@ implementation
                                       end;
 
                                     if not(is_con_or_destructor and
-                                           is_class(methodpointer.resulttype) and
+                                           is_class(methodpointer.resulttype.def) and
                                            {assigned(aktprocsym) and
                                           (aktprocsym^.definition^.proctypeoption in [potype_constructor,potype_destructor])}
                                            (procdefinition^.proctypeoption in [potype_constructor,potype_destructor])
@@ -604,7 +604,7 @@ implementation
                                     { will be made                                  }
                                     { con- and destructors need a pointer to the vmt }
                                     if is_con_or_destructor and
-                                      is_object(methodpointer.resulttype) and
+                                      is_object(methodpointer.resulttype.def) and
                                       assigned(aktprocsym) then
                                       begin
                                          if not(aktprocsym^.definition^.proctypeoption in
@@ -615,12 +615,12 @@ implementation
                                     { constructor flags ?                    }
                                     if is_con_or_destructor and
                                       not(
-                                        is_class(methodpointer.resulttype) and
+                                        is_class(methodpointer.resulttype.def) and
                                         assigned(aktprocsym) and
                                         (aktprocsym^.definition^.proctypeoption=potype_destructor)) then
                                       begin
                                          { a constructor needs also a flag }
-                                         if is_class(methodpointer.resulttype) then
+                                         if is_class(methodpointer.resulttype.def) then
                                            push_int(0);
                                          push_int(0);
                                       end;
@@ -636,7 +636,7 @@ implementation
                                     emit_reg(A_PUSH,S_L,R_ESI);
                                     { insert the vmt }
                                     emit_sym(A_PUSH,S_L,
-                                      newasmsymbol(pobjectdef(methodpointer.resulttype)^.vmt_mangledname));
+                                      newasmsymbol(pobjectdef(methodpointer.resulttype.def)^.vmt_mangledname));
                                     extended_new:=true;
                                  end;
                                hdisposen:
@@ -653,7 +653,7 @@ implementation
                                     del_reference(methodpointer.location.reference);
                                     emit_reg(A_PUSH,S_L,R_ESI);
                                     emit_sym(A_PUSH,S_L,
-                                      newasmsymbol(pobjectdef(methodpointer.resulttype)^.vmt_mangledname));
+                                      newasmsymbol(pobjectdef(methodpointer.resulttype.def)^.vmt_mangledname));
                                  end;
                                else
                                  begin
@@ -673,8 +673,8 @@ implementation
                                               end;
                                             else
                                               begin
-                                                 if (methodpointer.resulttype^.deftype=classrefdef) or
-                                                    is_class_or_interface(methodpointer.resulttype) then
+                                                 if (methodpointer.resulttype.def^.deftype=classrefdef) or
+                                                    is_class_or_interface(methodpointer.resulttype.def) then
                                                    emit_ref_reg(A_MOV,S_L,
                                                      newreference(methodpointer.location.reference),R_ESI)
                                                  else
@@ -689,7 +689,7 @@ implementation
                                     if not(po_containsself in procdefinition^.procoptions) then
                                       begin
                                         if (po_classmethod in procdefinition^.procoptions) and
-                                           not(methodpointer.resulttype^.deftype=classrefdef) then
+                                           not(methodpointer.resulttype.def^.deftype=classrefdef) then
                                           begin
                                              { class method needs current VMT }
                                              getexplicitregister32(R_ESI);
@@ -702,12 +702,12 @@ implementation
 
                                         { direct call to destructor: remove data }
                                         if (procdefinition^.proctypeoption=potype_destructor) and
-                                           is_class(methodpointer.resulttype) then
+                                           is_class(methodpointer.resulttype.def) then
                                           emit_const(A_PUSH,S_L,1);
 
                                         { direct call to class constructor, don't allocate memory }
                                         if (procdefinition^.proctypeoption=potype_constructor) and
-                                           is_class(methodpointer.resulttype) then
+                                           is_class(methodpointer.resulttype.def) then
                                           begin
                                              emit_const(A_PUSH,S_L,0);
                                              emit_const(A_PUSH,S_L,0);
@@ -716,8 +716,8 @@ implementation
                                           begin
                                              { constructor call via classreference => allocate memory }
                                              if (procdefinition^.proctypeoption=potype_constructor) and
-                                                (methodpointer.resulttype^.deftype=classrefdef) and
-                                                is_class(pclassrefdef(methodpointer.resulttype)^.pointertype.def) then
+                                                (methodpointer.resulttype.def^.deftype=classrefdef) and
+                                                is_class(pclassrefdef(methodpointer.resulttype.def)^.pointertype.def) then
                                                 emit_const(A_PUSH,S_L,1);
                                              emit_reg(A_PUSH,S_L,R_ESI);
                                           end;
@@ -726,13 +726,13 @@ implementation
                                     if is_con_or_destructor then
                                       begin
                                          { classes don't get a VMT pointer pushed }
-                                         if is_object(methodpointer.resulttype) then
+                                         if is_object(methodpointer.resulttype.def) then
                                            begin
                                               if (procdefinition^.proctypeoption=potype_constructor) then
                                                 begin
                                                    { it's no bad idea, to insert the VMT }
                                                    emit_sym(A_PUSH,S_L,newasmsymbol(
-                                                     pobjectdef(methodpointer.resulttype)^.vmt_mangledname));
+                                                     pobjectdef(methodpointer.resulttype.def)^.vmt_mangledname));
                                                 end
                                               { destructors haven't to dispose the instance, if this is }
                                               { a direct call                                           }
@@ -807,7 +807,7 @@ implementation
                 if (procdefinition^.proctypeoption=potype_destructor) and
                    assigned(methodpointer) and
                    (methodpointer.nodetype<>typen) and
-                   is_class(pobjectdef(methodpointer.resulttype)) and
+                   is_class(pobjectdef(methodpointer.resulttype.def)) and
                    (inlined or
                    (right=nil)) then
                   begin
@@ -898,7 +898,7 @@ implementation
                         ((procdefinition^.proctypeoption=potype_constructor) and
                         { esi contains the vmt if we call a constructor via a class ref }
                          assigned(methodpointer) and
-                         (methodpointer.resulttype^.deftype=classrefdef)
+                         (methodpointer.resulttype.def^.deftype=classrefdef)
                         ) or
                         { is_interface(pprocdef(procdefinition)^._class) or }
                         { ESI is loaded earlier }
@@ -1114,7 +1114,7 @@ implementation
            end;
 
          { call to AfterConstruction? }
-         if is_class(resulttype) and
+         if is_class(resulttype.def) and
            (inlined or
            (right=nil)) and
            (procdefinition^.proctypeoption=potype_constructor) and
@@ -1143,7 +1143,7 @@ implementation
          { handle function results }
          { structured results are easy to handle.... }
          { needed also when result_no_used !! }
-         if (resulttype<>pdef(voiddef)) and ret_in_param(resulttype) then
+         if (not is_void(resulttype.def)) and ret_in_param(resulttype.def) then
            begin
               location.loc:=LOC_MEM;
               location.reference.symbol:=nil;
@@ -1151,15 +1151,15 @@ implementation
            end;
          { we have only to handle the result if it is used, but }
          { ansi/widestrings must be registered, so we can dispose them }
-         if (resulttype<>pdef(voiddef)) and ((nf_return_value_used in flags) or
-           is_ansistring(resulttype) or is_widestring(resulttype)) then
+         if (not is_void(resulttype.def)) and ((nf_return_value_used in flags) or
+           is_ansistring(resulttype.def) or is_widestring(resulttype.def)) then
            begin
               { a contructor could be a function with boolean result }
               if (inlined or
                   (right=nil)) and
                  (procdefinition^.proctypeoption=potype_constructor) and
                  { quick'n'dirty check if it is a class or an object }
-                 (resulttype^.deftype=orddef) then
+                 (resulttype.def^.deftype=orddef) then
                 begin
                    { this fails if popsize > 0 PM }
                    location.loc:=LOC_FLAGS;
@@ -1181,7 +1181,7 @@ implementation
                      end;
                 end
                { structed results are easy to handle.... }
-              else if ret_in_param(resulttype) then
+              else if ret_in_param(resulttype.def) then
                 begin
                    {location.loc:=LOC_MEM;
                    stringdispose(location.reference.symbol);
@@ -1190,10 +1190,10 @@ implementation
                 end
               else
                 begin
-                   if (resulttype^.deftype in [orddef,enumdef]) then
+                   if (resulttype.def^.deftype in [orddef,enumdef]) then
                      begin
                         location.loc:=LOC_REGISTER;
-                        case resulttype^.size of
+                        case resulttype.def^.size of
                           4 :
                             begin
 {$ifdef test_dest_loc}
@@ -1257,35 +1257,18 @@ implementation
                      end
 
                 end
-              else if (resulttype^.deftype=floatdef) then
-                case pfloatdef(resulttype)^.typ of
-                  f32bit:
-                    begin
-                       location.loc:=LOC_REGISTER;
-{$ifdef test_dest_loc}
-                       if dest_loc_known and (dest_loc_tree=p) then
-                         mov_reg_to_dest(p,S_L,R_EAX)
-                       else
-{$endif test_dest_loc}
-                         begin
-                            hregister:=getexplicitregister32(R_EAX);
-                            emit_reg_reg(A_MOV,S_L,R_EAX,hregister);
-                            location.register:=hregister;
-                         end;
-                    end;
-                  else
-                    begin
-                       location.loc:=LOC_FPU;
-                       inc(fpuvaroffset);
-                    end;
+              else if (resulttype.def^.deftype=floatdef) then
+                begin
+                  location.loc:=LOC_FPU;
+                  inc(fpuvaroffset);
                 end
-              else if is_ansistring(resulttype) or
-                is_widestring(resulttype) then
+              else if is_ansistring(resulttype.def) or
+                is_widestring(resulttype.def) then
                 begin
                    hregister:=getexplicitregister32(R_EAX);
                    emit_reg_reg(A_MOV,S_L,R_EAX,hregister);
                    gettempansistringreference(hr);
-                   decrstringref(resulttype,hr);
+                   decrstringref(resulttype.def,hr);
                    emit_reg_ref(A_MOV,S_L,hregister,
                      newreference(hr));
                    ungetregister32(hregister);
@@ -1323,7 +1306,7 @@ implementation
 
          { at last, restore instance pointer (SELF) }
          if loadesi then
-           maybe_loadesi;
+           maybe_loadself;
          pp:=tbinarynode(params);
          while assigned(pp) do
            begin
@@ -1355,17 +1338,17 @@ implementation
 
 
          { from now on the result can be freed normally }
-         if inlined and ret_in_param(resulttype) then
+         if inlined and ret_in_param(resulttype.def) then
            persistanttemptonormal(funcretref.offset);
 
          { if return value is not used }
-         if (not(nf_return_value_used in flags)) and (resulttype<>pdef(voiddef)) then
+         if (not(nf_return_value_used in flags)) and (not is_void(resulttype.def)) then
            begin
               if location.loc in [LOC_MEM,LOC_REFERENCE] then
                 begin
                    { data which must be finalized ? }
-                   if (resulttype^.needs_inittable) then
-                      finalize(resulttype,location.reference,false);
+                   if (resulttype.def^.needs_inittable) then
+                      finalize(resulttype.def,location.reference,false);
                    { release unused temp }
                    ungetiftemp(location.reference)
                 end
@@ -1589,7 +1572,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.19  2001-03-11 22:58:51  peter
+  Revision 1.20  2001-04-02 21:20:36  peter
+    * resulttype rewrite
+
+  Revision 1.19  2001/03/11 22:58:51  peter
     * getsym redesign, removed the globals srsym,srsymtable
 
   Revision 1.18  2001/01/27 21:29:35  florian
@@ -1614,7 +1600,7 @@ end.
     * added lots of longint typecast to prevent range check errors in the
       compiler and rtl
     * type casts of symbolic ordinal constants are now preserved
-    * fixed bug where the original resulttype wasn't restored correctly
+    * fixed bug where the original resulttype.def wasn't restored correctly
       after doing a 64bit rangecheck
 
   Revision 1.13  2000/12/05 11:44:33  jonas

compiler/i386/n386cnv.pas

@@ -40,11 +40,8 @@ interface
           procedure second_chararray_to_string;virtual;
           procedure second_char_to_string;virtual;
           procedure second_int_to_real;virtual;
-          procedure second_real_to_fix;virtual;
           procedure second_real_to_real;virtual;
-          procedure second_fix_to_real;virtual;
           procedure second_cord_to_pointer;virtual;
-          procedure second_int_to_fix;virtual;
           procedure second_proc_to_procvar;virtual;
           procedure second_bool_to_int;virtual;
           procedure second_int_to_bool;virtual;
@@ -91,27 +88,27 @@ implementation
       begin
         { insert range check if not explicit conversion }
         if not(nf_explizit in flags) then
-          emitrangecheck(left,resulttype);
+          emitrangecheck(left,resulttype.def);
 
         { is the result size smaller ? }
-        if resulttype^.size<left.resulttype^.size then
+        if resulttype.def^.size<left.resulttype.def^.size then
           begin
             { only need to set the new size of a register }
             if (left.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then
              begin
-               case resulttype^.size of
+               case resulttype.def^.size of
                 1 : location.register:=makereg8(left.location.register);
                 2 : location.register:=makereg16(left.location.register);
                 4 : location.register:=makereg32(left.location.register);
                end;
                { we can release the upper register }
-               if is_64bitint(left.resulttype) then
+               if is_64bitint(left.resulttype.def) then
                  ungetregister32(left.location.registerhigh);
              end;
           end
 
         { is the result size bigger ? }
-        else if resulttype^.size>left.resulttype^.size then
+        else if resulttype.def^.size>left.resulttype.def^.size then
           begin
             { remove reference }
             if not(left.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then
@@ -125,19 +122,19 @@ implementation
               movz doesn't support constant values }
             if (left.location.loc=LOC_MEM) and (left.location.reference.is_immediate) then
              begin
-               if is_64bitint(resulttype) then
+               if is_64bitint(resulttype.def) then
                  opsize:=S_L
                else
-                 opsize:=def_opsize(resulttype);
+                 opsize:=def_opsize(resulttype.def);
                op:=A_MOV;
              end
             else
              begin
-               opsize:=def2def_opsize(left.resulttype,resulttype);
+               opsize:=def2def_opsize(left.resulttype.def,resulttype.def);
                if opsize in [S_B,S_W,S_L] then
                 op:=A_MOV
                else
-                if is_signed(left.resulttype) then
+                if is_signed(left.resulttype.def) then
                  op:=A_MOVSX
                 else
                  op:=A_MOVZX;
@@ -153,12 +150,12 @@ implementation
             location.loc:=LOC_REGISTER;
 
             { do we need a second register for a 64 bit type ? }
-            if is_64bitint(resulttype) then
+            if is_64bitint(resulttype.def) then
               begin
                  hregister2:=getregister32;
                  location.registerhigh:=hregister2;
               end;
-            case resulttype^.size of
+            case resulttype.def^.size of
              1:
                location.register:=makereg8(hregister);
              2:
@@ -174,7 +171,7 @@ implementation
                 newreference(left.location.reference),location.register);
 
             { do we need a sign extension for int64? }
-            if is_64bitint(resulttype) then
+            if is_64bitint(resulttype.def) then
               { special case for constants (JM) }
               if is_constintnode(left) then
                 begin
@@ -188,8 +185,8 @@ implementation
                 begin
                   emit_reg_reg(A_XOR,S_L,
                     hregister2,hregister2);
-                  if (porddef(resulttype)^.typ=s64bit) and
-                    is_signed(left.resulttype) then
+                  if (porddef(resulttype.def)^.typ=s64bit) and
+                    is_signed(left.resulttype.def) then
                     begin
                        getlabel(l);
                        emit_const_reg(A_TEST,S_L,longint($80000000),makereg32(hregister));
@@ -211,15 +208,15 @@ implementation
       begin
          { does anybody know a better solution than this big case statement ? }
          { ok, a proc table would do the job                              }
-         case pstringdef(resulttype)^.string_typ of
+         case pstringdef(resulttype.def)^.string_typ of
 
             st_shortstring:
-              case pstringdef(left.resulttype)^.string_typ of
+              case pstringdef(left.resulttype.def)^.string_typ of
                  st_shortstring:
                    begin
-                      gettempofsizereference(resulttype^.size,location.reference);
+                      gettempofsizereference(resulttype.def^.size,location.reference);
                       copyshortstring(location.reference,left.location.reference,
-                        pstringdef(resulttype)^.len,false,true);
+                        pstringdef(resulttype.def)^.len,false,true);
 {                      done by copyshortstring now (JM)          }
 {                      del_reference(left.location.reference); }
                       ungetiftemp(left.location.reference);
@@ -231,7 +228,7 @@ implementation
                    end;
                  st_ansistring:
                    begin
-                      gettempofsizereference(resulttype^.size,location.reference);
+                      gettempofsizereference(resulttype.def^.size,location.reference);
                       loadansi2short(left,self);
                       { this is done in secondtypeconv (FK)
                       removetemps(exprasmlist,temptoremove);
@@ -246,7 +243,7 @@ implementation
               end;
 
             st_longstring:
-              case pstringdef(left.resulttype)^.string_typ of
+              case pstringdef(left.resulttype.def)^.string_typ of
                  st_shortstring:
                    begin
                       {!!!!!!!}
@@ -265,13 +262,13 @@ implementation
               end;
 
             st_ansistring:
-              case pstringdef(left.resulttype)^.string_typ of
+              case pstringdef(left.resulttype.def)^.string_typ of
                  st_shortstring:
                    begin
                       clear_location(location);
                       location.loc:=LOC_REFERENCE;
                       gettempansistringreference(location.reference);
-                      decrstringref(cansistringdef,location.reference);
+                      decrstringref(cansistringtype.def,location.reference);
                       { We don't need the source regs anymore (JM) }
                       regs_to_push := $ff;
                       remove_non_regvars_from_loc(left.location,regs_to_push);
@@ -281,7 +278,7 @@ implementation
                       emit_push_lea_loc(location,false);
                       saveregvars(regs_to_push);
                       emitcall('FPC_SHORTSTR_TO_ANSISTR');
-                      maybe_loadesi;
+                      maybe_loadself;
                       popusedregisters(pushed);
                    end;
                  st_longstring:
@@ -297,7 +294,7 @@ implementation
               end;
 
             st_widestring:
-              case pstringdef(left.resulttype)^.string_typ of
+              case pstringdef(left.resulttype.def)^.string_typ of
                  st_shortstring:
                    begin
                       {!!!!!!!}
@@ -330,7 +327,7 @@ implementation
          clear_location(location);
          location.loc:=LOC_REGISTER;
          location.register:=getregister32;
-         case pstringdef(left.resulttype)^.string_typ of
+         case pstringdef(left.resulttype.def)^.string_typ of
            st_shortstring :
              begin
                inc(left.location.reference.offset);
@@ -373,7 +370,7 @@ implementation
          arrsize, strtype: longint;
          regstopush: byte;
       begin
-         with parraydef(resulttype)^ do
+         with parraydef(resulttype.def)^ do
           begin
             if highrange<lowrange then
              internalerror(75432653);
@@ -383,7 +380,7 @@ implementation
          if (left.nodetype = stringconstn) and
             { left.length+1 since there's always a terminating #0 character (JM) }
             (tstringconstnode(left).len+1 >= arrsize) and
-            (pstringdef(left.resulttype)^.string_typ=st_shortstring) then
+            (pstringdef(left.resulttype.def)^.string_typ=st_shortstring) then
            begin
              inc(location.reference.offset);
              exit;
@@ -398,7 +395,7 @@ implementation
 
          emit_push_lea_loc(location,false);
 
-         case pstringdef(left.resulttype)^.string_typ of
+         case pstringdef(left.resulttype.def)^.string_typ of
            st_shortstring :
              begin
                { 0 means shortstring }
@@ -495,12 +492,12 @@ implementation
          l : longint;
       begin
          { calc the length of the array }
-         l:=parraydef(left.resulttype)^.highrange-parraydef(left.resulttype)^.lowrange+1;
+         l:=parraydef(left.resulttype.def)^.highrange-parraydef(left.resulttype.def)^.lowrange+1;
          { this is a type conversion which copies the data, so we can't }
          { return a reference                                        }
          clear_location(location);
          location.loc:=LOC_MEM;
-         case pstringdef(resulttype)^.string_typ of
+         case pstringdef(resulttype.def)^.string_typ of
            st_shortstring :
              begin
                if l>255 then
@@ -508,15 +505,15 @@ implementation
                   CGMessage(type_e_mismatch);
                   l:=255;
                 end;
-               gettempofsizereference(resulttype^.size,location.reference);
+               gettempofsizereference(resulttype.def^.size,location.reference);
                { we've also to release the registers ... }
                { Yes, but before pushusedregisters since that one resets unused! }
                { This caused web bug 1073 (JM)                                   }
                regstopush := $ff;
                remove_non_regvars_from_loc(left.location,regstopush);
                pushusedregisters(pushed,regstopush);
-               if l>=resulttype^.size then
-                 push_int(resulttype^.size-1)
+               if l>=resulttype.def^.size then
+                 push_int(resulttype.def^.size-1)
                else
                  push_int(l);
                { ... here only the temp. location is released }
@@ -525,13 +522,13 @@ implementation
                emitpushreferenceaddr(location.reference);
                saveregvars(regstopush);
                emitcall('FPC_CHARARRAY_TO_SHORTSTR');
-               maybe_loadesi;
+               maybe_loadself;
                popusedregisters(pushed);
              end;
            st_ansistring :
              begin
                gettempansistringreference(location.reference);
-               decrstringref(cansistringdef,location.reference);
+               decrstringref(cansistringtype.def,location.reference);
                regstopush := $ff;
                remove_non_regvars_from_loc(left.location,regstopush);
                pushusedregisters(pushed,regstopush);
@@ -542,7 +539,7 @@ implementation
                saveregvars(regstopush);
                emitcall('FPC_CHARARRAY_TO_ANSISTR');
                popusedregisters(pushed);
-               maybe_loadesi;
+               maybe_loadself;
              end;
            st_longstring:
              begin
@@ -565,7 +562,7 @@ implementation
       begin
          clear_location(location);
          location.loc:=LOC_MEM;
-         case pstringdef(resulttype)^.string_typ of
+         case pstringdef(resulttype.def)^.string_typ of
            st_shortstring :
              begin
                gettempofsizereference(256,location.reference);
@@ -574,7 +571,7 @@ implementation
            st_ansistring :
              begin
                gettempansistringreference(location.reference);
-               decrstringref(cansistringdef,location.reference);
+               decrstringref(cansistringtype.def,location.reference);
                release_loc(left.location);
                pushusedregisters(pushed,$ff);
                emit_pushw_loc(left.location);
@@ -582,7 +579,7 @@ implementation
                saveregvars($ff);
                emitcall('FPC_CHAR_TO_ANSISTR');
                popusedregisters(pushed);
-               maybe_loadesi;
+               maybe_loadself;
              end;
            else
             internalerror(4179);
@@ -601,16 +598,16 @@ implementation
          { for u32bit a solution is to push $0 and to load a comp }
          { does this first, it destroys maybe EDI }
          hregister:=R_EDI;
-         if porddef(left.resulttype)^.typ=u32bit then
+         if porddef(left.resulttype.def)^.typ=u32bit then
             push_int(0);
          if (left.location.loc=LOC_REGISTER) or
             (left.location.loc=LOC_CREGISTER) then
            begin
 {$ifndef noAllocEdi}
-              if not (porddef(left.resulttype)^.typ in [u32bit,s32bit,u64bit,s64bit]) then
+              if not (porddef(left.resulttype.def)^.typ in [u32bit,s32bit,u64bit,s64bit]) then
                 getexplicitregister32(R_EDI);
 {$endif noAllocEdi}
-              case porddef(left.resulttype)^.typ of
+              case porddef(left.resulttype.def)^.typ of
                  s8bit : emit_reg_reg(A_MOVSX,S_BL,left.location.register,R_EDI);
                  u8bit : emit_reg_reg(A_MOVZX,S_BL,left.location.register,R_EDI);
                  s16bit : emit_reg_reg(A_MOVSX,S_WL,left.location.register,R_EDI);
@@ -631,7 +628,7 @@ implementation
 {$ifndef noAllocEdi}
               getexplicitregister32(R_EDI);
 {$endif noAllocEdi}
-              case porddef(left.resulttype)^.typ of
+              case porddef(left.resulttype.def)^.typ of
                  s8bit:
                    emit_ref_reg(A_MOVSX,S_BL,r,R_EDI);
                  u8bit:
@@ -661,7 +658,7 @@ implementation
            ungetregister32(R_EDI);
 {$endif noAllocEdi}
          r:=new_reference(R_ESP,0);
-         case porddef(left.resulttype)^.typ of
+         case porddef(left.resulttype.def)^.typ of
            u32bit:
              begin
                 emit_ref(A_FILD,S_IQ,r);
@@ -722,51 +719,6 @@ implementation
       end;
 
 
-    procedure ti386typeconvnode.second_real_to_fix;
-      var
-         rreg : tregister;
-         ref : treference;
-      begin
-         { real must be on fpu stack }
-         if (left.location.loc<>LOC_FPU) then
-           emit_ref(A_FLD,S_FL,newreference(left.location.reference));
-         push_int($1f3f);
-         push_int(65536);
-         reset_reference(ref);
-         ref.base:=R_ESP;
-
-         emit_ref(A_FIMUL,S_IL,newreference(ref));
-
-         ref.offset:=4;
-         emit_ref(A_FSTCW,S_NO,newreference(ref));
-
-         ref.offset:=6;
-         emit_ref(A_FLDCW,S_NO,newreference(ref));
-
-         ref.offset:=0;
-         emit_ref(A_FISTP,S_IL,newreference(ref));
-
-         ref.offset:=4;
-         emit_ref(A_FLDCW,S_NO,newreference(ref));
-
-         rreg:=getregister32;
-         emit_reg(A_POP,S_L,rreg);
-         { better than an add on all processors }
-{$ifndef noAllocEdi}
-         getexplicitregister32(R_EDI);
-{$endif noAllocEdi}
-         emit_reg(A_POP,S_L,R_EDI);
-{$ifndef noAllocEdi}
-         ungetregister32(R_EDI);
-{$endif noAllocEdi}
-
-         clear_location(location);
-         location.loc:=LOC_REGISTER;
-         location.register:=rreg;
-         inc(fpuvaroffset);
-      end;
-
-
     procedure ti386typeconvnode.second_real_to_real;
       begin
          case left.location.loc of
@@ -779,7 +731,7 @@ implementation
             LOC_MEM,
             LOC_REFERENCE:
               begin
-                 floatload(pfloatdef(left.resulttype)^.typ,
+                 floatload(pfloatdef(left.resulttype.def)^.typ,
                    left.location.reference);
                  { we have to free the reference }
                  del_reference(left.location.reference);
@@ -790,84 +742,6 @@ implementation
       end;
 
 
-    procedure ti386typeconvnode.second_fix_to_real;
-      var
-        popeax,popebx,popecx,popedx : boolean;
-        startreg : tregister;
-        hl : pasmlabel;
-        r : treference;
-      begin
-         if (left.location.loc=LOC_REGISTER) or
-            (left.location.loc=LOC_CREGISTER) then
-           begin
-              startreg:=left.location.register;
-              ungetregister(startreg);
-              popeax:=(startreg<>R_EAX) and not (R_EAX in unused);
-              if popeax then
-                emit_reg(A_PUSH,S_L,R_EAX);
-              { mov eax,eax is removed by emit_reg_reg }
-              emit_reg_reg(A_MOV,S_L,startreg,R_EAX);
-           end
-         else
-           begin
-              emit_ref_reg(A_MOV,S_L,newreference(
-                left.location.reference),R_EAX);
-              del_reference(left.location.reference);
-              startreg:=R_NO;
-           end;
-
-         popebx:=(startreg<>R_EBX) and not (R_EBX in unused);
-         if popebx then
-           emit_reg(A_PUSH,S_L,R_EBX);
-
-         popecx:=(startreg<>R_ECX) and not (R_ECX in unused);
-         if popecx then
-           emit_reg(A_PUSH,S_L,R_ECX);
-
-         popedx:=(startreg<>R_EDX) and not (R_EDX in unused);
-         if popedx then
-           emit_reg(A_PUSH,S_L,R_EDX);
-
-         emit_none(A_CDQ,S_NO);
-         emit_reg_reg(A_XOR,S_L,R_EDX,R_EAX);
-         emit_reg_reg(A_MOV,S_L,R_EAX,R_EBX);
-         emit_reg_reg(A_SUB,S_L,R_EDX,R_EAX);
-         getlabel(hl);
-         emitjmp(C_Z,hl);
-         emit_const_reg(A_RCL,S_L,1,R_EBX);
-         emit_reg_reg(A_BSR,S_L,R_EAX,R_EDX);
-         emit_const_reg(A_MOV,S_B,32,R_CL);
-         emit_reg_reg(A_SUB,S_B,R_DL,R_CL);
-         emit_reg_reg(A_SHL,S_L,R_CL,R_EAX);
-         emit_const_reg(A_ADD,S_W,1007,R_DX);
-         emit_const_reg(A_SHL,S_W,5,R_DX);
-         emit_const_reg_reg(A_SHLD,S_W,11,R_DX,R_BX);
-         emit_const_reg_reg(A_SHLD,S_L,20,R_EAX,R_EBX);
-
-         emit_const_reg(A_SHL,S_L,20,R_EAX);
-         emitlab(hl);
-         { better than an add on all processors }
-         emit_reg(A_PUSH,S_L,R_EBX);
-         emit_reg(A_PUSH,S_L,R_EAX);
-
-         reset_reference(r);
-         r.base:=R_ESP;
-         emit_ref(A_FLD,S_FL,newreference(r));
-         emit_const_reg(A_ADD,S_L,8,R_ESP);
-         if popedx then
-           emit_reg(A_POP,S_L,R_EDX);
-         if popecx then
-           emit_reg(A_POP,S_L,R_ECX);
-         if popebx then
-           emit_reg(A_POP,S_L,R_EBX);
-         if popeax then
-           emit_reg(A_POP,S_L,R_EAX);
-
-         clear_location(location);
-         location.loc:=LOC_FPU;
-      end;
-
-
     procedure ti386typeconvnode.second_cord_to_pointer;
       begin
         { this can't happend, because constants are already processed in
@@ -876,40 +750,6 @@ implementation
       end;
 
 
-    procedure ti386typeconvnode.second_int_to_fix;
-      var
-         hregister : tregister;
-      begin
-         if (left.location.loc=LOC_REGISTER) then
-           hregister:=left.location.register
-         else if (left.location.loc=LOC_CREGISTER) then
-           hregister:=getregister32
-         else
-           begin
-              del_reference(left.location.reference);
-              hregister:=getregister32;
-              case porddef(left.resulttype)^.typ of
-                s8bit : emit_ref_reg(A_MOVSX,S_BL,newreference(left.location.reference),
-                  hregister);
-                u8bit : emit_ref_reg(A_MOVZX,S_BL,newreference(left.location.reference),
-                  hregister);
-                s16bit : emit_ref_reg(A_MOVSX,S_WL,newreference(left.location.reference),
-                  hregister);
-                u16bit : emit_ref_reg(A_MOVZX,S_WL,newreference(left.location.reference),
-                  hregister);
-                u32bit,s32bit : emit_ref_reg(A_MOV,S_L,newreference(left.location.reference),
-                  hregister);
-                {!!!! u32bit }
-              end;
-           end;
-         emit_const_reg(A_SHL,S_L,16,hregister);
-
-         clear_location(location);
-         location.loc:=LOC_REGISTER;
-         location.register:=hregister;
-      end;
-
-
     procedure ti386typeconvnode.second_proc_to_procvar;
       begin
         { method pointer ? }
@@ -945,7 +785,7 @@ implementation
          { byte(boolean) or word(wordbool) or longint(longbool) must
          be accepted for var parameters }
          if (nf_explizit in flags) and
-            (left.resulttype^.size=resulttype^.size) and
+            (left.resulttype.def^.size=resulttype.def^.size) and
             (left.location.loc in [LOC_REFERENCE,LOC_MEM,LOC_CREGISTER]) then
            begin
               set_location(location,left.location);
@@ -956,16 +796,16 @@ implementation
          clear_location(location);
          location.loc:=LOC_REGISTER;
          del_reference(left.location.reference);
-         case left.resulttype^.size of
+         case left.resulttype.def^.size of
           1 : begin
-                case resulttype^.size of
+                case resulttype.def^.size of
                  1 : opsize:=S_B;
                  2 : opsize:=S_BW;
                  4 : opsize:=S_BL;
                 end;
               end;
           2 : begin
-                case resulttype^.size of
+                case resulttype.def^.size of
                  1 : begin
                        if left.location.loc in [LOC_REGISTER,LOC_CREGISTER] then
                         left.location.register:=reg16toreg8(left.location.register);
@@ -976,7 +816,7 @@ implementation
                 end;
               end;
           4 : begin
-                case resulttype^.size of
+                case resulttype.def^.size of
                  1 : begin
                        if left.location.loc in [LOC_REGISTER,LOC_CREGISTER] then
                         left.location.register:=reg32toreg8(left.location.register);
@@ -994,12 +834,12 @@ implementation
          if opsize in [S_B,S_W,S_L] then
           op:=A_MOV
          else
-          if is_signed(resulttype) then
+          if is_signed(resulttype.def) then
            op:=A_MOVSX
           else
            op:=A_MOVZX;
          hregister:=getregister32;
-         case resulttype^.size of
+         case resulttype.def^.size of
           1 : begin
                 location.register:=reg32toreg8(hregister);
                 newsize:=S_B;
@@ -1058,7 +898,7 @@ implementation
          { byte(boolean) or word(wordbool) or longint(longbool) must
          be accepted for var parameters }
          if (nf_explizit in flags) and
-            (left.resulttype^.size=resulttype^.size) and
+            (left.resulttype.def^.size=resulttype.def^.size) and
             (left.location.loc in [LOC_REFERENCE,LOC_MEM,LOC_CREGISTER]) then
            begin
               set_location(location,left.location);
@@ -1066,11 +906,11 @@ implementation
            end;
          location.loc:=LOC_REGISTER;
          del_reference(left.location.reference);
-         opsize:=def_opsize(left.resulttype);
+         opsize:=def_opsize(left.resulttype.def);
          case left.location.loc of
             LOC_MEM,LOC_REFERENCE :
               begin
-                hregister:=def_getreg(left.resulttype);
+                hregister:=def_getreg(left.resulttype.def);
                 emit_ref_reg(A_MOV,opsize,
                   newreference(left.location.reference),hregister);
                 emit_reg_reg(A_OR,opsize,hregister,hregister);
@@ -1090,7 +930,7 @@ implementation
             else
               internalerror(10062);
          end;
-         case resulttype^.size of
+         case resulttype.def^.size of
           1 : location.register:=makereg8(hregister);
           2 : location.register:=makereg16(hregister);
           4 : location.register:=makereg32(hregister);
@@ -1113,7 +953,7 @@ implementation
         emitpushreferenceaddr(href);
         saveregvars($ff);
         emitcall('FPC_SET_LOAD_SMALL');
-        maybe_loadesi;
+        maybe_loadself;
         popusedregisters(pushedregs);
         clear_location(location);
         location.loc:=LOC_MEM;
@@ -1155,11 +995,11 @@ implementation
         pushed : tpushed;
         regs_to_push: byte;
       begin
-         case pstringdef(resulttype)^.string_typ of
+         case pstringdef(resulttype.def)^.string_typ of
            st_shortstring:
              begin
                 location.loc:=LOC_REFERENCE;
-                gettempofsizereference(resulttype^.size,location.reference);
+                gettempofsizereference(resulttype.def^.size,location.reference);
                 pushusedregisters(pushed,$ff);
                 case left.location.loc of
                    LOC_REGISTER,LOC_CREGISTER:
@@ -1178,14 +1018,14 @@ implementation
                 emitpushreferenceaddr(location.reference);
                 saveregvars($ff);
                 emitcall('FPC_PCHAR_TO_SHORTSTR');
-                maybe_loadesi;
+                maybe_loadself;
                 popusedregisters(pushed);
              end;
            st_ansistring:
              begin
                 location.loc:=LOC_REFERENCE;
                 gettempansistringreference(location.reference);
-                decrstringref(cansistringdef,location.reference);
+                decrstringref(cansistringtype.def,location.reference);
                 { Find out which regs have to be pushed (JM) }
                 regs_to_push := $ff;
                 remove_non_regvars_from_loc(left.location,regs_to_push);
@@ -1209,7 +1049,7 @@ implementation
                 emitpushreferenceaddr(location.reference);
                 saveregvars(regs_to_push);
                 emitcall('FPC_PCHAR_TO_ANSISTR');
-                maybe_loadesi;
+                maybe_loadself;
                 popusedregisters(pushed);
              end;
          else
@@ -1247,8 +1087,8 @@ implementation
          emit_reg_reg(A_TEST,S_L,hreg,hreg);
          getlabel(l1);
          emitjmp(C_Z,l1);
-         emit_const_reg(A_ADD,S_L,pobjectdef(left.resulttype)^.implementedinterfaces^.ioffsets(
-           pobjectdef(left.resulttype)^.implementedinterfaces^.searchintf(resulttype))^,hreg);
+         emit_const_reg(A_ADD,S_L,pobjectdef(left.resulttype.def)^.implementedinterfaces^.ioffsets(
+           pobjectdef(left.resulttype.def)^.implementedinterfaces^.searchintf(resulttype.def))^,hreg);
          emitlab(l1);
          location.loc:=LOC_REGISTER;
          location.register:=hreg;
@@ -1286,9 +1126,6 @@ implementation
            @ti386typeconvnode.second_bool_to_int,
            @ti386typeconvnode.second_real_to_real,
            @ti386typeconvnode.second_int_to_real,
-           @ti386typeconvnode.second_int_to_fix,
-           @ti386typeconvnode.second_real_to_fix,
-           @ti386typeconvnode.second_fix_to_real,
            @ti386typeconvnode.second_proc_to_procvar,
            @ti386typeconvnode.second_nothing, {arrayconstructor_to_set}
            @ti386typeconvnode.second_load_smallset,
@@ -1337,10 +1174,10 @@ implementation
 {$ifdef TESTOBJEXT2}
                   { Check explicit conversions to objects pointers !! }
                      if p^.explizit and
-                        (p^.resulttype^.deftype=pointerdef) and
-                        (ppointerdef(p^.resulttype)^.definition^.deftype=objectdef) and not
-                        (pobjectdef(ppointerdef(p^.resulttype)^.definition)^.isclass) and
-                        ((pobjectdef(ppointerdef(p^.resulttype)^.definition)^.options and oo_hasvmt)<>0) and
+                        (p^.resulttype.def^.deftype=pointerdef) and
+                        (ppointerdef(p^.resulttype.def)^.definition^.deftype=objectdef) and not
+                        (pobjectdef(ppointerdef(p^.resulttype.def)^.definition)^.isclass) and
+                        ((pobjectdef(ppointerdef(p^.resulttype.def)^.definition)^.options and oo_hasvmt)<>0) and
                         (cs_check_range in aktlocalswitches) then
                        begin
                           new(r);
@@ -1363,13 +1200,13 @@ implementation
                           getlabel(nillabel);
                           emitjmp(C_E,nillabel);
                           { this is one point where we need vmt_offset (PM) }
-                          r^.offset:= pobjectdef(ppointerdef(p^.resulttype)^.definition)^.vmt_offset;
+                          r^.offset:= pobjectdef(ppointerdef(p^.resulttype.def)^.definition)^.vmt_offset;
 {$ifndef noAllocEdi}
                           getexplicitregister32(R_EDI);
 {$endif noAllocEdi}
                           emit_ref_reg(A_MOV,S_L,r,R_EDI);
                           emit_sym(A_PUSH,S_L,
-                            newasmsymbol(pobjectdef(ppointerdef(p^.resulttype)^.definition)^.vmt_mangledname));
+                            newasmsymbol(pobjectdef(ppointerdef(p^.resulttype.def)^.definition)^.vmt_mangledname));
                           emit_reg(A_PUSH,S_L,R_EDI);
 {$ifndef noAllocEdi}
                           ungetregister32(R_EDI);
@@ -1435,7 +1272,7 @@ implementation
          emitcall('FPC_DO_IS');
          emit_reg_reg(A_OR,S_B,R_AL,R_AL);
          popusedregisters(pushed);
-         maybe_loadesi;
+         maybe_loadself;
       end;
 
 
@@ -1487,7 +1324,7 @@ implementation
          { restore register, this restores automatically the }
          { result                                           }
          popusedregisters(pushed);
-         maybe_loadesi;
+         maybe_loadself;
       end;
 
 begin
@@ -1497,7 +1334,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.12  2001-01-08 21:45:11  peter
+  Revision 1.13  2001-04-02 21:20:36  peter
+    * resulttype rewrite
+
+  Revision 1.12  2001/01/08 21:45:11  peter
     * internalerror for string to chararray
 
   Revision 1.11  2000/12/25 00:07:32  peter
@@ -1513,7 +1353,7 @@ end.
     * added lots of longint typecast to prevent range check errors in the
       compiler and rtl
     * type casts of symbolic ordinal constants are now preserved
-    * fixed bug where the original resulttype wasn't restored correctly
+    * fixed bug where the original resulttype.def wasn't restored correctly
       after doing a 64bit rangecheck
 
   Revision 1.9  2000/12/05 11:44:33  jonas

compiler/i386/n386con.pas

@@ -34,10 +34,6 @@ interface
           procedure pass_2;override;
        end;
 
-       ti386fixconstnode = class(tfixconstnode)
-          procedure pass_2;override;
-       end;
-
        ti386ordconstnode = class(tordconstnode)
           procedure pass_2;override;
        end;
@@ -76,7 +72,7 @@ implementation
     procedure ti386realconstnode.pass_2;
       const
         floattype2ait:array[tfloattype] of tait=
-          (ait_real_32bit,ait_real_64bit,ait_real_80bit,ait_comp_64bit,ait_none,ait_none);
+          (ait_real_32bit,ait_real_64bit,ait_real_80bit,ait_comp_64bit);
 
       var
          hp1 : tai;
@@ -99,7 +95,7 @@ implementation
          else
            begin
               lastlabel:=nil;
-              realait:=floattype2ait[pfloatdef(resulttype)^.typ];
+              realait:=floattype2ait[pfloatdef(resulttype.def)^.typ];
               { const already used ? }
               if not assigned(lab_real) then
                 begin
@@ -158,19 +154,6 @@ implementation
       end;
 
 
-{*****************************************************************************
-                            TI386FIXCONSTNODE
-*****************************************************************************}
-
-    procedure ti386fixconstnode.pass_2;
-      begin
-         { an fix comma const. behaves as a memory reference }
-         location.loc:=LOC_MEM;
-         location.reference.is_immediate:=true;
-         location.reference.offset:=value_fix;
-      end;
-
-
 {*****************************************************************************
                             TI386ORDCONSTNODE
 *****************************************************************************}
@@ -181,7 +164,7 @@ implementation
 
       begin
          location.loc:=LOC_MEM;
-         if is_64bitint(resulttype) then
+         if is_64bitint(resulttype.def) then
            begin
               getdatalabel(l);
               if (cs_create_smart in aktmoduleswitches) then
@@ -229,7 +212,7 @@ implementation
          i,mylength  : longint;
       begin
          { for empty ansistrings we could return a constant 0 }
-         if is_ansistring(resulttype) and
+         if is_ansistring(resulttype.def) and
             (len=0) then
           begin
             location.loc:=LOC_MEM;
@@ -241,12 +224,12 @@ implementation
          lastlabel:=nil;
          if not assigned(lab_str) then
            begin
-              if is_shortstring(resulttype) then
+              if is_shortstring(resulttype.def) then
                 mylength:=len+2
               else
                 mylength:=len+1;
               { widestrings can't be reused yet }
-              if not(is_widestring(resulttype)) then
+              if not(is_widestring(resulttype.def)) then
                 begin
                   { tries to found an old entry }
                   hp1:=tai(Consts.first);
@@ -268,7 +251,7 @@ implementation
                                  same_string:=true;
                                  { if shortstring then check the length byte first and
                                    set the start index to 1 }
-                                 if is_shortstring(resulttype) then
+                                 if is_shortstring(resulttype.def) then
                                   begin
                                     if len<>ord(tai_string(hp1).str[0]) then
                                      same_string:=false;
@@ -294,7 +277,7 @@ implementation
                                   begin
                                     lab_str:=lastlabel;
                                     { create a new entry for ansistrings, but reuse the data }
-                                    if (stringtype in [st_ansistring,st_widestring]) then
+                                    if (st_type in [st_ansistring,st_widestring]) then
                                      begin
                                        getdatalabel(l2);
                                        Consts.concat(Tai_label.Create(l2));
@@ -319,7 +302,7 @@ implementation
                     Consts.concat(Tai_cut.Create);
                    Consts.concat(Tai_label.Create(lastlabel));
                    { generate an ansi string ? }
-                   case stringtype of
+                   case st_type of
                       st_ansistring:
                         begin
                            { an empty ansi string is nil! }
@@ -408,14 +391,14 @@ implementation
          neededtyp   : tait;
       begin
         { small sets are loaded as constants }
-        if psetdef(resulttype)^.settype=smallset then
+        if psetdef(resulttype.def)^.settype=smallset then
          begin
            location.loc:=LOC_MEM;
            location.reference.is_immediate:=true;
            location.reference.offset:=plongint(value_set)^;
            exit;
          end;
-        if psetdef(resulttype)^.settype=smallset then
+        if psetdef(resulttype.def)^.settype=smallset then
          neededtyp:=ait_const_32bit
         else
          neededtyp:=ait_const_8bit;
@@ -478,7 +461,7 @@ implementation
                  if (cs_create_smart in aktmoduleswitches) then
                   Consts.concat(Tai_cut.Create);
                  Consts.concat(Tai_label.Create(lastlabel));
-                 if psetdef(resulttype)^.settype=smallset then
+                 if psetdef(resulttype.def)^.settype=smallset then
                   begin
                     move(value_set^,i,sizeof(longint));
                     Consts.concat(Tai_const.Create_32bit(i));
@@ -509,7 +492,6 @@ implementation
 
 begin
    crealconstnode:=ti386realconstnode;
-   cfixconstnode:=ti386fixconstnode;
    cordconstnode:=ti386ordconstnode;
    cpointerconstnode:=ti386pointerconstnode;
    cstringconstnode:=ti386stringconstnode;
@@ -518,7 +500,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.6  2000-12-25 00:07:32  peter
+  Revision 1.7  2001-04-02 21:20:37  peter
+    * resulttype rewrite
+
+  Revision 1.6  2000/12/25 00:07:32  peter
     + new tlinkedlist class (merge of old tstringqueue,tcontainer and
       tlinkedlist objects)
 

compiler/i386/n386flw.pas

@@ -261,7 +261,7 @@ implementation
          { only calculate reference }
          cleartempgen;
          secondpass(t2);
-         hs:=t2.resulttype^.size;
+         hs:=t2.resulttype.def^.size;
          if t2.location.loc <> LOC_CREGISTER then
            cmp32:=getregister32;
          case hs of
@@ -308,7 +308,7 @@ implementation
          { produce start assignment }
          cleartempgen;
          secondpass(left);
-         count_var_is_signed:=is_signed(porddef(t2.resulttype));
+         count_var_is_signed:=is_signed(porddef(t2.resulttype.def));
          if temptovalue then
              begin
               if t2.location.loc=LOC_CREGISTER then
@@ -546,19 +546,8 @@ implementation
                         end;
              floatdef : begin
                           cleanleft;
-                          if pfloatdef(procinfo^.returntype.def)^.typ=f32bit then
-                           begin
-                             exprasmlist.concat(tairegalloc.alloc(R_EAX));
-                             allocated_eax := true;
-                             if is_mem then
-                               emit_ref_reg(A_MOV,S_L,
-                                 newreference(left.location.reference),R_EAX)
-                             else
-                               emit_reg_reg(A_MOV,S_L,left.location.register,R_EAX);
-                           end
-                          else
-                           if is_mem then
-                            floatload(pfloatdef(procinfo^.returntype.def)^.typ,left.location.reference);
+                          if is_mem then
+                           floatload(pfloatdef(procinfo^.returntype.def)^.typ,left.location.reference);
                         end;
               { orddef,
               enumdef : }
@@ -756,7 +745,7 @@ do_jmp:
          emit_reg(A_PUSH,S_L,R_EAX);
          emitcall('FPC_DESTROYEXCEPTION');
          exprasmList.concat(Tairegalloc.DeAlloc(R_EAX));
-         maybe_loadesi;
+         maybe_loadself;
       end;
 
     { pops one element from the exception address stack }
@@ -910,7 +899,7 @@ do_jmp:
               }
               push_int (-1);
               emitcall('FPC_CATCHES');
-              maybe_loadesi;
+              maybe_loadself;
 
               { the destruction of the exception object must be also }
               { guarded by an exception frame                        }
@@ -1125,7 +1114,7 @@ do_jmp:
                end;
 
               { esi is destroyed by FPC_CATCHES }
-              maybe_loadesi;
+              maybe_loadself;
               oldexceptblock:=aktexceptblock;
               aktexceptblock:=right;
               secondpass(right);
@@ -1396,7 +1385,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.8  2001-01-27 21:29:35  florian
+  Revision 1.9  2001-04-02 21:20:37  peter
+    * resulttype rewrite
+
+  Revision 1.8  2001/01/27 21:29:35  florian
      * behavior -Oa optimized
 
   Revision 1.7  2001/01/06 23:35:05  jonas

compiler/i386/n386inl.pas

@@ -82,7 +82,7 @@ implementation
     procedure StoreDirectFuncResult(var dest:tnode);
       var
         hp : tnode;
-        hdef : porddef;
+        htype : ttype;
         hreg : tregister;
         hregister : tregister;
         oldregisterdef : boolean;
@@ -91,37 +91,37 @@ implementation
 
       begin
         { Get the accumulator first so it can't be used in the dest }
-        if (dest.resulttype^.deftype=orddef) and
-          not(is_64bitint(dest.resulttype)) then
+        if (dest.resulttype.def^.deftype=orddef) and
+          not(is_64bitint(dest.resulttype.def)) then
           hregister:=getexplicitregister32(accumulator);
         { process dest }
         SecondPass(dest);
         if Codegenerror then
          exit;
         { store the value }
-        Case dest.resulttype^.deftype of
+        Case dest.resulttype.def^.deftype of
           floatdef:
             if dest.location.loc=LOC_CFPUREGISTER then
               begin
-                 floatstoreops(pfloatdef(dest.resulttype)^.typ,op,opsize);
+                 floatstoreops(pfloatdef(dest.resulttype.def)^.typ,op,opsize);
                  emit_reg(op,opsize,correct_fpuregister(dest.location.register,fpuvaroffset+1));
               end
             else
               begin
                  inc(fpuvaroffset);
-                 floatstore(PFloatDef(dest.resulttype)^.typ,dest.location.reference);
+                 floatstore(PFloatDef(dest.resulttype.def)^.typ,dest.location.reference);
                  { floatstore decrements the fpu var offset }
                  { but in fact we didn't increment it       }
               end;
           orddef:
             begin
-              if is_64bitint(dest.resulttype) then
+              if is_64bitint(dest.resulttype.def) then
                 begin
                    emit_movq_reg_loc(R_EDX,R_EAX,dest.location);
                 end
               else
                begin
-                 Case dest.resulttype^.size of
+                 Case dest.resulttype.def^.size of
                   1 : hreg:=regtoreg8(hregister);
                   2 : hreg:=regtoreg16(hregister);
                   4 : hreg:=hregister;
@@ -129,26 +129,26 @@ implementation
                  emit_mov_reg_loc(hreg,dest.location);
                  If (cs_check_range in aktlocalswitches) and
                     {no need to rangecheck longints or cardinals on 32bit processors}
-                    not((porddef(dest.resulttype)^.typ = s32bit) and
-                        (porddef(dest.resulttype)^.low = longint($80000000)) and
-                        (porddef(dest.resulttype)^.high = $7fffffff)) and
-                    not((porddef(dest.resulttype)^.typ = u32bit) and
-                        (porddef(dest.resulttype)^.low = 0) and
-                        (porddef(dest.resulttype)^.high = longint($ffffffff))) then
+                    not((porddef(dest.resulttype.def)^.typ = s32bit) and
+                        (porddef(dest.resulttype.def)^.low = longint($80000000)) and
+                        (porddef(dest.resulttype.def)^.high = $7fffffff)) and
+                    not((porddef(dest.resulttype.def)^.typ = u32bit) and
+                        (porddef(dest.resulttype.def)^.low = 0) and
+                        (porddef(dest.resulttype.def)^.high = longint($ffffffff))) then
                   Begin
                     {do not register this temporary def}
                     OldRegisterDef := RegisterDef;
                     RegisterDef := False;
-                    hdef:=nil;
-                    Case PordDef(dest.resulttype)^.typ of
+                    htype.reset;
+                    Case PordDef(dest.resulttype.def)^.typ of
                       u8bit,u16bit,u32bit:
                         begin
-                          new(hdef,init(u32bit,0,longint($ffffffff)));
+                          htype.setdef(new(porddef,init(u32bit,0,longint($ffffffff))));
                           hreg:=hregister;
                         end;
                       s8bit,s16bit,s32bit:
                         begin
-                          new(hdef,init(s32bit,longint($80000000),$7fffffff));
+                          htype.setdef(new(porddef,init(s32bit,longint($80000000),$7fffffff)));
                           hreg:=hregister;
                         end;
                     end;
@@ -156,14 +156,14 @@ implementation
                     hp := cnothingnode.create;
                     hp.location.loc := LOC_REGISTER;
                     hp.location.register := hreg;
-                    if assigned(hdef) then
-                      hp.resulttype:=hdef
+                    if assigned(htype.def) then
+                      hp.resulttype:=htype
                     else
                       hp.resulttype:=dest.resulttype;
                     { emit the range check }
-                    emitrangecheck(hp,dest.resulttype);
-                    if assigned(hdef) then
-                      Dispose(hdef, Done);
+                    emitrangecheck(hp,dest.resulttype.def);
+                    if assigned(htype.def) then
+                      Dispose(htype.def, Done);
                     RegisterDef := OldRegisterDef;
                     hp.free;
                   End;
@@ -267,11 +267,11 @@ implementation
                 npara := nb_para;
                 { calculate data variable }
                 { is first parameter a file type ? }
-                if node.left.resulttype^.deftype=filedef then
+                if node.left.resulttype.def^.deftype=filedef then
                   begin
-                     ft:=pfiledef(node.left.resulttype)^.filetyp;
+                     ft:=pfiledef(node.left.resulttype.def)^.filetyp;
                      if ft=ft_typed then
-                       typedtyp:=pfiledef(node.left.resulttype)^.typedfiletype.def;
+                       typedtyp:=pfiledef(node.left.resulttype.def)^.typedfiletype.def;
                      secondpass(node.left);
                      if codegenerror then
                        exit;
@@ -313,7 +313,7 @@ implementation
                 if ft=ft_typed then
                   { this is to avoid copy of simple const parameters }
                   {dummycoll.data:=new(pformaldef,init)}
-                  dummycoll.paratype.setdef(cformaldef)
+                  dummycoll.paratype:=cformaltype
                 else
                   { I think, this isn't a good solution (FK) }
                   dummycoll.paratype.reset;
@@ -331,17 +331,17 @@ implementation
                        convert here else we loose the old float type }
                      if (not doread) and
                         (ft<>ft_typed) and
-                        (tcallparanode(hp).left.resulttype^.deftype=floatdef) then
+                        (tcallparanode(hp).left.resulttype.def^.deftype=floatdef) then
                       begin
-                        orgfloattype:=pfloatdef(tcallparanode(hp).left.resulttype)^.typ;
-                        tcallparanode(hp).left:=gentypeconvnode(tcallparanode(hp).left,bestrealdef^);
+                        orgfloattype:=pfloatdef(tcallparanode(hp).left.resulttype.def)^.typ;
+                        tcallparanode(hp).left:=ctypeconvnode.create(tcallparanode(hp).left,pbestrealtype^);
                         firstpass(tcallparanode(hp).left);
                       end;
                      { when read ord,floats are functions, so they need this
                        parameter as their destination instead of being pushed }
                      if doread and
                         (ft<>ft_typed) and
-                        (tcallparanode(hp).resulttype^.deftype in [orddef,floatdef]) then
+                        (tcallparanode(hp).resulttype.def^.deftype in [orddef,floatdef]) then
                       begin
                       end
                      else
@@ -351,11 +351,11 @@ implementation
                         { reset data type }
                         dummycoll.paratype.reset;
                         { create temporary defs for high tree generation }
-                        if doread and (is_shortstring(tcallparanode(hp).resulttype)) then
-                          dummycoll.paratype.setdef(openshortstringdef)
+                        if doread and (is_shortstring(tcallparanode(hp).resulttype.def)) then
+                          dummycoll.paratype:=openshortstringtype
                         else
-                          if (is_chararray(tcallparanode(hp).resulttype)) then
-                            dummycoll.paratype.setdef(openchararraydef);
+                          if (is_chararray(tcallparanode(hp).resulttype.def)) then
+                            dummycoll.paratype:=openchararraytype;
                         tcallparanode(hp).secondcallparan(dummycoll,false,false,false,0,0);
                         if ft=ft_typed then
                           never_copy_const_param:=false;
@@ -388,7 +388,7 @@ implementation
                      else
                        begin
                           { save current position }
-                          pararesult:=tcallparanode(hp).left.resulttype;
+                          pararesult:=tcallparanode(hp).left.resulttype.def;
                           { handle possible field width  }
                           { of course only for write(ln) }
                           if not doread then
@@ -399,7 +399,7 @@ implementation
                                    hp:=node;
                                    node:=tcallparanode(node.right);
                                    tcallparanode(hp).right:=nil;
-                                   dummycoll.paratype.setdef(hp.resulttype);
+                                   dummycoll.paratype.setdef(hp.resulttype.def);
                                    dummycoll.paratyp:=vs_value;
                                    tcallparanode(hp).secondcallparan(dummycoll,false,false,false,0,0);
                                    tcallparanode(hp).right:=node;
@@ -417,7 +417,7 @@ implementation
                                    hp:=node;
                                    node:=tcallparanode(node.right);
                                    tcallparanode(hp).right:=nil;
-                                   dummycoll.paratype.setdef(hp.resulttype);
+                                   dummycoll.paratype.setdef(hp.resulttype.def);
                                    dummycoll.paratyp:=vs_value;
                                    tcallparanode(hp).secondcallparan(dummycoll,false,false,false,0,0);
                                    tcallparanode(hp).right:=node;
@@ -455,12 +455,12 @@ implementation
                               begin
                                 emitcall(rdwrprefix[doread]+'FLOAT');
                                 {
-                                if pfloatdef(resulttype)^.typ<>f32bit then
+                                if pfloatdef(resulttype.def)^.typ<>f32bit then
                                   dec(fpuvaroffset);
                                 }
                                 if doread then
                                   begin
-                                     maybe_loadesi;
+                                     maybe_loadself;
                                      esireloaded:=true;
                                      StoreDirectFuncResult(tcallparanode(hp).left);
                                   end;
@@ -485,7 +485,7 @@ implementation
                                 end;
                                 if doread then
                                   begin
-                                     maybe_loadesi;
+                                     maybe_loadself;
                                      esireloaded:=true;
                                      StoreDirectFuncResult(tcallparanode(hp).left);
                                   end;
@@ -495,7 +495,7 @@ implementation
                    { load ESI in methods again }
                      popusedregisters(pushed);
                      if not(esireloaded) then
-                       maybe_loadesi;
+                       maybe_loadself;
                   end;
              end;
          { Insert end of writing for textfiles }
@@ -519,7 +519,7 @@ implementation
                     emitcall('FPC_WRITE_END');
                 end;
                popusedregisters(pushed);
-               maybe_loadesi;
+               maybe_loadself;
              end;
          { Insert IOCheck if set }
            if assigned(iolabel) then
@@ -565,10 +565,10 @@ implementation
            is_real:=false;
            while assigned(node.right) do node:=tcallparanode(node.right);
            { if a real parameter somewhere then call REALSTR }
-           if (node.left.resulttype^.deftype=floatdef) then
+           if (node.left.resulttype.def^.deftype=floatdef) then
             begin
               is_real:=true;
-              realtype:=pfloatdef(node.left.resulttype)^.typ;
+              realtype:=pfloatdef(node.left.resulttype.def)^.typ;
             end;
 
            node:=tcallparanode(left);
@@ -580,11 +580,11 @@ implementation
            node:=tcallparanode(node.right);
            hp.right:=nil;
            dummycoll.paratyp:=vs_var;
-           if is_shortstring(hp.resulttype) then
-             dummycoll.paratype.setdef(openshortstringdef)
+           if is_shortstring(hp.resulttype.def) then
+             dummycoll.paratype:=openshortstringtype
            else
-             dummycoll.paratype.setdef(hp.resulttype);
-           procedureprefix:='FPC_'+pstringdef(hp.resulttype)^.stringtypname+'_';
+             dummycoll.paratype:=hp.resulttype;
+           procedureprefix:='FPC_'+pstringdef(hp.resulttype.def)^.stringtypname+'_';
            tcallparanode(hp).secondcallparan(dummycoll,false,false,false,0,0);
            if codegenerror then
              begin
@@ -608,12 +608,12 @@ implementation
            if (cpf_is_colon_para in hp.callparaflags) and assigned(node) and
               (cpf_is_colon_para in node.callparaflags) then
              begin
-                dummycoll.paratype.setdef(hp.resulttype);
+                dummycoll.paratype.setdef(hp.resulttype.def);
                 dummycoll.paratyp:=vs_value;
                 tcallparanode(hp).secondcallparan(dummycoll,false,false,false,0,0);
                 if codegenerror then
-                  begin  
-                    dummycoll.free;   
+                  begin
+                    dummycoll.free;
                     exit;
                   end;
                 hp.free;
@@ -628,12 +628,12 @@ implementation
            { third arg, length only if is_real }
            if (cpf_is_colon_para in hp.callparaflags) then
              begin
-                dummycoll.paratype.setdef(hp.resulttype);
+                dummycoll.paratype.setdef(hp.resulttype.def);
                 dummycoll.paratyp:=vs_value;
                 tcallparanode(hp).secondcallparan(dummycoll,false,false,false,0,0);
                 if codegenerror then
-                  begin  
-                    dummycoll.free;   
+                  begin
+                    dummycoll.free;
                     exit;
                   end;
                 hp.free;
@@ -650,17 +650,17 @@ implementation
            { Convert float to bestreal }
            if is_real then
             begin
-              hp.left:=gentypeconvnode(hp.left,bestrealdef^);
+              hp.left:=ctypeconvnode.create(hp.left,pbestrealtype^);
               firstpass(hp.left);
             end;
 
            { last arg longint or real }
-           dummycoll.paratype.setdef(hp.resulttype);
+           dummycoll.paratype.setdef(hp.resulttype.def);
            dummycoll.paratyp:=vs_value;
            tcallparanode(hp).secondcallparan(dummycoll,false,false,false,0,0);
            if codegenerror then
-             begin  
-               dummycoll.free;   
+             begin
+               dummycoll.free;
                exit;
              end;
 
@@ -668,7 +668,7 @@ implementation
            if is_real then
              emitcall(procedureprefix+'FLOAT')
            else
-             case porddef(hp.resulttype)^.typ of
+             case porddef(hp.resulttype.def)^.typ of
                 u32bit:
                   emitcall(procedureprefix+'CARDINAL');
 
@@ -719,7 +719,7 @@ implementation
                hp := node;
                node := tcallparanode(node.right);
                hp.right := nil;
-               has_32bit_code := (porddef(tcallparanode(code_para).left.resulttype)^.typ in [u32bit,s32bit]);
+               has_32bit_code := (porddef(tcallparanode(code_para).left.resulttype.def)^.typ in [u32bit,s32bit]);
              End;
 
           {hp = destination now, save for later use}
@@ -731,7 +731,7 @@ implementation
 
           {load and push the address of the destination}
            dummycoll.paratyp:=vs_var;
-           dummycoll.paratype.setdef(dest_para.resulttype);
+           dummycoll.paratype.setdef(dest_para.resulttype.def);
            dest_para.secondcallparan(dummycoll,false,false,false,0,0);
            if codegenerror then
            begin
@@ -748,7 +748,7 @@ implementation
            If has_32bit_code Then
              Begin
                dummycoll.paratyp:=vs_var;
-               dummycoll.paratype.setdef(code_para.resulttype);
+               dummycoll.paratype.setdef(code_para.resulttype.def);
                code_para.secondcallparan(dummycoll,false,false,false,0,0);
                if codegenerror then
                  begin
@@ -766,7 +766,7 @@ implementation
 
           {node = first parameter = string}
            dummycoll.paratyp:=vs_const;
-           dummycoll.paratype.setdef(node.resulttype);
+           dummycoll.paratype.setdef(node.resulttype.def);
            node.secondcallparan(dummycoll,false,false,false,0,0);
            if codegenerror then
              begin
@@ -774,29 +774,28 @@ implementation
                exit;
              end;
 
-           Case dest_para.resulttype^.deftype of
+           Case dest_para.resulttype.def^.deftype of
              floatdef:
                begin
                   procedureprefix := 'FPC_VAL_REAL_';
-                  if pfloatdef(resulttype)^.typ<>f32bit then
-                    inc(fpuvaroffset);
+                  inc(fpuvaroffset);
                end;
              orddef:
-               if is_64bitint(dest_para.resulttype) then
+               if is_64bitint(dest_para.resulttype.def) then
                  begin
-                    if is_signed(dest_para.resulttype) then
+                    if is_signed(dest_para.resulttype.def) then
                       procedureprefix := 'FPC_VAL_INT64_'
                     else
                       procedureprefix := 'FPC_VAL_QWORD_';
                  end
                else
                  begin
-                    if is_signed(dest_para.resulttype) then
+                    if is_signed(dest_para.resulttype.def) then
                       begin
                         {if we are converting to a signed number, we have to include the
                          size of the destination, so the Val function can extend the sign
                          of the result to allow proper range checking}
-                        emit_const(A_PUSH,S_L,dest_para.resulttype^.size);
+                        emit_const(A_PUSH,S_L,dest_para.resulttype.def^.size);
                         procedureprefix := 'FPC_VAL_SINT_'
                       end
                     else
@@ -805,7 +804,7 @@ implementation
            End;
 
            saveregvars($ff);
-           emitcall(procedureprefix+pstringdef(node.resulttype)^.stringtypname);
+           emitcall(procedureprefix+pstringdef(node.resulttype.def)^.stringtypname);
            { before disposing node we need to ungettemp !! PM }
            if node.left.location.loc in [LOC_REFERENCE,LOC_MEM] then
              ungetiftemp(node.left.location.reference);
@@ -813,15 +812,15 @@ implementation
            left := nil;
 
           {reload esi in case the dest_para/code_para is a class variable or so}
-           maybe_loadesi;
+           maybe_loadself;
 
-           If (dest_para.resulttype^.deftype = orddef) Then
+           If (dest_para.resulttype.def^.deftype = orddef) Then
              Begin
               {store the result in a safe place, because EAX may be used by a
                register variable}
                hreg := getexplicitregister32(R_EAX);
                emit_reg_reg(A_MOV,S_L,R_EAX,hreg);
-               if is_64bitint(dest_para.resulttype) then
+               if is_64bitint(dest_para.resulttype.def) then
                  begin
                     hreg2:=getexplicitregister32(R_EDX);
                     emit_reg_reg(A_MOV,S_L,R_EDX,hreg2);
@@ -862,11 +861,11 @@ implementation
            hr2.base := R_EDI;
 
           {save the function result in the destination variable}
-           Case dest_para.left.resulttype^.deftype of
+           Case dest_para.left.resulttype.def^.deftype of
              floatdef:
-               floatstore(PFloatDef(dest_para.left.resulttype)^.typ, hr2);
+               floatstore(PFloatDef(dest_para.left.resulttype.def)^.typ, hr2);
              orddef:
-               Case PordDef(dest_para.left.resulttype)^.typ of
+               Case PordDef(dest_para.left.resulttype.def)^.typ of
                  u8bit,s8bit:
                    emit_reg_ref(A_MOV, S_B,
                      RegToReg8(hreg),newreference(hr2));
@@ -891,18 +890,18 @@ implementation
            ungetregister32(R_EDI);
 {$endif noAllocEdi}
            If (cs_check_range in aktlocalswitches) and
-              (dest_para.left.resulttype^.deftype = orddef) and
-              (not(is_64bitint(dest_para.left.resulttype))) and
+              (dest_para.left.resulttype.def^.deftype = orddef) and
+              (not(is_64bitint(dest_para.left.resulttype.def))) and
             {the following has to be changed to 64bit checking, once Val
              returns 64 bit values (unless a special Val function is created
              for that)}
             {no need to rangecheck longints or cardinals on 32bit processors}
-               not((porddef(dest_para.left.resulttype)^.typ = s32bit) and
-                   (porddef(dest_para.left.resulttype)^.low = longint($80000000)) and
-                   (porddef(dest_para.left.resulttype)^.high = $7fffffff)) and
-               not((porddef(dest_para.left.resulttype)^.typ = u32bit) and
-                   (porddef(dest_para.left.resulttype)^.low = 0) and
-                   (porddef(dest_para.left.resulttype)^.high = longint($ffffffff))) then
+               not((porddef(dest_para.left.resulttype.def)^.typ = s32bit) and
+                   (porddef(dest_para.left.resulttype.def)^.low = longint($80000000)) and
+                   (porddef(dest_para.left.resulttype.def)^.high = $7fffffff)) and
+               not((porddef(dest_para.left.resulttype.def)^.typ = u32bit) and
+                   (porddef(dest_para.left.resulttype.def)^.low = 0) and
+                   (porddef(dest_para.left.resulttype.def)^.high = longint($ffffffff))) then
              Begin
                hp:=tcallparanode(dest_para.left.getcopy);
                hp.location.loc := LOC_REGISTER;
@@ -910,14 +909,14 @@ implementation
               {do not register this temporary def}
                OldRegisterDef := RegisterDef;
                RegisterDef := False;
-               Case PordDef(dest_para.left.resulttype)^.typ of
+               Case PordDef(dest_para.left.resulttype.def)^.typ of
                  u8bit,u16bit,u32bit: new(hdef,init(u32bit,0,longint($ffffffff)));
                  s8bit,s16bit,s32bit: new(hdef,init(s32bit,longint($80000000),$7fffffff));
                end;
-               hp.resulttype := hdef;
-               emitrangecheck(hp,dest_para.left.resulttype);
+               hp.resulttype.def := hdef;
+               emitrangecheck(hp,dest_para.left.resulttype.def);
                hp.right := nil;
-               Dispose(hp.resulttype, Done);
+               Dispose(hp.resulttype.def, Done);
                RegisterDef := OldRegisterDef;
                hp.free;
              End;
@@ -962,7 +961,8 @@ implementation
                  { lineno }
                  emit_const(A_PUSH,S_L,aktfilepos.line);
                  { filename string }
-                 hp2:=genstringconstnode(current_module.sourcefiles.get_file_name(aktfilepos.fileindex),st_shortstring);
+                 hp2:=cstringconstnode.createstr(current_module.sourcefiles.get_file_name(aktfilepos.fileindex),st_shortstring);
+                 firstpass(hp2);
                  secondpass(hp2);
                  if codegenerror then
                   exit;
@@ -1011,7 +1011,7 @@ implementation
                    begin
                       location.register:=getregister32;
                       emit_sym_ofs_reg(A_MOV,
-                        S_L,newasmsymbol(pobjectdef(left.resulttype)^.vmt_mangledname),0,
+                        S_L,newasmsymbol(pobjectdef(left.resulttype.def)^.vmt_mangledname),0,
                         location.register);
                    end
                  else
@@ -1022,7 +1022,7 @@ implementation
                       location.register:=getregister32;
                       { load VMT pointer }
                       inc(left.location.reference.offset,
-                        pobjectdef(left.resulttype)^.vmt_offset);
+                        pobjectdef(left.resulttype.def)^.vmt_offset);
                       emit_ref_reg(A_MOV,S_L,
                       newreference(left.location.reference),
                         location.register);
@@ -1109,10 +1109,10 @@ implementation
                  secondpass(left);
                  set_location(location,left.location);
                  { length in ansi strings is at offset -8 }
-                 if is_ansistring(left.resulttype) then
+                 if is_ansistring(left.resulttype.def) then
                    dec(location.reference.offset,8)
                  { char is always 1, so make it a constant value }
-                 else if is_char(left.resulttype) then
+                 else if is_char(left.resulttype.def) then
                    begin
                      clear_location(location);
                      location.loc:=LOC_MEM;
@@ -1134,7 +1134,7 @@ implementation
                      asmop:=A_SUB
                    else
                      asmop:=A_ADD;
-                 case resulttype^.size of
+                 case resulttype.def^.size of
                    8 : opsize:=S_L;
                    4 : opsize:=S_L;
                    2 : opsize:=S_W;
@@ -1143,7 +1143,7 @@ implementation
                    internalerror(10080);
                  end;
                  location.loc:=LOC_REGISTER;
-                 if resulttype^.size=8 then
+                 if resulttype.def^.size=8 then
                    begin
                       if left.location.loc<>LOC_REGISTER then
                         begin
@@ -1198,9 +1198,9 @@ implementation
                              del_reference(left.location.reference);
 
                            location.register:=getregister32;
-                           if (resulttype^.size=2) then
+                           if (resulttype.def^.size=2) then
                              location.register:=reg32toreg16(location.register);
-                           if (resulttype^.size=1) then
+                           if (resulttype.def^.size=1) then
                              location.register:=reg32toreg8(location.register);
                            if left.location.loc=LOC_CREGISTER then
                              emit_reg_reg(A_MOV,opsize,left.location.register,
@@ -1221,7 +1221,7 @@ implementation
                         location.register);
                    end;
                  emitoverflowcheck(self);
-                 emitrangecheck(self,resulttype);
+                 emitrangecheck(self,resulttype.def);
               end;
             in_dec_x,
             in_inc_x :
@@ -1231,10 +1231,10 @@ implementation
                 addconstant:=true;
               { load first parameter, must be a reference }
                 secondpass(tcallparanode(left).left);
-                case tcallparanode(left).left.resulttype^.deftype of
+                case tcallparanode(left).left.resulttype.def^.deftype of
                   orddef,
                  enumdef : begin
-                             case tcallparanode(left).left.resulttype^.size of
+                             case tcallparanode(left).left.resulttype.def^.size of
                               1 : opsize:=S_B;
                               2 : opsize:=S_W;
                               4 : opsize:=S_L;
@@ -1243,10 +1243,10 @@ implementation
                            end;
               pointerdef : begin
                              opsize:=S_L;
-                             if porddef(ppointerdef(tcallparanode(left).left.resulttype)^.pointertype.def)=voiddef then
+                             if is_void(ppointerdef(tcallparanode(left).left.resulttype.def)^.pointertype.def) then
                               addvalue:=1
                              else
-                              addvalue:=ppointerdef(tcallparanode(left).left.resulttype)^.pointertype.def^.size;
+                              addvalue:=ppointerdef(tcallparanode(left).left.resulttype.def)^.pointertype.def^.size;
                            end;
                 else
                  internalerror(10081);
@@ -1331,16 +1331,16 @@ implementation
                    ungetregister32(hregister);
                  end;
                 emitoverflowcheck(tcallparanode(left).left);
-                emitrangecheck(tcallparanode(left).left,tcallparanode(left).left.resulttype);
+                emitrangecheck(tcallparanode(left).left,tcallparanode(left).left.resulttype.def);
               end;
 
             in_typeinfo_x:
                begin
-                  pstoreddef(ttypenode(tcallparanode(left).left).typenodetype)^.generate_rtti;
+                  pstoreddef(ttypenode(tcallparanode(left).left).resulttype.def)^.generate_rtti;
                   location.register:=getregister32;
                   new(r);
                   reset_reference(r^);
-                  r^.symbol:=pstoreddef(ttypenode(tcallparanode(left).left).typenodetype)^.rtti_label;
+                  r^.symbol:=pstoreddef(ttypenode(tcallparanode(left).left).resulttype.def)^.rtti_label;
                   emit_ref_reg(A_LEA,S_L,r,location.register);
                end;
 
@@ -1348,12 +1348,12 @@ implementation
                begin
                   pushusedregisters(pushed,$ff);
                   { force rtti generation }
-                  pstoreddef(ttypenode(tcallparanode(left).left).resulttype)^.generate_rtti;
+                  pstoreddef(ttypenode(tcallparanode(left).left).resulttype.def)^.generate_rtti;
                   { if a count is passed, push size, typeinfo and count }
                   if assigned(tcallparanode(left).right) then
                     begin
                        secondpass(tcallparanode(tcallparanode(left).right).left);
-                       push_int(tcallparanode(left).left.resulttype^.size);
+                       push_int(tcallparanode(left).left.resulttype.def^.size);
                        if codegenerror then
                         exit;
                        emit_push_loc(tcallparanode(tcallparanode(left).right).left.location);
@@ -1361,7 +1361,7 @@ implementation
 
                   { generate a reference }
                   reset_reference(hr);
-                  hr.symbol:=pstoreddef(ttypenode(tcallparanode(left).left).resulttype)^.rtti_label;
+                  hr.symbol:=pstoreddef(ttypenode(tcallparanode(left).left).resulttype.def)^.rtti_label;
                   emitpushreferenceaddr(hr);
 
                   { data to finalize }
@@ -1399,7 +1399,7 @@ implementation
              in_reset_typedfile,in_rewrite_typedfile :
                begin
                   pushusedregisters(pushed,$ff);
-                  emit_const(A_PUSH,S_L,pfiledef(left.resulttype)^.typedfiletype.def^.size);
+                  emit_const(A_PUSH,S_L,pfiledef(left.resulttype.def)^.typedfiletype.def^.size);
                   secondpass(left);
                   emitpushreferenceaddr(left.location.reference);
                   saveregvars($ff);
@@ -1420,7 +1420,7 @@ implementation
                        inc(l);
                        hp:=tcallparanode(hp).right;
                     end;
-                  def:=tcallparanode(hp).left.resulttype;
+                  def:=tcallparanode(hp).left.resulttype.def;
                   hp:=left;
                   if is_dynamic_array(def) then
                     begin
@@ -1452,7 +1452,7 @@ implementation
                     begin
                       dummycoll:=TParaItem.Create;
                       dummycoll.paratyp:=vs_var;
-                      dummycoll.paratype.setdef(openshortstringdef);
+                      dummycoll.paratype:=openshortstringtype;
                       tcallparanode(hp).secondcallparan(dummycoll,false,false,false,0,0);
                       if codegenerror then
                         exit;
@@ -1506,7 +1506,7 @@ implementation
             in_str_x_string :
               begin
                  handle_str;
-                 maybe_loadesi;
+                 maybe_loadself;
               end;
             in_val_x :
               Begin
@@ -1558,7 +1558,7 @@ implementation
                         asmop:=A_BTS
                       else
                         asmop:=A_BTR;
-                      if psetdef(left.resulttype)^.settype=smallset then
+                      if psetdef(left.resulttype.def)^.settype=smallset then
                         begin
                            if tcallparanode(tcallparanode(left).right).left.location.loc in [LOC_CREGISTER,LOC_REGISTER] then
                              { we don't need a mod 32 because this is done automatically  }
@@ -1571,7 +1571,7 @@ implementation
                                 getexplicitregister32(R_EDI);
                                 hregister:=R_EDI;
                                 opsize:=def2def_opsize(
-                                  tcallparanode(tcallparanode(left).right).left.resulttype,u32bitdef);
+                                  tcallparanode(tcallparanode(left).right).left.resulttype.def,u32bittype.def);
                                 if opsize in [S_B,S_W,S_L] then
                                  op:=A_MOV
                                 else
@@ -1627,7 +1627,7 @@ implementation
                       end;
                     LOC_REFERENCE,LOC_MEM:
                       begin
-                         floatload(pfloatdef(left.resulttype)^.typ,left.location.reference);
+                         floatload(pfloatdef(left.resulttype.def)^.typ,left.location.reference);
                          del_reference(left.location.reference);
                       end
                     else
@@ -1704,7 +1704,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.12  2001-03-13 11:52:48  jonas
+  Revision 1.13  2001-04-02 21:20:37  peter
+    * resulttype rewrite
+
+  Revision 1.12  2001/03/13 11:52:48  jonas
     * fixed some memory leaks
 
   Revision 1.11  2000/12/25 00:07:33  peter
@@ -1723,7 +1726,7 @@ end.
     * added lots of longint typecast to prevent range check errors in the
       compiler and rtl
     * type casts of symbolic ordinal constants are now preserved
-    * fixed bug where the original resulttype wasn't restored correctly
+    * fixed bug where the original resulttype.def wasn't restored correctly
       after doing a 64bit rangecheck
 
   Revision 1.8  2000/12/05 11:44:33  jonas

compiler/i386/n386ld.pas

@@ -298,40 +298,51 @@ implementation
                  begin
                     if assigned(left) then
                       begin
-                         secondpass(left);
                          location.loc:=LOC_MEM;
                          gettempofsizereference(8,location.reference);
+                         if left.nodetype=typen then
+                          begin
+                            if left.resulttype.def^.deftype<>objectdef then
+                             internalerror(200103261);
+                            getexplicitregister32(R_EDI);
+                            hregister:=R_EDI;
+                            new(hp);
+                            emit_sym_ofs_reg(A_MOV,S_L,
+                              newasmsymbol(pobjectdef(left.resulttype.def)^.vmt_mangledname),0,R_EDI);
+                          end
+                         else
+                          begin
+                            secondpass(left);
+
+                            { load class instance address }
+                            case left.location.loc of
+
+                               LOC_CREGISTER,
+                               LOC_REGISTER:
+                                 begin
+                                    hregister:=left.location.register;
+                                    ungetregister32(left.location.register);
+                                    if is_object(left.resulttype.def) then
+                                      CGMessage(cg_e_illegal_expression);
+                                 end;
 
-                         { load class instance address }
-                         case left.location.loc of
-
-                            LOC_CREGISTER,
-                            LOC_REGISTER:
-                              begin
-                                 hregister:=left.location.register;
-                                 ungetregister32(left.location.register);
-                                 if is_object(left.resulttype) then
-                                   CGMessage(cg_e_illegal_expression);
-                              end;
-
-                            LOC_MEM,
-                            LOC_REFERENCE:
-                              begin
-{$ifndef noAllocEdi}
-                                 getexplicitregister32(R_EDI);
-{$endif noAllocEdi}
-                                 hregister:=R_EDI;
-                                 if is_class_or_interface(left.resulttype) then
-                                   emit_ref_reg(A_MOV,S_L,
-                                     newreference(left.location.reference),R_EDI)
-                                 else
-                                   emit_ref_reg(A_LEA,S_L,
-                                     newreference(left.location.reference),R_EDI);
-                                 del_reference(left.location.reference);
-                                 ungetiftemp(left.location.reference);
-                              end;
-                            else internalerror(26019);
-                         end;
+                               LOC_MEM,
+                               LOC_REFERENCE:
+                                 begin
+                                    getexplicitregister32(R_EDI);
+                                    hregister:=R_EDI;
+                                    if is_class_or_interface(left.resulttype.def) then
+                                      emit_ref_reg(A_MOV,S_L,
+                                        newreference(left.location.reference),R_EDI)
+                                    else
+                                      emit_ref_reg(A_LEA,S_L,
+                                        newreference(left.location.reference),R_EDI);
+                                    del_reference(left.location.reference);
+                                    ungetiftemp(left.location.reference);
+                                 end;
+                               else internalerror(26019);
+                            end;
+                          end;
 
                          { store the class instance address }
                          new(hp);
@@ -470,9 +481,9 @@ implementation
               exit;
            end;
 {$endif test_dest_loc}
-         if left.resulttype^.deftype=stringdef then
+         if left.resulttype.def^.deftype=stringdef then
            begin
-              if is_ansistring(left.resulttype) then
+              if is_ansistring(left.resulttype.def) then
                 begin
                   { before pushing any parameter, we have to save all used      }
                   { registers, but before that we have to release the       }
@@ -510,16 +521,16 @@ implementation
                   del_reference(left.location.reference);
                   saveregvars($ff);
                   emitcall('FPC_ANSISTR_ASSIGN');
-                  maybe_loadesi;
+                  maybe_loadself;
                   popusedregisters(regspushed);
                   if ungettemp then
                     ungetiftemp(right.location.reference);
                 end
               else
-              if is_shortstring(left.resulttype) and
+              if is_shortstring(left.resulttype.def) and
                 not (nf_concat_string in flags) then
                 begin
-                  if is_ansistring(right.resulttype) then
+                  if is_ansistring(right.resulttype.def) then
                     begin
                       if (right.nodetype=stringconstn) and
                          (tstringconstnode(right).len=0) then
@@ -541,7 +552,7 @@ implementation
                        ungetiftemp(right.location.reference);
                     end;
                 end
-              else if is_longstring(left.resulttype) then
+              else if is_longstring(left.resulttype.def) then
                 begin
                 end
               else
@@ -550,7 +561,7 @@ implementation
                   del_reference(right.location.reference);
                 end
            end
-        else if is_interfacecom(left.resulttype) then
+        else if is_interfacecom(left.resulttype.def) then
           begin
              loadinterfacecom(self);
           end
@@ -558,10 +569,10 @@ implementation
             LOC_REFERENCE,
             LOC_MEM : begin
                          { extra handling for ordinal constants }
-                         if (right.nodetype in [ordconstn,fixconstn]) or
+                         if (right.nodetype=ordconstn) or
                             (loc=LOC_CREGISTER) then
                            begin
-                              case left.resulttype^.size of
+                              case left.resulttype.def^.size of
                                  1 : opsize:=S_B;
                                  2 : opsize:=S_W;
                                  4 : opsize:=S_L;
@@ -574,7 +585,7 @@ implementation
                                   emit_ref_reg(A_MOV,opsize,
                                     newreference(right.location.reference),
                                     left.location.register);
-                                  if is_64bitint(right.resulttype) then
+                                  if is_64bitint(right.resulttype.def) then
                                     begin
                                        r:=newreference(right.location.reference);
                                        inc(r^.offset,4);
@@ -587,7 +598,7 @@ implementation
                                 end
                               else
                                 begin
-                                  if is_64bitint(right.resulttype) then
+                                  if is_64bitint(right.resulttype.def) then
                                     begin
                                        emit_const_ref(A_MOV,opsize,
                                          longint(lo(tordconstnode(right).value)),
@@ -614,7 +625,7 @@ implementation
                            end
                          else if loc=LOC_CFPUREGISTER then
                            begin
-                              floatloadops(pfloatdef(right.resulttype)^.typ,op,opsize);
+                              floatloadops(pfloatdef(right.resulttype.def)^.typ,op,opsize);
                               emit_ref(op,opsize,
                                 newreference(right.location.reference));
                               emit_reg(A_FSTP,S_NO,
@@ -622,16 +633,16 @@ implementation
                            end
                          else
                            begin
-                              if (right.resulttype^.needs_inittable) then
+                              if (right.resulttype.def^.needs_inittable) then
                                 begin
                                    { this would be a problem }
-                                   if not(left.resulttype^.needs_inittable) then
+                                   if not(left.resulttype.def^.needs_inittable) then
                                      internalerror(3457);
 
                                    { increment source reference counter }
                                    new(r);
                                    reset_reference(r^);
-                                   r^.symbol:=pstoreddef(right.resulttype)^.get_inittable_label;
+                                   r^.symbol:=pstoreddef(right.resulttype.def)^.get_inittable_label;
                                    emitpushreferenceaddr(r^);
 
                                    emitpushreferenceaddr(right.location.reference);
@@ -639,7 +650,7 @@ implementation
                                    { decrement destination reference counter }
                                    new(r);
                                    reset_reference(r^);
-                                   r^.symbol:=pstoreddef(left.resulttype)^.get_inittable_label;
+                                   r^.symbol:=pstoreddef(left.resulttype.def)^.get_inittable_label;
                                    emitpushreferenceaddr(r^);
                                    emitpushreferenceaddr(left.location.reference);
                                    emitcall('FPC_DECREF');
@@ -647,11 +658,11 @@ implementation
 
 {$ifdef regallocfix}
                               concatcopy(right.location.reference,
-                                left.location.reference,left.resulttype^.size,true,false);
+                                left.location.reference,left.resulttype.def^.size,true,false);
                               ungetiftemp(right.location.reference);
 {$Else regallocfix}
                               concatcopy(right.location.reference,
-                                left.location.reference,left.resulttype^.size,false,false);
+                                left.location.reference,left.resulttype.def^.size,false,false);
                               ungetiftemp(right.location.reference);
 {$endif regallocfix}
                            end;
@@ -670,7 +681,7 @@ implementation
 {$endif SUPPORT_MMX}
             LOC_REGISTER,
             LOC_CREGISTER : begin
-                              case right.resulttype^.size of
+                              case right.resulttype.def^.size of
                                  1 : opsize:=S_B;
                                  2 : opsize:=S_W;
                                  4 : opsize:=S_L;
@@ -694,7 +705,7 @@ implementation
                                   del_reference(left.location.reference);
 {$EndIf regallocfix}
                                 end;
-                              if is_64bitint(right.resulttype) then
+                              if is_64bitint(right.resulttype.def) then
                                 begin
                                    { simplified with op_reg_loc  }
                                    if loc=LOC_CREGISTER then
@@ -715,15 +726,15 @@ implementation
 
                            end;
             LOC_FPU : begin
-                              if (left.resulttype^.deftype=floatdef) then
-                               fputyp:=pfloatdef(left.resulttype)^.typ
+                              if (left.resulttype.def^.deftype=floatdef) then
+                               fputyp:=pfloatdef(left.resulttype.def)^.typ
                               else
-                               if (right.resulttype^.deftype=floatdef) then
-                                fputyp:=pfloatdef(right.resulttype)^.typ
+                               if (right.resulttype.def^.deftype=floatdef) then
+                                fputyp:=pfloatdef(right.resulttype.def)^.typ
                               else
                                if (right.nodetype=typeconvn) and
-                                  (ttypeconvnode(right).left.resulttype^.deftype=floatdef) then
-                                fputyp:=pfloatdef(ttypeconvnode(right).left.resulttype)^.typ
+                                  (ttypeconvnode(right).left.resulttype.def^.deftype=floatdef) then
+                                fputyp:=pfloatdef(ttypeconvnode(right).left.resulttype.def)^.typ
                               else
                                 fputyp:=s32real;
                               case loc of
@@ -740,15 +751,15 @@ implementation
                               end;
                            end;
             LOC_CFPUREGISTER: begin
-                              if (left.resulttype^.deftype=floatdef) then
-                               fputyp:=pfloatdef(left.resulttype)^.typ
+                              if (left.resulttype.def^.deftype=floatdef) then
+                               fputyp:=pfloatdef(left.resulttype.def)^.typ
                               else
-                               if (right.resulttype^.deftype=floatdef) then
-                                fputyp:=pfloatdef(right.resulttype)^.typ
+                               if (right.resulttype.def^.deftype=floatdef) then
+                                fputyp:=pfloatdef(right.resulttype.def)^.typ
                               else
                                if (right.nodetype=typeconvn) and
-                                  (ttypeconvnode(right).left.resulttype^.deftype=floatdef) then
-                                fputyp:=pfloatdef(ttypeconvnode(right).left.resulttype)^.typ
+                                  (ttypeconvnode(right).left.resulttype.def^.deftype=floatdef) then
+                                fputyp:=pfloatdef(ttypeconvnode(right).left.resulttype.def)^.typ
                               else
                                 fputyp:=s32real;
                               emit_reg(A_FLD,S_NO,
@@ -855,7 +866,7 @@ implementation
              location.reference.base:=procinfo^.framepointer;
              location.reference.offset:=procinfo^.return_offset;
            end;
-         if ret_in_param(rettype.def) then
+         if ret_in_param(resulttype.def) then
            begin
               if not hr_valid then
                 hr:=getregister32;
@@ -901,12 +912,12 @@ implementation
         dovariant : boolean;
         elesize : longint;
       begin
-        dovariant:=(nf_forcevaria in flags) or parraydef(resulttype)^.isvariant;
+        dovariant:=(nf_forcevaria in flags) or parraydef(resulttype.def)^.isvariant;
         if dovariant then
          elesize:=8
         else
          begin
-           elesize:=parraydef(resulttype)^.elesize;
+           elesize:=parraydef(resulttype.def)^.elesize;
            if elesize>4 then
             internalerror(8765678);
          end;
@@ -915,10 +926,10 @@ implementation
            reset_reference(location.reference);
            { Allocate always a temp, also if no elements are required, to
              be sure that location is valid (PFV) }
-            if parraydef(resulttype)^.highrange=-1 then
+            if parraydef(resulttype.def)^.highrange=-1 then
               gettempofsizereference(elesize,location.reference)
             else
-              gettempofsizereference((parraydef(resulttype)^.highrange+1)*elesize,location.reference);
+              gettempofsizereference((parraydef(resulttype.def)^.highrange+1)*elesize,location.reference);
            href:=location.reference;
          end;
         hp:=self;
@@ -935,7 +946,7 @@ implementation
                  { find the correct vtype value }
                  vtype:=$ff;
                  vaddr:=false;
-                 lt:=hp.left.resulttype;
+                 lt:=hp.left.resulttype.def;
                  case lt^.deftype of
                    enumdef,
                    orddef :
@@ -1004,7 +1015,7 @@ implementation
                   begin
                     if vaddr then
                      begin
-                       emit_to_mem(hp.left.location,hp.left.resulttype);
+                       emit_to_mem(hp.left.location,hp.left.resulttype.def);
                        emit_push_lea_loc(hp.left.location,freetemp);
                        del_reference(hp.left.location.reference);
                      end
@@ -1018,7 +1029,7 @@ implementation
                     inc(href.offset,4);
                     if vaddr then
                      begin
-                       emit_to_mem(hp.left.location,hp.left.resulttype);
+                       emit_to_mem(hp.left.location,hp.left.resulttype.def);
                        emit_lea_loc_ref(hp.left.location,href,freetemp);
                      end
                     else
@@ -1061,7 +1072,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.11  2000-12-25 00:07:33  peter
+  Revision 1.12  2001-04-02 21:20:37  peter
+    * resulttype rewrite
+
+  Revision 1.11  2000/12/25 00:07:33  peter
     + new tlinkedlist class (merge of old tstringqueue,tcontainer and
       tlinkedlist objects)
 

compiler/i386/n386mat.pas

@@ -77,13 +77,13 @@ implementation
          shrdiv := false;
          andmod := false;
          secondpass(left);
-         pushed:=maybe_push(right.registers32,left,is_64bitint(left.resulttype));
+         pushed:=maybe_push(right.registers32,left,is_64bitint(left.resulttype.def));
          secondpass(right);
          if pushed then
-           restore(left,is_64bitint(left.resulttype));
+           restore(left,is_64bitint(left.resulttype.def));
          set_location(location,left.location);
 
-         if is_64bitint(resulttype) then
+         if is_64bitint(resulttype.def) then
            begin
               { save lcoation, because we change it now }
               set_location(hloc,location);
@@ -102,7 +102,7 @@ implementation
               clear_location(hloc);
               emit_pushq_loc(right.location);
 
-              if porddef(resulttype)^.typ=u64bit then
+              if porddef(resulttype.def)^.typ=u64bit then
                 typename:='QWORD'
               else
                 typename:='INT64';
@@ -148,7 +148,7 @@ implementation
                     {for signed numbers, the numerator must be adjusted before the
                      shift instruction, but not wih unsigned numbers! Otherwise,
                      "Cardinal($ffffffff) div 16" overflows! (JM)}
-                    If is_signed(left.resulttype) Then
+                    If is_signed(left.resulttype.def) Then
                       Begin
                         If (aktOptProcessor <> class386) and
                            not(CS_LittleSize in aktglobalswitches) then
@@ -200,7 +200,7 @@ implementation
                   End
                 else
                   if (nodetype=modn) and (right.nodetype=ordconstn) and
-                    ispowerof2(tordconstnode(right).value,power) and Not(is_signed(left.resulttype)) Then
+                    ispowerof2(tordconstnode(right).value,power) and Not(is_signed(left.resulttype.def)) Then
                    {is there a similar trick for MOD'ing signed numbers? (JM)}
                    Begin
                      emit_const_reg(A_AND,S_L,tordconstnode(right).value-1,hreg1);
@@ -260,13 +260,13 @@ implementation
                           end;
                      end;
                    { sign extension depends on the left type }
-                   if porddef(left.resulttype)^.typ=u32bit then
+                   if porddef(left.resulttype.def)^.typ=u32bit then
                       emit_reg_reg(A_XOR,S_L,R_EDX,R_EDX)
                    else
                       emit_none(A_CDQ,S_NO);
 
                    { division depends on the right type }
-                   if porddef(right.resulttype)^.typ=u32bit then
+                   if porddef(right.resulttype.def)^.typ=u32bit then
                      emit_reg(A_DIV,S_L,R_EDI)
                    else
                      emit_reg(A_IDIV,S_L,R_EDI);
@@ -346,12 +346,12 @@ implementation
          popecx:=false;
 
          secondpass(left);
-         pushed:=maybe_push(right.registers32,left,is_64bitint(left.resulttype));
+         pushed:=maybe_push(right.registers32,left,is_64bitint(left.resulttype.def));
          secondpass(right);
          if pushed then
-           restore(left,is_64bitint(left.resulttype));
+           restore(left,is_64bitint(left.resulttype.def));
 
-         if is_64bitint(left.resulttype) then
+         if is_64bitint(left.resulttype.def) then
            begin
               { load left operator in a register }
               if left.location.loc<>LOC_REGISTER then
@@ -663,7 +663,7 @@ implementation
         begin
            location.loc:=LOC_MMXREGISTER;
            if cs_mmx_saturation in aktlocalswitches then
-             case mmx_type(resulttype) of
+             case mmx_type(resulttype.def) of
                 mmxs8bit:
                   op:=A_PSUBSB;
                 mmxu8bit:
@@ -674,7 +674,7 @@ implementation
                   op:=A_PSUBUSW;
              end
            else
-             case mmx_type(resulttype) of
+             case mmx_type(resulttype.def) of
                 mmxs8bit,mmxu8bit:
                   op:=A_PSUBB;
                 mmxs16bit,mmxu16bit,mmxfixed16:
@@ -688,7 +688,7 @@ implementation
 {$endif}
 
       begin
-         if is_64bitint(left.resulttype) then
+         if is_64bitint(left.resulttype.def) then
            begin
               secondpass(left);
               clear_location(location);
@@ -761,16 +761,15 @@ implementation
                  LOC_REFERENCE,LOC_MEM:
                                 begin
                                    del_reference(left.location.reference);
-                                   if (left.resulttype^.deftype=floatdef) and
-                                      (pfloatdef(left.resulttype)^.typ<>f32bit) then
+                                   if (left.resulttype.def^.deftype=floatdef) then
                                      begin
                                         location.loc:=LOC_FPU;
-                                        floatload(pfloatdef(left.resulttype)^.typ,
+                                        floatload(pfloatdef(left.resulttype.def)^.typ,
                                           left.location.reference);
                                         emit_none(A_FCHS,S_NO);
                                      end
 {$ifdef SUPPORT_MMX}
-                                   else if (cs_mmx in aktlocalswitches) and is_mmx_able_array(left.resulttype) then
+                                   else if (cs_mmx in aktlocalswitches) and is_mmx_able_array(left.resulttype.def) then
                                      begin
                                         location.register:=getregistermmx;
                                         emit_reg_reg(A_PXOR,S_NO,R_MM7,R_MM7);
@@ -827,9 +826,9 @@ implementation
          hl : pasmlabel;
          opsize : topsize;
       begin
-         if is_boolean(resulttype) then
+         if is_boolean(resulttype.def) then
           begin
-            opsize:=def_opsize(resulttype);
+            opsize:=def_opsize(resulttype.def);
             { the second pass could change the location of left }
             { if it is a register variable, so we've to do      }
             { this before the case statement                    }
@@ -864,7 +863,7 @@ implementation
                 begin
                   clear_location(location);
                   location.loc:=LOC_REGISTER;
-                  location.register:=def_getreg(resulttype);
+                  location.register:=def_getreg(resulttype.def);
                   emit_reg_reg(A_MOV,opsize,left.location.register,location.register);
                   emit_reg_reg(A_TEST,opsize,location.register,location.register);
                   ungetregister(location.register);
@@ -878,7 +877,7 @@ implementation
                   location.loc:=LOC_REGISTER;
                   del_reference(left.location.reference);
                   { this was placed before del_ref => internaalerror(10) }
-                  location.register:=def_getreg(resulttype);
+                  location.register:=def_getreg(resulttype.def);
                   emit_ref_reg(A_MOV,opsize,
                     newreference(left.location.reference),location.register);
                   emit_reg_reg(A_TEST,opsize,location.register,location.register);
@@ -890,7 +889,7 @@ implementation
           end
 {$ifdef SUPPORT_MMX}
          else
-          if (cs_mmx in aktlocalswitches) and is_mmx_able_array(left.resulttype) then
+          if (cs_mmx in aktlocalswitches) and is_mmx_able_array(left.resulttype.def) then
            begin
              secondpass(left);
              location.loc:=LOC_MMXREGISTER;
@@ -925,7 +924,7 @@ implementation
              emit_reg_reg(A_PXOR,S_D,R_MM7,location.register);
            end
 {$endif SUPPORT_MMX}
-         else if is_64bitint(left.resulttype) then
+         else if is_64bitint(left.resulttype.def) then
            begin
               secondpass(left);
               clear_location(location);
@@ -998,7 +997,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.10  2001-02-03 12:52:34  jonas
+  Revision 1.11  2001-04-02 21:20:38  peter
+    * resulttype rewrite
+
+  Revision 1.10  2001/02/03 12:52:34  jonas
     * fixed web bug 1383
 
   Revision 1.9  2000/12/07 17:19:46  jonas
@@ -1010,7 +1012,7 @@ end.
     * added lots of longint typecast to prevent range check errors in the
       compiler and rtl
     * type casts of symbolic ordinal constants are now preserved
-    * fixed bug where the original resulttype wasn't restored correctly
+    * fixed bug where the original resulttype.def wasn't restored correctly
       after doing a 64bit rangecheck
 
   Revision 1.8  2000/12/05 11:44:33  jonas

compiler/i386/n386mem.pas

@@ -105,7 +105,7 @@ implementation
       begin
          location.register:=getregister32;
          emit_sym_ofs_reg(A_MOV,
-            S_L,newasmsymbol(pobjectdef(pclassrefdef(resulttype)^.pointertype.def)^.vmt_mangledname),0,
+            S_L,newasmsymbol(pobjectdef(pclassrefdef(resulttype.def)^.pointertype.def)^.vmt_mangledname),0,
             location.register);
       end;
 
@@ -140,16 +140,16 @@ implementation
               gettempofsizereference(target_os.size_of_pointer,location.reference);
 
               { determines the size of the mem block }
-              push_int(ppointerdef(resulttype)^.pointertype.def^.size);
+              push_int(ppointerdef(resulttype.def)^.pointertype.def^.size);
               emit_push_lea_loc(location,false);
               saveregvars($ff);
               emitcall('FPC_GETMEM');
 
-              if ppointerdef(resulttype)^.pointertype.def^.needs_inittable then
+              if ppointerdef(resulttype.def)^.pointertype.def^.needs_inittable then
                 begin
                    new(r);
                    reset_reference(r^);
-                   r^.symbol:=pstoreddef(ppointerdef(resulttype)^.pointertype.def)^.get_inittable_label;
+                   r^.symbol:=pstoreddef(ppointerdef(resulttype.def)^.pointertype.def)^.get_inittable_label;
                    emitpushreferenceaddr(r^);
                    dispose(r);
                    { push pointer we just allocated, we need to initialize the
@@ -159,7 +159,7 @@ implementation
                 end;
               popusedregisters(pushed);
               { may be load ESI }
-              maybe_loadesi;
+              maybe_loadself;
            end;
          if codegenerror then
            exit;
@@ -219,11 +219,11 @@ implementation
          case nodetype of
            simpledisposen:
              begin
-                if ppointerdef(left.resulttype)^.pointertype.def^.needs_inittable then
+                if ppointerdef(left.resulttype.def)^.pointertype.def^.needs_inittable then
                   begin
                      new(r);
                      reset_reference(r^);
-                     r^.symbol:=pstoreddef(ppointerdef(left.resulttype)^.pointertype.def)^.get_inittable_label;
+                     r^.symbol:=pstoreddef(ppointerdef(left.resulttype.def)^.pointertype.def)^.get_inittable_label;
                      emitpushreferenceaddr(r^);
                      dispose(r);
                      { push pointer adress }
@@ -236,14 +236,14 @@ implementation
            simplenewn:
              begin
                 { determines the size of the mem block }
-                push_int(ppointerdef(left.resulttype)^.pointertype.def^.size);
+                push_int(ppointerdef(left.resulttype.def)^.pointertype.def^.size);
                 emit_push_lea_loc(left.location,true);
                 emitcall('FPC_GETMEM');
-                if ppointerdef(left.resulttype)^.pointertype.def^.needs_inittable then
+                if ppointerdef(left.resulttype.def)^.pointertype.def^.needs_inittable then
                   begin
                      new(r);
                      reset_reference(r^);
-                     r^.symbol:=pstoreddef(ppointerdef(left.resulttype)^.pointertype.def)^.get_inittable_label;
+                     r^.symbol:=pstoreddef(ppointerdef(left.resulttype.def)^.pointertype.def)^.get_inittable_label;
                      emitpushreferenceaddr(r^);
                      dispose(r);
                      emit_push_loc(left.location);
@@ -253,7 +253,7 @@ implementation
          end;
          popusedregisters(pushed);
          { may be load ESI }
-         maybe_loadesi;
+         maybe_loadself;
       end;
 
 
@@ -293,9 +293,9 @@ implementation
            emit_ref_reg(A_LEA,S_L,
              newreference(left.location.reference),
              location.register);
-           { for use of other segments }
-           if left.location.reference.segment<>R_NO then
-             location.segment:=left.location.reference.segment;
+         { for use of other segments }
+         if left.location.reference.segment<>R_NO then
+           location.segment:=left.location.reference.segment;
       end;
 
 
@@ -348,9 +348,9 @@ implementation
                  location.reference.base:=hr;
               end;
          end;
-         if ppointerdef(left.resulttype)^.is_far then
+         if ppointerdef(left.resulttype.def)^.is_far then
           location.reference.segment:=R_FS;
-         if not ppointerdef(left.resulttype)^.is_far and
+         if not ppointerdef(left.resulttype.def)^.is_far and
             (cs_gdb_heaptrc in aktglobalswitches) and
             (cs_checkpointer in aktglobalswitches) then
               begin
@@ -373,7 +373,7 @@ implementation
          if codegenerror then
            exit;
          { classes and interfaces must be dereferenced implicit }
-         if is_class_or_interface(left.resulttype) then
+         if is_class_or_interface(left.resulttype.def) then
            begin
              reset_reference(location.reference);
              case left.location.loc of
@@ -400,7 +400,7 @@ implementation
                   end;
              end;
            end
-         else if is_interfacecom(left.resulttype) then
+         else if is_interfacecom(left.resulttype.def) then
            begin
               gettempintfcomreference(location.reference);
               emit_mov_loc_ref(left.location,location.reference,S_L,false);
@@ -428,10 +428,10 @@ implementation
              get_mul_size:=1
             else
              begin
-               if (left.resulttype^.deftype=arraydef) then
-                get_mul_size:=parraydef(left.resulttype)^.elesize
+               if (left.resulttype.def^.deftype=arraydef) then
+                get_mul_size:=parraydef(left.resulttype.def)^.elesize
                else
-                get_mul_size:=resulttype^.size;
+                get_mul_size:=resulttype.def^.size;
              end
           end;
 
@@ -454,7 +454,7 @@ implementation
 
       var
          extraoffset : longint;
-         { rl stores the resulttype of the left node, this is necessary }
+         { rl stores the resulttype.def of the left node, this is necessary }
          { to detect if it is an ansistring                          }
          { because in constant nodes which constant index              }
          { the left tree is removed                                  }
@@ -471,8 +471,8 @@ implementation
          { we load the array reference to location }
 
          { an ansistring needs to be dereferenced }
-         if is_ansistring(left.resulttype) or
-           is_widestring(left.resulttype) then
+         if is_ansistring(left.resulttype.def) or
+           is_widestring(left.resulttype.def) then
            begin
               reset_reference(location.reference);
               if nf_callunique in flags then
@@ -485,11 +485,11 @@ implementation
                    pushusedregisters(pushed,$ff);
                    emitpushreferenceaddr(left.location.reference);
                    saveregvars($ff);
-                   if is_ansistring(left.resulttype) then
+                   if is_ansistring(left.resulttype.def) then
                      emitcall('FPC_ANSISTR_UNIQUE')
                    else
                      emitcall('FPC_WIDESTR_UNIQUE');
-                   maybe_loadesi;
+                   maybe_loadself;
                    popusedregisters(pushed);
                 end;
 
@@ -514,11 +514,11 @@ implementation
                    emit_reg(A_PUSH,S_L,location.reference.base);
                    saveregvars($ff);
                    emitcall('FPC_ANSISTR_CHECKZERO');
-                   maybe_loadesi;
+                   maybe_loadself;
                    popusedregisters(pushed);
                 end;
 
-              if is_ansistring(left.resulttype) then
+              if is_ansistring(left.resulttype.def) then
                 { in ansistrings S[1] is pchar(S)[0] !! }
                 dec(location.reference.offset)
               else
@@ -533,7 +533,7 @@ implementation
               { if a constant array index occurs, subject to change (FK) }
               set_location(left.location,location);
            end
-         else if is_dynamic_array(left.resulttype) then
+         else if is_dynamic_array(left.resulttype.def) then
          { ... also a dynamic string }
            begin
               reset_reference(location.reference);
@@ -559,7 +559,7 @@ implementation
                    emit_reg(A_PUSH,S_L,location.reference.base);
                    saveregvars($ff);
                    emitcall('FPC_ANSISTR_CHECKZERO');
-                   maybe_loadesi;
+                   maybe_loadself;
                    popusedregisters(pushed);
                 end;
 
@@ -571,21 +571,21 @@ implementation
            set_location(location,left.location);
 
          { offset can only differ from 0 if arraydef }
-         if (left.resulttype^.deftype=arraydef) and
-           not(is_dynamic_array(left.resulttype)) then
+         if (left.resulttype.def^.deftype=arraydef) and
+           not(is_dynamic_array(left.resulttype.def)) then
            dec(location.reference.offset,
-               get_mul_size*parraydef(left.resulttype)^.lowrange);
+               get_mul_size*parraydef(left.resulttype.def)^.lowrange);
          if right.nodetype=ordconstn then
            begin
               { offset can only differ from 0 if arraydef }
-              if (left.resulttype^.deftype=arraydef) then
+              if (left.resulttype.def^.deftype=arraydef) then
                 begin
-                   if not(is_open_array(left.resulttype)) and
-                      not(is_array_of_const(left.resulttype)) and
-                      not(is_dynamic_array(left.resulttype)) then
+                   if not(is_open_array(left.resulttype.def)) and
+                      not(is_array_of_const(left.resulttype.def)) and
+                      not(is_dynamic_array(left.resulttype.def)) then
                      begin
-                        if (tordconstnode(right).value>parraydef(left.resulttype)^.highrange) or
-                           (tordconstnode(right).value<parraydef(left.resulttype)^.lowrange) then
+                        if (tordconstnode(right).value>parraydef(left.resulttype.def)^.highrange) or
+                           (tordconstnode(right).value<parraydef(left.resulttype.def)^.lowrange) then
                            begin
                               if (cs_check_range in aktlocalswitches) then
                                 CGMessage(parser_e_range_check_error)
@@ -593,7 +593,7 @@ implementation
                                 CGMessage(parser_w_range_check_error);
                            end;
                         dec(left.location.reference.offset,
-                            get_mul_size*parraydef(left.resulttype)^.lowrange);
+                            get_mul_size*parraydef(left.resulttype.def)^.lowrange);
                      end
                    else
                      begin
@@ -602,13 +602,13 @@ implementation
                         {!!!!!!!!!!!!!!!!!}
                      end;
                 end
-              else if (left.resulttype^.deftype=stringdef) then
+              else if (left.resulttype.def^.deftype=stringdef) then
                 begin
-                   if (tordconstnode(right).value=0) and not(is_shortstring(left.resulttype)) then
+                   if (tordconstnode(right).value=0) and not(is_shortstring(left.resulttype.def)) then
                      CGMessage(cg_e_can_access_element_zero);
 
                    if (cs_check_range in aktlocalswitches) then
-                     case pstringdef(left.resulttype)^.string_typ of
+                     case pstringdef(left.resulttype.def)^.string_typ of
                         { it's the same for ansi- and wide strings }
                         st_widestring,
                         st_ansistring:
@@ -621,7 +621,7 @@ implementation
                              saveregvars($ff);
                              emitcall('FPC_ANSISTR_RANGECHECK');
                              popusedregisters(pushed);
-                             maybe_loadesi;
+                             maybe_loadself;
                           end;
 
                         st_shortstring:
@@ -640,7 +640,7 @@ implementation
               if nf_memseg in flags then
                 left.location.reference.segment:=R_FS;
               {
-              left.resulttype:=resulttype;
+              left.resulttype:=resulttype.def;
               disposetree(right);
               _p:=left;
               putnode(p);
@@ -656,7 +656,7 @@ implementation
               { need that fancy code (it would be }
               { buggy)                            }
                 not(cs_check_range in aktlocalswitches) and
-                (left.resulttype^.deftype=arraydef) then
+                (left.resulttype.def^.deftype=arraydef) then
                 begin
                    extraoffset:=0;
                    if (right.nodetype=addn) then
@@ -733,25 +733,25 @@ implementation
 
               if cs_check_range in aktlocalswitches then
                begin
-                 if left.resulttype^.deftype=arraydef then
+                 if left.resulttype.def^.deftype=arraydef then
                    begin
-                     if is_open_array(left.resulttype) or
-                        is_array_of_const(left.resulttype) then
+                     if is_open_array(left.resulttype.def) or
+                        is_array_of_const(left.resulttype.def) then
                       begin
                         reset_reference(href);
-                        parraydef(left.resulttype)^.genrangecheck;
-                        href.symbol:=newasmsymbol(parraydef(left.resulttype)^.getrangecheckstring);
+                        parraydef(left.resulttype.def)^.genrangecheck;
+                        href.symbol:=newasmsymbol(parraydef(left.resulttype.def)^.getrangecheckstring);
                         href.offset:=4;
                         srsym:=searchsymonlyin(tloadnode(left).symtable,
                           'high'+pvarsym(tloadnode(left).symtableentry)^.name);
-                        hightree:=genloadnode(pvarsym(srsym),tloadnode(left).symtable);
+                        hightree:=cloadnode.create(pvarsym(srsym),tloadnode(left).symtable);
                         firstpass(hightree);
                         secondpass(hightree);
                         emit_mov_loc_ref(hightree.location,href,S_L,true);
                         hightree.free;
                         hightree:=nil;
                       end;
-                     emitrangecheck(right,left.resulttype);
+                     emitrangecheck(right,left.resulttype.def);
                    end;
                end;
 
@@ -759,7 +759,7 @@ implementation
                  LOC_REGISTER:
                    begin
                       ind:=right.location.register;
-                      case right.resulttype^.size of
+                      case right.resulttype.def^.size of
                          1:
                            begin
                               hr:=reg8toreg32(ind);
@@ -777,7 +777,7 @@ implementation
                  LOC_CREGISTER:
                    begin
                       ind:=getregister32;
-                      case right.resulttype^.size of
+                      case right.resulttype.def^.size of
                          1:
                            emit_reg_reg(A_MOVZX,S_BL,right.location.register,ind);
                          2:
@@ -811,7 +811,7 @@ implementation
                       ind:=getregister32;
                       { Booleans are stored in an 8 bit memory location, so
                         the use of MOVL is not correct }
-                      case right.resulttype^.size of
+                      case right.resulttype.def^.size of
                        1 : tai:=Taicpu.Op_ref_reg(A_MOVZX,S_BL,newreference(right.location.reference),ind);
                        2 : tai:=Taicpu.Op_ref_reg(A_MOVZX,S_WL,newreference(right.location.reference),ind);
                        4 : tai:=Taicpu.Op_ref_reg(A_MOV,S_L,newreference(right.location.reference),ind);
@@ -825,13 +825,13 @@ implementation
             { produce possible range check code: }
               if cs_check_range in aktlocalswitches then
                begin
-                 if left.resulttype^.deftype=arraydef then
+                 if left.resulttype.def^.deftype=arraydef then
                    begin
                      { done defore (PM) }
                    end
-                 else if (left.resulttype^.deftype=stringdef) then
+                 else if (left.resulttype.def^.deftype=stringdef) then
                    begin
-                      case pstringdef(left.resulttype)^.string_typ of
+                      case pstringdef(left.resulttype.def)^.string_typ of
                          { it's the same for ansi- and wide strings }
                          st_widestring,
                          st_ansistring:
@@ -844,7 +844,7 @@ implementation
                               saveregvars($ff);
                               emitcall('FPC_ANSISTR_RANGECHECK');
                               popusedregisters(pushed);
-                              maybe_loadesi;
+                              maybe_loadself;
                            end;
                          st_shortstring:
                            begin
@@ -906,8 +906,8 @@ implementation
       begin
          reset_reference(location.reference);
          getexplicitregister32(R_ESI);
-         if (resulttype^.deftype=classrefdef) or
-           is_class(resulttype) then
+         if (resulttype.def^.deftype=classrefdef) or
+           is_class(resulttype.def) then
            location.register:=R_ESI
          else
            location.reference.base:=R_ESI;
@@ -948,7 +948,7 @@ implementation
                  end
                else
                 { call can have happend with a property }
-                if is_class_or_interface(left.resulttype) then
+                if is_class_or_interface(left.resulttype.def) then
                  begin
 {$ifndef noAllocEdi}
                     getexplicitregister32(R_EDI);
@@ -998,7 +998,7 @@ implementation
                       emitlab(withstartlabel);
                       withdebugList.concat(Tai_stabs.Create(strpnew(
                          '"with'+tostr(withlevel)+':'+tostr(symtablestack^.getnewtypecount)+
-                         '=*'+pstoreddef(left.resulttype)^.numberstring+'",'+
+                         '=*'+pstoreddef(left.resulttype.def)^.numberstring+'",'+
                          tostr(N_LSYM)+',0,0,'+tostr(withreference^.offset))));
                       mangled_length:=length(aktprocsym^.definition^.mangledname);
                       getmem(pp,mangled_length+50);
@@ -1061,7 +1061,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.10  2001-03-11 22:58:52  peter
+  Revision 1.11  2001-04-02 21:20:38  peter
+    * resulttype rewrite
+
+  Revision 1.10  2001/03/11 22:58:52  peter
     * getsym redesign, removed the globals srsym,srsymtable
 
   Revision 1.9  2001/02/02 22:38:00  peter

compiler/i386/n386opt.pas

@@ -29,6 +29,7 @@ uses node, nopt;
 
 type
   ti386addsstringcharoptnode = class(taddsstringcharoptnode)
+     function det_resulttype: tnode; override;
      function pass_1: tnode; override;
      procedure pass_2; override;
   end;
@@ -40,7 +41,7 @@ type
 
 implementation
 
-uses pass_1, types, htypechk, temp_gen, cpubase, cpuasm, cgai386, verbose,
+uses pass_1, types, htypechk, hcodegen, temp_gen, cpubase, cgai386,
      tgcpu, aasm, ncnv, ncon, pass_2, symdef;
 
 
@@ -48,28 +49,34 @@ uses pass_1, types, htypechk, temp_gen, cpubase, cpuasm, cgai386, verbose,
                              TI386ADDOPTNODE
 *****************************************************************************}
 
+function ti386addsstringcharoptnode.det_resulttype: tnode;
+begin
+  det_resulttype := nil;
+  resulttypepass(left);
+  resulttypepass(right);
+  if codegenerror then
+    exit;
+  { update the curmaxlen field (before converting to a string!) }
+  updatecurmaxlen;
+  if not is_shortstring(left.resulttype.def) then
+    inserttypeconv(left,cshortstringtype);
+  resulttype:=left.resulttype;
+end;
+
+
 function ti386addsstringcharoptnode.pass_1: tnode;
 begin
   pass_1 := nil;
-{ already done before it's created (JM)
   firstpass(left);
   firstpass(right);
   if codegenerror then
-    exit; }
-  { update the curmaxlen field (before converting to a string!) }
-  updatecurmaxlen;
-  if not is_shortstring(left.resulttype) then
-    begin
-      left := gentypeconvnode(left,cshortstringdef);
-      firstpass(left);
-    end;
+    exit;
   location.loc := LOC_MEM;
   if not is_constcharnode(right) then
     { it's not sure we need the register, but we can't know it here yet }
     calcregisters(self,2,0,0)
   else
     calcregisters(self,1,0,0);
-  resulttype := left.resulttype;
 end;
 
 
@@ -128,7 +135,7 @@ begin
   if istemp(left.location.reference) then
     checklength := curmaxlen = 255
   else
-    checklength := curmaxlen >= pstringdef(left.resulttype)^.len;
+    checklength := curmaxlen >= pstringdef(left.resulttype.def)^.len;
   if checklength then
     begin
       { is it already maximal? }
@@ -136,7 +143,7 @@ begin
       if istemp(left.location.reference) then
         emit_const_reg(A_CMP,S_L,255,lengthreg)
       else
-        emit_const_reg(A_CMP,S_L,pstringdef(left.resulttype)^.len,lengthreg);
+        emit_const_reg(A_CMP,S_L,pstringdef(left.resulttype.def)^.len,lengthreg);
       emitjmp(C_E,l);
     end;
 
@@ -229,7 +236,7 @@ begin
   saveregvars(regstopush);
   emitcall('FPC_SHORTSTR_CONCAT');
   ungetiftemp(right.location.reference);
-  maybe_loadesi;
+  maybe_loadself;
   popusedregisters(pushedregs);
   set_location(location,left.location);
 end;
@@ -241,7 +248,10 @@ end.
 
 {
   $Log$
-  Revision 1.2  2001-01-06 19:12:31  jonas
+  Revision 1.3  2001-04-02 21:20:38  peter
+    * resulttype rewrite
+
+  Revision 1.2  2001/01/06 19:12:31  jonas
     * fixed IE 10 (but code is less efficient now :( )
 
   Revision 1.1  2001/01/04 11:24:19  jonas

compiler/i386/n386set.pas

@@ -168,13 +168,13 @@ implementation
 
        begin
          { We check first if we can generate jumps, this can be done
-           because the resulttype is already set in firstpass }
+           because the resulttype.def is already set in firstpass }
 
          { check if we can use smallset operation using btl which is limited
            to 32 bits, the left side may also not contain higher values !! }
-         use_small:=(psetdef(right.resulttype)^.settype=smallset) and
-                    ((left.resulttype^.deftype=orddef) and (porddef(left.resulttype)^.high<=32) or
-                     (left.resulttype^.deftype=enumdef) and (penumdef(left.resulttype)^.max<=32));
+         use_small:=(psetdef(right.resulttype.def)^.settype=smallset) and
+                    ((left.resulttype.def^.deftype=orddef) and (porddef(left.resulttype.def)^.high<=32) or
+                     (left.resulttype.def^.deftype=enumdef) and (penumdef(left.resulttype.def)^.max<=32));
 
          { Can we generate jumps? Possible for all types of sets }
          genjumps:=(right.nodetype=setconstn) and
@@ -694,7 +694,7 @@ implementation
              if assigned(t^.less) then
                genitem(t^.less);
              { need we to test the first value }
-             if first and (t^._low>get_min_value(left.resulttype)) then
+             if first and (t^._low>get_min_value(left.resulttype.def)) then
                begin
                   emit_const_reg(A_CMP,opsize,longint(t^._low),hregister);
                   emitjmp(jmp_le,elselabel);
@@ -716,7 +716,7 @@ implementation
                   if first then
                     begin
                        { have we to ajust the first value ? }
-                       if (t^._low>get_min_value(left.resulttype)) then
+                       if (t^._low>get_min_value(left.resulttype.def)) then
                          gensub(t^._low);
                     end
                   else
@@ -847,7 +847,7 @@ implementation
            jumpsegment:=procinfo^.aktlocaldata
          else
            jumpsegment:=datasegment;
-         with_sign:=is_signed(left.resulttype);
+         with_sign:=is_signed(left.resulttype.def);
          if with_sign then
            begin
               jmp_gt:=C_G;
@@ -872,7 +872,7 @@ implementation
            end;
          secondpass(left);
          { determines the size of the operand }
-         opsize:=bytes2Sxx[left.resulttype^.size];
+         opsize:=bytes2Sxx[left.resulttype.def^.size];
          { copy the case expression to a register }
          case left.location.loc of
             LOC_REGISTER:
@@ -965,7 +965,7 @@ implementation
                    max_label:=case_get_max(nodes);
                    labels:=case_count_labels(nodes);
                    { can we omit the range check of the jump table ? }
-                   getrange(left.resulttype,lv,hv);
+                   getrange(left.resulttype.def,lv,hv);
                    jumptable_no_range:=(lv=min_label) and (hv=max_label);
                    { hack a little bit, because the range can be greater }
                    { than the positive range of a longint            }
@@ -1067,7 +1067,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.11  2001-02-11 12:14:56  jonas
+  Revision 1.12  2001-04-02 21:20:38  peter
+    * resulttype rewrite
+
+  Revision 1.11  2001/02/11 12:14:56  jonas
     * simplified and optimized code generated for in-statements
 
   Revision 1.10  2000/12/25 00:07:33  peter

compiler/i386/n386util.pas

@@ -153,7 +153,7 @@ implementation
            begin
               if (p^.location.loc=LOC_REGISTER) then
                 begin
-                   if isint64(p^.resulttype) then
+                   if isint64(p^.resulttype.def) then
                      begin
                         gettempofsizereference(href,8);
                         p^.temp_offset:=href.offset;
@@ -353,41 +353,37 @@ implementation
            LOC_REGISTER,
            LOC_CREGISTER:
              begin
-                case p.location.register of
+                  if p.resulttype.def^.size=8 then
+                    begin
+                       inc(pushedparasize,8);
+                       if inlined then
+                         begin
+                            r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize);
+                            exprasmlist.concat(taicpu.op_reg_ref(A_MOV,S_L,p.location.registerlow,r));
+                            r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize+4);
+                            exprasmlist.concat(taicpu.op_reg_ref(A_MOV,S_L,p.location.registerhigh,r));
+                         end
+                       else
+                         begin
+                           exprasmlist.concat(taicpu.op_reg(A_PUSH,S_L,p.location.registerhigh));
+                           exprasmlist.concat(taicpu.op_reg(A_PUSH,S_L,p.location.registerlow));
+                         end;
+                       ungetregister32(p.location.registerhigh);
+                       ungetregister32(p.location.registerlow);
+                    end
+                  else case p.location.register of
                    R_EAX,R_EBX,R_ECX,R_EDX,R_ESI,
                    R_EDI,R_ESP,R_EBP :
                       begin
-                        if p.resulttype^.size=8 then
-                          begin
-                             inc(pushedparasize,8);
-                             if inlined then
-                               begin
-                                  r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize);
-                                  exprasmList.concat(Taicpu.Op_reg_ref(A_MOV,S_L,
-                                    p.location.registerlow,r));
-                                  r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize+4);
-                                  exprasmList.concat(Taicpu.Op_reg_ref(A_MOV,S_L,
-                                    p.location.registerhigh,r));
-                               end
-                             else
-                               exprasmList.concat(Taicpu.Op_reg(A_PUSH,S_L,p.location.registerhigh));
-                             ungetregister32(p.location.registerhigh);
-                               exprasmList.concat(Taicpu.Op_reg(A_PUSH,S_L,p.location.registerlow));
-                             ungetregister32(p.location.registerlow);
-                          end
+                        inc(pushedparasize,4);
+                        if inlined then
+                         begin
+                           r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize);
+                           exprasmList.concat(Taicpu.Op_reg_ref(A_MOV,S_L,p.location.register,r));
+                         end
                         else
-                          begin
-                             inc(pushedparasize,4);
-                             if inlined then
-                               begin
-                                  r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize);
-                                  exprasmList.concat(Taicpu.Op_reg_ref(A_MOV,S_L,
-                                    p.location.register,r));
-                               end
-                             else
-                               exprasmList.concat(Taicpu.Op_reg(A_PUSH,S_L,p.location.register));
-                             ungetregister32(p.location.register);
-                          end;
+                         exprasmList.concat(Taicpu.Op_reg(A_PUSH,S_L,p.location.register));
+                        ungetregister32(p.location.register);
                       end;
                    R_AX,R_BX,R_CX,R_DX,R_SI,R_DI:
                       begin
@@ -441,7 +437,7 @@ implementation
              end;
            LOC_FPU:
              begin
-                size:=align(pfloatdef(p.resulttype)^.size,alignment);
+                size:=align(pfloatdef(p.resulttype.def)^.size,alignment);
                 inc(pushedparasize,size);
                 if not inlined then
                  emit_const_reg(A_SUB,S_L,size,R_ESP);
@@ -451,7 +447,7 @@ implementation
                   exprasmList.concat(Tai_force_line.Create);
 {$endif GDB}
                 r:=new_reference(R_ESP,0);
-                floatstoreops(pfloatdef(p.resulttype)^.typ,op,opsize);
+                floatstoreops(pfloatdef(p.resulttype.def)^.typ,op,opsize);
                 { this is the easiest case for inlined !! }
                 if inlined then
                   begin
@@ -465,7 +461,7 @@ implementation
              begin
                 exprasmList.concat(Taicpu.Op_reg(A_FLD,S_NO,
                   correct_fpuregister(p.location.register,fpuvaroffset)));
-                size:=align(pfloatdef(p.resulttype)^.size,alignment);
+                size:=align(pfloatdef(p.resulttype.def)^.size,alignment);
                 inc(pushedparasize,size);
                 if not inlined then
                  emit_const_reg(A_SUB,S_L,size,R_ESP);
@@ -475,7 +471,7 @@ implementation
                   exprasmList.concat(Tai_force_line.Create);
 {$endif GDB}
                 r:=new_reference(R_ESP,0);
-                floatstoreops(pfloatdef(p.resulttype)^.typ,op,opsize);
+                floatstoreops(pfloatdef(p.resulttype.def)^.typ,op,opsize);
                 { this is the easiest case for inlined !! }
                 if inlined then
                   begin
@@ -488,11 +484,11 @@ implementation
              begin
                 tempreference:=p.location.reference;
                 del_reference(p.location.reference);
-                case p.resulttype^.deftype of
+                case p.resulttype.def^.deftype of
                   enumdef,
                   orddef :
                     begin
-                      case p.resulttype^.size of
+                      case p.resulttype.def^.size of
                        8 : begin
                              inc(pushedparasize,8);
                              if inlined then
@@ -556,7 +552,7 @@ implementation
                                 ungetregister32(R_EDI);
                               end
                              else
-                              emit_push_mem_size(tempreference,p.resulttype^.size);
+                              emit_push_mem_size(tempreference,p.resulttype.def^.size);
                            end;
                          else
                            internalerror(234231);
@@ -564,8 +560,7 @@ implementation
                     end;
                   floatdef :
                     begin
-                      case pfloatdef(p.resulttype)^.typ of
-                        f32bit,
+                      case pfloatdef(p.resulttype.def)^.typ of
                         s32real :
                           begin
                              inc(pushedparasize,4);
@@ -695,23 +690,23 @@ implementation
                   objectdef :
                     begin
                        { even some structured types are 32 bit }
-                       if is_widestring(p.resulttype) or
-                          is_ansistring(p.resulttype) or
-                          is_smallset(p.resulttype) or
-                          ((p.resulttype^.deftype in [recorddef,arraydef]) and
+                       if is_widestring(p.resulttype.def) or
+                          is_ansistring(p.resulttype.def) or
+                          is_smallset(p.resulttype.def) or
+                          ((p.resulttype.def^.deftype in [recorddef,arraydef]) and
                            (
-                            (p.resulttype^.deftype<>arraydef) or not
-                            (parraydef(p.resulttype)^.IsConstructor or
-                             parraydef(p.resulttype)^.isArrayOfConst or
-                             is_open_array(p.resulttype))
+                            (p.resulttype.def^.deftype<>arraydef) or not
+                            (parraydef(p.resulttype.def)^.IsConstructor or
+                             parraydef(p.resulttype.def)^.isArrayOfConst or
+                             is_open_array(p.resulttype.def))
                            ) and
-                           (p.resulttype^.size<=4)
+                           (p.resulttype.def^.size<=4)
                           ) or
-                          is_class(p.resulttype) or
-                          is_interface(p.resulttype) then
+                          is_class(p.resulttype.def) or
+                          is_interface(p.resulttype.def) then
                          begin
-                            if (p.resulttype^.size>2) or
-                               ((alignment=4) and (p.resulttype^.size>0)) then
+                            if (p.resulttype.def^.size>2) or
+                               ((alignment=4) and (p.resulttype.def^.size>0)) then
                               begin
                                 inc(pushedparasize,4);
                                 if inlined then
@@ -724,7 +719,7 @@ implementation
                               end
                             else
                               begin
-                                if p.resulttype^.size>0 then
+                                if p.resulttype.def^.size>0 then
                                   begin
                                     inc(pushedparasize,2);
                                     if inlined then
@@ -741,7 +736,7 @@ implementation
                        else if is_cdecl then
                          begin
                            { push on stack }
-                           size:=align(p.resulttype^.size,alignment);
+                           size:=align(p.resulttype.def^.size,alignment);
                            inc(pushedparasize,size);
                            emit_const_reg(A_SUB,S_L,size,R_ESP);
                            r:=new_reference(R_ESP,0);
@@ -865,7 +860,7 @@ implementation
            exit;
          storepos:=aktfilepos;
          aktfilepos:=p.fileinfo;
-         if is_boolean(p.resulttype) then
+         if is_boolean(p.resulttype.def) then
            begin
               load_all_regvars(exprasmlist);
               if is_constboolnode(p) then
@@ -877,7 +872,7 @@ implementation
                 end
               else
                 begin
-                   opsize:=def_opsize(p.resulttype);
+                   opsize:=def_opsize(p.resulttype.def);
                    case p.location.loc of
                       LOC_CREGISTER,LOC_REGISTER : begin
                                         emit_reg_reg(A_OR,opsize,p.location.register,
@@ -914,9 +909,9 @@ implementation
          if not(cs_check_overflow in aktlocalswitches) then
           exit;
          getlabel(hl);
-         if not ((p.resulttype^.deftype=pointerdef) or
-                ((p.resulttype^.deftype=orddef) and
-                 (porddef(p.resulttype)^.typ in [u64bit,u16bit,u32bit,u8bit,uchar,
+         if not ((p.resulttype.def^.deftype=pointerdef) or
+                ((p.resulttype.def^.deftype=orddef) and
+                 (porddef(p.resulttype.def)^.typ in [u64bit,u16bit,u32bit,u8bit,uchar,
                                                   bool8bit,bool16bit,bool32bit]))) then
            emitjmp(C_NO,hl)
          else
@@ -943,7 +938,7 @@ implementation
         from_signed,to_signed: boolean;
 
       begin
-         fromdef:=p.resulttype;
+         fromdef:=p.resulttype.def;
          from_signed := is_signed(fromdef);
          to_signed := is_signed(todef);
 
@@ -984,12 +979,12 @@ implementation
              { simple cardinal                                          }
              emitlab(poslabel);
              new(hdef,init(u32bit,0,longint($ffffffff)));
-             { the real p.resulttype is already saved in fromdef }
-             p.resulttype := hdef;
+             { the real p.resulttype.def is already saved in fromdef }
+             p.resulttype.def := hdef;
              emitrangecheck(p,todef);
              dispose(hdef,done);
-             { restore original resulttype }
-             p.resulttype := todef;
+             { restore original resulttype.def }
+             p.resulttype.def := todef;
 
              if from_signed and to_signed then
                begin
@@ -1019,14 +1014,14 @@ implementation
                  { longint($80000000) and -1 (JM)               }
                  emitlab(neglabel);
                  new(hdef,init(s32bit,longint($80000000),-1));
-                 p.resulttype := hdef;
+                 p.resulttype.def := hdef;
                  emitrangecheck(p,todef);
                  dispose(hdef,done);
                  emitlab(endlabel);
                end;
              registerdef := oldregisterdef;
-             p.resulttype := fromdef;
-             { restore p's resulttype }
+             p.resulttype.def := fromdef;
+             { restore p's resulttype.def }
            end
          else
            { todef = 64bit int }
@@ -1048,7 +1043,7 @@ implementation
                else
                  begin
                    hreg := getexplicitregister32(R_EDI);
-                   case p.resulttype^.size of
+                   case p.resulttype.def^.size of
                      1: opsize := S_BL;
                      2: opsize := S_WL;
                      4,8: opsize := S_L;
@@ -1060,7 +1055,7 @@ implementation
                    else
                      opcode := A_MOV;
                    href := newreference(p.location.reference);
-                   if p.resulttype^.size = 8 then
+                   if p.resulttype.def^.size = 8 then
                      inc(href^.offset,4);
                    emit_ref_reg(opcode,opsize,href,hreg);
                  end;
@@ -1078,7 +1073,7 @@ implementation
      procedure emitrangecheck(p:tnode;todef:pdef);
      {
        generate range checking code for the value at location t. The
-       type used is the checked against todefs ranges. fromdef (p.resulttype)
+       type used is the checked against todefs ranges. fromdef (p.resulttype.def)
        is the original type used at that location, when both defs are
        equal the check is also insert (needed for succ,pref,inc,dec)
      }
@@ -1097,7 +1092,7 @@ implementation
           exit;
         { only check when assigning to scalar, subranges are different,
           when todef=fromdef then the check is always generated }
-        fromdef:=p.resulttype;
+        fromdef:=p.resulttype.def;
         { no range check if from and to are equal and are both longint/dword or }
         { int64/qword, since such operations can at most cause overflows (JM)   }
         if (fromdef = todef) and
@@ -1120,7 +1115,7 @@ implementation
         getrange(todef,lto,hto);
         if todef<>fromdef then
          begin
-           getrange(p.resulttype,lfrom,hfrom);
+           getrange(p.resulttype.def,lfrom,hfrom);
            { first check for not being u32bit, then if the to is bigger than
              from }
            if (lto<hto) and (lfrom<hfrom) and
@@ -1130,7 +1125,7 @@ implementation
         { generate the rangecheck code for the def where we are going to
           store the result }
       { get op and opsize }
-        opsize:=def2def_opsize(fromdef,u32bitdef);
+        opsize:=def2def_opsize(fromdef,u32bittype.def);
         if opsize in [S_B,S_W,S_L] then
          op:=A_MOV
         else
@@ -1213,8 +1208,8 @@ implementation
       begin
          { always calculate boolean AND and OR from left to right }
          if (p.nodetype in [orn,andn]) and
-            (p.left.resulttype^.deftype=orddef) and
-            (porddef(p.left.resulttype)^.typ in [bool8bit,bool16bit,bool32bit]) then
+            (p.left.resulttype.def^.deftype=orddef) and
+            (porddef(p.left.resulttype.def)^.typ in [bool8bit,bool16bit,bool32bit]) then
            begin
              { p.swaped:=false}
              if nf_swaped in p.flags then
@@ -1249,10 +1244,10 @@ implementation
         hightree : tnode;
         srsym    : psym;
       begin
-        if is_open_string(p.resulttype) then
+        if is_open_string(p.resulttype.def) then
          begin
            srsym:=searchsymonlyin(tloadnode(p).symtable,'high'+pvarsym(tloadnode(p).symtableentry)^.name);
-           hightree:=genloadnode(pvarsym(srsym),tloadnode(p).symtable);
+           hightree:=cloadnode.create(pvarsym(srsym),tloadnode(p).symtable);
            firstpass(hightree);
            secondpass(hightree);
            push_value_para(hightree,false,false,0,4);
@@ -1261,7 +1256,7 @@ implementation
          end
         else
          begin
-           push_int(pstringdef(p.resulttype)^.len);
+           push_int(pstringdef(p.resulttype.def)^.len);
          end;
       end;
 
@@ -1276,7 +1271,7 @@ implementation
       var
         href: treference;
       begin
-         case source.resulttype^.deftype of
+         case source.resulttype.def^.deftype of
             stringdef:
               begin
                  if (source.nodetype=stringconstn) and
@@ -1289,7 +1284,7 @@ implementation
                      emitpushreferenceaddr(source.location.reference);
                      push_shortstring_length(dest);
                      emitcall('FPC_SHORTSTR_COPY');
-                     maybe_loadesi;
+                     maybe_loadself;
                    end;
               end;
             orddef:
@@ -1337,7 +1332,7 @@ implementation
          r : preference;
 
       begin
-         case p.right.resulttype^.deftype of
+         case p.right.resulttype.def^.deftype of
             stringdef:
               begin
                  if (p.right.nodetype=stringconstn) and
@@ -1349,7 +1344,7 @@ implementation
                      emitpushreferenceaddr(p.right.location.reference);
                      push_shortstring_length(p.left);
                      emitcall('FPC_LONGSTR_COPY');
-                     maybe_loadesi;
+                     maybe_loadself;
                    end;
               end;
             orddef:
@@ -1422,7 +1417,7 @@ implementation
          saveregvars($ff);
          emitcall('FPC_ANSISTR_TO_SHORTSTR');
          popusedregisters(pushed);
-         maybe_loadesi;
+         maybe_loadself;
       end;
 
     procedure loadinterfacecom(p: tbinarynode);
@@ -1466,7 +1461,7 @@ implementation
          del_reference(p.left.location.reference);
          saveregvars($ff);
          emitcall('FPC_INTF_ASSIGN');
-         maybe_loadesi;
+         maybe_loadself;
          popusedregisters(pushed);
          if ungettemp then
            ungetiftemp(p.right.location.reference);
@@ -1477,7 +1472,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.13  2001-03-11 22:58:52  peter
+  Revision 1.14  2001-04-02 21:20:39  peter
+    * resulttype rewrite
+
+  Revision 1.13  2001/03/11 22:58:52  peter
     * getsym redesign, removed the globals srsym,srsymtable
 
   Revision 1.12  2001/03/04 10:26:56  jonas
@@ -1506,7 +1504,7 @@ end.
     * added lots of longint typecast to prevent range check errors in the
       compiler and rtl
     * type casts of symbolic ordinal constants are now preserved
-    * fixed bug where the original resulttype wasn't restored correctly
+    * fixed bug where the original resulttype.def wasn't restored correctly
       after doing a 64bit rangecheck
 
   Revision 1.6  2000/12/05 11:44:34  jonas

compiler/i386/popt386.pas

@@ -2003,7 +2003,10 @@ End.
 
 {
   $Log$
-  Revision 1.10  2001-02-08 12:13:40  jonas
+  Revision 1.11  2001-04-02 21:20:39  peter
+    * resulttype rewrite
+
+  Revision 1.10  2001/02/08 12:13:40  jonas
     * fixed web bug 1391
 
   Revision 1.9  2001/01/27 21:29:35  florian
@@ -2081,7 +2084,7 @@ End.
       ignore labels who have is_addr set
     + daopt386/csopt386: remove loads of registers which are overwritten
        before their contents are used (especially usefull for removing superfluous
-      maybe_loadesi outputs and push/pops transformed by below optimization
+      maybe_loadself outputs and push/pops transformed by below optimization
     + popt386: transform pop/pop/pop/.../push/push/push to sequences of
       'movl x(%esp),%reg' (only active when compiling a go32v2 compiler
       currently because I don't know whether it's safe to do this under Win32/

compiler/i386/ra386dir.pas

@@ -91,7 +91,7 @@ interface
           is_fpu(procinfo^.returntype.def) then
          procinfo^.funcret_state:=vs_assigned;
        if assigned(procinfo^.returntype.def) and
-          (procinfo^.returntype.def<>pdef(voiddef)) then
+          (not is_void(procinfo^.returntype.def)) then
          retstr:=upper(tostr(procinfo^.return_offset)+'('+att_reg2str[procinfo^.framepointer]+')')
        else
          retstr:='';
@@ -243,7 +243,7 @@ interface
                                            else if upper(hs)='__RESULT' then
                                              begin
                                                 if assigned(procinfo^.returntype.def) and
-                                                  (procinfo^.returntype.def<>pdef(voiddef)) then
+                                                  (not is_void(procinfo^.returntype.def)) then
                                                   hs:=retstr
                                                 else
                                                   Message(asmr_e_void_function);
@@ -288,7 +288,10 @@ interface
 end.
 {
   $Log$
-  Revision 1.5  2001-03-11 22:58:52  peter
+  Revision 1.6  2001-04-02 21:20:40  peter
+    * resulttype rewrite
+
+  Revision 1.5  2001/03/11 22:58:52  peter
     * getsym redesign, removed the globals srsym,srsymtable
 
   Revision 1.4  2000/12/25 00:07:34  peter

compiler/nbas.pas

@@ -33,12 +33,14 @@ interface
        tnothingnode = class(tnode)
           constructor create;virtual;
           function pass_1 : tnode;override;
+          function det_resulttype:tnode;override;
           procedure pass_2;override;
        end;
 
        terrornode = class(tnode)
           constructor create;virtual;
           function pass_1 : tnode;override;
+          function det_resulttype:tnode;override;
        end;
 
        tasmnode = class(tnode)
@@ -47,12 +49,14 @@ interface
           destructor destroy;override;
           function getcopy : tnode;override;
           function pass_1 : tnode;override;
+          function det_resulttype:tnode;override;
           function docompare(p: tnode): boolean; override;
        end;
 
        tstatementnode = class(tbinarynode)
           constructor create(l,r : tnode);virtual;
           function pass_1 : tnode;override;
+          function det_resulttype:tnode;override;
 {$ifdef extdebug}
           procedure dowrite;override;
 {$endif extdebug}
@@ -61,6 +65,7 @@ interface
        tblocknode = class(tunarynode)
           constructor create(l : tnode);virtual;
           function pass_1 : tnode;override;
+          function det_resulttype:tnode;override;
        end;
 
     var
@@ -73,9 +78,9 @@ interface
 implementation
 
     uses
-      cutils,cclasses,
+      cutils,
       verbose,globals,globtype,systems,
-      symconst,symtype,symdef,types,
+      symconst,symdef,types,
       pass_1,
       ncal,nflw,tgcpu,hcodegen
 {$ifdef newcg}
@@ -88,15 +93,19 @@ implementation
 *****************************************************************************}
 
     constructor tnothingnode.create;
-
       begin
          inherited create(nothingn);
       end;
 
+    function tnothingnode.det_resulttype:tnode;
+      begin
+         result:=nil;
+         resulttype:=voidtype;
+      end;
+
     function tnothingnode.pass_1 : tnode;
       begin
-         pass_1:=nil;
-         resulttype:=voiddef;
+         result:=nil;
       end;
 
     procedure tnothingnode.pass_2;
@@ -116,12 +125,18 @@ implementation
          inherited create(errorn);
       end;
 
-    function terrornode.pass_1 : tnode;
+    function terrornode.det_resulttype:tnode;
       begin
-         pass_1:=nil;
+         result:=nil;
          include(flags,nf_error);
          codegenerror:=true;
-         resulttype:=generrordef;
+         resulttype:=generrortype;
+      end;
+
+    function terrornode.pass_1 : tnode;
+      begin
+         result:=nil;
+         codegenerror:=true;
       end;
 
 {*****************************************************************************
@@ -134,11 +149,31 @@ implementation
          inherited create(statementn,l,r);
       end;
 
+    function tstatementnode.det_resulttype:tnode;
+      begin
+         result:=nil;
+         resulttype:=voidtype;
+
+         { right is the statement itself calln assignn or a complex one }
+         resulttypepass(right);
+         if (not (cs_extsyntax in aktmoduleswitches)) and
+            assigned(right.resulttype.def) and
+            not((right.nodetype=calln) and
+                (tcallnode(right).procdefinition^.proctypeoption=potype_constructor)) and
+            not(is_void(right.resulttype.def)) then
+           CGMessage(cg_e_illegal_expression);
+         if codegenerror then
+           exit;
+
+         { left is the next in the list }
+         resulttypepass(left);
+         if codegenerror then
+           exit;
+      end;
+
     function tstatementnode.pass_1 : tnode;
       begin
-         pass_1:=nil;
-         { left is the next statement in the list }
-         resulttype:=voiddef;
+         result:=nil;
          { no temps over several statements }
 {$ifdef newcg}
          tg.cleartempgen;
@@ -146,14 +181,7 @@ implementation
          cleartempgen;
 {$endif newcg}
          { right is the statement itself calln assignn or a complex one }
-         {must_be_valid:=true; obsolete PM }
          firstpass(right);
-         if (not (cs_extsyntax in aktmoduleswitches)) and
-            assigned(right.resulttype) and
-            not((right.nodetype=calln) and
-                (tcallnode(right).procdefinition^.proctypeoption=potype_constructor)) and
-            (right.resulttype<>pdef(voiddef)) then
-           CGMessage(cg_e_illegal_expression);
          if codegenerror then
            exit;
          registers32:=right.registers32;
@@ -203,12 +231,37 @@ implementation
          inherited create(blockn,l);
       end;
 
+    function tblocknode.det_resulttype:tnode;
+      var
+         hp : tstatementnode;
+      begin
+         result:=nil;
+         resulttype:=voidtype;
+
+         hp:=tstatementnode(left);
+         while assigned(hp) do
+           begin
+              if assigned(hp.right) then
+                begin
+                   codegenerror:=false;
+                   resulttypepass(hp.right);
+                   if (not (cs_extsyntax in aktmoduleswitches)) and
+                      assigned(hp.right.resulttype.def) and
+                      not((hp.right.nodetype=calln) and
+                          (tcallnode(hp.right).procdefinition^.proctypeoption=potype_constructor)) and
+                      not(is_void(hp.right.resulttype.def)) then
+                     CGMessage(cg_e_illegal_expression);
+                end;
+              hp:=tstatementnode(hp.left);
+           end;
+      end;
+
     function tblocknode.pass_1 : tnode;
       var
          hp : tstatementnode;
          count : longint;
       begin
-         pass_1:=nil;
+         result:=nil;
          count:=0;
          hp:=tstatementnode(left);
          while assigned(hp) do
@@ -265,14 +318,7 @@ implementation
 {$endif newcg}
                    codegenerror:=false;
                    firstpass(hp.right);
-                   if (not (cs_extsyntax in aktmoduleswitches)) and
-                      assigned(hp.right.resulttype) and
-                      not((hp.right.nodetype=calln) and
-                          (tcallnode(hp.right).procdefinition^.proctypeoption=potype_constructor)) and
-                      (hp.right.resulttype<>pdef(voiddef)) then
-                     CGMessage(cg_e_illegal_expression);
-                   {if codegenerror then
-                     exit;}
+
                    hp.registers32:=hp.right.registers32;
                    hp.registersfpu:=hp.right.registersfpu;
 {$ifdef SUPPORT_MMX}
@@ -328,9 +374,15 @@ implementation
         getcopy := n;
       end;
 
+    function tasmnode.det_resulttype:tnode;
+      begin
+         result:=nil;
+         resulttype:=voidtype;
+      end;
+
     function tasmnode.pass_1 : tnode;
       begin
-         pass_1:=nil;
+         result:=nil;
          procinfo^.flags:=procinfo^.flags or pi_uses_asm;
       end;
 
@@ -349,7 +401,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.8  2001-02-05 20:45:49  peter
+  Revision 1.9  2001-04-02 21:20:30  peter
+    * resulttype rewrite
+
+  Revision 1.8  2001/02/05 20:45:49  peter
     * fixed buf 1364
 
   Revision 1.7  2000/12/31 11:14:10  jonas

compiler/ncon.pas

@@ -34,35 +34,33 @@ interface
 
     type
        trealconstnode = class(tnode)
+          restype : ttype;
           value_real : bestreal;
           lab_real : pasmlabel;
-          constructor create(v : bestreal;def : pdef);virtual;
-          function getcopy : tnode;override;
-          function pass_1 : tnode;override;
-          function docompare(p: tnode) : boolean; override;
-       end;
-
-       tfixconstnode = class(tnode)
-          value_fix: longint;
-          constructor create(v : longint;def : pdef);virtual;
+          constructor create(v : bestreal;const t:ttype);virtual;
           function getcopy : tnode;override;
           function pass_1 : tnode;override;
+          function det_resulttype:tnode;override;
           function docompare(p: tnode) : boolean; override;
        end;
 
        tordconstnode = class(tnode)
+          restype : ttype;
           value : TConstExprInt;
-          constructor create(v : tconstexprint;def : pdef);virtual;
+          constructor create(v : tconstexprint;const t:ttype);virtual;
           function getcopy : tnode;override;
           function pass_1 : tnode;override;
+          function det_resulttype:tnode;override;
           function docompare(p: tnode) : boolean; override;
        end;
 
        tpointerconstnode = class(tnode)
+          restype : ttype;
           value : TPointerOrd;
-          constructor create(v : tpointerord;def : pdef);virtual;
+          constructor create(v : tpointerord;const t:ttype);virtual;
           function getcopy : tnode;override;
           function pass_1 : tnode;override;
+          function det_resulttype:tnode;override;
           function docompare(p: tnode) : boolean; override;
        end;
 
@@ -70,58 +68,48 @@ interface
           value_str : pchar;
           len : longint;
           lab_str : pasmlabel;
-          stringtype : tstringtype;
+          st_type : tstringtype;
           constructor createstr(const s : string;st:tstringtype);virtual;
           constructor createpchar(s : pchar;l : longint);virtual;
           constructor createwstr(const w : tcompilerwidestring);virtual;
           destructor destroy;override;
           function getcopy : tnode;override;
           function pass_1 : tnode;override;
+          function det_resulttype:tnode;override;
           function getpcharcopy : pchar;
           function docompare(p: tnode) : boolean; override;
        end;
 
        tsetconstnode = class(tunarynode)
+          restype : ttype;
           value_set : pconstset;
           lab_set : pasmlabel;
-          constructor create(s : pconstset;settype : psetdef);virtual;
+          constructor create(s : pconstset;const t:ttype);virtual;
           destructor destroy;override;
           function getcopy : tnode;override;
           function pass_1 : tnode;override;
+          function det_resulttype:tnode;override;
           function docompare(p: tnode) : boolean; override;
        end;
 
        tnilnode = class(tnode)
           constructor create;virtual;
           function pass_1 : tnode;override;
+          function det_resulttype:tnode;override;
        end;
 
     var
        crealconstnode : class of trealconstnode;
-       cfixconstnode : class of tfixconstnode;
        cordconstnode : class of tordconstnode;
        cpointerconstnode : class of tpointerconstnode;
        cstringconstnode : class of tstringconstnode;
        csetconstnode : class of tsetconstnode;
        cnilnode : class of tnilnode;
 
-    function genordinalconstnode(v : TConstExprInt;def : pdef) : tordconstnode;
-    { same as genordinalconstnode, but the resulttype }
-    { is determines automatically                     }
     function genintconstnode(v : TConstExprInt) : tordconstnode;
-    function genpointerconstnode(v : tpointerord;def : pdef) : tpointerconstnode;
     function genenumnode(v : penumsym) : tordconstnode;
-    function genfixconstnode(v : longint;def : pdef) : tfixconstnode;
-    function genrealconstnode(v : bestreal;def : pdef) : trealconstnode;
-    { allow pchar or string for defining a pchar node }
-    function genstringconstnode(const s : string;st:tstringtype) : tstringconstnode;
-    { length is required for ansistrings }
-    function genpcharconstnode(s : pchar;length : longint) : tstringconstnode;
-    function genwstringconstnode(const w : tcompilerwidestring) : tnode;
-    function gensetconstnode(s : pconstset;settype : psetdef) : tsetconstnode;
 
     { some helper routines }
-
 {$ifdef INT64FUNCRESOK}
     function get_ordinal_value(p : tnode) : TConstExprInt;
 {$else INT64FUNCRESOK}
@@ -143,12 +131,6 @@ implementation
       cutils,verbose,globals,systems,
       types,cpubase,nld;
 
-    function genordinalconstnode(v : tconstexprint;def : pdef) : tordconstnode;
-      begin
-         genordinalconstnode:=cordconstnode.create(v,def);
-      end;
-
-
     function genintconstnode(v : TConstExprInt) : tordconstnode;
 
       var
@@ -160,61 +142,23 @@ implementation
          { maxcardinal }
          i2 := i+i+1;
          if (v<=i) and (v>=-i-1) then
-           genintconstnode:=genordinalconstnode(v,s32bitdef)
+           genintconstnode:=cordconstnode.create(v,s32bittype)
          else if (v > i) and (v <= i2) then
-           genintconstnode:=genordinalconstnode(v,u32bitdef)
+           genintconstnode:=cordconstnode.create(v,u32bittype)
          else
-           genintconstnode:=genordinalconstnode(v,cs64bitdef);
-      end;
-
-
-    function genpointerconstnode(v : tpointerord;def : pdef) : tpointerconstnode;
-      begin
-         genpointerconstnode:=cpointerconstnode.create(v,def);
+           genintconstnode:=cordconstnode.create(v,cs64bittype);
       end;
 
 
     function genenumnode(v : penumsym) : tordconstnode;
+      var
+        htype : ttype;
       begin
-         genenumnode:=cordconstnode.create(v^.value,v^.definition);
-      end;
-
-
-    function gensetconstnode(s : pconstset;settype : psetdef) : tsetconstnode;
-      begin
-         gensetconstnode:=csetconstnode.create(s,settype);
-      end;
-
-
-    function genrealconstnode(v : bestreal;def : pdef) : trealconstnode;
-      begin
-         genrealconstnode:=crealconstnode.create(v,def);
-      end;
-
-
-    function genfixconstnode(v : longint;def : pdef) : tfixconstnode;
-      begin
-         genfixconstnode:=cfixconstnode.create(v,def);
-      end;
-
-
-    function genstringconstnode(const s : string;st:tstringtype) : tstringconstnode;
-      begin
-         genstringconstnode:=cstringconstnode.createstr(s,st);
-      end;
-
-    function genwstringconstnode(const w : tcompilerwidestring) : tnode;
-
-      begin
-         genwstringconstnode:=cstringconstnode.createwstr(w);
+         htype.setdef(v^.definition);
+         genenumnode:=cordconstnode.create(v^.value,htype);
       end;
 
 
-    function genpcharconstnode(s : pchar;length : longint) : tstringconstnode;
-      begin
-         genpcharconstnode:=cstringconstnode.createpchar(s,length);
-      end;
-
 {$ifdef INT64FUNCRESOK}
     function get_ordinal_value(p : tnode) : TConstExprInt;
 {$else INT64FUNCRESOK}
@@ -233,20 +177,20 @@ implementation
 
     function is_constnode(p : tnode) : boolean;
       begin
-        is_constnode:=(p.nodetype in [ordconstn,realconstn,stringconstn,fixconstn,setconstn]);
+        is_constnode:=(p.nodetype in [ordconstn,realconstn,stringconstn,setconstn]);
       end;
 
 
     function is_constintnode(p : tnode) : boolean;
       begin
-         is_constintnode:=(p.nodetype=ordconstn) and is_integer(p.resulttype);
+         is_constintnode:=(p.nodetype=ordconstn) and is_integer(p.resulttype.def);
       end;
 
 
     function is_constcharnode(p : tnode) : boolean;
 
       begin
-         is_constcharnode:=(p.nodetype=ordconstn) and is_char(p.resulttype);
+         is_constcharnode:=(p.nodetype=ordconstn) and is_char(p.resulttype.def);
       end;
 
 
@@ -260,7 +204,7 @@ implementation
     function is_constboolnode(p : tnode) : boolean;
 
       begin
-         is_constboolnode:=(p.nodetype=ordconstn) and is_boolean(p.resulttype);
+         is_constboolnode:=(p.nodetype=ordconstn) and is_boolean(p.resulttype.def);
       end;
 
 
@@ -303,12 +247,7 @@ implementation
         p1:=nil;
         case p^.consttyp of
           constint :
-            if (p^.value >= -maxlongint-1) and (p^.value <= maxlongint) then
-              p1:=genordinalconstnode(p^.value,s32bitdef)
-            else if (p^.value > maxlongint) and (p^.value <= int64(maxlongint)+int64(maxlongint)+int64(1)) then
-              p1:=genordinalconstnode(p^.value,u32bitdef)
-            else
-              p1:=genordinalconstnode(p^.value,cs64bitdef);
+            p1:=genintconstnode(p^.value);
           conststring :
             begin
               len:=p^.len;
@@ -317,26 +256,26 @@ implementation
               getmem(pc,len+1);
               move(pchar(tpointerord(p^.value))^,pc^,len);
               pc[len]:=#0;
-              p1:=genpcharconstnode(pc,len);
+              p1:=cstringconstnode.createpchar(pc,len);
             end;
           constchar :
-            p1:=genordinalconstnode(p^.value,cchardef);
+            p1:=cordconstnode.create(p^.value,cchartype);
           constreal :
-            p1:=genrealconstnode(pbestreal(tpointerord(p^.value))^,bestrealdef^);
+            p1:=crealconstnode.create(pbestreal(tpointerord(p^.value))^,pbestrealtype^);
           constbool :
-            p1:=genordinalconstnode(p^.value,booldef);
+            p1:=cordconstnode.create(p^.value,booltype);
           constset :
-            p1:=gensetconstnode(pconstset(tpointerord(p^.value)),psetdef(p^.consttype.def));
+            p1:=csetconstnode.create(pconstset(tpointerord(p^.value)),p^.consttype);
           constord :
-            p1:=genordinalconstnode(p^.value,p^.consttype.def);
+            p1:=cordconstnode.create(p^.value,p^.consttype);
           constpointer :
-            p1:=genpointerconstnode(p^.value,p^.consttype.def);
+            p1:=cpointerconstnode.create(p^.value,p^.consttype);
           constnil :
             p1:=cnilnode.create;
           constresourcestring:
             begin
-              p1:=genloadnode(pvarsym(p),pvarsym(p)^.owner);
-              p1.resulttype:=cansistringdef;
+              p1:=cloadnode.create(pvarsym(p),pvarsym(p)^.owner);
+              p1.resulttype:=cansistringtype;
             end;
         end;
         genconstsymtree:=p1;
@@ -346,11 +285,11 @@ implementation
                              TREALCONSTNODE
 *****************************************************************************}
 
-    constructor trealconstnode.create(v : bestreal;def : pdef);
+    constructor trealconstnode.create(v : bestreal;const t:ttype);
 
       begin
          inherited create(realconstn);
-         resulttype:=def;
+         restype:=t;
          value_real:=v;
          lab_real:=nil;
       end;
@@ -367,9 +306,15 @@ implementation
          getcopy:=n;
       end;
 
+    function trealconstnode.det_resulttype:tnode;
+      begin
+        result:=nil;
+        resulttype:=restype;
+      end;
+
     function trealconstnode.pass_1 : tnode;
       begin
-         pass_1:=nil;
+         result:=nil;
          if (value_real=1.0) or (value_real=0.0) then
            begin
               location.loc:=LOC_FPU;
@@ -386,55 +331,16 @@ implementation
           (value_real = trealconstnode(p).value_real);
       end;
 
-{*****************************************************************************
-                             TFIXCONSTNODE
-*****************************************************************************}
-
-    constructor tfixconstnode.create(v : longint;def : pdef);
-
-      begin
-         inherited create(fixconstn);
-         resulttype:=def;
-         value_fix:=v;
-      end;
-
-    function tfixconstnode.getcopy : tnode;
-
-      var
-         n : tfixconstnode;
-
-      begin
-         n:=tfixconstnode(inherited getcopy);
-         n.value_fix:=value_fix;
-         getcopy:=n;
-      end;
-
-    function tfixconstnode.pass_1 : tnode;
-
-      begin
-         pass_1:=nil;
-         location.loc:=LOC_MEM;
-      end;
-
-    function tfixconstnode.docompare(p: tnode): boolean;
-      begin
-        docompare :=
-          inherited docompare(p) and
-          (value_fix = tfixconstnode(p).value_fix);
-      end;
-
 {*****************************************************************************
                               TORDCONSTNODE
 *****************************************************************************}
 
-    constructor tordconstnode.create(v : tconstexprint;def : pdef);
+    constructor tordconstnode.create(v : tconstexprint;const t:ttype);
 
       begin
          inherited create(ordconstn);
          value:=v;
-         resulttype:=def;
-         if resulttype^.deftype=orddef then
-          testrange(resulttype,value);
+         restype:=t;
       end;
 
     function tordconstnode.getcopy : tnode;
@@ -448,9 +354,17 @@ implementation
          getcopy:=n;
       end;
 
+    function tordconstnode.det_resulttype:tnode;
+      begin
+        result:=nil;
+        resulttype:=restype;
+        if resulttype.def^.deftype=orddef then
+         testrange(resulttype.def,value);
+      end;
+
     function tordconstnode.pass_1 : tnode;
       begin
-         pass_1:=nil;
+         result:=nil;
          location.loc:=LOC_MEM;
       end;
 
@@ -465,12 +379,12 @@ implementation
                             TPOINTERCONSTNODE
 *****************************************************************************}
 
-    constructor tpointerconstnode.create(v : tpointerord;def : pdef);
+    constructor tpointerconstnode.create(v : tpointerord;const t:ttype);
 
       begin
          inherited create(pointerconstn);
          value:=v;
-         resulttype:=def;
+         restype:=t;
       end;
 
     function tpointerconstnode.getcopy : tnode;
@@ -484,9 +398,15 @@ implementation
          getcopy:=n;
       end;
 
+    function tpointerconstnode.det_resulttype:tnode;
+      begin
+        result:=nil;
+        resulttype:=restype;
+      end;
+
     function tpointerconstnode.pass_1 : tnode;
       begin
-         pass_1:=nil;
+         result:=nil;
          location.loc:=LOC_MEM;
       end;
 
@@ -497,6 +417,7 @@ implementation
           (value = tpointerconstnode(p).value);
       end;
 
+
 {*****************************************************************************
                              TSTRINGCONSTNODE
 *****************************************************************************}
@@ -518,20 +439,12 @@ implementation
          if st=st_default then
           begin
             if cs_ansistrings in aktlocalswitches then
-              stringtype:=st_ansistring
+              st_type:=st_ansistring
             else
-              stringtype:=st_shortstring;
+              st_type:=st_shortstring;
           end
          else
-          stringtype:=st;
-         case stringtype of
-           st_shortstring :
-             resulttype:=cshortstringdef;
-           st_ansistring :
-             resulttype:=cansistringdef;
-           else
-             internalerror(44990099);
-         end;
+          st_type:=st;
       end;
 
     constructor tstringconstnode.createwstr(const w : tcompilerwidestring);
@@ -543,8 +456,7 @@ implementation
          initwidestring(pcompilerwidestring(value_str)^);
          copywidestring(w,pcompilerwidestring(value_str)^);
          lab_str:=nil;
-         stringtype:=st_widestring;
-         resulttype:=cwidestringdef;
+         st_type:=st_widestring;
       end;
 
     constructor tstringconstnode.createpchar(s : pchar;l : longint);
@@ -552,18 +464,12 @@ implementation
       begin
          inherited create(stringconstn);
          len:=l;
+         value_str:=s;
          if (cs_ansistrings in aktlocalswitches) or
             (len>255) then
-          begin
-             stringtype:=st_ansistring;
-             resulttype:=cansistringdef;
-          end
+          st_type:=st_ansistring
          else
-          begin
-             stringtype:=st_shortstring;
-             resulttype:=cshortstringdef;
-          end;
-         value_str:=s;
+          st_type:=st_shortstring;
          lab_str:=nil;
       end;
 
@@ -580,30 +486,34 @@ implementation
 
       begin
          n:=tstringconstnode(inherited getcopy);
-         n.stringtype:=stringtype;
+         n.st_type:=st_type;
          n.len:=len;
          n.lab_str:=lab_str;
-         if stringtype=st_widestring then
-           copywidestring(pcompilerwidestring(value_str)^,
-             pcompilerwidestring(n.value_str)^)
+         if st_type=st_widestring then
+           copywidestring(pcompilerwidestring(value_str)^,pcompilerwidestring(n.value_str)^)
          else
            n.value_str:=getpcharcopy;
          getcopy:=n;
       end;
 
-    function tstringconstnode.pass_1 : tnode;
+    function tstringconstnode.det_resulttype:tnode;
       begin
-         pass_1:=nil;
-        case stringtype of
+        result:=nil;
+        case st_type of
           st_shortstring :
-            resulttype:=cshortstringdef;
+            resulttype:=cshortstringtype;
           st_ansistring :
-            resulttype:=cansistringdef;
+            resulttype:=cansistringtype;
           st_widestring :
-            resulttype:=cwidestringdef;
+            resulttype:=cwidestringtype;
           st_longstring :
-            resulttype:=clongstringdef;
+            resulttype:=clongstringtype;
         end;
+      end;
+
+    function tstringconstnode.pass_1 : tnode;
+      begin
+        result:=nil;
         location.loc:=LOC_MEM;
       end;
 
@@ -634,11 +544,11 @@ implementation
                              TSETCONSTNODE
 *****************************************************************************}
 
-    constructor tsetconstnode.create(s : pconstset;settype : psetdef);
+    constructor tsetconstnode.create(s : pconstset;const t:ttype);
 
       begin
          inherited create(setconstn,nil);
-         resulttype:=settype;
+         restype:=t;
          if assigned(s) then
            begin
               new(value_set);
@@ -673,9 +583,15 @@ implementation
          getcopy:=n;
       end;
 
+    function tsetconstnode.det_resulttype:tnode;
+      begin
+        result:=nil;
+        resulttype:=restype;
+      end;
+
     function tsetconstnode.pass_1 : tnode;
       begin
-         pass_1:=nil;
+         result:=nil;
          location.loc:=LOC_MEM;
       end;
 
@@ -704,19 +620,23 @@ implementation
     constructor tnilnode.create;
 
       begin
-         inherited create(niln);
+        inherited create(niln);
+      end;
+
+    function tnilnode.det_resulttype:tnode;
+      begin
+        result:=nil;
+        resulttype:=voidpointertype;
       end;
 
     function tnilnode.pass_1 : tnode;
       begin
-        pass_1:=nil;
-        resulttype:=voidpointerdef;
+        result:=nil;
         location.loc:=LOC_MEM;
       end;
 
 begin
    crealconstnode:=trealconstnode;
-   cfixconstnode:=tfixconstnode;
    cordconstnode:=tordconstnode;
    cpointerconstnode:=tpointerconstnode;
    cstringconstnode:=tstringconstnode;
@@ -725,7 +645,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.15  2000-12-31 11:14:10  jonas
+  Revision 1.16  2001-04-02 21:20:30  peter
+    * resulttype rewrite
+
+  Revision 1.15  2000/12/31 11:14:10  jonas
     + implemented/fixed docompare() mathods for all nodes (not tested)
     + nopt.pas, nadd.pas, i386/n386opt.pas: optimized nodes for adding strings
       and constant strings/chars together
@@ -748,7 +671,7 @@ end.
     * added lots of longint typecast to prevent range check errors in the
       compiler and rtl
     * type casts of symbolic ordinal constants are now preserved
-    * fixed bug where the original resulttype wasn't restored correctly
+    * fixed bug where the original resulttype.def wasn't restored correctly
       after doing a 64bit rangecheck
 
   Revision 1.11  2000/11/29 00:30:32  florian

compiler/nflw.pas

@@ -45,31 +45,37 @@ interface
        end;
 
        twhilerepeatnode = class(tloopnode)
+          function det_resulttype:tnode;override;
           function pass_1 : tnode;override;
        end;
 
        tifnode = class(tloopnode)
           constructor create(l,r,_t1 : tnode);virtual;
+          function det_resulttype:tnode;override;
           function pass_1 : tnode;override;
        end;
 
        tfornode = class(tloopnode)
           constructor create(l,r,_t1,_t2 : tnode;back : boolean);virtual;
+          function det_resulttype:tnode;override;
           function pass_1 : tnode;override;
        end;
 
        texitnode = class(tunarynode)
           constructor create(l:tnode);virtual;
+          function det_resulttype:tnode;override;
           function pass_1 : tnode;override;
        end;
 
        tbreaknode = class(tnode)
           constructor create;virtual;
+          function det_resulttype:tnode;override;
           function pass_1 : tnode;override;
        end;
 
        tcontinuenode = class(tnode)
           constructor create;virtual;
+          function det_resulttype:tnode;override;
           function pass_1 : tnode;override;
        end;
 
@@ -78,6 +84,7 @@ interface
           labsym : plabelsym;
           constructor create(p : pasmlabel);virtual;
           function getcopy : tnode;override;
+          function det_resulttype:tnode;override;
           function pass_1 : tnode;override;
           function docompare(p: tnode): boolean; override;
        end;
@@ -88,6 +95,7 @@ interface
           labsym : plabelsym;
           constructor create(p : pasmlabel;l:tnode);virtual;
           function getcopy : tnode;override;
+          function det_resulttype:tnode;override;
           function pass_1 : tnode;override;
           function docompare(p: tnode): boolean; override;
        end;
@@ -97,17 +105,20 @@ interface
           constructor create(l,taddr,tframe:tnode);virtual;
           function getcopy : tnode;override;
           procedure insertintolist(l : tnodelist);override;
+          function det_resulttype:tnode;override;
           function pass_1 : tnode;override;
           function docompare(p: tnode): boolean; override;
        end;
 
        ttryexceptnode = class(tloopnode)
           constructor create(l,r,_t1 : tnode);virtual;
+          function det_resulttype:tnode;override;
           function pass_1 : tnode;override;
        end;
 
        ttryfinallynode = class(tbinarynode)
           constructor create(l,r:tnode);virtual;
+          function det_resulttype:tnode;override;
           function pass_1 : tnode;override;
        end;
 
@@ -116,6 +127,7 @@ interface
           excepttype : pobjectdef;
           constructor create(l,r:tnode);virtual;
           destructor destroy;override;
+          function det_resulttype:tnode;override;
           function pass_1 : tnode;override;
           function getcopy : tnode;override;
           function docompare(p: tnode): boolean; override;
@@ -123,6 +135,7 @@ interface
 
        tfailnode = class(tnode)
           constructor create;virtual;
+          function det_resulttype:tnode;override;
           function pass_1: tnode;override;
           function docompare(p: tnode): boolean; override;
        end;
@@ -245,12 +258,19 @@ implementation
                                TWHILEREPEATNODE
 *****************************************************************************}
 
+    function twhilerepeatnode.det_resulttype:tnode;
+      begin
+        result:=nil;
+        resulttype:=voidtype;
+      end;
+
+
     function twhilerepeatnode.pass_1 : tnode;
 
       var
          old_t_times : longint;
       begin
-         pass_1:=nil;
+         result:=nil;
          old_t_times:=t_times;
 
          { calc register weight }
@@ -266,7 +286,7 @@ implementation
          set_varstate(left,true);
          if codegenerror then
            exit;
-         if not is_boolean(left.resulttype) then
+         if not is_boolean(left.resulttype.def) then
            begin
              CGMessage(type_e_mismatch);
              exit;
@@ -314,12 +334,20 @@ implementation
          inherited create(ifn,l,r,_t1,nil);
       end;
 
+
+    function tifnode.det_resulttype:tnode;
+      begin
+        result:=nil;
+        resulttype:=voidtype;
+      end;
+
+
     function tifnode.pass_1 : tnode;
       var
          old_t_times : longint;
          hp : tnode;
       begin
-         pass_1:=nil;
+         result:=nil;
          old_t_times:=t_times;
 {$ifdef newcg}
          tg.cleartempgen;
@@ -333,8 +361,8 @@ implementation
            the right also needs to be firstpassed }
          if not codegenerror then
           begin
-            if not is_boolean(left.resulttype) then
-              Message1(type_e_boolean_expr_expected,left.resulttype^.typename);
+            if not is_boolean(left.resulttype.def) then
+              Message1(type_e_boolean_expr_expected,left.resulttype.def^.typename);
           end;
 
          registers32:=left.registers32;
@@ -403,9 +431,9 @@ implementation
                    right:=nil;
                    { we cannot set p to nil !!! }
                    if assigned(hp) then
-                     pass_1:=hp
+                     result:=hp
                    else
-                     pass_1:=cnothingnode.create;
+                     result:=cnothingnode.create;
                 end
               else
                 begin
@@ -413,9 +441,9 @@ implementation
                    t1:=nil;
                    { we cannot set p to nil !!! }
                    if assigned(hp) then
-                     pass_1:=hp
+                     result:=hp
                    else
-                     pass_1:=cnothingnode.create;
+                     result:=cnothingnode.create;
                 end;
            end;
 
@@ -435,6 +463,14 @@ implementation
            include(flags,nf_backward);
       end;
 
+
+    function tfornode.det_resulttype:tnode;
+      begin
+        result:=nil;
+        resulttype:=voidtype;
+      end;
+
+
     function tfornode.pass_1 : tnode;
 
       var
@@ -515,7 +551,7 @@ implementation
           begin
             if tloadnode(hp).symtableentry^.typ=varsym then
               pvarsym(tloadnode(hp).symtableentry)^.varstate:=vs_used;
-            if (not(is_ordinal(t2.resulttype)) or is_64bitint(t2.resulttype)) then
+            if (not(is_ordinal(t2.resulttype.def)) or is_64bitint(t2.resulttype.def)) then
               CGMessagePos(hp.fileinfo,type_e_ordinal_expr_expected);
           end
          else
@@ -539,7 +575,7 @@ implementation
          set_varstate(right,true);
          if right.nodetype<>ordconstn then
            begin
-              right:=gentypeconvnode(right,t2.resulttype);
+              inserttypeconv(right,t2.resulttype);
 {$ifdef newcg}
               tg.cleartempgen;
 {$else newcg}
@@ -568,35 +604,41 @@ implementation
 *****************************************************************************}
 
     constructor texitnode.create(l:tnode);
-
+      var
+         pt : tnode;
       begin
         inherited create(exitn,l);
+
+        { Check the 2 types }
+        if assigned(left) then
+         begin
+           inserttypeconv(left,procinfo^.returntype);
+           if ret_in_param(procinfo^.returntype.def) or procinfo^.no_fast_exit then
+            begin
+              pt:=cfuncretnode.create(procinfo);
+              left:=cassignmentnode.create(pt,left);
+            end;
+         end;
       end;
 
+
+    function texitnode.det_resulttype:tnode;
+      begin
+        result:=nil;
+        resulttype:=voidtype;
+      end;
+
+
     function texitnode.pass_1 : tnode;
-      var
-         pt : tfuncretnode;
       begin
-         pass_1:=nil;
-         resulttype:=voiddef;
+         result:=nil;
          if assigned(left) then
            begin
               firstpass(left);
               set_varstate(left,true);
-              procinfo^.funcret_state:=vs_assigned;
               if codegenerror then
                exit;
-              { Check the 2 types }
-              left:=gentypeconvnode(left,procinfo^.returntype.def);
-              firstpass(left);
-              if ret_in_param(procinfo^.returntype.def) or procinfo^.no_fast_exit then
-                begin
-                  pt:=cfuncretnode.create;
-                  pt.rettype.setdef(procinfo^.returntype.def);
-                  pt.funcretprocinfo:=procinfo;
-                  left:=cassignmentnode.create(pt,left);
-                  firstpass(left);
-                end;
+              procinfo^.funcret_state:=vs_assigned;
               registers32:=left.registers32;
               registersfpu:=left.registersfpu;
 {$ifdef SUPPORT_MMX}
@@ -616,6 +658,14 @@ implementation
         inherited create(breakn);
       end;
 
+
+    function tbreaknode.det_resulttype:tnode;
+      begin
+        result:=nil;
+        resulttype:=voidtype;
+      end;
+
+
     function tbreaknode.pass_1 : tnode;
       begin
         result:=nil;
@@ -632,6 +682,14 @@ implementation
         inherited create(continuen);
       end;
 
+
+    function tcontinuenode.det_resulttype:tnode;
+      begin
+        result:=nil;
+        resulttype:=voidtype;
+      end;
+
+
     function tcontinuenode.pass_1 : tnode;
       begin
         result:=nil;
@@ -650,10 +708,16 @@ implementation
       end;
 
 
+    function tgotonode.det_resulttype:tnode;
+      begin
+        result:=nil;
+        resulttype:=voidtype;
+      end;
+
+
     function tgotonode.pass_1 : tnode;
       begin
-         pass_1:=nil;
-         resulttype:=voiddef;
+         result:=nil;
       end;
 
    function tgotonode.getcopy : tnode;
@@ -687,10 +751,17 @@ implementation
       end;
 
 
+    function tlabelnode.det_resulttype:tnode;
+      begin
+        result:=nil;
+        resulttype:=voidtype;
+      end;
+
+
     function tlabelnode.pass_1 : tnode;
 
       begin
-         pass_1:=nil;
+         result:=nil;
 {$ifdef newcg}
          tg.cleartempgen;
 {$else newcg}
@@ -703,7 +774,6 @@ implementation
 {$ifdef SUPPORT_MMX}
          registersmmx:=left.registersmmx;
 {$endif SUPPORT_MMX}
-         resulttype:=voiddef;
       end;
 
 
@@ -720,11 +790,13 @@ implementation
         result:=p;
      end;
 
+
     function tlabelnode.docompare(p: tnode): boolean;
       begin
         docompare := false;
       end;
 
+
 {*****************************************************************************
                             TRAISENODE
 *****************************************************************************}
@@ -736,6 +808,7 @@ implementation
          frametree:=tframe;
       end;
 
+
     function traisenode.getcopy : tnode;
 
       var
@@ -750,21 +823,28 @@ implementation
          getcopy:=n;
       end;
 
+
     procedure traisenode.insertintolist(l : tnodelist);
+      begin
+      end;
+
 
+    function traisenode.det_resulttype:tnode;
       begin
+        result:=nil;
+        resulttype:=voidtype;
       end;
 
+
     function traisenode.pass_1 : tnode;
       begin
-         pass_1:=nil;
-         resulttype:=voiddef;
+         result:=nil;
          if assigned(left) then
            begin
               { first para must be a _class_ }
               firstpass(left);
-              if assigned(left.resulttype) and
-                 not(is_class(left.resulttype)) then
+              if assigned(left.resulttype.def) and
+                 not(is_class(left.resulttype.def)) then
                 CGMessage(type_e_mismatch);
               set_varstate(left,true);
               if codegenerror then
@@ -774,7 +854,7 @@ implementation
                begin
                  { addr }
                  firstpass(right);
-                 right:=gentypeconvnode(right,s32bitdef);
+                 inserttypeconv(right,s32bittype);
                  firstpass(right);
                  if codegenerror then
                   exit;
@@ -782,7 +862,7 @@ implementation
                  if assigned(frametree) then
                   begin
                     firstpass(frametree);
-                    frametree:=gentypeconvnode(frametree,s32bitdef);
+                    inserttypeconv(frametree,s32bittype);
                     firstpass(frametree);
                     if codegenerror then
                      exit;
@@ -808,13 +888,21 @@ implementation
          inherited create(tryexceptn,l,r,_t1,nil);
       end;
 
+
+    function ttryexceptnode.det_resulttype:tnode;
+      begin
+        result:=nil;
+        resulttype:=voidtype;
+      end;
+
+
     function ttryexceptnode.pass_1 : tnode;
 
       var
          oldexceptblock : tnode;
 
       begin
-         pass_1:=nil;
+         result:=nil;
 {$ifdef newcg}
          tg.cleartempgen;
 {$else newcg}
@@ -868,14 +956,21 @@ implementation
         inherited create(tryfinallyn,l,r);
       end;
 
+
+    function ttryfinallynode.det_resulttype:tnode;
+      begin
+        result:=nil;
+        resulttype:=voidtype;
+      end;
+
+
     function ttryfinallynode.pass_1 : tnode;
 
       var
          oldexceptblock : tnode;
 
       begin
-         pass_1:=nil;
-         resulttype:=voiddef;
+         result:=nil;
 {$ifdef newcg}
          tg.cleartempgen;
 {$else newcg}
@@ -933,13 +1028,20 @@ implementation
          result:=n;
       end;
 
+    function tonnode.det_resulttype:tnode;
+      begin
+        result:=nil;
+        resulttype:=voidtype;
+      end;
+
+
     function tonnode.pass_1 : tnode;
 
       var
          oldexceptblock : tnode;
 
       begin
-         pass_1:=nil;
+         result:=nil;
          { that's really an example procedure for a firstpass :) }
          if not(is_class(excepttype)) then
            CGMessage(type_e_mismatch);
@@ -948,7 +1050,6 @@ implementation
 {$else newcg}
          cleartempgen;
 {$endif newcg}
-         resulttype:=voiddef;
          registers32:=0;
          registersfpu:=0;
 {$ifdef SUPPORT_MMX}
@@ -995,17 +1096,24 @@ implementation
 
 
     constructor tfailnode.create;
-
       begin
          inherited create(failn);
       end;
 
-    function tfailnode.pass_1 : tnode;
 
+    function tfailnode.det_resulttype:tnode;
+      begin
+        result:=nil;
+        resulttype:=voidtype;
+      end;
+
+
+    function tfailnode.pass_1 : tnode;
       begin
-         pass_1:=nil;
+         result:=nil;
       end;
 
+
     function tfailnode.docompare(p: tnode): boolean;
       begin
         docompare := false;
@@ -1028,7 +1136,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.14  2001-03-25 12:27:59  peter
+  Revision 1.15  2001-04-02 21:20:30  peter
+    * resulttype rewrite
+
+  Revision 1.14  2001/03/25 12:27:59  peter
     * set funcret to assigned (merged)
 
   Revision 1.13  2001/02/26 19:44:53  peter

compiler/nld.pas

@@ -35,9 +35,11 @@ interface
           symtableentry : psym;
           symtable : psymtable;
           constructor create(v : psym;st : psymtable);virtual;
-          function getcopy : tnode;override;
-          function pass_1 : tnode;override;
-          function docompare(p: tnode): boolean; override;
+          procedure set_mp(p:tnode);
+          function  getcopy : tnode;override;
+          function  pass_1 : tnode;override;
+          function  det_resulttype:tnode;override;
+          function  docompare(p: tnode): boolean; override;
        end;
 
        { different assignment types }
@@ -48,37 +50,39 @@ interface
           constructor create(l,r : tnode);virtual;
           function getcopy : tnode;override;
           function pass_1 : tnode;override;
+          function det_resulttype:tnode;override;
           function docompare(p: tnode): boolean; override;
        end;
 
        tfuncretnode = class(tnode)
           funcretprocinfo : pointer;
-          rettype : ttype;
-          constructor create;virtual;
+          constructor create(p:pointer);virtual;
           function getcopy : tnode;override;
           function pass_1 : tnode;override;
+          function det_resulttype:tnode;override;
           function docompare(p: tnode): boolean; override;
        end;
 
        tarrayconstructorrangenode = class(tbinarynode)
           constructor create(l,r : tnode);virtual;
           function pass_1 : tnode;override;
+          function det_resulttype:tnode;override;
        end;
 
        tarrayconstructornode = class(tbinarynode)
-          constructordef : pdef;
+          constructortype : ttype;
           constructor create(l,r : tnode);virtual;
           function getcopy : tnode;override;
           function pass_1 : tnode;override;
+          function det_resulttype:tnode;override;
           function docompare(p: tnode): boolean; override;
        end;
 
        ttypenode = class(tnode)
-          typenodetype : pdef;
-          typenodesym:ptypesym;
-          constructor create(t : pdef;sym:ptypesym);virtual;
-          function getcopy : tnode;override;
+          restype : ttype;
+          constructor create(t : ttype);virtual;
           function pass_1 : tnode;override;
+          function det_resulttype:tnode;override;
           function docompare(p: tnode): boolean; override;
        end;
 
@@ -90,11 +94,6 @@ interface
        carrayconstructornode : class of tarrayconstructornode;
        ctypenode : class of ttypenode;
 
-    function genloadnode(v : pvarsym;st : psymtable) : tloadnode;
-    function gentypenode(t : pdef;sym:ptypesym) : ttypenode;
-    function genloadcallnode(v: pprocsym;st: psymtable): tloadnode;
-    function genloadmethodcallnode(v: pprocsym;st: psymtable; mp: tnode): tloadnode;
-    function gentypedconstloadnode(sym : ptypedconstsym;st : psymtable) : tloadnode;
 
 implementation
 
@@ -109,54 +108,6 @@ implementation
 {$endif newcg}
       ;
 
-    function genloadnode(v : pvarsym;st : psymtable) : tloadnode;
-
-      var
-         n : tloadnode;
-
-      begin
-         n:=cloadnode.create(v,st);
-         n.resulttype:=v^.vartype.def;
-         genloadnode:=n;
-      end;
-
-    function genloadcallnode(v: pprocsym;st: psymtable): tloadnode;
-      var
-         n : tloadnode;
-
-      begin
-         n:=cloadnode.create(v,st);
-         n.resulttype:=v^.definition;
-         genloadcallnode:=n;
-      end;
-
-    function genloadmethodcallnode(v: pprocsym;st: psymtable; mp: tnode): tloadnode;
-      var
-         n : tloadnode;
-
-      begin
-         n:=cloadnode.create(v,st);
-         n.resulttype:=v^.definition;
-         n.left:=mp;
-         genloadmethodcallnode:=n;
-      end;
-
-
-    function gentypedconstloadnode(sym : ptypedconstsym;st : psymtable) : tloadnode;
-
-      var
-         n : tloadnode;
-
-      begin
-         n:=cloadnode.create(sym,st);
-         n.resulttype:=sym^.typedconsttype.def;
-         gentypedconstloadnode:=n;
-      end;
-
-    function gentypenode(t : pdef;sym:ptypesym) : ttypenode;
-      begin
-         gentypenode:=ctypenode.create(t,sym);
-      end;
 
 {*****************************************************************************
                              TLOADNODE
@@ -170,8 +121,14 @@ implementation
          symtable:=st;
       end;
 
-    function tloadnode.getcopy : tnode;
 
+    procedure tloadnode.set_mp(p:tnode);
+      begin
+        left:=p;
+      end;
+
+
+    function tloadnode.getcopy : tnode;
       var
          n : tloadnode;
 
@@ -182,6 +139,26 @@ implementation
          result:=n;
       end;
 
+
+    function tloadnode.det_resulttype:tnode;
+      begin
+         result:=nil;
+         case symtableentry^.typ of
+           absolutesym,
+           varsym :
+             resulttype:=pvarsym(symtableentry)^.vartype;
+           constsym :
+             resulttype:=pconstsym(symtableentry)^.consttype;
+           typedconstsym :
+             resulttype:=ptypedconstsym(symtableentry)^.typedconsttype;
+           procsym :
+             resulttype.setdef(pprocsym(symtableentry)^.definition);
+           else
+             internalerror(534785349);
+         end;
+      end;
+
+
     function tloadnode.pass_1 : tnode;
       var
          p1 : tnode;
@@ -192,7 +169,7 @@ implementation
             (symtableentry^.typ=varsym) then
            begin
               p1:=tnode(pwithsymtable(symtable)^.withrefnode).getcopy;
-              p1:=gensubscriptnode(pvarsym(symtableentry),p1);
+              p1:=csubscriptnode.create(pvarsym(symtableentry),p1);
               left:=nil;
               firstpass(p1);
               result:=p1;
@@ -208,7 +185,6 @@ implementation
          { handle first absolute as it will replace the symtableentry }
          if symtableentry^.typ=absolutesym then
            begin
-             resulttype:=pabsolutesym(symtableentry)^.vartype.def;
              { replace the symtableentry when it points to a var, else
                we are finished }
              if pabsolutesym(symtableentry)^.abstyp=tovar then
@@ -223,9 +199,7 @@ implementation
          case symtableentry^.typ of
             funcretsym :
               begin
-                p1:=cfuncretnode.create;
-                tfuncretnode(p1).funcretprocinfo:=pprocinfo(pfuncretsym(symtableentry)^.funcretprocinfo);
-                tfuncretnode(p1).rettype:=pfuncretsym(symtableentry)^.rettype;
+                p1:=cfuncretnode.create(pfuncretsym(symtableentry)^.funcretprocinfo);
                 firstpass(p1);
                 { if it's refered as absolute then we need to have the
                   type of the absolute instead of the function return,
@@ -242,7 +216,7 @@ implementation
               begin
                  if pconstsym(symtableentry)^.consttyp=constresourcestring then
                    begin
-                      resulttype:=cansistringdef;
+                      resulttype:=cansistringtype;
                       { we use ansistrings so no fast exit here }
                       if assigned(procinfo) then
                         procinfo^.no_fast_exit:=true;
@@ -253,13 +227,10 @@ implementation
               end;
             varsym :
                 begin
-                { if it's refered by absolute then it's used }
-                if nf_absolute in flags then
-                 pvarsym(symtableentry)^.varstate:=vs_used
-                else
-                 if (resulttype=nil) then
-                     resulttype:=pvarsym(symtableentry)^.vartype.def;
-                   if (symtable^.symtabletype in [parasymtable,localsymtable]) and
+                  { if it's refered by absolute then it's used }
+                  if nf_absolute in flags then
+                   pvarsym(symtableentry)^.varstate:=vs_used;
+                  if (symtable^.symtabletype in [parasymtable,localsymtable]) and
                       (lexlevel>symtable^.symtablelevel) then
                      begin
                        { if the variable is in an other stackframe then we need
@@ -300,20 +271,22 @@ implementation
                 end;
             typedconstsym :
                 if not(nf_absolute in flags) then
-                  resulttype:=ptypedconstsym(symtableentry)^.typedconsttype.def;
+                  resulttype:=ptypedconstsym(symtableentry)^.typedconsttype;
             procsym :
                 begin
                    if assigned(pprocsym(symtableentry)^.definition^.nextoverloaded) then
                      CGMessage(parser_e_no_overloaded_procvars);
-                   resulttype:=pprocsym(symtableentry)^.definition;
+                   resulttype.setdef(pprocsym(symtableentry)^.definition);
                    { if the owner of the procsym is a object,  }
                    { left must be set, if left isn't set       }
                    { it can be only self                       }
                    { this code is only used in TP procvar mode }
                    if (m_tp_procvar in aktmodeswitches) and
                       not(assigned(left)) and
-                     (pprocsym(symtableentry)^.owner^.symtabletype=objectsymtable) then
-                      left:=genselfnode(pobjectdef(symtableentry^.owner^.defowner));
+                      (pprocsym(symtableentry)^.owner^.symtabletype=objectsymtable) then
+                    begin
+                      left:=cselfnode.create(pobjectdef(symtableentry^.owner^.defowner));
+                    end;
                    { method pointer ? }
                    if assigned(left) then
                      begin
@@ -330,6 +303,7 @@ implementation
          end;
       end;
 
+
     function tloadnode.docompare(p: tnode): boolean;
       begin
         docompare :=
@@ -360,77 +334,69 @@ implementation
          getcopy:=n;
       end;
 
+
+    function tassignmentnode.det_resulttype:tnode;
+      begin
+        result:=nil;
+        resulttype:=voidtype;
+
+        { must be made unique }
+        if assigned(left) then
+          begin
+             set_unique(left);
+
+             { set we the function result? }
+             set_funcret_is_valid(left);
+          end;
+
+        resulttypepass(left);
+        resulttypepass(right);
+        set_varstate(left,false);
+        set_varstate(right,true);
+        if codegenerror then
+          exit;
+
+        { assignments to open arrays aren't allowed }
+        if is_open_array(left.resulttype.def) then
+          CGMessage(type_e_mismatch);
+
+        { some string functions don't need conversion, so treat them separatly }
+        if not (
+                is_shortstring(left.resulttype.def) and
+                (
+                 is_shortstring(right.resulttype.def) or
+                 is_ansistring(right.resulttype.def) or
+                 is_char(right.resulttype.def)
+                )
+               ) then
+         inserttypeconv(right,left.resulttype);
+
+        { test if node can be assigned, properties are allowed }
+        valid_for_assign(left,true);
+
+        { check if local proc/func is assigned to procvar }
+        if right.resulttype.def^.deftype=procvardef then
+          test_local_to_procvar(pprocvardef(right.resulttype.def),left.resulttype.def);
+      end;
+
+
     function tassignmentnode.pass_1 : tnode;
-{$ifdef newoptimizations2}
-      var
-        hp : tnode;
-{$endif newoptimizations2}
       begin
          result:=nil;
-         { must be made unique }
-         if assigned(left) then
-           begin
-              set_unique(left);
-
-              { set we the function result? }
-              set_funcret_is_valid(left);
-           end;
 
          firstpass(left);
-         set_varstate(left,false);
-         if codegenerror then
-           exit;
-
-         { assignements to open arrays aren't allowed }
-         if is_open_array(left.resulttype) then
-           CGMessage(type_e_mismatch);
-
-         { test if we can avoid copying string to temp
-           as in s:=s+...; (PM) }
-{$ifdef dummyi386}
-         if ((right.treetype=addn) or (right.treetype=subn)) and
-            equal_trees(left,right.left) and
-            (ret_in_acc(left.resulttype)) and
-            (not cs_rangechecking in aktmoduleswitches^) then
-           begin
-              disposetree(right.left);
-              hp:=right;
-              right:=right.right;
-              if hp.treetype=addn then
-                assigntyp:=at_plus
-              else
-                assigntyp:=at_minus;
-              putnode(hp);
-           end;
-         if assigntyp<>at_normal then
-           begin
-              { for fpu type there is no faster way }
-              if is_fpu(left.resulttype) then
-                case assigntyp of
-                  at_plus  : right:=gennode(addn,getcopy(left),right);
-                  at_minus : right:=gennode(subn,getcopy(left),right);
-                  at_star  : right:=gennode(muln,getcopy(left),right);
-                  at_slash : right:=gennode(slashn,getcopy(left),right);
-                end;
-           end;
-{$endif i386}
          firstpass(right);
-         set_varstate(right,true);
          if codegenerror then
            exit;
 
          { some string functions don't need conversion, so treat them separatly }
-         if is_shortstring(left.resulttype) and (assigned(right.resulttype)) then
+         if is_shortstring(left.resulttype.def) and
+            (
+             is_shortstring(right.resulttype.def) or
+             is_ansistring(right.resulttype.def) or
+             is_char(right.resulttype.def)
+            ) then
           begin
-            if not (is_shortstring(right.resulttype) or
-                    is_ansistring(right.resulttype) or
-                    is_char(right.resulttype)) then
-             begin
-               right:=gentypeconvnode(right,left.resulttype);
-               firstpass(right);
-               if codegenerror then
-                exit;
-             end;
             { we call STRCOPY }
             procinfo^.flags:=procinfo^.flags or pi_do_call;
             { test for s:=s+anything ... }
@@ -458,27 +424,8 @@ implementation
                   end;
               end;
 {$endif newoptimizations2}
-          end
-         else
-          begin
-            right:=gentypeconvnode(right,left.resulttype);
-            firstpass(right);
-            if codegenerror then
-             exit;
           end;
 
-         { test if node can be assigned, properties are allowed }
-         valid_for_assign(left,true);
-
-         { check if local proc/func is assigned to procvar }
-         if right.resulttype^.deftype=procvardef then
-           test_local_to_procvar(pprocvardef(right.resulttype),left.resulttype);
-
-         resulttype:=voiddef;
-         {
-           registers32:=max(left.registers32,right.registers32);
-           registersfpu:=max(left.registersfpu,right.registersfpu);
-         }
          registers32:=left.registers32+right.registers32;
          registersfpu:=max(left.registersfpu,right.registersfpu);
 {$ifdef SUPPORT_MMX}
@@ -497,31 +444,33 @@ implementation
                                  TFUNCRETNODE
 *****************************************************************************}
 
-    constructor tfuncretnode.create;
+    constructor tfuncretnode.create(p:pointer);
 
       begin
          inherited create(funcretn);
-         funcretprocinfo:=nil;
+         funcretprocinfo:=p;
       end;
 
     function tfuncretnode.getcopy : tnode;
-
       var
          n : tfuncretnode;
-
       begin
          n:=tfuncretnode(inherited getcopy);
          n.funcretprocinfo:=funcretprocinfo;
-         n.rettype:=rettype;
          getcopy:=n;
       end;
 
+    function tfuncretnode.det_resulttype:tnode;
+      begin
+        result:=nil;
+        resulttype:=pprocinfo(funcretprocinfo)^.returntype;
+      end;
+
     function tfuncretnode.pass_1 : tnode;
       begin
          result:=nil;
-         resulttype:=rettype.def;
          location.loc:=LOC_REFERENCE;
-         if ret_in_param(rettype.def) or
+         if ret_in_param(resulttype.def) or
             (procinfo<>pprocinfo(funcretprocinfo)) then
            registers32:=1;
       end;
@@ -530,9 +479,7 @@ implementation
       begin
         docompare :=
           inherited docompare(p) and
-          (funcretprocinfo = tfuncretnode(p).funcretprocinfo) and
-          (rettype.def = tfuncretnode(p).rettype.def) and
-          (rettype.sym = tfuncretnode(p).rettype.sym);
+          (funcretprocinfo = tfuncretnode(p).funcretprocinfo);
       end;
 
 {*****************************************************************************
@@ -545,18 +492,28 @@ implementation
          inherited create(arrayconstructorrangen,l,r);
       end;
 
-    function tarrayconstructorrangenode.pass_1 : tnode;
+    function tarrayconstructorrangenode.det_resulttype:tnode;
       begin
         result:=nil;
-        firstpass(left);
+        resulttypepass(left);
+        resulttypepass(right);
         set_varstate(left,true);
-        firstpass(right);
         set_varstate(right,true);
-        calcregisters(self,0,0,0);
+        if codegenerror then
+         exit;
         resulttype:=left.resulttype;
       end;
 
 
+    function tarrayconstructorrangenode.pass_1 : tnode;
+      begin
+        firstpass(left);
+        firstpass(right);
+        calcregisters(self,0,0,0);
+        result:=nil;
+      end;
+
+
 {****************************************************************************
                             TARRAYCONSTRUCTORNODE
 *****************************************************************************}
@@ -565,7 +522,7 @@ implementation
 
       begin
          inherited create(arrayconstructorn,l,r);
-         constructordef:=nil;
+         constructortype.reset;
       end;
 
     function tarrayconstructornode.getcopy : tnode;
@@ -575,13 +532,64 @@ implementation
 
       begin
          n:=tarrayconstructornode(inherited getcopy);
-         n.constructordef:=constructordef;
+         n.constructortype:=constructortype;
          result:=n;
       end;
 
+    function tarrayconstructornode.det_resulttype:tnode;
+      var
+        htype : ttype;
+        hp : tarrayconstructornode;
+        len : longint;
+        varia : boolean;
+      begin
+        result:=nil;
+      { are we allowing array constructor? Then convert it to a set }
+        if not allow_array_constructor then
+         begin
+           hp:=tarrayconstructornode(getcopy);
+           arrayconstructor_to_set(hp);
+           resulttypepass(hp);
+           result:=hp;
+           exit;
+         end;
+      { only pass left tree, right tree contains next construct if any }
+        htype:=constructortype;
+        len:=0;
+        varia:=false;
+        if assigned(left) then
+         begin
+           hp:=self;
+           while assigned(hp) do
+            begin
+              resulttypepass(hp.left);
+              set_varstate(hp.left,true);
+              if (htype.def=nil) then
+               htype:=hp.left.resulttype
+              else
+               begin
+                 if ((nf_novariaallowed in flags) or (not varia)) and
+                    (not is_equal(htype.def,hp.left.resulttype.def)) then
+                  begin
+                    varia:=true;
+                  end;
+               end;
+              inc(len);
+              hp:=tarrayconstructornode(hp.right);
+            end;
+         end;
+         if not assigned(htype.def) then
+          htype:=voidtype;
+         resulttype.setdef(new(parraydef,init(0,len-1,s32bittype)));
+         parraydef(resulttype.def)^.elementtype:=htype;
+         parraydef(resulttype.def)^.IsConstructor:=true;
+         parraydef(resulttype.def)^.IsVariant:=varia;
+      end;
+
+
     function tarrayconstructornode.pass_1 : tnode;
       var
-        pd : pdef;
+        htype : ttype;
         thp,
         chp,
         hp : tarrayconstructornode;
@@ -597,34 +605,25 @@ implementation
            { is_open_array checks now for isconstructor (FK)   }
            { if no type is set then we set the type to voiddef to overcome a
            0 addressing }
-           if not assigned(pd) then
-             pd:=voiddef;
+           if not assigned(htype.def) then
+             htype:=voidtype;
            { skip if already done ! (PM) }
-           if not assigned(t.resulttype) or
-              (t.resulttype^.deftype<>arraydef) or
-              not parraydef(t.resulttype)^.IsConstructor or
-              (parraydef(t.resulttype)^.lowrange<>0) or
-              (parraydef(t.resulttype)^.highrange<>len-1) then
-             t.resulttype:=new(parraydef,init(0,len-1,s32bitdef));
-
-           parraydef(t.resulttype)^.elementtype.def:=pd;
-           parraydef(t.resulttype)^.IsConstructor:=true;
-           parraydef(t.resulttype)^.IsVariant:=varia;
+           if not assigned(t.resulttype.def) or
+              (t.resulttype.def^.deftype<>arraydef) or
+              not parraydef(t.resulttype.def)^.IsConstructor or
+              (parraydef(t.resulttype.def)^.lowrange<>0) or
+              (parraydef(t.resulttype.def)^.highrange<>len-1) then
+             t.resulttype.setdef(new(parraydef,init(0,len-1,s32bittype)));
+
+           parraydef(t.resulttype.def)^.elementtype:=htype;
+           parraydef(t.resulttype.def)^.IsConstructor:=true;
+           parraydef(t.resulttype.def)^.IsVariant:=varia;
            t.location.loc:=LOC_MEM;
         end;
       begin
         result:=nil;
-      { are we allowing array constructor? Then convert it to a set }
-        if not allow_array_constructor then
-         begin
-           hp:=tarrayconstructornode(getcopy);
-           arrayconstructor_to_set(hp);
-           firstpass(hp);
-           pass_1:=hp;
-           exit;
-         end;
       { only pass left tree, right tree contains next construct if any }
-        pd:=constructordef;
+        htype:=constructortype;
         len:=0;
         varia:=false;
         if assigned(left) then
@@ -637,57 +636,57 @@ implementation
               if (not get_para_resulttype) and
                 (not(nf_novariaallowed in flags)) then
                begin
-                 case hp.left.resulttype^.deftype of
+                 case hp.left.resulttype.def^.deftype of
                    enumdef :
                      begin
-                       hp.left:=gentypeconvnode(hp.left,s32bitdef);
+                       hp.left:=ctypeconvnode.create(hp.left,s32bittype);
                        firstpass(hp.left);
                      end;
                    orddef :
                      begin
-                       if is_integer(hp.left.resulttype) and
-                         not(is_64bitint(hp.left.resulttype)) then
+                       if is_integer(hp.left.resulttype.def) and
+                         not(is_64bitint(hp.left.resulttype.def)) then
                         begin
-                          hp.left:=gentypeconvnode(hp.left,s32bitdef);
+                          hp.left:=ctypeconvnode.create(hp.left,s32bittype);
                           firstpass(hp.left);
                         end;
                      end;
                    floatdef :
                      begin
-                       hp.left:=gentypeconvnode(hp.left,bestrealdef^);
+                       hp.left:=ctypeconvnode.create(hp.left,pbestrealtype^);
                        firstpass(hp.left);
                      end;
                    stringdef :
                      begin
                        if nf_cargs in flags then
                         begin
-                          hp.left:=gentypeconvnode(hp.left,charpointerdef);
+                          hp.left:=ctypeconvnode.create(hp.left,charpointertype);
                           firstpass(hp.left);
                         end;
                      end;
                    procvardef :
                      begin
-                       hp.left:=gentypeconvnode(hp.left,voidpointerdef);
+                       hp.left:=ctypeconvnode.create(hp.left,voidpointertype);
                        firstpass(hp.left);
                      end;
                    pointerdef,
                    classrefdef,
                    objectdef : ;
                    else
-                     CGMessagePos1(hp.left.fileinfo,type_e_wrong_type_in_array_constructor,hp.left.resulttype^.typename);
+                     CGMessagePos1(hp.left.fileinfo,type_e_wrong_type_in_array_constructor,hp.left.resulttype.def^.typename);
                  end;
                end;
-              if (pd=nil) then
-               pd:=hp.left.resulttype
+              if (htype.def=nil) then
+               htype:=hp.left.resulttype
               else
                begin
                  if ((nf_novariaallowed in flags) or (not varia)) and
-                    (not is_equal(pd,hp.left.resulttype)) then
+                    (not is_equal(htype.def,hp.left.resulttype.def)) then
                   begin
                     { if both should be equal try inserting a conversion }
                     if nf_novariaallowed in flags then
                      begin
-                       hp.left:=gentypeconvnode(hp.left,pd);
+                       hp.left:=ctypeconvnode.create(hp.left,htype);
                        firstpass(hp.left);
                      end;
                     varia:=true;
@@ -713,7 +712,7 @@ implementation
               include(chp.flags,nf_cargs);
               include(chp.flags,nf_cargswap);
               postprocess(chp);
-              pass_1:=chp;
+              result:=chp;
               exit;
             end;
          end;
@@ -724,46 +723,36 @@ implementation
       begin
         docompare :=
           inherited docompare(p) and
-          (constructordef = tarrayconstructornode(p).constructordef);
+          (constructortype.def = tarrayconstructornode(p).constructortype.def);
       end;
 
+
 {*****************************************************************************
                               TTYPENODE
 *****************************************************************************}
 
-    constructor ttypenode.create(t : pdef;sym:ptypesym);
+    constructor ttypenode.create(t : ttype);
 
       begin
          inherited create(typen);
-         resulttype:=generrordef;
-         typenodetype:=t;
-         typenodesym:=sym;
+         restype:=t;
       end;
 
-    function ttypenode.getcopy : tnode;
-
-      var
-         n : ttypenode;
-
+    function ttypenode.det_resulttype:tnode;
       begin
-         n:=ttypenode(inherited getcopy);
-         n.typenodetype:=typenodetype;
-         n.typenodesym:=typenodesym;
-         result:=n;
+        result:=nil;
+        resulttype:=restype;
       end;
 
     function ttypenode.pass_1 : tnode;
       begin
-         pass_1:=nil;
-         { do nothing, resulttype is already set }
+         result:=nil;
       end;
 
     function ttypenode.docompare(p: tnode): boolean;
       begin
         docompare :=
-          inherited docompare(p) and
-          (typenodetype = ttypenode(p).typenodetype) and
-          (typenodesym = ttypenode(p).typenodesym);
+          inherited docompare(p);
       end;
 
 begin
@@ -776,7 +765,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.10  2000-12-31 11:14:10  jonas
+  Revision 1.11  2001-04-02 21:20:31  peter
+    * resulttype rewrite
+
+  Revision 1.10  2000/12/31 11:14:10  jonas
     + implemented/fixed docompare() mathods for all nodes (not tested)
     + nopt.pas, nadd.pas, i386/n386opt.pas: optimized nodes for adding strings
       and constant strings/chars together

compiler/nmat.pas

@@ -32,20 +32,24 @@ interface
     type
        tmoddivnode = class(tbinopnode)
           function pass_1 : tnode;override;
+          function det_resulttype:tnode;override;
        end;
 
        tshlshrnode = class(tbinopnode)
           function pass_1 : tnode;override;
+          function det_resulttype:tnode;override;
        end;
 
        tunaryminusnode = class(tunarynode)
-         constructor create(expr : tnode);virtual;
+          constructor create(expr : tnode);virtual;
           function pass_1 : tnode;override;
+          function det_resulttype:tnode;override;
        end;
 
        tnotnode = class(tunarynode)
           constructor create(expr : tnode);virtual;
           function pass_1 : tnode;override;
+          function det_resulttype:tnode;override;
        end;
 
     var
@@ -58,8 +62,11 @@ interface
 implementation
 
     uses
-      globtype,systems,tokens,
+      systems,tokens,
       verbose,globals,
+{$ifdef support_mmx}
+      globtype,
+{$endif}
       symconst,symtype,symtable,symdef,types,
       htypechk,pass_1,cpubase,cpuinfo,
 {$ifdef newcg}
@@ -71,138 +78,138 @@ implementation
 {****************************************************************************
                               TMODDIVNODE
  ****************************************************************************}
-    function tmoddivnode.pass_1 : tnode;
+
+    function tmoddivnode.det_resulttype:tnode;
       var
          t : tnode;
-         rv,lv : tconstexprint;
          rd,ld : pdef;
-
       begin
-         pass_1:=nil;
-         firstpass(left);
+         result:=nil;
+         resulttypepass(left);
+         resulttypepass(right);
          set_varstate(left,true);
-         firstpass(right);
          set_varstate(right,true);
          if codegenerror then
            exit;
 
+         { allow operator overloading }
          t:=self;
          if isbinaryoverloaded(t) then
            begin
-              pass_1:=t;
+              resulttypepass(t);
+              result:=t;
               exit;
            end;
 
-         { check for division by zero }
-         rv:=tordconstnode(right).value;
-         lv:=tordconstnode(left).value;
-         if is_constintnode(right) and (rv=0) then
-          begin
-            Message(parser_e_division_by_zero);
-            { recover }
-            rv:=1;
-          end;
-
-         if is_constintnode(left) and is_constintnode(right) then
-           begin
-              case nodetype of
-                modn:
-                  t:=genintconstnode(lv mod rv);
-                divn:
-                  t:=genintconstnode(lv div rv);
-              end;
-              firstpass(t);
-              pass_1:=t;
-              exit;
-           end;
          { if one operand is a cardinal and the other is a positive constant, convert the }
          { constant to a cardinal as well so we don't have to do a 64bit division (JM)    }
 
          { Do the same for qwords and positive constants as well, otherwise things like   }
          { "qword mod 10" are evaluated with int64 as result, which is wrong if the       }
          { "qword" was > high(int64) (JM)                                                 }
-         if (left.resulttype^.deftype=orddef) and (right.resulttype^.deftype=orddef) then
-           if (porddef(right.resulttype)^.typ in [u32bit,u64bit]) and
+         if (left.resulttype.def^.deftype=orddef) and (right.resulttype.def^.deftype=orddef) then
+           if (porddef(right.resulttype.def)^.typ in [u32bit,u64bit]) and
               is_constintnode(left) and
               (tordconstnode(left).value >= 0) then
-             begin
-               left := gentypeconvnode(left,right.resulttype);
-               firstpass(left);
-             end
-           else if (porddef(left.resulttype)^.typ in [u32bit,u64bit]) and
+             inserttypeconv(left,right.resulttype)
+           else if (porddef(left.resulttype.def)^.typ in [u32bit,u64bit]) and
               is_constintnode(right) and
               (tordconstnode(right).value >= 0) then
-             begin
-               right := gentypeconvnode(right,left.resulttype);
-               firstpass(right);
-             end;
+             inserttypeconv(right,left.resulttype);
 
-         if (left.resulttype^.deftype=orddef) and (right.resulttype^.deftype=orddef) and
-            (is_64bitint(left.resulttype) or is_64bitint(right.resulttype) or
+         if (left.resulttype.def^.deftype=orddef) and (right.resulttype.def^.deftype=orddef) and
+            (is_64bitint(left.resulttype.def) or is_64bitint(right.resulttype.def) or
              { when mixing cardinals and signed numbers, convert everythign to 64bit (JM) }
-             ((porddef(right.resulttype)^.typ = u32bit) and
-              is_signed(left.resulttype)) or
-             ((porddef(left.resulttype)^.typ = u32bit) and
-              is_signed(right.resulttype))) then
+             ((porddef(right.resulttype.def)^.typ = u32bit) and
+              is_signed(left.resulttype.def)) or
+             ((porddef(left.resulttype.def)^.typ = u32bit) and
+              is_signed(right.resulttype.def))) then
            begin
-              rd:=right.resulttype;
-              ld:=left.resulttype;
+              rd:=right.resulttype.def;
+              ld:=left.resulttype.def;
               { issue warning if necessary }
-              if not (is_64bitint(left.resulttype) or is_64bitint(right.resulttype)) then
+              if not (is_64bitint(left.resulttype.def) or is_64bitint(right.resulttype.def)) then
                 CGMessage(type_w_mixed_signed_unsigned);
               if is_signed(rd) or is_signed(ld) then
                 begin
                    if (porddef(ld)^.typ<>s64bit) then
-                     begin
-                       left:=gentypeconvnode(left,cs64bitdef);
-                       firstpass(left);
-                     end;
+                     inserttypeconv(left,cs64bittype);
                    if (porddef(rd)^.typ<>s64bit) then
-                     begin
-                        right:=gentypeconvnode(right,cs64bitdef);
-                        firstpass(right);
-                     end;
-                   calcregisters(self,2,0,0);
+                     inserttypeconv(right,cs64bittype);
                 end
               else
                 begin
                    if (porddef(ld)^.typ<>u64bit) then
-                     begin
-                       left:=gentypeconvnode(left,cu64bitdef);
-                       firstpass(left);
-                     end;
+                     inserttypeconv(left,cu64bittype);
                    if (porddef(rd)^.typ<>u64bit) then
-                     begin
-                        right:=gentypeconvnode(right,cu64bitdef);
-                        firstpass(right);
-                     end;
-                   calcregisters(self,2,0,0);
+                     inserttypeconv(right,cu64bittype);
                 end;
               resulttype:=left.resulttype;
            end
          else
            begin
-              if not(right.resulttype^.deftype=orddef) or
-                not(porddef(right.resulttype)^.typ in [s32bit,u32bit]) then
-                right:=gentypeconvnode(right,s32bitdef);
-
-              if not(left.resulttype^.deftype=orddef) or
-                not(porddef(left.resulttype)^.typ in [s32bit,u32bit]) then
-                left:=gentypeconvnode(left,s32bitdef);
+              if not(right.resulttype.def^.deftype=orddef) or
+                 not(porddef(right.resulttype.def)^.typ in [s32bit,u32bit]) then
+                inserttypeconv(right,s32bittype);
 
-              firstpass(left);
-              firstpass(right);
+              if not(left.resulttype.def^.deftype=orddef) or
+                 not(porddef(left.resulttype.def)^.typ in [s32bit,u32bit]) then
+                inserttypeconv(left,s32bittype);
 
-              { the resulttype depends on the right side, because the left becomes }
+              { the resulttype.def depends on the right side, because the left becomes }
               { always 64 bit                                                      }
               resulttype:=right.resulttype;
+           end;
+      end;
 
-              if codegenerror then
-                exit;
 
-              left_right_max;
-              if left.registers32<=right.registers32 then
-                inc(registers32);
+    function tmoddivnode.pass_1 : tnode;
+      var
+         t : tnode;
+         rv,lv : tconstexprint;
+
+      begin
+         result:=nil;
+         firstpass(left);
+         firstpass(right);
+         if codegenerror then
+           exit;
+
+         if is_constintnode(left) and is_constintnode(right) then
+           begin
+              rv:=tordconstnode(right).value;
+              lv:=tordconstnode(left).value;
+
+              { check for division by zero }
+              if (rv=0) then
+               begin
+                 Message(parser_e_division_by_zero);
+                 { recover }
+                 rv:=1;
+               end;
+
+              case nodetype of
+                modn:
+                  t:=genintconstnode(lv mod rv);
+                divn:
+                  t:=genintconstnode(lv div rv);
+              end;
+              firstpass(t);
+              result:=t;
+              exit;
+           end;
+
+         { 64bit }
+         if (left.resulttype.def^.deftype=orddef) and (right.resulttype.def^.deftype=orddef) and
+            (is_64bitint(left.resulttype.def) or is_64bitint(right.resulttype.def)) then
+           begin
+             calcregisters(self,2,0,0);
+           end
+         else
+           begin
+             left_right_max;
+             if left.registers32<=right.registers32 then
+              inc(registers32);
            end;
          location.loc:=LOC_REGISTER;
       end;
@@ -213,26 +220,51 @@ implementation
                               TSHLSHRNODE
  ****************************************************************************}
 
-    function tshlshrnode.pass_1 : tnode;
+    function tshlshrnode.det_resulttype:tnode;
       var
          t : tnode;
-         regs : longint;
       begin
-         pass_1:=nil;
-         firstpass(left);
-         set_varstate(left,true);
-         firstpass(right);
+         result:=nil;
+         resulttypepass(left);
+         resulttypepass(right);
          set_varstate(right,true);
+         set_varstate(left,true);
          if codegenerror then
            exit;
 
+         { allow operator overloading }
          t:=self;
          if isbinaryoverloaded(t) then
            begin
-              pass_1:=t;
+              resulttypepass(t);
+              result:=t;
               exit;
            end;
 
+         { 64 bit ints have their own shift handling }
+         if not(is_64bitint(left.resulttype.def)) then
+           begin
+              if porddef(left.resulttype.def)^.typ <> u32bit then
+               inserttypeconv(left,s32bittype);
+           end;
+
+         inserttypeconv(right,s32bittype);
+
+         resulttype:=left.resulttype;
+      end;
+
+
+    function tshlshrnode.pass_1 : tnode;
+      var
+         t : tnode;
+         regs : longint;
+      begin
+         result:=nil;
+         firstpass(left);
+         firstpass(right);
+         if codegenerror then
+           exit;
+
          if is_constintnode(left) and is_constintnode(right) then
            begin
               case nodetype of
@@ -242,29 +274,15 @@ implementation
                    t:=genintconstnode(tordconstnode(left).value shl tordconstnode(right).value);
               end;
               firstpass(t);
-              pass_1:=t;
+              result:=t;
               exit;
            end;
+
          { 64 bit ints have their own shift handling }
-         if not(is_64bitint(left.resulttype)) then
-           begin
-              if porddef(left.resulttype)^.typ <> u32bit then
-                left:=gentypeconvnode(left,s32bitdef);
-              firstpass(left);
-              regs:=1;
-              resulttype:=left.resulttype;
-           end
+         if not(is_64bitint(left.resulttype.def)) then
+          regs:=1
          else
-           begin
-              resulttype:=left.resulttype;
-              regs:=2;
-           end;
-
-         right:=gentypeconvnode(right,s32bitdef);
-         firstpass(right);
-
-         if codegenerror then
-           exit;
+          regs:=2;
 
          if (right.nodetype<>ordconstn) then
           inc(regs);
@@ -277,101 +295,46 @@ implementation
 {****************************************************************************
                             TUNARYMINUSNODE
  ****************************************************************************}
-    constructor tunaryminusnode.create(expr : tnode);
 
+    constructor tunaryminusnode.create(expr : tnode);
       begin
          inherited create(unaryminusn,expr);
       end;
 
-   function tunaryminusnode.pass_1 : tnode;
+    function tunaryminusnode.det_resulttype : tnode;
       var
          t : tnode;
          minusdef : pprocdef;
       begin
-         pass_1:=nil;
-         firstpass(left);
+         result:=nil;
+         resulttypepass(left);
          set_varstate(left,true);
-         registers32:=left.registers32;
-         registersfpu:=left.registersfpu;
-{$ifdef SUPPORT_MMX}
-         registersmmx:=left.registersmmx;
-{$endif SUPPORT_MMX}
-         resulttype:=left.resulttype;
          if codegenerror then
            exit;
-         if is_constintnode(left) then
-           begin
-              t:=genintconstnode(-tordconstnode(left).value);
-              firstpass(t);
-              pass_1:=t;
-              exit;
-           end;
-         if is_constrealnode(left) then
-           begin
-              t:=genrealconstnode(-trealconstnode(left).value_real,bestrealdef^);
-              firstpass(t);
-              pass_1:=t;
-              exit;
-           end;
-         if (left.resulttype^.deftype=floatdef) then
+         resulttype:=left.resulttype;
+
+         if (left.resulttype.def^.deftype=floatdef) then
            begin
-              if pfloatdef(left.resulttype)^.typ=f32bit then
-                begin
-                   if (left.location.loc<>LOC_REGISTER) and
-                     (registers32<1) then
-                     registers32:=1;
-                   location.loc:=LOC_REGISTER;
-                end
-              else
-                location.loc:=LOC_FPU;
            end
 {$ifdef SUPPORT_MMX}
          else if (cs_mmx in aktlocalswitches) and
-           is_mmx_able_array(left.resulttype) then
+           is_mmx_able_array(left.resulttype.def) then
              begin
-               if (left.location.loc<>LOC_MMXREGISTER) and
-                 (registersmmx<1) then
-                 registersmmx:=1;
-               { if saturation is on, left.resulttype isn't
+               { if saturation is on, left.resulttype.def isn't
                  "mmx able" (FK)
                if (cs_mmx_saturation in aktlocalswitches^) and
-                 (porddef(parraydef(resulttype)^.definition)^.typ in
+                 (porddef(parraydef(resulttype.def)^.definition)^.typ in
                  [s32bit,u32bit]) then
                  CGMessage(type_e_mismatch);
                }
              end
 {$endif SUPPORT_MMX}
-         else if is_64bitint(left.resulttype) then
+         else if is_64bitint(left.resulttype.def) then
            begin
-              firstpass(left);
-              registersfpu:=left.registersfpu;
-{$ifdef SUPPORT_MMX}
-              registersmmx:=left.registersmmx;
-{$endif SUPPORT_MMX}
-              registers32:=left.registers32;
-              if codegenerror then
-                exit;
-              if (left.location.loc<>LOC_REGISTER) and
-                (registers32<2) then
-              registers32:=2;
-              location.loc:=LOC_REGISTER;
-              resulttype:=left.resulttype;
            end
-         else if (left.resulttype^.deftype=orddef) then
+         else if (left.resulttype.def^.deftype=orddef) then
            begin
-              left:=gentypeconvnode(left,s32bitdef);
-              firstpass(left);
-              registersfpu:=left.registersfpu;
-{$ifdef SUPPORT_MMX}
-              registersmmx:=left.registersmmx;
-{$endif SUPPORT_MMX}
-              registers32:=left.registers32;
-              if codegenerror then
-                exit;
-              if (left.location.loc<>LOC_REGISTER) and
-                (registers32<1) then
-              registers32:=1;
-              location.loc:=LOC_REGISTER;
+              inserttypeconv(left,s32bittype);
               resulttype:=left.resulttype;
            end
          else
@@ -382,14 +345,14 @@ implementation
                 minusdef:=nil;
               while assigned(minusdef) do
                 begin
-                   if is_equal(tparaitem(minusdef^.para.first).paratype.def,left.resulttype) and
+                   if is_equal(tparaitem(minusdef^.para.first).paratype.def,left.resulttype.def) and
                       (tparaitem(minusdef^.para.first).next=nil) then
                      begin
-                        t:=gencallnode(overloaded_operators[_minus],nil);
-                        tcallnode(t).left:=gencallparanode(left,nil);
+                        t:=ccallnode.create(ccallparanode.create(left,nil),
+                                            overloaded_operators[_minus],nil,nil);
                         left:=nil;
-                        firstpass(t);
-                        pass_1:=t;
+                        resulttypepass(t);
+                        result:=t;
                         exit;
                      end;
                    minusdef:=minusdef^.nextoverloaded;
@@ -399,6 +362,66 @@ implementation
       end;
 
 
+    function tunaryminusnode.pass_1 : tnode;
+      var
+         t : tnode;
+      begin
+         result:=nil;
+         firstpass(left);
+         if codegenerror then
+           exit;
+
+         if is_constintnode(left) then
+           begin
+              t:=cordconstnode.create(-tordconstnode(left).value,resulttype);
+              firstpass(t);
+              result:=t;
+              exit;
+           end;
+         if is_constrealnode(left) then
+           begin
+              t:=crealconstnode.create(-trealconstnode(left).value_real,resulttype);
+              firstpass(t);
+              result:=t;
+              exit;
+           end;
+
+         registers32:=left.registers32;
+         registersfpu:=left.registersfpu;
+{$ifdef SUPPORT_MMX}
+         registersmmx:=left.registersmmx;
+{$endif SUPPORT_MMX}
+
+         if (left.resulttype.def^.deftype=floatdef) then
+           begin
+             location.loc:=LOC_FPU;
+           end
+{$ifdef SUPPORT_MMX}
+         else if (cs_mmx in aktlocalswitches) and
+           is_mmx_able_array(left.resulttype.def) then
+             begin
+               if (left.location.loc<>LOC_MMXREGISTER) and
+                  (registersmmx<1) then
+                 registersmmx:=1;
+             end
+{$endif SUPPORT_MMX}
+         else if is_64bitint(left.resulttype.def) then
+           begin
+              if (left.location.loc<>LOC_REGISTER) and
+                 (registers32<2) then
+                registers32:=2;
+              location.loc:=LOC_REGISTER;
+           end
+         else if (left.resulttype.def^.deftype=orddef) then
+           begin
+              if (left.location.loc<>LOC_REGISTER) and
+                 (registers32<1) then
+                registers32:=1;
+              location.loc:=LOC_REGISTER;
+           end;
+      end;
+
+
 {****************************************************************************
                                TNOTNODE
  ****************************************************************************}
@@ -409,12 +432,67 @@ implementation
          inherited create(notn,expr);
       end;
 
-    function tnotnode.pass_1 : tnode;
+    function tnotnode.det_resulttype : tnode;
       var
          t : tnode;
          notdef : pprocdef;
       begin
-         pass_1:=nil;
+         result:=nil;
+         resulttypepass(left);
+         set_varstate(left,true);
+         if codegenerror then
+           exit;
+
+         resulttype:=left.resulttype;
+         if is_boolean(resulttype.def) then
+           begin
+           end
+         else
+{$ifdef SUPPORT_MMX}
+           if (cs_mmx in aktlocalswitches) and
+             is_mmx_able_array(left.resulttype.def) then
+             begin
+             end
+         else
+{$endif SUPPORT_MMX}
+           if is_64bitint(left.resulttype.def) then
+             begin
+             end
+         else if is_integer(left.resulttype.def) then
+           begin
+              if (porddef(left.resulttype.def)^.typ <> u32bit) then
+                inserttypeconv(left,s32bittype);
+           end
+         else
+           begin
+              if assigned(overloaded_operators[_op_not]) then
+                notdef:=overloaded_operators[_op_not]^.definition
+              else
+                notdef:=nil;
+              while assigned(notdef) do
+                begin
+                   if is_equal(tparaitem(notdef^.para.first).paratype.def,left.resulttype.def) and
+                      (tparaitem(notdef^.para.first).next=nil) then
+                     begin
+                        t:=ccallnode.create(ccallparanode.create(left,nil),
+                                            overloaded_operators[_op_not],nil,nil);
+                        left:=nil;
+                        resulttypepass(t);
+                        result:=t;
+                        exit;
+                     end;
+                   notdef:=notdef^.nextoverloaded;
+                end;
+              CGMessage(type_e_mismatch);
+           end;
+      end;
+
+
+    function tnotnode.pass_1 : tnode;
+      var
+         t : tnode;
+      begin
+         result:=nil;
          firstpass(left);
          set_varstate(left,true);
          if codegenerror then
@@ -422,24 +500,25 @@ implementation
 
          if (left.nodetype=ordconstn) then
            begin
-              if is_boolean(left.resulttype) then
+              if is_boolean(left.resulttype.def) then
                 { here we do a boolena(byte(..)) type cast because }
                 { boolean(<int64>) is buggy in 1.00                }
-                t:=genordinalconstnode(byte(not(boolean(byte(tordconstnode(left).value)))),left.resulttype)
+                t:=cordconstnode.create(byte(not(boolean(byte(tordconstnode(left).value)))),left.resulttype)
               else
-                t:=genordinalconstnode(not(tordconstnode(left).value),left.resulttype);
+                t:=cordconstnode.create(not(tordconstnode(left).value),left.resulttype);
               firstpass(t);
-              pass_1:=t;
+              result:=t;
               exit;
            end;
-         resulttype:=left.resulttype;
+
          location.loc:=left.location.loc;
+         resulttype:=left.resulttype;
+         registers32:=left.registers32;
 {$ifdef SUPPORT_MMX}
          registersmmx:=left.registersmmx;
 {$endif SUPPORT_MMX}
-         if is_boolean(resulttype) then
+         if is_boolean(resulttype.def) then
            begin
-             registers32:=left.registers32;
              if (location.loc in [LOC_REFERENCE,LOC_MEM,LOC_CREGISTER]) then
               begin
                 location.loc:=LOC_REGISTER;
@@ -456,7 +535,7 @@ implementation
          else
 {$ifdef SUPPORT_MMX}
            if (cs_mmx in aktlocalswitches) and
-             is_mmx_able_array(left.resulttype) then
+             is_mmx_able_array(left.resulttype.def) then
              begin
                if (left.location.loc<>LOC_MMXREGISTER) and
                  (registersmmx<1) then
@@ -464,9 +543,8 @@ implementation
              end
          else
 {$endif SUPPORT_MMX}
-           if is_64bitint(left.resulttype) then
+           if is_64bitint(left.resulttype.def) then
              begin
-                registers32:=left.registers32;
                 if (location.loc in [LOC_REFERENCE,LOC_MEM,LOC_CREGISTER]) then
                  begin
                    location.loc:=LOC_REGISTER;
@@ -474,54 +552,15 @@ implementation
                     registers32:=2;
                  end;
              end
-         else if is_integer(left.resulttype) then
+         else if is_integer(left.resulttype.def) then
            begin
-              if (porddef(left.resulttype)^.typ <> u32bit) then
-                begin
-                  left:=gentypeconvnode(left,s32bitdef);
-                  firstpass(left);
-                  if codegenerror then
-                    exit;
-                end;
-
-              resulttype:=left.resulttype;
-              registers32:=left.registers32;
-{$ifdef SUPPORT_MMX}
-              registersmmx:=left.registersmmx;
-{$endif SUPPORT_MMX}
-
               if (left.location.loc<>LOC_REGISTER) and
                  (registers32<1) then
                 registers32:=1;
               location.loc:=LOC_REGISTER;
            end
-         else
-           begin
-              if assigned(overloaded_operators[_op_not]) then
-                notdef:=overloaded_operators[_op_not]^.definition
-              else
-                notdef:=nil;
-              while assigned(notdef) do
-                begin
-                   if is_equal(tparaitem(notdef^.para.first).paratype.def,left.resulttype) and
-                      (tparaitem(notdef^.para.first).next=nil) then
-                     begin
-                        t:=gencallnode(overloaded_operators[_op_not],nil);
-                        tcallnode(t).left:=gencallparanode(left,nil);
-                        left:=nil;
-                        firstpass(t);
-                        pass_1:=t;
-                        exit;
-                     end;
-                   notdef:=notdef^.nextoverloaded;
-                end;
-              CGMessage(type_e_mismatch);
-           end;
-
-         registersfpu:=left.registersfpu;
       end;
 
-
 begin
    cmoddivnode:=tmoddivnode;
    cshlshrnode:=tshlshrnode;
@@ -530,7 +569,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.16  2001-03-20 18:11:03  jonas
+  Revision 1.17  2001-04-02 21:20:31  peter
+    * resulttype rewrite
+
+  Revision 1.16  2001/03/20 18:11:03  jonas
     * not (cardinal) now has cardinal instead of longint result (bug reported
       in mailinglist) ("merged")
 
@@ -552,7 +594,7 @@ end.
       tlinkedlist objects)
 
   Revision 1.10  2000/12/16 15:54:01  jonas
-    * 'resulttype of cardinal shl/shr x' is cardinal instead of longint
+    * 'resulttype.def of cardinal shl/shr x' is cardinal instead of longint
 
   Revision 1.9  2000/11/29 00:30:34  florian
     * unused units removed from uses clause

compiler/node.pas

@@ -69,7 +69,6 @@ interface
           calln,           {Represents a call node.}
           callparan,       {Represents a parameter.}
           realconstn,      {Represents a real value.}
-          fixconstn,       {Represents a fixed value.}
           unaryminusn,     {Represents a sign change (i.e. -2).}
           asmn,     {Represents an assembler node }
           vecn,     {Represents array indexing.}
@@ -123,6 +122,90 @@ interface
           loadvmtn
        );
 
+      const
+        nodetype2str : array[tnodetype] of string[20] = (
+          'addn',
+          'muln',
+          'subn',
+          'divn',
+          'symdifn',
+          'modn',
+          'assignn',
+          'loadn',
+          'rangen',
+          'ltn',
+          'lten',
+          'gtn',
+          'gten',
+          'equaln',
+          'unequaln',
+          'inn',
+          'orn',
+          'xorn',
+          'shrn',
+          'shln',
+          'slashn',
+          'andn',
+          'subscriptn',
+          'derefn',
+          'addrn',
+          'doubleaddrn',
+          'ordconstn',
+          'typeconvn',
+          'calln',
+          'callparan',
+          'realconstn',
+          'umminusn',
+          'asmn',
+          'vecn',
+          'pointerconstn',
+          'stringconstn',
+          'funcretn',
+          'selfn',
+          'notn',
+          'inlinen',
+          'niln',
+          'errorn',
+          'typen',
+          'hnewn',
+          'hdisposen',
+          'newn',
+          'simpledisposen',
+          'setelementn',
+          'setconstn',
+          'blockn',
+          'statementn',
+          'loopn',
+          'ifn',
+          'breakn',
+          'continuen',
+          'repeatn',
+          'whilen',
+          'forn',
+          'exitn',
+          'withn',
+          'casen',
+          'labeln',
+          'goton',
+          'simplenewn',
+          'tryexceptn',
+          'raisen',
+          'switchesn',
+          'tryfinallyn',
+          'onn',
+          'isn',
+          'asn',
+          'caretn',
+          'failn',
+          'starstarn',
+          'procinlinen',
+          'arrayconstructn',
+          'arrayconstructrangen',
+          'addoptn',
+          'nothingn',
+          'loadvmtn');
+
+    type
        { all boolean field of ttree are now collected in flags }
        tnodeflags = (
          nf_needs_truefalselabel,
@@ -197,6 +280,7 @@ interface
 
        { later (for the newcg) tnode will inherit from tlinkedlist_item }
        tnode = class
+       public
           nodetype : tnodetype;
           { the location of the result of this node }
           location : tlocation;
@@ -210,10 +294,11 @@ interface
 {$ifdef SUPPORT_MMX}
           registersmmx,registerskni : longint;
 {$endif SUPPORT_MMX}
-          resulttype : pdef;
+          resulttype : ttype;
           fileinfo : tfileposinfo;
           localswitches : tlocalswitches;
 {$ifdef extdebug}
+          oldresulttype : ttype; { to detect changed resulttype }
           maxfirstpasscount,
           firstpasscount : longint;
 {$endif extdebug}
@@ -231,9 +316,9 @@ interface
           { and it need not to implement det_* then    }
           { 1.1: pass_1 returns a value<>0 if the node has been transformed }
           { 2.0: runs det_resulttype and det_temp                           }
-          function pass_1 : tnode;virtual;
+          function pass_1 : tnode;virtual;abstract;
           { dermines the resulttype of the node }
-          procedure det_resulttype;virtual;abstract;
+          function det_resulttype : tnode;virtual;abstract;
           { dermines the number of necessary temp. locations to evaluate
             the node }
           procedure det_temp;virtual;abstract;
@@ -279,8 +364,6 @@ interface
           destructor destroy;override;
           procedure concattolist(l : tlinkedlist);override;
           function ischild(p : tnode) : boolean;override;
-          procedure det_resulttype;override;
-          procedure det_temp;override;
           function docompare(p : tnode) : boolean;override;
           function getcopy : tnode;override;
           procedure insertintolist(l : tnodelist);override;
@@ -297,8 +380,6 @@ interface
           destructor destroy;override;
           procedure concattolist(l : tlinkedlist);override;
           function ischild(p : tnode) : boolean;override;
-          procedure det_resulttype;override;
-          procedure det_temp;override;
           function docompare(p : tnode) : boolean;override;
           procedure swapleftright;
           function getcopy : tnode;override;
@@ -342,12 +423,17 @@ implementation
          { save local info }
          fileinfo:=aktfilepos;
          localswitches:=aktlocalswitches;
-         resulttype:=nil;
+         resulttype.reset;
          registers32:=0;
          registersfpu:=0;
 {$ifdef SUPPORT_MMX}
          registersmmx:=0;
 {$endif SUPPORT_MMX}
+{$ifdef EXTDEBUG}
+         oldresulttype.reset;
+         maxfirstpasscount:=0;
+         firstpasscount:=0;
+{$endif EXTDEBUG}
          flags:=[];
       end;
 
@@ -368,27 +454,12 @@ implementation
     destructor tnode.destroy;
 
       begin
-         { reference info }
-         {if (location.loc in [LOC_MEM,LOC_REFERENCE]) and
-            assigned(location.reference.symbol) then
-           dispose(location.reference.symbol,done);}
-
 {$ifdef EXTDEBUG}
          if firstpasscount>maxfirstpasscount then
             maxfirstpasscount:=firstpasscount;
 {$endif EXTDEBUG}
       end;
 
-    function tnode.pass_1 : tnode;
-
-      begin
-         pass_1:=nil;
-
-         if not(assigned(resulttype)) then
-           det_resulttype;
-
-         det_temp;
-      end;
 
     procedure tnode.concattolist(l : tlinkedlist);
 
@@ -412,89 +483,6 @@ implementation
       end;
 
     procedure tnode.dowritenodetype;
-      const nodetype2str : array[tnodetype] of string[20] = (
-          'addn',
-          'muln',
-          'subn',
-          'divn',
-          'symdifn',
-          'modn',
-          'assignn',
-          'loadn',
-          'rangen',
-          'ltn',
-          'lten',
-          'gtn',
-          'gten',
-          'equaln',
-          'unequaln',
-          'inn',
-          'orn',
-          'xorn',
-          'shrn',
-          'shln',
-          'slashn',
-          'andn',
-          'subscriptn',
-          'derefn',
-          'addrn',
-          'doubleaddrn',
-          'ordconstn',
-          'typeconvn',
-          'calln',
-          'callparan',
-          'realconstn',
-          'fixconstn',
-          'umminusn',
-          'asmn',
-          'vecn',
-          'pointerconstn',
-          'stringconstn',
-          'funcretn',
-          'selfn',
-          'notn',
-          'inlinen',
-          'niln',
-          'errorn',
-          'typen',
-          'hnewn',
-          'hdisposen',
-          'newn',
-          'simpledisposen',
-          'setelementn',
-          'setconstn',
-          'blockn',
-          'statementn',
-          'loopn',
-          'ifn',
-          'breakn',
-          'continuen',
-          'repeatn',
-          'whilen',
-          'forn',
-          'exitn',
-          'withn',
-          'casen',
-          'labeln',
-          'goton',
-          'simplenewn',
-          'tryexceptn',
-          'raisen',
-          'switchesn',
-          'tryfinallyn',
-          'onn',
-          'isn',
-          'asn',
-          'caretn',
-          'failn',
-          'starstarn',
-          'procinlinen',
-          'arrayconstructn',
-          'arrayconstructrangen',
-          'addoptn',
-          'nothingn',
-          'loadvmtn');
-
       begin
          write(writenodeindention,'(',nodetype2str[nodetype]);
       end;
@@ -589,8 +577,9 @@ implementation
     function tunarynode.docompare(p : tnode) : boolean;
 
       begin
-         docompare:=(inherited docompare(p)) and
-           left.isequal(tunarynode(p).left);
+         docompare:=(inherited docompare(p) and
+           ((left=nil) or left.isequal(tunarynode(p).left))
+         );
       end;
 
     function tunarynode.getcopy : tnode;
@@ -649,18 +638,6 @@ implementation
          ischild:=p=left;
       end;
 
-    procedure tunarynode.det_resulttype;
-
-      begin
-         left.det_resulttype;
-      end;
-
-    procedure tunarynode.det_temp;
-
-      begin
-         left.det_temp;
-      end;
-
 {****************************************************************************
                             TBINARYNODE
  ****************************************************************************}
@@ -693,29 +670,15 @@ implementation
     function tbinarynode.ischild(p : tnode) : boolean;
 
       begin
-         ischild:=(p=right) or (p=right);
-      end;
-
-    procedure tbinarynode.det_resulttype;
-
-      begin
-         left.det_resulttype;
-         right.det_resulttype;
-      end;
-
-    procedure tbinarynode.det_temp;
-
-      begin
-         left.det_temp;
-         right.det_temp;
+         ischild:=(p=right);
       end;
 
     function tbinarynode.docompare(p : tnode) : boolean;
 
       begin
-         docompare:=
-           inherited docompare(p) and
-           right.isequal(tbinarynode(p).right);
+         docompare:=(inherited docompare(p) and
+             ((right=nil) or right.isequal(tbinarynode(p).right))
+         );
       end;
 
     function tbinarynode.getcopy : tnode;
@@ -745,8 +708,7 @@ implementation
       begin
          swapp:=right;
          right:=left;
-         left:=
-         swapp;
+         left:=swapp;
          if nf_swaped in flags then
            exclude(flags,nf_swaped)
          else
@@ -830,7 +792,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.13  2001-01-13 00:08:09  peter
+  Revision 1.14  2001-04-02 21:20:31  peter
+    * resulttype rewrite
+
+  Revision 1.13  2001/01/13 00:08:09  peter
     * added missing addoptn
 
   Revision 1.12  2001/01/01 11:38:45  peter

compiler/nopt.pas

@@ -1,284 +1,287 @@
-{
-    $Id$
-    Copyright (c) 1998-2000 by Jonas Maebe
-
-    This unit implements optimized nodes
-
-    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 nopt;
-
-{$i defines.inc}
-
-interface
-
-uses node, nadd;
-
-type
-  tsubnodetype = (
-    addsstringcharoptn,  { shorstring + char }
-    addsstringcsstringoptn   { shortstring + constant shortstring }
-  );
-
-  taddoptnode = class(taddnode)
-     subnodetype: tsubnodetype;
-     constructor create(ts: tsubnodetype; l,r : tnode); virtual;
-     { pass_1 will be overridden by the separate subclasses    }
-     { By default, pass_2 is the same as for addnode           }
-     { Only if there's a processor specific implementation, it }
-     { will be overridden.                                     }
-     function getcopy: tnode; override;
-     function docompare(p: tnode): boolean; override;
-  end;
-
-  taddsstringoptnode = class(taddoptnode)
-    { maximum length of the string until now, allows us to skip a compare }
-    { sometimes (it's initialized/updated by calling updatecurmaxlen)     }
-    curmaxlen: byte;
-    { pass_1 must be overridden, otherwise we get an endless loop }
-    function pass_1: tnode; override;
-    function getcopy: tnode; override;
-    function docompare(p: tnode): boolean; override;
-   protected
-    procedure updatecurmaxlen;
-  end;
-
-  { add a char to a shortstring }
-  taddsstringcharoptnode = class(taddsstringoptnode)
-    constructor create(l,r : tnode); virtual;
-  end;
-
-  { add a constant string to a short string }
-  taddsstringcsstringoptnode = class(taddsstringoptnode)
-    constructor create(l,r : tnode); virtual;
-  end;
-
-function canbeaddsstringcharoptnode(p: taddnode): boolean;
-function genaddsstringcharoptnode(p: taddnode): tnode;
-function canbeaddsstringcsstringoptnode(p: taddnode): boolean;
-function genaddsstringcsstringoptnode(p: taddnode): tnode;
-
-
-function is_addsstringoptnode(p: tnode): boolean;
-
-var
-{  these are never used directly
-   caddoptnode: class of taddoptnode; }
-   caddsstringcharoptnode: class of taddsstringcharoptnode;
-   caddsstringcsstringoptnode: class of taddsstringcsstringoptnode;
-
-implementation
-
-uses cutils, htypechk, types, globtype, globals, cpubase, pass_1, ncnv, ncon,
-     verbose, symdef, hcodegen;
-
-
-{*****************************************************************************
-                             TADDOPTNODE
-*****************************************************************************}
-
-constructor taddoptnode.create(ts: tsubnodetype; l,r : tnode);
-begin
-  { we need to keep the addn nodetype, otherwise taddnode.pass_2 will be }
-  { confused. Comparison for equal nodetypes therefore has to be         }
-  { implemented using the classtype() method (JM)                        }
-  inherited create(addn,l,r);
-  subnodetype := ts;
-end;
-
-function taddoptnode.getcopy: tnode;
-var
-  hp: taddoptnode;
-begin
-  hp := taddoptnode(inherited getcopy);
-  hp.subnodetype := subnodetype;
-  getcopy := hp;
-end;
-
-function taddoptnode.docompare(p: tnode): boolean;
-begin
-  docompare :=
-    inherited docompare(p) and
-    (subnodetype = taddoptnode(p).subnodetype);
-end;
-
-
-{*****************************************************************************
-                        TADDSSTRINGOPTNODE
-*****************************************************************************}
-
-function taddsstringoptnode.pass_1: tnode;
-begin
-  pass_1 := nil;
-  updatecurmaxlen;
-  { left and right are already firstpass'ed by taddnode.pass_1 }
-  if not is_shortstring(left.resulttype) then
-    begin
-      left := gentypeconvnode(left,cshortstringdef);
-      firstpass(left);
-    end;
-  if not is_shortstring(right.resulttype) then
-    begin
-      right := gentypeconvnode(right,cshortstringdef);
-      firstpass(right);
-    end;
-  location.loc := LOC_MEM;
-  calcregisters(self,0,0,0);
-  { here we call STRCONCAT or STRCMP or STRCOPY }
-  procinfo^.flags:=procinfo^.flags or pi_do_call;
-  resulttype := left.resulttype;
-end;
-
-function taddsstringoptnode.getcopy: tnode;
-var
-  hp: taddsstringoptnode;
-begin
-  hp := taddsstringoptnode(inherited getcopy);
-  hp.curmaxlen := curmaxlen;
-  getcopy := hp;
-end;
-
-function taddsstringoptnode.docompare(p: tnode): boolean;
-begin
-  docompare :=
-    inherited docompare(p) and
-    (curmaxlen = taddsstringcharoptnode(p).curmaxlen);
-end;
-
-
-function is_addsstringoptnode(p: tnode): boolean;
-begin
-  is_addsstringoptnode :=
-    p.inheritsfrom(taddsstringoptnode);
-end;
-
-procedure taddsstringoptnode.updatecurmaxlen;
-begin
-  if is_addsstringoptnode(left) then
-    begin
-      { made it a separate block so no other if's are processed (would be a }
-      { simple waste of time) (JM)                                          }
-      if (taddsstringoptnode(left).curmaxlen < 255) then
-        case subnodetype of
-          addsstringcharoptn:
-            curmaxlen := succ(taddsstringoptnode(left).curmaxlen);
-          addsstringcsstringoptn:
-            curmaxlen := min(taddsstringoptnode(left).curmaxlen +
-                              tstringconstnode(right).len,255)
-          else
-            internalerror(291220001);
-        end
-      else curmaxlen := 255;
-    end
-  else if (left.nodetype = stringconstn) then
-    curmaxlen := min(tstringconstnode(left).len,255)
-  else if is_char(left.resulttype) then
-    curmaxlen := 1
-  else if (left.nodetype = typeconvn) then
-    begin
-      case ttypeconvnode(left).convtype of
-        tc_char_2_string:
-          curmaxlen := 1;
-{       doesn't work yet, don't know why (JM)
-        tc_chararray_2_string:
-          curmaxlen :=
-            min(ttypeconvnode(left).left.resulttype^.size,255); }
-        else curmaxlen := 255;
-      end;
-    end
-  else
-    curmaxlen := 255;
-end;
-
-{*****************************************************************************
-                        TADDSSTRINGCHAROPTNODE
-*****************************************************************************}
-
-
-constructor taddsstringcharoptnode.create(l,r : tnode);
-begin
-  inherited create(addsstringcharoptn,l,r);
-end;
-
-{*****************************************************************************
-                        TADDSSTRINGCSSTRINGOPTNODE
-*****************************************************************************}
-
-
-constructor taddsstringcsstringoptnode.create(l,r : tnode);
-begin
-  inherited create(addsstringcsstringoptn,l,r);
-end;
-
-{*****************************************************************************
-                                HELPERS
-*****************************************************************************}
-
-function canbeaddsstringcharoptnode(p: taddnode): boolean;
-begin
-  canbeaddsstringcharoptnode :=
-    (cs_optimize in aktglobalswitches) and
-
-{   the shortstring will be gotten through conversion if necessary (JM)
-    is_shortstring(p.left.resulttype) and }
-    ((p.nodetype = addn) and
-     is_char(p.right.resulttype));
-end;
-
-function genaddsstringcharoptnode(p: taddnode): tnode;
-var
-  hp: tnode;
-begin
-  hp := caddsstringcharoptnode.create(p.left.getcopy,p.right.getcopy);
-  hp.flags := p.flags;
-  genaddsstringcharoptnode := hp;
-end;
-
-
-
-function canbeaddsstringcsstringoptnode(p: taddnode): boolean;
-begin
-  canbeaddsstringcsstringoptnode :=
-    (cs_optimize in aktglobalswitches) and
-
-{   the shortstring will be gotten through conversion if necessary (JM)
-    is_shortstring(p.left.resulttype) and }
-    ((p.nodetype = addn) and
-     (p.right.nodetype = stringconstn));
-end;
-
-function genaddsstringcsstringoptnode(p: taddnode): tnode;
-var
-  hp: tnode;
-begin
-  hp := caddsstringcsstringoptnode.create(p.left.getcopy,p.right.getcopy);
-  hp.flags := p.flags;
-  genaddsstringcsstringoptnode := hp;
-end;
-
-
-begin
-  caddsstringcharoptnode := taddsstringcharoptnode;
-  caddsstringcsstringoptnode := taddsstringcsstringoptnode;
-end.
-
-{
+{
+    $Id$
+    Copyright (c) 1998-2000 by Jonas Maebe
+
+    This unit implements optimized nodes
+
+    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 nopt;
+
+{$i defines.inc}
+
+interface
+
+uses node, nadd;
+
+type
+  tsubnodetype = (
+    addsstringcharoptn,  { shorstring + char }
+    addsstringcsstringoptn   { shortstring + constant shortstring }
+  );
+
+  taddoptnode = class(taddnode)
+     subnodetype: tsubnodetype;
+     constructor create(ts: tsubnodetype; l,r : tnode); virtual;
+     { pass_1 will be overridden by the separate subclasses    }
+     { By default, pass_2 is the same as for addnode           }
+     { Only if there's a processor specific implementation, it }
+     { will be overridden.                                     }
+     function getcopy: tnode; override;
+     function docompare(p: tnode): boolean; override;
+  end;
+
+  taddsstringoptnode = class(taddoptnode)
+    { maximum length of the string until now, allows us to skip a compare }
+    { sometimes (it's initialized/updated by calling updatecurmaxlen)     }
+    curmaxlen: byte;
+    { pass_1 must be overridden, otherwise we get an endless loop }
+    function det_resulttype: tnode; override;
+    function pass_1: tnode; override;
+    function getcopy: tnode; override;
+    function docompare(p: tnode): boolean; override;
+   protected
+    procedure updatecurmaxlen;
+  end;
+
+  { add a char to a shortstring }
+  taddsstringcharoptnode = class(taddsstringoptnode)
+    constructor create(l,r : tnode); virtual;
+  end;
+
+  { add a constant string to a short string }
+  taddsstringcsstringoptnode = class(taddsstringoptnode)
+    constructor create(l,r : tnode); virtual;
+  end;
+
+function canbeaddsstringcharoptnode(p: taddnode): boolean;
+function genaddsstringcharoptnode(p: taddnode): tnode;
+function canbeaddsstringcsstringoptnode(p: taddnode): boolean;
+function genaddsstringcsstringoptnode(p: taddnode): tnode;
+
+
+function is_addsstringoptnode(p: tnode): boolean;
+
+var
+{  these are never used directly
+   caddoptnode: class of taddoptnode; }
+   caddsstringcharoptnode: class of taddsstringcharoptnode;
+   caddsstringcsstringoptnode: class of taddsstringcsstringoptnode;
+
+implementation
+
+uses cutils, htypechk, types, globtype, globals, cpubase, pass_1, ncnv, ncon,
+     verbose, symdef, hcodegen;
+
+
+{*****************************************************************************
+                             TADDOPTNODE
+*****************************************************************************}
+
+constructor taddoptnode.create(ts: tsubnodetype; l,r : tnode);
+begin
+  { we need to keep the addn nodetype, otherwise taddnode.pass_2 will be }
+  { confused. Comparison for equal nodetypes therefore has to be         }
+  { implemented using the classtype() method (JM)                        }
+  inherited create(addn,l,r);
+  subnodetype := ts;
+end;
+
+function taddoptnode.getcopy: tnode;
+var
+  hp: taddoptnode;
+begin
+  hp := taddoptnode(inherited getcopy);
+  hp.subnodetype := subnodetype;
+  getcopy := hp;
+end;
+
+function taddoptnode.docompare(p: tnode): boolean;
+begin
+  docompare :=
+    inherited docompare(p) and
+    (subnodetype = taddoptnode(p).subnodetype);
+end;
+
+
+{*****************************************************************************
+                        TADDSSTRINGOPTNODE
+*****************************************************************************}
+
+function taddsstringoptnode.det_resulttype: tnode;
+begin
+  result := nil;
+  updatecurmaxlen;
+  { left and right are already firstpass'ed by taddnode.pass_1 }
+  if not is_shortstring(left.resulttype.def) then
+   inserttypeconv(left,cshortstringtype);
+  if not is_shortstring(right.resulttype.def) then
+   inserttypeconv(right,cshortstringtype);
+  resulttype := left.resulttype;
+end;
+
+function taddsstringoptnode.pass_1: tnode;
+begin
+  pass_1 := nil;
+  location.loc := LOC_MEM;
+  calcregisters(self,0,0,0);
+  { here we call STRCONCAT or STRCMP or STRCOPY }
+  procinfo^.flags:=procinfo^.flags or pi_do_call;
+end;
+
+function taddsstringoptnode.getcopy: tnode;
+var
+  hp: taddsstringoptnode;
+begin
+  hp := taddsstringoptnode(inherited getcopy);
+  hp.curmaxlen := curmaxlen;
+  getcopy := hp;
+end;
+
+function taddsstringoptnode.docompare(p: tnode): boolean;
+begin
+  docompare :=
+    inherited docompare(p) and
+    (curmaxlen = taddsstringcharoptnode(p).curmaxlen);
+end;
+
+
+function is_addsstringoptnode(p: tnode): boolean;
+begin
+  is_addsstringoptnode :=
+    p.inheritsfrom(taddsstringoptnode);
+end;
+
+procedure taddsstringoptnode.updatecurmaxlen;
+begin
+  if is_addsstringoptnode(left) then
+    begin
+      { made it a separate block so no other if's are processed (would be a }
+      { simple waste of time) (JM)                                          }
+      if (taddsstringoptnode(left).curmaxlen < 255) then
+        case subnodetype of
+          addsstringcharoptn:
+            curmaxlen := succ(taddsstringoptnode(left).curmaxlen);
+          addsstringcsstringoptn:
+            curmaxlen := min(taddsstringoptnode(left).curmaxlen +
+                              tstringconstnode(right).len,255)
+          else
+            internalerror(291220001);
+        end
+      else curmaxlen := 255;
+    end
+  else if (left.nodetype = stringconstn) then
+    curmaxlen := min(tstringconstnode(left).len,255)
+  else if is_char(left.resulttype.def) then
+    curmaxlen := 1
+  else if (left.nodetype = typeconvn) then
+    begin
+      case ttypeconvnode(left).convtype of
+        tc_char_2_string:
+          curmaxlen := 1;
+{       doesn't work yet, don't know why (JM)
+        tc_chararray_2_string:
+          curmaxlen :=
+            min(ttypeconvnode(left).left.resulttype.def^.size,255); }
+        else curmaxlen := 255;
+      end;
+    end
+  else
+    curmaxlen := 255;
+end;
+
+{*****************************************************************************
+                        TADDSSTRINGCHAROPTNODE
+*****************************************************************************}
+
+
+constructor taddsstringcharoptnode.create(l,r : tnode);
+begin
+  inherited create(addsstringcharoptn,l,r);
+end;
+
+{*****************************************************************************
+                        TADDSSTRINGCSSTRINGOPTNODE
+*****************************************************************************}
+
+
+constructor taddsstringcsstringoptnode.create(l,r : tnode);
+begin
+  inherited create(addsstringcsstringoptn,l,r);
+end;
+
+{*****************************************************************************
+                                HELPERS
+*****************************************************************************}
+
+function canbeaddsstringcharoptnode(p: taddnode): boolean;
+begin
+  canbeaddsstringcharoptnode :=
+    (cs_optimize in aktglobalswitches) and
+
+{   the shortstring will be gotten through conversion if necessary (JM)
+    is_shortstring(p.left.resulttype.def) and }
+    ((p.nodetype = addn) and
+     is_char(p.right.resulttype.def));
+end;
+
+function genaddsstringcharoptnode(p: taddnode): tnode;
+var
+  hp: tnode;
+begin
+  hp := caddsstringcharoptnode.create(p.left.getcopy,p.right.getcopy);
+  hp.flags := p.flags;
+  genaddsstringcharoptnode := hp;
+end;
+
+
+
+function canbeaddsstringcsstringoptnode(p: taddnode): boolean;
+begin
+  canbeaddsstringcsstringoptnode :=
+    (cs_optimize in aktglobalswitches) and
+
+{   the shortstring will be gotten through conversion if necessary (JM)
+    is_shortstring(p.left.resulttype.def) and }
+    ((p.nodetype = addn) and
+     (p.right.nodetype = stringconstn));
+end;
+
+function genaddsstringcsstringoptnode(p: taddnode): tnode;
+var
+  hp: tnode;
+begin
+  hp := caddsstringcsstringoptnode.create(p.left.getcopy,p.right.getcopy);
+  hp.flags := p.flags;
+  genaddsstringcsstringoptnode := hp;
+end;
+
+
+begin
+  caddsstringcharoptnode := taddsstringcharoptnode;
+  caddsstringcsstringoptnode := taddsstringcsstringoptnode;
+end.
+
+{
   $Log$
-  Revision 1.1  2001-01-04 11:24:19  jonas
+  Revision 1.2  2001-04-02 21:20:31  peter
+    * resulttype rewrite
+
+  Revision 1.1  2001/01/04 11:24:19  jonas
     + initial implementation (still needs to be made more modular)
-
-}
+
+}

compiler/nset.pas

@@ -51,16 +51,19 @@ interface
 
        tsetelementnode = class(tbinarynode)
           constructor create(l,r : tnode);virtual;
+          function det_resulttype:tnode;override;
           function pass_1 : tnode;override;
        end;
 
        tinnode = class(tbinopnode)
           constructor create(l,r : tnode);virtual;
+          function det_resulttype:tnode;override;
           function pass_1 : tnode;override;
        end;
 
        trangenode = class(tbinarynode)
           constructor create(l,r : tnode);virtual;
+          function det_resulttype:tnode;override;
           function pass_1 : tnode;override;
        end;
 
@@ -71,6 +74,7 @@ interface
           destructor destroy;override;
           function getcopy : tnode;override;
           procedure insertintolist(l : tnodelist);override;
+          function det_resulttype:tnode;override;
           function pass_1 : tnode;override;
           function docompare(p: tnode): boolean; override;
        end;
@@ -131,24 +135,32 @@ implementation
          inherited create(setelementn,l,r);
       end;
 
-    function tsetelementnode.pass_1 : tnode;
 
+    function tsetelementnode.det_resulttype:tnode;
       begin
-         pass_1:=nil;
-         firstpass(left);
+         result:=nil;
+         resulttypepass(left);
+         if assigned(right) then
+          resulttypepass(right);
          set_varstate(left,true);
          if codegenerror then
           exit;
 
+         resulttype:=left.resulttype;
+      end;
+
+
+    function tsetelementnode.pass_1 : tnode;
+
+      begin
+         result:=nil;
+         firstpass(left);
          if assigned(right) then
-          begin
-            firstpass(right);
-            if codegenerror then
-             exit;
-          end;
+          firstpass(right);
+         if codegenerror then
+          exit;
 
          calcregisters(self,0,0,0);
-         resulttype:=left.resulttype;
          set_location(location,left.location);
       end;
 
@@ -158,58 +170,54 @@ implementation
 *****************************************************************************}
 
     constructor tinnode.create(l,r : tnode);
-
       begin
          inherited create(inn,l,r);
       end;
 
-    function tinnode.pass_1 : tnode;
-      type
-        byteset = set of byte;
+
+    function tinnode.det_resulttype:tnode;
       var
         t : tnode;
         pst : pconstset;
 
-    function createsetconst(psd : psetdef) : pconstset;
-      var
-        pcs : pconstset;
-        pes : penumsym;
-        i : longint;
-      begin
-        new(pcs);
-        case psd^.elementtype.def^.deftype of
-          enumdef :
-            begin
-              pes:=penumsym(penumdef(psd^.elementtype.def)^.firstenum);
-              while assigned(pes) do
-                begin
-                  pcs^[pes^.value div 8]:=pcs^[pes^.value div 8] or (1 shl (pes^.value mod 8));
-                  pes:=pes^.nextenum;
-                end;
-            end;
-          orddef :
-            begin
-              for i:=porddef(psd^.elementtype.def)^.low to porddef(psd^.elementtype.def)^.high do
-                begin
-                  pcs^[i div 8]:=pcs^[i div 8] or (1 shl (i mod 8));
-                end;
-            end;
+        function createsetconst(psd : psetdef) : pconstset;
+        var
+          pcs : pconstset;
+          pes : penumsym;
+          i : longint;
+        begin
+          new(pcs);
+          case psd^.elementtype.def^.deftype of
+            enumdef :
+              begin
+                pes:=penumsym(penumdef(psd^.elementtype.def)^.firstenum);
+                while assigned(pes) do
+                  begin
+                    pcs^[pes^.value div 8]:=pcs^[pes^.value div 8] or (1 shl (pes^.value mod 8));
+                    pes:=pes^.nextenum;
+                  end;
+              end;
+            orddef :
+              begin
+                for i:=porddef(psd^.elementtype.def)^.low to porddef(psd^.elementtype.def)^.high do
+                  begin
+                    pcs^[i div 8]:=pcs^[i div 8] or (1 shl (i mod 8));
+                  end;
+              end;
+          end;
+          createsetconst:=pcs;
         end;
-       createsetconst:=pcs;
-      end;
 
       begin
-         pass_1:=nil;
-         location.loc:=LOC_FLAGS;
-         resulttype:=booldef;
-
-         firstpass(right);
+         result:=nil;
+         resulttype:=booltype;
+         resulttypepass(right);
          set_varstate(right,true);
          if codegenerror then
           exit;
 
          { Convert array constructor first to set }
-         if is_array_constructor(right.resulttype) then
+         if is_array_constructor(right.resulttype.def) then
           begin
             arrayconstructor_to_set(tarrayconstructornode(right));
             firstpass(right);
@@ -217,59 +225,66 @@ implementation
              exit;
           end;
 
-         { if right is a typen then the def
-         is in typenodetype PM }
-         if right.nodetype=typen then
-           right.resulttype:=ttypenode(right).typenodetype;
-
-         if right.resulttype^.deftype<>setdef then
+         if right.resulttype.def^.deftype<>setdef then
            CGMessage(sym_e_set_expected);
-         if codegenerror then
-           exit;
 
          if (right.nodetype=typen) then
            begin
              { we need to create a setconstn }
-             pst:=createsetconst(psetdef(ttypenode(right).typenodetype));
-             t:=gensetconstnode(pst,psetdef(ttypenode(right).typenodetype));
+             pst:=createsetconst(psetdef(ttypenode(right).resulttype.def));
+             t:=csetconstnode.create(pst,ttypenode(right).resulttype);
              dispose(pst);
              right.free;
              right:=t;
            end;
 
-         firstpass(left);
+         resulttypepass(left);
          set_varstate(left,true);
          if codegenerror then
            exit;
 
+         { type conversion/check }
+         if assigned(psetdef(right.resulttype.def)^.elementtype.def) then
+          inserttypeconv(left,psetdef(right.resulttype.def)^.elementtype);
+      end;
+
+
+    function tinnode.pass_1 : tnode;
+      type
+        byteset = set of byte;
+      var
+        t : tnode;
+      begin
+         result:=nil;
+         location.loc:=LOC_FLAGS;
+
+         firstpass(right);
+         firstpass(left);
+         if codegenerror then
+           exit;
+
          { empty set then return false }
-         if not assigned(psetdef(right.resulttype)^.elementtype.def) then
+         if not assigned(psetdef(right.resulttype.def)^.elementtype.def) then
           begin
-            t:=genordinalconstnode(0,booldef);
+            t:=cordconstnode.create(0,booltype);
             firstpass(t);
-            pass_1:=t;
+            result:=t;
             exit;
           end;
 
-         { type conversion/check }
-         left:=gentypeconvnode(left,psetdef(right.resulttype)^.elementtype.def);
-         firstpass(left);
-         if codegenerror then
-           exit;
-
          { constant evaulation }
          if (left.nodetype=ordconstn) and (right.nodetype=setconstn) then
           begin
-            t:=genordinalconstnode(byte(tordconstnode(left).value in byteset(tsetconstnode(right).value_set^)),booldef);
+            t:=cordconstnode.create(byte(tordconstnode(left).value in byteset(tsetconstnode(right).value_set^)),booltype);
             firstpass(t);
-            pass_1:=t;
+            result:=t;
             exit;
           end;
 
          left_right_max;
          { this is not allways true due to optimization }
          { but if we don't set this we get problems with optimizing self code }
-         if psetdef(right.resulttype)^.settype<>smallset then
+         if psetdef(right.resulttype.def)^.settype<>smallset then
            procinfo^.flags:=procinfo^.flags or pi_do_call
          else
            begin
@@ -292,32 +307,42 @@ implementation
          inherited create(rangen,l,r);
       end;
 
-    function trangenode.pass_1 : tnode;
+
+    function trangenode.det_resulttype : tnode;
       var
          ct : tconverttype;
       begin
-         pass_1:=nil;
-         firstpass(left);
+         result:=nil;
+         resulttypepass(left);
+         resulttypepass(right);
          set_varstate(left,true);
-         firstpass(right);
          set_varstate(right,true);
          if codegenerror then
            exit;
          { both types must be compatible }
-         if not(is_equal(left.resulttype,right.resulttype)) and
-            (isconvertable(left.resulttype,right.resulttype,ct,nil,ordconstn,false)=0) then
+         if not(is_equal(left.resulttype.def,right.resulttype.def)) and
+            (isconvertable(left.resulttype.def,right.resulttype.def,ct,ordconstn,false)=0) then
            CGMessage(type_e_mismatch);
          { Check if only when its a constant set }
          if (left.nodetype=ordconstn) and (right.nodetype=ordconstn) then
           begin
-          { upper limit must be greater or equal than lower limit }
-          { not if u32bit }
+            { upper limit must be greater or equal than lower limit }
             if (tordconstnode(left).value>tordconstnode(right).value) and
                ((tordconstnode(left).value<0) or (tordconstnode(right).value>=0)) then
               CGMessage(cg_e_upper_lower_than_lower);
           end;
-        left_right_max;
         resulttype:=left.resulttype;
+      end;
+
+
+    function trangenode.pass_1 : tnode;
+      begin
+         result:=nil;
+         firstpass(left);
+         firstpass(right);
+         if codegenerror then
+           exit;
+        left_right_max;
         set_location(location,left.location);
       end;
 
@@ -405,7 +430,6 @@ implementation
 *****************************************************************************}
 
     constructor tcasenode.create(l,r : tnode;n : pcaserecord);
-
       begin
          inherited create(casen,l,r);
          nodes:=n;
@@ -413,20 +437,29 @@ implementation
          set_file_line(l);
       end;
 
-    destructor tcasenode.destroy;
 
+    destructor tcasenode.destroy;
       begin
          elseblock.free;
          deletecaselabels(nodes);
          inherited destroy;
       end;
 
+
+    function tcasenode.det_resulttype : tnode;
+      begin
+        result:=nil;
+        resulttype:=voidtype;
+      end;
+
+
+
     function tcasenode.pass_1 : tnode;
       var
          old_t_times : longint;
          hp : tbinarynode;
       begin
-         pass_1:=nil;
+         result:=nil;
          { evalutes the case expression }
 {$ifdef newcg}
          tg.cleartempgen;
@@ -505,6 +538,7 @@ implementation
          if registers32<1 then registers32:=1;
       end;
 
+
     function tcasenode.getcopy : tnode;
 
       var
@@ -526,16 +560,16 @@ implementation
       end;
 
     function casenodesequal(n1,n2: pcaserecord): boolean;
-    begin
-      casenodesequal :=
-        (not assigned(n1) and not assigned(n2)) or
-        (assigned(n1) and assigned(n2) and
-         (n1^._low = n2^._low) and
-         (n1^._high = n2^._high) and
-         { the rest of the fields don't matter for equality (JM) }
-         casenodesequal(n1^.less,n2^.less) and
-         casenodesequal(n1^.greater,n2^.greater))
-    end;
+      begin
+        casenodesequal :=
+          (not assigned(n1) and not assigned(n2)) or
+          (assigned(n1) and assigned(n2) and
+           (n1^._low = n2^._low) and
+           (n1^._high = n2^._high) and
+           { the rest of the fields don't matter for equality (JM) }
+           casenodesequal(n1^.less,n2^.less) and
+           casenodesequal(n1^.greater,n2^.greater))
+      end;
 
 
     function tcasenode.docompare(p: tnode): boolean;
@@ -554,7 +588,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.11  2000-12-31 11:14:11  jonas
+  Revision 1.12  2001-04-02 21:20:31  peter
+    * resulttype rewrite
+
+  Revision 1.11  2000/12/31 11:14:11  jonas
     + implemented/fixed docompare() mathods for all nodes (not tested)
     + nopt.pas, nadd.pas, i386/n386opt.pas: optimized nodes for adding strings
       and constant strings/chars together

compiler/ogcoff.pas

@@ -877,17 +877,11 @@ implementation
 
     procedure tcoffobjectinput.handle_symbols;
       var
-        filename  : string[18];
         sec       : tsection;
-        sectionval,
         i,nsyms,
         symidx    : longint;
-        globalval : byte;
-        secrec    : coffsectionrec;
-        sym,
-        sym2      : coffsymbol;
-        strname,
-        strname2  : string;
+        sym       : coffsymbol;
+        strname   : string;
         p         : pasmsymbol;
         auxrec    : array[0..17] of byte;
       begin
@@ -984,18 +978,11 @@ implementation
 
     procedure tcoffobjectinput.readfromdisk;
       var
-        datapos,
-        secsymidx,
-        nsects,
         strsize,
-        sympos,i : longint;
-        hstab    : coffstab;
-        gotreloc : boolean;
+        i        : longint;
         sec      : tsection;
         header   : coffheader;
         sechdr   : coffsechdr;
-        empty    : array[0..15] of byte;
-        hp       : pdynamicblock;
       begin
         with tcoffdata(data) do
          begin
@@ -1101,7 +1088,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.10  2001-03-13 18:45:07  peter
+  Revision 1.11  2001-04-02 21:20:31  peter
+    * resulttype rewrite
+
+  Revision 1.10  2001/03/13 18:45:07  peter
     * fixed some memory leaks
 
   Revision 1.9  2001/03/05 21:40:38  peter

compiler/pass_1.pas

@@ -29,6 +29,13 @@ interface
     uses
        node;
 
+    var
+      resulttypepasscnt,
+      multiresulttypepasscnt : longint;
+
+    procedure resulttypepass(var p : tnode);
+    function  do_resulttypepass(var p : tnode) : boolean;
+
     procedure firstpass(var p : tnode);
     function  do_firstpass(var p : tnode) : boolean;
 
@@ -40,8 +47,8 @@ implementation
 
     uses
       globtype,systems,
-      cutils,cobjects,globals,
-      hcodegen,
+      cutils,cobjects,globals,verbose,
+      hcodegen,symdef,
 {$ifdef extdebug}
       htypechk,
 {$endif extdebug}
@@ -55,20 +62,65 @@ implementation
                             Global procedures
 *****************************************************************************}
 
-    procedure firstpass(var p : tnode);
+    procedure resulttypepass(var p : tnode);
+      var
+         oldcodegenerror  : boolean;
+         oldlocalswitches : tlocalswitches;
+         oldpos    : tfileposinfo;
+         hp        : tnode;
+      begin
+        inc(resulttypepasscnt);
+        if (p.resulttype.def=nil) then
+         begin
+           oldcodegenerror:=codegenerror;
+           oldpos:=aktfilepos;
+           oldlocalswitches:=aktlocalswitches;
+           codegenerror:=false;
+           aktfilepos:=p.fileinfo;
+           aktlocalswitches:=p.localswitches;
+           hp:=p.det_resulttype;
+//writeln('result: ',nodetype2str[p.nodetype],' ',dword(hp));
+           { should the node be replaced? }
+           if assigned(hp) then
+            begin
+               p.free;
+               p:=hp;
+            end;
+{$ifdef EXTDEBUG}
+           { save resulttype for checking of changes in pass_1 }
+           p.oldresulttype:=p.resulttype;
+{$endif EXTDEBUG}
+           aktlocalswitches:=oldlocalswitches;
+           aktfilepos:=oldpos;
+           if codegenerror then
+            begin
+              include(p.flags,nf_error);
+              { default to errortype if no type is set yet }
+              if p.resulttype.def=nil then
+               p.resulttype:=generrortype;
+            end;
+           codegenerror:=codegenerror or oldcodegenerror;
+         end
+        else
+         inc(multiresulttypepasscnt);
+      end;
+
+
+    function do_resulttypepass(var p : tnode) : boolean;
+      begin
+         aktexceptblock:=nil;
+         codegenerror:=false;
+         resulttypepass(p);
+         do_resulttypepass:=codegenerror;
+      end;
 
+
+    procedure firstpass(var p : tnode);
       var
          oldcodegenerror  : boolean;
          oldlocalswitches : tlocalswitches;
          oldpos    : tfileposinfo;
          hp : tnode;
-{$ifdef extdebug}
-   {$ifdef dummy}
-         str1,str2 : string;
-         oldp      : tnode;
-   {$endif}
-         not_first : boolean;
-{$endif extdebug}
       begin
 {$ifdef extdebug}
          inc(total_of_firstpass);
@@ -80,25 +132,29 @@ implementation
          oldlocalswitches:=aktlocalswitches;
 {$ifdef extdebug}
          if p.firstpasscount>0 then
-           begin
-    {$ifdef dummy}
-              move(p^,str1[1],sizeof(ttree));
-              str1[0]:=char(sizeof(ttree));
-              new(oldp);
-              old^:=p^;
-    {$endif}
-              not_first:=true;
-              inc(firstpass_several);
-           end
-         else
-           not_first:=false;
+          inc(firstpass_several);
 {$endif extdebug}
-
          if not(nf_error in p.flags) then
            begin
               codegenerror:=false;
               aktfilepos:=p.fileinfo;
               aktlocalswitches:=p.localswitches;
+              { determine the resulttype if not done }
+              if (p.resulttype.def=nil) then
+               begin
+                 hp:=p.det_resulttype;
+                 { should the node be replaced? }
+                 if assigned(hp) then
+                  begin
+                     p.free;
+                     p:=hp;
+                  end;
+{$ifdef EXTDEBUG}
+                 { save resulttype for checking of changes in pass_1 }
+                 p.oldresulttype:=p.resulttype;
+{$endif EXTDEBUG}
+               end;
+              { first pass }
               hp:=p.pass_1;
               { should the node be replaced? }
               if assigned(hp) then
@@ -106,6 +162,12 @@ implementation
                    p.free;
                    p:=hp;
                 end;
+{$ifdef EXTDEBUG}
+              { check if the resulttype is still the same }
+              if (p.oldresulttype.def<>p.resulttype.def) and
+                 (p.oldresulttype.sym<>p.resulttype.sym) then
+               Comment(V_Warning,'Resulttype change in '+nodetype2str[p.nodetype]+'.pass_1');
+{$endif EXTDEBUG}
               aktlocalswitches:=oldlocalswitches;
               aktfilepos:=oldpos;
               if codegenerror then
@@ -115,21 +177,6 @@ implementation
          else
            codegenerror:=true;
 {$ifdef extdebug}
-         if not_first then
-           begin
-    {$ifdef dummy}
-              { dirty trick to compare two ttree's (PM) }
-              move(p^,str2[1],sizeof(ttree));
-              str2[0]:=char(sizeof(ttree));
-              if str1<>str2 then
-                begin
-                   comment(v_debug,'tree changed after first counting pass '
-                     +tostr(longint(p.treetype)));
-                   compare_trees(oldp,p);
-                end;
-              dispose(oldp);
-    {$endif dummy}
-           end;
          if count_ref then
            inc(p.firstpasscount);
 {$endif extdebug}
@@ -147,7 +194,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.11  2000-12-18 21:56:52  peter
+  Revision 1.12  2001-04-02 21:20:31  peter
+    * resulttype rewrite
+
+  Revision 1.11  2000/12/18 21:56:52  peter
     * extdebug fixes
 
   Revision 1.10  2000/11/29 00:30:35  florian

compiler/pass_2.pas

@@ -47,6 +47,9 @@ procedure secondpass(var p : tnode);
 implementation
 
    uses
+{$ifdef logsecondpass}
+     cutils,
+{$endif}
      globtype,systems,
      cobjects,globals,
      symconst,symbase,symtype,symsym,aasm,
@@ -57,21 +60,11 @@ implementation
 *****************************************************************************}
 
 {$ifdef logsecondpass}
-     procedure logsecond(const s: string; entry: boolean);
-     var p: pchar;
-     begin
-       if entry then
-         p := strpnew(s+' (entry)')
-       else p := strpnew(s+' (exit)');
-       exprasmlist^.concat(new(pai_asm_comment,init(p)));
-     end;
-{$endif logsecondpass}
-
-     procedure secondpass(var p : tnode);
-{$ifdef logsecondpass}
-      secondnames: array[ttreetyp] of string[13] =
+     procedure logsecond(ht:tnodetype; entry: boolean);
+       const
+         secondnames: array[tnodetype] of string[13] =
             ('add-addn',  {addn}
-             'add-muln)',  {muln}
+             'add-muln',  {muln}
              'add-subn',  {subn}
              'moddiv-divn',      {divn}
              'add-symdifn',      {symdifn}
@@ -151,8 +144,18 @@ implementation
              'nothing-nothg',     {nothingn}
              'loadvmt'      {loadvmtn}
              );
-
+      var
+        p: pchar;
+      begin
+        if entry then
+          p := strpnew('second'+secondnames[ht]+' (entry)')
+        else
+          p := strpnew('second'+secondnames[ht]+' (exit)');
+        exprasmlist.concat(tai_asm_comment.create(p));
+      end;
 {$endif logsecondpass}
+
+     procedure secondpass(var p : tnode);
       var
          oldcodegenerror  : boolean;
          oldlocalswitches : tlocalswitches;
@@ -176,11 +179,11 @@ implementation
             aktlocalswitches:=p.localswitches;
             codegenerror:=false;
 {$ifdef logsecondpass}
-            logsecond('second'+secondnames[p.nodetype],true);
+            logsecond(p.nodetype,true);
 {$endif logsecondpass}
             p.pass_2;
 {$ifdef logsecondpass}
-            logsecond('second'+secondnames[p.nodetype],false);
+            logsecond(p.nodetype,false);
 {$endif logsecondpass}
             if codegenerror then
               include(p.flags,nf_error);
@@ -301,7 +304,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.12  2000-12-25 00:07:27  peter
+  Revision 1.13  2001-04-02 21:20:31  peter
+    * resulttype rewrite
+
+  Revision 1.12  2000/12/25 00:07:27  peter
     + new tlinkedlist class (merge of old tstringqueue,tcontainer and
       tlinkedlist objects)
 

compiler/pbase.pas

@@ -276,7 +276,7 @@ implementation
         { if nothing found give error and return errorsym }
         if srsym=nil then
          begin
-           identifier_not_found(pattern);
+           identifier_not_found(orgpattern);
            srsym:=generrorsym;
            srsymtable:=nil;
          end;
@@ -322,7 +322,10 @@ end.
 
 {
   $Log$
-  Revision 1.8  2001-03-11 22:58:49  peter
+  Revision 1.9  2001-04-02 21:20:31  peter
+    * resulttype rewrite
+
+  Revision 1.8  2001/03/11 22:58:49  peter
     * getsym redesign, removed the globals srsym,srsymtable
 
   Revision 1.7  2000/12/25 00:07:27  peter

compiler/pdecl.pas

@@ -86,16 +86,15 @@ implementation
            ordconstn:
              begin
                 if is_constintnode(p) then
-                  hp:=new(pconstsym,init_def(name,constint,tordconstnode(p).value,
-                                               tordconstnode(p).resulttype))
+                  hp:=new(pconstsym,init_typed(name,constint,tordconstnode(p).value,tordconstnode(p).resulttype))
                 else if is_constcharnode(p) then
-                  hp:=new(pconstsym,init_def(name,constchar,tordconstnode(p).value,nil))
+                  hp:=new(pconstsym,init(name,constchar,tordconstnode(p).value))
                 else if is_constboolnode(p) then
-                  hp:=new(pconstsym,init_def(name,constbool,tordconstnode(p).value,nil))
-                else if p.resulttype^.deftype=enumdef then
-                  hp:=new(pconstsym,init_def(name,constord,tordconstnode(p).value,p.resulttype))
-                else if p.resulttype^.deftype=pointerdef then
-                  hp:=new(pconstsym,init_def(name,constord,tordconstnode(p).value,p.resulttype))
+                  hp:=new(pconstsym,init(name,constbool,tordconstnode(p).value))
+                else if p.resulttype.def^.deftype=enumdef then
+                  hp:=new(pconstsym,init_typed(name,constord,tordconstnode(p).value,p.resulttype))
+                else if p.resulttype.def^.deftype=pointerdef then
+                  hp:=new(pconstsym,init_typed(name,constord,tordconstnode(p).value,p.resulttype))
                 else internalerror(111);
              end;
            stringconstn:
@@ -114,15 +113,15 @@ implementation
              begin
                new(ps);
                ps^:=tsetconstnode(p).value_set^;
-               hp:=new(pconstsym,init_def(name,constset,longint(ps),p.resulttype));
+               hp:=new(pconstsym,init_typed(name,constset,longint(ps),p.resulttype));
              end;
            pointerconstn :
              begin
-               hp:=new(pconstsym,init_def(name,constpointer,tordconstnode(p).value,p.resulttype));
+               hp:=new(pconstsym,init_typed(name,constpointer,tordconstnode(p).value,p.resulttype));
              end;
            niln :
              begin
-               hp:=new(pconstsym,init_def(name,constnil,0,p.resulttype));
+               hp:=new(pconstsym,init_typed(name,constnil,0,p.resulttype));
              end;
            else
              Message(cg_e_illegal_expression);
@@ -217,10 +216,10 @@ implementation
                       consume(_EQUAL);
 {$ifdef DELPHI_CONST_IN_RODATA}
                       if m_delphi in aktmodeswitches then
-                       readtypedconst(tt.def,ptypedconstsym(sym),true)
+                       readtypedconst(tt,ptypedconstsym(sym),true)
                       else
 {$endif DELPHI_CONST_IN_RODATA}
-                       readtypedconst(tt.def,ptypedconstsym(sym),false);
+                       readtypedconst(tt,ptypedconstsym(sym),false);
                       consume(_SEMICOLON);
                     end;
                 end;
@@ -338,7 +337,7 @@ implementation
                      begin
                        MessagePos1(psym(p)^.fileinfo,sym_e_forward_type_not_resolved,psym(p)^.realname);
                        { try to recover }
-                       ppointerdef(pd)^.pointertype.def:=generrordef;
+                       ppointerdef(pd)^.pointertype:=generrortype;
                      end;
                   end;
                end;
@@ -417,7 +416,7 @@ implementation
               { insert the new type first with an errordef, so that
                 referencing the type before it's really set it
                 will give an error (PFV) }
-              tt.setdef(generrordef);
+              tt:=generrortype;
               storetokenpos:=akttokenpos;
               newtype:=new(ptypesym,init(orgtypename,tt));
               symtablestack^.insert(newtype);
@@ -546,7 +545,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.25  2001-03-11 22:58:49  peter
+  Revision 1.26  2001-04-02 21:20:31  peter
+    * resulttype rewrite
+
+  Revision 1.25  2001/03/11 22:58:49  peter
     * getsym redesign, removed the globals srsym,srsymtable
 
   Revision 1.24  2000/12/25 00:07:27  peter
@@ -562,7 +564,7 @@ end.
     * added lots of longint typecast to prevent range check errors in the
       compiler and rtl
     * type casts of symbolic ordinal constants are now preserved
-    * fixed bug where the original resulttype wasn't restored correctly
+    * fixed bug where the original resulttype.def wasn't restored correctly
       after doing a 64bit rangecheck
 
   Revision 1.22  2000/11/29 00:30:35  florian

compiler/pdecobj.pas

@@ -78,7 +78,7 @@ implementation
                 else
                   begin
                      { OBJECT constructors return a boolean }
-                     aktprocsym^.definition^.rettype.setdef(booldef);
+                     aktprocsym^.definition^.rettype:=booltype;
                   end;
              end;
         end;
@@ -180,7 +180,7 @@ implementation
                                  consume(_ARRAY);
                                  consume(_OF);
                                  { define range and type of range }
-                                 tt.setdef(new(parraydef,init(0,-1,s32bitdef)));
+                                 tt.setdef(new(parraydef,init(0,-1,s32bittype)));
                                  { define field type }
                                  single_type(parraydef(tt.def)^.elementtype,s,false);
                               end
@@ -188,7 +188,7 @@ implementation
                               single_type(tt,s,false);
                          end
                        else
-                         tt.setdef(cformaldef);
+                         tt:=cformaltype;
                        repeat
                          s:=sc.get(declarepos);
                          if s='' then
@@ -218,15 +218,15 @@ implementation
                           consume(_INDEX);
                           pt:=comp_expr(true);
                           do_firstpass(pt);
-                          if is_ordinal(pt.resulttype) and
-                             (not is_64bitint(pt.resulttype)) then
+                          if is_ordinal(pt.resulttype.def) and
+                             (not is_64bitint(pt.resulttype.def)) then
                             p^.index:=tordconstnode(pt).value
                           else
                             begin
                               Message(parser_e_invalid_property_index_value);
                               p^.index:=0;
                             end;
-                          p^.indextype.setdef(pt.resulttype);
+                          p^.indextype.setdef(pt.resulttype.def);
                           include(p^.propoptions,ppo_indexed);
                           { concat a longint to the para template }
                           hp2:=TParaItem.Create;
@@ -249,7 +249,7 @@ implementation
                        end
                      else
                        begin
-                         p^.proptype.setdef(generrordef);
+                         p^.proptype:=generrortype;
                          message(parser_e_no_property_found_to_override);
                        end;
                   end;
@@ -416,14 +416,14 @@ implementation
                                              end;
                                            { found we a procedure and does it really return a bool? }
                                            if not(assigned(pp)) or
-                                              not(is_equal(pp^.rettype.def,booldef)) then
+                                              not(is_boolean(pp^.rettype.def)) then
                                              Message(parser_e_ill_property_storage_sym);
                                            p^.storedaccess^.setdef(pp);
                                          end;
                                        varsym :
                                          begin
                                            if not(propertyparas.empty) or
-                                              not(is_equal(pvarsym(sym)^.vartype.def,booldef)) then
+                                              not(is_boolean(pvarsym(sym)^.vartype.def)) then
                                              Message(parser_e_stored_property_must_be_boolean);
                                          end;
                                        else
@@ -460,7 +460,7 @@ implementation
                          arrayconstructor_to_set(tarrayconstructornode(pt));
                          do_firstpass(pt);
                        end;
-                     pt:=gentypeconvnode(pt,p^.proptype.def);
+                     pt:=ctypeconvnode.create(pt,p^.proptype);
                      do_firstpass(pt);
                      if not(is_constnode(pt)) then
                        Message(parser_e_property_default_value_must_const);
@@ -523,7 +523,7 @@ implementation
              if not (m_tp in aktmodeswitches) then
                Message(parser_e_no_paras_for_destructor);
            { no return value }
-           aktprocsym^.definition^.rettype.def:=voiddef;
+           aktprocsym^.definition^.rettype:=voidtype;
         end;
 
       var
@@ -787,13 +787,13 @@ implementation
                         if (tt.def^.deftype=forwarddef) or
                            is_class(tt.def) then
                           begin
-                             pcrd:=new(pclassrefdef,init(tt.def));
+                             pcrd:=new(pclassrefdef,init(tt));
                              object_dec:=pcrd;
                           end
                         else
                           begin
-                             object_dec:=generrordef;
-                             Message1(type_e_class_type_expected,generrordef^.typename);
+                             object_dec:=generrortype.def;
+                             Message1(type_e_class_type_expected,generrortype.def^.typename);
                           end;
                         typecanbeforward:=storetypecanbeforward;
                         readobjecttype:=false;
@@ -1165,7 +1165,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.17  2001-03-16 14:56:38  marco
+  Revision 1.18  2001-04-02 21:20:31  peter
+    * resulttype rewrite
+
+  Revision 1.17  2001/03/16 14:56:38  marco
    * Pavel's fixes commited (Peter asked). Cycled to test
 
   Revision 1.16  2001/03/11 22:58:49  peter

compiler/pdecsub.pas

@@ -96,6 +96,7 @@ implementation
         s       : string;
         hpos,
         storetokenpos : tfileposinfo;
+        htype,
         tt      : ttype;
         hvs,
         vs      : Pvarsym;
@@ -143,7 +144,8 @@ implementation
 {$else UseNiceNames}
                  hs2:=hs2+tostr(length('self'))+'self';
 {$endif UseNiceNames}
-                 vs:=new(Pvarsym,initdef('@',procinfo^._class));
+                 htype.setdef(procinfo^._class);
+                 vs:=new(Pvarsym,init('@',htype));
                  vs^.varspez:=vs_var;
                { insert the sym in the parasymtable }
                  pprocdef(aktprocdef)^.parast^.insert(vs);
@@ -175,7 +177,7 @@ implementation
                      consume(_ARRAY);
                      consume(_OF);
                    { define range and type of range }
-                     tt.setdef(new(Parraydef,init(0,-1,s32bitdef)));
+                     tt.setdef(new(Parraydef,init(0,-1,s32bittype)));
                    { array of const ? }
                      if (token=_CONST) and (m_objpas in aktmodeswitches) then
                       begin
@@ -208,7 +210,7 @@ implementation
                              (idtoken=_OPENSTRING)) then
                       begin
                         consume(token);
-                        tt.setdef(openshortstringdef);
+                        tt:=openshortstringtype;
                         hs1:='openstring';
                         inserthigh:=true;
                       end
@@ -247,7 +249,7 @@ implementation
 {$else UseNiceNames}
                   hs1:='var';
 {$endif UseNiceNames}
-                  tt.setdef(cformaldef);
+                  tt:=cformaltype;
                 end;
                if not is_procvar then
                 hs2:=pprocdef(aktprocdef)^.mangledname;
@@ -287,7 +289,7 @@ implementation
                    { also need to push a high value? }
                      if inserthigh then
                       begin
-                        hvs:=new(Pvarsym,initdef('$high'+Upper(s),s32bitdef));
+                        hvs:=new(Pvarsym,init('$high'+Upper(s),s32bittype));
                         hvs^.varspez:=vs_const;
                         pprocdef(aktprocdef)^.parast^.insert(hvs);
                       end;
@@ -662,7 +664,7 @@ begin
     _PROCEDURE : begin
                    consume(_PROCEDURE);
                    parse_proc_head(potype_none);
-                   aktprocsym^.definition^.rettype.def:=voiddef;
+                   aktprocsym^.definition^.rettype:=voidtype;
                  end;
   _CONSTRUCTOR : begin
                    consume(_CONSTRUCTOR);
@@ -671,23 +673,18 @@ begin
                       is_class(procinfo^._class) then
                     begin
                       { CLASS constructors return the created instance }
-                      aktprocsym^.definition^.rettype.def:=procinfo^._class;
+                      aktprocsym^.definition^.rettype.setdef(procinfo^._class);
                     end
                    else
                     begin
                       { OBJECT constructors return a boolean }
-{$IfDef GDB}
-                      { GDB doesn't like unnamed types !}
-                      aktprocsym^.definition^.rettype.def:=globaldef('boolean');
-{$else GDB}
-                      aktprocsym^.definition^.rettype.def:=new(porddef,init(bool8bit,0,1));
-{$Endif GDB}
+                      aktprocsym^.definition^.rettype:=booltype;
                     end;
                  end;
    _DESTRUCTOR : begin
                    consume(_DESTRUCTOR);
                    parse_proc_head(potype_destructor);
-                   aktprocsym^.definition^.rettype.def:=voiddef;
+                   aktprocsym^.definition^.rettype:=voidtype;
                  end;
      _OPERATOR : begin
                    if lexlevel>normal_function_level then
@@ -715,13 +712,13 @@ begin
                      end
                    else
                      begin
-                       opsym:=new(pvarsym,initdef(pattern,voiddef));
+                       opsym:=new(pvarsym,init(pattern,voidtype));
                        consume(_ID);
                      end;
                    if not try_to_consume(_COLON) then
                      begin
                        consume(_COLON);
-                       aktprocsym^.definition^.rettype.def:=generrordef;
+                       aktprocsym^.definition^.rettype:=generrortype;
                        consume_all_until(_SEMICOLON);
                      end
                    else
@@ -1870,7 +1867,7 @@ begin
         s:=Copy(name,4,255);
         if not(po_assembler in aktprocsym^.definition^.procoptions) then
          begin
-           vs:=new(Pvarsym,initdef(s,vartype.def));
+           vs:=new(Pvarsym,init(s,vartype));
            vs^.fileinfo:=fileinfo;
            vs^.varspez:=varspez;
            aktprocsym^.definition^.localst^.insert(vs);
@@ -1892,7 +1889,10 @@ end;
 end.
 {
   $Log$
-  Revision 1.15  2001-03-24 12:18:11  florian
+  Revision 1.16  2001-04-02 21:20:33  peter
+    * resulttype rewrite
+
+  Revision 1.15  2001/03/24 12:18:11  florian
     * procedure p(); is now allowed in all modes except TP
 
   Revision 1.14  2001/03/22 22:35:42  florian

compiler/pdecvar.pas

@@ -285,7 +285,7 @@ implementation
                   symtablestack^.insert(pconstsym);
                   akttokenpos:=storetokenpos;
                   consume(_EQUAL);
-                  readtypedconst(tt.def,pconstsym,false);
+                  readtypedconst(tt,pconstsym,false);
                   symdone:=true;
                end;
              { for a record there doesn't need to be a ; before the END or ) }
@@ -527,7 +527,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.11  2001-03-11 22:58:50  peter
+  Revision 1.12  2001-04-02 21:20:33  peter
+    * resulttype rewrite
+
+  Revision 1.11  2001/03/11 22:58:50  peter
     * getsym redesign, removed the globals srsym,srsymtable
 
   Revision 1.10  2001/03/06 18:28:02  peter

compiler/pmodules.pas

@@ -443,8 +443,6 @@ implementation
             end;
            pu:=tused_unit(pu.next);
          end;
-        { deref }
-        punitsymtable(current_module.globalsymtable)^.deref;
         { load browser info if stored }
         if ((current_module.flags and uf_has_browser)<>0) and load_refs then
           punitsymtable(current_module.globalsymtable)^.load_symtable_refs;
@@ -973,7 +971,7 @@ implementation
         { set some informations about the main program }
         with procinfo^ do
          begin
-           returntype.setdef(voiddef);
+           returntype:=voidtype;
            _class:=nil;
            para_offset:=8;
            framepointer:=frame_pointer;
@@ -1663,7 +1661,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.25  2001-03-13 18:45:07  peter
+  Revision 1.26  2001-04-02 21:20:33  peter
+    * resulttype rewrite
+
+  Revision 1.25  2001/03/13 18:45:07  peter
     * fixed some memory leaks
 
   Revision 1.24  2001/03/06 18:28:02  peter

compiler/pstatmnt.pas

@@ -39,7 +39,7 @@ implementation
 
     uses
        { common }
-       cutils,cobjects,
+       cutils,
        { global }
        globtype,globals,verbose,
        systems,cpuinfo,
@@ -198,16 +198,16 @@ implementation
          caseexpr:=comp_expr(true);
        { determines result type }
          cleartempgen;
-         do_firstpass(caseexpr);
+         do_resulttypepass(caseexpr);
          casedeferror:=false;
-         casedef:=caseexpr.resulttype;
+         casedef:=caseexpr.resulttype.def;
          if (not assigned(casedef)) or
             not(is_ordinal(casedef)) then
           begin
             CGMessage(type_e_ordinal_expr_expected);
             { create a correct tree }
             caseexpr.free;
-            caseexpr:=genordinalconstnode(0,u32bitdef);
+            caseexpr:=cordconstnode.create(0,u32bittype);
             { set error flag so no rangechecks are done }
             casedeferror:=true;
           end;
@@ -230,8 +230,8 @@ implementation
              if (p.nodetype=rangen) then
                begin
                   { type checking for case statements }
-                  if is_subequal(casedef, trangenode(p).left.resulttype) and
-                     is_subequal(casedef, trangenode(p).right.resulttype) then
+                  if is_subequal(casedef, trangenode(p).left.resulttype.def) and
+                     is_subequal(casedef, trangenode(p).right.resulttype.def) then
                     begin
                       hl1:=get_ordinal_value(trangenode(p).left);
                       hl2:=get_ordinal_value(trangenode(p).right);
@@ -250,7 +250,7 @@ implementation
              else
                begin
                   { type checking for case statements }
-                  if not is_subequal(casedef, p.resulttype) then
+                  if not is_subequal(casedef, p.resulttype.def) then
                     CGMessage(parser_e_case_mismatch);
                   hl1:=get_ordinal_value(p);
                   if not casedeferror then
@@ -385,15 +385,15 @@ implementation
          hp : tnode;
       begin
          p:=comp_expr(true);
-         do_firstpass(p);
+         do_resulttypepass(p);
          set_varstate(p,false);
          right:=nil;
          if (not codegenerror) and
-            (p.resulttype^.deftype in [objectdef,recorddef]) then
+            (p.resulttype.def^.deftype in [objectdef,recorddef]) then
           begin
-            case p.resulttype^.deftype of
+            case p.resulttype.def^.deftype of
              objectdef : begin
-                           obj:=pobjectdef(p.resulttype);
+                           obj:=pobjectdef(p.resulttype.def);
                            withsymtable:=new(pwithsymtable,init);
                            withsymtable^.symsearch:=obj^.symtable^.symsearch;
                            withsymtable^.defowner:=obj;
@@ -423,7 +423,7 @@ implementation
                            symtablestack:=withsymtable;
                          end;
              recorddef : begin
-                           symtab:=precorddef(p.resulttype)^.symtable;
+                           symtab:=precorddef(p.resulttype.def)^.symtable;
                            levelcount:=1;
                            withsymtable:=new(pwithsymtable,init);
                            withsymtable^.symsearch:=symtab^.symsearch;
@@ -432,7 +432,7 @@ implementation
                            pwithsymtable(withsymtable)^.direct_with:=true;
                            {symtab^.withnode:=p; not yet allocated !! }
                            pwithsymtable(withsymtable)^.withrefnode:=p;
-                           withsymtable^.defowner:=precorddef(p.resulttype);
+                           withsymtable^.defowner:=precorddef(p.resulttype.def);
                            withsymtable^.next:=symtablestack;
                            symtablestack:=withsymtable;
                         end;
@@ -452,7 +452,7 @@ implementation
              end;
             for i:=1 to levelcount do
              symtablestack:=symtablestack^.next;
-            _with_statement:=genwithnode(pwithsymtable(withsymtable),p,right,levelcount);
+            _with_statement:=cwithnode.create(pwithsymtable(withsymtable),p,right,levelcount);
           end
          else
           begin
@@ -519,17 +519,16 @@ implementation
       var
          p_try_block,p_finally_block,first,last,
          p_default,p_specific,hp : tnode;
-         ot : pobjectdef;
+         ot : ttype;
          sym : pvarsym;
          old_block_type : tblock_type;
          exceptsymtable : psymtable;
-         objname : stringid;
+         objname,objrealname : stringid;
          srsym : psym;
          srsymtable : psymtable;
 
       begin
-         procinfo^.flags:=procinfo^.flags or
-           pi_uses_exceptions;
+         procinfo^.flags:=procinfo^.flags or pi_uses_exceptions;
 
          p_default:=nil;
          p_specific:=nil;
@@ -568,9 +567,9 @@ implementation
               consume(_EXCEPT);
               old_block_type:=block_type;
               block_type:=bt_except;
-              ot:=pobjectdef(generrordef);
+              ot:=generrortype;
               p_specific:=nil;
-              if (token=_ID) and (idtoken=_ON) then
+              if (idtoken=_ON) then
                 { catch specific exceptions }
                 begin
                    repeat
@@ -578,6 +577,7 @@ implementation
                      if token=_ID then
                        begin
                           objname:=pattern;
+                          objrealname:=orgpattern;
                           { can't use consume_sym here, because we need already
                             to check for the colon }
                           searchsym(objname,srsym,srsymtable);
@@ -589,16 +589,16 @@ implementation
                                if (srsym^.typ=typesym) and
                                   is_class(ptypesym(srsym)^.restype.def) then
                                  begin
-                                    ot:=pobjectdef(ptypesym(srsym)^.restype.def);
-                                    sym:=new(pvarsym,initdef(objname,ot));
+                                    ot:=ptypesym(srsym)^.restype;
+                                    sym:=new(pvarsym,init(objrealname,ot));
                                  end
                                else
                                  begin
-                                    sym:=new(pvarsym,initdef(objname,new(perrordef,init)));
+                                    sym:=new(pvarsym,init(objrealname,generrortype));
                                     if (srsym^.typ=typesym) then
                                       Message1(type_e_class_type_expected,ptypesym(srsym)^.restype.def^.typename)
                                     else
-                                      Message1(type_e_class_type_expected,ot^.typename);
+                                      Message1(type_e_class_type_expected,ot.def^.typename);
                                  end;
                                exceptsymtable:=new(pstoredsymtable,init(stt_exceptsymtable));
                                exceptsymtable^.insert(sym);
@@ -612,7 +612,7 @@ implementation
                                  with "e: Exception" the e is not necessary }
                                if srsym=nil then
                                 begin
-                                  identifier_not_found(objname);
+                                  identifier_not_found(objrealname);
                                   srsym:=generrorsym;
                                 end;
                                { support unit.identifier }
@@ -620,25 +620,25 @@ implementation
                                  begin
                                     consume(_POINT);
                                     srsym:=searchsymonlyin(punitsym(srsym)^.unitsymtable,pattern);
-                                    consume(_ID);
                                     if srsym=nil then
                                      begin
-                                       identifier_not_found(objname);
+                                       identifier_not_found(orgpattern);
                                        srsym:=generrorsym;
                                      end;
+                                    consume(_ID);
                                  end;
                                { check if type is valid, must be done here because
                                  with "e: Exception" the e is not necessary }
                                if (srsym^.typ=typesym) and
                                   is_class(ptypesym(srsym)^.restype.def) then
-                                 ot:=pobjectdef(ptypesym(srsym)^.restype.def)
+                                 ot:=ptypesym(srsym)^.restype
                                else
                                  begin
-                                    ot:=pobjectdef(generrordef);
+                                    ot:=generrortype;
                                     if (srsym^.typ=typesym) then
                                       Message1(type_e_class_type_expected,ptypesym(srsym)^.restype.def^.typename)
                                     else
-                                      Message1(type_e_class_type_expected,ot^.typename);
+                                      Message1(type_e_class_type_expected,ot.def^.typename);
                                  end;
                                exceptsymtable:=nil;
                             end;
@@ -647,7 +647,7 @@ implementation
                        consume(_ID);
                      consume(_DO);
                      hp:=connode.create(nil,statement);
-                     if ot^.deftype=errordef then
+                     if ot.def^.deftype=errordef then
                        begin
                           hp.free;
                           hp:=cerrornode.create;
@@ -667,7 +667,7 @@ implementation
                      { that last and hp are errornodes (JM)                            }
                      if last.nodetype = onn then
                        begin
-                         tonnode(last).excepttype:=ot;
+                         tonnode(last).excepttype:=pobjectdef(ot.def);
                          tonnode(last).exceptsymtable:=exceptsymtable;
                        end;
                      { remove exception symtable }
@@ -716,14 +716,13 @@ implementation
               consume(_RKLAMMER);
               if (block_type=bt_except) then
                 Message(parser_e_exit_with_argument_not__possible);
-              if procinfo^.returntype.def=pdef(voiddef) then
+              if is_void(procinfo^.returntype.def) then
                 Message(parser_e_void_function);
            end
          else
            p:=nil;
          p:=cexitnode.create(p);
-         // p.resulttype:=procinfo^.returntype.def;
-         p.resulttype:=voiddef;
+         p.resulttype:=voidtype;
          exit_statement:=p;
       end;
 
@@ -844,7 +843,6 @@ implementation
         destructorname : stringid;
         sym      : psym;
         classh   : pobjectdef;
-        pd,pd2   : pdef;
         destructorpos,
         storepos : tfileposinfo;
         is_new   : boolean;
@@ -860,7 +858,6 @@ implementation
         p:=comp_expr(true);
         { calc return type }
         cleartempgen;
-        do_firstpass(p);
         set_varstate(p,(not is_new));
         { constructor,destructor specified }
         if try_to_consume(_COMMA) then
@@ -872,13 +869,9 @@ implementation
             destructorpos:=akttokenpos;
             consume(_ID);
 
-            pd:=p.resulttype;
-            if pd=nil then
-             pd:=generrordef;
-            pd2:=pd;
-            if (pd^.deftype<>pointerdef) then
+            if (p.resulttype.def^.deftype<>pointerdef) then
               begin
-                 Message1(type_e_pointer_type_expected,pd^.typename);
+                 Message1(type_e_pointer_type_expected,p.resulttype.def^.typename);
                  p.free;
                  p:=factor(false);
                  p.free;
@@ -887,7 +880,7 @@ implementation
                  exit;
               end;
             { first parameter must be an object or class }
-            if ppointerdef(pd)^.pointertype.def^.deftype<>objectdef then
+            if ppointerdef(p.resulttype.def)^.pointertype.def^.deftype<>objectdef then
               begin
                  Message(parser_e_pointer_to_class_expected);
                  p.free;
@@ -897,7 +890,7 @@ implementation
                  exit;
               end;
             { check, if the first parameter is a pointer to a _class_ }
-            classh:=pobjectdef(ppointerdef(pd)^.pointertype.def);
+            classh:=pobjectdef(ppointerdef(p.resulttype.def)^.pointertype.def);
             if is_class(classh) then
               begin
                  Message(parser_e_no_new_or_dispose_for_classes);
@@ -929,23 +922,17 @@ implementation
                  p2:=chnewnode.create
                 else
                  p2:=chdisposenode.create(p);
+                do_resulttypepass(p2);
+                p2.resulttype:=ppointerdef(p.resulttype.def)^.pointertype;
                 if is_new then
-                  begin
-                    { Constructors can take parameters.}
-                    p2.resulttype:=ppointerdef(pd)^.pointertype.def;
-                    do_member_read(false,sym,p2,pd,again);
-                  end
+                  do_member_read(false,sym,p2,again)
                 else
                   begin
                     if (m_tp in aktmodeswitches) then
-                      begin
-                        { Constructors can take parameters.}
-                        p2.resulttype:=ppointerdef(pd)^.pointertype.def;
-                        do_member_read(false,sym,p2,pd,again);
-                      end
+                      do_member_read(false,sym,p2,again)
                     else
                       begin
-                        p2:=ccallnode.create(pprocsym(sym),sym^.owner,p2);
+                        p2:=ccallnode.create(nil,pprocsym(sym),sym^.owner,p2);
                         { support dispose(p,done()); }
                         if try_to_consume(_LKLAMMER) then
                           begin
@@ -961,16 +948,17 @@ implementation
 
                 { we need the real called method }
                 cleartempgen;
-                do_firstpass(p2);
-
+                do_resulttypepass(p2);
                 if not codegenerror then
                  begin
                    if is_new then
                     begin
                       if (tcallnode(p2).procdefinition^.proctypeoption<>potype_constructor) then
                         Message(parser_e_expr_have_to_be_constructor_call);
-                      p2:=cassignmentnode.create(p,cnewnode.create(p2));
-                      tassignmentnode(p2).right.resulttype:=pd2;
+                      p2:=cnewnode.create(p2);
+                      do_resulttypepass(p2);
+                      p2.resulttype:=p.resulttype;
+                      p2:=cassignmentnode.create(p,p2);
                     end
                    else
                     begin
@@ -983,20 +971,18 @@ implementation
           end
         else
           begin
-             if p.resulttype=nil then
-              p.resulttype:=generrordef;
-             if (p.resulttype^.deftype<>pointerdef) then
+             if (p.resulttype.def^.deftype<>pointerdef) then
                Begin
-                  Message1(type_e_pointer_type_expected,p.resulttype^.typename);
+                  Message1(type_e_pointer_type_expected,p.resulttype.def^.typename);
                   new_dispose_statement:=cerrornode.create;
                end
              else
                begin
-                  if (ppointerdef(p.resulttype)^.pointertype.def^.deftype=objectdef) and
-                     (oo_has_vmt in pobjectdef(ppointerdef(p.resulttype)^.pointertype.def)^.objectoptions) then
+                  if (ppointerdef(p.resulttype.def)^.pointertype.def^.deftype=objectdef) and
+                     (oo_has_vmt in pobjectdef(ppointerdef(p.resulttype.def)^.pointertype.def)^.objectoptions) then
                     Message(parser_w_use_extended_syntax_for_objects);
-                  if (ppointerdef(p.resulttype)^.pointertype.def^.deftype=orddef) and
-                     (porddef(ppointerdef(p.resulttype)^.pointertype.def)^.typ=uvoid) then
+                  if (ppointerdef(p.resulttype.def)^.pointertype.def^.deftype=orddef) and
+                     (porddef(ppointerdef(p.resulttype.def)^.pointertype.def)^.typ=uvoid) then
                     begin
                       if (m_tp in aktmodeswitches) or
                          (m_delphi in aktmodeswitches) then
@@ -1186,7 +1172,7 @@ implementation
 
          { assembler code does not allocate }
          { space for the return value       }
-          if procinfo^.returntype.def<>pdef(voiddef) then
+          if not is_void(procinfo^.returntype.def) then
            begin
               if ret_in_acc(procinfo^.returntype.def) then
                 begin
@@ -1240,7 +1226,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.21  2001-03-22 22:35:42  florian
+  Revision 1.22  2001-04-02 21:20:34  peter
+    * resulttype rewrite
+
+  Revision 1.21  2001/03/22 22:35:42  florian
     + support for type a = (a=1); in Delphi mode added
     + procedure p(); in Delphi mode supported
     + on isn't keyword anymore, it can be used as

compiler/psub.pas

@@ -103,7 +103,7 @@ implementation
             exit;
           end;
 
-         if procinfo^.returntype.def<>pdef(voiddef) then
+         if not is_void(procinfo^.returntype.def) then
            begin
               { if the current is a function aktprocsym is non nil }
               { and there is a local symtable set }
@@ -135,24 +135,14 @@ implementation
          { !!!!!   this means that we can not set the return value
          in a subfunction !!!!! }
          { because we don't know yet where the address is }
-         if procinfo^.returntype.def<>pdef(voiddef) then
+         if not is_void(procinfo^.returntype.def) then
            begin
               if ret_in_acc(procinfo^.returntype.def) or (procinfo^.returntype.def^.deftype=floatdef) then
-              { if (procinfo^.retdef^.deftype=orddef) or
-                 (procinfo^.retdef^.deftype=pointerdef) or
-                 (procinfo^.retdef^.deftype=enumdef) or
-                 (procinfo^.retdef^.deftype=procvardef) or
-                 (procinfo^.retdef^.deftype=floatdef) or
-                 (
-                   (procinfo^.retdef^.deftype=setdef) and
-                   (psetdef(procinfo^.retdef)^.settype=smallset)
-                 ) then  }
                 begin
                    { the space has been set in the local symtable }
                    procinfo^.return_offset:=-funcretsym^.address;
                    if ((procinfo^.flags and pi_operator)<>0) and
-                     assigned(opsym) then
-                     {opsym^.address:=procinfo^.para_offset; is wrong PM }
+                      assigned(opsym) then
                      opsym^.address:=-procinfo^.return_offset;
                    { eax is modified by a function }
 {$ifndef newcg}
@@ -528,7 +518,7 @@ implementation
               s:=Copy(name,4,255);
               if not(po_assembler in aktprocsym^.definition^.procoptions) then
                begin
-                 vs:=new(Pvarsym,initdef(s,vartype.def));
+                 vs:=new(Pvarsym,init(s,vartype));
                  vs^.fileinfo:=fileinfo;
                  vs^.varspez:=varspez;
                  aktprocsym^.definition^.localst^.insert(vs);
@@ -823,7 +813,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.25  2001-02-26 19:44:53  peter
+  Revision 1.26  2001-04-02 21:20:34  peter
+    * resulttype rewrite
+
+  Revision 1.25  2001/02/26 19:44:53  peter
     * merged generic m68k updates from fixes branch
 
   Revision 1.24  2000/12/25 00:07:27  peter

compiler/psystem.pas

@@ -39,7 +39,7 @@ implementation
 
 uses
   globals,
-  symconst,symsym,symdef,symtable,
+  symconst,symtype,symsym,symdef,symtable,
   ninl;
 
 procedure insertinternsyms(p : psymtable);
@@ -82,88 +82,96 @@ procedure insert_intern_types(p : psymtable);
 {
   all the types inserted into the system unit
 }
+
+  procedure addtype(const s:string;const t:ttype);
+  begin
+    p^.insert(new(ptypesym,init(s,t)));
+  end;
+
+  procedure adddef(const s:string;def:pdef);
+  var
+    t : ttype;
+  begin
+    t.setdef(def);
+    p^.insert(new(ptypesym,init(s,t)));
+  end;
+
 var
   { several defs to simulate more or less C++ objects for GDB }
-  vmtdef      : precorddef;
-  vmtarraydef : parraydef;
-  vmtsymtable : psymtable;
+  vmttype,
+  vmtarraytype : ttype;
+  vmtsymtable  : psymtable;
 begin
 { Internal types }
-  p^.insert(new(ptypesym,initdef('$formal',cformaldef)));
-  p^.insert(new(ptypesym,initdef('$void',voiddef)));
-  p^.insert(new(ptypesym,initdef('$byte',u8bitdef)));
-  p^.insert(new(ptypesym,initdef('$word',u16bitdef)));
-  p^.insert(new(ptypesym,initdef('$ulong',u32bitdef)));
-  p^.insert(new(ptypesym,initdef('$longint',s32bitdef)));
-  p^.insert(new(ptypesym,initdef('$qword',cu64bitdef)));
-  p^.insert(new(ptypesym,initdef('$int64',cs64bitdef)));
-  p^.insert(new(ptypesym,initdef('$char',cchardef)));
-  p^.insert(new(ptypesym,initdef('$widechar',cwidechardef)));
-  p^.insert(new(ptypesym,initdef('$shortstring',cshortstringdef)));
-  p^.insert(new(ptypesym,initdef('$longstring',clongstringdef)));
-  p^.insert(new(ptypesym,initdef('$ansistring',cansistringdef)));
-  p^.insert(new(ptypesym,initdef('$widestring',cwidestringdef)));
-  p^.insert(new(ptypesym,initdef('$openshortstring',openshortstringdef)));
-  p^.insert(new(ptypesym,initdef('$boolean',booldef)));
-  p^.insert(new(ptypesym,initdef('$void_pointer',voidpointerdef)));
-  p^.insert(new(ptypesym,initdef('$char_pointer',charpointerdef)));
-  p^.insert(new(ptypesym,initdef('$void_farpointer',voidfarpointerdef)));
-  p^.insert(new(ptypesym,initdef('$openchararray',openchararraydef)));
-  p^.insert(new(ptypesym,initdef('$file',cfiledef)));
-  p^.insert(new(ptypesym,initdef('$variant',cvariantdef)));
-  p^.insert(new(ptypesym,initdef('$s32real',s32floatdef)));
-  p^.insert(new(ptypesym,initdef('$s64real',s64floatdef)));
-  p^.insert(new(ptypesym,initdef('$s80real',s80floatdef)));
-{$ifdef SUPPORT_FIXED}
-  p^.insert(new(ptypesym,initdef('$s32fixed',s32fixeddef)));
-{$endif SUPPORT_FIXED}
+  addtype('$formal',cformaltype);
+  addtype('$void',voidtype);
+  addtype('$byte',u8bittype);
+  addtype('$word',u16bittype);
+  addtype('$ulong',u32bittype);
+  addtype('$longint',s32bittype);
+  addtype('$qword',cu64bittype);
+  addtype('$int64',cs64bittype);
+  addtype('$char',cchartype);
+  addtype('$widechar',cwidechartype);
+  addtype('$shortstring',cshortstringtype);
+  addtype('$longstring',clongstringtype);
+  addtype('$ansistring',cansistringtype);
+  addtype('$widestring',cwidestringtype);
+  addtype('$openshortstring',openshortstringtype);
+  addtype('$boolean',booltype);
+  addtype('$void_pointer',voidpointertype);
+  addtype('$char_pointer',charpointertype);
+  addtype('$void_farpointer',voidfarpointertype);
+  addtype('$openchararray',openchararraytype);
+  addtype('$file',cfiletype);
+  addtype('$variant',cvarianttype);
+  addtype('$s32real',s32floattype);
+  addtype('$s64real',s64floattype);
+  addtype('$s80real',s80floattype);
   { Add a type for virtual method tables in lowercase }
   { so it isn't reachable!                            }
   vmtsymtable:=new(pstoredsymtable,init(recordsymtable));
-  vmtdef:=new(precorddef,init(vmtsymtable));
-  pvmtdef:=new(ppointerdef,initdef(vmtdef));
-  vmtsymtable^.insert(new(pvarsym,initdef('$parent',pvmtdef)));
-  vmtsymtable^.insert(new(pvarsym,initdef('$length',globaldef('longint'))));
-  vmtsymtable^.insert(new(pvarsym,initdef('$mlength',globaldef('longint'))));
-  vmtarraydef:=new(parraydef,init(0,1,s32bitdef));
-  vmtarraydef^.elementtype.setdef(voidpointerdef);
-  vmtsymtable^.insert(new(pvarsym,initdef('$__pfn',vmtarraydef)));
-  p^.insert(new(ptypesym,initdef('$__vtbl_ptr_type',vmtdef)));
-  p^.insert(new(ptypesym,initdef('$pvmt',pvmtdef)));
-  vmtarraydef:=new(parraydef,init(0,1,s32bitdef));
-  vmtarraydef^.elementtype.setdef(pvmtdef);
-  p^.insert(new(ptypesym,initdef('$vtblarray',vmtarraydef)));
+  vmttype.setdef(new(precorddef,init(vmtsymtable)));
+  pvmttype.setdef(new(ppointerdef,init(vmttype)));
+  vmtsymtable^.insert(new(pvarsym,init('$parent',pvmttype)));
+  vmtsymtable^.insert(new(pvarsym,init('$length',s32bittype)));
+  vmtsymtable^.insert(new(pvarsym,init('$mlength',s32bittype)));
+  vmtarraytype.setdef(new(parraydef,init(0,1,s32bittype)));
+  parraydef(vmtarraytype.def)^.elementtype:=voidpointertype;
+  vmtsymtable^.insert(new(pvarsym,init('$__pfn',vmtarraytype)));
+  addtype('$__vtbl_ptr_type',vmttype);
+  addtype('$pvmt',pvmttype);
+  vmtarraytype.setdef(new(parraydef,init(0,1,s32bittype)));
+  parraydef(vmtarraytype.def)^.elementtype:=pvmttype;
+  addtype('$vtblarray',vmtarraytype);
+{ Add functions that require compiler magic }
   insertinternsyms(p);
 { Normal types }
-  p^.insert(new(ptypesym,initdef('Single',s32floatdef)));
-  p^.insert(new(ptypesym,initdef('Double',s64floatdef)));
-  p^.insert(new(ptypesym,initdef('Extended',s80floatdef)));
-  p^.insert(new(ptypesym,initdef('Real',s64floatdef)));
+  addtype('Single',s32floattype);
+  addtype('Double',s64floattype);
+  addtype('Extended',s80floattype);
+  addtype('Real',s64floattype);
 {$ifdef i386}
-  p^.insert(new(ptypesym,initdef('Comp',new(pfloatdef,init(s64comp)))));
+  adddef('Comp',new(pfloatdef,init(s64comp)));
 {$endif}
-  p^.insert(new(ptypesym,initdef('Pointer',voidpointerdef)));
-  p^.insert(new(ptypesym,initdef('FarPointer',voidfarpointerdef)));
-  p^.insert(new(ptypesym,initdef('ShortString',cshortstringdef)));
-  p^.insert(new(ptypesym,initdef('LongString',clongstringdef)));
-  p^.insert(new(ptypesym,initdef('AnsiString',cansistringdef)));
-  p^.insert(new(ptypesym,initdef('WideString',cwidestringdef)));
-  p^.insert(new(ptypesym,initdef('Boolean',booldef)));
-  p^.insert(new(ptypesym,initdef('ByteBool',booldef)));
-  p^.insert(new(ptypesym,initdef('WordBool',new(porddef,init(bool16bit,0,1)))));
-  p^.insert(new(ptypesym,initdef('LongBool',new(porddef,init(bool32bit,0,1)))));
-  p^.insert(new(ptypesym,initdef('Char',cchardef)));
-  p^.insert(new(ptypesym,initdef('WideChar',cwidechardef)));
-  p^.insert(new(ptypesym,initdef('Text',new(pfiledef,inittext))));
-  p^.insert(new(ptypesym,initdef('Cardinal',u32bitdef)));
-{$ifdef SUPPORT_FIXED}
-  p^.insert(new(ptypesym,initdef('Fixed',new(pfloatdef,init(f32bit)))));
-  p^.insert(new(ptypesym,initdef('Fixed16',new(pfloatdef,init(f16bit)))));
-{$endif SUPPORT_FIXED}
-  p^.insert(new(ptypesym,initdef('QWord',cu64bitdef)));
-  p^.insert(new(ptypesym,initdef('Int64',cs64bitdef)));
-  p^.insert(new(ptypesym,initdef('TypedFile',new(pfiledef,inittypeddef(voiddef)))));
-  p^.insert(new(ptypesym,initdef('Variant',cvariantdef)));
+  addtype('Pointer',voidpointertype);
+  addtype('FarPointer',voidfarpointertype);
+  addtype('ShortString',cshortstringtype);
+  addtype('LongString',clongstringtype);
+  addtype('AnsiString',cansistringtype);
+  addtype('WideString',cwidestringtype);
+  addtype('Boolean',booltype);
+  addtype('ByteBool',booltype);
+  adddef('WordBool',new(porddef,init(bool16bit,0,1)));
+  adddef('LongBool',new(porddef,init(bool32bit,0,1)));
+  addtype('Char',cchartype);
+  addtype('WideChar',cwidechartype);
+  adddef('Text',new(pfiledef,inittext));
+  addtype('Cardinal',u32bittype);
+  addtype('QWord',cu64bittype);
+  addtype('Int64',cs64bittype);
+  adddef('TypedFile',new(pfiledef,inittyped(voidtype)));
+  addtype('Variant',cvarianttype);
 end;
 
 
@@ -172,35 +180,32 @@ procedure readconstdefs;
   Load all default definitions for consts from the system unit
 }
 begin
-  u8bitdef:=porddef(globaldef('byte'));
-  u16bitdef:=porddef(globaldef('word'));
-  u32bitdef:=porddef(globaldef('ulong'));
-  s32bitdef:=porddef(globaldef('longint'));
-  cu64bitdef:=porddef(globaldef('qword'));
-  cs64bitdef:=porddef(globaldef('int64'));
-  cformaldef:=pformaldef(globaldef('formal'));
-  voiddef:=porddef(globaldef('void'));
-  cchardef:=porddef(globaldef('char'));
-  cwidechardef:=porddef(globaldef('widechar'));
-  cshortstringdef:=pstringdef(globaldef('shortstring'));
-  clongstringdef:=pstringdef(globaldef('longstring'));
-  cansistringdef:=pstringdef(globaldef('ansistring'));
-  cwidestringdef:=pstringdef(globaldef('widestring'));
-  openshortstringdef:=pstringdef(globaldef('openshortstring'));
-  openchararraydef:=parraydef(globaldef('openchararray'));
-  s32floatdef:=pfloatdef(globaldef('s32real'));
-  s64floatdef:=pfloatdef(globaldef('s64real'));
-  s80floatdef:=pfloatdef(globaldef('s80real'));
-{$ifdef SUPPORT_FIXED}
-  s32fixeddef:=pfloatdef(globaldef('s32fixed'));
-{$endif SUPPORT_FIXED}
-  booldef:=porddef(globaldef('boolean'));
-  voidpointerdef:=ppointerdef(globaldef('void_pointer'));
-  charpointerdef:=ppointerdef(globaldef('char_pointer'));
-  voidfarpointerdef:=ppointerdef(globaldef('void_farpointer'));
-  cfiledef:=pfiledef(globaldef('file'));
-  pvmtdef:=ppointerdef(globaldef('pvmt'));
-  cvariantdef:=pvariantdef(globaldef('variant'));
+  globaldef('byte',u8bittype);
+  globaldef('word',u16bittype);
+  globaldef('ulong',u32bittype);
+  globaldef('longint',s32bittype);
+  globaldef('qword',cu64bittype);
+  globaldef('int64',cs64bittype);
+  globaldef('formal',cformaltype);
+  globaldef('void',voidtype);
+  globaldef('char',cchartype);
+  globaldef('widechar',cwidechartype);
+  globaldef('shortstring',cshortstringtype);
+  globaldef('longstring',clongstringtype);
+  globaldef('ansistring',cansistringtype);
+  globaldef('widestring',cwidestringtype);
+  globaldef('openshortstring',openshortstringtype);
+  globaldef('openchararray',openchararraytype);
+  globaldef('s32real',s32floattype);
+  globaldef('s64real',s64floattype);
+  globaldef('s80real',s80floattype);
+  globaldef('boolean',booltype);
+  globaldef('void_pointer',voidpointertype);
+  globaldef('char_pointer',charpointertype);
+  globaldef('void_farpointer',voidfarpointertype);
+  globaldef('file',cfiletype);
+  globaldef('pvmt',pvmttype);
+  globaldef('variant',cvarianttype);
 end;
 
 
@@ -214,48 +219,45 @@ begin
   { create definitions for constants }
   oldregisterdef:=registerdef;
   registerdef:=false;
-  cformaldef:=new(pformaldef,init);
-  voiddef:=new(porddef,init(uvoid,0,0));
-  u8bitdef:=new(porddef,init(u8bit,0,255));
-  u16bitdef:=new(porddef,init(u16bit,0,65535));
-  u32bitdef:=new(porddef,init(u32bit,0,longint($ffffffff)));
-  s32bitdef:=new(porddef,init(s32bit,longint($80000000),$7fffffff));
-  cu64bitdef:=new(porddef,init(u64bit,0,0));
-  cs64bitdef:=new(porddef,init(s64bit,0,0));
-  booldef:=new(porddef,init(bool8bit,0,1));
-  cchardef:=new(porddef,init(uchar,0,255));
-  cwidechardef:=new(porddef,init(uwidechar,0,65535));
-  cshortstringdef:=new(pstringdef,shortinit(255));
+  cformaltype.setdef(new(pformaldef,init));
+  voidtype.setdef(new(porddef,init(uvoid,0,0)));
+  u8bittype.setdef(new(porddef,init(u8bit,0,255)));
+  u16bittype.setdef(new(porddef,init(u16bit,0,65535)));
+  u32bittype.setdef(new(porddef,init(u32bit,0,longint($ffffffff))));
+  s32bittype.setdef(new(porddef,init(s32bit,longint($80000000),$7fffffff)));
+  cu64bittype.setdef(new(porddef,init(u64bit,0,0)));
+  cs64bittype.setdef(new(porddef,init(s64bit,0,0)));
+  booltype.setdef(new(porddef,init(bool8bit,0,1)));
+  cchartype.setdef(new(porddef,init(uchar,0,255)));
+  cwidechartype.setdef(new(porddef,init(uwidechar,0,65535)));
+  cshortstringtype.setdef(new(pstringdef,shortinit(255)));
   { should we give a length to the default long and ansi string definition ?? }
-  clongstringdef:=new(pstringdef,longinit(-1));
-  cansistringdef:=new(pstringdef,ansiinit(-1));
-  cwidestringdef:=new(pstringdef,wideinit(-1));
+  clongstringtype.setdef(new(pstringdef,longinit(-1)));
+  cansistringtype.setdef(new(pstringdef,ansiinit(-1)));
+  cwidestringtype.setdef(new(pstringdef,wideinit(-1)));
   { length=0 for shortstring is open string (needed for readln(string) }
-  openshortstringdef:=new(pstringdef,shortinit(0));
-  openchararraydef:=new(parraydef,init(0,-1,s32bitdef));
-  parraydef(openchararraydef)^.elementtype.setdef(cchardef);
+  openshortstringtype.setdef(new(pstringdef,shortinit(0)));
+  openchararraytype.setdef(new(parraydef,init(0,-1,s32bittype)));
+  parraydef(openchararraytype.def)^.elementtype:=cchartype;
 {$ifdef i386}
-  s32floatdef:=new(pfloatdef,init(s32real));
-  s64floatdef:=new(pfloatdef,init(s64real));
-  s80floatdef:=new(pfloatdef,init(s80real));
+  s32floattype.setdef(new(pfloatdef,init(s32real)));
+  s64floattype.setdef(new(pfloatdef,init(s64real)));
+  s80floattype.setdef(new(pfloatdef,init(s80real)));
 {$endif}
 {$ifdef m68k}
-  s32floatdef:=new(pfloatdef,init(s32real));
-  s64floatdef:=new(pfloatdef,init(s64real));
+  s32floattype.setdef(new(pfloatdef,init(s32real)));
+  s64floattype.setdef(new(pfloatdef,init(s64real)));
   if (cs_fp_emulation in aktmoduleswitches) then
-   s80floatdef:=new(pfloatdef,init(s32real))
+   s80floattype.setdef(new(pfloatdef,init(s32real)))
   else
-   s80floatdef:=new(pfloatdef,init(s80real));
+   s80floattype.setdef(new(pfloatdef,init(s80real)));
 {$endif}
-{$ifdef SUPPORT_FIXED}
-  s32fixeddef:=new(pfloatdef,init(f32bit));
-{$endif SUPPORT_FIXED}
   { some other definitions }
-  voidpointerdef:=new(ppointerdef,initdef(voiddef));
-  charpointerdef:=new(ppointerdef,initdef(cchardef));
-  voidfarpointerdef:=new(ppointerdef,initfardef(voiddef));
-  cfiledef:=new(pfiledef,inituntyped);
-  cvariantdef:=new(pvariantdef,init);
+  voidpointertype.setdef(new(ppointerdef,init(voidtype)));
+  charpointertype.setdef(new(ppointerdef,init(cchartype)));
+  voidfarpointertype.setdef(new(ppointerdef,initfar(voidtype)));
+  cfiletype.setdef(new(pfiledef,inituntyped));
+  cvarianttype.setdef(new(pvariantdef,init));
   registerdef:=oldregisterdef;
 end;
 
@@ -263,7 +265,10 @@ end;
 end.
 {
   $Log$
-  Revision 1.13  2001-03-25 12:40:00  florian
+  Revision 1.14  2001-04-02 21:20:34  peter
+    * resulttype rewrite
+
+  Revision 1.13  2001/03/25 12:40:00  florian
     * cwidechar was loaded with a chardef, fixed
 
   Revision 1.12  2001/03/22 00:10:58  florian
@@ -278,7 +283,7 @@ end.
     * added lots of longint typecast to prevent range check errors in the
       compiler and rtl
     * type casts of symbolic ordinal constants are now preserved
-    * fixed bug where the original resulttype wasn't restored correctly
+    * fixed bug where the original resulttype.def wasn't restored correctly
       after doing a 64bit rangecheck
 
   Revision 1.10  2000/11/29 00:30:38  florian

compiler/ptconst.pas

@@ -31,7 +31,7 @@ interface
     { this procedure reads typed constants }
     { sym is only needed for ansi strings  }
     { the assembler label is in the middle (PM) }
-    procedure readtypedconst(def : pdef;sym : ptypedconstsym;no_change_allowed : boolean);
+    procedure readtypedconst(const t:ttype;sym : ptypedconstsym;no_change_allowed : boolean);
 
 implementation
 
@@ -43,7 +43,7 @@ implementation
 {$endif Delphi}
        globtype,systems,tokens,cpuinfo,
        cutils,globals,scanner,
-       symconst,symbase,symdef,symtable,aasm,types,verbose,
+       symconst,symbase,symdef,aasm,types,verbose,
        { pass 1 }
        node,pass_1,
        nmat,nadd,ncal,nmem,nset,ncnv,ninl,ncon,nld,nflw,
@@ -60,7 +60,7 @@ implementation
   {$maxfpuregisters 0}
 {$endif fpc}
     { this procedure reads typed constants }
-    procedure readtypedconst(def : pdef;sym : ptypedconstsym;no_change_allowed : boolean);
+    procedure readtypedconst(const t:ttype;sym : ptypedconstsym;no_change_allowed : boolean);
 
       var
 {$ifdef m68k}
@@ -82,10 +82,10 @@ implementation
          value     : bestreal;
          strval    : pchar;
 
-      procedure check_range;
+      procedure check_range(def:porddef);
         begin
-           if ((tordconstnode(p).value>porddef(def)^.high) or
-               (tordconstnode(p).value<porddef(def)^.low)) then
+           if ((tordconstnode(p).value>def^.high) or
+               (tordconstnode(p).value<def^.low)) then
              begin
                 if (cs_check_range in aktlocalswitches) then
                   Message(parser_e_range_check_error)
@@ -100,12 +100,12 @@ implementation
            curconstsegment:=consts
          else
            curconstsegment:=datasegment;
-         case def^.deftype of
+         case t.def^.deftype of
             orddef:
               begin
                  p:=comp_expr(true);
                  do_firstpass(p);
-                 case porddef(def)^.typ of
+                 case porddef(t.def)^.typ of
                     bool8bit :
                       begin
                          if is_constboolnode(p) then
@@ -147,7 +147,7 @@ implementation
                          if is_constintnode(p) then
                            begin
                               curconstSegment.concat(Tai_const.Create_8bit(tordconstnode(p).value));
-                              check_range;
+                              check_range(porddef(t.def));
                            end
                          else
                            Message(cg_e_illegal_expression);
@@ -158,7 +158,7 @@ implementation
                          if is_constintnode(p) then
                            begin
                              curconstSegment.concat(Tai_const.Create_16bit(tordconstnode(p).value));
-                             check_range;
+                             check_range(porddef(t.def));
                            end
                          else
                            Message(cg_e_illegal_expression);
@@ -169,8 +169,8 @@ implementation
                          if is_constintnode(p) then
                            begin
                               curconstSegment.concat(Tai_const.Create_32bit(tordconstnode(p).value));
-                              if porddef(def)^.typ<>u32bit then
-                               check_range;
+                              if porddef(t.def)^.typ<>u32bit then
+                               check_range(porddef(t.def));
                            end
                          else
                            Message(cg_e_illegal_expression);
@@ -203,7 +203,7 @@ implementation
               else
                 Message(cg_e_illegal_expression);
 
-              case pfloatdef(def)^.typ of
+              case pfloatdef(t.def)^.typ of
                  s32real :
                    curconstSegment.concat(Tai_real_32bit.Create(value));
                  s64real :
@@ -212,8 +212,6 @@ implementation
                    curconstSegment.concat(Tai_real_80bit.Create(value));
                  s64comp :
                    curconstSegment.concat(Tai_comp_64bit.Create(value));
-                 f32bit :
-                   curconstSegment.concat(Tai_const.Create_32bit(trunc(value*65536)));
                  else
                    internalerror(18);
               end;
@@ -226,11 +224,11 @@ implementation
               case p.nodetype of
                  loadvmtn:
                    begin
-                      if not(pobjectdef(pclassrefdef(p.resulttype)^.pointertype.def)^.is_related(
-                        pobjectdef(pclassrefdef(def)^.pointertype.def))) then
+                      if not(pobjectdef(pclassrefdef(p.resulttype.def)^.pointertype.def)^.is_related(
+                        pobjectdef(pclassrefdef(t.def)^.pointertype.def))) then
                         Message(cg_e_illegal_expression);
                       curconstSegment.concat(Tai_const_symbol.Create(newasmsymbol(pobjectdef(
-                        pclassrefdef(p.resulttype)^.pointertype.def)^.vmt_mangledname)));
+                        pclassrefdef(p.resulttype.def)^.pointertype.def)^.vmt_mangledname)));
                    end;
                  niln:
                    curconstSegment.concat(Tai_const.Create_32bit(0));
@@ -244,7 +242,7 @@ implementation
               do_firstpass(p);
               if (p.nodetype=typeconvn) and
                  (ttypeconvnode(p).left.nodetype in [addrn,niln]) and
-                 is_equal(def,p.resulttype) then
+                 is_equal(t.def,p.resulttype.def) then
                 begin
                    hp:=ttypeconvnode(p).left;
                    ttypeconvnode(p).left:=nil;
@@ -269,7 +267,7 @@ implementation
                 curconstSegment.concat(Tai_const.Create_32bit(0))
               { maybe pchar ? }
               else
-                if is_char(ppointerdef(def)^.pointertype.def) and
+                if is_char(ppointerdef(t.def)^.pointertype.def) and
                    (p.nodetype<>addrn) then
                   begin
                     getdatalabel(ll);
@@ -298,9 +296,9 @@ implementation
                     hp:=taddrnode(p).left;
                     while assigned(hp) and (hp.nodetype in [subscriptn,vecn]) do
                       hp:=tbinarynode(hp).left;
-                    if (is_equal(ppointerdef(p.resulttype)^.pointertype.def,ppointerdef(def)^.pointertype.def) or
-                       (is_equal(ppointerdef(p.resulttype)^.pointertype.def,voiddef)) or
-                       (is_equal(ppointerdef(def)^.pointertype.def,voiddef))) and
+                    if (is_equal(ppointerdef(p.resulttype.def)^.pointertype.def,ppointerdef(t.def)^.pointertype.def) or
+                       (is_void(ppointerdef(p.resulttype.def)^.pointertype.def)) or
+                       (is_void(ppointerdef(t.def)^.pointertype.def))) and
                        (hp.nodetype=loadn) then
                       begin
                         do_firstpass(taddrnode(p).left);
@@ -311,7 +309,7 @@ implementation
                              case hp.nodetype of
                                vecn :
                                  begin
-                                   case tvecnode(hp).left.resulttype^.deftype of
+                                   case tvecnode(hp).left.resulttype.def^.deftype of
                                      stringdef :
                                        begin
                                           { this seems OK for shortstring and ansistrings PM }
@@ -321,8 +319,8 @@ implementation
                                        end;
                                      arraydef :
                                        begin
-                                          len:=parraydef(tvecnode(hp).left.resulttype)^.elesize;
-                                          base:=parraydef(tvecnode(hp).left.resulttype)^.lowrange;
+                                          len:=parraydef(tvecnode(hp).left.resulttype.def)^.elesize;
+                                          base:=parraydef(tvecnode(hp).left.resulttype.def)^.lowrange;
                                        end
                                      else
                                        Message(cg_e_illegal_expression);
@@ -354,7 +352,7 @@ implementation
                     if (tinlinenode(p).left.nodetype=typen) then
                       begin
                         curconstSegment.concat(Tai_const_symbol.createname(
-                          pobjectdef(tinlinenode(p).left.resulttype)^.vmt_mangledname));
+                          pobjectdef(tinlinenode(p).left.resulttype.def)^.vmt_mangledname));
                       end
                     else
                       Message(cg_e_illegal_expression);
@@ -375,7 +373,7 @@ implementation
                    else
                      begin
 {$ifdef i386}
-                        for l:=0 to def^.size-1 do
+                        for l:=0 to t.def^.size-1 do
                           curconstSegment.concat(Tai_const.Create_8bit(tsetconstnode(p).value_set^[l]));
 {$endif}
 {$ifdef m68k}
@@ -403,17 +401,17 @@ implementation
               do_firstpass(p);
               if p.nodetype=ordconstn then
                 begin
-                  if is_equal(p.resulttype,def) or
-                     is_subequal(p.resulttype,def) then
+                  if is_equal(p.resulttype.def,t.def) or
+                     is_subequal(p.resulttype.def,t.def) then
                    begin
-                     case p.resulttype^.size of
+                     case p.resulttype.def^.size of
                        1 : curconstSegment.concat(Tai_const.Create_8bit(tordconstnode(p).value));
                        2 : curconstSegment.concat(Tai_const.Create_16bit(tordconstnode(p).value));
                        4 : curconstSegment.concat(Tai_const.Create_32bit(tordconstnode(p).value));
                      end;
                    end
                   else
-                   Message2(type_e_incompatible_types,def^.typename,p.resulttype^.typename);
+                   Message2(type_e_incompatible_types,t.def^.typename,p.resulttype.def^.typename);
                 end
               else
                 Message(cg_e_illegal_expression);
@@ -446,13 +444,13 @@ implementation
                 end;
               if strlength>=0 then
                begin
-                 case pstringdef(def)^.string_typ of
+                 case pstringdef(t.def)^.string_typ of
                    st_shortstring:
                      begin
-                       if strlength>=def^.size then
+                       if strlength>=t.def^.size then
                         begin
-                          message2(parser_w_string_too_long,strpas(strval),tostr(def^.size-1));
-                          strlength:=def^.size-1;
+                          message2(parser_w_string_too_long,strpas(strval),tostr(t.def^.size-1));
+                          strlength:=t.def^.size-1;
                         end;
                        curconstSegment.concat(Tai_const.Create_8bit(strlength));
                        { this can also handle longer strings }
@@ -461,15 +459,15 @@ implementation
                        ca[strlength]:=#0;
                        curconstSegment.concat(Tai_string.Create_length_pchar(ca,strlength));
                        { fillup with spaces if size is shorter }
-                       if def^.size>strlength then
+                       if t.def^.size>strlength then
                         begin
-                          getmem(ca,def^.size-strlength);
+                          getmem(ca,t.def^.size-strlength);
                           { def^.size contains also the leading length, so we }
                           { we have to subtract one                       }
-                          fillchar(ca[0],def^.size-strlength-1,' ');
-                          ca[def^.size-strlength-1]:=#0;
+                          fillchar(ca[0],t.def^.size-strlength-1,' ');
+                          ca[t.def^.size-strlength-1]:=#0;
                           { this can also handle longer strings }
-                          curconstSegment.concat(Tai_string.Create_length_pchar(ca,def^.size-strlength-1));
+                          curconstSegment.concat(Tai_string.Create_length_pchar(ca,t.def^.size-strlength-1));
                         end;
                      end;
 {$ifdef UseLongString}
@@ -522,17 +520,17 @@ implementation
               if token=_LKLAMMER then
                 begin
                     consume(_LKLAMMER);
-                    for l:=parraydef(def)^.lowrange to parraydef(def)^.highrange-1 do
+                    for l:=parraydef(t.def)^.lowrange to parraydef(t.def)^.highrange-1 do
                       begin
-                         readtypedconst(parraydef(def)^.elementtype.def,nil,no_change_allowed);
+                         readtypedconst(parraydef(t.def)^.elementtype,nil,no_change_allowed);
                          consume(_COMMA);
                       end;
-                    readtypedconst(parraydef(def)^.elementtype.def,nil,no_change_allowed);
+                    readtypedconst(parraydef(t.def)^.elementtype,nil,no_change_allowed);
                     consume(_RKLAMMER);
                  end
               else
               { if array of char then we allow also a string }
-               if is_char(parraydef(def)^.elementtype.def) then
+               if is_char(parraydef(t.def)^.elementtype.def) then
                 begin
                    p:=comp_expr(true);
                    do_firstpass(p);
@@ -556,11 +554,11 @@ implementation
                        Message(cg_e_illegal_expression);
                        len:=0;
                      end;
-                   if len>(Parraydef(def)^.highrange-Parraydef(def)^.lowrange+1) then
+                   if len>(Parraydef(t.def)^.highrange-Parraydef(t.def)^.lowrange+1) then
                      Message(parser_e_string_larger_array);
-                   for i:=Parraydef(def)^.lowrange to Parraydef(def)^.highrange do
+                   for i:=Parraydef(t.def)^.lowrange to Parraydef(t.def)^.highrange do
                      begin
-                        if i+1-Parraydef(def)^.lowrange<=len then
+                        if i+1-Parraydef(t.def)^.lowrange<=len then
                           begin
                              curconstSegment.concat(Tai_const.Create_8bit(byte(ca^)));
                              inc(ca);
@@ -592,7 +590,7 @@ implementation
                   if token=_KLAMMERAFFE then
                     consume(_KLAMMERAFFE);
               getprocvar:=true;
-              getprocvardef:=pprocvardef(def);
+              getprocvardef:=pprocvardef(t.def);
               p:=comp_expr(true);
               getprocvar:=false;
               do_firstpass(p);
@@ -604,12 +602,10 @@ implementation
               { convert calln to loadn }
               if p.nodetype=calln then
                begin
+                 hp:=cloadnode.create(pprocsym(tcallnode(p).symtableprocentry),tcallnode(p).symtableproc);
                  if (tcallnode(p).symtableprocentry^.owner^.symtabletype=objectsymtable) and
                     is_class(pdef(tcallnode(p).symtableprocentry^.owner^.defowner)) then
-                  hp:=genloadmethodcallnode(pprocsym(tcallnode(p).symtableprocentry),tcallnode(p).symtableproc,
-                        tcallnode(p).methodpointer.getcopy)
-                 else
-                  hp:=genloadcallnode(pprocsym(tcallnode(p).symtableprocentry),tcallnode(p).symtableproc);
+                  tloadnode(hp).set_mp(tcallnode(p).methodpointer.getcopy);
                  p.free;
                  do_firstpass(hp);
                  p:=hp;
@@ -622,13 +618,11 @@ implementation
               else if (p.nodetype=addrn) and assigned(taddrnode(p).left) and
                 (taddrnode(p).left.nodetype=calln) then
                 begin
+                   hp:=cloadnode.create(pprocsym(tcallnode(taddrnode(p).left).symtableprocentry),
+                     tcallnode(taddrnode(p).left).symtableproc);
                    if (tcallnode(taddrnode(p).left).symtableprocentry^.owner^.symtabletype=objectsymtable) and
                       is_class(pdef(tcallnode(taddrnode(p).left).symtableprocentry^.owner^.defowner)) then
-                    hp:=genloadmethodcallnode(pprocsym(tcallnode(taddrnode(p).left).symtableprocentry),
-                      tcallnode(taddrnode(p).left).symtableproc,tcallnode(taddrnode(p).left).methodpointer.getcopy)
-                   else
-                    hp:=genloadcallnode(pprocsym(tcallnode(taddrnode(p).left).symtableprocentry),
-                      tcallnode(taddrnode(p).left).symtableproc);
+                    tloadnode(hp).set_mp(tcallnode(taddrnode(p).left).methodpointer.getcopy);
                    p.free;
                    do_firstpass(hp);
                    p:=hp;
@@ -639,7 +633,7 @@ implementation
                     end;
                 end;
               { let type conversion check everything needed }
-              p:=gentypeconvnode(p,def);
+              p:=ctypeconvnode.create(p,t);
               do_firstpass(p);
               if codegenerror then
                begin
@@ -678,11 +672,11 @@ implementation
          recorddef:
            begin
               { KAZ }
-              if (precorddef(def)=rec_tguid) and
+              if (precorddef(t.def)=rec_tguid) and
                  ((token=_CSTRING) or (token=_CCHAR) or (token=_ID)) then
                 begin
                   p:=comp_expr(true);
-                  p:=gentypeconvnode(p,cshortstringdef);
+                  p:=ctypeconvnode.create(p,cshortstringtype);
                   do_firstpass(p);
                   if p.nodetype=stringconstn then
                     begin
@@ -715,7 +709,7 @@ implementation
                         s:=pattern;
                         consume(_ID);
                         consume(_COLON);
-                        srsym:=psym(precorddef(def)^.symtable^.search(s));
+                        srsym:=psym(precorddef(t.def)^.symtable^.search(s));
                         if srsym=nil then
                           begin
                              Message1(sym_e_id_not_found,s);
@@ -736,14 +730,14 @@ implementation
                              aktpos:=pvarsym(srsym)^.address+pvarsym(srsym)^.vartype.def^.size;
 
                              { read the data }
-                             readtypedconst(pvarsym(srsym)^.vartype.def,nil,no_change_allowed);
+                             readtypedconst(pvarsym(srsym)^.vartype,nil,no_change_allowed);
 
                              if token=_SEMICOLON then
                                consume(_SEMICOLON)
                              else break;
                           end;
                    end;
-                 for i:=1 to def^.size-aktpos do
+                 for i:=1 to t.def^.size-aktpos do
                    curconstSegment.concat(Tai_const.Create_8bit(0));
                  consume(_RKLAMMER);
               end;
@@ -751,7 +745,7 @@ implementation
          { reads a typed object }
          objectdef:
            begin
-              if is_class_or_interface(def) then
+              if is_class_or_interface(t.def) then
                 begin
                   p:=comp_expr(true);
                   do_firstpass(p);
@@ -767,7 +761,7 @@ implementation
                   p.free;
                 end
               { for objects we allow it only if it doesn't contain a vmt }
-              else if (oo_has_vmt in pobjectdef(def)^.objectoptions) and
+              else if (oo_has_vmt in pobjectdef(t.def)^.objectoptions) and
                       not(m_tp in aktmodeswitches) then
                  Message(parser_e_type_const_not_possible)
               else
@@ -780,7 +774,7 @@ implementation
                         consume(_ID);
                         consume(_COLON);
                         srsym:=nil;
-                        obj:=pobjectdef(def);
+                        obj:=pobjectdef(t.def);
                         symt:=obj^.symtable;
                         while (srsym=nil) and assigned(symt) do
                           begin
@@ -806,14 +800,14 @@ implementation
 
                              { check in VMT needs to be added for TP mode }
                              if (m_tp in aktmodeswitches) and
-                                (oo_has_vmt in pobjectdef(def)^.objectoptions) and
-                                (pobjectdef(def)^.vmt_offset<pvarsym(srsym)^.address) then
+                                (oo_has_vmt in pobjectdef(t.def)^.objectoptions) and
+                                (pobjectdef(t.def)^.vmt_offset<pvarsym(srsym)^.address) then
                                begin
-                                 for i:=1 to pobjectdef(def)^.vmt_offset-aktpos do
+                                 for i:=1 to pobjectdef(t.def)^.vmt_offset-aktpos do
                                    curconstsegment.concat(tai_const.create_8bit(0));
-                                 curconstsegment.concat(tai_const_symbol.createname(pobjectdef(def)^.vmt_mangledname));
+                                 curconstsegment.concat(tai_const_symbol.createname(pobjectdef(t.def)^.vmt_mangledname));
                                  { this is more general }
-                                 aktpos:=pobjectdef(def)^.vmt_offset + target_os.size_of_pointer;
+                                 aktpos:=pobjectdef(t.def)^.vmt_offset + target_os.size_of_pointer;
                                end;
 
                              { if needed fill }
@@ -825,7 +819,7 @@ implementation
                              aktpos:=pvarsym(srsym)^.address+pvarsym(srsym)^.vartype.def^.size;
 
                              { read the data }
-                             readtypedconst(pvarsym(srsym)^.vartype.def,nil,no_change_allowed);
+                             readtypedconst(pvarsym(srsym)^.vartype,nil,no_change_allowed);
 
                              if token=_SEMICOLON then
                                consume(_SEMICOLON)
@@ -833,16 +827,16 @@ implementation
                           end;
                      end;
                    if (m_tp in aktmodeswitches) and
-                      (oo_has_vmt in pobjectdef(def)^.objectoptions) and
-                      (pobjectdef(def)^.vmt_offset>=aktpos) then
+                      (oo_has_vmt in pobjectdef(t.def)^.objectoptions) and
+                      (pobjectdef(t.def)^.vmt_offset>=aktpos) then
                      begin
-                       for i:=1 to pobjectdef(def)^.vmt_offset-aktpos do
+                       for i:=1 to pobjectdef(t.def)^.vmt_offset-aktpos do
                          curconstsegment.concat(tai_const.create_8bit(0));
-                       curconstsegment.concat(tai_const_symbol.createname(pobjectdef(def)^.vmt_mangledname));
+                       curconstsegment.concat(tai_const_symbol.createname(pobjectdef(t.def)^.vmt_mangledname));
                        { this is more general }
-                       aktpos:=pobjectdef(def)^.vmt_offset + target_os.size_of_pointer;
+                       aktpos:=pobjectdef(t.def)^.vmt_offset + target_os.size_of_pointer;
                      end;
-                   for i:=1 to def^.size-aktpos do
+                   for i:=1 to t.def^.size-aktpos do
                      curconstSegment.concat(Tai_const.Create_8bit(0));
                    consume(_RKLAMMER);
                 end;
@@ -865,7 +859,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.18  2001-03-11 22:58:50  peter
+  Revision 1.19  2001-04-02 21:20:34  peter
+    * resulttype rewrite
+
+  Revision 1.18  2001/03/11 22:58:50  peter
     * getsym redesign, removed the globals srsym,srsymtable
 
   Revision 1.17  2001/02/04 11:12:16  jonas

compiler/ptype.pas

@@ -55,7 +55,7 @@ implementation
 
     uses
        { common }
-       cutils,cobjects,cpuinfo,
+       cutils,cpuinfo,
        { global }
        globals,tokens,verbose,
        systems,
@@ -125,23 +125,23 @@ implementation
          if not assigned(srsym) then
           begin
             Message1(sym_e_id_not_found,s);
-            tt.setdef(generrordef);
+            tt:=generrortype;
             exit;
           end;
          { type sym ? }
          if (srsym^.typ<>typesym) then
           begin
             Message(type_e_type_id_expected);
-            tt.setdef(generrordef);
+            tt:=generrortype;
             exit;
           end;
          { Types are first defined with an error def before assigning
            the real type so check if it's an errordef. if so then
            give an error }
-         if (ptypesym(srsym)^.restype.def=generrordef) then
+         if (ptypesym(srsym)^.restype.def^.deftype=errordef) then
           begin
             Message(sym_e_error_in_type_def);
-            tt.setdef(generrordef);
+            tt:=generrortype;
             exit;
           end;
          { Only use the definitions for system/current unit, becuase
@@ -167,7 +167,7 @@ implementation
           case token of
             _STRING:
                 begin
-                   tt.setdef(string_dec);
+                   string_dec(tt);
                    s:='STRING';
                 end;
             _FILE:
@@ -182,7 +182,7 @@ implementation
                      end
                    else
                      begin
-                        tt.setdef(cfiledef);
+                        tt:=cfiletype;
                         s:='FILE';
                      end;
                 end;
@@ -268,7 +268,7 @@ implementation
                   (pt2.nodetype=ordconstn) then
                  begin
                  { check types }
-                   if CheckTypes(pt1.resulttype,pt2.resulttype) then
+                   if CheckTypes(pt1.resulttype.def,pt2.resulttype.def) then
                      begin
                      { Check bounds }
                        if tordconstnode(pt2).value<tordconstnode(pt1).value then
@@ -276,15 +276,15 @@ implementation
                        else
                         begin
                         { All checks passed, create the new def }
-                          case pt1.resulttype^.deftype of
+                          case pt1.resulttype.def^.deftype of
                             enumdef :
-                              tt.setdef(new(penumdef,init_subrange(penumdef(pt1.resulttype),tordconstnode(pt1).value,tordconstnode(pt2).value)));
+                              tt.setdef(new(penumdef,init_subrange(penumdef(pt1.resulttype.def),tordconstnode(pt1).value,tordconstnode(pt2).value)));
                             orddef :
                               begin
-                                if is_char(pt1.resulttype) then
+                                if is_char(pt1.resulttype.def) then
                                   tt.setdef(new(porddef,init(uchar,tordconstnode(pt1).value,tordconstnode(pt2).value)))
                                 else
-                                  if is_boolean(pt1.resulttype) then
+                                  if is_boolean(pt1.resulttype.def) then
                                     tt.setdef(new(porddef,init(bool8bit,tordconstnode(pt1).value,tordconstnode(pt2).value)))
                                   else
                                     tt.setdef(new(porddef,init(uauto,tordconstnode(pt1).value,tordconstnode(pt2).value)));
@@ -301,12 +301,7 @@ implementation
              begin
                { a simple type renaming }
                if (pt1.nodetype=typen) then
-                 begin
-                   if assigned(ttypenode(pt1).typenodesym) then
-                     tt.setsym(ttypenode(pt1).typenodesym)
-                   else
-                     tt.setdef(pt1.resulttype);
-                 end
+                 tt:=ttypenode(pt1).resulttype
                else
                  Message(sym_e_error_in_type_def);
              end;
@@ -317,32 +312,32 @@ implementation
         var
           lowval,
           highval   : longint;
-          arraytype : pdef;
+          arraytype : ttype;
           ht        : ttype;
 
-          procedure setdefdecl(p:pdef);
+          procedure setdefdecl(const t:ttype);
           begin
-            case p^.deftype of
+            case t.def^.deftype of
               enumdef :
                 begin
-                  lowval:=penumdef(p)^.min;
-                  highval:=penumdef(p)^.max;
-                  arraytype:=p;
+                  lowval:=penumdef(t.def)^.min;
+                  highval:=penumdef(t.def)^.max;
+                  arraytype:=t;
                 end;
               orddef :
                 begin
-                  if porddef(p)^.typ in [uchar,
+                  if porddef(t.def)^.typ in [uchar,
                     u8bit,u16bit,
                     s8bit,s16bit,s32bit,
                     bool8bit,bool16bit,bool32bit,
                     uwidechar] then
                     begin
-                       lowval:=porddef(p)^.low;
-                       highval:=porddef(p)^.high;
-                       arraytype:=p;
+                       lowval:=porddef(t.def)^.low;
+                       highval:=porddef(t.def)^.high;
+                       arraytype:=t;
                     end
                   else
-                    Message1(parser_e_type_cant_be_used_in_array_index,p^.gettypename);
+                    Message1(parser_e_type_cant_be_used_in_array_index,t.def^.gettypename);
                 end;
               else
                 Message(sym_e_error_in_type_def);
@@ -356,7 +351,7 @@ implementation
              begin
                 consume(_LECKKLAMMER);
                 { defaults }
-                arraytype:=generrordef;
+                arraytype:=generrortype;
                 lowval:=longint($80000000);
                 highval:=$7fffffff;
                 tt.reset;
@@ -367,7 +362,7 @@ implementation
                   if token=_LKLAMMER then
                    begin
                      read_type(ht,'');
-                     setdefdecl(ht.def);
+                     setdefdecl(ht);
                    end
                   else
                    begin
@@ -421,7 +416,7 @@ implementation
              end
            else
              begin
-                ap:=new(parraydef,init(0,-1,s32bitdef));
+                ap:=new(parraydef,init(0,-1,s32bittype));
                 ap^.IsDynamicArray:=true;
                 tt.setdef(ap);
              end;
@@ -497,19 +492,19 @@ implementation
                      { don't forget that min can be negativ  PM }
                      enumdef :
                        if penumdef(tt2.def)^.min>=0 then
-                        tt.setdef(new(psetdef,init(tt2.def,penumdef(tt2.def)^.max)))
+                        tt.setdef(new(psetdef,init(tt2,penumdef(tt2.def)^.max)))
                        else
                         Message(sym_e_ill_type_decl_set);
                      orddef :
                        begin
                          case porddef(tt2.def)^.typ of
                            uchar :
-                             tt.setdef(new(psetdef,init(tt2.def,255)));
+                             tt.setdef(new(psetdef,init(tt2,255)));
                            u8bit,u16bit,u32bit,
                            s8bit,s16bit,s32bit :
                              begin
                                if (porddef(tt2.def)^.low>=0) then
-                                tt.setdef(new(psetdef,init(tt2.def,porddef(tt2.def)^.high)))
+                                tt.setdef(new(psetdef,init(tt2,porddef(tt2.def)^.high)))
                                else
                                 Message(sym_e_ill_type_decl_set);
                              end;
@@ -522,7 +517,7 @@ implementation
                    end;
                  end
                 else
-                 tt.setdef(generrordef);
+                 tt:=generrortype;
               end;
            _CARET:
               begin
@@ -589,13 +584,16 @@ implementation
               expr_type;
          end;
          if tt.def=nil then
-          tt.setdef(generrordef);
+          tt:=generrortype;
       end;
 
 end.
 {
   $Log$
-  Revision 1.20  2001-03-22 22:35:42  florian
+  Revision 1.21  2001-04-02 21:20:34  peter
+    * resulttype rewrite
+
+  Revision 1.20  2001/03/22 22:35:42  florian
     + support for type a = (a=1); in Delphi mode added
     + procedure p(); in Delphi mode supported
     + on isn't keyword anymore, it can be used as
@@ -616,7 +614,7 @@ end.
     * added lots of longint typecast to prevent range check errors in the
       compiler and rtl
     * type casts of symbolic ordinal constants are now preserved
-    * fixed bug where the original resulttype wasn't restored correctly
+    * fixed bug where the original resulttype.def wasn't restored correctly
       after doing a 64bit rangecheck
 
   Revision 1.16  2000/11/29 00:30:38  florian

compiler/rautils.pas

@@ -733,7 +733,7 @@ Begin
   SetupResult:=false;
   { replace by correct offset. }
   if assigned(procinfo^.returntype.def) and
-     (procinfo^.returntype.def<>pdef(voiddef)) then
+     (not is_void(procinfo^.returntype.def)) then
    begin
      if (procinfo^.return_offset=0) and ((m_tp in aktmodeswitches) or
         (m_delphi in aktmodeswitches)) then
@@ -1498,7 +1498,6 @@ end;
           s64real : p.concat(Tai_real_64bit.Create(value));
           s80real : p.concat(Tai_real_80bit.Create(value));
           s64comp : p.concat(Tai_comp_64bit.Create(value));
-          f32bit  : p.concat(Tai_const.Create_32bit(trunc(value*$10000)));
        end;
     end;
 
@@ -1565,7 +1564,10 @@ end;
 end.
 {
   $Log$
-  Revision 1.16  2001-03-11 22:58:50  peter
+  Revision 1.17  2001-04-02 21:20:34  peter
+    * resulttype rewrite
+
+  Revision 1.16  2001/03/11 22:58:50  peter
     * getsym redesign, removed the globals srsym,srsymtable
 
   Revision 1.15  2001/02/26 19:44:54  peter

compiler/symconst.pas

@@ -68,8 +68,6 @@ const
   ftExtended = 2;
   ftComp     = 3;
   ftCurr     = 4;
-  ftFixed16  = 5;
-  ftFixed32  = 6;
 
   mkProcedure= 0;
   mkFunction = 1;
@@ -177,8 +175,7 @@ type
   { float types }
   tfloattype = (
     s32real,s64real,s80real,
-    s64comp,
-    f16bit,f32bit
+    s64comp
   );
 
   { string types }
@@ -455,7 +452,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.14  2001-03-22 00:10:58  florian
+  Revision 1.15  2001-04-02 21:20:34  peter
+    * resulttype rewrite
+
+  Revision 1.14  2001/03/22 00:10:58  florian
     + basic variant type support in the compiler
 
   Revision 1.13  2001/02/26 19:44:55  peter

compiler/symdef.pas

@@ -125,7 +125,6 @@ interface
           constructor inittext;
           constructor inituntyped;
           constructor inittyped(const tt : ttype);
-          constructor inittypeddef(p : pdef);
           constructor load;
           procedure write;virtual;
           procedure deref;virtual;
@@ -189,8 +188,6 @@ interface
           is_far : boolean;
           constructor init(const tt : ttype);
           constructor initfar(const tt : ttype);
-          constructor initdef(p : pdef);
-          constructor initfardef(p : pdef);
           constructor load;
           destructor  done;virtual;
           procedure write;virtual;
@@ -295,7 +292,7 @@ interface
 
        pclassrefdef = ^tclassrefdef;
        tclassrefdef = object(tpointerdef)
-          constructor init(def : pdef);
+          constructor init(const t:ttype);
           constructor load;
           procedure write;virtual;
           function gettypename:string;virtual;
@@ -319,7 +316,7 @@ interface
           IsArrayOfConst : boolean;
           function gettypename:string;virtual;
           function elesize : longint;
-          constructor init(l,h : longint;rd : pdef);
+          constructor init(l,h : longint;const t : ttype);
           constructor load;
           procedure write;virtual;
 {$ifdef GDB}
@@ -423,7 +420,7 @@ interface
           destructor done;virtual;
           procedure  write;virtual;
           procedure deref;virtual;
-          procedure concatpara(tt:ttype;vsp : tvarspez;defval:psym);
+          procedure concatpara(const tt:ttype;vsp : tvarspez;defval:psym);
           function  para_size(alignsize:longint) : longint;
           function  demangled_paras : string;
           function  proccalloption2str : string;
@@ -591,7 +588,7 @@ interface
        tsetdef = object(tstoreddef)
           elementtype : ttype;
           settype : tsettype;
-          constructor init(s : pdef;high : longint);
+          constructor init(const t:ttype;high : longint);
           constructor load;
           destructor  done;virtual;
           procedure write;virtual;
@@ -622,66 +619,59 @@ interface
 {$endif GDB}
 
     { default types }
-       generrordef : pdef;       { error in definition }
-
-       voidpointerdef : ppointerdef; { pointer for Void-Pointerdef }
-       charpointerdef : ppointerdef; { pointer for Char-Pointerdef }
-       voidfarpointerdef : ppointerdef;
-
-       cformaldef : pformaldef;    { unique formal definition }
-       voiddef   : porddef;        { Pointer to Void (procedure) }
-       cchardef  : porddef;        { Pointer to Char }
-       cwidechardef : porddef;     { Pointer to WideChar }
-       booldef   : porddef;        { pointer to boolean type }
-       u8bitdef  : porddef;        { Pointer to 8-Bit unsigned }
-       u16bitdef : porddef;        { Pointer to 16-Bit unsigned }
-       u32bitdef : porddef;        { Pointer to 32-Bit unsigned }
-       s32bitdef : porddef;        { Pointer to 32-Bit signed }
-
-       cu64bitdef : porddef;       { pointer to 64 bit unsigned def }
-       cs64bitdef : porddef;       { pointer to 64 bit signed def, }
-                                   { calculated by the int unit on i386 }
-
-       s32floatdef : pfloatdef;    { pointer for realconstn }
-       s64floatdef : pfloatdef;    { pointer for realconstn }
-       s80floatdef : pfloatdef;    { pointer to type of temp. floats }
-       s32fixeddef : pfloatdef;    { pointer to type of temp. fixed }
-
-       cshortstringdef : pstringdef;     { pointer to type of short string const   }
-       clongstringdef  : pstringdef;     { pointer to type of long string const   }
-       cansistringdef  : pstringdef;     { pointer to type of ansi string const  }
-       cwidestringdef  : pstringdef;     { pointer to type of wide string const  }
-       openshortstringdef : pstringdef;  { pointer to type of an open shortstring,
-                                           needed for readln() }
-       openchararraydef : parraydef;     { pointer to type of an open array of char,
-                                            needed for readln() }
-
-       cfiledef : pfiledef;       { get the same definition for all file }
+       generrortype,              { error in definition }
+       voidpointertype,           { pointer for Void-Pointerdef }
+       charpointertype,           { pointer for Char-Pointerdef }
+       voidfarpointertype,
+       cformaltype,               { unique formal definition }
+       voidtype,                  { Pointer to Void (procedure) }
+       cchartype,                 { Pointer to Char }
+       cwidechartype,             { Pointer to WideChar }
+       booltype,                  { pointer to boolean type }
+       u8bittype,                 { Pointer to 8-Bit unsigned }
+       u16bittype,                { Pointer to 16-Bit unsigned }
+       u32bittype,                { Pointer to 32-Bit unsigned }
+       s32bittype,                { Pointer to 32-Bit signed }
+       cu64bittype,               { pointer to 64 bit unsigned def }
+       cs64bittype,               { pointer to 64 bit signed def, }
+       s32floattype,              { pointer for realconstn }
+       s64floattype,              { pointer for realconstn }
+       s80floattype,              { pointer to type of temp. floats }
+       s32fixedtype,              { pointer to type of temp. fixed }
+       cshortstringtype,          { pointer to type of short string const   }
+       clongstringtype,           { pointer to type of long string const   }
+       cansistringtype,           { pointer to type of ansi string const  }
+       cwidestringtype,           { pointer to type of wide string const  }
+       openshortstringtype,       { pointer to type of an open shortstring,
+                                    needed for readln() }
+       openchararraytype,         { pointer to type of an open array of char,
+                                    needed for readln() }
+       cfiletype,                 { get the same definition for all file }
                                   { used for stabs }
+       cvarianttype,              { we use only one variant def }
+       pvmttype      : ttype;     { type of classrefs, used for stabs }
 
-       cvariantdef : pvariantdef; { we use only one variant def }
 
-       class_tobject : pobjectdef;   { pointer to the anchestor of all classes }
+       class_tobject : pobjectdef;      { pointer to the anchestor of all classes }
        interface_iunknown : pobjectdef; { KAZ: pointer to the ancestor }
        rec_tguid : precorddef;          { KAZ: pointer to the TGUID type }
                                         { of all interfaces            }
-       pvmtdef       : ppointerdef;  { type of classrefs }
 
     const
 {$ifdef i386}
-       bestrealdef : ^pfloatdef = @s80floatdef;
+       pbestrealtype : ^ttype = @s80floattype;
 {$endif}
 {$ifdef m68k}
-       bestrealdef : ^pfloatdef = @s64floatdef;
+       pbestrealtype : ^ttype = @s64floattype;
 {$endif}
 {$ifdef alpha}
-       bestrealdef : ^pfloatdef = @s64floatdef;
+       pbestrealtype : ^ttype = @s64floattype;
 {$endif}
 {$ifdef powerpc}
-       bestrealdef : ^pfloatdef = @s64floatdef;
+       pbestrealtype : ^ttype = @s64floattype;
 {$endif}
 {$ifdef ia64}
-       bestrealdef : ^pfloatdef = @s64floatdef;
+       pbestrealtype : ^ttype = @s64floattype;
 {$endif}
 
 {$ifdef GDB}
@@ -834,13 +824,6 @@ implementation
            nextglobal^.previousglobal:=previousglobal;
          previousglobal:=nil;
          nextglobal:=nil;
-{$ifdef SYNONYM}
-         while assigned(typesym) do
-           begin
-              ptypesym(typesym)^.restype.setdef(nil);
-              typesym:=ptypesym(typesym)^.synonym;
-           end;
-{$endif}
       end;
 
 
@@ -922,7 +905,7 @@ implementation
       {formal def have no type !}
       if deftype = formaldef then
         begin
-        numberstring := voiddef^.numberstring;
+        numberstring := pstoreddef(voidtype.def)^.numberstring;
         exit;
         end;
       if (not assigned(typesym)) or (not ptypesym(typesym)^.isusedinstab) then
@@ -1142,7 +1125,7 @@ implementation
    function tstoreddef.is_fpuregable : boolean;
 
      begin
-        is_fpuregable:=(deftype=floatdef) and not(pfloatdef(@self)^.typ in [f32bit,f16bit]);
+        is_fpuregable:=(deftype=floatdef);
      end;
 
 
@@ -1161,7 +1144,7 @@ implementation
 
 
 {****************************************************************************
-                               TSTRINGDEF
+                               Tstringdef
 ****************************************************************************}
 
     constructor tstringdef.shortinit(l : byte);
@@ -1784,9 +1767,9 @@ implementation
         s64bit    : stabstring := strpnew('-31;');
 {$endif not Use_integer_types_for_boolean}
          { u32bit : stabstring := strpnew('r'+
-              s32bitdef^.numberstring+';0;-1;'); }
+              s32bittype^.numberstring+';0;-1;'); }
         else
-          stabstring := strpnew('r'+s32bitdef^.numberstring+';'+tostr(low)+';'+tostr(high)+';');
+          stabstring := strpnew('r'+pstoreddef(s32bittype.def)^.numberstring+';'+tostr(low)+';'+tostr(high)+';');
         end;
       end;
 {$endif GDB}
@@ -1895,8 +1878,6 @@ implementation
     procedure tfloatdef.setsize;
       begin
          case typ of
-            f16bit : savesize:=2;
-            f32bit,
            s32real : savesize:=4;
            s64real : savesize:=8;
            s80real : savesize:=extended_size;
@@ -1921,21 +1902,14 @@ implementation
          case typ of
             s32real,
             s64real : stabstring := strpnew('r'+
-               s32bitdef^.numberstring+';'+tostr(savesize)+';0;');
-            { for fixed real use longint instead to be able to }
-            { debug something at least                         }
-            f32bit:
-              stabstring := s32bitdef^.stabstring;
-            f16bit:
-              stabstring := strpnew('r'+s32bitdef^.numberstring+';0;'+
-                tostr($ffff)+';');
+               pstoreddef(s32bittype.def)^.numberstring+';'+tostr(savesize)+';0;');
             { found this solution in stabsread.c from GDB v4.16 }
             s64comp : stabstring := strpnew('r'+
-               s32bitdef^.numberstring+';-'+tostr(savesize)+';0;');
+               pstoreddef(s32bittype.def)^.numberstring+';-'+tostr(savesize)+';0;');
 {$ifdef i386}
             { under dos at least you must give a size of twelve instead of 10 !! }
             { this is probably do to the fact that in gcc all is pushed in 4 bytes size }
-            s80real : stabstring := strpnew('r'+s32bitdef^.numberstring+';12;0;');
+            s80real : stabstring := strpnew('r'+pstoreddef(s32bittype.def)^.numberstring+';12;0;');
 {$endif i386}
             else
               internalerror(10005);
@@ -1946,9 +1920,9 @@ implementation
 
     procedure tfloatdef.write_rtti_data;
       const
-         {tfloattype = (s32real,s64real,s80real,s64bit,f16bit,f32bit);}
+         {tfloattype = (s32real,s64real,s80real,s64bit);}
          translate : array[tfloattype] of byte =
-           (ftSingle,ftDouble,ftExtended,ftComp,ftFixed16,ftFixed32);
+           (ftSingle,ftDouble,ftExtended,ftComp);
       begin
          rttiList.concat(Tai_const.Create_8bit(tkFloat));
          write_rtti_name;
@@ -1965,7 +1939,7 @@ implementation
 
       const
         names : array[tfloattype] of string[20] = (
-          'Single','Double','Extended','Comp','Fixed','Fixed16');
+          'Single','Double','Extended','Comp');
 
       begin
          gettypename:=names[typ];
@@ -2005,16 +1979,6 @@ implementation
       end;
 
 
-    constructor tfiledef.inittypeddef(p : pdef);
-      begin
-         inherited init;
-         deftype:=filedef;
-         filetyp:=ft_typed;
-         typedfiletype.setdef(p);
-         setsize;
-      end;
-
-
     constructor tfiledef.load;
       begin
          inherited load;
@@ -2068,7 +2032,7 @@ implementation
         ft_untyped :
           stabstring := strpnew('d'+voiddef^.numberstring{+';'});
         ft_text :
-          stabstring := strpnew('d'+cchardef^.numberstring{+';'});
+          stabstring := strpnew('d'+cchartype^.numberstring{+';'});
       end;
    {$Else}
       {based on
@@ -2191,25 +2155,6 @@ implementation
       end;
 
 
-    constructor tpointerdef.initdef(p : pdef);
-      var
-        t : ttype;
-      begin
-        t.setdef(p);
-        tpointerdef.init(t);
-      end;
-
-
-    constructor tpointerdef.initfardef(p : pdef);
-      var
-        t : ttype;
-      begin
-        t.setdef(p);
-        tpointerdef.initfar(t);
-      end;
-
-
-
     constructor tpointerdef.load;
       begin
          inherited load;
@@ -2322,9 +2267,9 @@ implementation
                               TCLASSREFDEF
 ****************************************************************************}
 
-    constructor tclassrefdef.init(def : pdef);
+    constructor tclassrefdef.init(const t:ttype);
       begin
-         inherited initdef(def);
+         inherited init(t);
          deftype:=classrefdef;
       end;
 
@@ -2352,7 +2297,7 @@ implementation
 {$ifdef GDB}
     function tclassrefdef.stabstring : pchar;
       begin
-         stabstring:=strpnew(pvmtdef^.numberstring+';');
+         stabstring:=strpnew(pstoreddef(pvmttype.def)^.numberstring+';');
       end;
 
 
@@ -2380,11 +2325,11 @@ implementation
 {$define usesmallset}
 {$endif i386}
 
-    constructor tsetdef.init(s : pdef;high : longint);
+    constructor tsetdef.init(const t:ttype;high : longint);
       begin
          inherited init;
          deftype:=setdef;
-         elementtype.setdef(s);
+         elementtype:=t;
 {$ifdef usesmallset}
          { small sets only working for i386 PM }
          if high<32 then
@@ -2459,7 +2404,7 @@ implementation
            this is obsolete with GDBPAS !!
            and anyhow creates problems with version 4.18!! PM
          if settype=smallset then
-           stabstring := strpnew('r'+s32bitdef^.numberstring+';0;0xffffffff;')
+           stabstring := strpnew('r'+s32bittype^.numberstring+';0;0xffffffff;')
          else }
            stabstring := strpnew('S'+pstoreddef(elementtype.def)^.numberstring);
       end;
@@ -2576,13 +2521,13 @@ implementation
                            TARRAYDEF
 ***************************************************************************}
 
-    constructor tarraydef.init(l,h : longint;rd : pdef);
+    constructor tarraydef.init(l,h : longint;const t : ttype);
       begin
          inherited init;
          deftype:=arraydef;
          lowrange:=l;
          highrange:=h;
-         rangetype.setdef(rd);
+         rangetype:=t;
          elementtype.reset;
          IsVariant:=false;
          IsConstructor:=false;
@@ -2884,9 +2829,9 @@ implementation
          aktrecordsymtable:=oldrecsyms;
          { assign TGUID? }
          if not(assigned(rec_tguid)) and
-           (upper(typename)='TGUID') and
-           assigned(owner) and
-           (owner^.name^='SYSTEM') then
+            (upper(typename)='TGUID') and
+            assigned(owner) and
+            (owner^.unitid=0) then
            rec_tguid:=@self;
       end;
 
@@ -3134,7 +3079,7 @@ implementation
          proctypeoption:=potype_none;
          proccalloptions:=[];
          procoptions:=[];
-         rettype.setdef(voiddef);
+         rettype:=voidtype;
          symtablelevel:=0;
          savesize:=target_os.size_of_pointer;
       end;
@@ -3147,7 +3092,7 @@ implementation
       end;
 
 
-    procedure tabstractprocdef.concatpara(tt:ttype;vsp : tvarspez;defval:psym);
+    procedure tabstractprocdef.concatpara(const tt:ttype;vsp : tvarspez;defval:psym);
       var
         hp : TParaItem;
       begin
@@ -3170,8 +3115,7 @@ implementation
     procedure tabstractprocdef.test_if_fpu_result;
       begin
          if assigned(rettype.def) and
-            (rettype.def^.deftype=floatdef) and
-            (pfloatdef(rettype.def)^.typ<>f32bit) then
+            (rettype.def^.deftype=floatdef) then
            fpu_used:=2;
       end;
 
@@ -3521,7 +3465,7 @@ implementation
       begin
         s:=fullprocname;
         if assigned(rettype.def) and
-          not(is_equal(rettype.def,voiddef)) then
+          not(is_equal(rettype.def,voidtype.def)) then
                s:=s+' : '+rettype.def^.gettypename;
         fullprocnamewithret:=s;
       end;
@@ -4070,7 +4014,7 @@ Const local_symtable_index : longint = $8001;
              write_rtti_name;
 
              { write kind of method (can only be function or procedure)}
-             if rettype.def = pdef(voiddef) then    { ### typecast shoudln't be necessary! (sg) }
+             if rettype.def = voidtype.def then
                methodkind := mkProcedure
              else
                methodkind := mkFunction;
@@ -4127,7 +4071,7 @@ Const local_symtable_index : longint = $8001;
     function tprocvardef.gettypename : string;
       begin
          if assigned(rettype.def) and
-            (rettype.def<>pdef(voiddef)) then
+            (rettype.def<>voidtype.def) then
            gettypename:='<procedure variable type of function'+demangled_paras+
              ':'+rettype.def^.gettypename+';'+proccalloption2str+'>'
          else
@@ -5626,7 +5570,10 @@ Const local_symtable_index : longint = $8001;
 end.
 {
   $Log$
-  Revision 1.23  2001-03-22 23:28:39  florian
+  Revision 1.24  2001-04-02 21:20:34  peter
+    * resulttype rewrite
+
+  Revision 1.23  2001/03/22 23:28:39  florian
     * correct initialisation of rec_tguid when loading the system unit
 
   Revision 1.22  2001/03/22 00:10:58  florian
@@ -5654,7 +5601,7 @@ end.
     * added lots of longint typecast to prevent range check errors in the
       compiler and rtl
     * type casts of symbolic ordinal constants are now preserved
-    * fixed bug where the original resulttype wasn't restored correctly
+    * fixed bug where the original resulttype.def wasn't restored correctly
       after doing a 64bit rangecheck
 
   Revision 1.16  2000/11/30 23:12:57  florian

compiler/symsym.pas

@@ -127,19 +127,12 @@ interface
 
        ptypesym = ^ttypesym;
        ttypesym = object(tstoredsym)
-{$ifdef SYNONYM}
-          synonym    : ptypesym;
-{$endif}
           restype    : ttype;
 {$ifdef GDB}
           isusedinstab : boolean;
 {$endif GDB}
           constructor init(const n : string;const tt : ttype);
-          constructor initdef(const n : string;d : pdef);
           constructor load;
-{$ifdef SYNONYM}
-          destructor done;virtual;
-{$endif}
           procedure write;virtual;
           function  gettypedef:pdef;virtual;
           procedure prederef;virtual;
@@ -163,7 +156,6 @@ interface
           constructor init(const n : string;const tt : ttype);
           constructor init_dll(const n : string;const tt : ttype);
           constructor init_C(const n,mangled : string;const tt : ttype);
-          constructor initdef(const n : string;p : pdef);
           constructor load;
           destructor  done;virtual;
           procedure write;virtual;
@@ -230,7 +222,6 @@ interface
           ref     : pstoredsym;
           asmname : pstring;
           constructor init(const n : string;const tt : ttype);
-          constructor initdef(const n : string;p : pdef);
           constructor load;
           procedure deref;virtual;
           function  mangledname : string;virtual;
@@ -268,7 +259,7 @@ interface
           value      : tconstexprint;
           len        : longint; { len is needed for string length }
           constructor init(const n : string;t : tconsttyp;v : tconstexprint);
-          constructor init_def(const n : string;t : tconsttyp;v : tconstexprint;def : pdef);
+          constructor init_typed(const n : string;t : tconsttyp;v : tconstexprint;const tt:ttype);
           constructor init_string(const n : string;t : tconsttyp;str:pchar;l:longint);
           constructor load;
           destructor  done;virtual;
@@ -689,9 +680,6 @@ implementation
 
     destructor tprocsym.done;
       begin
-         { don't check if errors !! }
-         if Errorcount=0 then
-           check_forward;
          inherited done;
       end;
 
@@ -742,7 +730,7 @@ implementation
 {$ifdef DONOTCHAINOPERATORS}
         t    : ttoken;
         last : pprocdef;
-{$endif DONOTCHAINOPERATORS}
+{$endif  DONOTCHAINOPERATORS}
         pd : pprocdef;
       begin
          resolvedef(pdef(definition));
@@ -1166,15 +1154,6 @@ implementation
       end;
 
 
-    constructor tabsolutesym.initdef(const n : string;p : pdef);
-      var
-        t : ttype;
-      begin
-        t.setdef(p);
-        tabsolutesym.init(n,t);
-      end;
-
-
     constructor tabsolutesym.load;
       begin
          tvarsym.load;
@@ -1320,15 +1299,6 @@ implementation
       end;
 
 
-    constructor tvarsym.initdef(const n : string;p : pdef);
-      var
-        t : ttype;
-      begin
-        t.setdef(p);
-        tvarsym.init(n,t);
-      end;
-
-
     constructor tvarsym.load;
       begin
          inherited load;
@@ -1944,13 +1914,14 @@ implementation
       end;
 
 
-    constructor tconstsym.init_def(const n : string;t : tconsttyp;v : TConstExprInt;def : pdef);
+    constructor tconstsym.init_typed(const n : string;t : tconsttyp;v : tconstexprint;const tt:ttype);
       begin
          inherited init(n);
          typ:=constsym;
          consttyp:=t;
          value:=v;
-         consttype.setdef(def);
+         ResStrIndex:=0;
+         consttype:=tt;
          len:=0;
       end;
 
@@ -1964,8 +1935,7 @@ implementation
          consttype.reset;
          len:=l;
          if t=constresourcestring then
-           ResStrIndex:=ResourceStrings.Register(name,
-             pchar(tpointerord(value)),len);
+           ResStrIndex:=ResourceStrings.Register(name,pchar(tpointerord(value)),len);
       end;
 
     constructor tconstsym.load;
@@ -2260,74 +2230,23 @@ implementation
 {$ifdef GDB}
          isusedinstab := false;
 {$endif GDB}
-{$ifdef SYNONYM}
-         if assigned(restype.def) then
-          begin
-             if not(assigned(restype.def^.typesym)) then
-               begin
-                  restype.def^.typesym:=@self;
-                  synonym:=nil;
-                  include(symoptions,sp_primary_typesym);
-               end
-             else
-               begin
-                  synonym:=restype.def^.typesym^.synonym;
-                  restype.def^.typesym^.synonym:=@self;
-               end;
-          end;
-{$else}
         { register the typesym for the definition }
         if assigned(restype.def) and
            not(assigned(restype.def^.typesym)) then
          restype.def^.typesym:=@self;
-{$endif}
       end;
 
-    constructor ttypesym.initdef(const n : string;d : pdef);
-      var
-        t : ttype;
-      begin
-        t.setdef(d);
-        ttypesym.init(n,t);
-      end;
 
     constructor ttypesym.load;
       begin
          inherited load;
          typ:=typesym;
-{$ifdef SYNONYM}
-         synonym:=nil;
-{$endif}
 {$ifdef GDB}
          isusedinstab := false;
 {$endif GDB}
          restype.load;
       end;
 
-{$ifdef SYNONYM}
-    destructor ttypesym.done;
-      var
-        prevsym : ptypesym;
-      begin
-         if assigned(restype.def) then
-           begin
-              prevsym:=restype.def^.typesym;
-              if prevsym=@self then
-                restype.def^.typesym:=synonym;
-              while assigned(prevsym) do
-                begin
-                   if (prevsym^.synonym=@self) then
-                     begin
-                        prevsym^.synonym:=synonym;
-                        break;
-                     end;
-                   prevsym:=prevsym^.synonym;
-                end;
-           end;
-         synonym:=nil;
-         inherited done;
-      end;
-{$endif}
 
     function  ttypesym.gettypedef:pdef;
       begin
@@ -2338,31 +2257,6 @@ implementation
     procedure ttypesym.prederef;
       begin
          restype.resolve;
-{$ifdef SYNONYM}
-         if assigned(restype.def) then
-          begin
-            if (sp_primary_typesym in symoptions) then
-              begin
-                 if restype.def^.typesym<>@self then
-                   synonym:=restype.def^.typesym;
-                 restype.def^.typesym:=@self;
-              end
-            else
-              begin
-                 if assigned(restype.def^.typesym) then
-                   begin
-                      synonym:=restype.def^.typesym^.synonym;
-                      if restype.def^.typesym<>@self then
-                        restype.def^.typesym^.synonym:=@self;
-                   end
-                 else
-                   restype.def^.typesym:=@self;
-              end;
-            if (restype.def^.deftype=recorddef) and assigned(precorddef(restype.def)^.symtable) and
-               (restype.def^.typesym=@self) then
-              precorddef(restype.def)^.symtable^.name:=stringdup('record '+name);
-          end;
-{$endif}
       end;
 
 
@@ -2471,7 +2365,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.8  2001-03-11 22:58:51  peter
+  Revision 1.9  2001-04-02 21:20:35  peter
+    * resulttype rewrite
+
+  Revision 1.8  2001/03/11 22:58:51  peter
     * getsym redesign, removed the globals srsym,srsymtable
 
   Revision 1.7  2000/12/25 00:07:30  peter

compiler/symtable.pas

@@ -52,7 +52,6 @@ interface
           procedure loadsyms;
           procedure writedefs;
           procedure writesyms;
-          procedure prederef;
           procedure deref;
           procedure insert(sym : psymentry);virtual;
           procedure insert_in(psymt : psymtable;offset : longint);
@@ -130,7 +129,7 @@ interface
 ****************************************************************************}
 
 {*** Misc ***}
-    function  globaldef(const s : string) : pdef;
+    procedure globaldef(const s : string;var t:ttype);
     function  findunitsymtable(st:psymtable):psymtable;
     procedure duplicatesym(sym:psym);
     procedure identifier_not_found(const s:string);
@@ -737,20 +736,6 @@ implementation
       end;
 
 
-    procedure tstoredsymtable.prederef;
-      var
-        hs : psym;
-      begin
-        { first deref the ttypesyms }
-        hs:=psym(symindex^.first);
-        while assigned(hs) do
-         begin
-           hs^.prederef;
-           hs:=psym(hs^.indexnext);
-         end;
-      end;
-
-
     procedure tstoredsymtable.deref;
       var
         hp : pdef;
@@ -763,6 +748,13 @@ implementation
            hp^.deref;
            hp:=pdef(hp^.indexnext);
          end;
+        { first deref the ttypesyms }
+        hs:=psym(symindex^.first);
+        while assigned(hs) do
+         begin
+           hs^.prederef;
+           hs:=psym(hs^.indexnext);
+         end;
         { deref the symbols }
         hs:=psym(symindex^.first);
         while assigned(hs) do
@@ -885,7 +877,7 @@ implementation
          if not (typ in [localsymtable,parasymtable,recordsymtable,objectsymtable]) then
           begin
             { now we can deref the syms and defs }
-            prederef;
+            deref;
             { restore symtablestack }
             symtablestack:=next;
           end;
@@ -2157,7 +2149,7 @@ implementation
                             Definition Helpers
 *****************************************************************************}
 
-    function globaldef(const s : string) : pdef;
+    procedure globaldef(const s : string;var t:ttype);
 
       var st : string;
           symt : psymtable;
@@ -2187,9 +2179,10 @@ implementation
             (srsym^.typ<>typesym) then
            begin
              Message(type_e_type_id_expected);
+             t:=generrortype;
              exit;
            end;
-         globaldef := pdef(ptypesym(srsym)^.restype.def);
+         t := ptypesym(srsym)^.restype;
       end;
 
 {****************************************************************************
@@ -2354,7 +2347,7 @@ implementation
 {$endif GDB}
      { create error syms and def }
         generrorsym:=new(perrorsym,init);
-        generrordef:=new(perrordef,init);
+        generrortype.setdef(new(perrordef,init));
 {$ifdef UNITALIASES}
      { unit aliases }
         unitaliases:=new(pdictionary,init);
@@ -2367,7 +2360,7 @@ implementation
    procedure DoneSymtable;
       begin
         dispose(generrorsym,done);
-        dispose(generrordef,done);
+        dispose(generrortype.def,done);
 {$ifdef UNITALIASES}
         dispose(unitaliases,done);
 {$endif}
@@ -2376,7 +2369,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.29  2001-03-22 00:10:58  florian
+  Revision 1.30  2001-04-02 21:20:35  peter
+    * resulttype rewrite
+
+  Revision 1.29  2001/03/22 00:10:58  florian
     + basic variant type support in the compiler
 
   Revision 1.28  2001/03/13 18:45:07  peter

compiler/symtype.pas

@@ -312,7 +312,11 @@ implementation
 
     procedure ttype.write;
       begin
-        if assigned(sym) then
+        { Don't write symbol references for the current unit
+          and for the system unit }
+        if assigned(sym) and
+           (sym^.owner^.unitid<>0) and
+           (sym^.owner^.unitid<>1) then
          begin
            writederef(nil);
            writederef(sym);
@@ -558,16 +562,13 @@ implementation
          sym:=nil;
       end;
 
-
-
-
-
-
-
 end.
 {
   $Log$
-  Revision 1.4  2000-12-25 00:07:30  peter
+  Revision 1.5  2001-04-02 21:20:35  peter
+    * resulttype rewrite
+
+  Revision 1.4  2000/12/25 00:07:30  peter
     + new tlinkedlist class (merge of old tstringqueue,tcontainer and
       tlinkedlist objects)
 

compiler/targets/t_win32.pas

@@ -66,7 +66,7 @@ interface
     tDLLScannerWin32=class(tDLLScanner)
     private
       cstring : array[0..127]of char;
-      function DOSstubOK(var x:cardinal):longbool;
+      function DOSstubOK(var x:longint):boolean;
       function FindDLL(const s:string;var founddll:string):boolean;
       function DllName(Const Name : string) : string;
     public
@@ -722,11 +722,9 @@ end;
 
 Function TLinkerWin32.WriteResponseFile(isdll:boolean) : Boolean;
 Var
-  linkres  : TLinkRes;
-  i        : longint;
-  HPath    : TStringListItem;
-  s,s2     : string;
-  found:boolean;
+  linkres : TLinkRes;
+  HPath   : TStringListItem;
+  s       : string;
 begin
   WriteResponseFile:=False;
 
@@ -1149,20 +1147,20 @@ end;
                             TDLLScannerWin32
 ****************************************************************************}
 
-function tDLLScannerWin32.DOSstubOK(var x:cardinal):longbool;
- begin
-  blockread(f,TheWord,2,loaded);
-  if loaded<>2 then
-   DOSstubOK:=false
-  else
-   begin
-    DOSstubOK:=TheWord='MZ';
-    seek(f,$3C);
-    blockread(f,x,4,loaded);
-    if(loaded<>4)or(x>filesize(f))then
-     DOSstubOK:=false;
-   end;
- end;
+    function tDLLScannerWin32.DOSstubOK(var x:longint):boolean;
+      begin
+        blockread(f,TheWord,2,loaded);
+        if loaded<>2 then
+         DOSstubOK:=false
+        else
+         begin
+           DOSstubOK:=(TheWord='MZ');
+           seek(f,$3C);
+           blockread(f,x,4,loaded);
+           if(loaded<>4)or(x>filesize(f))then
+            DOSstubOK:=false;
+         end;
+      end;
 
     function TDLLScannerWin32.FindDLL(const s:string;var founddll:string):boolean;
       var
@@ -1210,7 +1208,7 @@ function tDLLScannerWin32.isSuitableFileType(x:cardinal):longbool;
   isSuitableFileType:=(loaded=2)and(TheWord='PE');
  end;
 
- 
+
 function tDLLScannerWin32.GetEdata(HeaderEntry:cardinal):longbool;
  type
   TObjInfo=packed record
@@ -1256,7 +1254,7 @@ function tDLLScannerWin32.GetEdata(HeaderEntry:cardinal):longbool;
      hp:=tExternalsItem(hp.next);
     end;
   end;
- 
+
  procedure Store(index:cardinal;name:pchar;isData:longbool);
   begin
    if not isUsedFunction(name)then
@@ -1323,7 +1321,7 @@ function tDLLScannerWin32.GetEdata(HeaderEntry:cardinal):longbool;
       begin
        seek(f,RawOffset-VirtAddr+ExpDir.AddrOrds+j*2);
        blockread(f,Ordinal,2);
-       seek(f,RawOffset-VirtAddr+ExpDir.AddrFuncs+Ordinal*4);
+       seek(f,RawOffset-VirtAddr+ExpDir.AddrFuncs+cardinal(Ordinal)*4);
        blockread(f,ProcEntry,4);
        seek(f,RawOffset-VirtAddr+ExpDir.AddrNames+j*4);
        blockread(f,ulongval,4);
@@ -1383,7 +1381,10 @@ function tDLLScannerWin32.scan(const binname:string):longbool;
 end.
 {
   $Log$
-  Revision 1.2  2001-03-06 18:28:02  peter
+  Revision 1.3  2001-04-02 21:20:40  peter
+    * resulttype rewrite
+
+  Revision 1.2  2001/03/06 18:28:02  peter
     * patch from Pavel with a new and much faster DLL Scanner for
       automatic importing so $linklib works for DLLs. Thanks Pavel!
 

compiler/types.pas

@@ -174,9 +174,6 @@ interface
           tc_bool_2_int,
           tc_real_2_real,
           tc_int_2_real,
-          tc_int_2_fix,
-          tc_real_2_fix,
-          tc_fix_2_real,
           tc_proc_2_procvar,
           tc_arrayconstructor_2_set,
           tc_load_smallset,
@@ -194,7 +191,7 @@ interface
        2 - Convertable, but not first choice }
     function isconvertable(def_from,def_to : pdef;
              var doconv : tconverttype;
-             fromtree: tnode; fromtreetype : tnodetype;
+             fromtreetype : tnodetype;
              explicit : boolean) : byte;
 
     { same as is_equal, but with error message if failed }
@@ -389,7 +386,7 @@ implementation
               case acp of
               cp_value_equal_const :
                 begin
-                   if (isconvertable(def1.paratype.def,def2.paratype.def,doconv,nil,callparan,false)=0) or
+                   if (isconvertable(def1.paratype.def,def2.paratype.def,doconv,callparan,false)=0) or
                      ((def1.paratyp<>def2.paratyp) and
                       ((def1.paratyp in [vs_out,vs_var]) or
                        (def2.paratyp in [vs_out,vs_var])
@@ -402,7 +399,7 @@ implementation
                 end;
               cp_all :
                 begin
-                   if (isconvertable(def1.paratype.def,def2.paratype.def,doconv,nil,callparan,false)=0) or
+                   if (isconvertable(def1.paratype.def,def2.paratype.def,doconv,callparan,false)=0) or
                      (def1.paratyp<>def2.paratyp) then
                      begin
                         convertable_paras:=false;
@@ -411,7 +408,7 @@ implementation
                 end;
               cp_none :
                 begin
-                   if (isconvertable(def1.paratype.def,def2.paratype.def,doconv,nil,callparan,false)=0) then
+                   if (isconvertable(def1.paratype.def,def2.paratype.def,doconv,callparan,false)=0) then
                      begin
                         convertable_paras:=false;
                         exit;
@@ -467,9 +464,7 @@ implementation
     { returns true, if def uses FPU }
     function is_fpu(def : pdef) : boolean;
       begin
-         is_fpu:=(def^.deftype=floatdef) and
-                 (pfloatdef(def)^.typ<>f32bit) and
-                 (pfloatdef(def)^.typ<>f16bit);
+         is_fpu:=(def^.deftype=floatdef);
       end;
 
 
@@ -482,7 +477,7 @@ implementation
            orddef :
              begin
                dt:=porddef(def)^.typ;
-               is_ordinal:=dt in [uchar,
+               is_ordinal:=dt in [uchar,uwidechar,
                                   u8bit,u16bit,u32bit,u64bit,
                                   s8bit,s16bit,s32bit,s64bit,
                                   bool8bit,bool16bit,bool32bit];
@@ -591,10 +586,10 @@ implementation
     { true, if p points to an open array def }
     function is_open_array(p : pdef) : boolean;
       begin
-         { check for s32bitdef is needed, because for u32bit the high
+         { check for s32bittype is needed, because for u32bit the high
            range is also -1 ! (PFV) }
          is_open_array:=(p^.deftype=arraydef) and
-                        (parraydef(p)^.rangetype.def=pdef(s32bitdef)) and
+                        (parraydef(p)^.rangetype.def=s32bittype.def) and
                         (parraydef(p)^.lowrange=0) and
                         (parraydef(p)^.highrange=-1) and
                         not(parraydef(p)^.IsConstructor) and
@@ -671,7 +666,7 @@ implementation
     function is_chararray(p : pdef) : boolean;
       begin
         is_chararray:=(p^.deftype=arraydef) and
-                      is_equal(parraydef(p)^.elementtype.def,cchardef) and
+                      is_equal(parraydef(p)^.elementtype.def,cchartype.def) and
                       not(is_special_array(p));
       end;
 
@@ -679,7 +674,7 @@ implementation
     function is_widechararray(p : pdef) : boolean;
       begin
         is_widechararray:=(p^.deftype=arraydef) and
-                      is_equal(parraydef(p)^.elementtype.def,cwidechardef) and
+                      is_equal(parraydef(p)^.elementtype.def,cwidechartype.def) and
                       not(is_special_array(p));
       end;
 
@@ -688,7 +683,7 @@ implementation
     function is_pchar(p : pdef) : boolean;
       begin
         is_pchar:=(p^.deftype=pointerdef) and
-                  (is_equal(ppointerdef(p)^.pointertype.def,cchardef) or
+                  (is_equal(ppointerdef(p)^.pointertype.def,cchartype.def) or
                    (is_zero_based_array(ppointerdef(p)^.pointertype.def) and
                     is_chararray(ppointerdef(p)^.pointertype.def)));
       end;
@@ -697,7 +692,7 @@ implementation
     function is_pwidechar(p : pdef) : boolean;
       begin
         is_pwidechar:=(p^.deftype=pointerdef) and
-                  (is_equal(ppointerdef(p)^.pointertype.def,cwidechardef) or
+                  (is_equal(ppointerdef(p)^.pointertype.def,cwidechartype.def) or
                    (is_zero_based_array(ppointerdef(p)^.pointertype.def) and
                     is_widechararray(ppointerdef(p)^.pointertype.def)));
       end;
@@ -707,7 +702,8 @@ implementation
     function is_voidpointer(p : pdef) : boolean;
       begin
         is_voidpointer:=(p^.deftype=pointerdef) and
-                        is_equal(Ppointerdef(p)^.pointertype.def,voiddef);
+                        (ppointerdef(p)^.pointertype.def^.deftype=orddef) and
+                        (porddef(ppointerdef(p)^.pointertype.def)^.typ=uvoid);
       end;
 
 
@@ -726,8 +722,7 @@ implementation
                      ((def^.deftype=stringdef) and (pstringdef(def)^.string_typ in [st_ansistring,st_widestring])) or
                      ((def^.deftype=procvardef) and not(po_methodpointer in pprocvardef(def)^.procoptions)) or
                      ((def^.deftype=objectdef) and not is_object(def)) or
-                     ((def^.deftype=setdef) and (psetdef(def)^.settype=smallset)) or
-                     ((def^.deftype=floatdef) and (pfloatdef(def)^.typ=f32bit));
+                     ((def^.deftype=setdef) and (psetdef(def)^.settype=smallset));
       end;
 
 
@@ -844,7 +839,7 @@ implementation
              2: l := l and $ffff;
              { work around sign extension bug (to be fixed) (JM) }
              4: l := l and (int64($fffffff) shl 4 + $f);
-           end
+           end;
       end;
 
 
@@ -882,8 +877,6 @@ implementation
                 case pfloatdef(parraydef(p)^.elementtype.def)^.typ of
                   s32real:
                     mmx_type:=mmxsingle;
-                  f16bit:
-                    mmx_type:=mmxfixed16
                 end
               else
                 case porddef(parraydef(p)^.elementtype.def)^.typ of
@@ -932,11 +925,6 @@ implementation
                 (
                  (
                   (parraydef(p)^.elementtype.def^.deftype=floatdef) and
-                  (
-                   (parraydef(p)^.lowrange=0) and
-                   (parraydef(p)^.highrange=3) and
-                   (pfloatdef(parraydef(p)^.elementtype.def)^.typ=f16bit)
-                  ) or
                   (
                    (parraydef(p)^.lowrange=0) and
                    (parraydef(p)^.highrange=1) and
@@ -976,17 +964,9 @@ implementation
                  (
                   (parraydef(p)^.elementtype.def^.deftype=floatdef) and
                   (
-                   (
-                    (parraydef(p)^.lowrange=0) and
-                    (parraydef(p)^.highrange=3) and
-                    (pfloatdef(parraydef(p)^.elementtype.def)^.typ=f32bit)
-                   )
-                   or
-                   (
-                    (parraydef(p)^.lowrange=0) and
-                    (parraydef(p)^.highrange=1) and
-                    (pfloatdef(parraydef(p)^.elementtype.def)^.typ=s32real)
-                   )
+                   (parraydef(p)^.lowrange=0) and
+                   (parraydef(p)^.highrange=1) and
+                   (pfloatdef(parraydef(p)^.elementtype.def)^.typ=s32real)
                   )
                  )
                 );
@@ -1084,8 +1064,8 @@ implementation
                   (pfiledef(def2)^.typedfiletype.def<>nil) and
                   is_equal(pfiledef(def1)^.typedfiletype.def,pfiledef(def2)^.typedfiletype.def)
                  ) or
-                 ( (pfiledef(def1)^.typedfiletype.def=pdef(voiddef)) or
-                   (pfiledef(def2)^.typedfiletype.def=pdef(voiddef))
+                 ( (pfiledef(def1)^.typedfiletype.def=pdef(voidtype.def)) or
+                   (pfiledef(def2)^.typedfiletype.def=pdef(voidtype.def))
                  )))
          { sets with the same element base type are equal }
          else
@@ -1214,7 +1194,7 @@ implementation
             begin
               if is_equal(passproc^.rettype.def,to_def) and
                  (is_equal(TParaItem(passproc^.Para.first).paratype.def,from_def) or
-                 (isconvertable(from_def,TParaItem(passproc^.Para.first).paratype.def,convtyp,nil,ordconstn,false)=1)) then
+                 (isconvertable(from_def,TParaItem(passproc^.Para.first).paratype.def,convtyp,ordconstn,false)=1)) then
                 begin
                    assignment_overloaded:=passproc;
                    break;
@@ -1230,7 +1210,7 @@ implementation
        2 - Convertable, but not first choice }
     function isconvertable(def_from,def_to : pdef;
              var doconv : tconverttype;
-             fromtree: tnode; fromtreetype : tnodetype;
+             fromtreetype : tnodetype;
              explicit : boolean) : byte;
 
       { Tbasetype:  uauto,uvoid,uchar,
@@ -1366,10 +1346,7 @@ implementation
                    begin { ordinal to real }
                      if is_integer(def_from) then
                        begin
-                          if pfloatdef(def_to)^.typ=f32bit then
-                            doconv:=tc_int_2_fix
-                          else
-                            doconv:=tc_int_2_real;
+                          doconv:=tc_int_2_real;
                           b:=1;
                        end;
                    end;
@@ -1378,15 +1355,7 @@ implementation
                      if pfloatdef(def_from)^.typ=pfloatdef(def_to)^.typ then
                        doconv:=tc_equal
                      else
-                       begin
-                          if pfloatdef(def_from)^.typ=f32bit then
-                            doconv:=tc_fix_2_real
-                          else
-                            if pfloatdef(def_to)^.typ=f32bit then
-                              doconv:=tc_real_2_fix
-                            else
-                              doconv:=tc_real_2_real;
-                       end;
+                       doconv:=tc_real_2_real;
                      b:=1;
                    end;
                end;
@@ -1437,7 +1406,7 @@ implementation
                             end
                            else
                             if isconvertable(parraydef(def_from)^.elementtype.def,
-                                             parraydef(def_to)^.elementtype.def,hct,nil,arrayconstructorn,false)<>0 then
+                                             parraydef(def_to)^.elementtype.def,hct,arrayconstructorn,false)<>0 then
                              begin
                                doconv:=hct;
                                b:=2;
@@ -1504,7 +1473,7 @@ implementation
                      { char constant to zero terminated string constant }
                      if (fromtreetype=ordconstn) then
                       begin
-                        if is_equal(def_from,cchardef) and
+                        if is_equal(def_from,cchartype.def) and
                            is_pchar(def_to) then
                          begin
                            doconv:=tc_cchar_2_pchar;
@@ -1538,10 +1507,10 @@ implementation
                            pobjectdef(ppointerdef(def_to)^.pointertype.def))
                         ) or
                         { all pointers can be assigned to void-pointer }
-                        is_equal(ppointerdef(def_to)^.pointertype.def,voiddef) or
+                        is_equal(ppointerdef(def_to)^.pointertype.def,voidtype.def) or
                         { in my opnion, is this not clean pascal }
                         { well, but it's handy to use, it isn't ? (FK) }
-                        is_equal(ppointerdef(def_from)^.pointertype.def,voiddef) then
+                        is_equal(ppointerdef(def_from)^.pointertype.def,voidtype.def) then
                        begin
                          { but don't allow conversion between farpointer-pointer }
                          if (ppointerdef(def_to)^.is_far=ppointerdef(def_from)^.is_far) then
@@ -1656,6 +1625,15 @@ implementation
                      begin
                         doconv:=tc_class_2_intf;
                         b:=1;
+                     end
+                   { Interface 2 GUID handling }
+                   else if (def_to=pdef(rec_tguid)) and
+                           (fromtreetype=typen) and
+                           is_interface(def_from) and
+                           pobjectdef(def_from)^.isiidguidvalid then
+                     begin
+                       b:=1;
+                       doconv:=tc_equal;
                      end;
                  end;
              end;
@@ -1694,8 +1672,8 @@ implementation
                     (pfiledef(def_from)^.filetyp = ft_typed) and
                     (pfiledef(def_to)^.filetyp = ft_typed) and
                     (
-                     (pfiledef(def_from)^.typedfiletype.def = pdef(voiddef)) or
-                     (pfiledef(def_to)^.typedfiletype.def = pdef(voiddef))
+                     (pfiledef(def_from)^.typedfiletype.def = pdef(voidtype.def)) or
+                     (pfiledef(def_to)^.typedfiletype.def = pdef(voidtype.def))
                     )
                    ) or
                    (
@@ -1717,20 +1695,9 @@ implementation
 
            else
              begin
-                { Interface 2 GUID handling }
-                if (def_from^.deftype=errordef) and (def_to=pdef(rec_tguid)) and
-                   assigned(fromtree) and (fromtree.nodetype=typen) and
-                   assigned(ttypenode(fromtree).typenodetype) and
-                   is_interface(ttypenode(fromtree).typenodetype) and
-                   pobjectdef(ttypenode(fromtree).typenodetype)^.isiidguidvalid then
-                  begin
-                    b:=1;
-                    doconv:=tc_equal;
-                  end
-                else
-                  { assignment overwritten ?? }
-                  if assignment_overloaded(def_from,def_to)<>nil then
-                    b:=2;
+               { assignment overwritten ?? }
+               if assignment_overloaded(def_from,def_to)<>nil then
+                 b:=2;
              end;
          end;
         isconvertable:=b;
@@ -1766,7 +1733,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.36  2001-03-23 00:16:07  florian
+  Revision 1.37  2001-04-02 21:20:35  peter
+    * resulttype rewrite
+
+  Revision 1.36  2001/03/23 00:16:07  florian
     + some stuff to compile FreeCLX added
 
   Revision 1.35  2001/03/03 12:38:33  jonas

compiler/widestr.pas

@@ -124,7 +124,8 @@ unit widestr;
     function comparewidestringwidestring(const s1,s2 : tcompilerwidestring) : longint;
 
       begin
-         { !!!! }
+        {$warning todo}
+        comparewidestringwidestring:=0;
       end;
 
     procedure copywidestring(const s : tcompilerwidestring;var d : tcompilerwidestring);
@@ -146,10 +147,12 @@ unit widestr;
       end;
 }
       begin
+        {$warning todo}
+        asciichar2unicode:=0;
       end;
 
     procedure ascii2unicode(const s : string;var r : tcompilerwidestring);
-{!!!!!!
+(*
       var
          m : punicodemap;
          i : longint;
@@ -163,7 +166,7 @@ unit widestr;
            begin
            end;
       end;
-}
+*)
       begin
       end;
 
@@ -175,13 +178,17 @@ unit widestr;
 }
 
       begin
+        cpavailable:=false;
       end;
 
 end.
 {
   $Log$
-  Revision 1.1  2000-11-29 00:30:43  florian
+  Revision 1.2  2001-04-02 21:20:35  peter
+    * resulttype rewrite
+
+  Revision 1.1  2000/11/29 00:30:43  florian
     * unused units removed from uses clause
     * some changes for widestrings
 
-}
+}