+ YES, finally the new code generator is compilable, but it doesn't run yet :(

compiler/new/cgobj.pas

@@ -50,10 +50,13 @@ unit cgobj;
           procedure g_copyvalueparas(p : psym);
 {$endif}
 
-          procedure g_entrycode(list : paasmoutput;const proc_names:tstringcontainer;make_global:boolean;
-                              stackframe:longint;
-                              var parasize:longint;var nostackframe:boolean;
-                              inlined : boolean);
+          procedure g_entrycode(list : paasmoutput;
+            const proc_names : tstringcontainer;make_global : boolean;
+            stackframe : longint;var parasize : longint;
+            var nostackframe : boolean;inlined : boolean);
+
+          procedure g_exitcode(list : paasmoutput;parasize : longint;
+            nostackframe,inlined : boolean);
 
           { string helper routines }
           procedure g_decransiref(const ref : treference);
@@ -723,6 +726,149 @@ unit cgobj;
   {$endif GDB}
     end;
 
+  procedure tcg.g_exitcode(list : paasmoutput;parasize:longint;nostackframe,inlined:boolean);
+{$ifdef GDB}
+    var
+       mangled_length : longint;
+       p : pchar;
+{$endif GDB}
+  begin
+{$ifdef dummy}
+      { !!!! insert there automatic destructors }
+      curlist:=list;
+      if aktexitlabel^.is_used then
+        list^.insert(new(pai_label,init(aktexitlabel)));
+
+      { call the destructor help procedure }
+      if (aktprocsym^.definition^.options and podestructor)<>0 then
+        begin
+          if procinfo._class^.isclass then
+            begin
+              list^.insert(new(pai386,op_csymbol(A_CALL,S_NO,
+                newcsymbol('FPC_DISPOSE_CLASS',0))));
+              concat_external('FPC_DISPOSE_CLASS',EXT_NEAR);
+            end
+          else
+            begin
+              list^.insert(new(pai386,op_csymbol(A_CALL,S_NO,
+                newcsymbol('FPC_HELP_DESTRUCTOR',0))));
+              list^.insert(new(pai386,op_const_reg(A_MOV,S_L,procinfo._class^.vmt_offset,R_EDI)));
+              concat_external('FPC_HELP_DESTRUCTOR',EXT_NEAR);
+            end;
+        end;
+
+      { finalize local data }
+      aktprocsym^.definition^.localst^.foreach(finalize_data);
+
+      { finalize paras data }
+      if assigned(aktprocsym^.definition^.parast) then
+        aktprocsym^.definition^.parast^.foreach(finalize_data);
+
+      { call __EXIT for main program }
+      if (not DLLsource) and (not inlined) and ((aktprocsym^.definition^.options and poproginit)<>0) then
+       begin
+         list^.concat(new(pai386,op_csymbol(A_CALL,S_NO,newcsymbol('FPC_DO_EXIT',0))));
+         concat_external('FPC_DO_EXIT',EXT_NEAR);
+       end;
+
+      { handle return value }
+      if (aktprocsym^.definition^.options and poassembler)=0 then
+          if (aktprocsym^.definition^.options and poconstructor)=0 then
+            handle_return_value(list,inlined)
+          else
+              begin
+                  { successful constructor deletes the zero flag }
+                  { and returns self in eax                      }
+                  list^.concat(new(pai_label,init(quickexitlabel)));
+                  { eax must be set to zero if the allocation failed !!! }
+                  list^.concat(new(pai386,op_reg_reg(A_MOV,S_L,R_ESI,R_EAX)));
+                  list^.concat(new(pai386,op_reg_reg(A_OR,S_L,R_EAX,R_EAX)));
+              end;
+
+      { stabs uses the label also ! }
+      if aktexit2label^.is_used or
+         ((cs_debuginfo in aktmoduleswitches) and not inlined) then
+        list^.concat(new(pai_label,init(aktexit2label)));
+      { gives problems for long mangled names }
+      {list^.concat(new(pai_symbol,init(aktprocsym^.definition^.mangledname+'_end')));}
+
+      { should we restore edi ? }
+      { for all i386 gcc implementations }
+      if ((aktprocsym^.definition^.options and pocdecl)<>0) then
+        begin
+          list^.insert(new(pai386,op_reg(A_POP,S_L,R_EDI)));
+          list^.insert(new(pai386,op_reg(A_POP,S_L,R_ESI)));
+          if (aktprocsym^.definition^.usedregisters and ($80 shr byte(R_EBX)))<>0 then
+           list^.insert(new(pai386,op_reg(A_POP,S_L,R_EBX)));
+          { here we could reset R_EBX
+            but that is risky because it only works
+            if genexitcode is called after genentrycode
+            so lets skip this for the moment PM
+          aktprocsym^.definition^.usedregisters:=
+            aktprocsym^.definition^.usedregisters or not ($80 shr byte(R_EBX));
+          }
+        end;
+
+      if not(nostackframe) and not inlined then
+          list^.concat(new(pai386,op_none(A_LEAVE,S_NO)));
+      { parameters are limited to 65535 bytes because }
+      { ret allows only imm16                         }
+      if (parasize>65535) and not(aktprocsym^.definition^.options and poclearstack<>0) then
+       CGMessage(cg_e_parasize_too_big);
+
+      { at last, the return is generated }
+
+      if not inlined then
+      if (aktprocsym^.definition^.options and pointerrupt)<>0 then
+          generate_interrupt_stackframe_exit
+      else
+       begin
+       {Routines with the poclearstack flag set use only a ret.}
+       { also routines with parasize=0           }
+         if (parasize=0) or (aktprocsym^.definition^.options and poclearstack<>0) then
+          list^.concat(new(pai386,op_none(A_RET,S_NO)))
+         else
+          list^.concat(new(pai386,op_const(A_RET,S_NO,parasize)));
+       end;
+
+{$ifdef GDB}
+      if (cs_debuginfo in aktmoduleswitches) and not inlined  then
+          begin
+              aktprocsym^.concatstabto(list);
+              if assigned(procinfo._class) then
+                  list^.concat(new(pai_stabs,init(strpnew(
+                   '"$t:v'+procinfo._class^.numberstring+'",'+
+                   tostr(N_PSYM)+',0,0,'+tostr(procinfo.esi_offset)))));
+
+              if (porddef(aktprocsym^.definition^.retdef) <> voiddef) then
+                if ret_in_param(aktprocsym^.definition^.retdef) then
+                  list^.concat(new(pai_stabs,init(strpnew(
+                   '"'+aktprocsym^.name+':X*'+aktprocsym^.definition^.retdef^.numberstring+'",'+
+                   tostr(N_PSYM)+',0,0,'+tostr(procinfo.retoffset)))))
+                else
+                  list^.concat(new(pai_stabs,init(strpnew(
+                   '"'+aktprocsym^.name+':X'+aktprocsym^.definition^.retdef^.numberstring+'",'+
+                   tostr(N_PSYM)+',0,0,'+tostr(procinfo.retoffset)))));
+
+              mangled_length:=length(aktprocsym^.definition^.mangledname);
+              getmem(p,mangled_length+50);
+              strpcopy(p,'192,0,0,');
+              strpcopy(strend(p),aktprocsym^.definition^.mangledname);
+              list^.concat(new(pai_stabn,init(strnew(p))));
+              {list^.concat(new(pai_stabn,init(strpnew('192,0,0,'
+               +aktprocsym^.definition^.mangledname))));
+              p[0]:='2';p[1]:='2';p[2]:='4';
+              strpcopy(strend(p),'_end');}
+              freemem(p,mangled_length+50);
+              list^.concat(new(pai_stabn,init(
+                strpnew('224,0,0,'+lab2str(aktexit2label)))));
+               { strpnew('224,0,0,'
+               +aktprocsym^.definition^.mangledname+'_end'))));}
+          end;
+{$endif GDB}
+      curlist:=nil;
+{$endif dummy}
+  end;
 {*****************************************************************************
                        some abstract definitions
  ****************************************************************************}
