* merged

compiler/pexpr.pas

@@ -109,6 +109,29 @@ unit pexpr;
       end;
 
 
+    procedure check_tp_procvar(var p : ptree);
+      var
+         p1 : ptree;
+      begin
+         if (m_tp_procvar in aktmodeswitches) and
+{            (not afterassignment) and }
+            (not in_args) and
+            (p^.treetype in [loadn]) then
+            begin
+               { support if procvar then for tp7 and many other expression like this }
+               firstpass(p);
+               if p^.resulttype^.deftype=procvardef then
+                 begin
+                    p1:=gencallnode(nil,nil);
+                    p1^.right:=p;
+                    p1^.resulttype:=pprocvardef(p^.resulttype)^.retdef;
+                    firstpass(p1);
+                    p:=p1;
+                 end;
+            end;
+      end;
+
+
     function statement_syssym(l : longint;var pd : pdef) : ptree;
       var
         p1,p2,paras  : ptree;
@@ -539,21 +562,14 @@ unit pexpr;
       var
         hp : ptree;
       begin
-         hp:=nil;
-         if ((procvar^.options and pomethodpointer)<>0) then
-           begin
-              if assigned(t^.methodpointer) and
-                 (t^.methodpointer^.resulttype^.deftype=objectdef) and
-                 (pobjectdef(t^.methodpointer^.resulttype)^.isclass) and
-                 (proc_to_procvar_equal(pprocsym(t^.symtableentry)^.definition,procvar)) then
-                hp:=genloadmethodcallnode(pprocsym(t^.symtableprocentry),t^.symtable,getcopy(t^.methodpointer))
-              else
-                Message(type_e_mismatch);
-           end
-         else if (proc_to_procvar_equal(pprocsym(t^.symtableentry)^.definition,getprocvardef)) then
-           begin
-              hp:=genloadcallnode(pprocsym(t^.symtableprocentry),t^.symtable);
-           end;
+        hp:=nil;
+        if (proc_to_procvar_equal(pprocsym(t^.symtableentry)^.definition,procvar)) then
+         begin
+           if ((procvar^.options and pomethodpointer)<>0) then
+             hp:=genloadmethodcallnode(pprocsym(t^.symtableprocentry),t^.symtable,getcopy(t^.methodpointer))
+           else
+             hp:=genloadcallnode(pprocsym(t^.symtableprocentry),t^.symtable);
+         end;
         if assigned(hp) then
          begin
            disposetree(t);
@@ -606,10 +622,16 @@ unit pexpr;
                         { read the expression }
                         getprocvar:=ppropertysym(sym)^.proptype^.deftype=procvardef;
                         p2:=comp_expr(true);
-                        if (p2^.treetype<>errorn) and getprocvar then
-                          handle_procvar(pprocvardef(ppropertysym(sym)^.proptype),p2);
+                        if getprocvar then
+                         begin
+                           if (p2^.treetype=calln) then
+                            handle_procvar(pprocvardef(ppropertysym(sym)^.proptype),p2)
+                           else
+                            if (p2^.treetype=typeconvn) and
+                               (p2^.left^.treetype=calln) then
+                             handle_procvar(pprocvardef(ppropertysym(sym)^.proptype),p2^.left);
+                         end;
                         p1^.left:=gencallparanode(p2,p1^.left);
-{                       firstcallparan(p1^.left,nil); }
                         getprocvar:=false;
                      end
                    else if ppropertysym(sym)^.writeaccesssym^.typ=varsym then
@@ -1763,6 +1785,9 @@ unit pexpr;
         { generate error node if no node is created }
         if not assigned(p1) then
           p1:=genzeronode(errorn);
+         { tp7 procvar handling }
+         if (m_tp_procvar in aktmodeswitches) then
+           check_tp_procvar(p1);
         factor:=p1;
         check_tokenpos;
       end;
@@ -1858,27 +1883,6 @@ unit pexpr;
         sub_expr:=p1;
       end;
 
-    procedure check_tp_procvar(var p : ptree);
-      var
-         p1 : ptree;
-      begin
-         if (m_tp_procvar in aktmodeswitches) and
-            (not afterassignment) and
-            (not in_args) and (p^.treetype=loadn) then
-            begin
-               { support if procvar then for tp7 and many other expression like this }
-               firstpass(p);
-               if p^.resulttype^.deftype=procvardef then
-                 begin
-                    p1:=gencallnode(nil,nil);
-                    p1^.right:=p;
-                    p1^.resulttype:=pprocvardef(p^.resulttype)^.retdef;
-                    firstpass(p1);
-                    p:=p1;
-                 end;
-            end;
-      end;
-
 
     function comp_expr(accept_equal : boolean):Ptree;
       var
