* removed funcretn,funcretsym, function result is now in varsym

    and aliases for result and function name are added using absolutesym
  * vs_hidden parameter for funcret passed in parameter
  * vs_hidden fixes
  * writenode changed to printnode and released from extdebug
  * -vp option added to generate a tree.log with the nodetree
  * nicer printnode for statements, callnode

compiler/aasmtai.pas

@@ -390,6 +390,7 @@ interface
           constructor allocinfo(pos,size:longint;const st:string);
 {$endif EXTDEBUG}
           constructor ppuload(t:taitype;ppufile:tcompilerppufile);override;
+          destructor destroy;override;
           procedure ppuwrite(ppufile:tcompilerppufile);override;
        end;
 
@@ -418,9 +419,9 @@ interface
           oper      : array[0..max_operands-1] of toper;
           { Actual opcode of instruction }
           opcode    : tasmop;
-{$ifdef i386}
+{$ifdef x86}
           segprefix : tregister;
-{$endif i386}
+{$endif x86}
           { true if instruction is a jmp }
           is_jmp    : boolean; { is this instruction a jump? (needed for optimizer) }
           Constructor Create(op : tasmop);
@@ -1361,6 +1362,15 @@ uses
       end;
 
 
+    destructor tai_tempalloc.destroy;
+      begin
+{$ifdef EXTDEBUG}
+        stringdispose(problem);
+{$endif EXTDEBUG}
+        inherited destroy;
+      end;
+
+
     constructor tai_tempalloc.dealloc(pos,size:longint);
       begin
         inherited Create;