@@ -779,7 +925,10 @@ unit cgobj;
 end.
 {
   $Log$
-  Revision 1.3  1998-12-26 15:20:30  florian
+  Revision 1.4  1999-01-13 22:52:36  florian
+    + YES, finally the new code generator is compilable, but it doesn't run yet :(
+
+  Revision 1.3  1998/12/26 15:20:30  florian
     + more changes for the new version
 
   Revision 1.2  1998/12/15 22:18:55  florian

compiler/new/convtree.pas

@@ -0,0 +1,60 @@
+{
+    $Id$
+    Copyright (c) 1999 by Florian Klaempfl
+
+    Converts the old tree nodes into the new OOP nodest
+    This unit is necessary to interface the new code generator
+    with the old parser
+
+    This program is free software; you can redistribute it and/or modify
+    it under the terms of the GNU General Public License as published by
+    the Free Software Foundation; either version 2 of the License, or
+    (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU General Public License for more details.
+
+    You should have received a copy of the GNU General Public License
+    along with this program; if not, write to the Free Software
+    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ ****************************************************************************
+}
+unit convtree;
+
+  interface
+
+    uses
+       tree;
+
+    function convtree2node(p : ptree) : pnode;
+
+  implementation
+
+    uses
+       verbose;
+
+    function convtree2node(p : ptree) : pnode;
+
+      var
+         node : pnode;
+
+      begin
+         case p^.treetype of
+           blockn:
+             node:=new(pblocknode,init);
+           else internalerror(13751);
+         end;
+         disposetree(p);
+         convtree2node:=node;
+      end;
+
+end.
+{
+  $Log$
+  Revision 1.1  1999-01-13 22:52:37  florian
+    + YES, finally the new code generator is compilable, but it doesn't run yet :(
+
+}

compiler/new/pass_1.pas

@@ -202,7 +202,7 @@ implementation
          oldpos           : tfileposinfo;
 {$ifdef extdebug}
          str1,str2 : string;
-         oldp      : ptree;
+         oldp      : pnode;
          not_first : boolean;
 {$endif extdebug}
       begin
@@ -267,12 +267,14 @@ implementation
                 begin
                    comment(v_debug,'tree changed after first counting pass '
                      +tostr(longint(p^.treetype)));
-                   compare_trees(oldp,p);
+                   {!!!!!!! compare_trees(oldp,p); }
                 end;
               dispose(oldp);
            end;
+         {!!!!!!!
          if count_ref then
            inc(p^.firstpasscount);
+         }
 {$endif extdebug}
       end;
 
@@ -296,7 +298,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.1  1998-12-26 15:20:31  florian
+  Revision 1.2  1999-01-13 22:52:37  florian
+    + YES, finally the new code generator is compilable, but it doesn't run yet :(
+
+  Revision 1.1  1998/12/26 15:20:31  florian
     + more changes for the new version
 
 }

compiler/new/psub.pas

@@ -48,7 +48,8 @@ uses
   strings,globals,verbose,comphook,files,
   scanner,aasm,tree,types,
   import,gendef,
-  hcodegen,temp_gen,pass_1,pass_2
+  convtree,
+  hcodegen,temp_gen,pass_1,pass_2,cgobj
 {$ifdef GDB}
   ,gdb
 {$endif GDB}
@@ -79,11 +80,10 @@ var
   filepos : tfileposinfo;
   p       : Pdef;
   vs      : Pvarsym;
-{$ifdef VALUEPARA}
   l       : longint;
-{$endif}
   hs1,hs2 : string;
   varspez : Tvarspez;
+
 begin
   consume(LKLAMMER);
   inc(testcurobject);
@@ -152,7 +152,7 @@ begin
      end
     else
      begin
-{$ifndef UseNiceNames}
+{$ifdef NoNiceNames}
        hs1:='$$$';
 {$else UseNiceNames}
        hs1:='var';
@@ -164,7 +164,7 @@ begin
      begin
        s:=sc^.get_with_tokeninfo(filepos);
        aktprocsym^.definition^.concatdef(p,varspez);
-{$ifndef UseNiceNames}
+{$ifdef NoNiceNames}
        hs2:=hs2+'$'+hs1;
 {$else UseNiceNames}
        hs2:=hs2+tostr(length(hs1))+hs1;
@@ -173,18 +173,6 @@ begin
        vs^.fileinfo:=filepos;
        vs^.varspez:=varspez;
      { we have to add this to avoid var param to be in registers !!!}
-{$ifndef VALUEPARA}
-       if (varspez in [vs_var,vs_const]) and dont_copy_const_param(p) then
-         vs^.var_options := vs^.var_options or vo_regable;
-     { search for duplicate ids in object members/methods    }
-     { but only the current class, I don't know why ...      }
-     { at least TP and Delphi do it in that way         (FK) }
-       if assigned(procinfo._class) and (lexlevel=normal_function_level) and
-          (procinfo._class^.publicsyms^.search(vs^.name)<>nil) then
-      {   (search_class_member(procinfo._class,vs^.name)<>nil) then }
-         Message1(sym_e_duplicate_id,vs^.name);
-       aktprocsym^.definition^.parast^.insert(vs);
-{$else}
        if (varspez in [vs_var,vs_const]) and push_addr_param(p) then
          vs^.var_options := vs^.var_options or vo_regable;
 
@@ -212,7 +200,6 @@ begin
          end
        else
          aktprocsym^.definition^.parast^.insert(vs);
-{$endif}
      end;
     dispose(sc,done);
     aktprocsym^.definition^.setmangledname(hs2);
@@ -1047,8 +1034,8 @@ begin
     end;
 end;
 
-procedure compile_proc_body(const proc_names:Tstringcontainer;
-                            make_global,parent_has_class:boolean);
+procedure compile_proc_body(const proc_names : tstringcontainer;
+                            make_global,parent_has_class : boolean);
 {
   Compile the body of a procedure
 }
@@ -1058,13 +1045,13 @@ var
    { switches can change inside the procedure }
    entryswitches, exitswitches : tlocalswitches;
    { code for the subroutine as tree }
-   code:ptree;
+   code : pnode;
    { size of the local strackframe }
-   stackframe:longint;
+   stackframe : longint;
    { true when no stackframe is required }
-   nostackframe:boolean;
+   nostackframe : boolean;
    { number of bytes which have to be cleared by RET }
-   parasize:longint;
+   parasize : longint;
    { filepositions }
    entrypos,
    savepos,
@@ -1131,9 +1118,10 @@ begin
 
    { parse the code ... }
    if (aktprocsym^.definition^.options and poassembler)<> 0 then
-     code:=assembler_block
+     code:=convtree2node(assembler_block)
    else
-     code:=block(current_module^.islibrary);
+     code:=convtree2node(block(current_module^.islibrary));
+
 
    { get a better entry point }
    if assigned(code) then
@@ -1181,14 +1169,14 @@ begin
    aktfilepos:=entrypos;
    aktlocalswitches:=entryswitches;
    if assigned(code) then
-     genentrycode(procinfo.aktentrycode,proc_names,make_global,stackframe,parasize,nostackframe,false);
+     cg^.g_entrycode(procinfo.aktentrycode,proc_names,make_global,stackframe,parasize,nostackframe,false);
 
    { now generate exit code with the correct position and switches }
    aktfilepos:=exitpos;
    aktlocalswitches:=exitswitches;
    if assigned(code) then
      begin
-       genexitcode(procinfo.aktexitcode,parasize,nostackframe,false);
+       cg^.g_exitcode(procinfo.aktexitcode,parasize,nostackframe,false);
        procinfo.aktproccode^.insertlist(procinfo.aktentrycode);
        procinfo.aktproccode^.concatlist(procinfo.aktexitcode);
 {$ifdef i386}
@@ -1259,7 +1247,7 @@ begin
 
     { remove code tree, if not inline procedure }
     if assigned(code) and ((aktprocsym^.definition^.options and poinline)=0) then
-      disposetree(code);
+      dispose(code,done);
 
    { remove class member symbol tables }
    while symtablestack^.symtabletype=objectsymtable do
@@ -1460,7 +1448,10 @@ end.
 
 {
   $Log$
-  Revision 1.1  1998-12-26 15:20:31  florian
+  Revision 1.2  1999-01-13 22:52:39  florian
+    + YES, finally the new code generator is compilable, but it doesn't run yet :(
+
+  Revision 1.1  1998/12/26 15:20:31  florian
     + more changes for the new version
 
 }

compiler/new/tree.pas

@@ -199,6 +199,12 @@ unit tree;
             the node }
           procedure det_temp;virtual;
           procedure secondpass;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;virtual;
+{$endif EXTDEBUG}
        end;
 
        ploadnode = ^tloadnode;
@@ -237,9 +243,9 @@ unit tree;
           resulttype : pdef;
           fileinfo : tfileposinfo;
           localswitches : tlocalswitches;
-{$ifdef extdebug}
+{$ifdef EXTDEBUG}
           firstpasscount : longint;
-{$endif extdebug}
+{$endif EXTDEBUG}
           case treetype : ttreetyp of
              addn : (use_strconcat : boolean;string_typ : tstringtype);
              callparan : (is_colon_para : boolean;exact_match_found : boolean);
@@ -275,6 +281,7 @@ unit tree;
           punarynode = ^tunarynode;
           tunarynode = object(tnode)
              left : pnode;
+             procedure dowrite;virtual;
           end;
 
           pbinarynode = ^tbinarynode;
@@ -289,6 +296,11 @@ unit tree;
              swaped : boolean;
           end;
 
+          pblocknode = ^tblocknode;
+          tblocknode = object(tunarynode)
+            constructor init;
+          end;
+
 {$ifdef dummy}
           case treetype : ttreetyp of
              addn : (use_strconcat : boolean;string_typ : tstringtype);
@@ -363,11 +375,14 @@ unit tree;
     function getnode : ptree;
     procedure set_file_line(from,_to : ptree);
     procedure set_tree_filepos(p : ptree;const filepos : tfileposinfo);
-{$ifdef extdebug}
+{$ifdef EXTDEBUG}
     procedure compare_trees(oldp,p : ptree);
     const
        maxfirstpasscount : longint = 0;
-{$endif extdebug}
+
+    { writes a complete tree, checks for nil }
+    procedure writenode(n : pnode);
+{$endif EXTDEBUG}
 
     { sets the callunique flag, if the node is a vecn, }
     { takes care of type casts etc.                    }
@@ -394,6 +409,20 @@ unit tree;
        systems,
        globals,verbose,files,types;
 
+{$ifdef EXTDEBUG}
+
+    const
+       indention : string = '';
+
+    procedure writenode(n : pnode);
+
+      begin
+         if assigned(n) then
+           n^.dowrite
+         else
+           writeln(indention,'nil');
+      end;
+{$endif EXTDEBUG}
 {****************************************************************************
                                  TNODE
  ****************************************************************************}
@@ -422,10 +451,10 @@ unit tree;
          if (location.loc in [LOC_MEM,LOC_REFERENCE]) and
             assigned(location.reference.symbol) then
            stringdispose(location.reference.symbol);
-{$ifdef extdebug}
+{$ifdef EXTDEBUG}
          if firstpasscount>maxfirstpasscount then
             maxfirstpasscount:=firstpasscount;
-{$endif extdebug}
+{$endif EXTDEBUG}
       end;
 
     procedure tnode.pass_1;
@@ -453,6 +482,95 @@ unit tree;
          abstract;
       end;
 
+{$ifdef EXTDEBUG}
+    procedure tnode.dowrite;
+
+      const treetype2str : array[ttreetyp] of string[20] = (
+          'addn',
+          'muln',
+          'subn',
+          'divn',
+          'symdifn',
+          'modn',
+          'assignn',
+          'loadn',
+          'rangen',
+          'ltn',
+          'lten',
+          'gtn',
+          'gten',
+          'equaln',
+          'unequaln',
+          'inn',
+          'orn',
+          'xorn',
+          'shrn',
+          'shln',
+          'slashn',
+          'andn',
+          'subscriptn',
+          'derefn',
+          'addrn',
+          'doubleaddrn',
+          'ordconstn',
+          'typeconvn',
+          'calln',
+          'callparan',
+          'realconstn',
+          'fixconstn',
+          'umminusn',
+          'asmn',
+          'vecn',
+          'stringconstn',
+          'funcretn',
+          'selfn',
+          'notn',
+          'inlinen',
+          'niln',
+          'errorn',
+          'typen',
+          'hnewn',
+          'hdisposen',
+          'newn',
+          'simpledisposen',
+          'setelementn',
+          'setconstn',
+          'blockn',
+          'statementn',
+          'loopn',
+          'ifn',
+          'breakn',
+          'continuen',
+          'repeatn',
+          'whilen',
+          'forn',
+          'exitn',
+          'withn',
+          'casen',
+          'labeln',
+          'goton',
+          'simplenewn',
+          'tryexceptn',
+          'raisen',
+          'switchesn',
+          'tryfinallyn',
+          'onn',
+          'isn',
+          'asn',
+          'caretn',
+          'failn',
+          'starstarn',
+          'procinlinen',
+          'arrayconstructn',
+          'arrayconstructrangen',
+          'nothingn',
+          'loadvmtn');
+
+      begin
+         write(indention,'(',treetype2str[treetype]);
+      end;
+{$endif EXTDEBUG}
+
 {****************************************************************************
                                  TLOADNODE
  ****************************************************************************}
@@ -483,6 +601,31 @@ unit tree;
          { !!!!! dispose(left,done); }
       end;
 
+{****************************************************************************
+                                 TUNARYNODE
+ ****************************************************************************}
+
+    procedure tunarynode.dowrite;
+
+      begin
+         inherited dowrite;
+         writeln(',');
+         writenode(left);
+         writeln(')');
+         dec(byte(indention[0]),2);
+      end;
+
+{****************************************************************************
+                                 TBLOCKNODE
+ ****************************************************************************}
+
+    constructor tblocknode.init;
+
+      begin
+         inherited init;
+         treetype:=blockn;
+      end;
+
 {$ifdef dummy}
          { clean up the contents of a node }
          case p^.treetype of
@@ -1775,7 +1918,10 @@ unit tree;
 end.
 {
   $Log$
-  Revision 1.2  1998-12-26 15:20:32  florian
+  Revision 1.3  1999-01-13 22:52:40  florian
+    + YES, finally the new code generator is compilable, but it doesn't run yet :(
+
+  Revision 1.2  1998/12/26 15:20:32  florian
     + more changes for the new version
 
   Revision 1.1  1998/12/15 22:21:53  florian