@@ -1889,8 +1893,6 @@ unit pexpr;
          afterassignment:=true;
          p1:=sub_expr(opcompare,accept_equal);
          afterassignment:=oldafterassignment;
-         if (m_tp_procvar in aktmodeswitches) then
-           check_tp_procvar(p1);
          comp_expr:=p1;
       end;
 
@@ -1929,12 +1931,16 @@ unit pexpr;
                                  getprocvardef:=pprocvardef(p1^.resulttype);
                               end;
                             p2:=sub_expr(opcompare,true);
-                            if getprocvar and (p2^.treetype=calln) then
-                              handle_procvar(getprocvardef,p2);
-                            { also allow p:= proc(t); !! (PM) }
-                            if getprocvar and (p2^.treetype=typeconvn) and
-                               (p2^.left^.treetype=calln) then
-                              handle_procvar(getprocvardef,p2^.left);
+                            if getprocvar then
+                             begin
+                               if (p2^.treetype=calln) then
+                                handle_procvar(getprocvardef,p2)
+                               else
+                                { also allow p:= proc(t); !! (PM) }
+                                if (p2^.treetype=typeconvn) and
+                                   (p2^.left^.treetype=calln) then
+                                 handle_procvar(getprocvardef,p2^.left);
+                             end;
                             getprocvar:=false;
                             p1:=gennode(assignn,p1,p2);
                          end;
@@ -2018,9 +2024,15 @@ unit pexpr;
 end.
 {
   $Log$
-  Revision 1.113  1999-06-13 22:41:05  peter
+  Revision 1.114  1999-06-15 18:58:33  peter
+    * merged
+
+  Revision 1.113  1999/06/13 22:41:05  peter
     * merged from fixes
 
+  Revision 1.112.2.2  1999/06/15 18:54:52  peter
+    * more procvar fixes
+
   Revision 1.112.2.1  1999/06/13 22:38:09  peter
     * tp_procvar check for loading of procvars when getaddr=false
 

compiler/tccnv.pas

@@ -643,182 +643,181 @@ implementation
            own resulttype. They will therefore always be incompatible with
            a procvar. Because isconvertable cannot check for procedures we
            use an extra check for them.}
-           if (p^.resulttype^.deftype=procvardef) and
-              ((m_tp_procvar in aktmodeswitches) or
-              { method pointer use always the TP syntax }
-               ((pprocvardef(p^.resulttype)^.options and pomethodpointer)<>0)
-              ) and
-             ((is_procsym_load(p^.left) or is_procsym_call(p^.left))) then
-             begin
-                if is_procsym_call(p^.left) then
+           if (m_tp_procvar in aktmodeswitches) then
+            begin
+              if (p^.resulttype^.deftype=procvardef) and
+                 (is_procsym_load(p^.left) or is_procsym_call(p^.left)) then
+               begin
+                 if is_procsym_call(p^.left) then
                   begin
-                     if p^.left^.right=nil then
-                       begin
-                          p^.left^.treetype:=loadn;
-                          { are at same offset so this could be spared, but
-                          it more secure to do it anyway }
-                          p^.left^.symtableentry:=p^.left^.symtableprocentry;
-                          p^.left^.resulttype:=pprocsym(p^.left^.symtableentry)^.definition;
-                          aprocdef:=pprocdef(p^.left^.resulttype);
-                       end
-                     else
-                       begin
-                          p^.left^.right^.treetype:=loadn;
-                          p^.left^.right^.symtableentry:=p^.left^.right^.symtableentry;
-                          P^.left^.right^.resulttype:=pvarsym(p^.left^.symtableentry)^.definition;
-                          hp:=p^.left^.right;
-                          putnode(p^.left);
-                          p^.left:=hp;
-                          { should we do that ? }
-                          firstpass(p^.left);
-                          if not is_equal(p^.left^.resulttype,p^.resulttype) then
-                            begin
-                               CGMessage(type_e_mismatch);
-                               exit;
-                            end
-                          else
-                            begin
-                               hp:=p;
-                               p:=p^.left;
-                               p^.resulttype:=hp^.resulttype;
-                               putnode(hp);
-                               exit;
-                            end;
-                       end;
+                    if p^.left^.right=nil then
+                     begin
+                       p^.left^.treetype:=loadn;
+                       { are at same offset so this could be spared, but
+                       it more secure to do it anyway }
+                       p^.left^.symtableentry:=p^.left^.symtableprocentry;
+                       p^.left^.resulttype:=pprocsym(p^.left^.symtableentry)^.definition;
+                       aprocdef:=pprocdef(p^.left^.resulttype);
+                     end
+                    else
+                     begin
+                       p^.left^.right^.treetype:=loadn;
+                       p^.left^.right^.symtableentry:=p^.left^.right^.symtableentry;
+                       P^.left^.right^.resulttype:=pvarsym(p^.left^.symtableentry)^.definition;
+                       hp:=p^.left^.right;
+                       putnode(p^.left);
+                       p^.left:=hp;
+                       { should we do that ? }
+                       firstpass(p^.left);
+                       if not is_equal(p^.left^.resulttype,p^.resulttype) then
+                        begin
+                          CGMessage(type_e_mismatch);
+                          exit;
+                        end
+                       else
+                        begin
+                          hp:=p;
+                          p:=p^.left;
+                          p^.resulttype:=hp^.resulttype;
+                          putnode(hp);
+                          exit;
+                        end;
+                     end;
                   end