@@ -1816,7 +1826,19 @@ uses
 end.
 {
   $Log$
-  Revision 1.25  2003-04-25 08:25:26  daniel
+  Revision 1.27  2003-04-25 20:59:33  peter
+    * removed funcretn,funcretsym, function result is now in varsym
+      and aliases for result and function name are added using absolutesym
+    * vs_hidden parameter for funcret passed in parameter
+    * vs_hidden fixes
+    * writenode changed to printnode and released from extdebug
+    * -vp option added to generate a tree.log with the nodetree
+    * nicer printnode for statements, callnode
+
+  Revision 1.26  2002/04/25 16:12:09  florian
+    * fixed more problems with cpubase and x86-64
+
+  Revision 1.25  2003/04/25 08:25:26  daniel
     * Ifdefs around a lot of calls to cleartempgen
     * Fixed registers that are allocated but not freed in several nodes
     * Tweak to register allocator to cause less spills

compiler/aggas.pas

@@ -400,8 +400,8 @@ var
                  begin
 {$ifdef EXTDEBUG}
                    if assigned(tai_tempalloc(hp).problem) then
-                     AsmWriteLn(target_asm.comment+tai_tempalloc(hp).problem^+' ('+tostr(tai_tempalloc(hp).temppos)+','+
-                       tostr(tai_tempalloc(hp).tempsize)+')')
+                     AsmWriteLn(target_asm.comment+'Temp '+tostr(tai_tempalloc(hp).temppos)+','+
+                       tostr(tai_tempalloc(hp).tempsize)+' '+tai_tempalloc(hp).problem^)
                    else
 {$endif EXTDEBUG}
                      AsmWriteLn(target_asm.comment+'Temp '+tostr(tai_tempalloc(hp).temppos)+','+
@@ -813,7 +813,16 @@ var
 end.
 {
   $Log$
-  Revision 1.22  2003-04-24 22:29:57  florian
+  Revision 1.23  2003-04-25 20:59:33  peter
+    * removed funcretn,funcretsym, function result is now in varsym
+      and aliases for result and function name are added using absolutesym
+    * vs_hidden parameter for funcret passed in parameter
+    * vs_hidden fixes
+    * writenode changed to printnode and released from extdebug
+    * -vp option added to generate a tree.log with the nodetree
+    * nicer printnode for statements, callnode
+
+  Revision 1.22  2003/04/24 22:29:57  florian
     * fixed a lot of PowerPC related stuff
 
   Revision 1.21  2003/04/22 14:33:38  peter

compiler/cgbase.pas

@@ -172,10 +172,8 @@ unit cgbase;
           }
           procedure after_pass1;virtual;
 
-(*        done by symtablestack.insertvardata() (JM)
           { sets the offset for a temp used by the result }
           procedure set_result_offset;virtual;
-*)
        end;
 
        pregvarinfo = ^tregvarinfo;
@@ -437,14 +435,6 @@ implementation
            begin
               if paramanager.ret_in_reg(procdef.rettype.def,procdef.proccalloption) then
                 begin
-(* already done in symtable.pas:tlocalsymtable.insertvardata() (JM)
-                   { the space has been set in the local symtable }
-                   procinfo.return_offset:=tg.direction*tfuncretsym(procdef.funcretsym).address;
-*)
-                   if ((procinfo.flags and pi_operator)<>0) and
-                      assigned(otsym) then
-                     otsym.address:=tfuncretsym(procdef.funcretsym).address;
-
                    rg.usedinproc := rg.usedinproc +
                       getfuncretusedregisters(procdef.rettype.def,procdef.proccalloption);
                 end;
@@ -452,13 +442,16 @@ implementation
       end;
 
 
-(* already done in symtable.pas:tlocalsymtable.insertvardata() (JM)
     procedure tprocinfo.set_result_offset;
       begin
-         if paramanager.ret_in_reg(procdef.rettype.def,procdef.proccalloption) then
-           procinfo.return_offset:=tg.direction*tfuncretsym(procdef.funcretsym).address;
+        if assigned(procdef.funcretsym) then
+         begin
+           procinfo.return_offset:=tvarsym(procdef.funcretsym).address+
+                                  tvarsym(procdef.funcretsym).owner.address_fixup;
+           if tvarsym(procdef.funcretsym).owner.symtabletype=localsymtable then
+            procinfo.return_offset:=tg.direction*procinfo.return_offset;
+         end;
       end;
-*)
 
 
     procedure tprocinfo.after_header;
@@ -681,7 +674,16 @@ begin
 end.
 {
   $Log$
-  Revision 1.41  2003-04-23 12:35:34  florian
+  Revision 1.42  2003-04-25 20:59:33  peter
+    * removed funcretn,funcretsym, function result is now in varsym
+      and aliases for result and function name are added using absolutesym
+    * vs_hidden parameter for funcret passed in parameter
+    * vs_hidden fixes
+    * writenode changed to printnode and released from extdebug
+    * -vp option added to generate a tree.log with the nodetree
+    * nicer printnode for statements, callnode
+
+  Revision 1.41  2003/04/23 12:35:34  florian
     * fixed several issues with powerpc
     + applied a patch from Jonas for nested function calls (PowerPC only)
     * ...

compiler/cginfo.pas

@@ -126,12 +126,40 @@ interface
           OS_M8,OS_M16,OS_M32,OS_M64,OS_M128,OS_M8,OS_M16,OS_M32,
           OS_M64,OS_M128);
 
+       tcgloc2str : array[TCGLoc] of string[11] = (
+            'LOC_INVALID',
+            'LOC_VOID',
+            'LOC_CONST',
+            'LOC_JUMP',
+            'LOC_FLAGS',
+            'LOC_CREF',
+            'LOC_REF',
+            'LOC_REG',
+            'LOC_CREG',
+            'LOC_FPUREG',
+            'LOC_CFPUREG',
+            'LOC_MMXREG',
+            'LOC_CMMXREG',
+            'LOC_SSEREG',
+            'LOC_CSSEREG',
+            'LOC_MMREG',
+            'LOC_CMMREG');
+
 implementation
 
 end.
 {
   $Log$
-  Revision 1.20  2003-04-23 12:35:34  florian
+  Revision 1.21  2003-04-25 20:59:33  peter
+    * removed funcretn,funcretsym, function result is now in varsym
+      and aliases for result and function name are added using absolutesym
+    * vs_hidden parameter for funcret passed in parameter
+    * vs_hidden fixes
+    * writenode changed to printnode and released from extdebug
+    * -vp option added to generate a tree.log with the nodetree
+    * nicer printnode for statements, callnode
+
+  Revision 1.20  2003/04/23 12:35:34  florian
     * fixed several issues with powerpc
     + applied a patch from Jonas for nested function calls (PowerPC only)
     * ...

compiler/defutil.pas

@@ -184,8 +184,7 @@ interface
 implementation
 
     uses
-       globtype,tokens,systems,verbose,
-       symtable;
+       globtype,tokens,systems,verbose;
 
     { returns true, if def uses FPU }
     function is_fpu(def : tdef) : boolean;
@@ -758,7 +757,16 @@ implementation
 end.
 {
   $Log$
-  Revision 1.4  2003-04-23 20:16:04  peter
+  Revision 1.5  2003-04-25 20:59:33  peter
+    * removed funcretn,funcretsym, function result is now in varsym
+      and aliases for result and function name are added using absolutesym
+    * vs_hidden parameter for funcret passed in parameter
+    * vs_hidden fixes
+    * writenode changed to printnode and released from extdebug
+    * -vp option added to generate a tree.log with the nodetree
+    * nicer printnode for statements, callnode
+
+  Revision 1.4  2003/04/23 20:16:04  peter
     + added currency support based on int64
     + is_64bit for use in cg units instead of is_64bitint
     * removed cgmessage from n386add, replace with internalerrors

compiler/globals.pas

@@ -80,7 +80,7 @@ interface
        { maximum of units which are supported for a compilation }
        maxunits = 1024;
 
-
+       treelogfilename = 'tree.log';
 
     type
        pfileposinfo = ^tfileposinfo;
@@ -119,7 +119,9 @@ interface
        { things specified with parameters }
        paralinkoptions,
        paradynamiclinker : string;
+       paraprintnodetree : byte;
        parapreprocess    : boolean;
+       printnodefile     : text;
 
        { directory where the utils can be found (options -FD) }
        utilsdirectory : dirstr;
@@ -1527,7 +1529,16 @@ implementation
 end.
 {
   $Log$
-  Revision 1.85  2003-04-22 14:33:38  peter
+  Revision 1.86  2003-04-25 20:59:33  peter
+    * removed funcretn,funcretsym, function result is now in varsym
+      and aliases for result and function name are added using absolutesym
+    * vs_hidden parameter for funcret passed in parameter
+    * vs_hidden fixes
+    * writenode changed to printnode and released from extdebug
+    * -vp option added to generate a tree.log with the nodetree
+    * nicer printnode for statements, callnode
+
+  Revision 1.85  2003/04/22 14:33:38  peter
     * removed some notes/hints
 
   Revision 1.84  2003/03/23 23:21:42  hajny

compiler/htypechk.pas

@@ -108,9 +108,6 @@ interface
     { takes care of type casts etc.                 }
     procedure set_unique(p : tnode);
 
-    { sets funcret_is_valid to true, if p contains a funcref node }
-    procedure set_funcret_is_valid(p : tnode);
-
     function  valid_for_formal_var(p : tnode) : boolean;
     function  valid_for_formal_const(p : tnode) : boolean;
     function  valid_for_var(p:tnode):boolean;
@@ -636,10 +633,13 @@ implementation
                              assigned(aktprocsym) and
                              (hsym.owner = aktprocdef.localst)) then
                            begin
-                             if tloadnode(p).symtable.symtabletype=localsymtable then
-                              CGMessage1(sym_n_uninitialized_local_variable,hsym.realname)
+                             if (vo_is_funcret in hsym.varoptions) then
+                               CGMessage(sym_w_function_result_not_set)
+                             else
+                              if tloadnode(p).symtable.symtabletype=localsymtable then
+                               CGMessage1(sym_n_uninitialized_local_variable,hsym.realname)
                              else
-                              CGMessage1(sym_n_uninitialized_variable,hsym.realname);
+                               CGMessage1(sym_n_uninitialized_variable,hsym.realname);
                            end;
                         end;
                      end;
@@ -672,23 +672,6 @@ implementation
                   end;
                  break;
                end;
-             funcretn:
-               begin
-                 { no claim if setting higher return value_str }
-                 if must_be_valid and
-                    (lexlevel=tfuncretnode(p).funcretsym.owner.symtablelevel) and
-                    ((tfuncretnode(p).funcretsym.funcretstate=vs_declared) or
-                    ((nf_first_use in p.flags) and
-                     (tfuncretnode(p).funcretsym.funcretstate=vs_declared_and_first_found))) then
-                   begin
-                     CGMessage(sym_w_function_result_not_set);
-                     { avoid multiple warnings }
-                     tfuncretnode(p).funcretsym.funcretstate:=vs_assigned;
-                   end;
-                 if (nf_first_use in p.flags) and not must_be_valid then
-                   tfuncretnode(p).funcretsym.funcretstate:=vs_assigned;
-                 break;
-               end;
              else
                break;
            end;{case }
@@ -734,30 +717,6 @@ implementation
       end;
 
 
-    procedure set_funcret_is_valid(p:tnode);
-      begin
-        while assigned(p) do
-         begin
-           case p.nodetype of
-             funcretn:
-               begin
-                 if (nf_first_use in p.flags) or
-                    (tfuncretnode(p).funcretsym.funcretstate=vs_declared_and_first_found) then
-                   tfuncretnode(p).funcretsym.funcretstate:=vs_assigned;
-                 break;
-               end;
-             vecn,
-             {derefn,}
-             typeconvn,
-             subscriptn:
-               p:=tunarynode(p).left;
-             else
-               break;
-           end;
-         end;
-      end;
-
-
     function  valid_for_assign(p:tnode;opts:TValidAssigns):boolean;
       var
         hp : tnode;
@@ -899,8 +858,7 @@ implementation
                   CGMessagePos(hp.fileinfo,type_e_no_assign_to_addr);
                  exit;
                end;
-             selfn,
-             funcretn :
+             selfn :
                begin
                  valid_for_assign:=true;
                  exit;
@@ -969,11 +927,6 @@ implementation
                           exit;
                         end;
                      end;
-                   funcretsym :
-                     begin
-                       valid_for_assign:=true;
-                       exit;
-                     end;
                    typedconstsym :
                      begin
                        if ttypedconstsym(tloadnode(hp).symtableentry).is_writable then
@@ -1044,7 +997,16 @@ implementation
 end.
 {
   $Log$
-  Revision 1.59  2003-04-22 23:50:22  peter
+  Revision 1.60  2003-04-25 20:59:33  peter
+    * removed funcretn,funcretsym, function result is now in varsym
+      and aliases for result and function name are added using absolutesym
+    * vs_hidden parameter for funcret passed in parameter
+    * vs_hidden fixes
+    * writenode changed to printnode and released from extdebug
+    * -vp option added to generate a tree.log with the nodetree
+    * nicer printnode for statements, callnode
+
+  Revision 1.59  2003/04/22 23:50:22  peter
     * firstpass uses expectloc
     * checks if there are differences between the expectloc and
       location.loc from secondpass in EXTDEBUG

compiler/i386/radirect.pas

@@ -80,7 +80,7 @@ interface
             { consider it set function set if the offset was loaded }
            if assigned(aktprocdef.funcretsym) and
               (pos(retstr,upper(s))>0) then
-             tfuncretsym(aktprocdef.funcretsym).funcretstate:=vs_assigned;
+             tvarsym(aktprocdef.funcretsym).varstate:=vs_assigned;
            s:='';
          end;
 
@@ -89,7 +89,7 @@ interface
        s:='';
        if assigned(aktprocdef.funcretsym) and
           is_fpu(aktprocdef.rettype.def) then
-         tfuncretsym(aktprocdef.funcretsym).funcretstate:=vs_assigned;
+         tvarsym(aktprocdef.funcretsym).varstate:=vs_assigned;
        framereg:=procinfo.framepointer;
        convert_register_to_enum(framereg);
        if (not is_void(aktprocdef.rettype.def)) then
@@ -145,7 +145,7 @@ interface
                                     paramanager.ret_in_acc(aktprocdef.rettype.def,aktprocdef.proccalloption) and
                                     ((pos('AX',upper(hs))>0) or
                                     (pos('AL',upper(hs))>0)) then
-                                   tfuncretsym(aktprocdef.funcretsym).funcretstate:=vs_assigned;
+                                   tvarsym(aktprocdef.funcretsym).varstate:=vs_assigned;
                                  if (s[length(s)]<>'%') and
                                    (s[length(s)]<>'$') and
                                    ((s[length(s)]<>'0') or (hs[1]<>'x')) then
@@ -273,7 +273,7 @@ interface
                    end;
  '{',';',#10,#13 : begin
                       if pos(retstr,s) > 0 then
-                        tfuncretsym(aktprocdef.funcretsym).funcretstate:=vs_assigned;
+                        tvarsym(aktprocdef.funcretsym).varstate:=vs_assigned;
                      writeasmline;
                      c:=current_scanner.asmgetchar;
                    end;
@@ -308,7 +308,16 @@ initialization
 end.
 {
   $Log$
-  Revision 1.8  2003-04-25 12:04:31  florian
+  Revision 1.9  2003-04-25 20:59:35  peter
+    * removed funcretn,funcretsym, function result is now in varsym
+      and aliases for result and function name are added using absolutesym
+    * vs_hidden parameter for funcret passed in parameter
+    * vs_hidden fixes
+    * writenode changed to printnode and released from extdebug
+    * -vp option added to generate a tree.log with the nodetree
+    * nicer printnode for statements, callnode
+
+  Revision 1.8  2003/04/25 12:04:31  florian
     * merged agx64att and ag386att to x86/agx86att
 
   Revision 1.7  2003/04/21 20:05:10  peter

compiler/nbas.pas

@@ -66,14 +66,12 @@ interface
           constructor create(l,r : tnode);virtual;
           function pass_1 : tnode;override;
           function det_resulttype:tnode;override;
-{$ifdef extdebug}
-          procedure _dowrite;override;
-{$endif extdebug}
+          procedure printnodetree(var t:text);override;
        end;
        tstatementnodeclass = class of tstatementnode;
 
        tblocknode = class(tunarynode)
-          constructor create(l : tnode);virtual;
+          constructor create(l : tnode;releasetemp : boolean);virtual;
           function pass_1 : tnode;override;
           function det_resulttype:tnode;override;
 {$ifdef state_tracking}
@@ -114,6 +112,7 @@ interface
           function pass_1 : tnode; override;
           function det_resulttype: tnode; override;
           function docompare(p: tnode): boolean; override;
+          procedure printnodedata(var t:text);override;
         end;
        ttempcreatenodeclass = class of ttempcreatenode;
 
@@ -161,7 +160,7 @@ interface
 
        { Create a blocknode and statement node for multiple statements
          generated internally by the parser }
-       function  internalstatements(var laststatement:tstatementnode):tblocknode;
+       function  internalstatements(var laststatement:tstatementnode;releasetemp : boolean):tblocknode;
        procedure addstatement(var laststatement:tstatementnode;n:tnode);
 
 
@@ -170,7 +169,7 @@ implementation
     uses
       cutils,
       verbose,globals,globtype,systems,
-      symconst,symdef,symsym,defutil,defcmp,
+      symconst,symdef,symsym,symutil,defutil,defcmp,
       pass_1,
       nld,ncal,nflw,rgobj,cginfo,cgbase
       ;
@@ -180,11 +179,11 @@ implementation
                                      Helpers
 *****************************************************************************}
 
-    function internalstatements(var laststatement:tstatementnode):tblocknode;
+    function internalstatements(var laststatement:tstatementnode;releasetemp : boolean):tblocknode;
       begin
         { create dummy initial statement }
         laststatement := cstatementnode.create(cnothingnode.create,nil);
-        internalstatements := cblocknode.create(laststatement);
+        internalstatements := cblocknode.create(laststatement,releasetemp);
       end;
 
 
@@ -275,7 +274,7 @@ implementation
             not((left.nodetype=calln) and
                 { don't complain when funcretrefnode is set, because then the
                   value is already used. And also not for constructors }
-                (assigned(tcallnode(left).funcretrefnode) or
+                (assigned(tcallnode(left).funcretnode) or
                  (tcallnode(left).procdefinition.proctypeoption=potype_constructor))) and
             not(is_void(left.resulttype.def)) then
            CGMessage(cg_e_illegal_expression);
@@ -314,32 +313,22 @@ implementation
            exit;
       end;
 
-{$ifdef extdebug}
-    procedure tstatementnode._dowrite;
 
+    procedure tstatementnode.printnodetree(var t:text);
       begin
-         { can't use inherited dowrite, because that will use the
-           binary which we don't want for statements }
-         dowritenodetype;
-         writeln(',');
-         { write the statement }
-         writenodeindention:=writenodeindention+'    ';
-         writenode(left);
-         writeln(')');
-         delete(writenodeindention,1,4);
-         { go on with the next statement }
-         writenode(right);
+        printnodelist(t);
       end;
-{$endif}
 
 {*****************************************************************************
                              TBLOCKNODE
 *****************************************************************************}
 
-    constructor tblocknode.create(l : tnode);
+    constructor tblocknode.create(l : tnode;releasetemp : boolean);
 
       begin
          inherited create(blockn,l);
+         if releasetemp then
+           include(flags,nf_releasetemps);
       end;
 
     function tblocknode.det_resulttype:tnode;
@@ -359,9 +348,9 @@ implementation
                    if (not (cs_extsyntax in aktmoduleswitches)) and
                       assigned(hp.left.resulttype.def) and
                       not((hp.left.nodetype=calln) and
-                          { don't complain when funcretrefnode is set, because then the
+                          { don't complain when funcretnode is set, because then the
                             value is already used. And also not for constructors }
-                          (assigned(tcallnode(hp.left).funcretrefnode) or
+                          (assigned(tcallnode(hp.left).funcretnode) or
                            (tcallnode(hp.left).procdefinition.proctypeoption=potype_constructor))) and
                       not(is_void(hp.left.resulttype.def)) then
                      CGMessagePos(hp.left.fileinfo,cg_e_illegal_expression);
@@ -402,7 +391,8 @@ implementation
                       (tstatementnode(hp.right).left.nodetype=exitn) and
                       (hp.left.nodetype=assignn) and
                       { !!!! this tbinarynode should be tassignmentnode }
-                      (tbinarynode(hp.left).left.nodetype=funcretn) then
+                      (tbinarynode(hp.left).left.nodetype=loadn) and
+                      (is_funcret_sym(tloadnode(tbinarynode(hp.left).left).symtableentry)) then
                       begin
                          if assigned(texitnode(tstatementnode(hp.right).left).left) then
                            CGMessage(cg_n_inefficient_code)
@@ -600,6 +590,7 @@ implementation
       begin
         n := ttempcreatenode(inherited getcopy);
         n.size := size;
+        n.persistent := persistent;
 
         new(n.tempinfo);
         fillchar(n.tempinfo^,sizeof(n.tempinfo^),0);
@@ -640,6 +631,14 @@ implementation
           equal_defs(ttempcreatenode(p).tempinfo^.restype.def,tempinfo^.restype.def);
       end;
 
+
+    procedure ttempcreatenode.printnodedata(var t:text);
+      begin
+        inherited printnodedata(t);
+        writeln(t,printnodeindention,'size = ',size);
+      end;
+
+
 {*****************************************************************************
                              TEMPREFNODE
 *****************************************************************************}
@@ -726,17 +725,19 @@ implementation
         inherited create(tempdeleten);
         tempinfo := temp.tempinfo;
         release_to_normal := false;
-        if not temp.persistent then
-          internalerror(200204211);
       end;
 
+
     constructor ttempdeletenode.create_normal_temp(const temp: ttempcreatenode);
       begin
         inherited create(tempdeleten);
         tempinfo := temp.tempinfo;
         release_to_normal := true;
+        if not temp.persistent then
+          internalerror(200204211);
       end;
 
+
     function ttempdeletenode.getcopy: tnode;
       var
         n: ttempdeletenode;
@@ -802,7 +803,20 @@ begin
 end.
 {
   $Log$
-  Revision 1.45  2003-04-23 08:41:34  jonas
+  Revision 1.47  2003-04-25 20:59:33  peter
+    * removed funcretn,funcretsym, function result is now in varsym
+      and aliases for result and function name are added using absolutesym
+    * vs_hidden parameter for funcret passed in parameter
+    * vs_hidden fixes
+    * writenode changed to printnode and released from extdebug
+    * -vp option added to generate a tree.log with the nodetree
+    * nicer printnode for statements, callnode
+
+  Revision 1.46  2002/04/25 20:15:39  florian
+    * block nodes within expressions shouldn't release the used registers,
+      fixed using a flag till the new rg is ready
+
+  Revision 1.45  2003/04/23 08:41:34  jonas
     * fixed ttemprefnode.compare and .getcopy to take offset field into
       account
 
@@ -864,7 +878,7 @@ end.
 
   Revision 1.33  2002/08/17 22:09:44  florian
     * result type handling in tcgcal.pass_2 overhauled
-    * better tnode.dowrite
+    * better tnode.printnodetree
     * some ppc stuff fixed
 
   Revision 1.32  2002/08/17 09:23:34  florian

compiler/ncal.pas

@@ -74,7 +74,11 @@ interface
           symtableproc   : tsymtable;
           { the definition of the procedure to call }
           procdefinition : tabstractprocdef;
+          { tree that contains the pointer to the object for this method }
           methodpointer  : tnode;
+          { function return node, this is used to pass the data for a
+            ret_in_param return value }
+          funcretnode    : tnode;
 
           { separately specified resulttype for some compilerprocs (e.g. }
           { you can't have a function with an "array of char" resulttype }
@@ -82,9 +86,6 @@ interface
           restype: ttype;
           restypeset: boolean;
 
-          { function return reference node, this is used to pass an already
-            allocated reference for a ret_in_param return value }
-          funcretrefnode : tnode;
           { only the processor specific nodes need to override this }
           { constructor                                             }
           constructor create(l:tnode; v : tprocsym;st : tsymtable; mp : tnode);virtual;
@@ -112,6 +113,7 @@ interface
        {$endif state_tracking}
           function  docompare(p: tnode): boolean; override;
           procedure set_procvar(procvar:tnode);
+          procedure printnodedata(var t:text);override;
        private
 {$ifdef callparatemp}
           function extract_functioncall_paras: tblocknode;
@@ -131,6 +133,7 @@ interface
        tcallparanode = class(tbinarynode)
           callparaflags : set of tcallparaflags;
           paraitem : tparaitem;
+          used_by_callnode : boolean;
           { only the processor specific nodes need to override this }
           { constructor                                             }
           constructor create(expr,next : tnode);virtual;
@@ -147,6 +150,7 @@ interface
           procedure secondcallparan(push_from_left_to_right:boolean;calloption:tproccalloption;
                 para_alignment,para_offset : longint);virtual;abstract;
           function docompare(p: tnode): boolean; override;
+          procedure printnodetree(var t:text);override;
        end;
        tcallparanodeclass = class of tcallparanode;
 
@@ -537,6 +541,10 @@ type
     destructor tcallparanode.destroy;
 
       begin
+         { When the node is used by callnode then
+           we don't destroy left, the callnode takes care of it }
+         if used_by_callnode then
+          left:=nil;
          inherited destroy;
       end;
 
@@ -777,8 +785,8 @@ type
              if do_count then
               begin
                 { not completly proper, but avoids some warnings }
-                if (paraitem.paratyp in [vs_var,vs_out]) then
-                 set_funcret_is_valid(left);
+                {if (paraitem.paratyp in [vs_var,vs_out]) then
+                 set_funcret_is_valid(left); }
                 set_varstate(left,not(paraitem.paratyp in [vs_var,vs_out]));
               end;
              { must only be done after typeconv PM }
@@ -855,6 +863,12 @@ type
       end;
 
 
+    procedure tcallparanode.printnodetree(var t:text);
+      begin
+        printnodelist(t);
+      end;
+
+
 {****************************************************************************
                                  TCALLNODE
  ****************************************************************************}
@@ -868,8 +882,8 @@ type
          include(flags,nf_return_value_used);
          methodpointer:=mp;
          procdefinition:=nil;
-         restypeset := false;
-         funcretrefnode:=nil;
+         restypeset:=false;
+         funcretnode:=nil;
          paralength:=-1;
       end;
 
@@ -918,7 +932,7 @@ type
     constructor tcallnode.createinternreturn(const name: string; params: tnode; returnnode : tnode);
       begin
         self.createintern(name,params);
-        funcretrefnode:=returnnode;
+        funcretnode:=returnnode;
         if not paramanager.ret_in_param(symtableprocentry.first_procdef.rettype.def,symtableprocentry.first_procdef.proccalloption) then
           internalerror(200204247);
       end;
@@ -927,7 +941,7 @@ type
     destructor tcallnode.destroy;
       begin
          methodpointer.free;
-         funcretrefnode.free;
+         funcretnode.free;
          inherited destroy;
       end;
 
@@ -943,7 +957,7 @@ type
         procdefinition:=tprocdef(ppufile.getderef);
         restypeset:=boolean(ppufile.getbyte);
         methodpointer:=ppuloadnode(ppufile);
-        funcretrefnode:=ppuloadnode(ppufile);
+        funcretnode:=ppuloadnode(ppufile);
       end;
 
 
@@ -954,7 +968,7 @@ type
         ppufile.putderef(procdefinition);
         ppufile.putbyte(byte(restypeset));
         ppuwritenode(ppufile,methodpointer);
-        ppuwritenode(ppufile,funcretrefnode);
+        ppuwritenode(ppufile,funcretnode);
       end;
 
 
@@ -966,8 +980,8 @@ type
         resolvedef(pointer(procdefinition));
         if assigned(methodpointer) then
           methodpointer.derefimpl;
-        if assigned(funcretrefnode) then
-          funcretrefnode.derefimpl;
+        if assigned(funcretnode) then
+          funcretnode.derefimpl;
       end;
 
 
@@ -991,10 +1005,10 @@ type
          n.methodpointer:=methodpointer.getcopy
         else
          n.methodpointer:=nil;
-        if assigned(funcretrefnode) then
-         n.funcretrefnode:=funcretrefnode.getcopy
+        if assigned(funcretnode) then
+         n.funcretnode:=funcretnode.getcopy
         else
-         n.funcretrefnode:=nil;
+         n.funcretnode:=nil;
         result:=n;
       end;
 
@@ -1254,7 +1268,7 @@ type
          begin
            if all or
               (not hp^.invalid) then
-             MessagePos1(hp^.data.fileinfo,sym_h_param_list,hp^.data.fullprocname);
+             MessagePos1(hp^.data.fileinfo,sym_h_param_list,hp^.data.fullprocname(false));
            hp:=hp^.next;
          end;
       end;
@@ -1285,7 +1299,7 @@ type
         hp:=procs;
         while assigned(hp) do
          begin
-           Comment(lvl,'  '+hp^.data.fullprocname);
+           Comment(lvl,'  '+hp^.data.fullprocname(false));
            if (hp^.invalid) then
             Comment(lvl,'   invalid')
            else
@@ -1566,7 +1580,10 @@ type
         pt       : tcallparanode;
         oldppt   : ^tcallparanode;
         currpara : tparaitem;
+        used_by_callnode : boolean;
         hiddentree : tnode;
+        newstatement : tstatementnode;
+        temp         : ttempcreatenode;
       begin
         pt:=tcallparanode(left);
         oldppt:=@left;
@@ -1588,23 +1605,45 @@ type
         currpara:=tparaitem(procdefinition.Para.last);
         while assigned(currpara) do
          begin
-           if not assigned(pt) then
-             internalerror(200304082);
            if (currpara.paratyp=vs_hidden) then
             begin
+              { generate hidden tree }
+              used_by_callnode:=false;
               hiddentree:=nil;
-              if assigned(currpara.previous) and
-                 paramanager.push_high_param(tparaitem(currpara.previous).paratype.def,procdefinition.proccalloption) then
-//              if vo_is_high_value in tvarsym(currpara.parasym).varoptions then
+              if (vo_is_funcret in tvarsym(currpara.parasym).varoptions) then
                begin
-                 { we need the information of the next parameter }
-                 hiddentree:=gen_high_tree(pt.left,is_open_string(tparaitem(currpara.previous).paratype.def));
-               end;
-              { add a callparanode for the hidden parameter and
-                let the previous node point to this new node }
+                 { Generate funcretnode if not specified }
+                 if assigned(funcretnode) then
+                  begin
+                    hiddentree:=funcretnode;
+                    funcretnode:=nil;
+                  end
+                 else
+                  begin
+                    hiddentree:=internalstatements(newstatement,false);
+                    { need to use resulttype instead of procdefinition.rettype,
+                      because they can be different }
+                    temp:=ctempcreatenode.create(resulttype,resulttype.def.size,true);
+                    addstatement(newstatement,temp);
+                    addstatement(newstatement,ctempdeletenode.create_normal_temp(temp));
+                    addstatement(newstatement,ctemprefnode.create(temp));
+                  end;
+               end
+              else
+               if vo_is_high_value in tvarsym(currpara.parasym).varoptions then
+                begin
+                  if not assigned(pt) then
+                    internalerror(200304082);
+                  { we need the information of the next parameter }
+                  hiddentree:=gen_high_tree(pt.left,is_open_string(tparaitem(currpara.previous).paratype.def));
+                end;
+              { add the hidden parameter }
               if not assigned(hiddentree) then
                 internalerror(200304073);
+              { Already insert para and let the previous node point to
+                this new node }
               pt:=ccallparanode.create(hiddentree,oldppt^);
+              pt.used_by_callnode:=used_by_callnode;
               oldppt^:=pt;
             end;
            { Bind paraitem to this node }
@@ -1892,6 +1931,13 @@ type
           begin
             resulttypepass(methodpointer);
 
+            { direct call to inherited abstract method, then we
+              can already give a error in the compiler instead
+              of a runtime error }
+            if (methodpointer.nodetype=typen) and
+               (po_abstractmethod in procdefinition.procoptions) then
+              CGMessage(cg_e_cant_call_abstract_method);
+
             { if an inherited con- or destructor should be  }
             { called in a con- or destructor then a warning }
             { will be made                                  }
@@ -1946,14 +1992,6 @@ type
          if assigned(left) then
            tcallparanode(left).insert_typeconv(true);
 
-         { direct call to inherited abstract method, then we
-           can already give a error in the compiler instead
-           of a runtime error }
-         if assigned(methodpointer) and
-            (methodpointer.nodetype=typen) and
-            (po_abstractmethod in procdefinition.procoptions) then
-           CGMessage(cg_e_cant_call_abstract_method);
-
       errorexit:
          aktcallprocdef:=oldcallprocdef;
       end;
@@ -1989,7 +2027,7 @@ type
                 if (not foundcall) then
                   begin
                     foundcall := true;
-                    newblock := internalstatements(newstatement);
+                    newblock := internalstatements(newstatement,false);
                   end;
                 temp := ctempcreatenode.create(curpara.left.resulttype,curpara.left.resulttype.def.size,true);
                 addstatement(newstatement,temp);
@@ -2038,9 +2076,9 @@ type
          if assigned(left) then
            tcallparanode(left).det_registers;
 
-         { return node }
-         if assigned(funcretrefnode) then
-           firstpass(funcretrefnode);
+         { function result node }
+         if assigned(funcretnode) then
+           firstpass(funcretnode);
 
          if assigned(procdefinition) and
             (procdefinition.proccalloption=pocall_inline) then
@@ -2104,17 +2142,17 @@ type
          { get a register for the return value }
          if (not is_void(resulttype.def)) then
            begin
+              if paramanager.ret_in_param(resulttype.def,procdefinition.proccalloption) then
+               begin
+                 expectloc:=LOC_REFERENCE;
+               end
+             else
              { for win32 records returned in EDX:EAX, we
                move them to memory after ... }
              if (resulttype.def.deftype=recorddef) then
               begin
                 expectloc:=LOC_CREFERENCE;
               end
-             else
-              if paramanager.ret_in_param(resulttype.def,procdefinition.proccalloption) then
-               begin
-                 expectloc:=LOC_CREFERENCE;
-               end
              else
              { ansi/widestrings must be registered, so we can dispose them }
               if is_ansistring(resulttype.def) or
@@ -2251,7 +2289,7 @@ type
              tcallnode(newcall).left := paras;
              tcallnode(newcall).right := oldright;
 
-             newblock := internalstatements(statement);
+             newblock := internalstatements(statement,false);
              addstatement(statement,callparatemps);
              { add the copy of the call node after the callparatemps block    }
              { and return that. The last statement of a bocknode determines   }
@@ -2314,6 +2352,20 @@ type
            (not restypeset and not tcallnode(p).restypeset));
       end;
 
+
+    procedure tcallnode.printnodedata(var t:text);
+      begin
+        if assigned(procdefinition) and
+           (procdefinition.deftype=procdef) then
+          writeln(t,printnodeindention,'proc = ',tprocdef(procdefinition).fullprocname(true))
+        else
+          writeln(t,printnodeindention,'proc = ',symtableprocentry.name);
+        printnode(t,methodpointer);
+        printnode(t,right);
+        printnode(t,left);
+      end;
+
+
 {****************************************************************************
                             TPROCINLINENODE
  ****************************************************************************}
@@ -2483,7 +2535,20 @@ begin
 end.
 {
   $Log$
-  Revision 1.142  2003-04-23 20:16:04  peter
+  Revision 1.144  2003-04-25 20:59:33  peter
+    * removed funcretn,funcretsym, function result is now in varsym
+      and aliases for result and function name are added using absolutesym
+    * vs_hidden parameter for funcret passed in parameter
+    * vs_hidden fixes
+    * writenode changed to printnode and released from extdebug
+    * -vp option added to generate a tree.log with the nodetree
+    * nicer printnode for statements, callnode
+
+  Revision 1.143  2002/04/25 20:15:39  florian
+    * block nodes within expressions shouldn't release the used registers,
+      fixed using a flag till the new rg is ready
+
+  Revision 1.142  2003/04/23 20:16:04  peter
     + added currency support based on int64
     + is_64bit for use in cg units instead of is_64bitint
     * removed cgmessage from n386add, replace with internalerrors

compiler/ncgcal.pas

@@ -1,5 +1,5 @@
 {
-    Id: ncgcal.pas,v 1.10 2002/08/17 09:23:35 florian Exp $
+    $Id$
     Copyright (c) 1998-2002 by Florian Klaempfl
 
     Generate i386 assembler for in call nodes
@@ -43,7 +43,7 @@ interface
        private
           function  push_self_and_vmt(needvmtreg:boolean):tregister;
        protected
-          funcretref : treference;
+//          funcretref : treference;
           refcountedtemp : treference;
           procedure handle_return_value(inlined:boolean);
           {# This routine is used to push the current frame pointer
@@ -90,17 +90,28 @@ implementation
 {$endif i386}
       cg64f32,ncgutil,cgobj,tgobj,regvars,rgobj,rgcpu,cgcpu;
 
+
+    var
+      { Current callnode, this is needed for having a link
+        between the callparanodes and the callnode they belong to }
+      aktcallnode : tcallnode;
+
 {*****************************************************************************
                              TCGCALLPARANODE
 *****************************************************************************}
 
     procedure tcgcallparanode.secondcallparan(push_from_left_to_right:boolean;calloption:tproccalloption;para_alignment,para_offset : longint);
       var
-         otlabel,oflabel : tasmlabel;
-         tempdeftype : tdeftype;
-         tmpreg : tregister;
-         href   : treference;
+         otlabel,
+         oflabel : tasmlabel;
+         tmpreg  : tregister;
+         href    : treference;
+         varspez : tvarspez;
       begin
+         if not(assigned(paraitem.paratype.def) or
+                assigned(paraitem.parasym)) then
+           internalerror(200304242);
+
          { set default para_alignment to target_info.stackalignment }
          if para_alignment=0 then
            para_alignment:=aktalignment.paraalign;
@@ -121,6 +132,11 @@ implementation
          objectlibrary.getlabel(truelabel);
          objectlibrary.getlabel(falselabel);
          secondpass(left);
+         { retrieve the type of parameter, for hidden parameters
+           the value is stored in the parasym }
+         varspez:=paraitem.paratyp;
+         if varspez=vs_hidden then
+           varspez:=tvarsym(paraitem.parasym).varspez;
          { handle varargs first, because defcoll is not valid }
          if (nf_varargs_para in flags) then
            begin
@@ -143,7 +159,7 @@ implementation
                  (paraitem.paratype.def.deftype=formaldef) then
            begin
               { allow passing of a constant to a const formaldef }
-              if (paraitem.paratyp=vs_const) and
+              if (varspez=vs_const) and
                  (left.location.loc=LOC_CONSTANT) then
                 location_force_mem(exprasmlist,left.location);
 
@@ -188,7 +204,7 @@ implementation
                 end;
            end
          { handle call by reference parameter }
-         else if (paraitem.paratyp in [vs_var,vs_out]) then
+         else if (varspez in [vs_var,vs_out]) then
            begin
               if (left.location.loc<>LOC_REFERENCE) then
                begin
@@ -198,7 +214,7 @@ implementation
                         (left.nodetype=selfn)) then
                   internalerror(200106041);
                end;
-              if (paraitem.paratyp=vs_out) and
+              if (varspez=vs_out) and
                  assigned(paraitem.paratype.def) and
                  not is_class(paraitem.paratype.def) and
                  paraitem.paratype.def.needs_inittable then
@@ -226,7 +242,6 @@ implementation
            end
          else
            begin
-              tempdeftype:=resulttype.def.deftype;
               { open array must always push the address, this is needed to
                 also push addr of small open arrays and with cdecl functions (PFV) }
               if (
@@ -286,6 +301,14 @@ implementation
            end;
          truelabel:=otlabel;
          falselabel:=oflabel;
+
+         { update return location in callnode when this is the function
+           result }
+         if (vo_is_funcret in tvarsym(paraitem.parasym).varoptions) then
+          begin
+            location_copy(aktcallnode.location,left.location);
+          end;
+
          { push from right to left }
          if not push_from_left_to_right and assigned(right) then
           begin
@@ -685,9 +708,9 @@ implementation
         { needed also when result_no_used !! }
         if paramanager.ret_in_param(resulttype.def,procdefinition.proccalloption) then
          begin
-           location_reset(location,LOC_CREFERENCE,def_cgsize(resulttype.def));
-           location.reference.symbol:=nil;
-           location.reference:=funcretref;
+           { Location should be setup by the funcret para }
+           if location.loc<>LOC_REFERENCE then
+            internalerror(200304241);
          end
         else
         { ansi/widestrings must be registered, so we can dispose them }
@@ -835,15 +858,13 @@ implementation
          unusedstate: pointer;
          pushed : tpushedsaved;
          pushedint : tpushedsavedint;
-         hregister : tregister;
          oldpushedparasize : longint;
          { adress returned from an I/O-error }
          iolabel : tasmlabel;
          { help reference pointer }
          href : treference;
          hp : tnode;
-         pp : tbinarynode;
-         params : tnode;
+         pp : tcallparanode;
          virtual_vmt_call,
          inlined : boolean;
          inlinecode : tprocinlinenode;
@@ -855,6 +876,7 @@ implementation
          pararef : treference;
          accreg,
          vmtreg : tregister;
+         oldaktcallnode : tcallnode;
       begin
          iolabel:=nil;
          inlinecode:=nil;
@@ -882,11 +904,6 @@ implementation
          if not assigned(procdefinition) then
           exit;
 
-         if assigned(left) then
-           params:=left
-         else
-           params := nil;
-
          if (procdefinition.proccalloption=pocall_inline) then
            begin
               inlined:=true;
@@ -895,7 +912,7 @@ implementation
               { set it to the same lexical level as the local symtable, becuase
                 the para's are stored there }
               tprocdef(procdefinition).parast.symtablelevel:=aktprocdef.localst.symtablelevel;
-              if assigned(params) then
+              if assigned(left) then
                begin
                  inlinecode.para_size:=tprocdef(procdefinition).para_size(para_alignment);
                  tg.GetTemp(exprasmlist,inlinecode.para_size,tt_persistant,pararef);
@@ -970,7 +987,9 @@ implementation
            pop_size:=align_parasize(oldpushedparasize,para_alignment);
 
          { Push parameters }
-         if assigned(params) then
+         oldaktcallnode:=aktcallnode;
+         aktcallnode:=self;
+         if assigned(left) then
            begin
               { be found elsewhere }
               if inlined then
@@ -980,14 +999,15 @@ implementation
                 para_offset:=0;
               if not(inlined) and
                  assigned(right) then
-                tcallparanode(params).secondcallparan(
+                tcallparanode(left).secondcallparan(
                   (po_leftright in procdefinition.procoptions),procdefinition.proccalloption,
                   para_alignment,para_offset)
               else
-                tcallparanode(params).secondcallparan(
+                tcallparanode(left).secondcallparan(
                   (po_leftright in procdefinition.procoptions),procdefinition.proccalloption,
                   para_alignment,para_offset);
            end;
+         aktcallnode:=oldaktcallnode;
 
          { Allocate return value for inlined routines }
          if inlined and
@@ -997,58 +1017,6 @@ implementation
              inlinecode.retoffset:=returnref.offset;
            end;
 
-         { Allocate return value when returned in argument }
-         if paramanager.ret_in_param(resulttype.def,procdefinition.proccalloption) then
-           begin
-             if assigned(funcretrefnode) then
-              begin
-                secondpass(funcretrefnode);
-                if codegenerror then
-                 exit;
-                if (funcretrefnode.location.loc<>LOC_REFERENCE) then
-                 internalerror(200204246);
-                funcretref:=funcretrefnode.location.reference;
-              end
-             else
-              begin
-                if inlined then
-                 begin
-                   tg.GetTemp(exprasmlist,resulttype.def.size,tt_persistant,funcretref);
-{$ifdef extdebug}
-                   Comment(V_debug,'function return value is at offset '
-                                   +tostr(funcretref.offset));
-                   exprasmlist.concat(tai_comment.create(
-                                       strpnew('function return value is at offset '
-                                               +tostr(funcretref.offset))));
-{$endif extdebug}
-                 end
-                else
-                 tg.GetTemp(exprasmlist,resulttype.def.size,tt_normal,funcretref);
-              end;
-
-             { This must not be counted for C code,
-               complex return address is removed from stack
-               by function itself !   }
-             if inlined then
-               begin
-                {$ifdef newra}
-                  hregister:=rg.getaddressregister(exprasmlist);
-                {$else}
-                  hregister:=cg.get_scratch_reg_address(exprasmlist);
-                {$endif}
-                  cg.a_loadaddr_ref_reg(exprasmlist,funcretref,hregister);
-                  reference_reset_base(href,procinfo.framepointer,inlinecode.retoffset);
-                  cg.a_load_reg_ref(exprasmlist,OS_ADDR,hregister,href);
-                {$ifdef newra}
-                  rg.ungetregisterint(exprasmlist,hregister);
-                {$else}
-                  cg.free_scratch_reg(exprasmlist,hregister);
-                {$endif}
-               end
-             else
-               cg.a_paramaddr_ref(exprasmlist,funcretref,paramanager.getfuncretparaloc(procdefinition));
-           end;
-
          { procedure variable or normal function call ? }
          if inlined or
             (right=nil) then
@@ -1217,12 +1185,14 @@ implementation
          rg.restoreusedintregisters(exprasmlist,pushedint);
 
          { Release temps from parameters }
-         pp:=tbinarynode(params);
+         pp:=tcallparanode(left);
          while assigned(pp) do
            begin
               if assigned(pp.left) then
                 begin
-                  location_freetemp(exprasmlist,pp.left.location);
+                  { don't release the funcret temp }
+                  if not(vo_is_funcret in tvarsym(pp.paraitem.parasym).varoptions) then
+                    location_freetemp(exprasmlist,pp.left.location);
                   { process also all nodes of an array of const }
                   if pp.left.nodetype=arrayconstructorn then
                     begin
@@ -1237,7 +1207,7 @@ implementation
                        end;
                     end;
                 end;
-              pp:=tbinarynode(pp.right);
+              pp:=tcallparanode(pp.right);
            end;
 
          if inlined then
@@ -1249,7 +1219,7 @@ implementation
 
              { from now on the result can be freed normally }
              if paramanager.ret_in_param(resulttype.def,procdefinition.proccalloption) then
-               tg.ChangeTempType(exprasmlist,funcretref,tt_normal);
+               tg.ChangeTempType(exprasmlist,funcretnode.location.reference,tt_normal);
            end;
 
          { if return value is not used }
@@ -1467,7 +1437,16 @@ begin
 end.
 {
   $Log$
-  Revision 1.52  2003-04-25 08:25:26  daniel
+  Revision 1.53  2003-04-25 20:59:33  peter
+    * removed funcretn,funcretsym, function result is now in varsym
+      and aliases for result and function name are added using absolutesym
+    * vs_hidden parameter for funcret passed in parameter
+    * vs_hidden fixes
+    * writenode changed to printnode and released from extdebug
+    * -vp option added to generate a tree.log with the nodetree
+    * nicer printnode for statements, callnode
+
+  Revision 1.52  2003/04/25 08:25:26  daniel
     * Ifdefs around a lot of calls to cleartempgen
     * Fixed registers that are allocated but not freed in several nodes
     * Tweak to register allocator to cause less spills

compiler/ncgld.pas

@@ -39,10 +39,6 @@ interface
           procedure pass_2;override;
        end;
 
-       tcgfuncretnode = class(tfuncretnode)
-          procedure pass_2;override;
-       end;
-
        tcgarrayconstructornode = class(tarrayconstructornode)
           procedure pass_2;override;
        end;
@@ -706,57 +702,6 @@ implementation
       end;
 
 
-{*****************************************************************************
-                             SecondFuncRet
-*****************************************************************************}
-
-    procedure tcgfuncretnode.pass_2;
-      var
-         hreg : tregister;
-         href : treference;
-         pp : tprocinfo;
-         hr_valid : boolean;
-         i : integer;
-      begin
-         location_reset(location,LOC_REFERENCE,def_cgsize(resulttype.def));
-         hr_valid:=false;
-         if (not inlining_procedure) and
-            (lexlevel<>funcretsym.owner.symtablelevel) then
-           begin
-              hreg:=rg.getaddressregister(exprasmlist);
-              hr_valid:=true;
-              reference_reset_base(href,procinfo.framepointer,procinfo.framepointer_offset);
-              cg.a_load_ref_reg(exprasmlist,OS_ADDR,href,hreg);
-
-              { walk up the stack frame }
-              pp:=procinfo.parent;
-              i:=lexlevel-1;
-              while i>funcretsym.owner.symtablelevel do
-               begin
-                 reference_reset_base(href,hreg,pp.framepointer_offset);
-                 cg.a_load_ref_reg(exprasmlist,OS_ADDR,href,hreg);
-                 pp:=pp.parent;
-                 dec(i);
-               end;
-              location.reference.base:=hreg;
-              location.reference.offset:=pp.return_offset;
-           end
-         else
-           begin
-             location.reference.base:=procinfo.framepointer;
-             location.reference.offset:=procinfo.return_offset;
-           end;
-         if paramanager.ret_in_param(funcretsym.returntype.def,
-                                     tprocdef(funcretsym.owner.defowner).proccalloption) then
-           begin
-              { the parameter is actual a pointer to the value }
-              if not hr_valid then
-                hreg:=rg.getaddressregister(exprasmlist);
-              cg.a_load_ref_reg(exprasmlist,OS_ADDR,location.reference,hreg);
-              location.reference.base:=hreg;
-              location.reference.offset:=0;
-           end;
-      end;
 {*****************************************************************************
                            SecondArrayConstruct
 *****************************************************************************}
@@ -1004,12 +949,20 @@ implementation
 begin
    cloadnode:=tcgloadnode;
    cassignmentnode:=tcgassignmentnode;
-   cfuncretnode:=tcgfuncretnode;
    carrayconstructornode:=tcgarrayconstructornode;
 end.
 {
   $Log$
-  Revision 1.51  2003-04-23 20:16:04  peter
+  Revision 1.52  2003-04-25 20:59:33  peter
+    * removed funcretn,funcretsym, function result is now in varsym
+      and aliases for result and function name are added using absolutesym
+    * vs_hidden parameter for funcret passed in parameter
+    * vs_hidden fixes
+    * writenode changed to printnode and released from extdebug
+    * -vp option added to generate a tree.log with the nodetree
+    * nicer printnode for statements, callnode
+
+  Revision 1.51  2003/04/23 20:16:04  peter
     + added currency support based on int64
     + is_64bit for use in cg units instead of is_64bitint
     * removed cgmessage from n386add, replace with internalerrors

compiler/ncgutil.pas

@@ -1160,9 +1160,6 @@ implementation
       begin
         if not is_void(aktprocdef.rettype.def) then
          begin
-           if (tfuncretsym(aktprocdef.funcretsym).funcretstate<>vs_assigned) and
-              (not inlined) then
-            CGMessage(sym_w_function_result_not_set);
            reference_reset_base(href,procinfo.framepointer,procinfo.return_offset);
            cgsize:=def_cgsize(aktprocdef.rettype.def);
            { Here, we return the function result. In most architectures, the value is
@@ -1783,7 +1780,7 @@ implementation
         usesself:=false;
         if not(po_assembler in aktprocdef.procoptions) or
            (assigned(aktprocdef.funcretsym) and
-            (tfuncretsym(aktprocdef.funcretsym).refcount>1)) then
+            (tvarsym(aktprocdef.funcretsym).refcount>1)) then
           begin
             if (aktprocdef.proctypeoption=potype_constructor) then
               begin
@@ -2055,7 +2052,16 @@ implementation
 end.
 {
   $Log$
-  Revision 1.88  2003-04-23 12:35:34  florian
+  Revision 1.89  2003-04-25 20:59:33  peter
+    * removed funcretn,funcretsym, function result is now in varsym
+      and aliases for result and function name are added using absolutesym
+    * vs_hidden parameter for funcret passed in parameter
+    * vs_hidden fixes
+    * writenode changed to printnode and released from extdebug
+    * -vp option added to generate a tree.log with the nodetree
+    * nicer printnode for statements, callnode
+
+  Revision 1.88  2003/04/23 12:35:34  florian
     * fixed several issues with powerpc
     + applied a patch from Jonas for nested function calls (PowerPC only)
     * ...

compiler/ncon.pas

@@ -45,9 +45,7 @@ interface
           function pass_1 : tnode;override;
           function det_resulttype:tnode;override;
           function docompare(p: tnode) : boolean; override;
-       {$ifdef extdebug}
-          procedure _dowrite;override;
-       {$endif}
+          procedure printnodedata(var t:text);override;
        end;
        trealconstnodeclass = class of trealconstnode;
 
@@ -67,9 +65,7 @@ interface
           function pass_1 : tnode;override;
           function det_resulttype:tnode;override;
           function docompare(p: tnode) : boolean; override;
-       {$ifdef extdebug}
-          procedure _dowrite;override;
-       {$endif}
+          procedure printnodedata(var t:text);override;
        end;
        tordconstnodeclass = class of tordconstnode;
 
@@ -421,15 +417,13 @@ implementation
           (value_real = trealconstnode(p).value_real);
       end;
 
-{$ifdef extdebug}
-    procedure Trealconstnode._dowrite;
 
-    begin
-        inherited _dowrite;
-        writeln(',');
-        system.write(writenodeindention,'value = ',value_real);
-    end;
-{$endif}
+    procedure Trealconstnode.printnodedata(var t:text);
+      begin
+        inherited printnodedata(t);
+        writeln(t,printnodeindention,'value = ',value_real);
+      end;
+
 
 {*****************************************************************************
                               TORDCONSTNODE
@@ -506,15 +500,13 @@ implementation
           (value = tordconstnode(p).value);
       end;
 
-{$ifdef extdebug}
-    procedure Tordconstnode._dowrite;
 
-    begin
-        inherited _dowrite;
-        writeln(',');
-        system.write(writenodeindention,'value = ',value);
-    end;
-{$endif}
+    procedure Tordconstnode.printnodedata(var t:text);
+      begin
+        inherited printnodedata(t);
+        writeln(t,printnodeindention,'value = ',value);
+      end;
+
 
 {*****************************************************************************
                             TPOINTERCONSTNODE
@@ -946,7 +938,16 @@ begin
 end.
 {
   $Log$
-  Revision 1.48  2003-04-24 22:29:57  florian
+  Revision 1.49  2003-04-25 20:59:33  peter
+    * removed funcretn,funcretsym, function result is now in varsym
+      and aliases for result and function name are added using absolutesym
+    * vs_hidden parameter for funcret passed in parameter
+    * vs_hidden fixes
+    * writenode changed to printnode and released from extdebug
+    * -vp option added to generate a tree.log with the nodetree
+    * nicer printnode for statements, callnode
+
+  Revision 1.48  2003/04/24 22:29:57  florian
     * fixed a lot of PowerPC related stuff
 
   Revision 1.47  2003/04/23 20:16:04  peter

compiler/nflw.pas

@@ -60,9 +60,7 @@ interface
           procedure ppuwrite(ppufile:tcompilerppufile);override;
           procedure derefimpl;override;
           procedure insertintolist(l : tnodelist);override;
-{$ifdef extdebug}
-          procedure _dowrite;override;
-{$endif extdebug}
+          procedure printnodetree(var t:text);override;
           function docompare(p: tnode): boolean; override;
        end;
 
@@ -318,16 +316,19 @@ implementation
 
       begin
       end;
-{$ifdef extdebug}
-    procedure tloopnode._dowrite;
+
+
+    procedure tloopnode.printnodetree(var t:text);
       begin
-        inherited _dowrite;
-        writenodeindention:=writenodeindention+'    ';
-        writenode(t1);
-        writenode(t2);
-        delete(writenodeindention,1,4);
+        printnodeinfo(t);
+        printnodeindent;
+        printnode(t,left);
+        printnode(t,right);
+        printnode(t,t1);
+        printnode(t,t2);
+        printnodeunindent;
       end;
-{$endif extdebug}
+
 
     function tloopnode.docompare(p: tnode): boolean;
       begin
@@ -735,8 +736,7 @@ implementation
            hp:=tunarynode(hp).left;
          { we need a simple loadn, but the load must be in a global symtable or
            in the same lexlevel }
-         if (hp.nodetype=funcretn) or
-            (
+         if (
              (hp.nodetype=loadn) and
              (
               (tloadnode(hp).symtable.symtablelevel<=1) or
@@ -893,11 +893,11 @@ implementation
                  (procinfo.no_fast_exit) or
                  ((procinfo.flags and pi_uses_exceptions)<>0) then
                begin
-                 pt:=cfuncretnode.create(aktprocdef.funcretsym);
+                 pt:=load_funcret(aktprocdef);
                  left:=cassignmentnode.create(pt,left);
                  onlyassign:=true;
                end;
-              tfuncretsym(aktprocdef.funcretsym).funcretstate:=vs_assigned;
+              tvarsym(aktprocdef.funcretsym).varstate:=vs_assigned;
             end;
          end;
         if assigned(left) then
@@ -1494,7 +1494,16 @@ begin
 end.
 {
   $Log$
-  Revision 1.67  2003-04-25 08:25:26  daniel
+  Revision 1.68  2003-04-25 20:59:33  peter
+    * removed funcretn,funcretsym, function result is now in varsym
+      and aliases for result and function name are added using absolutesym
+    * vs_hidden parameter for funcret passed in parameter
+    * vs_hidden fixes
+    * writenode changed to printnode and released from extdebug
+    * -vp option added to generate a tree.log with the nodetree
+    * nicer printnode for statements, callnode
+
+  Revision 1.67  2003/04/25 08:25:26  daniel
     * Ifdefs around a lot of calls to cleartempgen
     * Fixed registers that are allocated but not freed in several nodes
     * Tweak to register allocator to cause less spills

compiler/nld.pas

@@ -49,9 +49,7 @@ interface
           function  det_resulttype:tnode;override;
           procedure mark_write;override;
           function  docompare(p: tnode): boolean; override;
-       {$ifdef extdebug}
-          procedure _dowrite;override;
-       {$endif}
+          procedure printnodedata(var t:text);override;
        end;
        tloadnodeclass = class of tloadnode;
 
@@ -73,20 +71,6 @@ interface
        end;
        tassignmentnodeclass = class of tassignmentnode;
 
-       tfuncretnode = class(tnode)
-          funcretsym : tfuncretsym;
-          constructor create(v:tsym);virtual;
-          constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
-          procedure ppuwrite(ppufile:tcompilerppufile);override;
-          procedure derefimpl;override;
-          function getcopy : tnode;override;
-          function pass_1 : tnode;override;
-          function det_resulttype:tnode;override;
-          procedure mark_write;override;
-          function docompare(p: tnode): boolean; override;
-       end;
-       tfuncretnodeclass = class of tfuncretnode;
-
        tarrayconstructorrangenode = class(tbinarynode)
           constructor create(l,r : tnode);virtual;
           function pass_1 : tnode;override;
@@ -136,7 +120,6 @@ interface
     var
        cloadnode : tloadnodeclass;
        cassignmentnode : tassignmentnodeclass;
-       cfuncretnode : tfuncretnodeclass;
        carrayconstructorrangenode : tarrayconstructorrangenodeclass;
        carrayconstructornode : tarrayconstructornodeclass;
        ctypenode : ttypenodeclass;
@@ -145,6 +128,7 @@ interface
 
     procedure load_procvar_from_calln(var p1:tnode);
     function load_high_value(vs:tvarsym):tnode;
+    function load_funcret(pd:tprocdef):tnode;
 
 
 implementation
@@ -216,6 +200,21 @@ implementation
       end;
 
 
+    function load_funcret(pd:tprocdef):tnode;
+      var
+        srsym : tsym;
+        srsymtable : tsymtable;
+      begin
+        result:=nil;
+        srsymtable:=pd.localst;
+        srsym:=searchsymonlyin(srsymtable,'result');
+        if assigned(srsym) then
+          result:=cloadnode.create(srsym,srsymtable)
+        else
+          CGMessage(cg_e_illegal_expression);
+      end;
+
+
 {*****************************************************************************
                              TLOADNODE
 *****************************************************************************}
@@ -294,7 +293,6 @@ implementation
     function tloadnode.det_resulttype:tnode;
       var
         p1 : tnode;
-        p  : tprocinfo;
       begin
          result:=nil;
          { optimize simple with loadings }
@@ -325,35 +323,6 @@ implementation
               exit;
            end;
          case symtableentry.typ of
-            funcretsym :
-              begin
-                { find the main funcret for the function }
-                p:=procinfo;
-                while assigned(p) do
-                 begin
-                   if assigned(p.procdef.funcretsym) and
-                      ((tfuncretsym(symtableentry)=p.procdef.resultfuncretsym) or
-                       (tfuncretsym(symtableentry)=p.procdef.funcretsym)) then
-                     begin
-                       symtableentry:=p.procdef.funcretsym;
-                       break;
-                     end;
-                    p:=p.parent;
-                  end;
-                { generate funcretnode }
-                p1:=cfuncretnode.create(symtableentry);
-                resulttypepass(p1);
-                { if it's refered as absolute then we need to have the
-                  type of the absolute instead of the function return,
-                  the function return is then also assigned }
-                if nf_absolute in flags then
-                 begin
-                   tfuncretsym(symtableentry).funcretstate:=vs_assigned;
-                   p1.resulttype:=resulttype;
-                 end;
-                left:=nil;
-                result:=p1;
-              end;
             constsym:
               begin
                  if tconstsym(symtableentry).consttyp=constresourcestring then
@@ -414,8 +383,6 @@ implementation
          case symtableentry.typ of
             absolutesym :
               ;
-            funcretsym :
-              internalerror(200104142);
             constsym:
               begin
                  if tconstsym(symtableentry).consttyp=constresourcestring then
@@ -501,15 +468,12 @@ implementation
           (symtable = tloadnode(p).symtable);
       end;
 
-{$ifdef extdebug}
-    procedure Tloadnode._dowrite;
 
-    begin
-        inherited _dowrite;
-        writeln(',');
-        system.write(writenodeindention,'symbol = ',symtableentry.name);
-    end;
-{$endif}
+    procedure Tloadnode.printnodedata(var t:text);
+      begin
+        inherited printnodedata(t);
+        writeln(t,printnodeindention,'symbol = ',symtableentry.name);
+      end;
 
 
 {*****************************************************************************
@@ -607,7 +571,7 @@ implementation
         resulttypepass(right);
         set_varstate(left,false);
         set_varstate(right,true);
-        set_funcret_is_valid(left);
+{        set_funcret_is_valid(left); }
         if codegenerror then
           exit;
 
@@ -790,78 +754,6 @@ implementation
     end;
 {$endif}
 
-{*****************************************************************************
-                                 TFUNCRETNODE
-*****************************************************************************}
-
-    constructor tfuncretnode.create(v:tsym);
-
-      begin
-         inherited create(funcretn);
-         funcretsym:=tfuncretsym(v);
-      end;
-
-
-    constructor tfuncretnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
-      begin
-        inherited ppuload(t,ppufile);
-        funcretsym:=tfuncretsym(ppufile.getderef);
-      end;
-
-
-    procedure tfuncretnode.ppuwrite(ppufile:tcompilerppufile);
-      begin
-        inherited ppuwrite(ppufile);
-        ppufile.putderef(funcretsym);
-      end;
-
-
-    procedure tfuncretnode.derefimpl;
-      begin
-        inherited derefimpl;
-        resolvesym(pointer(funcretsym));
-      end;
-
-
-    function tfuncretnode.getcopy : tnode;
-      var
-         n : tfuncretnode;
-      begin
-         n:=tfuncretnode(inherited getcopy);
-         n.funcretsym:=funcretsym;
-         getcopy:=n;
-      end;
-
-
-    function tfuncretnode.det_resulttype:tnode;
-      begin
-        result:=nil;
-        resulttype:=funcretsym.returntype;
-      end;
-
-    procedure Tfuncretnode.mark_write;
-
-    begin
-      include(flags,nf_write);
-    end;
-
-    function tfuncretnode.pass_1 : tnode;
-      begin
-         result:=nil;
-         expectloc:=LOC_REFERENCE;
-         if paramanager.ret_in_param(resulttype.def,tprocdef(funcretsym.owner.defowner).proccalloption) or
-            (lexlevel<>funcretsym.owner.symtablelevel) then
-           registers32:=1;
-      end;
-
-
-    function tfuncretnode.docompare(p: tnode): boolean;
-      begin
-        docompare :=
-          inherited docompare(p) and
-          (funcretsym = tfuncretnode(p).funcretsym);
-      end;
-
 
 {*****************************************************************************
                            TARRAYCONSTRUCTORRANGENODE
@@ -1252,7 +1144,6 @@ implementation
 begin
    cloadnode:=tloadnode;
    cassignmentnode:=tassignmentnode;
-   cfuncretnode:=tfuncretnode;
    carrayconstructorrangenode:=tarrayconstructorrangenode;
    carrayconstructornode:=tarrayconstructornode;
    ctypenode:=ttypenode;
@@ -1260,7 +1151,16 @@ begin
 end.
 {
   $Log$
-  Revision 1.86  2003-04-23 20:16:04  peter
+  Revision 1.87  2003-04-25 20:59:33  peter
+    * removed funcretn,funcretsym, function result is now in varsym
+      and aliases for result and function name are added using absolutesym
+    * vs_hidden parameter for funcret passed in parameter
+    * vs_hidden fixes
+    * writenode changed to printnode and released from extdebug
+    * -vp option added to generate a tree.log with the nodetree
+    * nicer printnode for statements, callnode
+
+  Revision 1.86  2003/04/23 20:16:04  peter
     + added currency support based on int64
     + is_64bit for use in cg units instead of is_64bitint
     * removed cgmessage from n386add, replace with internalerrors

compiler/nmat.pas

@@ -529,7 +529,7 @@ implementation
            begin
               minusdef:=nil;
               if assigned(overloaded_operators[_minus]) then
-                minusdef:=overloaded_operators[_minus].search_procdef_by1paradef(left.resulttype.def);
+                minusdef:=overloaded_operators[_minus].search_procdef_unary_operator(left.resulttype.def);
               if minusdef<>nil then
                 begin
                   t:=ccallnode.create(ccallparanode.create(left,nil),
@@ -702,7 +702,7 @@ implementation
            begin
               notdef:=nil;
               if assigned(overloaded_operators[_op_not]) then
-                notdef:=overloaded_operators[_op_not].search_procdef_by1paradef(left.resulttype.def);
+                notdef:=overloaded_operators[_op_not].search_procdef_unary_operator(left.resulttype.def);
               if notdef<>nil then
                 begin
                   t:=ccallnode.create(ccallparanode.create(left,nil),
@@ -793,7 +793,16 @@ begin
 end.
 {
   $Log$
-  Revision 1.46  2003-04-23 20:16:04  peter
+  Revision 1.47  2003-04-25 20:59:33  peter
+    * removed funcretn,funcretsym, function result is now in varsym
+      and aliases for result and function name are added using absolutesym
+    * vs_hidden parameter for funcret passed in parameter
+    * vs_hidden fixes
+    * writenode changed to printnode and released from extdebug
+    * -vp option added to generate a tree.log with the nodetree
+    * nicer printnode for statements, callnode
+
+  Revision 1.46  2003/04/23 20:16:04  peter
     + added currency support based on int64
     + is_64bit for use in cg units instead of is_64bitint
     * removed cgmessage from n386add, replace with internalerrors

compiler/nobj.pas

@@ -547,7 +547,7 @@ implementation
            { check, if a method should be overridden }
            if (pd._class=_class) and
               (po_overridingmethod in pd.procoptions) then
-             MessagePos1(pd.fileinfo,parser_e_nothing_to_be_overridden,pd.fullprocname);
+             MessagePos1(pd.fileinfo,parser_e_nothing_to_be_overridden,pd.fullprocname(false));
         end;
 
       { creates a new entry in the procsym list }
@@ -634,7 +634,7 @@ implementation
                                            if is_visible then
                                              procdefcoll^.hidden:=true;
                                            if _class=pd._class then
-                                             MessagePos1(pd.fileinfo,parser_w_should_use_override,pd.fullprocname);
+                                             MessagePos1(pd.fileinfo,parser_w_should_use_override,pd.fullprocname(false));
                                          end;
                                       end
                                      { if both are virtual we check the header }
@@ -653,7 +653,7 @@ implementation
                                               if is_visible then
                                                 procdefcoll^.hidden:=true;
                                               if _class=pd._class then
-                                                MessagePos1(pd.fileinfo,parser_w_should_use_override,pd.fullprocname);
+                                                MessagePos1(pd.fileinfo,parser_w_should_use_override,pd.fullprocname(false));
                                             end;
                                          end
                                         { check if the method to override is visible }
@@ -676,7 +676,7 @@ implementation
                                                ((procdefcoll^.data.procoptions-
                                                    [po_abstractmethod,po_overridingmethod,po_assembler,po_overload])<>
                                                 (pd.procoptions-[po_abstractmethod,po_overridingmethod,po_assembler,po_overload])) then
-                                              MessagePos1(pd.fileinfo,parser_e_header_dont_match_forward,pd.fullprocname);
+                                              MessagePos1(pd.fileinfo,parser_e_header_dont_match_forward,pd.fullprocname(false));
 
                                            { error, if the return types aren't equal }
                                            if not(equal_defs(procdefcoll^.data.rettype.def,pd.rettype.def)) and
@@ -686,8 +686,8 @@ implementation
                                                is_class(pd.rettype.def) and
                                                (tobjectdef(pd.rettype.def).is_related(
                                                    tobjectdef(procdefcoll^.data.rettype.def)))) then
-                                             Message2(parser_e_overridden_methods_not_same_ret,pd.fullprocnamewithret,
-                                                      procdefcoll^.data.fullprocnamewithret);
+                                             Message2(parser_e_overridden_methods_not_same_ret,pd.fullprocname(false),
+                                                      procdefcoll^.data.fullprocname(false));
 
                                            { now set the number }
                                            pd.extnumber:=procdefcoll^.data.extnumber;
@@ -707,7 +707,7 @@ implementation
                                               if is_visible then
                                                 procdefcoll^.hidden:=true;
                                               if _class=pd._class then
-                                                MessagePos1(pd.fileinfo,parser_w_should_use_override,pd.fullprocname);
+                                                MessagePos1(pd.fileinfo,parser_w_should_use_override,pd.fullprocname(false));
                                             end;
                                          end;
                                       end
@@ -1072,7 +1072,7 @@ implementation
                 if assigned(implprocdef) then
                   _class.implementedinterfaces.addimplproc(intfindex,implprocdef)
                 else
-                  Message1(sym_e_no_matching_implementation_found,proc.fullprocnamewithret);
+                  Message1(sym_e_no_matching_implementation_found,proc.fullprocname(false));
               end;
           end;
       end;
@@ -1333,7 +1333,16 @@ initialization
 end.
 {
   $Log$
-  Revision 1.41  2003-04-23 10:11:22  peter
+  Revision 1.42  2003-04-25 20:59:33  peter
+    * removed funcretn,funcretsym, function result is now in varsym
+      and aliases for result and function name are added using absolutesym
+    * vs_hidden parameter for funcret passed in parameter
+    * vs_hidden fixes
+    * writenode changed to printnode and released from extdebug
+    * -vp option added to generate a tree.log with the nodetree
+    * nicer printnode for statements, callnode
+
+  Revision 1.41  2003/04/23 10:11:22  peter
     * range check error for GUID fixed
 
   Revision 1.40  2003/01/13 14:54:34  daniel

compiler/node.pas

@@ -81,7 +81,6 @@ interface
           vecn,             {Represents array indexing}
           pointerconstn,    {Represents a pointer constant}
           stringconstn,     {Represents a string constant}
-          funcretn,         {Represents the function result var}
           selfn,            {Represents the self parameter}
           notn,             {Represents the not operator}
           inlinen,          {Internal procedures (i.e. writeln)}
@@ -166,7 +165,6 @@ interface
           'vecn',
           'pointerconstn',
           'stringconstn',
-          'funcretn',
           'selfn',
           'notn',
           'inlinen',
@@ -261,7 +259,10 @@ interface
          nf_explicit,
 
          { tinlinenode }
-         nf_inlineconst
+         nf_inlineconst,
+
+         { tblocknode }
+         nf_releasetemps
        );
 
        tnodeflagset = set of tnodeflags;
@@ -344,14 +345,12 @@ interface
           function getcopy : tnode;virtual;
 
           procedure insertintolist(l : tnodelist);virtual;
-{$ifdef EXTDEBUG}
           { writes a node for debugging purpose, shouldn't be called }
-          { direct, because there is no test for nil, use writenode  }
-          { to write a complete tree                                 }
-          procedure dowrite;
-          procedure dowritenodetype;virtual;
-          procedure _dowrite;virtual;
-{$endif EXTDEBUG}
+          { direct, because there is no test for nil, use printnode  }
+          { to write a complete tree }
+          procedure printnodeinfo(var t:text);
+          procedure printnodedata(var t:text);virtual;
+          procedure printnodetree(var t:text);virtual;
           procedure concattolist(l : tlinkedlist);virtual;
           function ischild(p : tnode) : boolean;virtual;
           procedure set_file_line(from : tnode);
@@ -379,9 +378,7 @@ interface
           function getcopy : tnode;override;
           procedure insertintolist(l : tnodelist);override;
           procedure left_max;
-{$ifdef extdebug}
-          procedure _dowrite;override;
-{$endif extdebug}
+          procedure printnodedata(var t:text);override;
        end;
 
        pbinarynode = ^tbinarynode;
@@ -399,9 +396,8 @@ interface
           function getcopy : tnode;override;
           procedure insertintolist(l : tnodelist);override;
           procedure left_right_max;
-{$ifdef extdebug}
-          procedure _dowrite;override;
-{$endif extdebug}
+          procedure printnodedata(var t:text);override;
+          procedure printnodelist(var t:text);
        end;
 
        tbinopnode = class(tbinarynode)
@@ -419,17 +415,20 @@ interface
     var
       { array with all class types for tnodes }
       nodeclass : tnodeclassarray;
-{$ifdef EXTDEBUG}
-      { indention used when writing the tree to the screen }
-      writenodeindention : string;
-{$endif EXTDEBUG}
-
 
     function ppuloadnode(ppufile:tcompilerppufile):tnode;
     procedure ppuwritenode(ppufile:tcompilerppufile;n:tnode);
-{$ifdef EXTDEBUG}
-    procedure writenode(t:tnode);
-{$endif EXTDEBUG}
+
+    const
+      printnodespacing = '   ';
+    var
+      { indention used when writing the tree to the screen }
+      printnodeindention : string;
+
+    procedure printnodeindent;
+    procedure printnodeunindent;
+    procedure printnode(var t:text;n:tnode);
+
 
 
 implementation
@@ -487,17 +486,26 @@ implementation
       end;
 
 
-{$ifdef EXTDEBUG}
-     procedure writenode(t:tnode);
-       begin
-         if assigned(t) then
-          t.dowrite
-         else
-          write(writenodeindention,'nil');
-         if writenodeindention='' then
-           writeln;
-       end;
-{$endif EXTDEBUG}
+    procedure printnodeindent;
+      begin
+        printnodeindention:=printnodeindention+printnodespacing;
+      end;
+
+
+    procedure printnodeunindent;
+      begin
+        delete(printnodeindention,1,length(printnodespacing));
+      end;
+
+
+    procedure printnode(var t:text;n:tnode);
+      begin
+        if assigned(n) then
+         n.printnodetree(t)
+        else
+         writeln(t,printnodeindention,'nil');
+      end;
+
 
 {****************************************************************************
                                  TNODE
@@ -577,7 +585,6 @@ implementation
 
 
     procedure tnode.toggleflag(f : tnodeflags);
-
       begin
          if f in flags then
            exclude(flags,f)
@@ -585,8 +592,8 @@ implementation
            include(flags,f);
       end;
 
-    destructor tnode.destroy;
 
+    destructor tnode.destroy;
       begin
 {$ifdef EXTDEBUG}
          if firstpasscount>maxfirstpasscount then
@@ -596,12 +603,11 @@ implementation
 
 
     procedure tnode.concattolist(l : tlinkedlist);
-
       begin
       end;
 
-    function tnode.ischild(p : tnode) : boolean;
 
+    function tnode.ischild(p : tnode) : boolean;
       begin
          ischild:=false;
       end;
@@ -615,57 +621,37 @@ implementation
       end;
 
 
-{$ifdef EXTDEBUG}
-    procedure tnode._dowrite;
-      const
-         loc2str : array[TCGLoc] of string[18] = (
-           'LOC_INVALID',
-           'LOC_VOID',
-           'LOC_CONSTANT',
-           'LOC_JUMP',
-           'LOC_FLAGS',
-           'LOC_CREFERENCE',
-           'LOC_REFERENCE',
-           'LOC_REGISTER',
-           'LOC_CREGISTER',
-           'LOC_FPUREGISTER',
-           'LOC_CFPUREGISTER',
-           'LOC_MMXREGISTER',
-           'LOC_CMMXREGISTER',
-           'LOC_SSEREGISTER',
-           'LOC_CSSEREGISTER',
-           'LOC_MMREGISTER',
-           'LOC_CMMREGISTER');
-
+    procedure tnode.printnodeinfo(var t:text);
       begin
-        dowritenodetype;
+        write(t,nodetype2str[nodetype]);
         if assigned(resulttype.def) then
-          write(',resulttype = "',resulttype.def.gettypename,'"')
+          write(t,' ,resulttype = "',resulttype.def.gettypename,'"')
         else
-          write(',resulttype = <nil>');
-        write(',location.loc = ',loc2str[location.loc]);
-        write(',registersint = ',registers32);
-        write(',registersfpu = ',registersfpu);
+          write(t,' ,resulttype = <nil>');
+        writeln(t,', pos = (',fileinfo.line,',',fileinfo.column,')',
+                  ', loc = ',tcgloc2str[location.loc],
+                  ', inttgobj:  = ',registers32,
+                  ', fpuregs = ',registersfpu);
       end;
 
-    procedure tnode.dowritenodetype;
+
+    procedure tnode.printnodedata(var t:text);
       begin
-          write(nodetype2str[nodetype]);
       end;
 
-    procedure tnode.dowrite;
+
+    procedure tnode.printnodetree(var t:text);
       begin
-         write(writenodeindention,'(');
-         writenodeindention:=writenodeindention+'    ';
-         _dowrite;
-         writeln;
-         delete(writenodeindention,1,4);
-         write(writenodeindention,')');
+         write(t,printnodeindention,'(');
+         printnodeinfo(t);
+         printnodeindent;
+         printnodedata(t);
+         printnodeunindent;
+         writeln(t,printnodeindention,')');
       end;
-{$endif EXTDEBUG}
 
-    function tnode.isequal(p : tnode) : boolean;
 
+    function tnode.isequal(p : tnode) : boolean;
       begin
          isequal:=
            (not assigned(self) and not assigned(p)) or
@@ -680,24 +666,21 @@ implementation
 
 {$ifdef state_tracking}
     function Tnode.track_state_pass(exec_known:boolean):boolean;
-
-    begin
-    track_state_pass:=false;
-    end;
+      begin
+        track_state_pass:=false;
+      end;
 {$endif state_tracking}
 
-    function tnode.docompare(p : tnode) : boolean;
 
+    function tnode.docompare(p : tnode) : boolean;
       begin
          docompare:=true;
       end;
 
 
     function tnode.getcopy : tnode;
-
       var
          p : tnode;
-
       begin
          { this is quite tricky because we need a node of the current }
          { node type and not one of tnode!                            }
@@ -722,34 +705,30 @@ implementation
          getcopy:=p;
       end;
 
-{    procedure tnode.mark_write;
-      begin
-      end;}
 
     procedure tnode.insertintolist(l : tnodelist);
-
       begin
       end;
 
-    procedure tnode.set_file_line(from : tnode);
 
+    procedure tnode.set_file_line(from : tnode);
       begin
          if assigned(from) then
            fileinfo:=from.fileinfo;
       end;
 
-    procedure tnode.set_tree_filepos(const filepos : tfileposinfo);
 
+    procedure tnode.set_tree_filepos(const filepos : tfileposinfo);
       begin
          fileinfo:=filepos;
       end;
 
+
 {****************************************************************************
                                  TUNARYNODE
  ****************************************************************************}
 
     constructor tunarynode.create(t:tnodetype;l : tnode);
-
       begin
          inherited create(t);
          left:=l;
@@ -786,18 +765,16 @@ implementation
 
 
     function tunarynode.docompare(p : tnode) : boolean;
-
       begin
          docompare:=(inherited docompare(p) and
            ((left=nil) or left.isequal(tunarynode(p).left))
          );
       end;
 
-    function tunarynode.getcopy : tnode;
 
+    function tunarynode.getcopy : tnode;
       var
          p : tunarynode;
-
       begin
          p:=tunarynode(inherited getcopy);
          if assigned(left) then
@@ -807,23 +784,20 @@ implementation
          getcopy:=p;
       end;
 
-    procedure tunarynode.insertintolist(l : tnodelist);
 
+    procedure tunarynode.insertintolist(l : tnodelist);
       begin
       end;
 
-{$ifdef extdebug}
-    procedure tunarynode._dowrite;
 
+    procedure tunarynode.printnodedata(var t:text);
       begin
-         inherited _dowrite;
-         writeln(',');
-         writenode(left);
+         inherited printnodedata(t);
+         printnode(t,left);
       end;
-{$endif}
 
-    procedure tunarynode.left_max;
 
+    procedure tunarynode.left_max;
       begin
          registers32:=left.registers32;
          registersfpu:=left.registersfpu;
@@ -832,26 +806,26 @@ implementation
 {$endif SUPPORT_MMX}
       end;
 
-    procedure tunarynode.concattolist(l : tlinkedlist);
 
+    procedure tunarynode.concattolist(l : tlinkedlist);
       begin
          left.parent:=self;
          left.concattolist(l);
          inherited concattolist(l);
       end;
 
-    function tunarynode.ischild(p : tnode) : boolean;
 
+    function tunarynode.ischild(p : tnode) : boolean;
       begin
          ischild:=p=left;
       end;
 
+
 {****************************************************************************
                             TBINARYNODE
  ****************************************************************************}
 
     constructor tbinarynode.create(t:tnodetype;l,r : tnode);
-
       begin
          inherited create(t,l);
          right:=r
@@ -888,7 +862,6 @@ implementation
 
 
     procedure tbinarynode.concattolist(l : tlinkedlist);
-
       begin
          { we could change that depending on the number of }
          { required registers                              }
@@ -899,25 +872,24 @@ implementation
          inherited concattolist(l);
       end;
 
-    function tbinarynode.ischild(p : tnode) : boolean;
 
+    function tbinarynode.ischild(p : tnode) : boolean;
       begin
          ischild:=(p=right);
       end;
 
-    function tbinarynode.docompare(p : tnode) : boolean;
 
+    function tbinarynode.docompare(p : tnode) : boolean;
       begin
          docompare:=(inherited docompare(p) and
              ((right=nil) or right.isequal(tbinarynode(p).right))
          );
       end;
 
-    function tbinarynode.getcopy : tnode;
 
+    function tbinarynode.getcopy : tnode;
       var
          p : tbinarynode;
-
       begin
          p:=tbinarynode(inherited getcopy);
          if assigned(right) then
@@ -927,16 +899,15 @@ implementation
          getcopy:=p;
       end;
 
-    procedure tbinarynode.insertintolist(l : tnodelist);
 
+    procedure tbinarynode.insertintolist(l : tnodelist);
       begin
       end;
 
-    procedure tbinarynode.swapleftright;
 
+    procedure tbinarynode.swapleftright;
       var
          swapp : tnode;
-
       begin
          swapp:=right;
          right:=left;
@@ -947,6 +918,7 @@ implementation
            include(flags,nf_swaped);
       end;
 
+
     procedure tbinarynode.left_right_max;
       begin
         if assigned(left) then
@@ -970,28 +942,43 @@ implementation
          end;
       end;
 
-{$ifdef extdebug}
-    procedure tbinarynode._dowrite;
 
+    procedure tbinarynode.printnodedata(var t:text);
       begin
-         inherited _dowrite;
-         writeln(',');
-         writenode(right);
+         inherited printnodedata(t);
+         printnode(t,right);
       end;
-{$endif}
+
+
+    procedure tbinarynode.printnodelist(var t:text);
+      var
+        hp : tbinarynode;
+      begin
+        hp:=self;
+        while assigned(hp) do
+         begin
+           write(t,printnodeindention,'(');
+           printnodeindent;
+           hp.printnodeinfo(t);
+           printnode(t,hp.left);
+           printnodeunindent;
+           writeln(t,printnodeindention,')');
+           hp:=tbinarynode(hp.right);
+         end;
+      end;
+
 
 {****************************************************************************
                             TBINOPYNODE
  ****************************************************************************}
 
     constructor tbinopnode.create(t:tnodetype;l,r : tnode);
-
       begin
          inherited create(t,l,r);
       end;
 
-    function tbinopnode.docompare(p : tnode) : boolean;
 
+    function tbinopnode.docompare(p : tnode) : boolean;
       begin
          docompare:=(inherited docompare(p)) or
            { if that's in the flags, is p then always a tbinopnode (?) (JM) }
@@ -1003,7 +990,20 @@ implementation
 end.
 {
   $Log$
-  Revision 1.56  2003-04-24 22:29:58  florian
+  Revision 1.58  2003-04-25 20:59:33  peter
+    * removed funcretn,funcretsym, function result is now in varsym
+      and aliases for result and function name are added using absolutesym
+    * vs_hidden parameter for funcret passed in parameter
+    * vs_hidden fixes
+    * writenode changed to printnode and released from extdebug
+    * -vp option added to generate a tree.log with the nodetree
+    * nicer printnode for statements, callnode
+
+  Revision 1.57  2002/04/25 20:15:39  florian
+    * block nodes within expressions shouldn't release the used registers,
+      fixed using a flag till the new rg is ready
+
+  Revision 1.56  2003/04/24 22:29:58  florian
     * fixed a lot of PowerPC related stuff
 
   Revision 1.55  2003/04/23 10:12:14  peter

compiler/parser.pas

@@ -54,7 +54,7 @@ implementation
 {$endif GDB}
       comphook,
       scanner,scandir,
-      pbase,ptype,psystem,pmodules,cresstr,cpuinfo;
+      pbase,ptype,psystem,pmodules,psub,cresstr,cpuinfo;
 
 
     procedure initparser;
@@ -113,6 +113,10 @@ implementation
 
          { list of generated .o files, so the linker can remove them }
          SmartLinkOFiles:=TStringList.Create;
+
+         { codegen }
+         if paraprintnodetree<>0 then
+           printnode_reset;
       end;
 
 
@@ -621,7 +625,16 @@ implementation
 end.
 {
   $Log$
-  Revision 1.48  2002-12-29 14:57:50  peter
+  Revision 1.49  2003-04-25 20:59:33  peter
+    * removed funcretn,funcretsym, function result is now in varsym
+      and aliases for result and function name are added using absolutesym
+    * vs_hidden parameter for funcret passed in parameter
+    * vs_hidden fixes
+    * writenode changed to printnode and released from extdebug
+    * -vp option added to generate a tree.log with the nodetree
+    * nicer printnode for statements, callnode
+
+  Revision 1.48  2002/12/29 14:57:50  peter
     * unit loading changed to first register units and load them
       afterwards. This is needed to support uses xxx in yyy correctly
     * unit dependency check fixed

compiler/pass_2.pas

@@ -107,7 +107,6 @@ implementation
              'vecn',        {vecn}
              'pointerconst',{pointerconstn}
              'stringconst', {stringconstn}
-             'funcret',     {funcretn}
              'selfn',       {selfn}
              'not',         {notn}
              'inline',      {inlinen}
@@ -215,7 +214,7 @@ implementation
             for i:=1 to max_scratch_regs do
               if not(scratch_regs[i] in cg.unusedscratchregisters) then
                 begin
-                   writenode(p);
+                   printnode(stdout,p);
                    internalerror(2003042201);
                 end;
 {$endif EXTDEBUG}
@@ -352,7 +351,16 @@ implementation
 end.
 {
   $Log$
-  Revision 1.46  2003-04-23 10:12:14  peter
+  Revision 1.47  2003-04-25 20:59:33  peter
+    * removed funcretn,funcretsym, function result is now in varsym
+      and aliases for result and function name are added using absolutesym
+    * vs_hidden parameter for funcret passed in parameter
+    * vs_hidden fixes
+    * writenode changed to printnode and released from extdebug
+    * -vp option added to generate a tree.log with the nodetree
+    * nicer printnode for statements, callnode
+
+  Revision 1.46  2003/04/23 10:12:14  peter
     * allow multi pass2 changed to global boolean instead of node flag
 
   Revision 1.45  2003/04/22 23:50:23  peter

compiler/pdecobj.pas

@@ -212,12 +212,12 @@ implementation
            pd : tprocdef;
            pt : tnode;
            propname : stringid;
-           dummyst : tparasymtable;
-           vs : tvarsym;
            sc : tsinglelist;
            oldregisterdef : boolean;
-           temppara : tparaitem;
-           propertyprocdef : tprocvardef;
+           readvs,
+           hvs      : tvarsym;
+           readprocdef,
+           writeprocdef : tprocvardef;
         begin
            { check for a class }
            aktprocsym:=nil;
@@ -226,313 +226,328 @@ implementation
               ((m_delphi in aktmodeswitches) and (is_object(aktclass)))) then
              Message(parser_e_syntax_error);
            consume(_PROPERTY);
+
+           { Generate temp procvardefs to search for matching read/write
+             procedures. the readprocdef will store all definitions }
            oldregisterdef:=registerdef;
            registerdef:=false;
-           propertyprocdef:=tprocvardef.create;
+           readprocdef:=tprocvardef.create;
+           writeprocdef:=tprocvardef.create;
            registerdef:=oldregisterdef;
-           if token=_ID then
+
+           if token<>_ID then
              begin
-                p:=tpropertysym.create(orgpattern);
-                propname:=pattern;
                 consume(_ID);
-                { property parameters ? }
-                if token=_LECKKLAMMER then
-                  begin
-                     if (sp_published in current_object_option) then
-                       Message(parser_e_cant_publish_that_property);
-
-                     { create a list of the parameters }
-                     dummyst:=tparasymtable.create;
-                     dummyst.next:=symtablestack;
-                     symtablestack:=dummyst;
-                     sc:=tsinglelist.create;
-                     consume(_LECKKLAMMER);
-                     inc(testcurobject);
-                     repeat
-                       if token=_VAR then
-                         begin
-                            consume(_VAR);
-                            varspez:=vs_var;
-                         end
-                       else if token=_CONST then
-                         begin
-                            consume(_CONST);
-                            varspez:=vs_const;
-                         end
-                       else if (idtoken=_OUT) and (m_out in aktmodeswitches) then
-                         begin
-                            consume(_OUT);
-                            varspez:=vs_out;
-                         end
-                       else
-                         varspez:=vs_value;
-                       sc.reset;
-                       repeat
-                         vs:=tvarsym.create(orgpattern,generrortype);
-                         dummyst.insert(vs);
-                         sc.insert(vs);
-                         consume(_ID);
-                       until not try_to_consume(_COMMA);
-                       if token=_COLON then
+                consume(_SEMICOLON);
+                exit;
+             end;
+           { Generate propertysym and insert in symtablestack }
+           p:=tpropertysym.create(orgpattern);
+           symtablestack.insert(p);
+           propname:=pattern;
+           consume(_ID);
+           { Set the symtablestack to the parast of readprop so
+             temp defs will be destroyed after declaration }
+           readprocdef.parast.next:=symtablestack;
+           symtablestack:=readprocdef.parast;
+           { property parameters ? }
+           if token=_LECKKLAMMER then
+             begin
+                if (sp_published in current_object_option) then
+                  Message(parser_e_cant_publish_that_property);
+
+                { create a list of the parameters }
+                sc:=tsinglelist.create;
+                consume(_LECKKLAMMER);
+                inc(testcurobject);
+                repeat
+                  if token=_VAR then
+                    begin
+                       consume(_VAR);
+                       varspez:=vs_var;
+                    end
+                  else if token=_CONST then
+                    begin
+                       consume(_CONST);
+                       varspez:=vs_const;
+                    end
+                  else if (idtoken=_OUT) and (m_out in aktmodeswitches) then
+                    begin
+                       consume(_OUT);
+                       varspez:=vs_out;
+                    end
+                  else
+                    varspez:=vs_value;
+                  sc.reset;
+                  repeat
+                    readvs:=tvarsym.create(orgpattern,generrortype);
+                    readprocdef.parast.insert(readvs);
+                    sc.insert(readvs);
+                    consume(_ID);
+                  until not try_to_consume(_COMMA);
+                  if token=_COLON then
+                    begin
+                       consume(_COLON);
+                       if token=_ARRAY then
                          begin
-                            consume(_COLON);
-                            if token=_ARRAY then
-                              begin
-                                 consume(_ARRAY);
-                                 consume(_OF);
-                                 { define range and type of range }
-                                 tt.setdef(tarraydef.create(0,-1,s32bittype));
-                                 { define field type }
-                                 single_type(arraytype,s,false);
-                                 tarraydef(tt.def).setelementtype(arraytype);
-                              end
-                            else
-                              single_type(tt,s,false);
+                            consume(_ARRAY);
+                            consume(_OF);
+                            { define range and type of range }
+                            tt.setdef(tarraydef.create(0,-1,s32bittype));
+                            { define field type }
+                            single_type(arraytype,s,false);
+                            tarraydef(tt.def).setelementtype(arraytype);
                          end
                        else
-                         tt:=cformaltype;
-                       vs:=tvarsym(sc.first);
-                       while assigned(vs) do
-                        begin
-                          propertyprocdef.concatpara(nil,tt,nil,varspez,nil);
-                          vs:=tvarsym(vs.listnext);
-                        end;
-                     until not try_to_consume(_SEMICOLON);
-                     dec(testcurobject);
-                     consume(_RECKKLAMMER);
-
-                     { remove dummy symtable }
-                     symtablestack:=symtablestack.next;
-                     dummyst.free;
-                     sc.free;
-
-                     { the parser need to know if a property has parameters, the
-                       index parameter doesn't count (PFV) }
-                     if propertyprocdef.minparacount>0 then
-                       include(p.propoptions,ppo_hasparameters);
-                  end;
-                { overriden property ?                                 }
-                { force property interface, if there is a property parameter }
-                if (token=_COLON) or (propertyprocdef.minparacount>0) then
+                         single_type(tt,s,false);
+                    end
+                  else
+                    tt:=cformaltype;
+                  readvs:=tvarsym(sc.first);
+                  while assigned(readvs) do
+                   begin
+                     readprocdef.concatpara(nil,tt,readvs,varspez,nil);
+                     { also update the writeprocdef }
+                     hvs:=tvarsym.create(readvs.realname,generrortype);
+                     writeprocdef.parast.insert(hvs);
+                     writeprocdef.concatpara(nil,tt,hvs,varspez,nil);
+                     readvs:=tvarsym(readvs.listnext);
+                   end;
+                until not try_to_consume(_SEMICOLON);
+                sc.free;
+                dec(testcurobject);
+                consume(_RECKKLAMMER);
+
+                { the parser need to know if a property has parameters, the
+                  index parameter doesn't count (PFV) }
+                if readprocdef.minparacount>0 then
+                  include(p.propoptions,ppo_hasparameters);
+             end;
+           { overriden property ?                                 }
+           { force property interface, if there is a property parameter }
+           if (token=_COLON) or (readprocdef.minparacount>0) then
+             begin
+                consume(_COLON);
+                single_type(p.proptype,hs,false);
+                if (idtoken=_INDEX) then
                   begin
-                     consume(_COLON);
-                     single_type(p.proptype,hs,false);
-                     if (idtoken=_INDEX) then
+                     consume(_INDEX);
+                     pt:=comp_expr(true);
+                     if is_constnode(pt) and
+                        is_ordinal(pt.resulttype.def) and
+                        (not is_64bitint(pt.resulttype.def)) then
+                       p.index:=tordconstnode(pt).value
+                     else
                        begin
-                          consume(_INDEX);
-                          pt:=comp_expr(true);
-                          if is_constnode(pt) and
-                             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.def);
-                          include(p.propoptions,ppo_indexed);
-                          { concat a longint to the para template }
-                          propertyprocdef.concatpara(nil,p.indextype,nil,vs_value,nil);
-                          pt.free;
+                         Message(parser_e_invalid_property_index_value);
+                         p.index:=0;
                        end;
+                     p.indextype.setdef(pt.resulttype.def);
+                     include(p.propoptions,ppo_indexed);
+                     { concat a longint to the para templates }
+                     hvs:=tvarsym.create('$index',p.indextype);
+                     readprocdef.parast.insert(hvs);
+                     readprocdef.concatpara(nil,p.indextype,hvs,vs_value,nil);
+                     hvs:=tvarsym.create('$index',p.indextype);
+                     writeprocdef.parast.insert(hvs);
+                     writeprocdef.concatpara(nil,p.indextype,hvs,vs_value,nil);
+                     pt.free;
+                  end;
+             end
+           else
+             begin
+                { do an property override }
+                overriden:=search_class_member(aktclass,propname);
+                if assigned(overriden) and (overriden.typ=propertysym) then
+                  begin
+                    p.dooverride(tpropertysym(overriden));
                   end
                 else
                   begin
-                     { do an property override }
-                     overriden:=search_class_member(aktclass,propname);
-                     if assigned(overriden) and (overriden.typ=propertysym) then
-                       begin
-                         p.dooverride(tpropertysym(overriden));
-                       end
-                     else
-                       begin
-                         p.proptype:=generrortype;
-                         message(parser_e_no_property_found_to_override);
-                       end;
+                    p.proptype:=generrortype;
+                    message(parser_e_no_property_found_to_override);
                   end;
-                if (sp_published in current_object_option) and
-                   not(p.proptype.def.is_publishable) then
-                  Message(parser_e_cant_publish_that_property);
+             end;
+           if (sp_published in current_object_option) and
+              not(p.proptype.def.is_publishable) then
+             Message(parser_e_cant_publish_that_property);
 
-                if try_to_consume(_READ) then
-                 begin
-                   p.readaccess.clear;
-                   if parse_symlist(p.readaccess) then
-                    begin
-                      sym:=p.readaccess.firstsym^.sym;
-                      case sym.typ of
-                        procsym :
-                          begin
-                            pd:=Tprocsym(sym).search_procdef_bypara(propertyprocdef.para,true,false);
-                            if not(assigned(pd)) or
-                               not(equal_defs(pd.rettype.def,p.proptype.def)) then
-                              Message(parser_e_ill_property_access_sym);
-                            p.readaccess.setdef(pd);
-                          end;
-                        varsym :
-                          begin
-                            if compare_defs(p.readaccess.def,p.proptype.def,nothingn)>=te_equal then
-                             begin
-                               { property parameters are allowed if this is
-                                 an indexed property, because the index is then
-                                 the parameter.
-                                 Note: In the help of Kylix it is written
-                                 that it isn't allowed, but the compiler accepts it (PFV) }
-                               if (ppo_hasparameters in p.propoptions) then
-                                Message(parser_e_ill_property_access_sym);
-                             end
-                            else
-                             CGMessage2(type_e_incompatible_types,p.readaccess.def.typename,p.proptype.def.typename);
-                          end;
-                        else
-                          Message(parser_e_ill_property_access_sym);
-                      end;
-                    end;
+           if try_to_consume(_READ) then
+            begin
+              p.readaccess.clear;
+              if parse_symlist(p.readaccess) then
+               begin
+                 sym:=p.readaccess.firstsym^.sym;
+                 case sym.typ of
+                   procsym :
+                     begin
+                       { read is function returning the type of the property }
+                       readprocdef.rettype:=p.proptype;
+                       { Insert hidden parameters }
+                       insert_hidden_para(readprocdef);
+                       insert_funcret_para(readprocdef);
+                       { search procdefs matching readprocdef }
+                       pd:=Tprocsym(sym).search_procdef_bypara(readprocdef.para,p.proptype.def,true,false);
+                       if not(assigned(pd)) then
+                         Message(parser_e_ill_property_access_sym);
+                       p.readaccess.setdef(pd);
+                     end;
+                   varsym :
+                     begin
+                       if compare_defs(p.readaccess.def,p.proptype.def,nothingn)>=te_equal then
+                        begin
+                          { property parameters are allowed if this is
+                            an indexed property, because the index is then
+                            the parameter.
+                            Note: In the help of Kylix it is written
+                            that it isn't allowed, but the compiler accepts it (PFV) }
+                          if (ppo_hasparameters in p.propoptions) then
+                           Message(parser_e_ill_property_access_sym);
+                        end
+                       else
+                        CGMessage2(type_e_incompatible_types,p.readaccess.def.typename,p.proptype.def.typename);
+                     end;
+                   else
+                     Message(parser_e_ill_property_access_sym);
                  end;
-                if try_to_consume(_WRITE) then
-                 begin
-                   p.writeaccess.clear;
-                   if parse_symlist(p.writeaccess) then
-                    begin
-                      sym:=p.writeaccess.firstsym^.sym;
-                      case sym.typ of
-                        procsym :
-                          begin
-                            { insert data entry to check access method }
-                            temppara:=propertyprocdef.concatpara(nil,p.proptype,nil,vs_value,nil);
-                            pd:=Tprocsym(sym).search_procdef_bypara(propertyprocdef.para,true,false);
-                            { ... and remove it }
-                            propertyprocdef.removepara(temppara);
-                            if not(assigned(pd)) then
-                              Message(parser_e_ill_property_access_sym);
-                            p.writeaccess.setdef(pd);
-                          end;
-                        varsym :
-                          begin
-                            if compare_defs(p.writeaccess.def,p.proptype.def,nothingn)>=te_equal then
-                             begin
-                               { property parameters are allowed if this is
-                                 an indexed property, because the index is then
-                                 the parameter.
-                                 Note: In the help of Kylix it is written
-                                 that it isn't allowed, but the compiler accepts it (PFV) }
-                               if (ppo_hasparameters in p.propoptions) then
-                                Message(parser_e_ill_property_access_sym);
-                             end
-                            else
-                             CGMessage2(type_e_incompatible_types,p.readaccess.def.typename,p.proptype.def.typename);
-                          end;
-                        else
-                          Message(parser_e_ill_property_access_sym);
-                      end;
-                    end;
+               end;
+            end;
+           if try_to_consume(_WRITE) then
+            begin
+              p.writeaccess.clear;
+              if parse_symlist(p.writeaccess) then
+               begin
+                 sym:=p.writeaccess.firstsym^.sym;
+                 case sym.typ of
+                   procsym :
+                     begin
+                       { write is a procedure with an extra value parameter
+                         of the of the property }
+                       writeprocdef.rettype:=voidtype;
+                       hvs:=tvarsym.create('$value',p.proptype);
+                       writeprocdef.parast.insert(hvs);
+                       writeprocdef.concatpara(nil,p.proptype,hvs,vs_value,nil);
+                       { Insert hidden parameters }
+                       insert_hidden_para(writeprocdef);
+                       insert_funcret_para(writeprocdef);
+                       { search procdefs matching writeprocdef }
+                       pd:=Tprocsym(sym).search_procdef_bypara(writeprocdef.para,writeprocdef.rettype.def,true,false);
+                       if not(assigned(pd)) then
+                         Message(parser_e_ill_property_access_sym);
+                       p.writeaccess.setdef(pd);
+                     end;
+                   varsym :
+                     begin
+                       if compare_defs(p.writeaccess.def,p.proptype.def,nothingn)>=te_equal then
+                        begin
+                          { property parameters are allowed if this is
+                            an indexed property, because the index is then
+                            the parameter.
+                            Note: In the help of Kylix it is written
+                            that it isn't allowed, but the compiler accepts it (PFV) }
+                          if (ppo_hasparameters in p.propoptions) then
+                           Message(parser_e_ill_property_access_sym);
+                        end
+                       else
+                        CGMessage2(type_e_incompatible_types,p.readaccess.def.typename,p.proptype.def.typename);
+                     end;
+                   else
+                     Message(parser_e_ill_property_access_sym);
                  end;
-                include(p.propoptions,ppo_stored);
-                if try_to_consume(_STORED) then
-                 begin
-                   p.storedaccess.clear;
-                   case token of
-                     _ID:
-                       begin
-                         { in the case that idtoken=_DEFAULT }
-                         { we have to do nothing except      }
-                         { setting ppo_stored, it's the same }
-                         { as stored true                    }
-                         if idtoken<>_DEFAULT then
-                          begin
-                            if parse_symlist(p.storedaccess) then
-                             begin
-                               sym:=p.storedaccess.firstsym^.sym;
-                               case sym.typ of
-                                 procsym :
-                                   begin
-                                      pp:=Tprocsym(sym).search_procdef_nopara_boolret;
-                                      if assigned(pp) then
-                                        p.storedaccess.setdef(pp)
-                                      else
-                                        message(parser_e_ill_property_storage_sym);
-                                   end;
-                                 varsym :
-                                   begin
-                                     if (ppo_hasparameters in p.propoptions) or
-                                        not(is_boolean(p.storedaccess.def)) then
-                                      Message(parser_e_stored_property_must_be_boolean);
-                                   end;
+               end;
+            end;
+           include(p.propoptions,ppo_stored);
+           if try_to_consume(_STORED) then
+            begin
+              p.storedaccess.clear;
+              case token of
+                _ID:
+                  begin
+                    { in the case that idtoken=_DEFAULT }
+                    { we have to do nothing except      }
+                    { setting ppo_stored, it's the same }
+                    { as stored true                    }
+                    if idtoken<>_DEFAULT then
+                     begin
+                       if parse_symlist(p.storedaccess) then
+                        begin
+                          sym:=p.storedaccess.firstsym^.sym;
+                          case sym.typ of
+                            procsym :
+                              begin
+                                 pp:=Tprocsym(sym).search_procdef_nopara_boolret;
+                                 if assigned(pp) then
+                                   p.storedaccess.setdef(pp)
                                  else
-                                   Message(parser_e_ill_property_access_sym);
-                               end;
-                             end;
+                                   message(parser_e_ill_property_storage_sym);
+                              end;
+                            varsym :
+                              begin
+                                if (ppo_hasparameters in p.propoptions) or
+                                   not(is_boolean(p.storedaccess.def)) then
+                                 Message(parser_e_stored_property_must_be_boolean);
+                              end;
+                            else
+                              Message(parser_e_ill_property_access_sym);
                           end;
-                       end;
-                     _FALSE:
-                       begin
-                         consume(_FALSE);
-                         exclude(p.propoptions,ppo_stored);
-                       end;
-                     _TRUE:
-                       consume(_TRUE);
-                   end;
-                 end;
-                if try_to_consume(_DEFAULT) then
-                  begin
-                     if not(is_ordinal(p.proptype.def) or
-                            is_64bitint(p.proptype.def) or
-                            ((p.proptype.def.deftype=setdef) and
-                             (tsetdef(p.proptype.def).settype=smallset))) or
-                            ((p.proptype.def.deftype=arraydef) and
-                             (ppo_indexed in p.propoptions)) or
-                        (ppo_hasparameters in p.propoptions) then
-                       Message(parser_e_property_cant_have_a_default_value);
-                     { Get the result of the default, the firstpass is
-                       needed to support values like -1 }
-                     pt:=comp_expr(true);
-                     if (p.proptype.def.deftype=setdef) and
-                        (pt.nodetype=arrayconstructorn) then
-                       begin
-                         arrayconstructor_to_set(pt);
-                         do_resulttypepass(pt);
-                       end;
-                     inserttypeconv(pt,p.proptype);
-                     if not(is_constnode(pt)) then
-                       Message(parser_e_property_default_value_must_const);
-
-                     if pt.nodetype=setconstn then
-                       p.default:=plongint(tsetconstnode(pt).value_set)^
-                     else
-                       p.default:=tordconstnode(pt).value;
-                     pt.free;
-                  end
-                else if try_to_consume(_NODEFAULT) then
+                        end;
+                     end;
+                  end;
+                _FALSE:
                   begin
-                     p.default:=0;
+                    consume(_FALSE);
+                    exclude(p.propoptions,ppo_stored);
                   end;
-                symtablestack.insert(p);
-                { default property ? }
-                consume(_SEMICOLON);
-                if try_to_consume(_DEFAULT) then
+                _TRUE:
+                  consume(_TRUE);
+              end;
+            end;
+           if try_to_consume(_DEFAULT) then
+             begin
+                if not(is_ordinal(p.proptype.def) or
+                       is_64bitint(p.proptype.def) or
+                       ((p.proptype.def.deftype=setdef) and
+                        (tsetdef(p.proptype.def).settype=smallset))) or
+                       ((p.proptype.def.deftype=arraydef) and
+                        (ppo_indexed in p.propoptions)) or
+                   (ppo_hasparameters in p.propoptions) then
+                  Message(parser_e_property_cant_have_a_default_value);
+                { Get the result of the default, the firstpass is
+                  needed to support values like -1 }
+                pt:=comp_expr(true);
+                if (p.proptype.def.deftype=setdef) and
+                   (pt.nodetype=arrayconstructorn) then
                   begin
-                     { overriding a default propertyp is allowed
-                     p2:=search_default_property(aktclass);
-                     if assigned(p2) then
-                       message1(parser_e_only_one_default_property,
-                         tobjectdef(p2.owner.defowner)^.objrealname^)
-                     else
-                     }
-                       begin
-                          include(p.propoptions,ppo_defaultproperty);
-                          if propertyprocdef.maxparacount=0 then
-                            message(parser_e_property_need_paras);
-                       end;
-                     consume(_SEMICOLON);
+                    arrayconstructor_to_set(pt);
+                    do_resulttypepass(pt);
                   end;
+                inserttypeconv(pt,p.proptype);
+                if not(is_constnode(pt)) then
+                  Message(parser_e_property_default_value_must_const);
+
+                if pt.nodetype=setconstn then
+                  p.default:=plongint(tsetconstnode(pt).value_set)^
+                else
+                  p.default:=tordconstnode(pt).value;
+                pt.free;
              end
-           else
+           else if try_to_consume(_NODEFAULT) then
              begin
-                consume(_ID);
-                consume(_SEMICOLON);
+                p.default:=0;
+             end;
+           consume(_SEMICOLON);
+           { default property ? }
+           if try_to_consume(_DEFAULT) then
+             begin
+               include(p.propoptions,ppo_defaultproperty);
+               if readprocdef.maxparacount=0 then
+                 message(parser_e_property_need_paras);
+               consume(_SEMICOLON);
              end;
-           propertyprocdef.free;
+           { remove temporary procvardefs }
+           symtablestack:=symtablestack.next;
+           readprocdef.free;
+           writeprocdef.free;
         end;
 
 
@@ -1139,7 +1154,16 @@ implementation
 end.
 {
   $Log$
-  Revision 1.59  2003-04-10 17:57:52  peter
+  Revision 1.60  2003-04-25 20:59:33  peter
+    * removed funcretn,funcretsym, function result is now in varsym
+      and aliases for result and function name are added using absolutesym
+    * vs_hidden parameter for funcret passed in parameter
+    * vs_hidden fixes
+    * writenode changed to printnode and released from extdebug
+    * -vp option added to generate a tree.log with the nodetree
+    * nicer printnode for statements, callnode
+
+  Revision 1.59  2003/04/10 17:57:52  peter
     * vs_hidden released
 
   Revision 1.58  2003/01/09 21:52:37  peter

compiler/pdecsub.pas

@@ -41,6 +41,9 @@ interface
 
     function  is_proc_directive(tok:ttoken):boolean;
 
+    procedure insert_funcret_para(pd:tabstractprocdef);
+    procedure insert_funcret_local(pd:tprocdef);
+
     procedure insert_hidden_para(pd:tabstractprocdef);
     procedure check_self_para(aktprocdef:tabstractprocdef);
     procedure parameter_dec(aktprocdef:tabstractprocdef);
@@ -88,6 +91,85 @@ implementation
        ;
 
 
+    procedure insert_funcret_para(pd:tabstractprocdef);
+      var
+        storepos : tfileposinfo;
+        vs       : tvarsym;
+      begin
+        if not is_void(pd.rettype.def) and
+           not paramanager.ret_in_reg(pd.rettype.def,pd.proccalloption) then
+         begin
+           storepos:=akttokenpos;
+           if pd.deftype=procdef then
+            akttokenpos:=tprocdef(pd).fileinfo;
+
+           { Generate result variable accessing function result }
+           vs:=tvarsym.create('$result',pd.rettype);
+           include(vs.varoptions,vo_is_funcret);
+           { Store the this symbol as fucnretsym for procedures }
+           if pd.deftype=procdef then
+            tprocdef(pd).funcretsym:=vs;
+
+           { Handle like a var parameter }
+           vs.varspez:=vs_var;
+           pd.parast.insert(vs);
+           { Also insert a hidden parameter as first }
+           pd.insertpara(vs.vartype,vs,vs_hidden,nil);
+
+           akttokenpos:=storepos;
+         end;
+      end;
+
+
+    procedure insert_funcret_local(pd:tprocdef);
+      var
+        storepos : tfileposinfo;
+        vs       : tvarsym;
+      begin
+        if not is_void(pd.rettype.def) then
+         begin
+           { if the current is a function aktprocsym is non nil }
+           { and there is a local symtable set }
+           storepos:=akttokenpos;
+           akttokenpos:=pd.fileinfo;
+
+           { We always need a localsymtable }
+           if not assigned(pd.localst) then
+            pd.insert_localst;
+
+           { We need to insert a varsym for the result in the localst
+             when it is returning in a register }
+           if paramanager.ret_in_reg(pd.rettype.def,pd.proccalloption) then
+            begin
+              vs:=tvarsym.create('$result',pd.rettype);
+              include(vs.varoptions,vo_is_funcret);
+              pd.localst.insert(vs);
+              pd.localst.insertvardata(vs);
+              pd.funcretsym:=vs;
+            end;
+
+           { insert the name of the procedure as alias for the function result,
+             we can't use realname because that will not work for compilerprocs
+             as the name is lowercase and unreachable from the code }
+           if pd.resultname='' then
+            pd.resultname:=aktprocdef.procsym.name;
+           vs:=tabsolutesym.create_ref(pd.resultname,pd.rettype,tstoredsym(pd.funcretsym));
+           include(vs.varoptions,vo_is_funcret);
+           pd.localst.insert(vs);
+
+           { insert result also if support is on }
+           if (m_result in aktmodeswitches) then
+            begin
+              vs:=tabsolutesym.create_ref('RESULT',pd.rettype,tstoredsym(pd.funcretsym));
+              include(vs.varoptions,vo_is_funcret);
+              pd.localst.insert(vs);
+            end;
+
+           akttokenpos:=storepos;
+         end;
+      end;
+
+
     procedure insert_hidden_para(pd:tabstractprocdef);
       var
         currpara : tparaitem;
@@ -219,7 +301,6 @@ implementation
         tdefaultvalue : tconstsym;
         defaultrequired : boolean;
         old_object_option : tsymoptions;
-        dummyst : tparasymtable;
         currparast : tparasymtable;
       begin
         consume(_LKLAMMER);
@@ -230,16 +311,7 @@ implementation
           exit;
         { parsing a proc or procvar ? }
         is_procvar:=(aktprocdef.deftype=procvardef);
-        { create dummy symtable for procvars }
-        if is_procvar then
-         begin
-           dummyst:=tparasymtable.create;
-           currparast:=dummyst;
-         end
-        else
-         begin
-           currparast:=tparasymtable(tprocdef(aktprocdef).parast);
-         end;
+        currparast:=tparasymtable(aktprocdef.parast);
         { reset }
         sc:=tsinglelist.create;
         defaultrequired:=false;
@@ -368,10 +440,8 @@ implementation
                 if (varspez in [vs_var,vs_const,vs_out]) and
                    paramanager.push_addr_param(tt.def,aktprocdef.proccalloption) then
                   include(vs.varoptions,vo_regable);
-                hpara:=aktprocdef.concatpara(nil,tt,vs,varspez,tdefaultvalue);
-              end
-             else
-              hpara:=aktprocdef.concatpara(nil,tt,nil,varspez,tdefaultvalue);
+              end;
+             hpara:=aktprocdef.concatpara(nil,tt,vs,varspez,tdefaultvalue);
              { save position of self parameter }
              if vs.name='SELF' then
               aktprocdef.selfpara:=hpara;
@@ -379,8 +449,6 @@ implementation
            end;
         until not try_to_consume(_SEMICOLON);
         { remove parasymtable from stack }
-        if is_procvar then
-          dummyst.free;
         sc.free;
         { check for a self parameter, only for normal procedures. For
           procvars we need to wait until the 'of object' is parsed }
@@ -701,7 +769,7 @@ implementation
 
     procedure parse_proc_dec;
       var
-        hs : string;
+        hs            : string;
         isclassmethod : boolean;
       begin
         inc(lexlevel);
@@ -717,111 +785,121 @@ implementation
         else
          isclassmethod:=false;
         case token of
-           _FUNCTION : begin
-                         consume(_FUNCTION);
-                         parse_proc_head(potype_none);
-                         if token<>_COLON then
-                          begin
-                             if assigned(aktprocsym) and
-                                not(is_interface(aktprocdef._class)) and
-                                not(aktprocdef.forwarddef) or
-                               (m_repeat_forward in aktmodeswitches) then
-                             begin
-                               consume(_COLON);
-                               consume_all_until(_SEMICOLON);
-                             end;
-                          end
-                         else
-                          begin
-                            consume(_COLON);
-                            inc(testcurobject);
-                            single_type(aktprocdef.rettype,hs,false);
-                            aktprocdef.test_if_fpu_result;
-                            if (aktprocdef.rettype.def.deftype=stringdef) and
-                               (tstringdef(aktprocdef.rettype.def).string_typ<>st_shortstring) then
-                              procinfo.no_fast_exit:=true;
-                            dec(testcurobject);
-                          end;
-                       end;
-          _PROCEDURE : begin
-                         consume(_PROCEDURE);
-                         parse_proc_head(potype_none);
-                         if assigned(aktprocsym) then
-                           aktprocdef.rettype:=voidtype;
-                       end;
-        _CONSTRUCTOR : begin
-                         consume(_CONSTRUCTOR);
-                         parse_proc_head(potype_constructor);
-                         if assigned(procinfo._class) and
-                            is_class(procinfo._class) then
-                          begin
-                            { CLASS constructors return the created instance }
-                            aktprocdef.rettype.setdef(procinfo._class);
-                          end
-                         else
-                          begin
-                            { OBJECT constructors return a boolean }
-                            aktprocdef.rettype:=booltype;
-                          end;
-                       end;
-         _DESTRUCTOR : begin
-                         consume(_DESTRUCTOR);
-                         parse_proc_head(potype_destructor);
-                         aktprocdef.rettype:=voidtype;
-                       end;
-           _OPERATOR : begin
-                         if lexlevel>normal_function_level then
-                           Message(parser_e_no_local_operator);
-                         consume(_OPERATOR);
-                         if (token in [first_overloaded..last_overloaded]) then
-                          begin
-                            procinfo.flags:=procinfo.flags or pi_operator;
-                            optoken:=token;
-                          end
-                         else
-                          begin
-                            Message(parser_e_overload_operator_failed);
-                            { Use the dummy NOTOKEN that is also declared
-                              for the overloaded_operator[] }
-                            optoken:=NOTOKEN;
-                          end;
-                         consume(Token);
-                         parse_proc_head(potype_operator);
-                         if token<>_ID then
-                           begin
-                              otsym:=nil;
-                              if not(m_result in aktmodeswitches) then
-                                consume(_ID);
-                           end
-                         else
-                           begin
-                             otsym:=tvarsym.create(pattern,voidtype);
-                             consume(_ID);
-                           end;
-                         if not try_to_consume(_COLON) then
-                           begin
-                             consume(_COLON);
-                             aktprocdef.rettype:=generrortype;
-                             consume_all_until(_SEMICOLON);
-                           end
-                         else
-                          begin
-                            single_type(aktprocdef.rettype,hs,false);
-                            aktprocdef.test_if_fpu_result;
-                            if (optoken in [_EQUAL,_GT,_LT,_GTE,_LTE]) and
-                               ((aktprocdef.rettype.def.deftype<>orddef) or
-                                (torddef(aktprocdef.rettype.def).typ<>bool8bit)) then
-                               Message(parser_e_comparative_operator_return_boolean);
-                            if assigned(otsym) then
-                              otsym.vartype.def:=aktprocdef.rettype.def;
-                            if (optoken=_ASSIGNMENT) and
-                               equal_defs(aktprocdef.rettype.def,
-                                  tvarsym(aktprocdef.parast.symindex.first).vartype.def) then
-                              message(parser_e_no_such_assignment)
-                            else if not isoperatoracceptable(aktprocdef,optoken) then
-                              Message(parser_e_overload_impossible);
-                          end;
-                       end;
+          _FUNCTION :
+            begin
+              consume(_FUNCTION);
+              parse_proc_head(potype_none);
+              if token<>_COLON then
+               begin
+                  if (
+                      assigned(aktprocsym) and
+                      not(is_interface(aktprocdef._class)) and
+                      not(aktprocdef.forwarddef)
+                     ) or
+                     (m_repeat_forward in aktmodeswitches) then
+                  begin
+                    consume(_COLON);
+                    consume_all_until(_SEMICOLON);
+                  end;
+               end
+              else
+               begin
+                 consume(_COLON);
+                 inc(testcurobject);
+                 single_type(aktprocdef.rettype,hs,false);
+                 aktprocdef.test_if_fpu_result;
+                 if (aktprocdef.rettype.def.deftype=stringdef) and
+                    (tstringdef(aktprocdef.rettype.def).string_typ<>st_shortstring) then
+                   procinfo.no_fast_exit:=true;
+                 dec(testcurobject);
+               end;
+
+              { Insert function result parameter }
+              insert_funcret_para(aktprocdef);
+            end;
+          _PROCEDURE :
+            begin
+              consume(_PROCEDURE);
+              parse_proc_head(potype_none);
+              if assigned(aktprocsym) then
+                aktprocdef.rettype:=voidtype;
+            end;
+          _CONSTRUCTOR :
+            begin
+              consume(_CONSTRUCTOR);
+              parse_proc_head(potype_constructor);
+              if assigned(procinfo._class) and
+                 is_class(procinfo._class) then
+               begin
+                 { CLASS constructors return the created instance }
+                 aktprocdef.rettype.setdef(procinfo._class);
+               end
+              else
+               begin
+                 { OBJECT constructors return a boolean }
+                 aktprocdef.rettype:=booltype;
+               end;
+            end;
+          _DESTRUCTOR :
+            begin
+              consume(_DESTRUCTOR);
+              parse_proc_head(potype_destructor);
+              aktprocdef.rettype:=voidtype;
+            end;
+          _OPERATOR :
+            begin
+              if lexlevel>normal_function_level then
+                Message(parser_e_no_local_operator);
+              consume(_OPERATOR);
+              if (token in [first_overloaded..last_overloaded]) then
+               begin
+                 procinfo.flags:=procinfo.flags or pi_operator;
+                 optoken:=token;
+               end
+              else
+               begin
+                 Message(parser_e_overload_operator_failed);
+                 { Use the dummy NOTOKEN that is also declared
+                   for the overloaded_operator[] }
+                 optoken:=NOTOKEN;
+               end;
+              consume(token);
+              parse_proc_head(potype_operator);
+              if token<>_ID then
+                begin
+                   if not(m_result in aktmodeswitches) then
+                     consume(_ID);
+                end
+              else
+                begin
+                  aktprocdef.resultname:=orgpattern;
+                  consume(_ID);
+                end;
+              if not try_to_consume(_COLON) then
+                begin
+                  consume(_COLON);
+                  aktprocdef.rettype:=generrortype;
+                  consume_all_until(_SEMICOLON);
+                end
+              else
+               begin
+                 single_type(aktprocdef.rettype,hs,false);
+                 aktprocdef.test_if_fpu_result;
+                 if (optoken in [_EQUAL,_GT,_LT,_GTE,_LTE]) and
+                    ((aktprocdef.rettype.def.deftype<>orddef) or
+                     (torddef(aktprocdef.rettype.def).typ<>bool8bit)) then
+                    Message(parser_e_comparative_operator_return_boolean);
+                 if (optoken=_ASSIGNMENT) and
+                    equal_defs(aktprocdef.rettype.def,
+                       tvarsym(aktprocdef.parast.symindex.first).vartype.def) then
+                   message(parser_e_no_such_assignment)
+                 else if not isoperatoracceptable(aktprocdef,optoken) then
+                   Message(parser_e_overload_impossible);
+               end;
+
+              { Insert function result parameter }
+              insert_funcret_para(aktprocdef);
+            end;
         end;
         if isclassmethod and
            assigned(aktprocsym) then
@@ -1703,7 +1781,6 @@ const
         if (def.deftype=procdef) then
           tprocdef(def).parast.foreach_static({$ifdef FPCPROCVAR}@{$endif}checkvaluepara,nil);
 
-
         { add mangledname to external list }
         if (def.deftype=procdef) and
            (po_external in def.procoptions) and
@@ -1786,9 +1863,6 @@ const
             break;
          end;
         handle_calling_convention(aktprocsym,aktprocdef);
-        { calculate addresses in parasymtable }
-        if aktprocdef.deftype=procdef then
-          calc_parasymtable_addresses(aktprocdef);
       end;
 
 
@@ -1904,7 +1978,7 @@ const
                        (not equal_defs(hd.rettype.def,aprocdef.rettype.def))) then
                      begin
                        MessagePos1(aprocdef.fileinfo,parser_e_header_dont_match_forward,
-                                   aprocdef.fullprocname);
+                                   aprocdef.fullprocname(false));
                        aprocsym.write_parameter_lists(aprocdef);
                        break;
                      end;
@@ -1913,7 +1987,7 @@ const
                    if hd.forwarddef and aprocdef.forwarddef then
                     begin
                       MessagePos1(aprocdef.fileinfo,parser_e_function_already_declared_public_forward,
-                                  aprocdef.fullprocname);
+                                  aprocdef.fullprocname(false));
                     end;
 
                    { internconst or internproc only need to be defined once }
@@ -1968,14 +2042,14 @@ const
                    if ((po_comp * hd.procoptions)<>(po_comp * aprocdef.procoptions)) then
                      begin
                        MessagePos1(aprocdef.fileinfo,parser_e_header_dont_match_forward,
-                                   aprocdef.fullprocname);
+                                   aprocdef.fullprocname(false));
                        aprocsym.write_parameter_lists(aprocdef);
                        { This error is non-fatal, we can recover }
                      end;
 
                    { Check manglednames }
                    if (m_repeat_forward in aktmodeswitches) or
-                      aprocdef.haspara then
+                      (aprocdef.minparacount>0) then
                     begin
                       { If mangled names are equal then they have the same amount of arguments }
                       { We can check the names of the arguments }
@@ -2036,7 +2110,9 @@ const
                       { encountered, it must already use the new mangled name (JM)  }
                     end;
 
-                   { return the forwarddef }
+                   { the procdef will be released by the symtable, we release
+                     at least the parast }
+                   aprocdef.releasemem;
                    aprocdef:=hd;
                  end
                else
@@ -2094,34 +2170,6 @@ const
            inc(aprocsym.overloadcount);
          end;
 
-        { insert otsym only in the right symtable }
-        if ((procinfo.flags and pi_operator)<>0) and
-           assigned(otsym) then
-         begin
-           if not parse_only then
-            begin
-              if paramanager.ret_in_param(aprocdef.rettype.def,aprocdef.proccalloption) then
-               begin
-                 aprocdef.parast.insert(otsym);
-                 { this allows to read the funcretoffset }
-                 otsym.address:=-4;
-                 otsym.varspez:=vs_var;
-               end
-              else
-               begin
-                 if not assigned(aprocdef.localst) then
-                  aprocdef.insert_localst;
-                 aprocdef.localst.insert(otsym);
-                 aprocdef.localst.insertvardata(otsym);
-               end;
-            end
-           else
-            begin
-              { this is not required anymore }
-              otsym.free;
-              otsym:=nil;
-            end;
-         end;
         paramanager.create_param_loc_info(aprocdef);
         proc_add_definition:=forwardfound;
       end;
@@ -2129,7 +2177,16 @@ const
 end.
 {
   $Log$
-  Revision 1.115  2003-04-24 13:03:01  florian
+  Revision 1.116  2003-04-25 20:59:33  peter
+    * removed funcretn,funcretsym, function result is now in varsym
+      and aliases for result and function name are added using absolutesym
+    * vs_hidden parameter for funcret passed in parameter
+    * vs_hidden fixes
+    * writenode changed to printnode and released from extdebug
+    * -vp option added to generate a tree.log with the nodetree
+    * nicer printnode for statements, callnode
+
+  Revision 1.115  2003/04/24 13:03:01  florian
     * comp is now written with its bit pattern to the ppu instead as an extended
 
   Revision 1.114  2003/04/23 13:12:26  peter

compiler/pdecvar.pas

@@ -236,7 +236,7 @@ implementation
                 else if (pt.nodetype=loadn) then
                  begin
                    { we should check the result type of srsym }
-                   if not (tloadnode(pt).symtableentry.typ in [varsym,typedconstsym,funcretsym]) then
+                   if not (tloadnode(pt).symtableentry.typ in [varsym,typedconstsym]) then
                      Message(parser_e_absolute_only_to_var_or_const);
                    abssym:=tabsolutesym.create(vs.realname,tt);
                    abssym.fileinfo:=vs.fileinfo;
@@ -255,16 +255,6 @@ implementation
                           tvarsym(tloadnode(pt).symtableentry).varoptions-[vo_regable,vo_fpuregable]
                      end;
                  end
-                { funcret }
-                else if (pt.nodetype=funcretn) then
-                 begin
-                   abssym:=tabsolutesym.create(vs.realname,tt);
-                   abssym.fileinfo:=vs.fileinfo;
-                   abssym.abstyp:=tovar;
-                   abssym.ref:=tstoredsym(tfuncretnode(pt).funcretsym);
-                   symtablestack.replace(vs,abssym);
-                   vs.free;
-                 end
                 { address }
                 else if is_constintnode(pt) and
                         ((target_info.system=system_i386_go32v2) or
@@ -612,7 +602,16 @@ implementation
 end.
 {
   $Log$
-  Revision 1.45  2003-03-17 18:56:02  peter
+  Revision 1.46  2003-04-25 20:59:33  peter
+    * removed funcretn,funcretsym, function result is now in varsym
+      and aliases for result and function name are added using absolutesym
+    * vs_hidden parameter for funcret passed in parameter
+    * vs_hidden fixes
+    * writenode changed to printnode and released from extdebug
+    * -vp option added to generate a tree.log with the nodetree
+    * nicer printnode for statements, callnode
+
+  Revision 1.45  2003/03/17 18:56:02  peter
     * fix crash with duplicate id
 
   Revision 1.44  2003/01/02 11:14:02  michael

compiler/pexpr.pas

@@ -1013,63 +1013,6 @@ implementation
 
     function factor(getaddr : boolean) : tnode;
 
-         {---------------------------------------------
-                         Is_func_ret
-         ---------------------------------------------}
-
-        function is_func_ret(var p1:tnode;var sym : tsym;var srsymtable:tsymtable) : boolean;
-        var
-           p : tprocinfo;
-           storesymtablestack : tsymtable;
-        begin
-          is_func_ret:=false;
-          if not assigned(procinfo) or
-             ((sym.typ<>funcretsym) and ((procinfo.flags and pi_operator)=0)) then
-            exit;
-          p:=procinfo;
-          while assigned(p) do
-            begin
-               { is this an access to a function result? Accessing _RESULT is
-                 always allowed and funcretn is generated }
-               if assigned(p.procdef.funcretsym) and
-                  ((sym=tsym(p.procdef.resultfuncretsym)) or
-                   ((sym=tsym(p.procdef.funcretsym)) or
-                    ((sym=tsym(otsym)) and ((p.flags and pi_operator)<>0))) and
-                   (not is_void(p.procdef.rettype.def)) and
-                   (token<>_LKLAMMER) and
-                   (not (not(m_fpc in aktmodeswitches) and (afterassignment or in_args)))
-                  ) then
-                 begin
-                    if ((sym=tsym(otsym)) and
-                       ((p.flags and pi_operator)<>0)) then
-                      inc(otsym.refs);
-                    p1:=cfuncretnode.create(p.procdef.funcretsym);
-                    is_func_ret:=true;
-                    if tfuncretsym(p.procdef.funcretsym).funcretstate=vs_declared then
-                      begin
-                        tfuncretsym(p.procdef.funcretsym).funcretstate:=vs_declared_and_first_found;
-                        include(p1.flags,nf_first_use);
-                      end;
-                    exit;
-                 end;
-               p:=p.parent;
-            end;
-          { we must use the function call, update the
-            sym to be the procsym }
-          if (sym.typ=funcretsym) then
-            begin
-               storesymtablestack:=symtablestack;
-               symtablestack:=sym.owner.next;
-               searchsym(sym.name,sym,srsymtable);
-               check_hints(sym);
-               if not assigned(sym) then
-                sym:=generrorsym;
-               if (sym.typ<>procsym) then
-                Message(cg_e_illegal_expression);
-               symtablestack:=storesymtablestack;
-            end;
-        end;
-
          {---------------------------------------------
                          Factor_read_id
          ---------------------------------------------}
@@ -1081,13 +1024,33 @@ implementation
            srsym : tsym;
            possible_error : boolean;
            srsymtable : tsymtable;
+           storesymtablestack : tsymtable;
            htype : ttype;
            static_name : string;
          begin
            { allow post fix operators }
            again:=true;
            consume_sym(srsym,srsymtable);
-           if not is_func_ret(p1,srsym,srsymtable) then
+
+           { Access to funcret or need to call the function? }
+           if (srsym.typ in [absolutesym,varsym]) and
+              (vo_is_funcret in tvarsym(srsym).varoptions) and
+              (
+               (token=_LKLAMMER) or
+               (not(m_fpc in aktmodeswitches) and
+                (afterassignment or in_args))
+              ) then
+            begin
+              storesymtablestack:=symtablestack;
+              symtablestack:=srsym.owner.next;
+              searchsym(srsym.name,srsym,srsymtable);
+              if not assigned(srsym) then
+               srsym:=generrorsym;
+              if (srsym.typ<>procsym) then
+               Message(cg_e_illegal_expression);
+              symtablestack:=storesymtablestack;
+            end;
+
             begin
               { check semantics of private }
               if (srsym.typ in [propertysym,procsym,varsym]) and
@@ -2347,7 +2310,16 @@ implementation
 end.
 {
   $Log$
-  Revision 1.109  2003-04-23 10:13:55  peter
+  Revision 1.110  2003-04-25 20:59:33  peter
+    * removed funcretn,funcretsym, function result is now in varsym
+      and aliases for result and function name are added using absolutesym
+    * vs_hidden parameter for funcret passed in parameter
+    * vs_hidden fixes
+    * writenode changed to printnode and released from extdebug
+    * -vp option added to generate a tree.log with the nodetree
+    * nicer printnode for statements, callnode
+
+  Revision 1.109  2003/04/23 10:13:55  peter
     * firstaddr will check procvardef
 
   Revision 1.108  2003/04/22 23:50:23  peter

compiler/ppu.pas

@@ -41,7 +41,7 @@ type
 {$endif Test_Double_checksum}
 
 const
-  CurrentPPUVersion=34;
+  CurrentPPUVersion=35;
 
 { buffer sizes }
   maxentrysize = 1024;
@@ -89,9 +89,8 @@ const
   ibvarsym_C      = 28;
   ibunitsym       = 29;  { needed for browser }
   iblabelsym      = 30;
-  ibfuncretsym    = 31;
-  ibsyssym        = 32;
-  ibrttisym       = 33;
+  ibsyssym        = 31;
+  ibrttisym       = 32;
   {definitions}
   iborddef         = 40;
   ibpointerdef     = 41;
@@ -985,7 +984,16 @@ end;
 end.
 {
   $Log$
-  Revision 1.33  2003-04-24 13:03:01  florian
+  Revision 1.34  2003-04-25 20:59:34  peter
+    * removed funcretn,funcretsym, function result is now in varsym
+      and aliases for result and function name are added using absolutesym
+    * vs_hidden parameter for funcret passed in parameter
+    * vs_hidden fixes
+    * writenode changed to printnode and released from extdebug
+    * -vp option added to generate a tree.log with the nodetree
+    * nicer printnode for statements, callnode
+
+  Revision 1.33  2003/04/24 13:03:01  florian
     * comp is now written with its bit pattern to the ppu instead as an extended
 
   Revision 1.32  2003/04/23 14:42:07  daniel

compiler/pstatmnt.pas

@@ -118,7 +118,7 @@ implementation
               consume_emptystats;
            end;
          consume(_END);
-         statements_til_end:=cblocknode.create(first);
+         statements_til_end:=cblocknode.create(first,true);
       end;
 
 
@@ -332,7 +332,7 @@ implementation
          consume(_UNTIL);
          dec(statement_level);
 
-         first:=cblocknode.create(first);
+         first:=cblocknode.create(first,true);
          p_e:=comp_expr(true);
          repeat_statement:=genloopnode(whilerepeatn,p_e,first,nil,true);
       end;
@@ -555,7 +555,7 @@ implementation
                 break;
               consume_emptystats;
            end;
-         p_try_block:=cblocknode.create(first);
+         p_try_block:=cblocknode.create(first,true);
 
          if try_to_consume(_FINALLY) then
            begin
@@ -990,7 +990,7 @@ implementation
 
          dec(statement_level);
 
-         last:=cblocknode.create(first);
+         last:=cblocknode.create(first,true);
          last.set_tree_filepos(filepos);
          statement_block:=last;
       end;
@@ -1099,7 +1099,7 @@ implementation
             (aktprocdef.localst.datasize=aktprocdef.rettype.def.size) and
             (aktprocdef.owner.symtabletype<>objectsymtable) and
             (not assigned(aktprocdef.funcretsym) or
-             (tfuncretsym(aktprocdef.funcretsym).refcount<=1)) and
+             (tvarsym(aktprocdef.funcretsym).refcount<=1)) and
             not(paramanager.ret_in_param(aktprocdef.rettype.def,aktprocdef.proccalloption)) and
             (target_cpu in [cpu_i386,cpu_m68k,cpu_vm])
 {$ifdef CHECKFORPUSH}
@@ -1113,7 +1113,7 @@ implementation
         }
         if assigned(aktprocdef.funcretsym) and
            paramanager.ret_in_reg(aktprocdef.rettype.def,aktprocdef.proccalloption) then
-          tfuncretsym(aktprocdef.funcretsym).funcretstate:=vs_assigned;
+          tvarsym(aktprocdef.funcretsym).varstate:=vs_assigned;
 
         { because the END is already read we need to get the
           last_endtoken_filepos here (PFV) }
@@ -1125,7 +1125,20 @@ implementation
 end.
 {
   $Log$
-  Revision 1.89  2003-04-25 08:25:26  daniel
+  Revision 1.91  2003-04-25 20:59:34  peter
+    * removed funcretn,funcretsym, function result is now in varsym
+      and aliases for result and function name are added using absolutesym
+    * vs_hidden parameter for funcret passed in parameter
+    * vs_hidden fixes
+    * writenode changed to printnode and released from extdebug
+    * -vp option added to generate a tree.log with the nodetree
+    * nicer printnode for statements, callnode
+
+  Revision 1.90  2002/04/25 20:15:40  florian
+    * block nodes within expressions shouldn't release the used registers,
+      fixed using a flag till the new rg is ready
+
+  Revision 1.89  2003/04/25 08:25:26  daniel
     * Ifdefs around a lot of calls to cleartempgen
     * Fixed registers that are allocated but not freed in several nodes
     * Tweak to register allocator to cause less spills

compiler/psub.pas

@@ -26,6 +26,8 @@ unit psub;
 
 interface
 
+    procedure printnode_reset;
+
     procedure compile_proc_body(make_global,parent_has_class:boolean);
 
     { reads the declaration blocks }
@@ -102,39 +104,7 @@ implementation
 
 
     function block(islibrary : boolean) : tnode;
-      var
-         storepos : tfileposinfo;
       begin
-         if not is_void(aktprocdef.rettype.def) then
-           begin
-              { if the current is a function aktprocsym is non nil }
-              { and there is a local symtable set }
-              storepos:=akttokenpos;
-              akttokenpos:=aktprocsym.fileinfo;
-              aktprocdef.funcretsym:=tfuncretsym.create(aktprocsym.name,aktprocdef.rettype);
-              { insert in local symtable }
-{$ifdef powerpc}
-              { this requires us to setup a stack frame, which gives problem in the linux syscall helpers (JM) }
-              if not(po_assembler in aktprocdef.procoptions) then
-{$endif powerpc}
-//                 not(paramanager.ret_in_reg(aktprocdef.rettype.def,aktprocdef.proccalloption)) then
-                begin
-                  symtablestack.insert(aktprocdef.funcretsym);
-                  symtablestack.insertvardata(aktprocdef.funcretsym);
-                end;
-              akttokenpos:=storepos;
-
-(*            already done by
-              symtablestack.insertvardata(aktprocdef.funcretsym); above (JM)
-              procinfo.set_result_offset;
-*)
-              { insert result also if support is on }
-              if (m_result in aktmodeswitches) then
-               begin
-                 aktprocdef.resultfuncretsym:=tfuncretsym.create('RESULT',aktprocdef.rettype);
-                 symtablestack.insert(aktprocdef.resultfuncretsym);
-               end;
-           end;
          { parse const,types and vars }
          read_declarations(islibrary);
 
@@ -211,6 +181,43 @@ implementation
                        PROCEDURE/FUNCTION COMPILING
 ****************************************************************************}
 
+    procedure printnode_reset;
+      begin
+        assign(printnodefile,treelogfilename);
+        {$I-}
+         rewrite(printnodefile);
+        {$I+}
+        if ioresult<>0 then
+         begin
+           Comment(V_Error,'Error creating '+treelogfilename);
+           exit;
+         end;
+        close(printnodefile);
+      end;
+
+
+    procedure printnode_procdef(pd:tprocdef);
+      begin
+        assign(printnodefile,treelogfilename);
+        {$I-}
+         append(printnodefile);
+         if ioresult<>0 then
+          rewrite(printnodefile);
+        {$I+}
+        if ioresult<>0 then
+         begin
+           Comment(V_Error,'Error creating '+treelogfilename);
+           exit;
+         end;
+        writeln(printnodefile);
+        writeln(printnodefile,'*******************************************************************************');
+        writeln(printnodefile,aktprocdef.fullprocname(false));
+        writeln(printnodefile,'*******************************************************************************');
+        printnode(printnodefile,pd.code);
+        close(printnodefile);
+      end;
+
+
     procedure compile_proc_body(make_global,parent_has_class:boolean);
       {
         Compile the body of a procedure
@@ -345,8 +352,11 @@ implementation
             { the procedure is now defined }
             aktprocdef.forwarddef:=false;
 
-             { only generate the code if no type errors are found, else
-               finish at least the type checking pass }
+            if paraprintnodetree=1 then
+              printnode_procdef(aktprocdef);
+
+            { only generate the code if no type errors are found, else
+              finish at least the type checking pass }
 {$ifndef NOPASS2}
             if (status.errorcount=0) then
               begin
@@ -562,6 +572,8 @@ implementation
         oldprocinfo      : tprocinfo;
         oldconstsymtable : tsymtable;
         oldfilepos       : tfileposinfo;
+        oldselftokenmode,
+        oldfailtokenmode : tmodeswitch;
         pdflags          : word;
       begin
       { save old state }
@@ -651,7 +663,7 @@ implementation
              if assigned(procinfo._class) and
                 (not assigned(oldprocinfo._class)) then
               begin
-                Message1(parser_e_header_dont_match_any_member,aktprocdef.fullprocname);
+                Message1(parser_e_header_dont_match_any_member,aktprocdef.fullprocname(false));
                 aktprocsym.write_parameter_lists(aktprocdef);
               end
              else
@@ -665,7 +677,7 @@ implementation
                    aktprocsym.first_procdef.interfacedef and
                    not(aktprocsym.procdef_count>2) then
                  begin
-                   Message1(parser_e_header_dont_match_forward,aktprocdef.fullprocname);
+                   Message1(parser_e_header_dont_match_forward,aktprocdef.fullprocname(false));
                    aktprocsym.write_parameter_lists(aktprocdef);
                  end
                 else
@@ -679,77 +691,69 @@ implementation
               end;
            end;
 
+         { restore file pos }
+         aktfilepos:=oldfilepos;
+
          { update procinfo, because the aktprocdef can be
            changed by check_identical_proc (PFV) }
          procinfo.procdef:=aktprocdef;
 
+         { compile procedure when a body is needed }
+         if (pdflags and pd_body)<>0 then
+          begin
+            Message1(parser_d_procedure_start,aktprocdef.fullprocname(false));
 
-{$ifdef i386}
-         { add implicit pushes for interrupt routines }
-         if (po_interrupt in aktprocdef.procoptions) then
-           procinfo.allocate_interrupt_stackframe;
-{$endif i386}
+            if assigned(aktprocsym.owner) then
+              aktprocdef.aliasnames.insert(aktprocdef.mangledname);
 
-         { pointer to the return value ? }
-         if paramanager.ret_in_param(aktprocdef.rettype.def,aktprocdef.proccalloption)
-{$ifdef m68k}
-            and not (aktprocdef.proccalloption in [pocall_cdecl])
-{$endif m68k}
-            then
-          begin
-            procinfo.return_offset:=procinfo.para_offset;
-            inc(procinfo.para_offset,pointer_size);
-          end;
-         { allows to access the parameters of main functions in nested functions }
-         aktprocdef.parast.address_fixup:=procinfo.para_offset;
+            { Insert result variables in the localst }
+            insert_funcret_local(aktprocdef);
 
-         { when it is a value para and it needs a local copy then rename
-           the parameter and insert a copy in the localst. This is not done
-           for assembler procedures }
-         if (not parse_only) and (not aktprocdef.forwarddef) then
-           aktprocdef.parast.foreach_static({$ifdef FPCPROCVAR}@{$endif}checkvaluepara,nil);
+            { when it is a value para and it needs a local copy then rename
+              the parameter and insert a copy in the localst. This is not done
+              for assembler procedures }
+            aktprocdef.parast.foreach_static({$ifdef FPCPROCVAR}@{$endif}checkvaluepara,nil);
 
-         procinfo.after_header;
+            { calculate addresses in parasymtable }
+            aktprocdef.parast.address_fixup:=procinfo.para_offset;
+            calc_parasymtable_addresses(aktprocdef);
 
-         { restore file pos }
-         aktfilepos:=oldfilepos;
+{$ifdef i386}
+            { add implicit pushes for interrupt routines }
+            if (po_interrupt in aktprocdef.procoptions) then
+              procinfo.allocate_interrupt_stackframe;
+{$endif i386}
 
-         { compile procedure when a body is needed }
-         if (pdflags and pd_body)<>0 then
-           begin
-             Message1(parser_d_procedure_start,aktprocdef.fullprocname);
+            procinfo.set_result_offset;
+            procinfo.after_header;
 
-             if assigned(aktprocsym.owner) then
-               aktprocdef.aliasnames.insert(aktprocdef.mangledname);
             { set _FAIL as keyword if constructor }
             if (aktprocdef.proctypeoption=potype_constructor) then
-              tokeninfo^[_FAIL].keyword:=m_all;
+             begin
+               oldfailtokenmode:=tokeninfo^[_FAIL].keyword;
+               tokeninfo^[_FAIL].keyword:=m_all;
+             end;
+            { set _SELF as keyword if methods }
             if assigned(aktprocdef._class) then
-              tokeninfo^[_SELF].keyword:=m_all;
+             begin
+               oldselftokenmode:=tokeninfo^[_SELF].keyword;
+               tokeninfo^[_SELF].keyword:=m_all;
+             end;
 
-             compile_proc_body(((pdflags and pd_global)<>0),assigned(oldprocinfo._class));
+            compile_proc_body(((pdflags and pd_global)<>0),assigned(oldprocinfo._class));
 
-            { reset _FAIL as normal }
+            { reset _FAIL as _SELF normal }
             if (aktprocdef.proctypeoption=potype_constructor) then
-              tokeninfo^[_FAIL].keyword:=m_none;
+              tokeninfo^[_FAIL].keyword:=oldfailtokenmode;
             if assigned(aktprocdef._class) and (lexlevel=main_program_level) then
-              tokeninfo^[_SELF].keyword:=m_none;
+              tokeninfo^[_SELF].keyword:=oldselftokenmode;
              consume(_SEMICOLON);
-           end;
+          end;
+
          { close }
          codegen_doneprocedure;
          { Restore old state }
          constsymtable:=oldconstsymtable;
-{$ifdef notused}
-         { restore the interface order to maintain CRC values PM }
-         if assigned(prevdef) and assigned(aktprocdef.nextoverloaded) then
-           begin
-             stdef:=aktprocdef;
-             aktprocdef:=stdef.nextoverloaded;
-             stdef.nextoverloaded:=prevdef.nextoverloaded;
-             prevdef.nextoverloaded:=stdef;
-           end;
-{$endif notused}
          { release procsym when it was not stored in the symtable }
          if not assigned(aktprocsym.owner) then
           begin
@@ -759,7 +763,6 @@ implementation
          aktprocsym:=oldprocsym;
          aktprocdef:=oldprocdef;
          procinfo:=oldprocinfo;
-         otsym:=nil;
       end;
 
 
@@ -884,7 +887,16 @@ implementation
 end.
 {
   $Log$
-  Revision 1.103  2003-04-24 13:03:01  florian
+  Revision 1.104  2003-04-25 20:59:34  peter
+    * removed funcretn,funcretsym, function result is now in varsym
+      and aliases for result and function name are added using absolutesym
+    * vs_hidden parameter for funcret passed in parameter
+    * vs_hidden fixes
+    * writenode changed to printnode and released from extdebug
+    * -vp option added to generate a tree.log with the nodetree
+    * nicer printnode for statements, callnode
+
+  Revision 1.103  2003/04/24 13:03:01  florian
     * comp is now written with its bit pattern to the ppu instead as an extended
 
   Revision 1.102  2003/04/23 12:35:34  florian

compiler/psystem.pas

@@ -379,7 +379,6 @@ implementation
         nodeclass[vecn]:=cvecnode;
         nodeclass[pointerconstn]:=cpointerconstnode;
         nodeclass[stringconstn]:=cstringconstnode;
-        nodeclass[funcretn]:=cfuncretnode;
         nodeclass[selfn]:=cselfnode;
         nodeclass[notn]:=cnotnode;
         nodeclass[inlinen]:=cinlinenode;
@@ -482,7 +481,16 @@ implementation
 end.
 {
   $Log$
-  Revision 1.46  2003-04-23 21:10:54  peter
+  Revision 1.47  2003-04-25 20:59:34  peter
+    * removed funcretn,funcretsym, function result is now in varsym
+      and aliases for result and function name are added using absolutesym
+    * vs_hidden parameter for funcret passed in parameter
+    * vs_hidden fixes
+    * writenode changed to printnode and released from extdebug
+    * -vp option added to generate a tree.log with the nodetree
+    * nicer printnode for statements, callnode
+
+  Revision 1.46  2003/04/23 21:10:54  peter
     * fix compile for ppc,sparc,m68k
 
   Revision 1.45  2003/04/23 20:16:04  peter

compiler/ptype.pas

@@ -59,6 +59,8 @@ implementation
        { global }
        globals,tokens,verbose,
        systems,
+       { target }
+       paramgr,
        { symtable }
        symconst,symbase,symdef,symsym,symtable,
        defutil,defcmp,
@@ -451,7 +453,9 @@ implementation
         end;
 
       var
-        p : tnode;
+        p  : tnode;
+        vs : tvarsym;
+        pd : tabstractprocdef;
         enumdupmsg : boolean;
       begin
          tt.reset;
@@ -607,17 +611,21 @@ implementation
             _FUNCTION:
               begin
                 consume(_FUNCTION);
-                tt.def:=tprocvardef.create;
+                pd:=tprocvardef.create;
                 if token=_LKLAMMER then
-                 parameter_dec(tprocvardef(tt.def));
+                 parameter_dec(pd);
                 consume(_COLON);
-                single_type(tprocvardef(tt.def).rettype,hs,false);
+                single_type(pd.rettype,hs,false);
                 if token=_OF then
                   begin
                     consume(_OF);
                     consume(_OBJECT);
-                    include(tprocvardef(tt.def).procoptions,po_methodpointer);
+                    include(pd.procoptions,po_methodpointer);
                   end;
+                { Add implicit hidden parameters and function result }
+                insert_hidden_para(pd);
+                insert_funcret_para(pd);
+                tt.def:=pd;
               end;
             else
               expr_type;
@@ -629,7 +637,16 @@ implementation
 end.
 {
   $Log$
-  Revision 1.50  2003-01-05 15:54:15  florian
+  Revision 1.51  2003-04-25 20:59:34  peter
+    * removed funcretn,funcretsym, function result is now in varsym
+      and aliases for result and function name are added using absolutesym
+    * vs_hidden parameter for funcret passed in parameter
+    * vs_hidden fixes
+    * writenode changed to printnode and released from extdebug
+    * -vp option added to generate a tree.log with the nodetree
+    * nicer printnode for statements, callnode
+
+  Revision 1.50  2003/01/05 15:54:15  florian
     + added proper support of type = type <type>; for simple types
 
   Revision 1.49  2003/01/03 23:50:41  peter

compiler/rautils.pas

@@ -744,10 +744,10 @@ Begin
      opr.ref.base:= procinfo.framepointer;
      opr.ref.options:=ref_parafixup;
      { always assume that the result is valid. }
-     tfuncretsym(aktprocdef.funcretsym).funcretstate:=vs_assigned;
+     tvarsym(aktprocdef.funcretsym).varstate:=vs_assigned;
      { increase reference count, this is also used to check
        if the result variable is actually used or not }
-     inc(tfuncretsym(aktprocdef.funcretsym).refcount);
+     inc(tvarsym(aktprocdef.funcretsym).refcount);
      SetupResult:=true;
    end
   else
@@ -1582,7 +1582,16 @@ end;
 end.
 {
   $Log$
-  Revision 1.55  2003-04-06 21:11:23  olle
+  Revision 1.56  2003-04-25 20:59:34  peter
+    * removed funcretn,funcretsym, function result is now in varsym
+      and aliases for result and function name are added using absolutesym
+    * vs_hidden parameter for funcret passed in parameter
+    * vs_hidden fixes
+    * writenode changed to printnode and released from extdebug
+    * -vp option added to generate a tree.log with the nodetree
+    * nicer printnode for statements, callnode
+
+  Revision 1.55  2003/04/06 21:11:23  olle
     * changed newasmsymbol to newasmsymboldata for data symbols
 
   Revision 1.54  2003/03/28 19:16:57  peter

compiler/rgobj.pas

@@ -1516,7 +1516,7 @@ unit rgobj;
         n:Tsuperregister;
 
     begin
-      {We the element with the least interferences out of the 
+      {We the element with the least interferences out of the
        simplifyworklist.}
       min:=$ff;
       p:=1;
@@ -1533,7 +1533,7 @@ unit rgobj;
         end;
       n:=Tsuperregister(simplifyworklist[p]);
       delete(simplifyworklist,p,1);
-          
+
       {Push it on the selectstack.}
       selectstack:=selectstack+char(n);
       adj:=igraph.adjlist[n];
@@ -1761,7 +1761,7 @@ unit rgobj;
                   worklist_moves.remove(m);
                 Tmoveins(m).moveset:=ms_frozen_moves;
                 frozen_moves.insert(m);
-  
+
                 if not(move_related(v)) and (degree[v]<cpu_registers) then
                   begin
                     delete(freezeworklist,pos(char(v),freezeworklist),1);
@@ -2016,7 +2016,16 @@ end.
 
 {
   $Log$
-  Revision 1.40  2003-04-25 08:25:26  daniel
+  Revision 1.41  2003-04-25 20:59:35  peter
+    * removed funcretn,funcretsym, function result is now in varsym
+      and aliases for result and function name are added using absolutesym
+    * vs_hidden parameter for funcret passed in parameter
+    * vs_hidden fixes
+    * writenode changed to printnode and released from extdebug
+    * -vp option added to generate a tree.log with the nodetree
+    * nicer printnode for statements, callnode
+
+  Revision 1.40  2003/04/25 08:25:26  daniel
     * Ifdefs around a lot of calls to cleartempgen
     * Fixed registers that are allocated but not freed in several nodes
     * Tweak to register allocator to cause less spills

compiler/symconst.pas

@@ -250,7 +250,8 @@ type
     vo_is_local_copy,
     vo_is_const,  { variable is declared as const (parameter) and can't be written to }
     vo_is_exported,
-    vo_is_high_value
+    vo_is_high_value,
+    vo_is_funcret
   );
   tvaroptions=set of tvaroption;
 
@@ -274,8 +275,7 @@ type
   { possible types for symtable entries }
   tsymtyp = (abstractsym,varsym,typesym,procsym,unitsym,
              constsym,enumsym,typedconstsym,errorsym,syssym,
-             labelsym,absolutesym,propertysym,funcretsym,
-             macrosym,rttisym);
+             labelsym,absolutesym,propertysym,macrosym,rttisym);
 
   { State of the variable, if it's declared, assigned or used }
   tvarstate=(vs_none,
@@ -333,8 +333,7 @@ const
      SymTypeName : array[tsymtyp] of string[12] = (
        'abstractsym','variable','type','proc','unit',
        'const','enum','typed const','errorsym','system sym',
-       'label','absolute','property','funcret',
-       'macrosym','rttisym'
+       'label','absolute','property','macrosym','rttisym'
      );
 
      DefTypeName : array[tdeftype] of string[12] = (
@@ -354,7 +353,16 @@ implementation
 end.
 {
   $Log$
-  Revision 1.48  2003-04-23 20:16:04  peter
+  Revision 1.49  2003-04-25 20:59:35  peter
+    * removed funcretn,funcretsym, function result is now in varsym
+      and aliases for result and function name are added using absolutesym
+    * vs_hidden parameter for funcret passed in parameter
+    * vs_hidden fixes
+    * writenode changed to printnode and released from extdebug
+    * -vp option added to generate a tree.log with the nodetree
+    * nicer printnode for statements, callnode
+
+  Revision 1.48  2003/04/23 20:16:04  peter
     + added currency support based on int64
     + is_64bit for use in cg units instead of is_64bitint
     * removed cgmessage from n386add, replace with internalerrors

compiler/symdef.pas

@@ -413,6 +413,7 @@ interface
        tabstractprocdef = class(tstoreddef)
           { saves a definition to the return type }
           rettype         : ttype;
+          parast          : tsymtable;
           para            : tlinkedlist;
           selfpara        : tparaitem;
           proctypeoption  : tproctypeoption;
@@ -427,10 +428,12 @@ interface
           destructor destroy;override;
           procedure  ppuwrite(ppufile:tcompilerppufile);override;
           procedure deref;override;
+          procedure releasemem;
           function  concatpara(afterpara:tparaitem;const tt:ttype;sym : tsym;vsp : tvarspez;defval:tsym):tparaitem;
+          function  insertpara(const tt:ttype;sym : tsym;vsp : tvarspez;defval:tsym):tparaitem;
           procedure removepara(currpara:tparaitem);
           function  para_size(alignsize:longint) : longint;
-          function  typename_paras : string;
+          function  typename_paras(showhidden:boolean): string;
           procedure test_if_fpu_result;
           function  is_methodpointer:boolean;virtual;
           function  is_addressonly:boolean;virtual;
@@ -445,6 +448,7 @@ interface
           constructor create;
           constructor ppuload(ppufile:tcompilerppufile);
           procedure ppuwrite(ppufile:tcompilerppufile);override;
+          function  getsymtable(t:tgetsymtable):tsymtable;override;
           function  size : longint;override;
           function  gettypename:string;override;
           function  is_publishable : boolean;override;
@@ -488,12 +492,8 @@ interface
           { alias names }
           aliasnames : tstringlist;
           { symtables }
-          parast,
           localst : tsymtable;
           funcretsym : tsym;
-          { next is only used to check if RESULT is accessed,
-            not stored in a tnode }
-          resultfuncretsym : tsym;
           { browser info }
           lastref,
           defref,
@@ -505,6 +505,8 @@ interface
           code : tnode;
           { info about register variables (JM) }
           regvarinfo: pointer;
+          { name of the result variable to insert in the localsymtable }
+          resultname : stringid;
           { true, if the procedure is only declared }
           { (forward procedure) }
           forwarddef,
@@ -524,7 +526,6 @@ interface
           procedure deref;override;
           procedure derefimpl;override;
           function  getsymtable(t:tgetsymtable):tsymtable;override;
-          function  haspara:boolean;
           function gettypename : string;override;
           function  mangledname : string;
           procedure setmangledname(const s : string);
@@ -535,8 +536,7 @@ interface
             when we are sure that a local symbol table will be required.
           }
           procedure insert_localst;
-          function  fullprocname:string;
-          function  fullprocnamewithret:string;
+          function  fullprocname(showhidden:boolean):string;
           function  cplusplusmangledname : string;
           function  is_methodpointer:boolean;override;
           function  is_addressonly:boolean;override;
@@ -757,11 +757,9 @@ implementation
        { global }
        verbose,
        { target }
-       aasmcpu,
-       systems,
+       systems,aasmcpu,paramgr,
        { symtable }
-       symsym,symtable,paramgr,
-       symutil,defutil,
+       symsym,symtable,symutil,defutil,
        { module }
 {$ifdef GDB}
        gdb,
@@ -2894,17 +2892,12 @@ implementation
 
 
     constructor trecorddef.ppuload(ppufile:tcompilerppufile);
-      var
-         oldread_member : boolean;
       begin
          inherited ppuloaddef(ppufile);
          deftype:=recorddef;
          savesize:=ppufile.getlongint;
-         oldread_member:=read_member;
-         read_member:=true;
          symtable:=trecordsymtable.create;
          trecordsymtable(symtable).ppuload(ppufile);
-         read_member:=oldread_member;
          symtable.defowner:=self;
          isunion:=false;
       end;
@@ -2945,16 +2938,11 @@ implementation
 
 
     procedure trecorddef.ppuwrite(ppufile:tcompilerppufile);
-      var
-         oldread_member : boolean;
       begin
-         oldread_member:=read_member;
-         read_member:=true;
          inherited ppuwritedef(ppufile);
          ppufile.putlongint(savesize);
          ppufile.writeentry(ibrecorddef);
          trecordsymtable(symtable).ppuwrite(ppufile);
-         read_member:=oldread_member;
       end;
 
 
@@ -3057,6 +3045,8 @@ implementation
     constructor tabstractprocdef.create;
       begin
          inherited create;
+         parast:=tparasymtable.create;
+         parast.defowner:=self;
          para:=TLinkedList.Create;
          selfpara:=nil;
          minparacount:=0;
@@ -3073,11 +3063,31 @@ implementation
 
     destructor tabstractprocdef.destroy;
       begin
-         Para.Free;
+         if assigned(para) then
+          para.free;
+         if assigned(parast) then
+          begin
+{$ifdef MEMDEBUG}
+            memprocparast.start;
+{$endif MEMDEBUG}
+            parast.free;
+{$ifdef MEMDEBUG}
+            memprocparast.stop;
+{$endif MEMDEBUG}
+          end;
          inherited destroy;
       end;
 
 
+    procedure tabstractprocdef.releasemem;
+      begin
+        para.free;
+        para:=nil;
+        parast.free;
+        parast:=nil;
+      end;
+
+
     function tabstractprocdef.concatpara(afterpara:tparaitem;const tt:ttype;sym : tsym;vsp : tvarspez;defval:tsym):tparaitem;
       var
         hp : TParaItem;
@@ -3103,6 +3113,28 @@ implementation
       end;
 
 
+    function tabstractprocdef.insertpara(const tt:ttype;sym : tsym;vsp : tvarspez;defval:tsym):tparaitem;
+      var
+        hp : TParaItem;
+      begin
+        hp:=TParaItem.Create;
+        hp.paratyp:=vsp;
+        hp.parasym:=sym;
+        hp.paratype:=tt;
+        hp.defaultvalue:=defval;
+        { Parameters are stored from left to right }
+        Para.insert(hp);
+        { Don't count hidden parameters }
+        if (vsp<>vs_hidden) then
+         begin
+           if not assigned(defval) then
+            inc(minparacount);
+           inc(maxparacount);
+         end;
+        insertpara:=hp;
+      end;
+
+
     procedure tabstractprocdef.removepara(currpara:tparaitem);
       begin
         { Don't count hidden parameters }
@@ -3132,9 +3164,16 @@ implementation
     procedure tabstractprocdef.deref;
       var
          hp : TParaItem;
+         oldlocalsymtable : tsymtable;
       begin
          inherited deref;
          rettype.resolve;
+         { parast }
+         oldlocalsymtable:=aktlocalsymtable;
+         aktlocalsymtable:=parast;
+         tparasymtable(parast).deref;
+         aktlocalsymtable:=oldlocalsymtable;
+         { paraitems }
          hp:=TParaItem(Para.first);
          while assigned(hp) do
           begin
@@ -3152,6 +3191,7 @@ implementation
          count,i : word;
       begin
          inherited ppuloaddef(ppufile);
+         parast:=nil;
          Para:=TLinkedList.Create;
          selfpara:=nil;
          minparacount:=0;
@@ -3241,30 +3281,41 @@ implementation
       end;
 
 
-    function tabstractprocdef.typename_paras : string;
+    function tabstractprocdef.typename_paras(showhidden:boolean) : string;
       var
         hs,s : string;
         hp : TParaItem;
         hpc : tconstsym;
+        first : boolean;
       begin
         hp:=TParaItem(Para.first);
-        s:='(';
+        s:='';
+        first:=true;
         while assigned(hp) do
          begin
-           case hp.paratyp of
-             vs_var :
-               s:=s+'var';
-             vs_const :
-               s:=s+'const';
-             vs_out :
-               s:=s+'out';
-           end;
-           if hp.paratyp<>vs_hidden then
-             begin
+           if (hp.paratyp<>vs_hidden) or
+              (showhidden) then
+            begin
+               if first then
+                begin
+                  s:=s+'(';
+                  first:=false;
+                end
+               else
+                s:=s+',';
+               case hp.paratyp of
+                 vs_var :
+                   s:=s+'var';
+                 vs_const :
+                   s:=s+'const';
+                 vs_out :
+                   s:=s+'out';
+                 vs_hidden :
+                   s:=s+'hidden';
+               end;
                if assigned(hp.paratype.def.typesym) then
                  begin
-                   if hp.paratyp in [vs_var,vs_const,vs_out] then
-                     s := s + ' ';
+                   s:=s+' ';
                    hs:=hp.paratype.def.typesym.realname;
                    if hs[1]<>'$' then
                      s:=s+hp.paratype.def.typesym.realname
@@ -3303,18 +3354,14 @@ implementation
                   if hs<>'' then
                    s:=s+'="'+hs+'"';
                 end;
-               if assigned(hp.next) then
-                s:=s+',';
              end;
            hp:=TParaItem(hp.next);
          end;
-        s:=s+')';
+        if not first then
+         s:=s+')';
         if (po_varargs in procoptions) then
          s:=s+';VarArgs';
-        if s='()' then
-         typename_paras:=''
-        else
-         typename_paras:=s;
+        typename_paras:=s;
       end;
 
 
@@ -3362,10 +3409,8 @@ implementation
          fileinfo:=aktfilepos;
          extnumber:=$ffff;
          aliasnames:=tstringlist.create;
-         parast:=tparasymtable.create;
          funcretsym:=nil;
          localst := nil;
-         parast.defowner:=self;
          defref:=nil;
          lastwritten:=nil;
          refcount:=0;
@@ -3420,10 +3465,11 @@ implementation
             code := nil;
             funcretsym:=nil;
           end;
-         { load para and local symtables }
+         { load para symtable }
          parast:=tparasymtable.create;
          tparasymtable(parast).ppuload(ppufile);
          parast.defowner:=self;
+         { load local symtable }
          if (proccalloption=pocall_inline) or
             ((current_module.flags and uf_local_browser)<>0) then
           begin
@@ -3462,16 +3508,6 @@ implementation
              defref.free;
            end;
          aliasnames.free;
-         if assigned(parast) then
-          begin
-{$ifdef MEMDEBUG}
-            memprocparast.start;
-{$endif MEMDEBUG}
-            parast.free;
-{$ifdef MEMDEBUG}
-            memprocparast.stop;
-{$endif MEMDEBUG}
-          end;
          if assigned(localst) and (localst.symtabletype<>staticsymtable) then
           begin
 {$ifdef MEMDEBUG}
@@ -3553,11 +3589,6 @@ implementation
          ppufile.writeentry(ibprocdef);
 
          { Save the para symtable, this is taken from the interface }
-         if not assigned(parast) then
-          begin
-            parast:=tparasymtable.create;
-            parast.defowner:=self;
-          end;
          tparasymtable(parast).ppuwrite(ppufile);
 
          { save localsymtable for inline procedures or when local
@@ -3589,7 +3620,7 @@ implementation
 
 
 
-    function tprocdef.fullprocname:string;
+    function tprocdef.fullprocname(showhidden:boolean):string;
       var
         s : string;
       begin
@@ -3600,20 +3631,11 @@ implementation
             s:=s+'class ';
            s:=s+_class.objrealname^+'.';
          end;
-        s:=s+procsym.realname+typename_paras;
-        fullprocname:=s;
-      end;
-
-
-    function tprocdef.fullprocnamewithret:string;
-      var
-        s : string;
-      begin
-        s:=fullprocname;
+        s:=s+procsym.realname+typename_paras(showhidden);
         if assigned(rettype.def) and
           not(is_void(rettype.def)) then
-               s:=s+' : '+rettype.def.gettypename;
-        fullprocnamewithret:=s;
+               s:=s+':'+rettype.def.gettypename;
+        fullprocname:=s;
       end;
 
 
@@ -3705,6 +3727,7 @@ implementation
         end;
       end;
 
+
     procedure tprocdef.load_references(ppufile:tcompilerppufile;locals:boolean);
       var
         pos : tfileposinfo;
@@ -3802,13 +3825,6 @@ implementation
           end;
       end;
 
-
-    function tprocdef.haspara:boolean;
-      begin
-        haspara:=assigned(parast.symindex.first);
-      end;
-
-
 {$ifdef GDB}
 
 {$ifdef unused}
@@ -3915,16 +3931,9 @@ implementation
 
 
     procedure tprocdef.deref;
-      var
-        oldlocalsymtable : tsymtable;
       begin
          inherited deref;
          resolvedef(pointer(_class));
-         { parast }
-         oldlocalsymtable:=aktlocalsymtable;
-         aktlocalsymtable:=parast;
-         tparasymtable(parast).deref;
-         aktlocalsymtable:=oldlocalsymtable;
          { procsym that originaly defined this definition, should be in the
            same symtable }
          resolvesym(pointer(procsym));
@@ -3962,7 +3971,7 @@ implementation
 
     function tprocdef.gettypename : string;
       begin
-         gettypename := FullProcName+';'+ProcCallOptionStr[proccalloption];
+         gettypename := FullProcName(false)+';'+ProcCallOptionStr[proccalloption];
       end;
 
 
@@ -4087,6 +4096,10 @@ implementation
       begin
          inherited ppuload(ppufile);
          deftype:=procvardef;
+         { load para symtable }
+         parast:=tparasymtable.create;
+         tparasymtable(parast).ppuload(ppufile);
+         parast.defowner:=self;
       end;
 
 
@@ -4101,7 +4114,23 @@ implementation
          else
            fpu_used:=0;
          inherited ppuwrite(ppufile);
+
+         { Write this entry }
          ppufile.writeentry(ibprocvardef);
+
+         { Save the para symtable, this is taken from the interface }
+         tparasymtable(parast).ppuwrite(ppufile);
+      end;
+
+
+    function tprocvardef.getsymtable(t:tgetsymtable):tsymtable;
+      begin
+        case t of
+          gs_para :
+            getsymtable:=parast;
+          else
+            getsymtable:=nil;
+        end;
       end;
 
 
@@ -4250,9 +4279,9 @@ implementation
              s := s+'procedure variable type of';
          if assigned(rettype.def) and
             (rettype.def<>voidtype.def) then
-           s:=s+' function'+typename_paras+':'+rettype.def.gettypename
+           s:=s+' function'+typename_paras(false)+':'+rettype.def.gettypename
          else
-           s:=s+' procedure'+typename_paras;
+           s:=s+' procedure'+typename_paras(false);
          if po_methodpointer in procoptions then
            s := s+' of object';
          gettypename := s+';'+ProcCallOptionStr[proccalloption]+'>';
@@ -4302,7 +4331,6 @@ implementation
 
     constructor tobjectdef.ppuload(ppufile:tcompilerppufile);
       var
-         oldread_member : boolean;
          i,implintfcount: longint;
       begin
          inherited ppuloaddef(ppufile);
@@ -4339,11 +4367,8 @@ implementation
          else
            implementedinterfaces:=nil;
 
-         oldread_member:=read_member;
-         read_member:=true;
          symtable:=tobjectsymtable.create(objrealname^);
          tobjectsymtable(symtable).ppuload(ppufile);
-         read_member:=oldread_member;
 
          symtable.defowner:=self;
 
@@ -4382,7 +4407,6 @@ implementation
 
     procedure tobjectdef.ppuwrite(ppufile:tcompilerppufile);
       var
-         oldread_member : boolean;
          implintfcount : longint;
          i : longint;
       begin
@@ -4413,10 +4437,7 @@ implementation
 
          ppufile.writeentry(ibobjectdef);
 
-         oldread_member:=read_member;
-         read_member:=true;
          tobjectsymtable(symtable).ppuwrite(ppufile);
-         read_member:=oldread_member;
       end;
 
 
@@ -5708,12 +5729,19 @@ implementation
           (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba]);
       end;
 
-begin
-   voidprocdef:=tprocdef.create;
 end.
 {
   $Log$
-  Revision 1.135  2003-04-23 20:16:04  peter
+  Revision 1.136  2003-04-25 20:59:35  peter
+    * removed funcretn,funcretsym, function result is now in varsym
+      and aliases for result and function name are added using absolutesym
+    * vs_hidden parameter for funcret passed in parameter
+    * vs_hidden fixes
+    * writenode changed to printnode and released from extdebug
+    * -vp option added to generate a tree.log with the nodetree
+    * nicer printnode for statements, callnode
+
+  Revision 1.135  2003/04/23 20:16:04  peter
     + added currency support based on int64
     + is_64bit for use in cg units instead of is_64bitint
     * removed cgmessage from n386add, replace with internalerrors

compiler/symsym.pas

@@ -138,10 +138,11 @@ interface
           function search_procdef_nopara_boolret:Tprocdef;
           function search_procdef_bytype(pt:Tproctypeoption):Tprocdef;
           function search_procdef_bypara(params:Tlinkedlist;
+                                         retdef:tdef;
                                          allowconvert,
                                          allowdefault:boolean):Tprocdef;
           function search_procdef_byprocvardef(d:Tprocvardef):Tprocdef;
-          function search_procdef_by1paradef(firstpara:Tdef):Tprocdef;
+          function search_procdef_unary_operator(firstpara:Tdef):Tprocdef;
           function search_procdef_assignment_operator(fromdef,todef:tdef):Tprocdef;
           function search_procdef_binary_operator(def1,def2:tdef):Tprocdef;
           function  write_references(ppufile:tcompilerppufile;locals:boolean):boolean;override;
@@ -226,26 +227,13 @@ interface
 {$endif GDB}
        end;
 
-       tfuncretsym = class(tstoredsym)
-          returntype    : ttype;
-          address       : longint;
-          funcretstate  : tvarstate;
-          constructor create(const n : string;const tt : ttype);
-          constructor ppuload(ppufile:tcompilerppufile);
-          destructor  destroy;override;
-          procedure ppuwrite(ppufile:tcompilerppufile);override;
-          procedure deref;override;
-{$ifdef GDB}
-          procedure concatstabto(asmlist : taasmoutput);override;
-{$endif GDB}
-       end;
-
        tabsolutesym = class(tvarsym)
           abstyp  : absolutetyp;
           absseg  : boolean;
           ref     : tstoredsym;
           asmname : pstring;
           constructor create(const n : string;const tt : ttype);
+          constructor create_ref(const n : string;const tt : ttype;sym:tstoredsym);
           constructor ppuload(ppufile:tcompilerppufile);
           procedure deref;override;
           function  mangledname : string;
@@ -360,8 +348,6 @@ interface
 
        generrorsym : tsym;
 
-       otsym : tvarsym;
-
     const
        current_object_option : tsymoptions = [sp_public];
 
@@ -369,8 +355,6 @@ interface
     procedure generate_rtti(p:tsym);
     procedure generate_inittable(p:tsym);
 
-
-
 implementation
 
     uses
@@ -384,7 +368,7 @@ implementation
        { target }
        systems,
        { symtable }
-       symtable,defutil,defcmp,
+       defutil,defcmp,symtable,
 {$ifdef GDB}
        gdb,
 {$endif GDB}
@@ -854,7 +838,7 @@ implementation
          while assigned(p) do
            begin
               if p^.def<>skipdef then
-                MessagePos1(p^.def.fileinfo,sym_h_param_list,p^.def.fullprocname);
+                MessagePos1(p^.def.fileinfo,sym_h_param_list,p^.def.fullprocname(false));
               p:=p^.next;
            end;
       end;
@@ -870,7 +854,7 @@ implementation
               if (p^.def.procsym=self) and
                  (p^.def.forwarddef) then
                 begin
-                   MessagePos1(p^.def.fileinfo,sym_e_forward_not_resolved,p^.def.fullprocname);
+                   MessagePos1(p^.def.fileinfo,sym_e_forward_not_resolved,p^.def.fullprocname(false));
                    { Turn futher error messages off }
                    p^.def.forwarddef:=false;
                 end;
@@ -918,7 +902,7 @@ implementation
     function Tprocsym.getprocdef(nr:cardinal):Tprocdef;
       var
         i : cardinal;
-        pd : Pprocdeflist;
+        pd : pprocdeflist;
       begin
         pd:=pdlistfirst;
         for i:=2 to nr do
@@ -933,12 +917,12 @@ implementation
 
     procedure Tprocsym.add_para_match_to(Aprocsym:Tprocsym);
       var
-        pd:Pprocdeflist;
+        pd:pprocdeflist;
       begin
         pd:=pdlistfirst;
         while assigned(pd) do
           begin
-            if Aprocsym.search_procdef_bypara(pd^.def.para,false,true)=nil then
+            if Aprocsym.search_procdef_bypara(pd^.def.para,nil,false,true)=nil then
               Aprocsym.addprocdef(pd^.def);
             pd:=pd^.next;
           end;
@@ -947,7 +931,7 @@ implementation
 
     procedure Tprocsym.concat_procdefs_to(s:Tprocsym);
       var
-        pd : Pprocdeflist;
+        pd : pprocdeflist;
       begin
         pd:=pdlistfirst;
         while assigned(pd) do
@@ -978,7 +962,7 @@ implementation
 
     procedure Tprocsym.foreach_procdef_static(proc2call:Tprocdefcallback;arg:pointer);
       var
-        p : Pprocdeflist;
+        p : pprocdeflist;
       begin
         p:=pdlistfirst;
         while assigned(p) do
@@ -991,7 +975,7 @@ implementation
 
     function Tprocsym.search_procdef_nopara_boolret:Tprocdef;
       var
-        p : Pprocdeflist;
+        p : pprocdeflist;
       begin
         search_procdef_nopara_boolret:=nil;
         p:=pdlistfirst;
@@ -1009,7 +993,7 @@ implementation
 
     function Tprocsym.search_procdef_bytype(pt:Tproctypeoption):Tprocdef;
       var
-        p : Pprocdeflist;
+        p : pprocdeflist;
       begin
         search_procdef_bytype:=nil;
         p:=pdlistfirst;
@@ -1026,30 +1010,39 @@ implementation
 
 
     function Tprocsym.search_procdef_bypara(params:Tlinkedlist;
+                                            retdef:tdef;
                                             allowconvert,
                                             allowdefault:boolean):Tprocdef;
       var
-        pd : Pprocdeflist;
+        pd : pprocdeflist;
         eq : tequaltype;
       begin
         search_procdef_bypara:=nil;
         pd:=pdlistfirst;
         while assigned(pd) do
          begin
-           eq:=compare_paras(pd^.def.para,params,cp_value_equal_const,allowdefault);
+           if assigned(retdef) then
+             eq:=compare_defs(retdef,pd^.def.rettype.def,nothingn)
+           else
+             eq:=te_equal;
            if (eq>=te_equal) or
               (allowconvert and (eq>te_incompatible)) then
-             begin
-               search_procdef_bypara:=pd^.def;
-               break;
-             end;
+            begin
+              eq:=compare_paras(pd^.def.para,params,cp_value_equal_const,allowdefault);
+              if (eq>=te_equal) or
+                 (allowconvert and (eq>te_incompatible)) then
+                begin
+                  search_procdef_bypara:=pd^.def;
+                  break;
+                end;
+            end;
            pd:=pd^.next;
          end;
       end;
 
     function Tprocsym.search_procdef_byprocvardef(d:Tprocvardef):Tprocdef;
       var
-        pd : Pprocdeflist;
+        pd : pprocdeflist;
         eq,besteq : tequaltype;
         bestpd : tprocdef;
       begin
@@ -1081,20 +1074,28 @@ implementation
       end;
 
 
-    function Tprocsym.search_procdef_by1paradef(firstpara:Tdef):Tprocdef;
+    function Tprocsym.search_procdef_unary_operator(firstpara:Tdef):Tprocdef;
       var
-        pd:Pprocdeflist;
+        pd : pprocdeflist;
+        currpara : tparaitem;
       begin
-        search_procdef_by1paradef:=nil;
+        search_procdef_unary_operator:=nil;
         pd:=pdlistfirst;
         while assigned(pd) do
           begin
-            if equal_defs(Tparaitem(pd^.def.para.first).paratype.def,firstpara) and
-               (Tparaitem(pd^.def.para.first).next=nil) then
-              begin
-                search_procdef_by1paradef:=pd^.def;
-                break;
-              end;
+            currpara:=tparaitem(pd^.def.para.first);
+            { ignore vs_hidden parameters }
+            while assigned(currpara) and (currpara.paratyp=vs_hidden) do
+             currpara:=tparaitem(currpara.next);
+            if assigned(currpara) then
+             begin
+               if (currpara.next=nil) and
+                  equal_defs(currpara.paratype.def,firstpara) then
+                 begin
+                   search_procdef_unary_operator:=pd^.def;
+                   break;
+                 end;
+             end;
             pd:=pd^.next;
           end;
       end;
@@ -1108,6 +1109,7 @@ implementation
         eq,
         besteq : tequaltype;
         hpd : tprocdef;
+        currpara : tparaitem;
       begin
         search_procdef_assignment_operator:=nil;
         bestpd:=nil;
@@ -1117,19 +1119,26 @@ implementation
           begin
             if equal_defs(todef,pd^.def.rettype.def) then
              begin
-               eq:=compare_defs_ext(fromdef,Tparaitem(pd^.def.para.first).paratype.def,
-                                    nothingn,false,false,convtyp,hpd);
-               if eq=te_exact then
-                begin
-                  search_procdef_assignment_operator:=pd^.def;
-                  exit;
-                end;
-               if eq>besteq then
+               currpara:=Tparaitem(pd^.def.para.first);
+               { ignore vs_hidden parameters }
+               while assigned(currpara) and (currpara.paratyp=vs_hidden) do
+                currpara:=tparaitem(currpara.next);
+               if assigned(currpara) then
                 begin
-                  bestpd:=pd^.def;
-                  besteq:=eq;
+                  eq:=compare_defs_ext(fromdef,currpara.paratype.def,
+                                       nothingn,false,false,convtyp,hpd);
+                  if eq=te_exact then
+                   begin
+                     search_procdef_assignment_operator:=pd^.def;
+                     exit;
+                   end;
+                  if eq>besteq then
+                   begin
+                     bestpd:=pd^.def;
+                     besteq:=eq;
+                   end;
                 end;
-              end;
+             end;
             pd:=pd^.next;
           end;
         search_procdef_assignment_operator:=bestpd;
@@ -1145,6 +1154,8 @@ implementation
         eqlev,
         bestlev : byte;
         hpd : tprocdef;
+        nextpara,
+        currpara : tparaitem;
       begin
         search_procdef_binary_operator:=nil;
         bestpd:=nil;
@@ -1152,26 +1163,50 @@ implementation
         pd:=pdlistfirst;
         while assigned(pd) do
           begin
-            { Compare def1 with the first para }
-            eq1:=compare_defs_ext(def1,Tparaitem(pd^.def.para.first).paratype.def,
-                                 nothingn,false,false,convtyp,hpd);
-            if eq1<>te_incompatible then
+            currpara:=Tparaitem(pd^.def.para.first);
+            { ignore vs_hidden parameters }
+            while assigned(currpara) and (currpara.paratyp=vs_hidden) do
+             currpara:=tparaitem(currpara.next);
+            if assigned(currpara) then
              begin
-               { Compare def2 with the last para }
-               eq2:=compare_defs_ext(def2,Tparaitem(pd^.def.para.last).paratype.def,
+               { Compare def1 with the first para }
+               eq1:=compare_defs_ext(def1,currpara.paratype.def,
                                     nothingn,false,false,convtyp,hpd);
-               if eq2<>te_incompatible then
+               if eq1<>te_incompatible then
                 begin
-                  eqlev:=byte(eq1)+byte(eq2);
-                  if eqlev=(byte(te_exact)+byte(te_exact)) then
-                   begin
-                     search_procdef_binary_operator:=pd^.def;
-                     exit;
-                   end;
-                  if eqlev>bestlev then
+                  { Ignore vs_hidden parameters }
+                  repeat
+                    currpara:=tparaitem(currpara.next);
+                  until (not assigned(currpara)) or (currpara.paratyp<>vs_hidden);
+                  if assigned(currpara) then
                    begin
-                     bestpd:=pd^.def;
-                     bestlev:=eqlev;
+                     { Ignore vs_hidden parameters }
+                     nextpara:=currpara;
+                     repeat
+                       nextpara:=tparaitem(nextpara.next);
+                     until (not assigned(nextpara)) or (nextpara.paratyp<>vs_hidden);
+                     { There should be no other parameters left }
+                     if not assigned(nextpara) then
+                      begin
+                        { Compare def2 with the last para }
+                        eq2:=compare_defs_ext(def2,currpara.paratype.def,
+                                             nothingn,false,false,convtyp,hpd);
+                        if (eq2<>te_incompatible)  then
+                         begin
+                           { check level }
+                           eqlev:=byte(eq1)+byte(eq2);
+                           if eqlev=(byte(te_exact)+byte(te_exact)) then
+                            begin
+                              search_procdef_binary_operator:=pd^.def;
+                              exit;
+                            end;
+                           if eqlev>bestlev then
+                            begin
+                              bestpd:=pd^.def;
+                              bestlev:=eqlev;
+                            end;
+                         end;
+                      end;
                    end;
                 end;
              end;
@@ -1413,64 +1448,23 @@ implementation
       end;
 {$endif GDB}
 
+
 {****************************************************************************
-                                  TFUNCRETSYM
+                                  TABSOLUTESYM
 ****************************************************************************}
 
-    constructor tfuncretsym.create(const n : string;const tt:ttype);
-
-      begin
-         inherited create(n);
-         typ:=funcretsym;
-         returntype:=tt;
-         funcretstate:=vs_declared;
-         { address valid for ret in param only }
-         { otherwise set by insert             }
-         address:=procinfo.return_offset;
-      end;
-
-    constructor tfuncretsym.ppuload(ppufile:tcompilerppufile);
-      begin
-         inherited loadsym(ppufile);
-         ppufile.gettype(returntype);
-         address:=ppufile.getlongint;
-         typ:=funcretsym;
-      end;
-
-    destructor tfuncretsym.destroy;
-      begin
-        inherited destroy;
-      end;
-
-    procedure tfuncretsym.ppuwrite(ppufile:tcompilerppufile);
-      begin
-         inherited writesym(ppufile);
-         ppufile.puttype(returntype);
-         ppufile.putlongint(address);
-         ppufile.writeentry(ibfuncretsym);
-         funcretstate:=vs_used;
-      end;
-
-    procedure tfuncretsym.deref;
-      begin
-         returntype.resolve;
-      end;
-
-{$ifdef GDB}
-    procedure tfuncretsym.concatstabto(asmlist : taasmoutput);
+    constructor tabsolutesym.create(const n : string;const tt : ttype);
       begin
-        { Nothing to do here, it is done in genexitcode  }
+        inherited create(n,tt);
+        typ:=absolutesym;
       end;
-{$endif GDB}
 
-{****************************************************************************
-                                  TABSOLUTESYM
-****************************************************************************}
 
-    constructor tabsolutesym.create(const n : string;const tt : ttype);
+    constructor tabsolutesym.create_ref(const n : string;const tt : ttype;sym:tstoredsym);
       begin
         inherited create(n,tt);
         typ:=absolutesym;
+        ref:=sym;
       end;
 
 
@@ -2563,7 +2557,16 @@ implementation
 end.
 {
   $Log$
-  Revision 1.96  2003-04-23 13:13:58  peter
+  Revision 1.97  2003-04-25 20:59:35  peter
+    * removed funcretn,funcretsym, function result is now in varsym
+      and aliases for result and function name are added using absolutesym
+    * vs_hidden parameter for funcret passed in parameter
+    * vs_hidden fixes
+    * writenode changed to printnode and released from extdebug
+    * -vp option added to generate a tree.log with the nodetree
+    * nicer printnode for statements, callnode
+
+  Revision 1.96  2003/04/23 13:13:58  peter
     * fix operator overload search parameter order
 
   Revision 1.95  2003/04/10 17:57:53  peter

compiler/symtable.pas

@@ -201,7 +201,6 @@ interface
     var
        constsymtable  : tsymtable;      { symtable were the constants can be inserted }
        systemunit     : tglobalsymtable; { pointer to the system unit }
-       read_member    : boolean;        { reading members of an symtable }
 
        lexlevel       : byte;          { level of code }
                                        { 1 for main procedure }
@@ -282,6 +281,8 @@ implementation
       verbose,globals,
       { target }
       systems,
+      { symtable }
+      symutil,
       { module }
       fmodule,
 {$ifdef GDB}
@@ -379,7 +380,6 @@ implementation
                 ibprocsym : sym:=tprocsym.ppuload(ppufile);
                ibconstsym : sym:=tconstsym.ppuload(ppufile);
                  ibvarsym : sym:=tvarsym.ppuload(ppufile);
-             ibfuncretsym : sym:=tfuncretsym.ppuload(ppufile);
             ibabsolutesym : sym:=tabsolutesym.ppuload(ppufile);
                 ibenumsym : sym:=tenumsym.ppuload(ppufile);
           ibtypedconstsym : sym:=ttypedconstsym.ppuload(ppufile);
@@ -561,7 +561,8 @@ implementation
               the user. (Under delphi it can still be accessed using result),
               but don't allow hiding of RESULT }
             if (m_duplicate_names in aktmodeswitches) and
-               (hsym.typ=funcretsym) and
+               (hsym.typ=varsym) and
+               (vo_is_funcret in tvarsym(hsym).varoptions) and
                not((m_result in aktmodeswitches) and
                    (hsym.name='RESULT')) then
              hsym.owner.rename(hsym.name,'hidden'+hsym.name)
@@ -727,11 +728,11 @@ implementation
            if (tvarsym(p).refs=0) then
              begin
                 if (tsym(p).owner.symtabletype=parasymtable) or (vo_is_local_copy in tvarsym(p).varoptions) then
-                  begin
-                    MessagePos1(tsym(p).fileinfo,sym_h_para_identifier_not_used,tsym(p).realname);
-                  end
+                  MessagePos1(tsym(p).fileinfo,sym_h_para_identifier_not_used,tsym(p).realname)
                 else if (tsym(p).owner.symtabletype=objectsymtable) then
                   MessagePos2(tsym(p).fileinfo,sym_n_private_identifier_not_used,tsym(p).owner.realname^,tsym(p).realname)
+                else if p.name='result' then
+                  MessagePos(tsym(p).fileinfo,sym_w_function_result_not_set)
                 else
                   MessagePos1(tsym(p).fileinfo,sym_n_local_identifier_not_used,tsym(p).realname);
              end
@@ -764,7 +765,7 @@ implementation
            if (tstoredsym(p).refs=0) and (tsym(p).owner.symtabletype=objectsymtable) then
              MessagePos2(tsym(p).fileinfo,sym_n_private_method_not_used,tsym(p).owner.realname^,tsym(p).realname)
            { units references are problematic }
-           else if (tstoredsym(p).refs=0) and not(tsym(p).typ in [funcretsym,enumsym,unitsym]) then
+           else if (tstoredsym(p).refs=0) and not(tsym(p).typ in [enumsym,unitsym]) then
              if (tsym(p).typ<>procsym) or not (tprocsym(p).is_global) or
              { all program functions are declared global
                but unused should still be signaled PM }
@@ -1255,10 +1256,11 @@ implementation
                   { a parameter and the function can have the same
                     name in TP and Delphi, but RESULT not }
                   if (m_duplicate_names in aktmodeswitches) and
-                     (sym.typ=funcretsym) and
+                     (sym.typ in [absolutesym,varsym]) and
+                     (vo_is_funcret in tvarsym(sym).varoptions) and
                      not((m_result in aktmodeswitches) and
                          (sym.name='RESULT')) then
-                   sym.name:='hidden'+sym.name
+                   sym.owner.rename(sym.name,'hidden'+sym.name)
                   else
                    begin
                      DuplicateSym(hsym);
@@ -1270,7 +1272,7 @@ implementation
             { check for duplicate id in local symtable of methods }
             if assigned(next.next) and
                { funcretsym is allowed !! }
-               (sym.typ <> funcretsym) and
+               (not is_funcret_sym(sym)) and
                (next.next.symtabletype=objectsymtable) then
              begin
                hsym:=search_class_member(tobjectdef(next.next.defowner),sym.name);
@@ -1299,7 +1301,7 @@ implementation
       var
         l,varalign : longint;
       begin
-        if not(sym.typ in [varsym,funcretsym]) then
+        if not(sym.typ in [varsym]) then
           internalerror(200208255);
         case sym.typ of
           varsym :
@@ -1320,36 +1322,6 @@ implementation
                   datasize:=tvarsym(sym).address;
                 end;
             end;
-          funcretsym :
-            begin
-              { if retoffset is already set then reuse it, this is needed
-                when inserting the result variable }
-              if procinfo.return_offset<>0 then
-               tfuncretsym(sym).address:=procinfo.return_offset
-              else
-               begin
-                 { allocate space in local if ret in register }
-                 if paramanager.ret_in_reg(tfuncretsym(sym).returntype.def,
-                                           tprocdef(sym.owner.defowner).proccalloption) then
-                  begin
-                    l:=tfuncretsym(sym).returntype.def.size;
-                    varalign:=size_2_align(l);
-                    varalign:=used_align(varalign,aktalignment.localalignmin,dataalignment);
-                    if (tg.direction = 1) then
-                      begin
-                        { on the powerpc, the local variables are accessed with a positiv offset }
-                        tfuncretsym(sym).address:=align(datasize,varalign);
-                        datasize:=tfuncretsym(sym).address+l;
-                      end
-                    else
-                      begin
-                        tfuncretsym(sym).address:=align(datasize+l,varalign);
-                        datasize:=tfuncretsym(sym).address;
-                      end;
-                    procinfo.return_offset:=tg.direction*tfuncretsym(sym).address;
-                  end;
-               end;
-            end;
         end;
       end;
 
@@ -1422,7 +1394,7 @@ implementation
               not(assigned(procinfo.parent._class)))
             ) and
             { funcretsym is allowed !! }
-            (sym.typ<>funcretsym) then
+            (not is_funcret_sym(sym)) then
            begin
               hsym:=search_class_member(procinfo._class,sym.name);
               { private ids can be reused }
@@ -2428,9 +2400,8 @@ implementation
      var
        token : ttoken;
      begin
-      { Reset symbolstack }
+        { Reset symbolstack }
         registerdef:=false;
-        read_member:=false;
         symtablestack:=nil;
         systemunit:=nil;
 {$ifdef GDB}
@@ -2439,20 +2410,23 @@ implementation
         globaltypecount:=1;
         pglobaltypecount:=@globaltypecount;
 {$endif GDB}
-     { create error syms and def }
+        { defs for internal use }
+        voidprocdef:=tprocdef.create;
+        { create error syms and def }
         generrorsym:=terrorsym.create;
         generrortype.setdef(terrordef.create);
 {$ifdef UNITALIASES}
-     { unit aliases }
+        { unit aliases }
         unitaliases:=tdictionary.create;
 {$endif}
-       for token:=first_overloaded to last_overloaded do
+        for token:=first_overloaded to last_overloaded do
          overloaded_operators[token]:=nil;
      end;
 
 
    procedure DoneSymtable;
       begin
+        voidprocdef.free;
         generrorsym.free;
         generrortype.def.free;
 {$ifdef UNITALIASES}
@@ -2463,7 +2437,16 @@ implementation
 end.
 {
   $Log$
-  Revision 1.93  2003-04-16 07:53:11  jonas
+  Revision 1.94  2003-04-25 20:59:35  peter
+    * removed funcretn,funcretsym, function result is now in varsym
+      and aliases for result and function name are added using absolutesym
+    * vs_hidden parameter for funcret passed in parameter
+    * vs_hidden fixes
+    * writenode changed to printnode and released from extdebug
+    * -vp option added to generate a tree.log with the nodetree
+    * nicer printnode for statements, callnode
+
+  Revision 1.93  2003/04/16 07:53:11  jonas
     * calculation of parameter and resultlocation offsets now depends on
       tg.direction instead of if(n)def powerpc
 

compiler/symutil.pas

@@ -27,24 +27,29 @@ unit symutil;
 interface
 
     uses
-       cclasses,
-       cpuinfo,
-       globals,
-       node,
-       symconst,symbase,symtype,symdef,symsym;
-
+       symbase,symtype,symsym;
 
-    function equal_constsym(sym1,sym2:tconstsym):boolean;
+    function is_funcret_sym(p:tsymentry):boolean;
 
     { returns true, if sym needs an entry in the proplist of a class rtti }
     function needs_prop_entry(sym : tsym) : boolean;
 
+    function equal_constsym(sym1,sym2:tconstsym):boolean;
+
 
 implementation
 
     uses
-       globtype,tokens,systems,verbose,
-       symtable;
+       globtype,
+       cpuinfo,
+       symconst;
+
+
+    function is_funcret_sym(p:tsymentry):boolean;
+      begin
+        is_funcret_sym:=(p.typ in [absolutesym,varsym]) and
+                        (vo_is_funcret in tvarsym(p).varoptions);
+      end;
 
 
     function needs_prop_entry(sym : tsym) : boolean;
@@ -100,7 +105,16 @@ implementation
 end.
 {
   $Log$
-  Revision 1.1  2002-11-25 17:43:26  peter
+  Revision 1.2  2003-04-25 20:59:35  peter
+    * removed funcretn,funcretsym, function result is now in varsym
+      and aliases for result and function name are added using absolutesym
+    * vs_hidden parameter for funcret passed in parameter
+    * vs_hidden fixes
+    * writenode changed to printnode and released from extdebug
+    * -vp option added to generate a tree.log with the nodetree
+    * nicer printnode for statements, callnode
+
+  Revision 1.1  2002/11/25 17:43:26  peter
     * splitted defbase in defutil,symutil,defcmp
     * merged isconvertable and is_equal into compare_defs(_ext)
     * made operator search faster by walking the list only once

compiler/tgobj.pas

@@ -173,7 +173,7 @@ unit tgobj;
 {$ifdef EXTDEBUG}
            if not(templist^.temptype in FreeTempTypes) then
             begin
-              Comment(V_Warning,'temp at pos '+tostr(templist^.pos)+
+              Comment(V_Warning,'tgobj: (ResetTempgen) temp at pos '+tostr(templist^.pos)+
                       ' with size '+tostr(templist^.size)+' and type '+TempTypeStr[templist^.temptype]+
                       ' from pos '+tostr(templist^.posinfo.line)+':'+tostr(templist^.posinfo.column)+
                       ' not freed at the end of the procedure');
@@ -235,7 +235,7 @@ unit tgobj;
          if size=0 then
           begin
 {$ifdef EXTDEBUG}
-            Comment(V_Warning,'Temp of size 0 requested, allocating 4 bytes');
+            Comment(V_Warning,'tgobj: (AllocTemp) temp of size 0 requested, allocating 4 bytes');
 {$endif}
             size:=4;
           end;
@@ -257,7 +257,7 @@ unit tgobj;
              begin
 {$ifdef EXTDEBUG}
                if not(hp^.temptype in FreeTempTypes) then
-                 Comment(V_Warning,'Temp in freelist is not set to tt_free');
+                 Comment(V_Warning,'tgobj: (AllocTemp) temp at pos '+tostr(hp^.pos)+ ' in freelist is not set to tt_free !');
 {$endif}
                if (hp^.temptype=freetype) and
                   (hp^.size>=size) then
@@ -344,7 +344,7 @@ unit tgobj;
           end;
 {$ifdef EXTDEBUG}
          tl^.posinfo:=aktfilepos;
-         list.concat(tai_tempalloc.allocinfo(tl^.pos,tl^.size,'Temp type '+TempTypeStr[templist^.temptype]));
+         list.concat(tai_tempalloc.allocinfo(tl^.pos,tl^.size,'allocated with type '+TempTypeStr[templist^.temptype]));
 {$else}
          list.concat(tai_tempalloc.alloc(tl^.pos,tl^.size));
 {$endif}
@@ -367,7 +367,7 @@ unit tgobj;
                if hp^.temptype in FreeTempTypes then
                 begin
 {$ifdef EXTDEBUG}
-                  Comment(V_Warning,'temp managment : (FreeTemp) temp at pos '+tostr(pos)+ ' is already free !');
+                  Comment(V_Warning,'tgobj: (FreeTemp) temp at pos '+tostr(pos)+ ' is already free !');
                   list.concat(tai_tempalloc.allocinfo(hp^.pos,hp^.size,'temp is already freed'));
 {$endif}
                   exit;
@@ -376,7 +376,7 @@ unit tgobj;
                if not(hp^.temptype in temptypes) then
                 begin
 {$ifdef EXTDEBUG}
-                  Comment(V_Debug,'temp managment : (Freetemp) temp at pos '+tostr(pos)+ ' has different type ('+TempTypeStr[hp^.temptype]+'), not releasing');
+                  Comment(V_Debug,'tgobj: (Freetemp) temp at pos '+tostr(pos)+ ' has different type ('+TempTypeStr[hp^.temptype]+'), not releasing');
                   list.concat(tai_tempalloc.allocinfo(hp^.pos,hp^.size,'temp has wrong type ('+TempTypeStr[hp^.temptype]+') not releasing'));
 {$endif}
                   exit;
@@ -477,7 +477,7 @@ unit tgobj;
              hp := hp^.next;
            end;
 {$ifdef EXTDEBUG}
-         Comment(V_Debug,'temp managment : SizeOfTemp temp at pos '+tostr(ref.offset)+' not found !');
+         Comment(V_Debug,'tgobj: (SizeOfTemp) temp at pos '+tostr(ref.offset)+' not found !');
          list.concat(tai_tempalloc.allocinfo(ref.offset,0,'temp not found'));
 {$endif}
       end;
@@ -497,9 +497,9 @@ unit tgobj;
                 begin
 {$ifdef EXTDEBUG}
                   if hp^.temptype=temptype then
-                    Comment(V_Warning,'temp managment : ChangeTempType temp'+
+                    Comment(V_Warning,'tgobj: (ChangeTempType) temp'+
                        ' at pos '+tostr(ref.offset)+ ' is already of the correct type !');
-                  list.concat(tai_tempalloc.allocinfo(hp^.pos,hp^.size,'type changed to '+TempTypeStr[templist^.temptype]));
+                  list.concat(tai_tempalloc.allocinfo(hp^.pos,hp^.size,'type changed to '+TempTypeStr[temptype]));
 {$endif}
                   ChangeTempType:=true;
                   hp^.temptype:=temptype;
@@ -507,7 +507,7 @@ unit tgobj;
                else
                 begin
 {$ifdef EXTDEBUG}
-                   Comment(V_Warning,'temp managment : ChangeTempType temp'+
+                   Comment(V_Warning,'tgobj: (ChangeTempType) temp'+
                       ' at pos '+tostr(ref.offset)+ ' is already freed !');
                   list.concat(tai_tempalloc.allocinfo(hp^.pos,hp^.size,'temp is already freed'));
 {$endif}
@@ -517,7 +517,7 @@ unit tgobj;
             hp:=hp^.next;
           end;
 {$ifdef EXTDEBUG}
-         Comment(V_Warning,'temp managment : ChangeTempType temp'+
+         Comment(V_Warning,'tgobj: (ChangeTempType) temp'+
             ' at pos '+tostr(ref.offset)+ ' not found !');
          list.concat(tai_tempalloc.allocinfo(ref.offset,0,'temp not found'));
 {$endif}
@@ -544,7 +544,16 @@ finalization
 end.
 {
   $Log$
-  Revision 1.29  2003-04-23 08:40:39  jonas
+  Revision 1.30  2003-04-25 20:59:35  peter
+    * removed funcretn,funcretsym, function result is now in varsym
+      and aliases for result and function name are added using absolutesym
+    * vs_hidden parameter for funcret passed in parameter
+    * vs_hidden fixes
+    * writenode changed to printnode and released from extdebug
+    * -vp option added to generate a tree.log with the nodetree
+    * nicer printnode for statements, callnode
+
+  Revision 1.29  2003/04/23 08:40:39  jonas
     * fixed istemp() when tg.direction = 1
 
   Revision 1.28  2003/04/22 09:46:17  peter

compiler/utils/ppudump.pp

@@ -1092,14 +1092,6 @@ begin
               end;
            end;
 
-         ibfuncretsym :
-           begin
-             readcommonsym('Func return value ');
-             write  (space,' Return Type: ');
-             readtype;
-             writeln(space,'     Address: ',getlongint);
-           end;
-
          iberror :
            begin
              Writeln('!! Error in PPU');
@@ -1938,7 +1930,16 @@ begin
 end.
 {
   $Log$
-  Revision 1.38  2003-04-10 17:57:53  peter
+  Revision 1.39  2003-04-25 20:59:35  peter
+    * removed funcretn,funcretsym, function result is now in varsym
+      and aliases for result and function name are added using absolutesym
+    * vs_hidden parameter for funcret passed in parameter
+    * vs_hidden fixes
+    * writenode changed to printnode and released from extdebug
+    * -vp option added to generate a tree.log with the nodetree
+    * nicer printnode for statements, callnode
+
+  Revision 1.38  2003/04/10 17:57:53  peter
     * vs_hidden released
 
   Revision 1.37  2003/03/24 19:57:54  hajny

compiler/verbose.pas

@@ -198,6 +198,12 @@ var
                 { Special cases }
                  'A' : status.verbosity:=V_All;
                  '0' : status.verbosity:=V_Default;
+                 'P' : begin
+                         if inverse then
+                          paraprintnodetree:=0
+                         else
+                          paraprintnodetree:=1;
+                       end;
                  'R' : begin
                           if inverse then
                             begin
@@ -699,7 +705,16 @@ finalization
 end.
 {
   $Log$
-  Revision 1.25  2003-04-22 14:33:38  peter
+  Revision 1.26  2003-04-25 20:59:35  peter
+    * removed funcretn,funcretsym, function result is now in varsym
+      and aliases for result and function name are added using absolutesym
+    * vs_hidden parameter for funcret passed in parameter
+    * vs_hidden fixes
+    * writenode changed to printnode and released from extdebug
+    * -vp option added to generate a tree.log with the nodetree
+    * nicer printnode for statements, callnode
+
+  Revision 1.25  2003/04/22 14:33:38  peter
     * removed some notes/hints
 
   Revision 1.24  2003/01/09 21:52:38  peter