-                else
+                 else
                   begin
                     if (p^.left^.treetype<>addrn) then
                       aprocdef:=pprocsym(p^.left^.symtableentry)^.definition;
                   end;
-
-                p^.convtyp:=tc_proc_2_procvar;
-                { Now check if the procedure we are going to assign to
-                  the procvar,  is compatible with the procvar's type }
-                if assigned(aprocdef) then
+                 p^.convtyp:=tc_proc_2_procvar;
+                 { Now check if the procedure we are going to assign to
+                   the procvar,  is compatible with the procvar's type }
+                 if assigned(aprocdef) then
                   begin
-                    if proc_to_procvar_equal(aprocdef,pprocvardef(p^.resulttype)) then
+                    if not proc_to_procvar_equal(aprocdef,pprocvardef(p^.resulttype)) then
                      CGMessage2(type_e_incompatible_types,aprocdef^.typename,p^.resulttype^.typename);
                     firstconvert[p^.convtyp](p);
                   end
-                else
+                 else
                   CGMessage2(type_e_incompatible_types,p^.left^.resulttype^.typename,p^.resulttype^.typename);
-                exit;
-             end
-           else
-             begin
-                if p^.explizit then
-                  begin
-                     { boolean to byte are special because the
-                       location can be different }
+                 exit;
+               end;
+            end;
+           if p^.explizit then
+            begin
+              { boolean to byte are special because the
+                location can be different }
+              if is_integer(p^.resulttype) and
+                 is_boolean(p^.left^.resulttype) then
+               begin
+                  p^.convtyp:=tc_bool_2_int;
+                  firstconvert[p^.convtyp](p);
+                  exit;
+               end;
+              { ansistring to pchar }
+              if is_pchar(p^.resulttype) and
+                 is_ansistring(p^.left^.resulttype) then
+               begin
+                 p^.convtyp:=tc_ansistring_2_pchar;
+                 firstconvert[p^.convtyp](p);
+                 exit;
+               end;
+              { do common tc_equal cast }
+              p^.convtyp:=tc_equal;
 
-                     if is_integer(p^.resulttype) and
-                        is_boolean(p^.left^.resulttype) then
-                       begin
-                          p^.convtyp:=tc_bool_2_int;
-                          firstconvert[p^.convtyp](p);
-                          exit;
-                       end;
-                     if is_pchar(p^.resulttype) and
-                        is_ansistring(p^.left^.resulttype) then
-                       begin
-                          p^.convtyp:=tc_ansistring_2_pchar;
-                          firstconvert[p^.convtyp](p);
-                          exit;
-                       end;
-                     { do common tc_equal cast }
-                     p^.convtyp:=tc_equal;
-                     { wenn Aufz„hltyp nach Ordinal konvertiert werden soll }
-                     { dann Aufz„hltyp=s32bit                          }
-                     if (p^.left^.resulttype^.deftype=enumdef) and
-                        is_ordinal(p^.resulttype) then
-                       begin
-                          if p^.left^.treetype=ordconstn then
-                            begin
-                               hp:=genordinalconstnode(p^.left^.value,p^.resulttype);
-                               disposetree(p);
-                               firstpass(hp);
-                               p:=hp;
-                               exit;
-                            end
-                          else
-                            begin
-                               if isconvertable(s32bitdef,p^.resulttype,p^.convtyp,ordconstn,false)=0 then
-                                 CGMessage(cg_e_illegal_type_conversion);
-                            end;
+              { enum to ordinal will always be s32bit }
+              if (p^.left^.resulttype^.deftype=enumdef) and
+                 is_ordinal(p^.resulttype) then
+               begin
+                 if p^.left^.treetype=ordconstn then
+                  begin
+                    hp:=genordinalconstnode(p^.left^.value,p^.resulttype);
+                    disposetree(p);
+                    firstpass(hp);
+                    p:=hp;
+                    exit;
+                  end
+                 else
+                  begin
+                    if isconvertable(s32bitdef,p^.resulttype,p^.convtyp,ordconstn,false)=0 then
+                      CGMessage(cg_e_illegal_type_conversion);
+                  end;
+               end
 
-                       end
-                     { ordinal to enumeration }
-                     else
-                       if (p^.resulttype^.deftype=enumdef) and
-                          is_ordinal(p^.left^.resulttype) then
-                         begin
-                            if p^.left^.treetype=ordconstn then
-                              begin
-                                 hp:=genordinalconstnode(p^.left^.value,p^.resulttype);
-                                 disposetree(p);
-                                 firstpass(hp);
-                                 p:=hp;
-                                 exit;
-                              end
-                            else
-                              begin
-                                 if IsConvertable(p^.left^.resulttype,s32bitdef,p^.convtyp,ordconstn,false)=0 then
-                                   CGMessage(cg_e_illegal_type_conversion);
-                              end;
-                         end
-                     {Are we typecasting an ordconst to a char?}
-                     else
-                       if is_char(p^.resulttype) and
-                          is_ordinal(p^.left^.resulttype) then
-                         begin
-                            if p^.left^.treetype=ordconstn then
-                              begin
-                                 hp:=genordinalconstnode(p^.left^.value,p^.resulttype);
-                                 firstpass(hp);
-                                 disposetree(p);
-                                 p:=hp;
-                                 exit;
-                              end
-                            else
-                              begin
-                                 { this is wrong because it converts to a 4 byte long var !!
-                                   if not isconvertable(p^.left^.resulttype,s32bitdef,p^.convtyp,ordconstn  nur Dummy ) then }
-                                 if IsConvertable(p^.left^.resulttype,u8bitdef,p^.convtyp,ordconstn,false)=0 then
-                                   CGMessage(cg_e_illegal_type_conversion);
-                              end;
-                         end
-                     { only if the same size or formal def }
-                     { why do we allow typecasting of voiddef ?? (PM) }
-                     else
-                       begin
-                          if not(
-                             (p^.left^.resulttype^.deftype=formaldef) or
-                             (p^.left^.resulttype^.size=p^.resulttype^.size) or
-                             (is_equal(p^.left^.resulttype,voiddef)  and
-                             (p^.left^.treetype=derefn))
-                             ) then
-                             CGMessage(cg_e_illegal_type_conversion);
-                          if ((p^.left^.resulttype^.deftype=orddef) and
-                             (p^.resulttype^.deftype=pointerdef)) or
-                             ((p^.resulttype^.deftype=orddef) and
-                             (p^.left^.resulttype^.deftype=pointerdef))
-                             {$ifdef extdebug}and (p^.firstpasscount=0){$endif} then
-                               CGMessage(cg_d_pointer_to_longint_conv_not_portable);
-                       end;
-                     { the conversion into a strutured type is only }
-                     { possible, if the source is no register    }
-                     if ((p^.resulttype^.deftype in [recorddef,stringdef,arraydef]) or
-                         ((p^.resulttype^.deftype=objectdef) and not(pobjectdef(p^.resulttype)^.isclass))
-                        ) and (p^.left^.location.loc in [LOC_REGISTER,LOC_CREGISTER]) and
-                        {it also works if the assignment is overloaded }
-                        not is_assignment_overloaded(p^.left^.resulttype,p^.resulttype) then
+              { ordinal to enumeration }
+              else
+               if (p^.resulttype^.deftype=enumdef) and
+                  is_ordinal(p^.left^.resulttype) then
+                begin
+                  if p^.left^.treetype=ordconstn then
+                   begin
+                     hp:=genordinalconstnode(p^.left^.value,p^.resulttype);
+                     disposetree(p);
+                     firstpass(hp);
+                     p:=hp;
+                     exit;
+                   end
+                  else
+                   begin
+                     if IsConvertable(p^.left^.resulttype,s32bitdef,p^.convtyp,ordconstn,false)=0 then
                        CGMessage(cg_e_illegal_type_conversion);
+                   end;
                 end
+
+              {Are we typecasting an ordconst to a char?}
               else
-                CGMessage2(type_e_incompatible_types,p^.left^.resulttype^.typename,p^.resulttype^.typename);
-           end
+                if is_char(p^.resulttype) and
+                   is_ordinal(p^.left^.resulttype) then
+                 begin
+                   if p^.left^.treetype=ordconstn then
+                    begin
+                      hp:=genordinalconstnode(p^.left^.value,p^.resulttype);
+                      firstpass(hp);
+                      disposetree(p);
+                      p:=hp;
+                      exit;
+                    end
+                   else
+                    begin
+                      { this is wrong because it converts to a 4 byte long var !!
+                      if not isconvertable(p^.left^.resulttype,s32bitdef,p^.convtyp,ordconstn  nur Dummy ) then }
+                      if IsConvertable(p^.left^.resulttype,u8bitdef,p^.convtyp,ordconstn,false)=0 then
+                        CGMessage(cg_e_illegal_type_conversion);
+                    end;
+                 end
+
+               { only if the same size or formal def }
+               { why do we allow typecasting of voiddef ?? (PM) }
+               else
+                begin
+                  if not(
+                     (p^.left^.resulttype^.deftype=formaldef) or
+                     (p^.left^.resulttype^.size=p^.resulttype^.size) or
+                     (is_equal(p^.left^.resulttype,voiddef)  and
+                     (p^.left^.treetype=derefn))
+                     ) then
+                    CGMessage(cg_e_illegal_type_conversion);
+                  if ((p^.left^.resulttype^.deftype=orddef) and
+                      (p^.resulttype^.deftype=pointerdef)) or
+                      ((p^.resulttype^.deftype=orddef) and
+                       (p^.left^.resulttype^.deftype=pointerdef))
+                       {$ifdef extdebug}and (p^.firstpasscount=0){$endif} then
+                    CGMessage(cg_d_pointer_to_longint_conv_not_portable);
+                end;
+
+               { the conversion into a strutured type is only }
+               { possible, if the source is no register    }
+               if ((p^.resulttype^.deftype in [recorddef,stringdef,arraydef]) or
+                   ((p^.resulttype^.deftype=objectdef) and not(pobjectdef(p^.resulttype)^.isclass))
+                  ) and (p^.left^.location.loc in [LOC_REGISTER,LOC_CREGISTER]) and
+                  {it also works if the assignment is overloaded }
+                  not is_assignment_overloaded(p^.left^.resulttype,p^.resulttype) then
+                 CGMessage(cg_e_illegal_type_conversion);
+            end
+           else
+            CGMessage2(type_e_incompatible_types,p^.left^.resulttype^.typename,p^.resulttype^.typename);
          end;
+
         { ordinal contants can be directly converted }
         if (p^.left^.treetype=ordconstn) and is_ordinal(p^.resulttype) then
           begin
@@ -913,9 +912,15 @@ implementation
 end.
 {
   $Log$
-  Revision 1.36  1999-06-13 22:41:06  peter
+  Revision 1.37  1999-06-15 18:58:35  peter
+    * merged
+
+  Revision 1.36  1999/06/13 22:41:06  peter
     * merged from fixes
 
+  Revision 1.35.2.2  1999/06/15 18:54:53  peter
+    * more procvar fixes
+
   Revision 1.35.2.1  1999/06/13 22:39:19  peter
     * use proc_to_procvar_equal
 

compiler/tcinl.pas

@@ -612,8 +612,8 @@ implementation
                                 if assigned(hp^.left^.resulttype) then
                                   begin
                                     isreal:=false;
-                                    { support writeln(procvar) for tp7 }
-                                    if (m_tp_procvar in aktmodeswitches) and (hp^.left^.resulttype^.deftype=procvardef) then
+                                    { support writeln(procvar) }
+                                    if (hp^.left^.resulttype^.deftype=procvardef) then
                                      begin
                                        p1:=gencallnode(nil,nil);
                                        p1^.right:=hp^.left;
@@ -1101,7 +1101,13 @@ implementation
 end.
 {
   $Log$
-  Revision 1.35  1999-05-27 19:45:19  peter
+  Revision 1.36  1999-06-15 18:58:36  peter
+    * merged
+
+  Revision 1.35.2.1  1999/06/15 18:54:54  peter
+    * more procvar fixes
+
+  Revision 1.35  1999/05/27 19:45:19  peter
     * removed oldasm
     * plabel -> pasmlabel
     * -a switches to source writing automaticly