* moehrendorf oct 2000 rewrite

compiler/cobjects.pas

@@ -246,7 +246,7 @@ interface
          pos,
          used : longint;
          next : pdynamicblock;
-         data : array[0..1] of byte;
+         data : array[0..high(longint)-20] of byte;
        end;
 
        pdynamicarray = ^tdynamicarray;
@@ -1843,7 +1843,10 @@ end;
 end.
 {
   $Log$
-  Revision 1.14  2000-09-24 21:19:50  peter
+  Revision 1.15  2000-10-14 10:14:46  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.14  2000/09/24 21:19:50  peter
     * delphi compile fixes
 
   Revision 1.13  2000/09/24 15:06:12  peter

compiler/compiler.pas

@@ -89,7 +89,11 @@ uses
 {$endif Delphi}
   verbose,comphook,systems,
   cutils,cobjects,globals,options,fmodule,parser,symtable,
-  link,import,export,tokens;
+  link,import,export,tokens,
+{$ifdef i386}
+  n386
+{$endif i386}
+  ;
 
 function Compile(const cmd:string):longint;
 
@@ -308,7 +312,10 @@ end;
 end.
 {
   $Log$
-  Revision 1.7  2000-10-08 10:26:33  peter
+  Revision 1.8  2000-10-14 10:14:46  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.7  2000/10/08 10:26:33  peter
     * merged @result fix from Pierre
 
   Revision 1.6  2000/09/24 15:06:14  peter

compiler/daopt386.pas

@@ -1250,8 +1250,6 @@ Procedure DestroyReg(p1: PPaiProp; Reg: TRegister; doIncState:Boolean);
  it's contents are directly modified/overwritten, but because of an indirect
  action (e.g. this register holds the contents of a variable and the value
  of the variable in memory is changed) }
-Var TmpWState, TmpRState: Byte;
-    Counter: TRegister;
 Begin
   Reg := Reg32(Reg);
   { the following happens for fpu registers }
@@ -2359,7 +2357,10 @@ End.
 
 {
   $Log$
-  Revision 1.15  2000-09-30 13:07:23  jonas
+  Revision 1.16  2000-10-14 10:14:47  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.15  2000/09/30 13:07:23  jonas
     * fixed support for -Or with new features of CSE
 
   Revision 1.14  2000/09/29 23:14:11  jonas
@@ -2425,4 +2426,4 @@ End.
   Revision 1.2  2000/07/13 11:32:40  michael
   + removed logs
 
-}
+}

compiler/hcgdata.pas

@@ -648,6 +648,31 @@ implementation
            end;
       end;
 
+     procedure disposevmttree;
+
+       var
+          symcoll : psymcoll;
+          procdefcoll : pprocdefcoll;
+
+       begin
+          { disposes the above generated tree }
+          symcoll:=wurzel;
+          while assigned(symcoll) do
+            begin
+               wurzel:=symcoll^.next;
+               stringdispose(symcoll^.name);
+               procdefcoll:=symcoll^.data;
+               while assigned(procdefcoll) do
+                 begin
+                    symcoll^.data:=procdefcoll^.next;
+                    dispose(procdefcoll);
+                    procdefcoll:=symcoll^.data;
+                 end;
+               dispose(symcoll);
+               symcoll:=wurzel;
+            end;
+       end;
+
     procedure genvmt(list : paasmoutput;_class : pobjectdef);
 
       procedure do_genvmt(p : pobjectdef);
@@ -729,28 +754,295 @@ implementation
                    symcoll:=symcoll^.next;
                 end;
            end;
-         { disposes the above generated tree }
-         symcoll:=wurzel;
-         while assigned(symcoll) do
-           begin
-              wurzel:=symcoll^.next;
-              stringdispose(symcoll^.name);
-              procdefcoll:=symcoll^.data;
-              while assigned(procdefcoll) do
-                begin
-                   symcoll^.data:=procdefcoll^.next;
-                   dispose(procdefcoll);
-                   procdefcoll:=symcoll^.data;
-                end;
-              dispose(symcoll);
-              symcoll:=wurzel;
-           end;
+         disposevmttree;
+      end;
+
+{$ifdef SUPPORT_INTERFACES}
+
+    function  gintfgetvtbllabelname(_class: pobjectdef; intfindex: integer): string;
+      begin
+        gintfgetvtbllabelname:='_$$_'+_class^.objname^+'_$$_'+
+          _class^.implementedinterfaces^.interfaces(intfindex)^.objname^+'_$$_VTBL';
+      end;
+
+    procedure gintfcreatevtbl(_class: pobjectdef; intfindex: integer; rawdata: paasmoutput);
+      var
+        implintf: pimplementedinterfaces;
+        curintf: pobjectdef;
+        count: integer;
+        tmps: string;
+        i: longint;
+      begin
+        implintf:=_class^.implementedinterfaces;
+        curintf:=implintf^.interfaces(intfindex);
+        rawdata^.concat(new(pai_symbol,initname(gintfgetvtbllabelname(_class,intfindex),0)));
+        count:=implintf^.implproccount(intfindex);
+        for i:=1 to count do
+          begin
+            tmps:=implintf^.implprocs(intfindex,i)^.mangledname+'_$$_'+curintf^.objname^;
+            { create wrapper code }
+            cgintfwrapper(implintf^.implprocs(intfindex,i),tmps,implintf^.ioffsets(intfindex)^);
+            { create reference }
+            rawdata^.concat(new(pai_const_symbol,initname(tmps)));
+          end;
+      end;
+
+    procedure gintfgenentry(_class: pobjectdef; intfindex, contintfindex: integer; rawdata: paasmoutput);
+      var
+        implintf: pimplementedinterfaces;
+        curintf: pobjectdef;
+        tmplabel: pasmlabel;
+        i: longint;
+      begin
+        implintf:=_class^.implementedinterfaces;
+        curintf:=implintf^.interfaces(intfindex);
+        { GUID }
+        if curintf^.objecttype in [odt_interfacecom] then
+          begin
+            { label for GUID }
+            getdatalabel(tmplabel);
+            rawdata^.concat(new(pai_label,init(tmplabel)));
+            rawdata^.concat(new(pai_const,init_32bit(curintf^.iidguid.D1)));
+            rawdata^.concat(new(pai_const,init_16bit(curintf^.iidguid.D2)));
+            rawdata^.concat(new(pai_const,init_16bit(curintf^.iidguid.D3)));
+            for i:=Low(curintf^.iidguid.D4) to High(curintf^.iidguid.D4) do
+              rawdata^.concat(new(pai_const,init_8bit(curintf^.iidguid.D4[i])));
+            datasegment^.concat(new(pai_const_symbol,init(tmplabel)));
+          end
+        else
+          begin
+            { nil for Corba interfaces }
+            datasegment^.concat(new(pai_const,init_32bit(0))); { nil }
+          end;
+        { VTable }
+        datasegment^.concat(new(pai_const_symbol,initname(gintfgetvtbllabelname(_class,contintfindex))));
+        { IOffset field }
+        datasegment^.concat(new(pai_const,init_32bit(implintf^.ioffsets(contintfindex)^)));
+        { IIDStr }
+        getdatalabel(tmplabel);
+        rawdata^.concat(new(pai_label,init(tmplabel)));
+        rawdata^.concat(new(pai_const,init_8bit(length(curintf^.iidstr^))));
+        if curintf^.objecttype=odt_interfacecom then
+          rawdata^.concat(new(pai_string,init(upper(curintf^.iidstr^))))
+        else
+          rawdata^.concat(new(pai_string,init(curintf^.iidstr^)));
+        datasegment^.concat(new(pai_const_symbol,init(tmplabel)));
+      end;
+
+    procedure gintfoptimizevtbls(_class: pobjectdef; var implvtbl: tlongintarr);
+      type
+        tcompintfentry = record
+          weight: longint;
+          compintf: longint;
+        end;
+        { Max 1000 interface in the class header interfaces it's enough imho }
+        tcompintfs = {$ifndef tp} packed {$endif} array[1..1000] of tcompintfentry;
+        pcompintfs = ^tcompintfs;
+        tequals    = {$ifndef tp} packed {$endif} array[1..1000] of longint;
+        pequals    = ^tequals;
+      var
+        max: longint;
+        equals: pequals;
+        compats: pcompintfs;
+        i: longint;
+        j: longint;
+        w: longint;
+        cij: boolean;
+        cji: boolean;
+      begin
+        max:=_class^.implementedinterfaces^.count;
+        if max>High(tequals) then
+          Internalerror(200006135);
+        getmem(compats,sizeof(tcompintfentry)*max);
+        getmem(equals,sizeof(longint)*max);
+        fillchar(compats^,sizeof(tcompintfentry)*max,0);
+        fillchar(equals^,sizeof(longint)*max,0);
+        { ismergepossible is a containing relation
+          meaning of ismergepossible(a,b,w) =
+          if implementorfunction map of a is contained implementorfunction map of b
+          imp(a,b) and imp(b,c) => imp(a,c) ; imp(a,b) and imp(b,a) => a == b
+        }
+        { the order is very important for correct allocation }
+        for i:=1 to max do
+          begin
+            for j:=i+1 to max do
+              begin
+                cij:=_class^.implementedinterfaces^.isimplmergepossible(i,j,w);
+                cji:=_class^.implementedinterfaces^.isimplmergepossible(j,i,w);
+                if cij and cji then { i equal j }
+                  begin
+                    { get minimum index of equal }
+                    if equals^[j]=0 then
+                      equals^[j]:=i;
+                  end
+                else if cij then
+                  begin
+                    { get minimum index of maximum weight  }
+                    if compats^[i].weight<w then
+                      begin
+                        compats^[i].weight:=w;
+                        compats^[i].compintf:=j;
+                      end;
+                  end
+                else if cji then
+                  begin
+                    { get minimum index of maximum weight  }
+                    if (compats^[j].weight<w) then
+                      begin
+                        compats^[j].weight:=w;
+                        compats^[j].compintf:=i;
+                      end;
+                  end;
+              end;
+          end;
+        for i:=1 to max do
+          begin
+            if compats^[i].compintf<>0 then
+              implvtbl[i]:=compats^[i].compintf
+            else if equals^[i]<>0 then
+              implvtbl[i]:=equals^[i]
+            else
+              implvtbl[i]:=i;
+          end;
+        freemem(compats,sizeof(tcompintfentry)*max);
+        freemem(equals,sizeof(longint)*max);
+      end;
+
+    procedure gintfwritedata(_class: pobjectdef);
+      var
+        rawdata: taasmoutput;
+        impintfindexes: plongintarr;
+        max: longint;
+        i: longint;
+      begin
+        max:=_class^.implementedinterfaces^.count;
+        getmem(impintfindexes,(max+1)*sizeof(longint));
+
+        gintfoptimizevtbls(_class,impintfindexes^);
+
+        rawdata.init;
+        datasegment^.concat(new(pai_const,init_16bit(max)));
+        { Two pass, one for allocation and vtbl creation }
+        for i:=1 to max do
+          begin
+            if impintfindexes^[i]=i then { if implement itself }
+              begin
+                { allocate a pointer in the object memory }
+                with _class^.symtable^ do
+                  begin
+                    if (alignment>=target_os.size_of_pointer) then
+                      datasize:=align(datasize,alignment)
+                    else
+                      datasize:=align(datasize,target_os.size_of_pointer);
+                    _class^.implementedinterfaces^.ioffsets(i)^:=datasize;
+                    datasize:=datasize+target_os.size_of_pointer;
+                  end;
+                { write vtbl }
+                gintfcreatevtbl(_class,i,@rawdata);
+              end;
+          end;
+        { second pass: for fill interfacetable and remained ioffsets }
+        for i:=1 to max do
+          begin
+            if i<>impintfindexes^[i] then { why execute x:=x ? }
+              with _class^.implementedinterfaces^ do ioffsets(i)^:=ioffsets(impintfindexes^[i])^;
+            gintfgenentry(_class,i,impintfindexes^[i],@rawdata);
+          end;
+        datasegment^.insertlist(@rawdata);
+        rawdata.done;
+        freemem(impintfindexes,(max+1)*sizeof(longint));
       end;
 
+    function gintfgetcprocdef(_class: pobjectdef; proc: pprocdef;const name: string): pprocdef;
+      var
+        sym: pprocsym;
+        implprocdef: pprocdef;
+      begin
+        implprocdef:=nil;
+        sym:=pprocsym(search_class_member(_class,name));
+        if assigned(sym) and (sym^.typ=procsym) and not (sp_private in sym^.symoptions) then
+          begin
+            implprocdef:=sym^.definition;
+            while assigned(implprocdef) and not equal_paras(proc^.para,implprocdef^.para,false) and
+                  (proc^.proccalloptions<>implprocdef^.proccalloptions) do
+              implprocdef:=implprocdef^.nextoverloaded;
+          end;
+        gintfgetcprocdef:=implprocdef;
+      end;
+
+    procedure gintfdoonintf(intf, _class: pobjectdef; intfindex: longint);
+      var
+        i: longint;
+        proc: pprocdef;
+        procname: string; { for error }
+        mappedname: string;
+        nextexist: pointer;
+        implprocdef: pprocdef;
+      begin
+        for i:=1 to intf^.symtable^.defindex^.count do
+          begin
+            proc:=pprocdef(intf^.symtable^.defindex^.search(i));
+            if proc^.deftype=procdef then
+              begin
+                procname:='';
+                implprocdef:=nil;
+                nextexist:=nil;
+                repeat
+                  mappedname:=_class^.implementedinterfaces^.getmappings(intfindex,proc^.procsym^.name,nextexist);
+                  if procname='' then
+                    procname:=mappedname; { for error messages }
+                  if mappedname<>'' then
+                    implprocdef:=gintfgetcprocdef(_class,proc,mappedname);
+                until assigned(implprocdef) or not assigned(nextexist);
+                if not assigned(implprocdef) then
+                  implprocdef:=gintfgetcprocdef(_class,proc,proc^.procsym^.name);
+                if procname='' then
+                  procname:=proc^.procsym^.name;
+                if assigned(implprocdef) then
+                  _class^.implementedinterfaces^.addimplproc(intfindex,implprocdef)
+                else
+                  Message1(sym_e_id_not_found,procname);
+              end;
+          end;
+      end;
+
+    procedure gintfwalkdowninterface(intf, _class: pobjectdef; intfindex: longint);
+      begin
+        if assigned(intf^.childof) then
+          gintfwalkdowninterface(intf^.childof,_class,intfindex);
+        gintfdoonintf(intf,_class,intfindex);
+      end;
+
+    function genintftable(_class: pobjectdef): pasmlabel;
+      var
+        intfindex: longint;
+        curintf: pobjectdef;
+        intftable: pasmlabel;
+      begin
+        { 1. step collect implementor functions into the implementedinterfaces^.implprocs }
+        for intfindex:=1 to _class^.implementedinterfaces^.count do
+          begin
+            curintf:=_class^.implementedinterfaces^.interfaces(intfindex);
+            gintfwalkdowninterface(curintf,_class,intfindex);
+          end;
+        { 2. step calc required fieldcount and their offsets in the object memory map
+             and write data }
+        getdatalabel(intftable);
+        datasegment^.concat(new(pai_label,init(intftable)));
+        gintfwritedata(_class);
+        _class^.implementedinterfaces^.clearimplprocs; { release temporary information }
+        genintftable:=intftable;
+      end;
+
+{$endif SUPPORT_INTERFACES}
+
 end.
 {
   $Log$
-  Revision 1.6  2000-09-24 21:19:50  peter
+  Revision 1.7  2000-10-14 10:14:47  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.6  2000/09/24 21:19:50  peter
     * delphi compile fixes
 
   Revision 1.5  2000/09/24 15:06:17  peter
@@ -766,4 +1058,4 @@ end.
   Revision 1.2  2000/07/13 11:32:41  michael
   + removed logs
 
-}
+}

compiler/htypechk.pas

@@ -28,25 +28,14 @@ interface
 
     uses
       tokens,
-{$ifdef cg11}
       node,
-{$else cg11}
-      tree,
-{$endif cg11}
       symtable;
 
     type
-{$ifdef cg11}
       Ttok2nodeRec=record
         tok : ttoken;
         nod : tnodetype;
         op_overloading_supported : boolean;
-{$else cg11}
-      Ttok2nodeRec=record
-        tok : ttoken;
-        nod : ttreetyp;
-        op_overloading_supported : boolean;
-{$endif cg11}
       end;
 
     const
@@ -86,7 +75,6 @@ interface
        get_para_resulttype : boolean = false;
        allow_array_constructor : boolean = false;
 
-{$ifdef cg11}
     { is overloading of this operator allowed for this
       binary operator }
     function isbinaryoperatoroverloadable(ld, rd,dd : pdef;
@@ -129,56 +117,7 @@ interface
     { sets varsym varstate field correctly }
     procedure unset_varstate(p : tnode);
     procedure set_varstate(p : tnode;must_be_valid : boolean);
-{$else cg11}
-    { Conversion }
-    function isconvertable(def_from,def_to : pdef;
-             var doconv : tconverttype;fromtreetype : ttreetyp;
-             explicit : boolean) : byte;
-    { is overloading of this operator allowed for this
-      binary operator }
-    function isbinaryoperatoroverloadable(ld, rd,dd : pdef;
-             treetyp : ttreetyp) : boolean;
-
-    { is overloading of this operator allowed for this
-      unary operator }
-    function isunaryoperatoroverloadable(rd,dd : pdef;
-             treetyp : ttreetyp) : boolean;
-
-    { check operator args and result type }
-    function isoperatoracceptable(pf : pprocdef; optoken : ttoken) : boolean;
-
-    { Register Allocation }
-    procedure make_not_regable(p : ptree);
-    procedure left_right_max(p : ptree);
-    procedure calcregisters(p : ptree;r32,fpu,mmx : word);
-
-    { subroutine handling }
-    procedure test_protected_sym(sym : psym);
-    procedure test_protected(p : ptree);
-    function  valid_for_formal_var(p : ptree) : boolean;
-    function  valid_for_formal_const(p : ptree) : boolean;
-    function  is_procsym_load(p:Ptree):boolean;
-    function  is_procsym_call(p:Ptree):boolean;
-    function  assignment_overloaded(from_def,to_def : pdef) : pprocdef;
-    procedure test_local_to_procvar(from_def:pprocvardef;to_def:pdef);
-    function  valid_for_assign(p:ptree;allowprop:boolean):boolean;
-    { sets the callunique flag, if the node is a vecn, }
-    { takes care of type casts etc.                 }
-    procedure set_unique(p : ptree);
-
-    { sets funcret_is_valid to true, if p contains a funcref node }
-    procedure set_funcret_is_valid(p : ptree);
-
-    {
-    type
-    tvarstaterequire = (vsr_can_be_undefined,vsr_must_be_valid,
-      vsr_is_used_after,vsr_must_be_valid_and_is_used_after); }
 
-    { sets varsym varstate field correctly }
-    procedure unset_varstate(p : ptree);
-    procedure set_varstate(p : ptree;must_be_valid : boolean);
-
-{$endif cg11}
 
 implementation
 
@@ -187,10 +126,8 @@ implementation
        cutils,cobjects,verbose,globals,
        symconst,
        types,pass_1,cpubase,
-{$ifdef cg11}
        ncnv,nld,
        nmem,ncal,nmat,
-{$endif cg11}
 {$ifdef newcg}
        cgbase
 {$else}
@@ -198,7 +135,6 @@ implementation
 {$endif}
        ;
 
-{$ifdef cg11}
     { ld is the left type definition
       rd the right type definition
       dd the result type definition  or voiddef if unkown }
@@ -950,1194 +886,13 @@ implementation
          end;
       end;
 
+end.
+{
+  $Log$
+  Revision 1.12  2000-10-14 10:14:47  peter
+    * moehrendorf oct 2000 rewrite
 
-{$else cg11}
-{****************************************************************************
-                             Convert
-****************************************************************************}
-
-   { Returns:
-       0 - Not convertable
-       1 - Convertable
-       2 - Convertable, but not first choice }
-    function isconvertable(def_from,def_to : pdef;
-             var doconv : tconverttype;fromtreetype : ttreetyp;
-             explicit : boolean) : byte;
-
-      { Tbasetype:  uauto,uvoid,uchar,
-                    u8bit,u16bit,u32bit,
-                    s8bit,s16bit,s32,
-                    bool8bit,bool16bit,bool32bit,
-                    u64bit,s64bitint }
-      type
-        tbasedef=(bvoid,bchar,bint,bbool);
-      const
-        basedeftbl:array[tbasetype] of tbasedef =
-          (bvoid,bvoid,bchar,
-           bint,bint,bint,
-           bint,bint,bint,
-           bbool,bbool,bbool,bint,bint,bchar);
-
-        basedefconverts : array[tbasedef,tbasedef] of tconverttype =
-         ((tc_not_possible,tc_not_possible,tc_not_possible,tc_not_possible),
-          (tc_not_possible,tc_equal,tc_not_possible,tc_not_possible),
-          (tc_not_possible,tc_not_possible,tc_int_2_int,tc_int_2_bool),
-          (tc_not_possible,tc_not_possible,tc_bool_2_int,tc_bool_2_bool));
-
-      var
-         b : byte;
-         hd1,hd2 : pdef;
-         hct : tconverttype;
-      begin
-       { safety check }
-         if not(assigned(def_from) and assigned(def_to)) then
-          begin
-            isconvertable:=0;
-            exit;
-          end;
-
-       { tp7 procvar def support, in tp7 a procvar is always called, if the
-         procvar is passed explicit a addrn would be there }
-         if (m_tp_procvar in aktmodeswitches) and
-            (def_from^.deftype=procvardef) and
-            (fromtreetype=loadn) then
-          begin
-            def_from:=pprocvardef(def_from)^.rettype.def;
-          end;
-
-       { we walk the wanted (def_to) types and check then the def_from
-         types if there is a conversion possible }
-         b:=0;
-         case def_to^.deftype of
-           orddef :
-             begin
-               case def_from^.deftype of
-                 orddef :
-                   begin
-                     doconv:=basedefconverts[basedeftbl[porddef(def_from)^.typ],basedeftbl[porddef(def_to)^.typ]];
-                     b:=1;
-                     if (doconv=tc_not_possible) or
-                        ((doconv=tc_int_2_bool) and
-                         (not explicit) and
-                         (not is_boolean(def_from))) or
-                        ((doconv=tc_bool_2_int) and
-                         (not explicit) and
-                         (not is_boolean(def_to))) then
-                       b:=0;
-                   end;
-                 enumdef :
-                   begin
-                     { needed for char(enum) }
-                     if explicit then
-                      begin
-                        doconv:=tc_int_2_int;
-                        b:=1;
-                      end;
-                   end;
-               end;
-             end;
-
-          stringdef :
-             begin
-               case def_from^.deftype of
-                 stringdef :
-                   begin
-                     doconv:=tc_string_2_string;
-                     b:=1;
-                   end;
-                 orddef :
-                   begin
-                   { char to string}
-                     if is_char(def_from) then
-                      begin
-                        doconv:=tc_char_2_string;
-                        b:=1;
-                      end;
-                   end;
-                 arraydef :
-                   begin
-                   { array of char to string, the length check is done by the firstpass of this node }
-                     if is_chararray(def_from) then
-                      begin
-                        doconv:=tc_chararray_2_string;
-                        if (not(cs_ansistrings in aktlocalswitches) and
-                            is_shortstring(def_to)) or
-                           ((cs_ansistrings in aktlocalswitches) and
-                            is_ansistring(def_to)) then
-                         b:=1
-                        else
-                         b:=2;
-                      end;
-                   end;
-                 pointerdef :
-                   begin
-                   { pchar can be assigned to short/ansistrings,
-                     but not in tp7 compatible mode }
-                     if is_pchar(def_from) and not(m_tp7 in aktmodeswitches) then
-                      begin
-                        doconv:=tc_pchar_2_string;
-                        b:=1;
-                      end;
-                   end;
-               end;
-             end;
-
-           floatdef :
-             begin
-               case def_from^.deftype of
-                 orddef :
-                   begin { ordinal to real }
-                     if is_integer(def_from) then
-                       begin
-                          if pfloatdef(def_to)^.typ=f32bit then
-                            doconv:=tc_int_2_fix
-                          else
-                            doconv:=tc_int_2_real;
-                          b:=1;
-                       end;
-                   end;
-                 floatdef :
-                   begin { 2 float types ? }
-                     if pfloatdef(def_from)^.typ=pfloatdef(def_to)^.typ then
-                       doconv:=tc_equal
-                     else
-                       begin
-                          if pfloatdef(def_from)^.typ=f32bit then
-                            doconv:=tc_fix_2_real
-                          else
-                            if pfloatdef(def_to)^.typ=f32bit then
-                              doconv:=tc_real_2_fix
-                            else
-                              doconv:=tc_real_2_real;
-                       end;
-                     b:=1;
-                   end;
-               end;
-             end;
-
-           enumdef :
-             begin
-               if (def_from^.deftype=enumdef) then
-                begin
-                  hd1:=def_from;
-                  while assigned(penumdef(hd1)^.basedef) do
-                   hd1:=penumdef(hd1)^.basedef;
-                  hd2:=def_to;
-                  while assigned(penumdef(hd2)^.basedef) do
-                    hd2:=penumdef(hd2)^.basedef;
-                  if (hd1=hd2) then
-                    begin
-                       b:=1;
-                       { because of packenum they can have different sizes! (JM) }
-                       doconv:=tc_int_2_int;
-                    end;
-                end;
-             end;
-
-           arraydef :
-             begin
-             { open array is also compatible with a single element of its base type }
-               if is_open_array(def_to) and
-                  is_equal(parraydef(def_to)^.elementtype.def,def_from) then
-                begin
-                  doconv:=tc_equal;
-                  b:=1;
-                end
-               else
-                begin
-                  case def_from^.deftype of
-                    arraydef :
-                      begin
-                        { array constructor -> open array }
-                        if is_open_array(def_to) and
-                           is_array_constructor(def_from) then
-                         begin
-                           if is_void(parraydef(def_from)^.elementtype.def) or
-                              is_equal(parraydef(def_to)^.elementtype.def,parraydef(def_from)^.elementtype.def) then
-                            begin
-                              doconv:=tc_equal;
-                              b:=1;
-                            end
-                           else
-                            if isconvertable(parraydef(def_from)^.elementtype.def,
-                                             parraydef(def_to)^.elementtype.def,hct,arrayconstructn,false)<>0 then
-                             begin
-                               doconv:=hct;
-                               b:=2;
-                             end;
-                         end;
-                      end;
-                    pointerdef :
-                      begin
-                        if is_zero_based_array(def_to) and
-                           is_equal(ppointerdef(def_from)^.pointertype.def,parraydef(def_to)^.elementtype.def) then
-                         begin
-                           doconv:=tc_pointer_2_array;
-                           b:=1;
-                         end;
-                      end;
-                    stringdef :
-                      begin
-                        { string to array of char}
-                        if (not(is_special_array(def_to)) or is_open_array(def_to)) and
-                          is_equal(parraydef(def_to)^.elementtype.def,cchardef) then
-                         begin
-                           doconv:=tc_string_2_chararray;
-                           b:=1;
-                         end;
-                      end;
-                  end;
-                end;
-             end;
-
-           pointerdef :
-             begin
-               case def_from^.deftype of
-                 stringdef :
-                   begin
-                     { string constant (which can be part of array constructor)
-                       to zero terminated string constant }
-                     if (fromtreetype in [arrayconstructn,stringconstn]) and
-                        is_pchar(def_to) then
-                      begin
-                        doconv:=tc_cstring_2_pchar;
-                        b:=1;
-                      end;
-                   end;
-                 orddef :
-                   begin
-                     { char constant to zero terminated string constant }
-                     if (fromtreetype=ordconstn) then
-                      begin
-                        if is_equal(def_from,cchardef) and
-                           is_pchar(def_to) then
-                         begin
-                           doconv:=tc_cchar_2_pchar;
-                           b:=1;
-                         end
-                        else
-                         if is_integer(def_from) then
-                          begin
-                            doconv:=tc_cord_2_pointer;
-                            b:=1;
-                          end;
-                      end;
-                   end;
-                 arraydef :
-                   begin
-                     { chararray to pointer }
-                     if is_zero_based_array(def_from) and
-                        is_equal(parraydef(def_from)^.elementtype.def,ppointerdef(def_to)^.pointertype.def) then
-                      begin
-                        doconv:=tc_array_2_pointer;
-                        b:=1;
-                      end;
-                   end;
-                 pointerdef :
-                   begin
-                     { child class pointer can be assigned to anchestor pointers }
-                     if (
-                         (ppointerdef(def_from)^.pointertype.def^.deftype=objectdef) and
-                         (ppointerdef(def_to)^.pointertype.def^.deftype=objectdef) and
-                         pobjectdef(ppointerdef(def_from)^.pointertype.def)^.is_related(
-                           pobjectdef(ppointerdef(def_to)^.pointertype.def))
-                        ) or
-                        { all pointers can be assigned to void-pointer }
-                        is_equal(ppointerdef(def_to)^.pointertype.def,voiddef) or
-                        { in my opnion, is this not clean pascal }
-                        { well, but it's handy to use, it isn't ? (FK) }
-                        is_equal(ppointerdef(def_from)^.pointertype.def,voiddef) then
-                       begin
-                         doconv:=tc_equal;
-                         b:=1;
-                       end;
-                   end;
-                 procvardef :
-                   begin
-                     { procedure variable can be assigned to an void pointer }
-                     { Not anymore. Use the @ operator now.}
-                     if not(m_tp_procvar in aktmodeswitches) and
-                        (ppointerdef(def_to)^.pointertype.def^.deftype=orddef) and
-                        (porddef(ppointerdef(def_to)^.pointertype.def)^.typ=uvoid) then
-                      begin
-                        doconv:=tc_equal;
-                        b:=1;
-                      end;
-                   end;
-                 classrefdef,
-                 objectdef :
-                   begin
-                     { class types and class reference type
-                       can be assigned to void pointers      }
-                     if (
-                         ((def_from^.deftype=objectdef) and pobjectdef(def_from)^.is_class) or
-                         (def_from^.deftype=classrefdef)
-                        ) and
-                        (ppointerdef(def_to)^.pointertype.def^.deftype=orddef) and
-                        (porddef(ppointerdef(def_to)^.pointertype.def)^.typ=uvoid) then
-                       begin
-                         doconv:=tc_equal;
-                         b:=1;
-                       end;
-                   end;
-               end;
-             end;
-
-           setdef :
-             begin
-               { automatic arrayconstructor -> set conversion }
-               if is_array_constructor(def_from) then
-                begin
-                  doconv:=tc_arrayconstructor_2_set;
-                  b:=1;
-                end;
-             end;
-
-           procvardef :
-             begin
-               { proc -> procvar }
-               if (def_from^.deftype=procdef) then
-                begin
-                  doconv:=tc_proc_2_procvar;
-                  if proc_to_procvar_equal(pprocdef(def_from),pprocvardef(def_to)) then
-                   b:=1;
-                end
-               else
-                { for example delphi allows the assignement from pointers }
-                { to procedure variables                                  }
-                if (m_pointer_2_procedure in aktmodeswitches) and
-                  (def_from^.deftype=pointerdef) and
-                  (ppointerdef(def_from)^.pointertype.def^.deftype=orddef) and
-                  (porddef(ppointerdef(def_from)^.pointertype.def)^.typ=uvoid) then
-                begin
-                   doconv:=tc_equal;
-                   b:=1;
-                end
-               else
-               { nil is compatible with procvars }
-                if (fromtreetype=niln) then
-                 begin
-                   doconv:=tc_equal;
-                   b:=1;
-                 end;
-             end;
-
-           objectdef :
-             begin
-               { object pascal objects }
-               if (def_from^.deftype=objectdef) {and
-                  pobjectdef(def_from)^.isclass and pobjectdef(def_to)^.isclass }then
-                begin
-                  doconv:=tc_equal;
-                  if pobjectdef(def_from)^.is_related(pobjectdef(def_to)) then
-                   b:=1;
-                end
-               else
-               { Class specific }
-                if (pobjectdef(def_to)^.is_class) then
-                 begin
-                   { void pointer also for delphi mode }
-                   if (m_delphi in aktmodeswitches) and
-                      is_voidpointer(def_from) then
-                    begin
-                      doconv:=tc_equal;
-                      b:=1;
-                    end
-                   else
-                   { nil is compatible with class instances }
-                    if (fromtreetype=niln) and (pobjectdef(def_to)^.is_class) then
-                     begin
-                       doconv:=tc_equal;
-                       b:=1;
-                     end;
-                 end;
-             end;
-
-           classrefdef :
-             begin
-               { class reference types }
-               if (def_from^.deftype=classrefdef) then
-                begin
-                  doconv:=tc_equal;
-                  if pobjectdef(pclassrefdef(def_from)^.pointertype.def)^.is_related(
-                       pobjectdef(pclassrefdef(def_to)^.pointertype.def)) then
-                   b:=1;
-                end
-               else
-                { nil is compatible with class references }
-                if (fromtreetype=niln) then
-                 begin
-                   doconv:=tc_equal;
-                   b:=1;
-                 end;
-             end;
-
-           filedef :
-             begin
-               { typed files are all equal to the abstract file type
-               name TYPEDFILE in system.pp in is_equal in types.pas
-               the problem is that it sholud be also compatible to FILE
-               but this would leed to a problem for ASSIGN RESET and REWRITE
-               when trying to find the good overloaded function !!
-               so all file function are doubled in system.pp
-               this is not very beautiful !!}
-               if (def_from^.deftype=filedef) and
-                  (
-                   (
-                    (pfiledef(def_from)^.filetyp = ft_typed) and
-                    (pfiledef(def_to)^.filetyp = ft_typed) and
-                    (
-                     (pfiledef(def_from)^.typedfiletype.def = pdef(voiddef)) or
-                     (pfiledef(def_to)^.typedfiletype.def = pdef(voiddef))
-                    )
-                   ) or
-                   (
-                    (
-                     (pfiledef(def_from)^.filetyp = ft_untyped) and
-                     (pfiledef(def_to)^.filetyp = ft_typed)
-                    ) or
-                    (
-                     (pfiledef(def_from)^.filetyp = ft_typed) and
-                     (pfiledef(def_to)^.filetyp = ft_untyped)
-                    )
-                   )
-                  ) then
-                 begin
-                    doconv:=tc_equal;
-                    b:=1;
-                 end
-             end;
-
-           else
-             begin
-             { assignment overwritten ?? }
-               if assignment_overloaded(def_from,def_to)<>nil then
-                b:=2;
-             end;
-         end;
-        isconvertable:=b;
-      end;
-
-    { ld is the left type definition
-      rd the right type definition
-      dd the result type definition  or voiddef if unkown }
-    function isbinaryoperatoroverloadable(ld, rd, dd : pdef;
-             treetyp : ttreetyp) : boolean;
-      begin
-        isbinaryoperatoroverloadable:=
-           (treetyp=starstarn) or
-           (ld^.deftype=recorddef) or
-           (rd^.deftype=recorddef) or
-           ((rd^.deftype=pointerdef) and
-            not(is_pchar(rd) and
-                (is_chararray(ld) or
-                 (ld^.deftype=stringdef) or
-                 (treetyp=addn))) and
-            (not(ld^.deftype in [pointerdef,objectdef,classrefdef,procvardef]) or
-             not (treetyp in [equaln,unequaln,gtn,gten,ltn,lten,subn])
-            ) and
-            (not is_integer(ld) or not (treetyp in [addn,subn]))
-           ) or
-           ((ld^.deftype=pointerdef) and
-            not(is_pchar(ld) and
-                (is_chararray(rd) or
-                 (rd^.deftype=stringdef) or
-                 (treetyp=addn))) and
-            (not(rd^.deftype in [stringdef,pointerdef,objectdef,classrefdef,procvardef]) and
-             ((not is_integer(rd) and (rd^.deftype<>objectdef)
-               and (rd^.deftype<>classrefdef)) or
-              not (treetyp in [equaln,unequaln,gtn,gten,ltn,lten,addn,subn])
-             )
-            )
-           ) or
-           { array def, but not mmx or chararray+[char,string,chararray] }
-           ((ld^.deftype=arraydef) and
-            not((cs_mmx in aktlocalswitches) and
-                is_mmx_able_array(ld)) and
-            not(is_chararray(ld) and
-                (is_char(rd) or
-                is_pchar(rd) or
-                 (rd^.deftype=stringdef) or
-                 is_chararray(rd)))
-           ) or
-           ((rd^.deftype=arraydef) and
-            not((cs_mmx in aktlocalswitches) and
-                is_mmx_able_array(rd)) and
-            not(is_chararray(rd) and
-                (is_char(ld) or
-                 is_pchar(ld) or
-                 (ld^.deftype=stringdef) or
-                 is_chararray(ld)))
-           ) or
-           { <> and = are defined for classes }
-           ((ld^.deftype=objectdef) and
-            (not(pobjectdef(ld)^.is_class) or
-             not(treetyp in [equaln,unequaln])
-            )
-           ) or
-           ((rd^.deftype=objectdef) and
-            (not(pobjectdef(rd)^.is_class) or
-             not(treetyp in [equaln,unequaln])
-            )
-             or
-           { allow other operators that + on strings }
-           (
-            (is_char(rd) or
-             is_pchar(rd) or
-             (rd^.deftype=stringdef) or
-             is_chararray(rd) or
-             is_char(ld) or
-             is_pchar(ld) or
-             (ld^.deftype=stringdef) or
-             is_chararray(ld)
-             ) and
-             not(treetyp in [addn,equaln,unequaln,gtn,gten,ltn,lten]) and
-             not(is_pchar(ld) and
-                 (is_integer(rd) or (rd^.deftype=pointerdef)) and
-                 (treetyp=subn)
-                )
-            )
-           );
-      end;
-
-    function isunaryoperatoroverloadable(rd,dd : pdef;
-             treetyp : ttreetyp) : boolean;
-      begin
-        isunaryoperatoroverloadable:=false;
-        { what assignment overloading should be allowed ?? }
-        if (treetyp=assignn) then
-          begin
-            isunaryoperatoroverloadable:=true;
-             { this already get tbs0261 to fail
-             isunaryoperatoroverloadable:=not is_equal(rd,dd); PM }
-          end
-        { should we force that rd and dd are equal ?? }
-        else if (treetyp=subn { unaryminusn }) then
-          begin
-            isunaryoperatoroverloadable:=
-              not is_integer(rd) and not (rd^.deftype=floatdef)
-{$ifdef SUPPORT_MMX}
-              and not ((cs_mmx in aktlocalswitches) and
-              is_mmx_able_array(rd))
-{$endif SUPPORT_MMX}
-              ;
-          end
-        else if (treetyp=notn) then
-          begin
-            isunaryoperatoroverloadable:=not is_integer(rd) and not is_boolean(rd)
-{$ifdef SUPPORT_MMX}
-              and not ((cs_mmx in aktlocalswitches) and
-              is_mmx_able_array(rd))
-{$endif SUPPORT_MMX}
-              ;
-          end;
-      end;
-
-    function isoperatoracceptable(pf : pprocdef; optoken : ttoken) : boolean;
-      var
-        ld,rd,dd : pdef;
-        i : longint;
-      begin
-        case pf^.parast^.symindex^.count of
-          2 : begin
-                isoperatoracceptable:=false;
-                for i:=1 to tok2nodes do
-                  if tok2node[i].tok=optoken then
-                    begin
-                      ld:=pvarsym(pf^.parast^.symindex^.first)^.vartype.def;
-                      rd:=pvarsym(pf^.parast^.symindex^.first^.indexnext)^.vartype.def;
-                      dd:=pf^.rettype.def;
-                      isoperatoracceptable:=
-                        tok2node[i].op_overloading_supported and
-                        isbinaryoperatoroverloadable(ld,rd,dd,tok2node[i].nod);
-                      break;
-                    end;
-              end;
-          1 : begin
-                rd:=pvarsym(pf^.parast^.symindex^.first)^.vartype.def;
-                dd:=pf^.rettype.def;
-                for i:=1 to tok2nodes do
-                  if tok2node[i].tok=optoken then
-                    begin
-                      isoperatoracceptable:=
-                        tok2node[i].op_overloading_supported and
-                        isunaryoperatoroverloadable(rd,dd,tok2node[i].nod);
-                      break;
-                    end;
-              end;
-          else
-            isoperatoracceptable:=false;
-          end;
-      end;
-
-{****************************************************************************
-                          Register Calculation
-****************************************************************************}
-
-    { marks an lvalue as "unregable" }
-    procedure make_not_regable(p : ptree);
-      begin
-         case p^.treetype of
-            typeconvn :
-              make_not_regable(p^.left);
-            loadn :
-              if p^.symtableentry^.typ=varsym then
-                pvarsym(p^.symtableentry)^.varoptions:=pvarsym(p^.symtableentry)^.varoptions-[vo_regable,vo_fpuregable];
-         end;
-      end;
-
-
-    procedure left_right_max(p : ptree);
-      begin
-        if assigned(p^.left) then
-         begin
-           if assigned(p^.right) then
-            begin
-              p^.registers32:=max(p^.left^.registers32,p^.right^.registers32);
-              p^.registersfpu:=max(p^.left^.registersfpu,p^.right^.registersfpu);
-{$ifdef SUPPORT_MMX}
-              p^.registersmmx:=max(p^.left^.registersmmx,p^.right^.registersmmx);
-{$endif SUPPORT_MMX}
-            end
-           else
-            begin
-              p^.registers32:=p^.left^.registers32;
-              p^.registersfpu:=p^.left^.registersfpu;
-{$ifdef SUPPORT_MMX}
-              p^.registersmmx:=p^.left^.registersmmx;
-{$endif SUPPORT_MMX}
-            end;
-         end;
-      end;
-
-    { calculates the needed registers for a binary operator }
-    procedure calcregisters(p : ptree;r32,fpu,mmx : word);
-
-      begin
-         left_right_max(p);
-
-      { Only when the difference between the left and right registers < the
-        wanted registers allocate the amount of registers }
-
-        if assigned(p^.left) then
-         begin
-           if assigned(p^.right) then
-            begin
-              if (abs(p^.left^.registers32-p^.right^.registers32)<r32) then
-               inc(p^.registers32,r32);
-              if (abs(p^.left^.registersfpu-p^.right^.registersfpu)<fpu) then
-               inc(p^.registersfpu,fpu);
-{$ifdef SUPPORT_MMX}
-              if (abs(p^.left^.registersmmx-p^.right^.registersmmx)<mmx) then
-               inc(p^.registersmmx,mmx);
-{$endif SUPPORT_MMX}
-              { the following is a little bit guessing but I think }
-              { it's the only way to solve same internalerrors:    }
-              { if the left and right node both uses registers     }
-              { and return a mem location, but the current node    }
-              { doesn't use an integer register we get probably    }
-              { trouble when restoring a node                      }
-              if (p^.left^.registers32=p^.right^.registers32) and
-                 (p^.registers32=p^.left^.registers32) and
-                 (p^.registers32>0) and
-                (p^.left^.location.loc in [LOC_REFERENCE,LOC_MEM]) and
-                (p^.right^.location.loc in [LOC_REFERENCE,LOC_MEM]) then
-                inc(p^.registers32);
-            end
-           else
-            begin
-              if (p^.left^.registers32<r32) then
-               inc(p^.registers32,r32);
-              if (p^.left^.registersfpu<fpu) then
-               inc(p^.registersfpu,fpu);
-{$ifdef SUPPORT_MMX}
-              if (p^.left^.registersmmx<mmx) then
-               inc(p^.registersmmx,mmx);
-{$endif SUPPORT_MMX}
-            end;
-         end;
-
-         { error CGMessage, if more than 8 floating point }
-         { registers are needed                         }
-         if p^.registersfpu>8 then
-          CGMessage(cg_e_too_complex_expr);
-      end;
-
-{****************************************************************************
-                          Subroutine Handling
-****************************************************************************}
-
-{ protected field handling
-  protected field can not appear in
-  var parameters of function !!
-  this can only be done after we have determined the
-  overloaded function
-  this is the reason why it is not in the parser, PM }
-
-    procedure test_protected_sym(sym : psym);
-      begin
-         if (sp_protected in sym^.symoptions) and
-            ((sym^.owner^.symtabletype=unitsymtable) or
-             ((sym^.owner^.symtabletype=objectsymtable) and
-             (pobjectdef(sym^.owner^.defowner)^.owner^.symtabletype=unitsymtable))
-            ) then
-          CGMessage(parser_e_cant_access_protected_member);
-      end;
-
-
-    procedure test_protected(p : ptree);
-      begin
-        case p^.treetype of
-         loadn : test_protected_sym(p^.symtableentry);
-     typeconvn : test_protected(p^.left);
-        derefn : test_protected(p^.left);
-    subscriptn : begin
-                 { test_protected(p^.left);
-                   Is a field of a protected var
-                   also protected ???  PM }
-                   test_protected_sym(p^.vs);
-                 end;
-        end;
-      end;
-
-   function  valid_for_formal_var(p : ptree) : boolean;
-     var
-        v : boolean;
-     begin
-        case p^.treetype of
-         loadn :
-           v:=(p^.symtableentry^.typ in [typedconstsym,varsym]);
-         typeconvn :
-           v:=valid_for_formal_var(p^.left);
-         derefn,
-         subscriptn,
-         vecn,
-         funcretn,
-         selfn :
-           v:=true;
-         calln : { procvars are callnodes first }
-           v:=assigned(p^.right) and not assigned(p^.left);
-         addrn :
-           begin
-             { addrn is not allowed as this generate a constant value,
-               but a tp procvar are allowed (PFV) }
-             if p^.procvarload then
-              v:=true
-             else
-              v:=false;
-           end;
-         else
-           v:=false;
-        end;
-        valid_for_formal_var:=v;
-     end;
-
-   function  valid_for_formal_const(p : ptree) : boolean;
-     var
-        v : boolean;
-     begin
-        { p must have been firstpass'd before }
-        { accept about anything but not a statement ! }
-        case p^.treetype of
-          calln,
-          statementn,
-          addrn :
-           begin
-             { addrn is not allowed as this generate a constant value,
-               but a tp procvar are allowed (PFV) }
-             if p^.procvarload then
-              v:=true
-             else
-              v:=false;
-           end;
-          else
-            v:=true;
-        end;
-        valid_for_formal_const:=v;
-     end;
-
-    function is_procsym_load(p:Ptree):boolean;
-      begin
-         is_procsym_load:=((p^.treetype=loadn) and (p^.symtableentry^.typ=procsym)) or
-                          ((p^.treetype=addrn) and (p^.left^.treetype=loadn)
-                          and (p^.left^.symtableentry^.typ=procsym)) ;
-      end;
-
-   { change a proc call to a procload for assignment to a procvar }
-   { this can only happen for proc/function without arguments }
-    function is_procsym_call(p:Ptree):boolean;
-      begin
-        is_procsym_call:=(p^.treetype=calln) and (p^.left=nil) and
-             (((p^.symtableprocentry^.typ=procsym) and (p^.right=nil)) or
-             ((p^.right<>nil) and (p^.right^.symtableprocentry^.typ=varsym)));
-      end;
-
-
-    function assignment_overloaded(from_def,to_def : pdef) : pprocdef;
-       var
-          passproc : pprocdef;
-          convtyp : tconverttype;
-       begin
-          assignment_overloaded:=nil;
-          if assigned(overloaded_operators[_assignment]) then
-            passproc:=overloaded_operators[_assignment]^.definition
-          else
-            exit;
-          while passproc<>nil do
-            begin
-              if is_equal(passproc^.rettype.def,to_def) and
-                 (is_equal(pparaitem(passproc^.para^.first)^.paratype.def,from_def) or
-                 (isconvertable(from_def,pparaitem(passproc^.para^.first)^.paratype.def,convtyp,ordconstn,false)=1)) then
-                begin
-                   assignment_overloaded:=passproc;
-                   break;
-                end;
-              passproc:=passproc^.nextoverloaded;
-            end;
-       end;
-
-
-    { local routines can't be assigned to procvars }
-    procedure test_local_to_procvar(from_def:pprocvardef;to_def:pdef);
-      begin
-         if (from_def^.symtablelevel>1) and (to_def^.deftype=procvardef) then
-           CGMessage(type_e_cannot_local_proc_to_procvar);
-      end;
-
-
-    function valid_for_assign(p:ptree;allowprop:boolean):boolean;
-      var
-        hp : ptree;
-        gotwith,
-        gotsubscript,
-        gotpointer,
-        gotclass,
-        gotderef : boolean;
-      begin
-        valid_for_assign:=false;
-        gotsubscript:=false;
-        gotderef:=false;
-        gotclass:=false;
-        gotpointer:=false;
-        gotwith:=false;
-        hp:=p;
-        while assigned(hp) do
-         begin
-           { property allowed? calln has a property check itself }
-           if (not allowprop) and
-              (hp^.isproperty) and
-              (hp^.treetype<>calln) then
-            begin
-              CGMessagePos(hp^.fileinfo,type_e_argument_cant_be_assigned);
-              exit;
-            end;
-           case hp^.treetype of
-             derefn :
-               begin
-                 gotderef:=true;
-                 hp:=hp^.left;
-               end;
-             typeconvn :
-               begin
-                 case hp^.resulttype^.deftype of
-                   pointerdef :
-                     gotpointer:=true;
-                   objectdef :
-                     gotclass:=pobjectdef(hp^.resulttype)^.is_class;
-                   classrefdef :
-                     gotclass:=true;
-                   arraydef :
-                     begin
-                       { pointer -> array conversion is done then we need to see it
-                         as a deref, because a ^ is then not required anymore }
-                       if (hp^.left^.resulttype^.deftype=pointerdef) then
-                        gotderef:=true;
-                     end;
-                 end;
-                 hp:=hp^.left;
-               end;
-             vecn,
-             asn :
-               hp:=hp^.left;
-             subscriptn :
-               begin
-                 gotsubscript:=true;
-                 hp:=hp^.left;
-               end;
-             subn,
-             addn :
-               begin
-                 { Allow add/sub operators on a pointer, or an integer
-                   and a pointer typecast and deref has been found }
-                 if (hp^.resulttype^.deftype=pointerdef) or
-                    (is_integer(hp^.resulttype) and gotpointer and gotderef) then
-                  valid_for_assign:=true
-                 else
-                  CGMessagePos(hp^.fileinfo,type_e_variable_id_expected);
-                 exit;
-               end;
-             addrn :
-               begin
-                 if not(gotderef) and
-                    not(hp^.procvarload) then
-                  CGMessagePos(hp^.fileinfo,type_e_no_assign_to_addr);
-                 exit;
-               end;
-             selfn,
-             funcretn :
-               begin
-                 valid_for_assign:=true;
-                 exit;
-               end;
-             calln :
-               begin
-                 { check return type }
-                 case hp^.resulttype^.deftype of
-                   pointerdef :
-                     gotpointer:=true;
-                   objectdef :
-                     gotclass:=pobjectdef(hp^.resulttype)^.is_class;
-                   recorddef, { handle record like class it needs a subscription }
-                   classrefdef :
-                     gotclass:=true;
-                 end;
-                 { 1. if it returns a pointer and we've found a deref,
-                   2. if it returns a class or record and a subscription or with is found,
-                   3. property is allowed }
-                 if (gotpointer and gotderef) or
-                    (gotclass and (gotsubscript or gotwith)) or
-                    (hp^.isproperty and allowprop) then
-                  valid_for_assign:=true
-                 else
-                  CGMessagePos(hp^.fileinfo,type_e_argument_cant_be_assigned);
-                 exit;
-               end;
-             loadn :
-               begin
-                 case hp^.symtableentry^.typ of
-                   absolutesym,
-                   varsym :
-                     begin
-                       if (pvarsym(hp^.symtableentry)^.varspez=vs_const) then
-                        begin
-                          { allow p^:= constructions with p is const parameter }
-                          if gotderef then
-                           valid_for_assign:=true
-                          else
-                           CGMessagePos(hp^.fileinfo,type_e_no_assign_to_const);
-                          exit;
-                        end;
-                       { Are we at a with symtable, then we need to process the
-                         withrefnode also to check for maybe a const load }
-                       if (hp^.symtable^.symtabletype=withsymtable) then
-                        begin
-                          { continue with processing the withref node }
-                          hp:=ptree(pwithsymtable(hp^.symtable)^.withrefnode);
-                          gotwith:=true;
-                        end
-                       else
-                        begin
-                          { set the assigned flag for varsyms }
-                          if (pvarsym(hp^.symtableentry)^.varstate=vs_declared) then
-                           pvarsym(hp^.symtableentry)^.varstate:=vs_assigned;
-                          valid_for_assign:=true;
-                          exit;
-                        end;
-                     end;
-                   funcretsym,
-                   typedconstsym :
-                     begin
-                       valid_for_assign:=true;
-                       exit;
-                     end;
-                 end;
-               end;
-             else
-               begin
-                 CGMessagePos(hp^.fileinfo,type_e_variable_id_expected);
-                 exit;
-               end;
-            end;
-         end;
-      end;
-
-
-    procedure set_varstate(p : ptree;must_be_valid : boolean);
-      begin
-        while assigned(p) do
-         begin
-           if p^.varstateset then
-            exit;
-           p^.varstateset:=true;
-           case p^.treetype of
-             typeconvn :
-               begin
-                 case p^.convtyp of
-                   tc_cchar_2_pchar,
-                   tc_cstring_2_pchar,
-                   tc_array_2_pointer :
-                     must_be_valid:=false;
-                   tc_pchar_2_string,
-                   tc_pointer_2_array :
-                     must_be_valid:=true;
-                 end;
-                 p:=p^.left;
-               end;
-             subscriptn :
-               p:=p^.left;
-             vecn:
-               begin
-                 set_varstate(p^.right,true);
-                 if not(p^.left^.resulttype^.deftype in [stringdef,arraydef]) then
-                  must_be_valid:=true;
-                 p:=p^.left;
-               end;
-             { do not parse calln }
-             calln :
-               break;
-             callparan :
-               begin
-                 set_varstate(p^.right,must_be_valid);
-                 p:=p^.left;
-               end;
-             loadn :
-               begin
-                 if (p^.symtableentry^.typ=varsym) then
-                  begin
-                    if must_be_valid and p^.is_first then
-                     begin
-                       if (pvarsym(p^.symtableentry)^.varstate=vs_declared_and_first_found) or
-                          (pvarsym(p^.symtableentry)^.varstate=vs_set_but_first_not_passed) then
-                        begin
-                          if (assigned(pvarsym(p^.symtableentry)^.owner) and
-                             assigned(aktprocsym) and
-                             (pvarsym(p^.symtableentry)^.owner = aktprocsym^.definition^.localst)) then
-                           begin
-                             if p^.symtable^.symtabletype=localsymtable then
-                              CGMessage1(sym_n_uninitialized_local_variable,pvarsym(p^.symtableentry)^.name)
-                             else
-                              CGMessage1(sym_n_uninitialized_variable,pvarsym(p^.symtableentry)^.name);
-                           end;
-                        end;
-                     end;
-                    if (p^.is_first) then
-                     begin
-                       if pvarsym(p^.symtableentry)^.varstate=vs_declared_and_first_found then
-                        begin
-                          { this can only happen at left of an assignment, no ? PM }
-                          if (parsing_para_level=0) and not must_be_valid then
-                           pvarsym(p^.symtableentry)^.varstate:=vs_assigned
-                          else
-                           pvarsym(p^.symtableentry)^.varstate:=vs_used;
-                        end
-                       else
-                        if pvarsym(p^.symtableentry)^.varstate=vs_set_but_first_not_passed then
-                         pvarsym(p^.symtableentry)^.varstate:=vs_used;
-                       p^.is_first:=false;
-                     end
-                    else
-                      begin
-                        if (pvarsym(p^.symtableentry)^.varstate=vs_assigned) and
-                           (must_be_valid or (parsing_para_level>0) or
-                            (p^.resulttype^.deftype=procvardef)) then
-                          pvarsym(p^.symtableentry)^.varstate:=vs_used;
-                        if (pvarsym(p^.symtableentry)^.varstate=vs_declared_and_first_found) and
-                           (must_be_valid or (parsing_para_level>0) or
-                           (p^.resulttype^.deftype=procvardef)) then
-                          pvarsym(p^.symtableentry)^.varstate:=vs_set_but_first_not_passed;
-                      end;
-                  end;
-                 break;
-               end;
-             funcretn:
-               begin
-                 { no claim if setting higher return value_str }
-                 if must_be_valid and
-                    (procinfo=pprocinfo(p^.funcretprocinfo)) and
-                    ((procinfo^.funcret_state=vs_declared) or
-                    ((p^.is_first_funcret) and
-                     (procinfo^.funcret_state=vs_declared_and_first_found))) then
-                   begin
-                     CGMessage(sym_w_function_result_not_set);
-                     { avoid multiple warnings }
-                     procinfo^.funcret_state:=vs_assigned;
-                   end;
-                 if p^.is_first_funcret and not must_be_valid then
-                   pprocinfo(p^.funcretprocinfo)^.funcret_state:=vs_assigned;
-                 break;
-               end;
-             else
-               break;
-           end;{case }
-         end;
-      end;
-
-
-    procedure unset_varstate(p : ptree);
-      begin
-        while assigned(p) do
-         begin
-           p^.varstateset:=false;
-           case p^.treetype of
-             typeconvn,
-             subscriptn,
-             vecn :
-               p:=p^.left;
-             else
-               break;
-           end;
-         end;
-      end;
-
-
-    procedure set_unique(p : ptree);
-      begin
-        while assigned(p) do
-         begin
-           case p^.treetype of
-             vecn:
-               begin
-                 p^.callunique:=true;
-                 break;
-               end;
-             typeconvn,
-             subscriptn,
-             derefn:
-               p:=p^.left;
-             else
-               break;
-           end;
-         end;
-      end;
-
-
-    procedure set_funcret_is_valid(p : ptree);
-      begin
-        while assigned(p) do
-         begin
-           case p^.treetype of
-             funcretn:
-               begin
-                 if p^.is_first_funcret then
-                  pprocinfo(p^.funcretprocinfo)^.funcret_state:=vs_assigned;
-                 break;
-               end;
-             vecn,
-             {derefn,}
-             typeconvn,
-             subscriptn:
-               p:=p^.left;
-             else
-               break;
-           end;
-         end;
-      end;
-
-{$endif cg11}
-end.
-{
-  $Log$
-  Revision 1.11  2000-10-01 19:48:23  peter
+  Revision 1.11  2000/10/01 19:48:23  peter
     * lot of compile updates for cg11
 
   Revision 1.10  2000/09/29 15:45:23  florian

compiler/n386.pas

@@ -0,0 +1,41 @@
+{
+    $Id$
+    Copyright (c) 2000 by Florian Klaempfl
+
+    Includes the i386 code generator
+
+    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 n386;
+
+{$i defines.inc}
+
+  interface
+
+  implementation
+
+    uses
+       n386bas,n386ld,n386add,n386cal,n386con,n386flw,n386mat,n386mem,
+       n386set,n386inl;
+
+end.
+{
+  $Log$
+  Revision 1.1  2000-10-14 10:14:47  peter
+    * moehrendorf oct 2000 rewrite
+
+}

compiler/n386add.pas

@@ -27,25 +27,35 @@ unit n386add;
 interface
 
     uses
-       nadd;
-
-    ti386addnode = class(taddnode)
-       procedure pass_2;override;
-       function getresflags(unsigned : boolean) : tresflags;
-       procedure SetResultLocation(cmpop,unsigned : boolean);
-       procedure addstring;
-       procedure addset;
-    end;
+       nadd,cpubase;
+
+    type
+       ti386addnode = class(taddnode)
+          procedure pass_2;override;
+          function getresflags(unsigned : boolean) : tresflags;
+          procedure SetResultLocation(cmpop,unsigned : boolean);
+          procedure addstring;
+          procedure addset;
+       end;
 
   implementation
 
+    uses
+      globtype,systems,
+      cutils,cobjects,verbose,globals,
+      symconst,symtable,aasm,types,
+      hcodegen,temp_gen,pass_2,
+      cpuasm,
+      node,ncon,nset,
+      cgai386,n386util,tgeni386;
+
     function ti386addnode.getresflags(unsigned : boolean) : tresflags;
 
       begin
          if not(unsigned) then
            begin
-              if swaped then
-                case treetype of
+              if nf_swaped in flags then
+                case nodetype of
                    equaln : getresflags:=F_E;
                    unequaln : getresflags:=F_NE;
                    ltn : getresflags:=F_G;
@@ -54,7 +64,7 @@ interface
                    gten : getresflags:=F_LE;
                 end
               else
-                case treetype of
+                case nodetype of
                    equaln : getresflags:=F_E;
                    unequaln : getresflags:=F_NE;
                    ltn : getresflags:=F_L;
@@ -65,8 +75,8 @@ interface
            end
          else
            begin
-              if swaped then
-                case treetype of
+              if nf_swaped in flags then
+                case nodetype of
                    equaln : getresflags:=F_E;
                    unequaln : getresflags:=F_NE;
                    ltn : getresflags:=F_A;
@@ -75,7 +85,7 @@ interface
                    gten : getresflags:=F_BE;
                 end
               else
-                case treetype of
+                case nodetype of
                    equaln : getresflags:=F_E;
                    unequaln : getresflags:=F_NE;
                    ltn : getresflags:=F_B;
@@ -105,7 +115,7 @@ interface
            begin
               clear_location(location);
               location.loc:=LOC_FLAGS;
-              location.resflags:=getresflags(p,unsigned);
+              location.resflags:=getresflags(unsigned);
            end;
       end;
 
@@ -130,12 +140,12 @@ interface
         regstopush : byte;
       begin
         { string operations are not commutative }
-        if swaped then
+        if nf_swaped in flags then
           swapleftright;
         case pstringdef(left.resulttype)^.string_typ of
            st_ansistring:
              begin
-                case treetype of
+                case nodetype of
                    addn:
                      begin
                         cmpop:=false;
@@ -146,7 +156,7 @@ interface
                         secondpass(right);
                         if pushed then
                           begin
-                             restore(p,false);
+                             restore(self,false);
                              set_location(left.location,location);
                           end;
                         { get the temp location, must be done before regs are
@@ -175,9 +185,9 @@ interface
                    equaln,unequaln:
                      begin
                         cmpop:=true;
-                        if (treetype in [equaln,unequaln]) and
-                           (left.treetype=stringconstn) and
-                           (left.length=0) then
+                        if (nodetype in [equaln,unequaln]) and
+                           (left.nodetype=stringconstn) and
+                           (tstringconstnode(left).len=0) then
                           begin
                              secondpass(right);
                              { release used registers }
@@ -192,9 +202,9 @@ interface
                              ungetiftempansi(left.location.reference);
                              ungetiftempansi(right.location.reference);
                           end
-                        else if (treetype in [equaln,unequaln]) and
-                          (right.treetype=stringconstn) and
-                          (right.length=0) then
+                        else if (nodetype in [equaln,unequaln]) and
+                          (right.nodetype=stringconstn) and
+                          (tstringconstnode(right).len=0) then
                           begin
                              secondpass(left);
                              { release used registers }
@@ -244,11 +254,11 @@ interface
                      end;
                 end;
                { the result of ansicompare is signed }
-               SetResultLocation(cmpop,false,p);
+               SetResultLocation(cmpop,false);
              end;
            st_shortstring:
              begin
-                case treetype of
+                case nodetype of
                    addn:
                      begin
                         cmpop:=false;
@@ -256,7 +266,7 @@ interface
                         { if str_concat is set in expr
                           s:=s+ ... no need to create a temp string (PM) }
 
-                        if (left.treetype<>addn) and not (use_strconcat) then
+                        if (left.nodetype<>addn) and not(nf_use_strconcat in flags) then
                           begin
 
                              { can only reference be }
@@ -304,7 +314,7 @@ interface
                             emitjmp(C_E,l);
                             { no, so add the new character }
                             { is it a constant char? }
-                            if (right.treetype <> ordconstn) then
+                            if (right.nodetype <> ordconstn) then
                               { no, make sure it is in a register }
                               if right.location.loc in [LOC_REFERENCE,LOC_MEM] then
                                 begin
@@ -347,7 +357,7 @@ interface
                             { increase the string length }
                             emit_ref(A_INC,S_B,newreference(left.location.reference));
                             { and store the character at the end of the string }
-                            if (right.treetype <> ordconstn) then
+                            if (right.nodetype <> ordconstn) then
                               begin
                                 { no new_reference(href2) because it's only }
                                 { used once (JM)                            }
@@ -402,9 +412,9 @@ interface
                      begin
                         cmpop:=true;
                         { generate better code for s='' and s<>'' }
-                        if (treetype in [equaln,unequaln]) and
-                           (((left.treetype=stringconstn) and (str_length(left)=0)) or
-                            ((right.treetype=stringconstn) and (str_length(right)=0))) then
+                        if (nodetype in [equaln,unequaln]) and
+                           (((left.nodetype=stringconstn) and (str_length(left)=0)) or
+                            ((right.nodetype=stringconstn) and (str_length(right)=0))) then
                           begin
                              secondpass(left);
                              { are too few registers free? }
@@ -415,7 +425,7 @@ interface
                              { only one node can be stringconstn }
                              { else pass 1 would have evaluted   }
                              { this node                         }
-                             if left.treetype=stringconstn then
+                             if left.nodetype=stringconstn then
                                emit_const_ref(
                                  A_CMP,S_B,0,newreference(right.location.reference))
                              else
@@ -442,7 +452,7 @@ interface
                      end;
                    else CGMessage(type_e_mismatch);
                 end;
-               SetResultLocation(cmpop,true,p);
+               SetResultLocation(cmpop,true);
              end;
           end;
       end;
@@ -464,12 +474,12 @@ interface
         cmpop:=false;
 
         { not commutative }
-        if swaped then
-         swaptree(p);
+        if nf_swaped in flags then
+         swapleftright;
 
         { optimize first loading of a set }
 {$ifdef usecreateset}
-        if (right.treetype=setelementn) and
+        if (right.nodetype=setelementn) and
            not(assigned(right.right)) and
            is_emptyset(left) then
          createset:=true
@@ -492,7 +502,7 @@ interface
 
         { handle operations }
 
-        case treetype of
+        case nodetype of
           equaln,
         unequaln
 {$IfNDef NoSetInclusion}
@@ -504,7 +514,7 @@ interface
                      del_location(right.location);
                      pushusedregisters(pushedregs,$ff);
 {$IfNDef NoSetInclusion}
-                     If (treetype in [equaln, unequaln, lten]) Then
+                     If (nodetype in [equaln, unequaln, lten]) Then
                        Begin
 {$EndIf NoSetInclusion}
                          emitpushreferenceaddr(right.location.reference);
@@ -516,7 +526,7 @@ interface
                          emitpushreferenceaddr(left.location.reference);
                          emitpushreferenceaddr(right.location.reference);
                        End;
-                     Case treetype of
+                     Case nodetype of
                        equaln, unequaln:
 {$EndIf NoSetInclusion}
                          emitcall('FPC_SET_COMP_SETS');
@@ -525,7 +535,7 @@ interface
                          Begin
                            emitcall('FPC_SET_CONTAINS_SETS');
                            { we need a jne afterwards, not a jnbe/jnae }
-                           treetype := equaln;
+                           nodetype := equaln;
                         End;
                      End;
 {$EndIf NoSetInclusion}
@@ -561,30 +571,30 @@ interface
                      gettempofsizereference(32,href);
                      if createset then
                       begin
-                        pushsetelement(right.left);
+                        pushsetelement(tunarynode(right).left);
                         emitpushreferenceaddr(href);
                         emitcall('FPC_SET_CREATE_ELEMENT');
                       end
                      else
                       begin
                       { add a range or a single element? }
-                        if right.treetype=setelementn then
+                        if right.nodetype=setelementn then
                          begin
 {$IfNDef regallocfix}
                            concatcopy(left.location.reference,href,32,false,false);
 {$Else regallocfix}
                            concatcopy(left.location.reference,href,32,true,false);
 {$EndIf regallocfix}
-                           if assigned(right.right) then
+                           if assigned(tbinarynode(right).right) then
                             begin
-                              pushsetelement(right.right);
-                              pushsetelement(right.left);
+                              pushsetelement(tbinarynode(right).right);
+                              pushsetelement(tunarynode(right).left);
                               emitpushreferenceaddr(href);
                               emitcall('FPC_SET_SET_RANGE');
                             end
                            else
                             begin
-                              pushsetelement(right.left);
+                              pushsetelement(tunarynode(right).left);
                               emitpushreferenceaddr(href);
                               emitcall('FPC_SET_SET_BYTE');
                             end;
@@ -631,7 +641,7 @@ interface
                      { The same here }
                      del_location(left.location);
                      emitpushreferenceaddr(left.location.reference);
-                     case treetype of
+                     case nodetype of
                       subn : emitcall('FPC_SET_SUB_SETS');
                    symdifn : emitcall('FPC_SET_SYMDIF_SETS');
                       muln : emitcall('FPC_SET_MUL_SETS');
@@ -665,7 +675,7 @@ interface
          noswap,popeax,popedx,
          pushed,mboverflow,cmpop : boolean;
          op,op2 : tasmop;
-         flags : tresflags;
+         resflags : tresflags;
          otl,ofl : pasmlabel;
          power : longint;
          opsize : topsize;
@@ -692,34 +702,34 @@ interface
       procedure firstjmp64bitcmp;
 
         var
-           oldtreetype : ttreetyp;
+           oldnodetype : tnodetype;
 
         begin
            { the jump the sequence is a little bit hairy }
-           case treetype of
+           case nodetype of
               ltn,gtn:
                 begin
-                   emitjmp(flag_2_cond[getresflags(p,unsigned)],truelabel);
+                   emitjmp(flag_2_cond[getresflags(unsigned)],truelabel);
                    { cheat a little bit for the negative test }
-                   swaped:=not(swaped);
-                   emitjmp(flag_2_cond[getresflags(p,unsigned)],falselabel);
-                   swaped:=not(swaped);
+                   toggleflag(nf_swaped);
+                   emitjmp(flag_2_cond[getresflags(unsigned)],falselabel);
+                   toggleflag(nf_swaped);
                 end;
               lten,gten:
                 begin
-                   oldtreetype:=treetype;
-                   if treetype=lten then
-                     treetype:=ltn
+                   oldnodetype:=nodetype;
+                   if nodetype=lten then
+                     nodetype:=ltn
                    else
-                     treetype:=gtn;
-                   emitjmp(flag_2_cond[getresflags(p,unsigned)],truelabel);
+                     nodetype:=gtn;
+                   emitjmp(flag_2_cond[getresflags(unsigned)],truelabel);
                    { cheat for the negative test }
-                   if treetype=ltn then
-                     treetype:=gtn
+                   if nodetype=ltn then
+                     nodetype:=gtn
                    else
-                     treetype:=ltn;
-                   emitjmp(flag_2_cond[getresflags(p,unsigned)],falselabel);
-                   treetype:=oldtreetype;
+                     nodetype:=ltn;
+                   emitjmp(flag_2_cond[getresflags(unsigned)],falselabel);
+                   nodetype:=oldnodetype;
                 end;
               equaln:
                 emitjmp(C_NE,falselabel);
@@ -732,12 +742,12 @@ interface
 
         begin
            { the jump the sequence is a little bit hairy }
-           case treetype of
+           case nodetype of
               ltn,gtn,lten,gten:
                 begin
                    { the comparisaion of the low dword have to be }
                    {  always unsigned!                            }
-                   emitjmp(flag_2_cond[getresflags(p,true)],truelabel);
+                   emitjmp(flag_2_cond[getresflags(true)],truelabel);
                    emitjmp(C_None,falselabel);
                 end;
               equaln:
@@ -758,14 +768,14 @@ interface
         own procedures }
          case left.resulttype^.deftype of
          stringdef : begin
-                       addstring(p);
+                       addstring;
                        exit;
                      end;
             setdef : begin
                      { normalsets are handled separate }
                        if not(psetdef(left.resulttype)^.settype=smallset) then
                         begin
-                          addset(p);
+                          addset;
                           exit;
                         end;
                      end;
@@ -783,7 +793,7 @@ interface
          is_set:=(left.resulttype^.deftype=setdef);
 
          { calculate the operator which is more difficult }
-         firstcomplex(p);
+         firstcomplex(self);
 
          { handling boolean expressions extra: }
          if is_boolean(left.resulttype) and
@@ -799,11 +809,11 @@ interface
              else
                opsize:=S_L;
              if (cs_full_boolean_eval in aktlocalswitches) or
-                (p^.treetype in
+                (nodetype in
                   [unequaln,ltn,lten,gtn,gten,equaln,xorn]) then
                begin
-                 if left.treetype=ordconstn then
-                  swaptree(p);
+                 if left.nodetype=ordconstn then
+                  swapleftright;
                  if left.location.loc=LOC_JUMP then
                    begin
                       otl:=truelabel;
@@ -822,7 +832,7 @@ interface
                       locjump2reg(left.location,opsize, otl, ofl);
                  end;
                  set_location(location,left.location);
-                 pushed:=maybe_push(right.registers32,p,false);
+                 pushed:=maybe_push(right.registers32,self,false);
                  if right.location.loc=LOC_JUMP then
                    begin
                       otl:=truelabel;
@@ -833,7 +843,7 @@ interface
                  secondpass(right);
                  if pushed then
                    begin
-                      restore(p,false);
+                      restore(self,false);
                       set_location(left.location,location);
                    end;
                  case right.location.loc of
@@ -843,15 +853,15 @@ interface
                       locjump2reg(right.location,opsize,otl,ofl);
                  end;
                  goto do_normal;
-              end
+              end;
 
-             case treetype of
+             case nodetype of
               andn,
                orn : begin
                        clear_location(location);
                        location.loc:=LOC_JUMP;
                        cmpop:=false;
-                       case treetype of
+                       case nodetype of
                         andn : begin
                                   otl:=truelabel;
                                   getlabel(truelabel);
@@ -881,8 +891,8 @@ interface
          else
            begin
               { in case of constant put it to the left }
-              if (left.treetype=ordconstn) then
-               swaptree(p);
+              if (left.nodetype=ordconstn) then
+               swapleftright;
               secondpass(left);
               { this will be complicated as
                a lot of code below assumes that
@@ -901,11 +911,11 @@ interface
                 set_location(location,left.location);
 
               { are too few registers free? }
-              pushed:=maybe_push(right.registers32,p,is_64bitint(left.resulttype));
+              pushed:=maybe_push(right.registers32,self,is_64bitint(left.resulttype));
               secondpass(right);
               if pushed then
                 begin
-                  restore(p,is_64bitint(left.resulttype));
+                  restore(self,is_64bitint(left.resulttype));
                   set_location(left.location,location);
                 end;
 
@@ -954,7 +964,7 @@ interface
                    unsigned := not(is_signed(left.resulttype)) or
                                not(is_signed(right.resulttype));
 {$endif cardinalmulfix}
-                   case treetype of
+                   case nodetype of
                       addn : begin
                                { this is a really ugly hack!!!!!!!!!! }
                                { this could be done later using EDI   }
@@ -963,13 +973,13 @@ interface
                                if is_set then
                                 begin
                                 { adding elements is not commutative }
-                                  if swaped and (left.treetype=setelementn) then
-                                   swaptree;
+                                  if (nf_swaped in flags) and (left.nodetype=setelementn) then
+                                   swapleftright;
                                 { are we adding set elements ? }
-                                  if right.treetype=setelementn then
+                                  if right.nodetype=setelementn then
                                    begin
                                    { no range support for smallsets! }
-                                     if assigned(right.right) then
+                                     if assigned(tsetelementnode(right).right) then
                                       internalerror(43244);
                                    { bts requires both elements to be registers }
                                      if left.location.loc in [LOC_MEM,LOC_REFERENCE] then
@@ -1044,7 +1054,7 @@ interface
                                   mboverflow:=false;
                                   unsigned:=false;
 {$IfNDef NoSetConstNot}
-                                  If (right.treetype = setconstn) then
+                                  If (right.nodetype = setconstn) then
                                     right.location.reference.offset := not(right.location.reference.offset)
                                   Else
 {$EndIf NoNosetConstNot}
@@ -1061,11 +1071,11 @@ interface
            equaln,unequaln : begin
 {$IfNDef NoSetInclusion}
                                If is_set Then
-                                 Case treetype of
+                                 Case nodetype of
                                    lten,gten:
                                      Begin
-                                      If treetype = lten then
-                                        swaptree(p);
+                                      If nodetype = lten then
+                                        swapleftright;
                                       if left.location.loc in [LOC_MEM,LOC_REFERENCE] then
                                         begin
                                          ungetiftemp(left.location.reference);
@@ -1099,8 +1109,8 @@ interface
                                         emit_reg_reg(A_AND,opsize,
                                           right.location.register,left.location.register);
                 {warning: ugly hack ahead: we need a "jne" after the cmp, so
-                 change the treetype from lten/gten to equaln}
-                                      treetype := equaln
+                 change the nodetype from lten/gten to equaln}
+                                      nodetype := equaln
                                      End;
                            {no < or > support for sets}
                                    ltn,gtn: CGMessage(type_e_mismatch);
@@ -1131,10 +1141,10 @@ interface
                  { the location.register will be filled in later (JM) }
                        location.loc:=LOC_REGISTER;
 {$IfNDef NoShlMul}
-                       if right.treetype=ordconstn then
-                        swaptree(p);
-                       If (left.treetype = ordconstn) and
-                          ispowerof2(left.value, power) and
+                       if right.nodetype=ordconstn then
+                        swapleftright;
+                       If (left.nodetype = ordconstn) and
+                          ispowerof2(tordconstnode(left).value, power) and
                           not(cs_check_overflow in aktlocalswitches) then
                          Begin
                            { This release will be moved after the next }
@@ -1199,7 +1209,7 @@ interface
 {$IfNDef NoShlMul}
                         End;
 {$endif NoShlMul}
-                       SetResultLocation(false,true,p);
+                       SetResultLocation(false,true);
                        exit;
                      end;
 
@@ -1273,7 +1283,7 @@ interface
                           swap_location(location,right.location);
 
                           { newly swapped also set swapped flag }
-                          swaped:=not(swaped);
+                          toggleflag(nf_swaped);
                        end;
                    { at this point, location.loc should be LOC_REGISTER }
                    { and location.register should be a valid register   }
@@ -1281,7 +1291,7 @@ interface
 
                     if right.location.loc<>LOC_REGISTER then
                      begin
-                        if (treetype=subn) and swaped then
+                        if (nodetype=subn) and (nf_swaped in flags) then
                           begin
                              if right.location.loc=LOC_CREGISTER then
                                begin
@@ -1309,32 +1319,32 @@ interface
                           end
                         else
                           begin
-                             if (right.treetype=ordconstn) and
+                             if (right.nodetype=ordconstn) and
                                 (op=A_CMP) and
-                                (right.value=0) then
+                                (tordconstnode(right).value=0) then
                                begin
                                   emit_reg_reg(A_TEST,opsize,location.register,
                                     location.register);
                                end
-                             else if (right.treetype=ordconstn) and
+                             else if (right.nodetype=ordconstn) and
                                 (op=A_ADD) and
-                                (right.value=1) and
+                                (tordconstnode(right).value=1) and
                                 not(cs_check_overflow in aktlocalswitches) then
                                begin
                                   emit_reg(A_INC,opsize,
                                     location.register);
                                end
-                             else if (right.treetype=ordconstn) and
+                             else if (right.nodetype=ordconstn) and
                                 (op=A_SUB) and
-                                (right.value=1) and
+                                (tordconstnode(right).value=1) and
                                 not(cs_check_overflow in aktlocalswitches) then
                                begin
                                   emit_reg(A_DEC,opsize,
                                     location.register);
                                end
-                             else if (right.treetype=ordconstn) and
+                             else if (right.nodetype=ordconstn) and
                                 (op=A_IMUL) and
-                                (ispowerof2(right.value,power)) and
+                                (ispowerof2(tordconstnode(right).value,power)) and
                                 not(cs_check_overflow in aktlocalswitches) then
                                begin
                                   emit_const_reg(A_SHL,opsize,power,
@@ -1385,7 +1395,7 @@ interface
                    else
                      begin
                         { when swapped another result register }
-                        if (treetype=subn) and swaped then
+                        if (nodetype=subn) and (nf_swaped in flags) then
                           begin
                              if extra_not then
                                emit_reg(A_NOT,S_L,location.register);
@@ -1395,7 +1405,7 @@ interface
                                swap_location(location,right.location);
                                { newly swapped also set swapped flag }
                                { just to maintain ordering         }
-                               swaped:=not(swaped);
+                               toggleflag(nf_swaped);
                           end
                         else
                           begin
@@ -1444,7 +1454,7 @@ interface
                    ((left.resulttype^.deftype=enumdef) and
                     (left.resulttype^.size=1)) then
                  begin
-                   case treetype of
+                   case nodetype of
                       ltn,lten,gtn,gten,
                       equaln,unequaln :
                                 cmpop:=true;
@@ -1489,7 +1499,7 @@ interface
                      begin
                        swap_location(location,right.location);
                        { newly swapped also set swapped flag }
-                       swaped:=not(swaped);
+                       toggleflag(nf_swaped);
                      end;
 
                    if right.location.loc<>LOC_REGISTER then
@@ -1519,7 +1529,7 @@ interface
                 if ((left.resulttype^.deftype=enumdef) and
                     (left.resulttype^.size=2)) then
                  begin
-                   case treetype of
+                   case nodetype of
                       ltn,lten,gtn,gten,
                       equaln,unequaln :
                                 cmpop:=true;
@@ -1564,7 +1574,7 @@ interface
                      begin
                        swap_location(location,right.location);
                        { newly swapped also set swapped flag }
-                       swaped:=not(swaped);
+                       toggleflag(nf_swaped);
                      end;
 
                    if right.location.loc<>LOC_REGISTER then
@@ -1599,7 +1609,7 @@ interface
                        (porddef(left.resulttype)^.typ=u64bit)) or
                       ((right.resulttype^.deftype=orddef) and
                        (porddef(right.resulttype)^.typ=u64bit));
-                   case treetype of
+                   case nodetype of
                       addn : begin
                                 begin
                                   op:=A_ADD;
@@ -1644,7 +1654,7 @@ interface
                      CGMessage(type_e_mismatch);
                    end;
 
-                   if treetype=muln then
+                   if nodetype=muln then
                      begin
                         { save lcoation, because we change it now }
                         set_location(hloc,location);
@@ -1741,7 +1751,7 @@ interface
                                swap_location(location,right.location);
 
                                { newly swapped also set swapped flag }
-                               swaped:=not(swaped);
+                               toggleflag(nf_swaped);
                             end;
                         { at this point, location.loc should be LOC_REGISTER }
                         { and location.register should be a valid register   }
@@ -1749,7 +1759,7 @@ interface
 
                         if right.location.loc<>LOC_REGISTER then
                           begin
-                             if (treetype=subn) and swaped then
+                             if (nodetype=subn) and (nf_swaped in flags) then
                                begin
                                   if right.location.loc=LOC_CREGISTER then
                                     begin
@@ -1820,14 +1830,14 @@ interface
                              else
                                begin
                                   {
-                                  if (right.treetype=ordconstn) and
+                                  if (right.nodetype=ordconstn) and
                                      (op=A_CMP) and
                                      (right.value=0) then
                                     begin
                                        emit_reg_reg(A_TEST,opsize,location.register,
                                          location.register);
                                     end
-                                  else if (right.treetype=ordconstn) and
+                                  else if (right.nodetype=ordconstn) and
                                      (op=A_IMUL) and
                                      (ispowerof2(right.value,power)) then
                                     begin
@@ -1861,7 +1871,7 @@ interface
                         else
                           begin
                              { when swapped another result register }
-                             if (treetype=subn) and swaped then
+                             if (nodetype=subn) and (nf_swaped in flags) then
                                begin
                                  emit_reg_reg(op,S_L,
                                     location.registerlow,
@@ -1872,7 +1882,7 @@ interface
                                   swap_location(location,right.location);
                                   { newly swapped also set swapped flag }
                                   { just to maintain ordering           }
-                                  swaped:=not(swaped);
+                                  toggleflag(nf_swaped);
                                end
                              else if cmpop then
                                begin
@@ -1937,11 +1947,11 @@ interface
                  begin
                     { real constants to the right, but only if it
                       isn't on the FPU stack, i.e. 1.0 or 0.0! }
-                    if (left.treetype=realconstn) and
+                    if (left.nodetype=realconstn) and
                       (left.location.loc<>LOC_FPU) then
-                      swaptree(p);
+                      swapleftright;
                     cmpop:=false;
-                    case treetype of
+                    case nodetype of
                        addn : op:=A_FADDP;
                        muln : op:=A_FMULP;
                        subn : op:=A_FSUBP;
@@ -1977,7 +1987,7 @@ interface
                            end
                          { left was on the stack => swap }
                          else
-                           swaped:=not(swaped);
+                           toggleflag(nf_swaped);
 
                          { releases the right reference }
                          del_reference(right.location.reference);
@@ -1996,18 +2006,18 @@ interface
                       end
                     { fpu operands are always in the wrong order on the stack }
                     else
-                      swaped:=not(swaped);
+                      toggleflag(nf_swaped);
 
                     { releases the left reference }
                     if (left.location.loc in [LOC_MEM,LOC_REFERENCE]) then
                       del_reference(left.location.reference);
 
                     { if we swaped the tree nodes, then use the reverse operator }
-                    if swaped then
+                    if nf_swaped in flags then
                       begin
-                         if (treetype=slashn) then
+                         if (nodetype=slashn) then
                            op:=A_FDIVRP
-                         else if (treetype=subn) then
+                         else if (nodetype=subn) then
                            op:=A_FSUBRP;
                       end;
                     { to avoid the pentium bug
@@ -2042,31 +2052,31 @@ interface
                            emit_reg_reg(A_MOV,S_L,R_EDI,R_EAX);
                            ungetregister32(R_EDI);
                          end;
-                       if swaped then
+                       if nf_swaped in flags then
                         begin
-                          case treetype of
-                              equaln : flags:=F_E;
-                            unequaln : flags:=F_NE;
-                                 ltn : flags:=F_A;
-                                lten : flags:=F_AE;
-                                 gtn : flags:=F_B;
-                                gten : flags:=F_BE;
+                          case nodetype of
+                              equaln : resflags:=F_E;
+                            unequaln : resflags:=F_NE;
+                                 ltn : resflags:=F_A;
+                                lten : resflags:=F_AE;
+                                 gtn : resflags:=F_B;
+                                gten : resflags:=F_BE;
                           end;
                         end
                        else
                         begin
-                          case treetype of
-                              equaln : flags:=F_E;
-                            unequaln : flags:=F_NE;
-                                 ltn : flags:=F_B;
-                                lten : flags:=F_BE;
-                                 gtn : flags:=F_A;
-                                gten : flags:=F_AE;
+                          case nodetype of
+                              equaln : resflags:=F_E;
+                            unequaln : resflags:=F_NE;
+                                 ltn : resflags:=F_B;
+                                lten : resflags:=F_BE;
+                                 gtn : resflags:=F_A;
+                                gten : resflags:=F_AE;
                           end;
                         end;
                        clear_location(location);
                        location.loc:=LOC_FLAGS;
-                       location.resflags:=flags;
+                       location.resflags:=resflags;
                        cmpop:=false;
                      end
                     else
@@ -2083,7 +2093,7 @@ interface
                  begin
                    cmpop:=false;
                    mmxbase:=mmx_type(left.resulttype);
-                   case treetype of
+                   case nodetype of
                       addn : begin
                                 if (cs_mmx_saturation in aktlocalswitches) then
                                   begin
@@ -2209,14 +2219,14 @@ interface
                        begin
                           swap_location(location,right.location);
                           { newly swapped also set swapped flag }
-                          swaped:=not(swaped);
+                          toggleflag(nf_swaped);
                        end;
                    { at this point, location.loc should be LOC_MMXREGISTER }
                    { and location.register should be a valid register      }
                    { containing the left result                        }
                    if right.location.loc<>LOC_MMXREGISTER then
                      begin
-                        if (treetype=subn) and swaped then
+                        if (nodetype=subn) and (nf_swaped in flags) then
                           begin
                              if right.location.loc=LOC_CMMXREGISTER then
                                begin
@@ -2253,14 +2263,14 @@ interface
                    else
                      begin
                         { when swapped another result register }
-                        if (treetype=subn) and swaped then
+                        if (nodetype=subn) and (nf_swaped in flags) then
                           begin
                              emit_reg_reg(op,S_NO,
                                location.register,right.location.register);
                              swap_location(location,right.location);
                              { newly swapped also set swapped flag }
                              { just to maintain ordering         }
-                             swaped:=not(swaped);
+                             toggleflag(nf_swaped);
                           end
                         else
                           begin
@@ -2277,17 +2287,15 @@ interface
        SetResultLocation(cmpop,unsigned);
     end;
 
-    procedure ti386addnode.pass_2;
-
-      begin
-      end;
-
 begin
    caddnode:=ti386addnode;
 end.
 {
   $Log$
-  Revision 1.5  2000-09-30 16:08:45  peter
+  Revision 1.6  2000-10-14 10:14:47  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.5  2000/09/30 16:08:45  peter
     * more cg11 updates
 
   Revision 1.4  2000/09/24 15:06:18  peter
@@ -2304,4 +2312,4 @@ end.
 
   Revision 1.1  2000/09/20 21:23:32  florian
     * initial revision
-}
+}

compiler/n386bas.pas

@@ -0,0 +1,210 @@
+{
+    $Id$
+    Copyright (c) 1998-2000 by Florian Klaempfl
+
+    This unit handles the codegeneration pass
+
+    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 n386bas;
+
+{$i defines.inc}
+
+  interface
+
+    uses
+       node,nbas;
+
+    type
+       ti386statementnode = class(tstatementnode)
+          procedure pass_2;override;
+       end;
+
+       ti386blocknode = class(tblocknode)
+          procedure pass_2;override;
+       end;
+
+       ti386asmnode = class(tasmnode)
+          procedure pass_2;override;
+       end;
+
+  implementation
+
+    uses
+       globals,
+       aasm,cpubase,cpuasm,
+       symtable,symconst,
+       pass_2,tgeni386,
+       cgai386;
+
+    procedure ti386asmnode.pass_2;
+
+      procedure ReLabel(var p:pasmsymbol);
+        begin
+          if p^.proclocal then
+           begin
+             if not assigned(p^.altsymbol) then
+              begin
+                p^.GenerateAltSymbol;
+                UsedAsmSymbolListInsert(p);
+              end;
+             p:=p^.altsymbol;
+           end;
+        end;
+
+      var
+        hp,hp2 : pai;
+        localfixup,parafixup,
+        i : longint;
+        skipnode : boolean;
+      begin
+         if inlining_procedure then
+           begin
+             InitUsedAsmSymbolList;
+             localfixup:=aktprocsym^.definition^.localst^.address_fixup;
+             parafixup:=aktprocsym^.definition^.parast^.address_fixup;
+             hp:=pai(p_asm^.first);
+             while assigned(hp) do
+              begin
+                hp2:=pai(hp^.getcopy);
+                skipnode:=false;
+                case hp2^.typ of
+                  ait_label :
+                     begin
+                       { regenerate the labels by setting altsymbol }
+                       ReLabel(pasmsymbol(pai_label(hp2)^.l));
+                     end;
+                  ait_const_rva,
+                  ait_const_symbol :
+                     begin
+                       ReLabel(pai_const_symbol(hp2)^.sym);
+                     end;
+                  ait_instruction :
+                     begin
+{$ifdef i386}
+                       { fixup the references }
+                       for i:=1 to paicpu(hp2)^.ops do
+                        begin
+                          with paicpu(hp2)^.oper[i-1] do
+                           begin
+                             case typ of
+                               top_ref :
+                                 begin
+                                   case ref^.options of
+                                     ref_parafixup :
+                                       ref^.offsetfixup:=parafixup;
+                                     ref_localfixup :
+                                       ref^.offsetfixup:=localfixup;
+                                   end;
+                                   if assigned(ref^.symbol) then
+                                    ReLabel(ref^.symbol);
+                                 end;
+                               top_symbol :
+                                 begin
+                                   ReLabel(sym);
+                                 end;
+                              end;
+                           end;
+                        end;
+{$endif i386}
+                     end;
+                   ait_marker :
+                     begin
+                     { it's not an assembler block anymore }
+                       if (pai_marker(hp2)^.kind in [AsmBlockStart, AsmBlockEnd]) then
+                        skipnode:=true;
+                     end;
+                   else
+                end;
+                if not skipnode then
+                 exprasmlist^.concat(hp2)
+                else
+                 dispose(hp2,done);
+                hp:=pai(hp^.next);
+              end;
+             { restore used symbols }
+             UsedAsmSymbolListResetAltSym;
+             DoneUsedAsmSymbolList;
+           end
+         else
+           begin
+             { if the routine is an inline routine, then we must hold a copy
+               becuase it can be necessary for inlining later }
+             if (pocall_inline in aktprocsym^.definition^.proccalloptions) then
+               exprasmlist^.concatlistcopy(p_asm)
+             else
+               exprasmlist^.concatlist(p_asm);
+           end;
+         if not (nf_object_preserved in flags) then
+          begin
+{$ifdef i386}
+            maybe_loadesi;
+{$endif}
+{$ifdef m68k}
+            maybe_loada5;
+{$endif}
+          end;
+       end;
+
+    procedure ti386statementnode.pass_2;
+
+      var
+         hp : tnode;
+
+      begin
+         hp:=self;
+         while assigned(hp) do
+          begin
+            if assigned(tstatementnode(hp).right) then
+             begin
+               cleartempgen;
+               {!!!!!!
+               oldrl:=temptoremove;
+               temptoremove:=new(plinkedlist,init);
+               }
+               secondpass(tstatementnode(hp).right);
+               { !!!!!!!
+                 some temporary data which can't be released elsewhere
+               removetemps(exprasmlist,temptoremove);
+               dispose(temptoremove,done);
+               temptoremove:=oldrl;
+               }
+             end;
+            hp:=tstatementnode(hp).left;
+          end;
+      end;
+
+
+    procedure ti386blocknode.pass_2;
+      begin
+      { do second pass on left node }
+        if assigned(left) then
+         secondpass(left);
+      end;
+
+
+begin
+   cstatementnode:=ti386statementnode;
+   cblocknode:=ti386blocknode;
+   casmnode:=ti386asmnode;
+end.
+{
+  $Log$
+  Revision 1.1  2000-10-14 10:14:48  peter
+    * moehrendorf oct 2000 rewrite
+
+}

compiler/n386cal.pas

@@ -31,19 +31,20 @@ interface
     uses
       symtable,node,ncal;
 
-    ti386callparanode = class(tcallparanode)
-       procedure secondcallparan(defcoll : pparaitem;
-                push_from_left_to_right,inlined,is_cdecl : boolean;
-                para_alignment,para_offset : longint);virtual;
-    end;
+    type
+       ti386callparanode = class(tcallparanode)
+          procedure secondcallparan(defcoll : pparaitem;
+                   push_from_left_to_right,inlined,is_cdecl : boolean;
+                   para_alignment,para_offset : longint);override;
+       end;
 
-    ti386callnode = class(tcallnode)
-       procedure pass_2;override;
-    end;
+       ti386callnode = class(tcallnode)
+          procedure pass_2;override;
+       end;
 
-    ti386procinlinenode = class(tprocinlinenode)
-       procedure pass_2;override;
-    end;
+       ti386procinlinenode = class(tprocinlinenode)
+          procedure pass_2;override;
+       end;
 
 implementation
 
@@ -61,7 +62,8 @@ implementation
 {$endif GDB}
       hcodegen,temp_gen,pass_2,
       cpubase,cpuasm,
-      cgai386,tgeni386,cg386ld;
+      nmem,nld,
+      cgai386,tgeni386,n386ld,n386util;
 
 {*****************************************************************************
                              TI386CALLPARANODE
@@ -139,7 +141,7 @@ implementation
 
          { push from left to right if specified }
          if push_from_left_to_right and assigned(right) then
-           secondcallparan(right,pparaitem(defcoll^.next),push_from_left_to_right,
+           tcallparanode(right).secondcallparan(pparaitem(defcoll^.next),push_from_left_to_right,
              inlined,is_cdecl,para_alignment,para_offset);
          otlabel:=truelabel;
          oflabel:=falselabel;
@@ -147,7 +149,7 @@ implementation
          getlabel(falselabel);
          secondpass(left);
          { filter array constructor with c styled args }
-         if is_array_constructor(left.resulttype) and left.cargs then
+         if is_array_constructor(left.resulttype) and (nf_cargs in left.flags) then
            begin
              { nothing, everything is already pushed }
            end
@@ -157,8 +159,8 @@ implementation
            begin
               { allow @var }
               inc(pushedparasize,4);
-              if (left.treetype=addrn) and
-                 (not left.procvarload) then
+              if (left.nodetype=addrn) and
+                 (not(nf_procvarload in left.flags)) then
                 begin
                 { always a register }
                   if inlined then
@@ -256,7 +258,7 @@ implementation
          falselabel:=oflabel;
          { push from right to left }
          if not push_from_left_to_right and assigned(right) then
-           secondcallparan(right,pparaitem(defcoll^.next),push_from_left_to_right,
+           tcallparanode(right).secondcallparan(pparaitem(defcoll^.next),push_from_left_to_right,
              inlined,is_cdecl,para_alignment,para_offset);
       end;
 
@@ -265,7 +267,7 @@ implementation
                              TI386CALLNODE
 *****************************************************************************}
 
-    procedure ti386callnode.pass_1;
+    procedure ti386callnode.pass_2;
       var
          unusedregisters : tregisterset;
          usablecount : byte;
@@ -287,11 +289,11 @@ implementation
          i : longint;
          { help reference pointer }
          r : preference;
-         hp : tnode
+         hp : tnode;
          pp : tbinarynode;
          params : tnode;
          inlined : boolean;
-         inlinecode : ptree;
+         inlinecode : tprocinlinenode;
          para_alignment,
          para_offset : longint;
          { instruction for alignement correction }
@@ -318,8 +320,7 @@ implementation
          unusedregisters:=unused;
          usablecount:=usablereg32;
 
-         if (pocall_cdecl in procdefinition^.proccalloptions) or
-            (pocall_stdcall in procdefinition^.proccalloptions) then
+         if ([pocall_cdecl,pocall_cppdecl,pocall_stdcall]*procdefinition^.proccalloptions)<>[] then
           para_alignment:=4
          else
           para_alignment:=target_os.stackalignment;
@@ -333,15 +334,15 @@ implementation
          if (pocall_inline in procdefinition^.proccalloptions) then
            begin
               { make a copy for the next time the procedure is inlined (JM) }
-              left:=getcopy(left);
+              left:=left.getcopy;
               inlined:=true;
-              inlinecode:=right;
+              inlinecode:=tprocinlinenode(right);
               { set it to the same lexical level as the local symtable, becuase
                 the para's are stored there }
               pprocdef(procdefinition)^.parast^.symtablelevel:=aktprocsym^.definition^.localst^.symtablelevel;
               if assigned(params) then
-                inlinecode^.para_offset:=gettempofsizepersistant(inlinecode^.para_size);
-              pprocdef(procdefinition)^.parast^.address_fixup:=inlinecode^.para_offset;
+                inlinecode.para_offset:=gettempofsizepersistant(inlinecode.para_size);
+              pprocdef(procdefinition)^.parast^.address_fixup:=inlinecode.para_offset;
 {$ifdef extdebug}
              Comment(V_debug,
                'inlined parasymtable is at offset '
@@ -351,7 +352,7 @@ implementation
                +tostr(pprocdef(procdefinition)^.parast^.address_fixup)))));
 {$endif extdebug}
               { copy for the next time the procedure is inlined (JM) }
-              right:=getcopy(right);
+              right:=right.getcopy;
               { disable further inlining of the same proc
                 in the args }
               exclude(procdefinition^.proccalloptions,pocall_inline);
@@ -486,18 +487,18 @@ implementation
                 para_offset:=0;
               if not(inlined) and
                  assigned(right) then
-                secondcallparan(params,pparaitem(pabstractprocdef(right.resulttype)^.para^.first),
+                tcallparanode(params).secondcallparan(pparaitem(pabstractprocdef(right.resulttype)^.para^.first),
                   (pocall_leftright in procdefinition^.proccalloptions),inlined,
-                  (pocall_cdecl in procdefinition^.proccalloptions),
+                  (([pocall_cdecl,pocall_cppdecl]*procdefinition^.proccalloptions)<>[]),
                   para_alignment,para_offset)
               else
-                secondcallparan(params,pparaitem(procdefinition^.para^.first),
+                tcallparanode(params).secondcallparan(pparaitem(procdefinition^.para^.first),
                   (pocall_leftright in procdefinition^.proccalloptions),inlined,
-                  (pocall_cdecl in procdefinition^.proccalloptions),
+                  (([pocall_cdecl,pocall_cppdecl]*procdefinition^.proccalloptions)<>[]),
                   para_alignment,para_offset);
            end;
          if inlined then
-           inlinecode^.retoffset:=gettempofsizepersistant(4);
+           inlinecode.retoffset:=gettempofsizepersistant(4);
          if ret_in_param(resulttype) then
            begin
               { This must not be counted for C code
@@ -513,7 +514,7 @@ implementation
 {$endif noAllocEdi}
                    emit_ref_reg(A_LEA,S_L,
                      newreference(funcretref),R_EDI);
-                   r:=new_reference(procinfo^.framepointer,inlinecode^.retoffset);
+                   r:=new_reference(procinfo^.framepointer,inlinecode.retoffset);
                    emit_reg_ref(A_MOV,S_L,R_EDI,r);
 {$ifndef noAllocEdi}
                    ungetregister32(R_EDI);
@@ -528,24 +529,22 @@ implementation
            begin
               { overloaded operator have no symtable }
               { push self }
-              if assigned(symtable) and
-                (symtable^.symtabletype=withsymtable) then
+              if assigned(symtableproc) and
+                (symtableproc^.symtabletype=withsymtable) then
                 begin
                    { dirty trick to avoid the secondcall below }
-                   methodpointer:=genzeronode(callparan);
-                   methodpointer^.location.loc:=LOC_REGISTER;
+                   methodpointer:=ccallparanode.create(nil,nil);
+                   methodpointer.location.loc:=LOC_REGISTER;
 {$ifndef noAllocEDI}
                    getexplicitregister32(R_ESI);
 {$endif noAllocEDI}
-                   methodpointer^.location.register:=R_ESI;
+                   methodpointer.location.register:=R_ESI;
                    { ARGHHH this is wrong !!!
                      if we can init from base class for a child
                      class that the wrong VMT will be
                      transfered to constructor !! }
-                   methodpointer^.resulttype:=
-                     ptree(pwithsymtable(symtable)^.withnode)^.left.resulttype;
-                   { change dispose type !! }
-                   disposetyp:=dt_mbleft_and_method;
+                   methodpointer.resulttype:=
+                     twithnode(pwithsymtable(symtableproc)^.withnode).left.resulttype;
                    { make a reference }
                    new(r);
                    reset_reference(r^);
@@ -558,19 +557,19 @@ implementation
                         r^.offset:=symtable^.datasize;
                         r^.base:=procinfo^.framepointer;
                      end; }
-                   r^:=ptree(pwithsymtable(symtable)^.withnode)^.withreference^;
-                   if ((not ptree(pwithsymtable(symtable)^.withnode)^.islocal) and
-                       (not pwithsymtable(symtable)^.direct_with)) or
-                      pobjectdef(methodpointer^.resulttype)^.is_class then
+                   r^:=twithnode(pwithsymtable(symtableproc)^.withnode).withreference^;
+                   if ((not(nf_islocal in twithnode(pwithsymtable(symtableproc)^.withnode).flags)) and
+                       (not pwithsymtable(symtableproc)^.direct_with)) or
+                      pobjectdef(methodpointer.resulttype)^.is_class then
                      emit_ref_reg(A_MOV,S_L,r,R_ESI)
                    else
                      emit_ref_reg(A_LEA,S_L,r,R_ESI);
                 end;
 
               { push self }
-              if assigned(symtable) and
-                ((symtable^.symtabletype=objectsymtable) or
-                (symtable^.symtabletype=withsymtable)) then
+              if assigned(symtableproc) and
+                ((symtableproc^.symtabletype=objectsymtable) or
+                (symtableproc^.symtabletype=withsymtable)) then
                 begin
                    if assigned(methodpointer) then
                      begin
@@ -584,7 +583,7 @@ implementation
                           end
                         else }
                           begin
-                             case methodpointer^.treetype of
+                             case methodpointer.nodetype of
                                typen:
                                  begin
                                     { direct call to inherited method }
@@ -606,12 +605,12 @@ implementation
 {$ifndef noAllocEDI}
                                          getexplicitregister32(R_ESI);
 {$endif noAllocEDI}
-                                         if not(oo_has_vmt in pobjectdef(methodpointer^.resulttype)^.objectoptions) then
+                                         if not(oo_has_vmt in pobjectdef(methodpointer.resulttype)^.objectoptions) then
                                            emit_const_reg(A_MOV,S_L,0,R_ESI)
                                          else
                                            begin
                                              emit_sym_ofs_reg(A_MOV,S_L,
-                                               newasmsymbol(pobjectdef(methodpointer^.resulttype)^.vmt_mangledname),
+                                               newasmsymbol(pobjectdef(methodpointer.resulttype)^.vmt_mangledname),
                                                0,R_ESI);
                                            end;
                                          { emit_reg(A_PUSH,S_L,R_ESI);
@@ -622,7 +621,7 @@ implementation
                                       loadesi:=false;
 
                                     { a class destructor needs a flag }
-                                    if pobjectdef(methodpointer^.resulttype)^.is_class and
+                                    if pobjectdef(methodpointer.resulttype)^.is_class and
                                        {assigned(aktprocsym) and
                                        (aktprocsym^.definition^.proctypeoption=potype_destructor)}
                                        (procdefinition^.proctypeoption=potype_destructor) then
@@ -632,7 +631,7 @@ implementation
                                       end;
 
                                     if not(is_con_or_destructor and
-                                           pobjectdef(methodpointer^.resulttype)^.is_class and
+                                           pobjectdef(methodpointer.resulttype)^.is_class and
                                            {assigned(aktprocsym) and
                                           (aktprocsym^.definition^.proctypeoption in [potype_constructor,potype_destructor])}
                                            (procdefinition^.proctypeoption in [potype_constructor,potype_destructor])
@@ -643,7 +642,7 @@ implementation
                                     { will be made                                  }
                                     { con- and destructors need a pointer to the vmt }
                                     if is_con_or_destructor and
-                                    not(pobjectdef(methodpointer^.resulttype)^.is_class) and
+                                    not(pobjectdef(methodpointer.resulttype)^.is_class) and
                                     assigned(aktprocsym) then
                                       begin
                                          if not(aktprocsym^.definition^.proctypeoption in
@@ -653,12 +652,12 @@ implementation
                                     { class destructors get there flag above }
                                     { constructor flags ?                    }
                                     if is_con_or_destructor and
-                                        not(pobjectdef(methodpointer^.resulttype)^.is_class and
+                                        not(pobjectdef(methodpointer.resulttype)^.is_class and
                                         assigned(aktprocsym) and
                                         (aktprocsym^.definition^.proctypeoption=potype_destructor)) then
                                       begin
                                          { a constructor needs also a flag }
-                                         if pobjectdef(methodpointer^.resulttype)^.is_class then
+                                         if pobjectdef(methodpointer.resulttype)^.is_class then
                                            push_int(0);
                                          push_int(0);
                                       end;
@@ -674,7 +673,7 @@ implementation
                                     emit_reg(A_PUSH,S_L,R_ESI);
                                     { insert the vmt }
                                     emit_sym(A_PUSH,S_L,
-                                      newasmsymbol(pobjectdef(methodpointer^.resulttype)^.vmt_mangledname));
+                                      newasmsymbol(pobjectdef(methodpointer.resulttype)^.vmt_mangledname));
                                     extended_new:=true;
                                  end;
                                hdisposen:
@@ -687,39 +686,39 @@ implementation
                                     getexplicitregister32(R_ESI);
 {$endif noAllocEDI}
                                     emit_ref_reg(A_LEA,S_L,
-                                      newreference(methodpointer^.location.reference),R_ESI);
-                                    del_reference(methodpointer^.location.reference);
+                                      newreference(methodpointer.location.reference),R_ESI);
+                                    del_reference(methodpointer.location.reference);
                                     emit_reg(A_PUSH,S_L,R_ESI);
                                     emit_sym(A_PUSH,S_L,
-                                      newasmsymbol(pobjectdef(methodpointer^.resulttype)^.vmt_mangledname));
+                                      newasmsymbol(pobjectdef(methodpointer.resulttype)^.vmt_mangledname));
                                  end;
                                else
                                  begin
                                     { call to an instance member }
-                                    if (symtable^.symtabletype<>withsymtable) then
+                                    if (symtableproc^.symtabletype<>withsymtable) then
                                       begin
                                          secondpass(methodpointer);
 {$ifndef noAllocEDI}
                                          getexplicitregister32(R_ESI);
 {$endif noAllocEDI}
-                                         case methodpointer^.location.loc of
+                                         case methodpointer.location.loc of
                                             LOC_CREGISTER,
                                             LOC_REGISTER:
                                               begin
-                                                 emit_reg_reg(A_MOV,S_L,methodpointer^.location.register,R_ESI);
-                                                 ungetregister32(methodpointer^.location.register);
+                                                 emit_reg_reg(A_MOV,S_L,methodpointer.location.register,R_ESI);
+                                                 ungetregister32(methodpointer.location.register);
                                               end;
                                             else
                                               begin
-                                                 if (methodpointer^.resulttype^.deftype=classrefdef) or
-                                                    ((methodpointer^.resulttype^.deftype=objectdef) and
-                                                   pobjectdef(methodpointer^.resulttype)^.is_class) then
+                                                 if (methodpointer.resulttype^.deftype=classrefdef) or
+                                                    ((methodpointer.resulttype^.deftype=objectdef) and
+                                                   pobjectdef(methodpointer.resulttype)^.is_class) then
                                                    emit_ref_reg(A_MOV,S_L,
-                                                     newreference(methodpointer^.location.reference),R_ESI)
+                                                     newreference(methodpointer.location.reference),R_ESI)
                                                  else
                                                    emit_ref_reg(A_LEA,S_L,
-                                                     newreference(methodpointer^.location.reference),R_ESI);
-                                                 del_reference(methodpointer^.location.reference);
+                                                     newreference(methodpointer.location.reference),R_ESI);
+                                                 del_reference(methodpointer.location.reference);
                                               end;
                                          end;
                                       end;
@@ -728,7 +727,7 @@ implementation
                                     if not(po_containsself in procdefinition^.procoptions) then
                                       begin
                                         if (po_classmethod in procdefinition^.procoptions) and
-                                           not(methodpointer^.resulttype^.deftype=classrefdef) then
+                                           not(methodpointer.resulttype^.deftype=classrefdef) then
                                           begin
                                              { class method needs current VMT }
                                              getexplicitregister32(R_ESI);
@@ -741,14 +740,14 @@ implementation
 
                                         { direct call to destructor: remove data }
                                         if (procdefinition^.proctypeoption=potype_destructor) and
-                                           (methodpointer^.resulttype^.deftype=objectdef) and
-                                           (pobjectdef(methodpointer^.resulttype)^.is_class) then
+                                           (methodpointer.resulttype^.deftype=objectdef) and
+                                           (pobjectdef(methodpointer.resulttype)^.is_class) then
                                           emit_const(A_PUSH,S_L,1);
 
                                         { direct call to class constructor, don't allocate memory }
                                         if (procdefinition^.proctypeoption=potype_constructor) and
-                                           (methodpointer^.resulttype^.deftype=objectdef) and
-                                           (pobjectdef(methodpointer^.resulttype)^.is_class) then
+                                           (methodpointer.resulttype^.deftype=objectdef) and
+                                           (pobjectdef(methodpointer.resulttype)^.is_class) then
                                           begin
                                              emit_const(A_PUSH,S_L,0);
                                              emit_const(A_PUSH,S_L,0);
@@ -757,8 +756,8 @@ implementation
                                           begin
                                              { constructor call via classreference => allocate memory }
                                              if (procdefinition^.proctypeoption=potype_constructor) and
-                                                (methodpointer^.resulttype^.deftype=classrefdef) and
-                                                (pobjectdef(pclassrefdef(methodpointer^.resulttype)^.
+                                                (methodpointer.resulttype^.deftype=classrefdef) and
+                                                (pobjectdef(pclassrefdef(methodpointer.resulttype)^.
                                                    pointertype.def)^.is_class) then
                                                 emit_const(A_PUSH,S_L,1);
                                              emit_reg(A_PUSH,S_L,R_ESI);
@@ -768,14 +767,14 @@ implementation
                                     if is_con_or_destructor then
                                       begin
                                          { classes don't get a VMT pointer pushed }
-                                         if (methodpointer^.resulttype^.deftype=objectdef) and
-                                           not(pobjectdef(methodpointer^.resulttype)^.is_class) then
+                                         if (methodpointer.resulttype^.deftype=objectdef) and
+                                           not(pobjectdef(methodpointer.resulttype)^.is_class) then
                                            begin
                                               if (procdefinition^.proctypeoption=potype_constructor) then
                                                 begin
                                                    { it's no bad idea, to insert the VMT }
                                                    emit_sym(A_PUSH,S_L,newasmsymbol(
-                                                     pobjectdef(methodpointer^.resulttype)^.vmt_mangledname));
+                                                     pobjectdef(methodpointer.resulttype)^.vmt_mangledname));
                                                 end
                                               { destructors haven't to dispose the instance, if this is }
                                               { a direct call                                           }
@@ -909,13 +908,13 @@ implementation
                      begin
                        if (((sp_static in aktprocsym^.symoptions) or
                         (po_classmethod in aktprocsym^.definition^.procoptions)) and
-                        ((methodpointer=nil) or (methodpointer^.treetype=typen)))
+                        ((methodpointer=nil) or (methodpointer.nodetype=typen)))
                         or
                         (po_staticmethod in procdefinition^.procoptions) or
                         ((procdefinition^.proctypeoption=potype_constructor) and
                         { esi contains the vmt if we call a constructor via a class ref }
                          assigned(methodpointer) and
-                         (methodpointer^.resulttype^.deftype=classrefdef)
+                         (methodpointer.resulttype^.deftype=classrefdef)
                         ) or
                         { ESI is loaded earlier }
                         (po_classmethod in procdefinition^.procoptions) then
@@ -1133,7 +1132,7 @@ implementation
              (right=nil)) and
             (procdefinition^.proctypeoption=potype_constructor) and
             assigned(methodpointer) and
-            (methodpointer^.treetype=typen) and
+            (methodpointer.nodetype=typen) and
             (aktprocsym^.definition^.proctypeoption=potype_constructor) then
            begin
              emitjmp(C_Z,faillabel);
@@ -1149,7 +1148,7 @@ implementation
            end;
          { we have only to handle the result if it is used, but }
          { ansi/widestrings must be registered, so we can dispose them }
-         if (resulttype<>pdef(voiddef)) and (return_value_used or
+         if (resulttype<>pdef(voiddef)) and ((nf_return_value_used in flags) or
            is_ansistring(resulttype) or is_widestring(resulttype)) then
            begin
               { a contructor could be a function with boolean result }
@@ -1322,15 +1321,15 @@ implementation
                   if (pp.left.location.loc in [LOC_REFERENCE,LOC_MEM]) then
                     ungetiftemp(pp.left.location.reference);
                 { process also all nodes of an array of const }
-                  if pp.left.treetype=arrayconstructn then
+                  if pp.left.nodetype=arrayconstructorn then
                     begin
-                      if assigned(pp.left.left) then
+                      if assigned(tarrayconstructornode(pp.left).left) then
                        begin
                          hp:=pp.left;
                          while assigned(hp) do
                           begin
-                            if (hp.left.location.loc in [LOC_REFERENCE,LOC_MEM]) then
-                              ungetiftemp(hp.left.location.reference);
+                            if (tarrayconstructornode(tunarynode(hp).left).location.loc in [LOC_REFERENCE,LOC_MEM]) then
+                              ungetiftemp(tarrayconstructornode(hp).left.location.reference);
                             hp:=tbinarynode(hp).right;
                           end;
                        end;
@@ -1339,10 +1338,9 @@ implementation
               pp:=tbinarynode(pp.right);
            end;
          if inlined then
-           ungetpersistanttemp(inlinecode^.retoffset);
-         if assigned(inlinecode) then
-           disposetree(inlinecode);
-         disposetree(params);
+           ungetpersistanttemp(inlinecode.retoffset);
+         inlinecode.free;
+         params.free;
 
 
          { from now on the result can be freed normally }
@@ -1350,7 +1348,7 @@ implementation
            persistanttemptonormal(funcretref.offset);
 
          { if return value is not used }
-         if (not return_value_used) and (resulttype<>pdef(voiddef)) then
+         if (not(nf_return_value_used in flags)) and (resulttype<>pdef(voiddef)) then
            begin
               if location.loc in [LOC_MEM,LOC_REFERENCE] then
                 begin
@@ -1384,7 +1382,7 @@ implementation
     procedure ti386procinlinenode.pass_2;
        var st : psymtable;
            oldprocsym : pprocsym;
-           para_size, i : longint;
+           ps, i : longint;
            tmpreg: tregister;
            oldprocinfo : pprocinfo;
            oldinlining_procedure,
@@ -1514,9 +1512,9 @@ implementation
           inlineentrycode:=new(paasmoutput,init);
           inlineexitcode:=new(paasmoutput,init);
           proc_names.init;
-          para_size:=para_size;
+          ps:=para_size;
           make_global:=false; { to avoid warning }
-          genentrycode(inlineentrycode,proc_names,make_global,0,para_size,nostackframe,true);
+          genentrycode(inlineentrycode,proc_names,make_global,0,ps,nostackframe,true);
           exprasmlist^.concatlist(inlineentrycode);
           secondpass(inlinetree);
           genexitcode(inlineexitcode,0,false,true);
@@ -1595,7 +1593,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.1  2000-10-10 17:31:56  florian
+  Revision 1.2  2000-10-14 10:14:48  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.1  2000/10/10 17:31:56  florian
     * initial revision
 
 }

compiler/n386cnv.pas

@@ -0,0 +1,1440 @@
+{
+    $Id$
+    Copyright (c) 1998-2000 by Florian Klaempfl
+
+    Generate i386 assembler for type converting nodes
+
+    This program is free software; you can redistribute it and/or modify
+    it under the terms of the GNU General Public License as published by
+    the Free Software Foundation; either version 2 of the License, or
+    (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU General Public License for more details.
+
+    You should have received a copy of the GNU General Public License
+    along with this program; if not, write to the Free Software
+    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ ****************************************************************************
+}
+unit n386cnv;
+
+{$i defines.inc}
+
+interface
+
+    uses
+      node,ncnv,types;
+
+    type
+       ti386typeconvnode = class(ttypeconvnode)
+          procedure second_int_to_int;virtual;
+          procedure second_string_to_string;virtual;
+          procedure second_cstring_to_pchar;virtual;
+          procedure second_string_to_chararray;virtual;
+          procedure second_array_to_pointer;virtual;
+          procedure second_pointer_to_array;virtual;
+          procedure second_chararray_to_string;virtual;
+          procedure second_char_to_string;virtual;
+          procedure second_int_to_real;virtual;
+          procedure second_real_to_fix;virtual;
+          procedure second_real_to_real;virtual;
+          procedure second_fix_to_real;virtual;
+          procedure second_cord_to_pointer;virtual;
+          procedure second_int_to_fix;virtual;
+          procedure second_proc_to_procvar;virtual;
+          procedure second_bool_to_int;virtual;
+          procedure second_int_to_bool;virtual;
+          procedure second_load_smallset;virtual;
+          procedure second_ansistring_to_pchar;virtual;
+          procedure second_pchar_to_string;virtual;
+          procedure second_nothing;virtual;
+          procedure pass_2;override;
+          procedure second_call_helper(c : tconverttype);
+       end;
+
+       ti386asnode = class(tasnode)
+          procedure pass_2;override;
+       end;
+
+       ti386isnode = class(tisnode)
+          procedure pass_2;override;
+       end;
+
+implementation
+
+   uses
+      cobjects,verbose,globtype,globals,systems,
+      symconst,symtable,aasm,
+      hcodegen,temp_gen,pass_2,pass_1,
+      ncon,ncal,
+      cpubase,cpuasm,
+      cgai386,tgeni386,n386util;
+
+
+{*****************************************************************************
+                             SecondTypeConv
+*****************************************************************************}
+
+    procedure ti386typeconvnode.second_int_to_int;
+      var
+        op      : tasmop;
+        opsize    : topsize;
+        hregister,
+        hregister2 : tregister;
+        l : pasmlabel;
+
+      begin
+        { insert range check if not explicit conversion }
+        if not(nf_explizit in flags) then
+          emitrangecheck(left,resulttype);
+
+        { is the result size smaller ? }
+        if resulttype^.size<left.resulttype^.size then
+          begin
+            { only need to set the new size of a register }
+            if (left.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then
+             begin
+               case resulttype^.size of
+                1 : location.register:=makereg8(left.location.register);
+                2 : location.register:=makereg16(left.location.register);
+                4 : location.register:=makereg32(left.location.register);
+               end;
+               { we can release the upper register }
+               if is_64bitint(left.resulttype) then
+                 ungetregister32(left.location.registerhigh);
+             end;
+          end
+
+        { is the result size bigger ? }
+        else if resulttype^.size>left.resulttype^.size then
+          begin
+            { remove reference }
+            if not(left.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then
+              begin
+                del_reference(left.location.reference);
+                { we can do this here as we need no temp inside }
+                ungetiftemp(left.location.reference);
+              end;
+
+            { get op and opsize, handle separate for constants, because
+              movz doesn't support constant values }
+            if (left.location.loc=LOC_MEM) and (left.location.reference.is_immediate) then
+             begin
+               if is_64bitint(resulttype) then
+                 opsize:=S_L
+               else
+                 opsize:=def_opsize(resulttype);
+               op:=A_MOV;
+             end
+            else
+             begin
+               opsize:=def2def_opsize(left.resulttype,resulttype);
+               if opsize in [S_B,S_W,S_L] then
+                op:=A_MOV
+               else
+                if is_signed(left.resulttype) then
+                 op:=A_MOVSX
+                else
+                 op:=A_MOVZX;
+             end;
+            { load the register we need }
+            if left.location.loc<>LOC_REGISTER then
+              hregister:=getregister32
+            else
+              hregister:=left.location.register;
+
+            { set the correct register size and location }
+            clear_location(location);
+            location.loc:=LOC_REGISTER;
+
+            { do we need a second register for a 64 bit type ? }
+            if is_64bitint(resulttype) then
+              begin
+                 hregister2:=getregister32;
+                 location.registerhigh:=hregister2;
+              end;
+            case resulttype^.size of
+             1:
+               location.register:=makereg8(hregister);
+             2:
+               location.register:=makereg16(hregister);
+             4,8:
+               location.register:=makereg32(hregister);
+            end;
+            { insert the assembler code }
+            if left.location.loc in [LOC_CREGISTER,LOC_REGISTER] then
+              emit_reg_reg(op,opsize,left.location.register,location.register)
+            else
+              emit_ref_reg(op,opsize,
+                newreference(left.location.reference),location.register);
+
+            { do we need a sign extension for int64? }
+            if is_64bitint(resulttype) then
+              begin
+                 emit_reg_reg(A_XOR,S_L,
+                   hregister2,hregister2);
+                 if (porddef(resulttype)^.typ=s64bit) and
+                   is_signed(left.resulttype) then
+                   begin
+                      getlabel(l);
+                      emit_const_reg(A_TEST,S_L,$80000000,makereg32(hregister));
+                      emitjmp(C_Z,l);
+                      emit_reg(A_NOT,S_L,
+                        hregister2);
+                      emitlab(l);
+                   end;
+              end;
+          end;
+      end;
+
+    procedure ti386typeconvnode.second_string_to_string;
+
+      var
+         pushed : tpushed;
+         regs_to_push: byte;
+
+      begin
+         { does anybody know a better solution than this big case statement ? }
+         { ok, a proc table would do the job                              }
+         case pstringdef(resulttype)^.string_typ of
+
+            st_shortstring:
+              case pstringdef(left.resulttype)^.string_typ of
+                 st_shortstring:
+                   begin
+                      gettempofsizereference(resulttype^.size,location.reference);
+                      copyshortstring(location.reference,left.location.reference,
+                        pstringdef(resulttype)^.len,false,true);
+{                      done by copyshortstring now (JM)          }
+{                      del_reference(left.location.reference); }
+                      ungetiftemp(left.location.reference);
+                   end;
+                 st_longstring:
+                   begin
+                      {!!!!!!!}
+                      internalerror(8888);
+                   end;
+                 st_ansistring:
+                   begin
+                      gettempofsizereference(resulttype^.size,location.reference);
+                      loadansi2short(left,self);
+                      { this is done in secondtypeconv (FK)
+                      removetemps(exprasmlist,temptoremove);
+                      destroys:=true;
+                      }
+                   end;
+                 st_widestring:
+                   begin
+                      {!!!!!!!}
+                      internalerror(8888);
+                   end;
+              end;
+
+            st_longstring:
+              case pstringdef(left.resulttype)^.string_typ of
+                 st_shortstring:
+                   begin
+                      {!!!!!!!}
+                      internalerror(8888);
+                   end;
+                 st_ansistring:
+                   begin
+                      {!!!!!!!}
+                      internalerror(8888);
+                   end;
+                 st_widestring:
+                   begin
+                      {!!!!!!!}
+                      internalerror(8888);
+                   end;
+              end;
+
+            st_ansistring:
+              case pstringdef(left.resulttype)^.string_typ of
+                 st_shortstring:
+                   begin
+                      clear_location(location);
+                      location.loc:=LOC_REFERENCE;
+                      gettempansistringreference(location.reference);
+                      decrstringref(cansistringdef,location.reference);
+                      { We don't need the source regs anymore (JM) }
+                      regs_to_push := $ff;
+                      remove_non_regvars_from_loc(left.location,regs_to_push);
+                      pushusedregisters(pushed,regs_to_push);
+                      release_loc(left.location);
+                      emit_push_lea_loc(left.location,true);
+                      emit_push_lea_loc(location,false);
+                      emitcall('FPC_SHORTSTR_TO_ANSISTR');
+                      maybe_loadesi;
+                      popusedregisters(pushed);
+                   end;
+                 st_longstring:
+                   begin
+                      {!!!!!!!}
+                      internalerror(8888);
+                   end;
+                 st_widestring:
+                   begin
+                      {!!!!!!!}
+                      internalerror(8888);
+                   end;
+              end;
+
+            st_widestring:
+              case pstringdef(left.resulttype)^.string_typ of
+                 st_shortstring:
+                   begin
+                      {!!!!!!!}
+                      internalerror(8888);
+                   end;
+                 st_longstring:
+                   begin
+                      {!!!!!!!}
+                      internalerror(8888);
+                   end;
+                 st_ansistring:
+                   begin
+                      {!!!!!!!}
+                      internalerror(8888);
+                   end;
+                 st_widestring:
+                   begin
+                      {!!!!!!!}
+                      internalerror(8888);
+                   end;
+              end;
+         end;
+      end;
+
+
+    procedure ti386typeconvnode.second_cstring_to_pchar;
+      var
+        hr : preference;
+      begin
+         clear_location(location);
+         location.loc:=LOC_REGISTER;
+         location.register:=getregister32;
+         case pstringdef(left.resulttype)^.string_typ of
+           st_shortstring :
+             begin
+               inc(left.location.reference.offset);
+               emit_ref_reg(A_LEA,S_L,newreference(left.location.reference),
+                 location.register);
+             end;
+           st_ansistring :
+             begin
+               if (left.nodetype=stringconstn) and
+                  (str_length(left)=0) then
+                begin
+                  new(hr);
+                  reset_reference(hr^);
+                  hr^.symbol:=newasmsymbol('FPC_EMPTYCHAR');
+                  emit_ref_reg(A_LEA,S_L,hr,location.register);
+                end
+               else
+                emit_ref_reg(A_MOV,S_L,newreference(left.location.reference),
+                  location.register);
+             end;
+           st_longstring:
+             begin
+               {!!!!!!!}
+               internalerror(8888);
+             end;
+           st_widestring:
+             begin
+               {!!!!!!!}
+               internalerror(8888);
+             end;
+         end;
+      end;
+
+
+    procedure ti386typeconvnode.second_string_to_chararray;
+      var
+         pushedregs: tpushed;
+         //l1 : pasmlabel;
+         //hr : preference;
+         arrsize, strtype: longint;
+         regstopush: byte;
+      begin
+         with parraydef(resulttype)^ do
+           arrsize := highrange-lowrange+1;
+
+         if (left.nodetype = stringconstn) and
+            { left.length+1 since there's always a terminating #0 character (JM) }
+            (tstringconstnode(left).len+1 >= arrsize) and
+            (pstringdef(left.resulttype)^.string_typ=st_shortstring) then
+           begin
+             inc(location.reference.offset);
+             exit;
+           end;
+         clear_location(location);
+         location.loc := LOC_REFERENCE;
+         gettempofsizereference(arrsize,location.reference);
+
+         regstopush := $ff;
+         remove_non_regvars_from_loc(left.location,regstopush);
+         pushusedregisters(pushedregs,regstopush);
+
+         emit_push_lea_loc(location,false);
+
+         case pstringdef(left.resulttype)^.string_typ of
+           st_shortstring :
+             begin
+               { 0 means shortstring }
+               strtype := 0;
+               del_reference(left.location.reference);
+               emit_push_lea_loc(left.location,true);
+               ungetiftemp(left.location.reference);
+             end;
+           st_ansistring :
+             begin
+               { 1 means ansistring }
+               strtype := 1;
+               case left.location.loc of
+                  LOC_CREGISTER,LOC_REGISTER:
+                    begin
+                      ungetregister(left.location.register);
+                      emit_push_loc(left.location);
+                    end;
+                  LOC_MEM,LOC_REFERENCE:
+                    begin
+                      del_reference(left.location.reference);
+                      emit_push_loc(left.location);
+                      ungetiftemp(left.location.reference);
+                    end;
+               end;
+             end;
+           st_longstring:
+             begin
+               {!!!!!!!}
+               { 2 means longstring, but still needs support in FPC_STR_TO_CHARARRAY,
+                 which is in i386.inc and/or generic.inc (JM) }
+               strtype := 2;
+
+               internalerror(8888);
+             end;
+           st_widestring:
+             begin
+               {!!!!!!!}
+               { 3 means widestring, but still needs support in FPC_STR_TO_CHARARRAY,
+                 which is in i386.inc and/or generic.inc (JM) }
+               strtype := 3;
+               internalerror(8888);
+             end;
+         end;
+         push_int(arrsize);
+         push_int(strtype);
+         emitcall('FPC_STR_TO_CHARARRAY');
+         popusedregisters(pushedregs);
+      end;
+
+
+    procedure ti386typeconvnode.second_array_to_pointer;
+      begin
+         del_reference(left.location.reference);
+         clear_location(location);
+         location.loc:=LOC_REGISTER;
+         location.register:=getregister32;
+         emit_ref_reg(A_LEA,S_L,newreference(left.location.reference),
+           location.register);
+      end;
+
+
+    procedure ti386typeconvnode.second_pointer_to_array;
+      begin
+        clear_location(location);
+        location.loc:=LOC_REFERENCE;
+        reset_reference(location.reference);
+        case left.location.loc of
+          LOC_REGISTER :
+            location.reference.base:=left.location.register;
+          LOC_CREGISTER :
+            begin
+              location.reference.base:=getregister32;
+              emit_reg_reg(A_MOV,S_L,left.location.register,location.reference.base);
+            end
+         else
+            begin
+              del_reference(left.location.reference);
+              location.reference.base:=getregister32;
+              emit_ref_reg(A_MOV,S_L,newreference(left.location.reference),
+                location.reference.base);
+            end;
+        end;
+      end;
+
+
+    { generates the code for the type conversion from an array of char }
+    { to a string                                                       }
+    procedure ti386typeconvnode.second_chararray_to_string;
+      var
+         pushed : tpushed;
+         regstopush: byte;
+         l : longint;
+      begin
+         { calc the length of the array }
+         l:=parraydef(left.resulttype)^.highrange-parraydef(left.resulttype)^.lowrange+1;
+         { this is a type conversion which copies the data, so we can't }
+         { return a reference                                        }
+         clear_location(location);
+         location.loc:=LOC_MEM;
+         case pstringdef(resulttype)^.string_typ of
+           st_shortstring :
+             begin
+               if l>255 then
+                begin
+                  CGMessage(type_e_mismatch);
+                  l:=255;
+                end;
+               gettempofsizereference(resulttype^.size,location.reference);
+               { we've also to release the registers ... }
+               { Yes, but before pushusedregisters since that one resets unused! }
+               { This caused web bug 1073 (JM)                                   }
+               regstopush := $ff;
+               remove_non_regvars_from_loc(left.location,regstopush);
+               pushusedregisters(pushed,regstopush);
+               if l>=resulttype^.size then
+                 push_int(resulttype^.size-1)
+               else
+                 push_int(l);
+               { ... here only the temp. location is released }
+               emit_push_lea_loc(left.location,true);
+               del_reference(left.location.reference);
+               emitpushreferenceaddr(location.reference);
+               emitcall('FPC_CHARARRAY_TO_SHORTSTR');
+               maybe_loadesi;
+               popusedregisters(pushed);
+             end;
+           st_ansistring :
+             begin
+               gettempansistringreference(location.reference);
+               decrstringref(cansistringdef,location.reference);
+               regstopush := $ff;
+               remove_non_regvars_from_loc(left.location,regstopush);
+               pushusedregisters(pushed,regstopush);
+               push_int(l);
+               emitpushreferenceaddr(left.location.reference);
+               release_loc(left.location);
+               emitpushreferenceaddr(location.reference);
+               emitcall('FPC_CHARARRAY_TO_ANSISTR');
+               popusedregisters(pushed);
+               maybe_loadesi;
+             end;
+           st_longstring:
+             begin
+               {!!!!!!!}
+               internalerror(8888);
+             end;
+           st_widestring:
+             begin
+               {!!!!!!!}
+               internalerror(8888);
+             end;
+        end;
+      end;
+
+
+    procedure ti386typeconvnode.second_char_to_string;
+      var
+        pushed : tpushed;
+
+      begin
+         clear_location(location);
+         location.loc:=LOC_MEM;
+         case pstringdef(resulttype)^.string_typ of
+           st_shortstring :
+             begin
+               gettempofsizereference(256,location.reference);
+               loadshortstring(left,self);
+             end;
+           st_ansistring :
+             begin
+               gettempansistringreference(location.reference);
+               decrstringref(cansistringdef,location.reference);
+               release_loc(left.location);
+               pushusedregisters(pushed,$ff);
+               emit_pushw_loc(left.location);
+               emitpushreferenceaddr(location.reference);
+               emitcall('FPC_CHAR_TO_ANSISTR');
+               popusedregisters(pushed);
+               maybe_loadesi;
+             end;
+           else
+            internalerror(4179);
+        end;
+      end;
+
+
+    procedure ti386typeconvnode.second_int_to_real;
+
+      var
+         r : preference;
+         hregister : tregister;
+         l1,l2 : pasmlabel;
+
+      begin
+         { for u32bit a solution is to push $0 and to load a comp }
+         { does this first, it destroys maybe EDI }
+         hregister:=R_EDI;
+         if porddef(left.resulttype)^.typ=u32bit then
+            push_int(0);
+         if (left.location.loc=LOC_REGISTER) or
+            (left.location.loc=LOC_CREGISTER) then
+           begin
+{$ifndef noAllocEdi}
+              if not (porddef(left.resulttype)^.typ in [u32bit,s32bit,u64bit,s64bit]) then
+                getexplicitregister32(R_EDI);
+{$endif noAllocEdi}
+              case porddef(left.resulttype)^.typ of
+                 s8bit : emit_reg_reg(A_MOVSX,S_BL,left.location.register,R_EDI);
+                 u8bit : emit_reg_reg(A_MOVZX,S_BL,left.location.register,R_EDI);
+                 s16bit : emit_reg_reg(A_MOVSX,S_WL,left.location.register,R_EDI);
+                 u16bit : emit_reg_reg(A_MOVZX,S_WL,left.location.register,R_EDI);
+                 u32bit,s32bit:
+                   hregister:=left.location.register;
+                 u64bit,s64bit:
+                   begin
+                      emit_reg(A_PUSH,S_L,left.location.registerhigh);
+                      hregister:=left.location.registerlow;
+                   end;
+              end;
+              ungetregister(left.location.register);
+           end
+         else
+           begin
+              r:=newreference(left.location.reference);
+{$ifndef noAllocEdi}
+              getexplicitregister32(R_EDI);
+{$endif noAllocEdi}
+              case porddef(left.resulttype)^.typ of
+                 s8bit:
+                   emit_ref_reg(A_MOVSX,S_BL,r,R_EDI);
+                 u8bit:
+                   emit_ref_reg(A_MOVZX,S_BL,r,R_EDI);
+                 s16bit:
+                   emit_ref_reg(A_MOVSX,S_WL,r,R_EDI);
+                 u16bit:
+                   emit_ref_reg(A_MOVZX,S_WL,r,R_EDI);
+                 u32bit,s32bit:
+                   emit_ref_reg(A_MOV,S_L,r,R_EDI);
+                 u64bit,s64bit:
+                   begin
+                      inc(r^.offset,4);
+                      emit_ref_reg(A_MOV,S_L,r,R_EDI);
+                      emit_reg(A_PUSH,S_L,R_EDI);
+                      r:=newreference(left.location.reference);
+                      emit_ref_reg(A_MOV,S_L,r,R_EDI);
+                   end;
+              end;
+              del_reference(left.location.reference);
+              ungetiftemp(left.location.reference);
+           end;
+         { for 64 bit integers, the high dword is already pushed }
+         emit_reg(A_PUSH,S_L,hregister);
+{$ifndef noAllocEdi}
+         if hregister = R_EDI then
+           ungetregister32(R_EDI);
+{$endif noAllocEdi}
+         r:=new_reference(R_ESP,0);
+         case porddef(left.resulttype)^.typ of
+           u32bit:
+             begin
+                emit_ref(A_FILD,S_IQ,r);
+                emit_const_reg(A_ADD,S_L,8,R_ESP);
+             end;
+           s64bit:
+             begin
+                emit_ref(A_FILD,S_IQ,r);
+                emit_const_reg(A_ADD,S_L,8,R_ESP);
+             end;
+           u64bit:
+             begin
+                { unsigned 64 bit ints are harder to handle: }
+                { we load bits 0..62 and then check bit 63:  }
+                { if it is 1 then we add $80000000 000000000 }
+                { as double                                  }
+                inc(r^.offset,4);
+{$ifndef noAllocEdi}
+                getexplicitregister32(R_EDI);
+{$endif noAllocEdi}
+                emit_ref_reg(A_MOV,S_L,r,R_EDI);
+                r:=new_reference(R_ESP,4);
+                emit_const_ref(A_AND,S_L,$7fffffff,r);
+                emit_const_reg(A_TEST,S_L,$80000000,R_EDI);
+{$ifndef noAllocEdi}
+                ungetregister32(R_EDI);
+{$endif noAllocEdi}
+                r:=new_reference(R_ESP,0);
+                emit_ref(A_FILD,S_IQ,r);
+                getdatalabel(l1);
+                getlabel(l2);
+                emitjmp(C_Z,l2);
+                consts^.concat(new(pai_label,init(l1)));
+                { I got this constant from a test progtram (FK) }
+                consts^.concat(new(pai_const,init_32bit(0)));
+                consts^.concat(new(pai_const,init_32bit(1138753536)));
+                r:=new_reference(R_NO,0);
+                r^.symbol:=l1;
+                emit_ref(A_FADD,S_FL,r);
+                emitlab(l2);
+                emit_const_reg(A_ADD,S_L,8,R_ESP);
+             end
+           else
+             begin
+                emit_ref(A_FILD,S_IL,r);
+{$ifndef noAllocEdi}
+                getexplicitregister32(R_EDI);
+{$endif noAllocEdi}
+                emit_reg(A_POP,S_L,R_EDI);
+{$ifndef noAllocEdi}
+                ungetregister32(R_EDI);
+{$endif noAllocEdi}
+             end;
+         end;
+         inc(fpuvaroffset);
+         clear_location(location);
+         location.loc:=LOC_FPU;
+      end;
+
+
+    procedure ti386typeconvnode.second_real_to_fix;
+      var
+         rreg : tregister;
+         ref : treference;
+      begin
+         { real must be on fpu stack }
+         if (left.location.loc<>LOC_FPU) then
+           emit_ref(A_FLD,S_FL,newreference(left.location.reference));
+         push_int($1f3f);
+         push_int(65536);
+         reset_reference(ref);
+         ref.base:=R_ESP;
+
+         emit_ref(A_FIMUL,S_IL,newreference(ref));
+
+         ref.offset:=4;
+         emit_ref(A_FSTCW,S_NO,newreference(ref));
+
+         ref.offset:=6;
+         emit_ref(A_FLDCW,S_NO,newreference(ref));
+
+         ref.offset:=0;
+         emit_ref(A_FISTP,S_IL,newreference(ref));
+
+         ref.offset:=4;
+         emit_ref(A_FLDCW,S_NO,newreference(ref));
+
+         rreg:=getregister32;
+         emit_reg(A_POP,S_L,rreg);
+         { better than an add on all processors }
+{$ifndef noAllocEdi}
+         getexplicitregister32(R_EDI);
+{$endif noAllocEdi}
+         emit_reg(A_POP,S_L,R_EDI);
+{$ifndef noAllocEdi}
+         ungetregister32(R_EDI);
+{$endif noAllocEdi}
+
+         clear_location(location);
+         location.loc:=LOC_REGISTER;
+         location.register:=rreg;
+         inc(fpuvaroffset);
+      end;
+
+
+    procedure ti386typeconvnode.second_real_to_real;
+      begin
+         case left.location.loc of
+            LOC_FPU : ;
+            LOC_CFPUREGISTER:
+              begin
+                 location:=left.location;
+                 exit;
+              end;
+            LOC_MEM,
+            LOC_REFERENCE:
+              begin
+                 floatload(pfloatdef(left.resulttype)^.typ,
+                   left.location.reference);
+                 { we have to free the reference }
+                 del_reference(left.location.reference);
+              end;
+         end;
+         clear_location(location);
+         location.loc:=LOC_FPU;
+      end;
+
+
+    procedure ti386typeconvnode.second_fix_to_real;
+      var
+        popeax,popebx,popecx,popedx : boolean;
+        startreg : tregister;
+        hl : pasmlabel;
+        r : treference;
+      begin
+         if (left.location.loc=LOC_REGISTER) or
+            (left.location.loc=LOC_CREGISTER) then
+           begin
+              startreg:=left.location.register;
+              ungetregister(startreg);
+              popeax:=(startreg<>R_EAX) and not (R_EAX in unused);
+              if popeax then
+                emit_reg(A_PUSH,S_L,R_EAX);
+              { mov eax,eax is removed by emit_reg_reg }
+              emit_reg_reg(A_MOV,S_L,startreg,R_EAX);
+           end
+         else
+           begin
+              emit_ref_reg(A_MOV,S_L,newreference(
+                left.location.reference),R_EAX);
+              del_reference(left.location.reference);
+              startreg:=R_NO;
+           end;
+
+         popebx:=(startreg<>R_EBX) and not (R_EBX in unused);
+         if popebx then
+           emit_reg(A_PUSH,S_L,R_EBX);
+
+         popecx:=(startreg<>R_ECX) and not (R_ECX in unused);
+         if popecx then
+           emit_reg(A_PUSH,S_L,R_ECX);
+
+         popedx:=(startreg<>R_EDX) and not (R_EDX in unused);
+         if popedx then
+           emit_reg(A_PUSH,S_L,R_EDX);
+
+         emit_none(A_CDQ,S_NO);
+         emit_reg_reg(A_XOR,S_L,R_EDX,R_EAX);
+         emit_reg_reg(A_MOV,S_L,R_EAX,R_EBX);
+         emit_reg_reg(A_SUB,S_L,R_EDX,R_EAX);
+         getlabel(hl);
+         emitjmp(C_Z,hl);
+         emit_const_reg(A_RCL,S_L,1,R_EBX);
+         emit_reg_reg(A_BSR,S_L,R_EAX,R_EDX);
+         emit_const_reg(A_MOV,S_B,32,R_CL);
+         emit_reg_reg(A_SUB,S_B,R_DL,R_CL);
+         emit_reg_reg(A_SHL,S_L,R_CL,R_EAX);
+         emit_const_reg(A_ADD,S_W,1007,R_DX);
+         emit_const_reg(A_SHL,S_W,5,R_DX);
+         emit_const_reg_reg(A_SHLD,S_W,11,R_DX,R_BX);
+         emit_const_reg_reg(A_SHLD,S_L,20,R_EAX,R_EBX);
+
+         emit_const_reg(A_SHL,S_L,20,R_EAX);
+         emitlab(hl);
+         { better than an add on all processors }
+         emit_reg(A_PUSH,S_L,R_EBX);
+         emit_reg(A_PUSH,S_L,R_EAX);
+
+         reset_reference(r);
+         r.base:=R_ESP;
+         emit_ref(A_FLD,S_FL,newreference(r));
+         emit_const_reg(A_ADD,S_L,8,R_ESP);
+         if popedx then
+           emit_reg(A_POP,S_L,R_EDX);
+         if popecx then
+           emit_reg(A_POP,S_L,R_ECX);
+         if popebx then
+           emit_reg(A_POP,S_L,R_EBX);
+         if popeax then
+           emit_reg(A_POP,S_L,R_EAX);
+
+         clear_location(location);
+         location.loc:=LOC_FPU;
+      end;
+
+
+    procedure ti386typeconvnode.second_cord_to_pointer;
+      begin
+        { this can't happend, because constants are already processed in
+          pass 1 }
+        internalerror(47423985);
+      end;
+
+
+    procedure ti386typeconvnode.second_int_to_fix;
+      var
+         hregister : tregister;
+      begin
+         if (left.location.loc=LOC_REGISTER) then
+           hregister:=left.location.register
+         else if (left.location.loc=LOC_CREGISTER) then
+           hregister:=getregister32
+         else
+           begin
+              del_reference(left.location.reference);
+              hregister:=getregister32;
+              case porddef(left.resulttype)^.typ of
+                s8bit : emit_ref_reg(A_MOVSX,S_BL,newreference(left.location.reference),
+                  hregister);
+                u8bit : emit_ref_reg(A_MOVZX,S_BL,newreference(left.location.reference),
+                  hregister);
+                s16bit : emit_ref_reg(A_MOVSX,S_WL,newreference(left.location.reference),
+                  hregister);
+                u16bit : emit_ref_reg(A_MOVZX,S_WL,newreference(left.location.reference),
+                  hregister);
+                u32bit,s32bit : emit_ref_reg(A_MOV,S_L,newreference(left.location.reference),
+                  hregister);
+                {!!!! u32bit }
+              end;
+           end;
+         emit_const_reg(A_SHL,S_L,16,hregister);
+
+         clear_location(location);
+         location.loc:=LOC_REGISTER;
+         location.register:=hregister;
+      end;
+
+
+    procedure ti386typeconvnode.second_proc_to_procvar;
+      begin
+        { method pointer ? }
+        if assigned(tcallnode(left).left) then
+          begin
+             set_location(location,left.location);
+          end
+        else
+          begin
+             clear_location(location);
+             location.loc:=LOC_REGISTER;
+             location.register:=getregister32;
+             del_reference(left.location.reference);
+             emit_ref_reg(A_LEA,S_L,
+               newreference(left.location.reference),location.register);
+          end;
+      end;
+
+
+    procedure ti386typeconvnode.second_bool_to_int;
+      var
+         oldtruelabel,oldfalselabel,hlabel : pasmlabel;
+         hregister : tregister;
+         newsize,
+         opsize : topsize;
+         op     : tasmop;
+      begin
+         oldtruelabel:=truelabel;
+         oldfalselabel:=falselabel;
+         getlabel(truelabel);
+         getlabel(falselabel);
+         secondpass(left);
+         { byte(boolean) or word(wordbool) or longint(longbool) must
+         be accepted for var parameters }
+         if (nf_explizit in flags) and
+            (left.resulttype^.size=resulttype^.size) and
+            (left.location.loc in [LOC_REFERENCE,LOC_MEM,LOC_CREGISTER]) then
+           begin
+              set_location(location,left.location);
+              truelabel:=oldtruelabel;
+              falselabel:=oldfalselabel;
+              exit;
+           end;
+         clear_location(location);
+         location.loc:=LOC_REGISTER;
+         del_reference(left.location.reference);
+         case left.resulttype^.size of
+          1 : begin
+                case resulttype^.size of
+                 1 : opsize:=S_B;
+                 2 : opsize:=S_BW;
+                 4 : opsize:=S_BL;
+                end;
+              end;
+          2 : begin
+                case resulttype^.size of
+                 1 : begin
+                       if left.location.loc in [LOC_REGISTER,LOC_CREGISTER] then
+                        left.location.register:=reg16toreg8(left.location.register);
+                       opsize:=S_B;
+                     end;
+                 2 : opsize:=S_W;
+                 4 : opsize:=S_WL;
+                end;
+              end;
+          4 : begin
+                case resulttype^.size of
+                 1 : begin
+                       if left.location.loc in [LOC_REGISTER,LOC_CREGISTER] then
+                        left.location.register:=reg32toreg8(left.location.register);
+                       opsize:=S_B;
+                     end;
+                 2 : begin
+                       if left.location.loc in [LOC_REGISTER,LOC_CREGISTER] then
+                        left.location.register:=reg32toreg16(left.location.register);
+                       opsize:=S_W;
+                     end;
+                 4 : opsize:=S_L;
+                end;
+              end;
+         end;
+         if opsize in [S_B,S_W,S_L] then
+          op:=A_MOV
+         else
+          if is_signed(resulttype) then
+           op:=A_MOVSX
+          else
+           op:=A_MOVZX;
+         hregister:=getregister32;
+         case resulttype^.size of
+          1 : begin
+                location.register:=reg32toreg8(hregister);
+                newsize:=S_B;
+              end;
+          2 : begin
+                location.register:=reg32toreg16(hregister);
+                newsize:=S_W;
+              end;
+          4 : begin
+                location.register:=hregister;
+                newsize:=S_L;
+              end;
+         else
+          internalerror(10060);
+         end;
+
+         case left.location.loc of
+            LOC_MEM,
+      LOC_REFERENCE : emit_ref_reg(op,opsize,
+                        newreference(left.location.reference),location.register);
+       LOC_REGISTER,
+      LOC_CREGISTER : begin
+                      { remove things like movb %al,%al }
+                        if left.location.register<>location.register then
+                          emit_reg_reg(op,opsize,
+                            left.location.register,location.register);
+                      end;
+          LOC_FLAGS : begin
+                        emit_flag2reg(left.location.resflags,location.register);
+                      end;
+           LOC_JUMP : begin
+                        getlabel(hlabel);
+                        emitlab(truelabel);
+                        emit_const_reg(A_MOV,newsize,1,location.register);
+                        emitjmp(C_None,hlabel);
+                        emitlab(falselabel);
+                        emit_reg_reg(A_XOR,newsize,location.register,
+                          location.register);
+                        emitlab(hlabel);
+                      end;
+         else
+           internalerror(10061);
+         end;
+         truelabel:=oldtruelabel;
+         falselabel:=oldfalselabel;
+      end;
+
+
+    procedure ti386typeconvnode.second_int_to_bool;
+      var
+        hregister : tregister;
+        resflags  : tresflags;
+        opsize    : topsize;
+      begin
+         clear_location(location);
+         { byte(boolean) or word(wordbool) or longint(longbool) must
+         be accepted for var parameters }
+         if (nf_explizit in flags) and
+            (left.resulttype^.size=resulttype^.size) and
+            (left.location.loc in [LOC_REFERENCE,LOC_MEM,LOC_CREGISTER]) then
+           begin
+              set_location(location,left.location);
+              exit;
+           end;
+         location.loc:=LOC_REGISTER;
+         del_reference(left.location.reference);
+         opsize:=def_opsize(left.resulttype);
+         case left.location.loc of
+            LOC_MEM,LOC_REFERENCE :
+              begin
+                hregister:=def_getreg(left.resulttype);
+                emit_ref_reg(A_MOV,opsize,
+                  newreference(left.location.reference),hregister);
+                emit_reg_reg(A_OR,opsize,hregister,hregister);
+                resflags:=F_NE;
+              end;
+            LOC_FLAGS :
+              begin
+                hregister:=getregister32;
+                resflags:=left.location.resflags;
+              end;
+            LOC_REGISTER,LOC_CREGISTER :
+              begin
+                hregister:=left.location.register;
+                emit_reg_reg(A_OR,opsize,hregister,hregister);
+                resflags:=F_NE;
+              end;
+            else
+              internalerror(10062);
+         end;
+         case resulttype^.size of
+          1 : location.register:=makereg8(hregister);
+          2 : location.register:=makereg16(hregister);
+          4 : location.register:=makereg32(hregister);
+         else
+          internalerror(10064);
+         end;
+         emit_flag2reg(resflags,location.register);
+      end;
+
+
+    procedure ti386typeconvnode.second_load_smallset;
+      var
+        href : treference;
+        pushedregs : tpushed;
+      begin
+        href.symbol:=nil;
+        pushusedregisters(pushedregs,$ff);
+        gettempofsizereference(32,href);
+        emitpushreferenceaddr(left.location.reference);
+        emitpushreferenceaddr(href);
+        emitcall('FPC_SET_LOAD_SMALL');
+        maybe_loadesi;
+        popusedregisters(pushedregs);
+        clear_location(location);
+        location.loc:=LOC_MEM;
+        location.reference:=href;
+      end;
+
+
+    procedure ti386typeconvnode.second_ansistring_to_pchar;
+      var
+         l1 : pasmlabel;
+         hr : preference;
+      begin
+         clear_location(location);
+         location.loc:=LOC_REGISTER;
+         getlabel(l1);
+         case left.location.loc of
+            LOC_CREGISTER,LOC_REGISTER:
+              location.register:=left.location.register;
+            LOC_MEM,LOC_REFERENCE:
+              begin
+                location.register:=getregister32;
+                emit_ref_reg(A_MOV,S_L,newreference(left.location.reference),
+                  location.register);
+                del_reference(left.location.reference);
+              end;
+         end;
+         emit_const_reg(A_CMP,S_L,0,location.register);
+         emitjmp(C_NZ,l1);
+         new(hr);
+         reset_reference(hr^);
+         hr^.symbol:=newasmsymbol('FPC_EMPTYCHAR');
+         emit_ref_reg(A_LEA,S_L,hr,location.register);
+         emitlab(l1);
+      end;
+
+
+    procedure ti386typeconvnode.second_pchar_to_string;
+      var
+        pushed : tpushed;
+        regs_to_push: byte;
+      begin
+         case pstringdef(resulttype)^.string_typ of
+           st_shortstring:
+             begin
+                location.loc:=LOC_REFERENCE;
+                gettempofsizereference(resulttype^.size,location.reference);
+                pushusedregisters(pushed,$ff);
+                case left.location.loc of
+                   LOC_REGISTER,LOC_CREGISTER:
+                     begin
+                        emit_reg(A_PUSH,S_L,left.location.register);
+                        ungetregister32(left.location.register);
+                     end;
+                   LOC_REFERENCE,LOC_MEM:
+                     begin
+                       { Now release the registers (see cgai386.pas:     }
+                       { loadansistring for more info on the order) (JM) }
+                        del_reference(left.location.reference);
+                        emit_push_mem(left.location.reference);
+                     end;
+                end;
+                emitpushreferenceaddr(location.reference);
+                emitcall('FPC_PCHAR_TO_SHORTSTR');
+                maybe_loadesi;
+                popusedregisters(pushed);
+             end;
+           st_ansistring:
+             begin
+                location.loc:=LOC_REFERENCE;
+                gettempansistringreference(location.reference);
+                decrstringref(cansistringdef,location.reference);
+                { Find out which regs have to be pushed (JM) }
+                regs_to_push := $ff;
+                remove_non_regvars_from_loc(left.location,regs_to_push);
+                pushusedregisters(pushed,regs_to_push);
+                case left.location.loc of
+                  LOC_REFERENCE,LOC_MEM:
+                    begin
+                      { Now release the registers (see cgai386.pas:     }
+                      { loadansistring for more info on the order) (JM) }
+                      del_reference(left.location.reference);
+                      emit_push_mem(left.location.reference);
+                    end;
+                  LOC_REGISTER,LOC_CREGISTER:
+                    begin
+                       { Now release the registers (see cgai386.pas:     }
+                       { loadansistring for more info on the order) (JM) }
+                      emit_reg(A_PUSH,S_L,left.location.register);
+                      ungetregister32(left.location.register);
+                   end;
+                end;
+                emitpushreferenceaddr(location.reference);
+                emitcall('FPC_PCHAR_TO_ANSISTR');
+                maybe_loadesi;
+                popusedregisters(pushed);
+             end;
+         else
+          begin
+            internalerror(12121);
+          end;
+         end;
+      end;
+
+
+    procedure ti386typeconvnode.second_nothing;
+      begin
+      end;
+
+
+{****************************************************************************
+                           TI386TYPECONVNODE
+****************************************************************************}
+
+    procedure ti386typeconvnode.second_call_helper(c : tconverttype);
+
+      const
+         secondconvert : array[tconverttype] of pointer = (
+           @ti386typeconvnode.second_nothing, {equal}
+           @ti386typeconvnode.second_nothing, {not_possible}
+           @ti386typeconvnode.second_string_to_string,
+           @ti386typeconvnode.second_char_to_string,
+           @ti386typeconvnode.second_pchar_to_string,
+           @ti386typeconvnode.second_nothing, {cchar_to_pchar}
+           @ti386typeconvnode.second_cstring_to_pchar,
+           @ti386typeconvnode.second_ansistring_to_pchar,
+           @ti386typeconvnode.second_string_to_chararray,
+           @ti386typeconvnode.second_chararray_to_string,
+           @ti386typeconvnode.second_array_to_pointer,
+           @ti386typeconvnode.second_pointer_to_array,
+           @ti386typeconvnode.second_int_to_int,
+           @ti386typeconvnode.second_int_to_bool,
+           @ti386typeconvnode.second_bool_to_int, { bool_to_bool }
+           @ti386typeconvnode.second_bool_to_int,
+           @ti386typeconvnode.second_real_to_real,
+           @ti386typeconvnode.second_int_to_real,
+           @ti386typeconvnode.second_int_to_fix,
+           @ti386typeconvnode.second_real_to_fix,
+           @ti386typeconvnode.second_fix_to_real,
+           @ti386typeconvnode.second_proc_to_procvar,
+           @ti386typeconvnode.second_nothing, {arrayconstructor_to_set}
+           @ti386typeconvnode.second_load_smallset,
+           @ti386typeconvnode.second_cord_to_pointer
+         );
+      type
+         tprocedureofobject = procedure of object;
+
+      var
+         r : packed record
+                proc : pointer;
+                obj : pointer;
+             end;
+
+      begin
+         { this is a little bit dirty but it works }
+         { and should be quite portable too        }
+         r.proc:=secondconvert[c];
+         r.obj:=self;
+         tprocedureofobject(r){$ifdef FPC}();{$endif FPC}
+      end;
+
+    procedure ti386typeconvnode.pass_2;
+{$ifdef TESTOBJEXT2}
+      var
+         r : preference;
+         nillabel : plabel;
+{$endif TESTOBJEXT2}
+      begin
+
+         { this isn't good coding, I think tc_bool_2_int, shouldn't be }
+         { type conversion (FK)                                 }
+
+         if not(convtype in [tc_bool_2_int,tc_bool_2_bool]) then
+           begin
+              secondpass(left);
+              set_location(location,left.location);
+              if codegenerror then
+               exit;
+           end;
+         second_call_helper(convtype);
+
+{$ifdef TESTOBJEXT2}
+                  { Check explicit conversions to objects pointers !! }
+                     if p^.explizit and
+                        (p^.resulttype^.deftype=pointerdef) and
+                        (ppointerdef(p^.resulttype)^.definition^.deftype=objectdef) and not
+                        (pobjectdef(ppointerdef(p^.resulttype)^.definition)^.isclass) and
+                        ((pobjectdef(ppointerdef(p^.resulttype)^.definition)^.options and oo_hasvmt)<>0) and
+                        (cs_check_range in aktlocalswitches) then
+                       begin
+                          new(r);
+                          reset_reference(r^);
+                          if p^.location.loc in [LOC_REGISTER,LOC_CREGISTER] then
+                           r^.base:=p^.location.register
+                          else
+                            begin
+{$ifndef noAllocEdi}
+                               getexplicitregister32(R_EDI);
+{$endif noAllocEdi}
+                               emit_mov_loc_reg(p^.location,R_EDI);
+                               r^.base:=R_EDI;
+                            end;
+                          { NIL must be accepted !! }
+                          emit_reg_reg(A_OR,S_L,r^.base,r^.base);
+{$ifndef noAllocEdi}
+                          ungetregister32(R_EDI);
+{$endif noAllocEdi}
+                          getlabel(nillabel);
+                          emitjmp(C_E,nillabel);
+                          { this is one point where we need vmt_offset (PM) }
+                          r^.offset:= pobjectdef(ppointerdef(p^.resulttype)^.definition)^.vmt_offset;
+{$ifndef noAllocEdi}
+                          getexplicitregister32(R_EDI);
+{$endif noAllocEdi}
+                          emit_ref_reg(A_MOV,S_L,r,R_EDI);
+                          emit_sym(A_PUSH,S_L,
+                            newasmsymbol(pobjectdef(ppointerdef(p^.resulttype)^.definition)^.vmt_mangledname));
+                          emit_reg(A_PUSH,S_L,R_EDI);
+{$ifndef noAllocEdi}
+                          ungetregister32(R_EDI);
+{$endif noAllocEdi}
+                          emitcall('FPC_CHECK_OBJECT_EXT');
+                          emitlab(nillabel);
+                       end;
+{$endif TESTOBJEXT2}
+      end;
+
+
+{*****************************************************************************
+                             TI386ISNODE
+*****************************************************************************}
+
+    procedure ti386isnode.pass_2;
+      var
+         pushed : tpushed;
+
+      begin
+         { save all used registers }
+         pushusedregisters(pushed,$ff);
+         secondpass(left);
+         clear_location(location);
+         location.loc:=LOC_FLAGS;
+         location.resflags:=F_NE;
+
+         { push instance to check: }
+         case left.location.loc of
+            LOC_REGISTER,LOC_CREGISTER:
+              begin
+                 emit_reg(A_PUSH,
+                   S_L,left.location.register);
+                 ungetregister32(left.location.register);
+              end;
+            LOC_MEM,LOC_REFERENCE:
+              begin
+                 emit_ref(A_PUSH,
+                   S_L,newreference(left.location.reference));
+                 del_reference(left.location.reference);
+              end;
+            else internalerror(100);
+         end;
+
+         { generate type checking }
+         secondpass(right);
+         case right.location.loc of
+            LOC_REGISTER,LOC_CREGISTER:
+              begin
+                 emit_reg(A_PUSH,
+                   S_L,right.location.register);
+                 ungetregister32(right.location.register);
+              end;
+            LOC_MEM,LOC_REFERENCE:
+              begin
+                 emit_ref(A_PUSH,
+                   S_L,newreference(right.location.reference));
+                 del_reference(right.location.reference);
+              end;
+            else internalerror(100);
+         end;
+         emitcall('FPC_DO_IS');
+         emit_reg_reg(A_OR,S_B,R_AL,R_AL);
+         popusedregisters(pushed);
+         maybe_loadesi;
+      end;
+
+
+{*****************************************************************************
+                             TI386ASNODE
+*****************************************************************************}
+
+    procedure ti386asnode.pass_2;
+      var
+         pushed : tpushed;
+      begin
+         secondpass(left);
+         { save all used registers }
+         pushusedregisters(pushed,$ff);
+
+         { push instance to check: }
+         case left.location.loc of
+            LOC_REGISTER,LOC_CREGISTER:
+              emit_reg(A_PUSH,
+                S_L,left.location.register);
+            LOC_MEM,LOC_REFERENCE:
+              emit_ref(A_PUSH,
+                S_L,newreference(left.location.reference));
+            else internalerror(100);
+         end;
+
+         { we doesn't modifiy the left side, we check only the type }
+         set_location(location,left.location);
+
+         { generate type checking }
+         secondpass(right);
+         case right.location.loc of
+            LOC_REGISTER,LOC_CREGISTER:
+              begin
+                 emit_reg(A_PUSH,
+                   S_L,right.location.register);
+                 ungetregister32(right.location.register);
+              end;
+            LOC_MEM,LOC_REFERENCE:
+              begin
+                 emit_ref(A_PUSH,
+                   S_L,newreference(right.location.reference));
+                 del_reference(right.location.reference);
+              end;
+            else internalerror(100);
+         end;
+         emitcall('FPC_DO_AS');
+         { restore register, this restores automatically the }
+         { result                                           }
+         popusedregisters(pushed);
+         maybe_loadesi;
+      end;
+
+begin
+   ctypeconvnode:=ti386typeconvnode;
+   cisnode:=ti386isnode;
+   casnode:=ti386asnode;
+end.
+{
+  $Log$
+  Revision 1.1  2000-10-14 10:14:48  peter
+    * moehrendorf oct 2000 rewrite
+
+}

compiler/n386con.pas

@@ -49,6 +49,7 @@ interface
        ti386stringconstnode = class(tstringconstnode)
           procedure pass_2;override;
        end;
+
        ti386setconstnode = class(tsetconstnode)
           procedure pass_2;override;
        end;
@@ -63,7 +64,7 @@ implementation
     uses
       globtype,systems,
       cobjects,verbose,globals,
-      symconst,symtable,aasm,
+      symconst,symtable,aasm,types,
       hcodegen,temp_gen,pass_2,
       cpubase,cpuasm,
       cgai386,tgeni386;
@@ -229,7 +230,7 @@ implementation
       begin
          { for empty ansistrings we could return a constant 0 }
          if is_ansistring(resulttype) and
-            (length=0) then
+            (len=0) then
           begin
             location.loc:=LOC_MEM;
             location.reference.is_immediate:=true;
@@ -241,9 +242,9 @@ implementation
          if not assigned(lab_str) then
            begin
               if is_shortstring(resulttype) then
-               mylength:=length+2
+               mylength:=len+2
               else
-               mylength:=length+1;
+               mylength:=len+1;
               { tries to found an old entry }
               hp1:=pai(consts^.first);
               while assigned(hp1) do
@@ -266,7 +267,7 @@ implementation
                                set the start index to 1 }
                              if is_shortstring(resulttype) then
                               begin
-                                if length<>ord(pai_string(hp1)^.str[0]) then
+                                if len<>ord(pai_string(hp1)^.str[0]) then
                                  same_string:=false;
                                 j:=1;
                               end
@@ -275,7 +276,7 @@ implementation
                              { don't check if the length byte was already wrong }
                              if same_string then
                               begin
-                                for i:=0 to length do
+                                for i:=0 to len do
                                  begin
                                    if pai_string(hp1)^.str[j]<>value_str[i] then
                                     begin
@@ -318,7 +319,7 @@ implementation
                       st_ansistring:
                         begin
                            { an empty ansi string is nil! }
-                           if length=0 then
+                           if len=0 then
                              consts^.concat(new(pai_const,init_32bit(0)))
                            else
                              begin
@@ -326,16 +327,16 @@ implementation
                                 getdatalabel(l2);
                                 consts^.concat(new(pai_label,init(l2)));
                                 consts^.concat(new(pai_const_symbol,init(l1)));
-                                consts^.concat(new(pai_const,init_32bit(length)));
-                                consts^.concat(new(pai_const,init_32bit(length)));
+                                consts^.concat(new(pai_const,init_32bit(len)));
+                                consts^.concat(new(pai_const,init_32bit(len)));
                                 consts^.concat(new(pai_const,init_32bit(-1)));
                                 consts^.concat(new(pai_label,init(l1)));
-                                getmem(pc,length+2);
-                                move(value_str^,pc^,length);
-                                pc[length]:=#0;
+                                getmem(pc,len+2);
+                                move(value_str^,pc^,len);
+                                pc[len]:=#0;
                                 { to overcome this problem we set the length explicitly }
                                 { with the ending null char }
-                                consts^.concat(new(pai_string,init_length_pchar(pc,length+1)));
+                                consts^.concat(new(pai_string,init_length_pchar(pc,len+1)));
                                 { return the offset of the real string }
                                 lab_str:=l2;
                              end;
@@ -343,10 +344,10 @@ implementation
                       st_shortstring:
                         begin
                           { truncate strings larger than 255 chars }
-                          if length>255 then
+                          if len>255 then
                            l:=255
                           else
-                           l:=length;
+                           l:=len;
                           { also length and terminating zero }
                           getmem(pc,l+3);
                           move(value_str^,pc[1],l+1);
@@ -487,7 +488,9 @@ begin
 end.
 {
   $Log$
-  Revision 1.1  2000-09-28 20:48:52  florian
-  *** empty log message ***
+  Revision 1.2  2000-10-14 10:14:48  peter
+    * moehrendorf oct 2000 rewrite
 
+  Revision 1.1  2000/09/28 20:48:52  florian
+  *** empty log message ***
 }

compiler/n386flw.pas

@@ -0,0 +1,1290 @@
+{
+    $Id$
+    Copyright (c) 1998-2000 by Florian Klaempfl
+
+    Generate i386 assembler for nodes that influence the flow
+
+    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 n386flw;
+
+{$i defines.inc}
+
+interface
+
+    uses
+      node,nflw;
+
+    type
+       ti386whilerepeatnode = class(twhilerepeatnode)
+          procedure pass_2;override;
+       end;
+
+       ti386ifnode = class(tifnode)
+          procedure pass_2;override;
+       end;
+
+       ti386fornode = class(tfornode)
+          procedure pass_2;override;
+       end;
+
+       ti386exitnode = class(texitnode)
+          procedure pass_2;override;
+       end;
+
+       ti386breaknode = class(tbreaknode)
+          procedure pass_2;override;
+       end;
+
+       ti386continuenode = class(tcontinuenode)
+          procedure pass_2;override;
+       end;
+
+       ti386gotonode = class(tgotonode)
+          procedure pass_2;override;
+       end;
+
+       ti386labelnode = class(tlabelnode)
+          procedure pass_2;override;
+       end;
+
+       ti386raisenode = class(traisenode)
+          procedure pass_2;override;
+       end;
+
+       ti386tryexceptnode = class(ttryexceptnode)
+          procedure pass_2;override;
+       end;
+
+       ti386tryfinallynode = class(ttryfinallynode)
+          procedure pass_2;override;
+       end;
+
+       ti386onnode = class(tonnode)
+          procedure pass_2;override;
+       end;
+
+       ti386failnode = class(tfailnode)
+          procedure pass_2;override;
+       end;
+
+implementation
+
+    uses
+      cobjects,verbose,globtype,globals,systems,
+      symconst,symtable,aasm,types,
+      hcodegen,temp_gen,pass_2,
+      cpubase,cpuasm,
+      pass_1,nld,ncon,
+      cgai386,tgeni386,n386util;
+
+{*****************************************************************************
+                         Second_While_RepeatN
+*****************************************************************************}
+
+    procedure ti386whilerepeatnode.pass_2;
+      var
+         lcont,lbreak,lloop,
+         oldclabel,oldblabel : pasmlabel;
+         otlabel,oflabel : pasmlabel;
+
+      begin
+         getlabel(lloop);
+         getlabel(lcont);
+         getlabel(lbreak);
+         { arrange continue and breaklabels: }
+         oldclabel:=aktcontinuelabel;
+         oldblabel:=aktbreaklabel;
+
+         { handling code at the end as it is much more efficient, and makes
+           while equal to repeat loop, only the end true/false is swapped (PFV) }
+         if nodetype=whilen then
+          emitjmp(C_None,lcont);
+
+         emitlab(lloop);
+
+         aktcontinuelabel:=lcont;
+         aktbreaklabel:=lbreak;
+         cleartempgen;
+         if assigned(right) then
+           secondpass(right);
+         emitlab(lcont);
+         otlabel:=truelabel;
+         oflabel:=falselabel;
+         if nodetype=whilen then
+          begin
+            truelabel:=lloop;
+            falselabel:=lbreak;
+          end
+         { repeatn }
+         else
+          begin
+            truelabel:=lbreak;
+            falselabel:=lloop;
+          end;
+         cleartempgen;
+         secondpass(left);
+         maketojumpbool(left);
+         emitlab(lbreak);
+         truelabel:=otlabel;
+         falselabel:=oflabel;
+
+         aktcontinuelabel:=oldclabel;
+         aktbreaklabel:=oldblabel;
+         { a break/continue in a while/repeat block can't be seen outside }
+         flowcontrol:=flowcontrol-[fc_break,fc_continue];
+      end;
+
+
+{*****************************************************************************
+                               TI386IFNODE
+*****************************************************************************}
+
+    procedure ti386ifnode.pass_2;
+
+      var
+         hl,otlabel,oflabel : pasmlabel;
+
+      begin
+         otlabel:=truelabel;
+         oflabel:=falselabel;
+         getlabel(truelabel);
+         getlabel(falselabel);
+         cleartempgen;
+         secondpass(left);
+         maketojumpbool(left);
+         if assigned(right) then
+           begin
+              emitlab(truelabel);
+              cleartempgen;
+              secondpass(right);
+           end;
+         if assigned(t1) then
+           begin
+              if assigned(right) then
+                begin
+                   getlabel(hl);
+                   { do go back to if line !! }
+                   aktfilepos:=exprasmlist^.getlasttaifilepos^;
+                   emitjmp(C_None,hl);
+                end;
+              emitlab(falselabel);
+              cleartempgen;
+              secondpass(t1);
+              if assigned(right) then
+                emitlab(hl);
+           end
+         else
+           begin
+              emitlab(falselabel);
+           end;
+         if not(assigned(right)) then
+           begin
+              emitlab(truelabel);
+           end;
+         truelabel:=otlabel;
+         falselabel:=oflabel;
+      end;
+
+
+{*****************************************************************************
+                              SecondFor
+*****************************************************************************}
+
+    procedure ti386fornode.pass_2;
+      var
+         l3,oldclabel,oldblabel : pasmlabel;
+         omitfirstcomp,temptovalue : boolean;
+         hs : byte;
+         temp1 : treference;
+         hop : tasmop;
+         hcond : tasmcond;
+         cmpreg,cmp32 : tregister;
+         opsize : topsize;
+         count_var_is_signed : boolean;
+
+      begin
+         oldclabel:=aktcontinuelabel;
+         oldblabel:=aktbreaklabel;
+         getlabel(aktcontinuelabel);
+         getlabel(aktbreaklabel);
+         getlabel(l3);
+
+         { could we spare the first comparison ? }
+         omitfirstcomp:=false;
+         if right.nodetype=ordconstn then
+           if tassignmentnode(left).right.nodetype=ordconstn then
+             omitfirstcomp:=((nf_backward in flags) and
+               (tordconstnode(tassignmentnode(left).right).value>=tordconstnode(right).value))
+               or (not(nf_backward in flags) and
+                  (tordconstnode(tassignmentnode(left).right).value<=tordconstnode(right).value));
+
+         { only calculate reference }
+         cleartempgen;
+         secondpass(t2);
+         hs:=t2.resulttype^.size;
+         if t2.location.loc <> LOC_CREGISTER then
+           cmp32:=getregister32;
+         case hs of
+            1 : begin
+                   opsize:=S_B;
+                   if t2.location.loc <> LOC_CREGISTER then
+                     cmpreg:=reg32toreg8(cmp32);
+                end;
+            2 : begin
+                   opsize:=S_W;
+                   if t2.location.loc <> LOC_CREGISTER then
+                     cmpreg:=reg32toreg16(cmp32);
+                end;
+            4 : begin
+                   opsize:=S_L;
+                   if t2.location.loc <> LOC_CREGISTER then
+                     cmpreg:=cmp32;
+                end;
+         end;
+
+         { first set the to value
+           because the count var can be in the expression !! }
+         cleartempgen;
+         secondpass(right);
+         { calculate pointer value and check if changeable and if so }
+         { load into temporary variable                       }
+         if right.nodetype<>ordconstn then
+           begin
+              temp1.symbol:=nil;
+              gettempofsizereference(hs,temp1);
+              temptovalue:=true;
+              if (right.location.loc=LOC_REGISTER) or
+                 (right.location.loc=LOC_CREGISTER) then
+                begin
+                   emit_reg_ref(A_MOV,opsize,right.location.register,
+                      newreference(temp1));
+                 end
+              else
+                 concatcopy(right.location.reference,temp1,hs,false,false);
+           end
+         else
+           temptovalue:=false;
+
+         { produce start assignment }
+         cleartempgen;
+         secondpass(left);
+         count_var_is_signed:=is_signed(porddef(t2.resulttype));
+         if temptovalue then
+             begin
+              if t2.location.loc=LOC_CREGISTER then
+                begin
+                   emit_ref_reg(A_CMP,opsize,newreference(temp1),
+                     t2.location.register);
+                end
+              else
+                begin
+                   emit_ref_reg(A_MOV,opsize,newreference(t2.location.reference),
+                     cmpreg);
+                   emit_ref_reg(A_CMP,opsize,newreference(temp1),
+                     cmpreg);
+                   { temp register not necessary anymore currently (JM) }
+                   ungetregister32(cmp32);
+                end;
+           end
+         else
+             begin
+              if not(omitfirstcomp) then
+                begin
+                   if t2.location.loc=LOC_CREGISTER then
+                     emit_const_reg(A_CMP,opsize,tordconstnode(right).value,
+                       t2.location.register)
+                   else
+                     emit_const_ref(A_CMP,opsize,tordconstnode(right).value,
+                       newreference(t2.location.reference));
+                end;
+           end;
+         if nf_backward in flags then
+           if count_var_is_signed then
+             hcond:=C_L
+           else
+             hcond:=C_B
+         else
+           if count_var_is_signed then
+             hcond:=C_G
+           else
+             hcond:=C_A;
+
+         if not(omitfirstcomp) or temptovalue then
+           emitjmp(hcond,aktbreaklabel);
+
+         { align loop target }
+         if not(cs_littlesize in aktglobalswitches) then
+           exprasmlist^.concat(new(pai_align,init_op(4,$90)));
+
+         emitlab(l3);
+
+         { help register must not be in instruction block }
+         cleartempgen;
+         if assigned(t1) then
+           secondpass(t1);
+
+         emitlab(aktcontinuelabel);
+
+         { makes no problems there }
+         cleartempgen;
+
+         if (t2.location.loc <> LOC_CREGISTER) then
+           begin
+             { demand help register again }
+             cmp32:=getregister32;
+             case hs of
+                1 : cmpreg:=reg32toreg8(cmp32);
+                2 : cmpreg:=reg32toreg16(cmp32);
+                4 : cmpreg:=cmp32;
+             end;
+           end;
+
+         { produce comparison and the corresponding }
+         { jump                              }
+         if temptovalue then
+           begin
+              if t2.location.loc=LOC_CREGISTER then
+                begin
+                   emit_ref_reg(A_CMP,opsize,newreference(temp1),
+                     t2.location.register);
+                end
+              else
+                begin
+                   emit_ref_reg(A_MOV,opsize,newreference(t2.location.reference),
+                     cmpreg);
+                   emit_ref_reg(A_CMP,opsize,newreference(temp1),
+                     cmpreg);
+                    end;
+           end
+         else
+           begin
+              if t2.location.loc=LOC_CREGISTER then
+                emit_const_reg(A_CMP,opsize,tordconstnode(right).value,
+                  t2.location.register)
+              else
+                 emit_const_ref(A_CMP,opsize,tordconstnode(right).value,
+                   newreference(t2.location.reference));
+           end;
+         if nf_backward in flags then
+           if count_var_is_signed then
+             hcond:=C_LE
+           else
+             hcond:=C_BE
+          else
+            if count_var_is_signed then
+              hcond:=C_GE
+            else
+              hcond:=C_AE;
+         emitjmp(hcond,aktbreaklabel);
+         { according to count direction DEC or INC... }
+         { must be after the test because of 0 to 255 for bytes !! }
+         if nf_backward in flags then
+           hop:=A_DEC
+         else
+           hop:=A_INC;
+
+         if t2.location.loc=LOC_CREGISTER then
+           emit_reg(hop,opsize,t2.location.register)
+         else
+           emit_ref(hop,opsize,newreference(t2.location.reference));
+         emitjmp(C_None,l3);
+
+         if (t2.location.loc <> LOC_CREGISTER) then
+           ungetregister32(cmp32);
+         if temptovalue then
+           ungetiftemp(temp1);
+
+         { this is the break label: }
+         emitlab(aktbreaklabel);
+
+         aktcontinuelabel:=oldclabel;
+         aktbreaklabel:=oldblabel;
+         { a break/continue in a for block can't be seen outside }
+         flowcontrol:=flowcontrol-[fc_break,fc_continue];
+      end;
+
+
+{*****************************************************************************
+                              SecondExitN
+*****************************************************************************}
+
+    procedure ti386exitnode.pass_2;
+      var
+         is_mem : boolean;
+         {op : tasmop;
+         s : topsize;}
+         otlabel,oflabel : pasmlabel;
+         r : preference;
+
+      label
+         do_jmp;
+      begin
+         include(flowcontrol,fc_exit);
+         if assigned(left) then
+         if left.nodetype=assignn then
+           begin
+              { just do a normal assignment followed by exit }
+              secondpass(left);
+              emitjmp(C_None,aktexitlabel);
+           end
+         else
+           begin
+              otlabel:=truelabel;
+              oflabel:=falselabel;
+              getlabel(truelabel);
+              getlabel(falselabel);
+              secondpass(left);
+              case left.location.loc of
+                 LOC_FPU : goto do_jmp;
+                 LOC_MEM,
+           LOC_REFERENCE : is_mem:=true;
+           LOC_CREGISTER,
+            LOC_REGISTER : is_mem:=false;
+               LOC_FLAGS : begin
+                             emit_flag2reg(left.location.resflags,R_AL);
+                             goto do_jmp;
+                           end;
+                LOC_JUMP : begin
+                             emitlab(truelabel);
+                             emit_const_reg(A_MOV,S_B,1,R_AL);
+                             emitjmp(C_None,aktexit2label);
+                             emitlab(falselabel);
+                             emit_reg_reg(A_XOR,S_B,R_AL,R_AL);
+                             goto do_jmp;
+                           end;
+              else
+                internalerror(2001);
+              end;
+              case procinfo^.returntype.def^.deftype of
+           pointerdef,
+           procvardef : begin
+                          if is_mem then
+                            emit_ref_reg(A_MOV,S_L,
+                              newreference(left.location.reference),R_EAX)
+                          else
+                            emit_reg_reg(A_MOV,S_L,
+                              left.location.register,R_EAX);
+                        end;
+             floatdef : begin
+                          if pfloatdef(procinfo^.returntype.def)^.typ=f32bit then
+                           begin
+                             if is_mem then
+                               emit_ref_reg(A_MOV,S_L,
+                                 newreference(left.location.reference),R_EAX)
+                             else
+                               emit_reg_reg(A_MOV,S_L,left.location.register,R_EAX);
+                           end
+                          else
+                           if is_mem then
+                            floatload(pfloatdef(procinfo^.returntype.def)^.typ,left.location.reference);
+                        end;
+              { orddef,
+              enumdef : }
+              else
+              { it can be anything shorter than 4 bytes PM
+              this caused form bug 711 }
+                       begin
+                          case procinfo^.returntype.def^.size of
+                           { it can be a qword/int64 too ... }
+                           8 : if is_mem then
+                                 begin
+                                    emit_ref_reg(A_MOV,S_L,
+                                      newreference(left.location.reference),R_EAX);
+                                    r:=newreference(left.location.reference);
+                                    inc(r^.offset,4);
+                                    emit_ref_reg(A_MOV,S_L,r,R_EDX);
+                                 end
+                               else
+                                 begin
+                                    emit_reg_reg(A_MOV,S_L,left.location.registerlow,R_EAX);
+                                    emit_reg_reg(A_MOV,S_L,left.location.registerhigh,R_EDX);
+                                 end;
+                          { if its 3 bytes only we can still
+                            copy one of garbage ! PM }
+                           4,3 : if is_mem then
+                                 emit_ref_reg(A_MOV,S_L,
+                                   newreference(left.location.reference),R_EAX)
+                               else
+                                 emit_reg_reg(A_MOV,S_L,left.location.register,R_EAX);
+                           2 : if is_mem then
+                                 emit_ref_reg(A_MOV,S_W,
+                                   newreference(left.location.reference),R_AX)
+                               else
+                                 emit_reg_reg(A_MOV,S_W,makereg16(left.location.register),R_AX);
+                           1 : if is_mem then
+                                 emit_ref_reg(A_MOV,S_B,
+                                   newreference(left.location.reference),R_AL)
+                               else
+                                 emit_reg_reg(A_MOV,S_B,makereg8(left.location.register),R_AL);
+                           else internalerror(605001);
+                          end;
+                        end;
+              end;
+do_jmp:
+              truelabel:=otlabel;
+              falselabel:=oflabel;
+              emitjmp(C_None,aktexit2label);
+           end
+         else
+           begin
+              emitjmp(C_None,aktexitlabel);
+           end;
+       end;
+
+
+{*****************************************************************************
+                              SecondBreakN
+*****************************************************************************}
+
+    procedure ti386breaknode.pass_2;
+      begin
+         include(flowcontrol,fc_break);
+         if aktbreaklabel<>nil then
+           emitjmp(C_None,aktbreaklabel)
+         else
+           CGMessage(cg_e_break_not_allowed);
+      end;
+
+
+{*****************************************************************************
+                              SecondContinueN
+*****************************************************************************}
+
+    procedure ti386continuenode.pass_2;
+      begin
+         include(flowcontrol,fc_continue);
+         if aktcontinuelabel<>nil then
+           emitjmp(C_None,aktcontinuelabel)
+         else
+           CGMessage(cg_e_continue_not_allowed);
+      end;
+
+
+{*****************************************************************************
+                             SecondGoto
+*****************************************************************************}
+
+    procedure ti386gotonode.pass_2;
+
+       begin
+         emitjmp(C_None,labelnr);
+         { the assigned avoids only crashes if the label isn't defined }
+         if assigned(labsym) and
+           assigned(labsym^.code) and
+            (aktexceptblock<>tlabelnode(labsym^.code).exceptionblock) then
+           CGMessage(cg_e_goto_inout_of_exception_block);
+       end;
+
+
+{*****************************************************************************
+                             SecondLabel
+*****************************************************************************}
+
+    procedure ti386labelnode.pass_2;
+      begin
+         emitlab(labelnr);
+         cleartempgen;
+         secondpass(left);
+      end;
+
+
+{*****************************************************************************
+                             SecondRaise
+*****************************************************************************}
+
+    procedure ti386raisenode.pass_2;
+
+      var
+         a : pasmlabel;
+      begin
+         if assigned(left) then
+           begin
+              { multiple parameters? }
+              if assigned(right) then
+                begin
+                  { push frame }
+                  if assigned(frametree) then
+                    begin
+                      secondpass(frametree);
+                      if codegenerror then
+                       exit;
+                      emit_push_loc(frametree.location);
+                    end
+                  else
+                    emit_const(A_PUSH,S_L,0);
+                  { push address }
+                  secondpass(right);
+                  if codegenerror then
+                   exit;
+                  emit_push_loc(right.location);
+                end
+              else
+                begin
+                   getaddrlabel(a);
+                   emitlab(a);
+                   emit_reg(A_PUSH,S_L,R_EBP);
+                   emit_sym(A_PUSH,S_L,a);
+                end;
+              { push object }
+              secondpass(left);
+              if codegenerror then
+                exit;
+              emit_push_loc(left.location);
+              emitcall('FPC_RAISEEXCEPTION');
+           end
+         else
+           begin
+              emitcall('FPC_POPADDRSTACK');
+              emitcall('FPC_RERAISE');
+           end;
+       end;
+
+
+{*****************************************************************************
+                             SecondTryExcept
+*****************************************************************************}
+
+    var
+       endexceptlabel : pasmlabel;
+
+    { does the necessary things to clean up the object stack }
+    { in the except block                                    }
+    procedure cleanupobjectstack;
+
+      begin
+         emitcall('FPC_POPOBJECTSTACK');
+         exprasmlist^.concat(new(pairegalloc,alloc(R_EAX)));
+         emit_reg(A_PUSH,S_L,R_EAX);
+         emitcall('FPC_DESTROYEXCEPTION');
+         exprasmlist^.concat(new(pairegalloc,dealloc(R_EAX)));
+         maybe_loadesi;
+      end;
+
+    { pops one element from the exception address stack }
+    { and removes the flag                              }
+    procedure cleanupaddrstack;
+
+      begin
+         emitcall('FPC_POPADDRSTACK');
+         { allocate eax }
+         exprasmlist^.concat(new(pairegalloc,alloc(R_EAX)));
+         emit_reg(A_POP,S_L,R_EAX);
+         { deallocate eax }
+         exprasmlist^.concat(new(pairegalloc,dealloc(R_EAX)));
+      end;
+
+    procedure ti386tryexceptnode.pass_2;
+
+      var
+         exceptlabel,doexceptlabel,oldendexceptlabel,
+         lastonlabel,
+         exitexceptlabel,
+         continueexceptlabel,
+         breakexceptlabel,
+         exittrylabel,
+         continuetrylabel,
+         breaktrylabel,
+         doobjectdestroy,
+         doobjectdestroyandreraise,
+         oldaktexitlabel,
+         oldaktexit2label,
+         oldaktcontinuelabel,
+         oldaktbreaklabel : pasmlabel;
+         oldexceptblock : tnode;
+
+
+         oldflowcontrol,tryflowcontrol,
+         exceptflowcontrol : tflowcontrol;
+      label
+         errorexit;
+      begin
+         oldflowcontrol:=flowcontrol;
+         flowcontrol:=[];
+         { this can be called recursivly }
+         oldendexceptlabel:=endexceptlabel;
+
+         { we modify EAX }
+         usedinproc:=usedinproc or ($80 shr byte(R_EAX));
+
+         { save the old labels for control flow statements }
+         oldaktexitlabel:=aktexitlabel;
+         oldaktexit2label:=aktexit2label;
+         if assigned(aktbreaklabel) then
+           begin
+              oldaktcontinuelabel:=aktcontinuelabel;
+              oldaktbreaklabel:=aktbreaklabel;
+           end;
+
+         { get new labels for the control flow statements }
+         getlabel(exittrylabel);
+         getlabel(exitexceptlabel);
+         if assigned(aktbreaklabel) then
+           begin
+              getlabel(breaktrylabel);
+              getlabel(continuetrylabel);
+              getlabel(breakexceptlabel);
+              getlabel(continueexceptlabel);
+           end;
+
+         getlabel(exceptlabel);
+         getlabel(doexceptlabel);
+         getlabel(endexceptlabel);
+         getlabel(lastonlabel);
+         push_int (1); { push type of exceptionframe }
+         emitcall('FPC_PUSHEXCEPTADDR');
+         { allocate eax }
+         exprasmlist^.concat(new(pairegalloc,alloc(R_EAX)));
+         emit_reg(A_PUSH,S_L,R_EAX);
+         emitcall('FPC_SETJMP');
+         emit_reg(A_PUSH,S_L,R_EAX);
+         emit_reg_reg(A_TEST,S_L,R_EAX,R_EAX);
+         { deallocate eax }
+         exprasmlist^.concat(new(pairegalloc,dealloc(R_EAX)));
+         emitjmp(C_NE,exceptlabel);
+
+         { try block }
+         { set control flow labels for the try block }
+         aktexitlabel:=exittrylabel;
+         aktexit2label:=exittrylabel;
+         if assigned(oldaktbreaklabel) then
+          begin
+            aktcontinuelabel:=continuetrylabel;
+            aktbreaklabel:=breaktrylabel;
+          end;
+
+         oldexceptblock:=aktexceptblock;
+         aktexceptblock:=left;
+         flowcontrol:=[];
+         secondpass(left);
+         tryflowcontrol:=flowcontrol;
+         aktexceptblock:=oldexceptblock;
+         if codegenerror then
+           goto errorexit;
+
+         emitlab(exceptlabel);
+         emitcall('FPC_POPADDRSTACK');
+
+         exprasmlist^.concat(new(pairegalloc,alloc(R_EAX)));
+         emit_reg(A_POP,S_L,R_EAX);
+         emit_reg_reg(A_TEST,S_L,R_EAX,R_EAX);
+         exprasmlist^.concat(new(pairegalloc,dealloc(R_EAX)));
+
+         emitjmp(C_E,endexceptlabel);
+         emitlab(doexceptlabel);
+
+         { set control flow labels for the except block }
+         { and the on statements                        }
+         aktexitlabel:=exitexceptlabel;
+         aktexit2label:=exitexceptlabel;
+         if assigned(oldaktbreaklabel) then
+          begin
+            aktcontinuelabel:=continueexceptlabel;
+            aktbreaklabel:=breakexceptlabel;
+          end;
+
+         flowcontrol:=[];
+         { on statements }
+         if assigned(right) then
+           begin
+              oldexceptblock:=aktexceptblock;
+              aktexceptblock:=right;
+              secondpass(right);
+              aktexceptblock:=oldexceptblock;
+           end;
+
+         emitlab(lastonlabel);
+         { default handling except handling }
+         if assigned(t1) then
+           begin
+              { FPC_CATCHES must be called with
+                'default handler' flag (=-1)
+              }
+              push_int (-1);
+              emitcall('FPC_CATCHES');
+              maybe_loadesi;
+
+              { the destruction of the exception object must be also }
+              { guarded by an exception frame                        }
+              getlabel(doobjectdestroy);
+              getlabel(doobjectdestroyandreraise);
+              exprasmlist^.concat(new(paicpu,op_const(A_PUSH,S_L,1)));
+              emitcall('FPC_PUSHEXCEPTADDR');
+              exprasmlist^.concat(new(pairegalloc,alloc(R_EAX)));
+              exprasmlist^.concat(new(paicpu,
+                op_reg(A_PUSH,S_L,R_EAX)));
+              exprasmlist^.concat(new(pairegalloc,dealloc(R_EAX)));
+              emitcall('FPC_SETJMP');
+              exprasmlist^.concat(new(pairegalloc,alloc(R_EAX)));
+              exprasmlist^.concat(new(paicpu,
+                op_reg(A_PUSH,S_L,R_EAX)));
+              exprasmlist^.concat(new(paicpu,
+                op_reg_reg(A_TEST,S_L,R_EAX,R_EAX)));
+              exprasmlist^.concat(new(pairegalloc,dealloc(R_EAX)));
+              emitjmp(C_NE,doobjectdestroyandreraise);
+
+              oldexceptblock:=aktexceptblock;
+              aktexceptblock:=t1;
+              { here we don't have to reset flowcontrol           }
+              { the default and on flowcontrols are handled equal }
+              secondpass(t1);
+              exceptflowcontrol:=flowcontrol;
+              aktexceptblock:=oldexceptblock;
+
+              emitlab(doobjectdestroyandreraise);
+              emitcall('FPC_POPADDRSTACK');
+              exprasmlist^.concat(new(pairegalloc,alloc(R_EAX)));
+              exprasmlist^.concat(new(paicpu,
+                op_reg(A_POP,S_L,R_EAX)));
+              exprasmlist^.concat(new(paicpu,
+                op_reg_reg(A_TEST,S_L,R_EAX,R_EAX)));
+              exprasmlist^.concat(new(pairegalloc,dealloc(R_EAX)));
+              emitjmp(C_E,doobjectdestroy);
+              emitcall('FPC_POPSECONDOBJECTSTACK');
+              exprasmlist^.concat(new(pairegalloc,alloc(R_EAX)));
+              emit_reg(A_PUSH,S_L,R_EAX);
+              emitcall('FPC_DESTROYEXCEPTION');
+              exprasmlist^.concat(new(pairegalloc,dealloc(R_EAX)));
+              { we don't need to restore esi here because reraise never }
+              { returns                                                 }
+              emitcall('FPC_RERAISE');
+
+              emitlab(doobjectdestroy);
+              cleanupobjectstack;
+              emitjmp(C_None,endexceptlabel);
+           end
+         else
+           begin
+              emitcall('FPC_RERAISE');
+              exceptflowcontrol:=flowcontrol;
+           end;
+
+         if fc_exit in exceptflowcontrol then
+           begin
+              { do some magic for exit in the try block }
+              emitlab(exitexceptlabel);
+              { we must also destroy the address frame which guards }
+              { exception object                                    }
+              cleanupaddrstack;
+              cleanupobjectstack;
+              emitjmp(C_None,oldaktexitlabel);
+           end;
+
+         if fc_break in exceptflowcontrol then
+           begin
+              emitlab(breakexceptlabel);
+              { we must also destroy the address frame which guards }
+              { exception object                                    }
+              cleanupaddrstack;
+              cleanupobjectstack;
+              emitjmp(C_None,oldaktbreaklabel);
+           end;
+
+         if fc_continue in exceptflowcontrol then
+           begin
+              emitlab(continueexceptlabel);
+              { we must also destroy the address frame which guards }
+              { exception object                                    }
+              cleanupaddrstack;
+              cleanupobjectstack;
+              emitjmp(C_None,oldaktcontinuelabel);
+           end;
+
+         if fc_exit in tryflowcontrol then
+           begin
+              { do some magic for exit in the try block }
+              emitlab(exittrylabel);
+              cleanupaddrstack;
+              emitjmp(C_None,oldaktexitlabel);
+           end;
+
+         if fc_break in tryflowcontrol then
+           begin
+              emitlab(breaktrylabel);
+              cleanupaddrstack;
+              emitjmp(C_None,oldaktbreaklabel);
+           end;
+
+         if fc_continue in tryflowcontrol then
+           begin
+              emitlab(continuetrylabel);
+              cleanupaddrstack;
+              emitjmp(C_None,oldaktcontinuelabel);
+           end;
+
+         emitlab(endexceptlabel);
+
+       errorexit:
+         { restore all saved labels }
+         endexceptlabel:=oldendexceptlabel;
+
+         { restore the control flow labels }
+         aktexitlabel:=oldaktexitlabel;
+         aktexit2label:=oldaktexit2label;
+         if assigned(oldaktbreaklabel) then
+          begin
+            aktcontinuelabel:=oldaktcontinuelabel;
+            aktbreaklabel:=oldaktbreaklabel;
+          end;
+
+         { return all used control flow statements }
+         flowcontrol:=oldflowcontrol+exceptflowcontrol+
+           tryflowcontrol;
+      end;
+
+    procedure ti386onnode.pass_2;
+      var
+         nextonlabel,
+         exitonlabel,
+         continueonlabel,
+         breakonlabel,
+         oldaktexitlabel,
+         oldaktexit2label,
+         oldaktcontinuelabel,
+         doobjectdestroyandreraise,
+         doobjectdestroy,
+         oldaktbreaklabel : pasmlabel;
+         ref : treference;
+         oldexceptblock : tnode;
+         oldflowcontrol : tflowcontrol;
+
+      begin
+         oldflowcontrol:=flowcontrol;
+         flowcontrol:=[];
+         getlabel(nextonlabel);
+
+         { push the vmt }
+         emit_sym(A_PUSH,S_L,
+           newasmsymbol(excepttype^.vmt_mangledname));
+         emitcall('FPC_CATCHES');
+         { allocate eax }
+         exprasmlist^.concat(new(pairegalloc,alloc(R_EAX)));
+         emit_reg_reg(A_TEST,S_L,R_EAX,R_EAX);
+         emitjmp(C_E,nextonlabel);
+         ref.symbol:=nil;
+         gettempofsizereference(4,ref);
+
+         { what a hack ! }
+         if assigned(exceptsymtable) then
+           pvarsym(exceptsymtable^.symindex^.first)^.address:=ref.offset;
+
+         emit_reg_ref(A_MOV,S_L,
+           R_EAX,newreference(ref));
+         { deallocate eax }
+         exprasmlist^.concat(new(pairegalloc,dealloc(R_EAX)));
+
+         { in the case that another exception is risen }
+         { we've to destroy the old one                }
+         getlabel(doobjectdestroyandreraise);
+         exprasmlist^.concat(new(paicpu,op_const(A_PUSH,S_L,1)));
+         emitcall('FPC_PUSHEXCEPTADDR');
+         exprasmlist^.concat(new(pairegalloc,alloc(R_EAX)));
+         exprasmlist^.concat(new(paicpu,
+           op_reg(A_PUSH,S_L,R_EAX)));
+         exprasmlist^.concat(new(pairegalloc,dealloc(R_EAX)));
+         emitcall('FPC_SETJMP');
+         exprasmlist^.concat(new(pairegalloc,alloc(R_EAX)));
+         exprasmlist^.concat(new(paicpu,
+           op_reg(A_PUSH,S_L,R_EAX)));
+         exprasmlist^.concat(new(paicpu,
+           op_reg_reg(A_TEST,S_L,R_EAX,R_EAX)));
+         exprasmlist^.concat(new(pairegalloc,dealloc(R_EAX)));
+         emitjmp(C_NE,doobjectdestroyandreraise);
+
+         if assigned(right) then
+           begin
+              oldaktexitlabel:=aktexitlabel;
+              oldaktexit2label:=aktexit2label;
+              getlabel(exitonlabel);
+              aktexitlabel:=exitonlabel;
+              aktexit2label:=exitonlabel;
+              if assigned(aktbreaklabel) then
+               begin
+                 oldaktcontinuelabel:=aktcontinuelabel;
+                 oldaktbreaklabel:=aktbreaklabel;
+                 getlabel(breakonlabel);
+                 getlabel(continueonlabel);
+                 aktcontinuelabel:=continueonlabel;
+                 aktbreaklabel:=breakonlabel;
+               end;
+
+              { esi is destroyed by FPC_CATCHES }
+              maybe_loadesi;
+              oldexceptblock:=aktexceptblock;
+              aktexceptblock:=right;
+              secondpass(right);
+              aktexceptblock:=oldexceptblock;
+           end;
+         getlabel(doobjectdestroy);
+         emitlab(doobjectdestroyandreraise);
+         emitcall('FPC_POPADDRSTACK');
+         exprasmlist^.concat(new(pairegalloc,alloc(R_EAX)));
+         exprasmlist^.concat(new(paicpu,
+           op_reg(A_POP,S_L,R_EAX)));
+         exprasmlist^.concat(new(paicpu,
+           op_reg_reg(A_TEST,S_L,R_EAX,R_EAX)));
+         exprasmlist^.concat(new(pairegalloc,dealloc(R_EAX)));
+         emitjmp(C_E,doobjectdestroy);
+         emitcall('FPC_POPSECONDOBJECTSTACK');
+         exprasmlist^.concat(new(pairegalloc,alloc(R_EAX)));
+         emit_reg(A_PUSH,S_L,R_EAX);
+         emitcall('FPC_DESTROYEXCEPTION');
+         exprasmlist^.concat(new(pairegalloc,dealloc(R_EAX)));
+         { we don't need to restore esi here because reraise never }
+         { returns                                                 }
+         emitcall('FPC_RERAISE');
+
+         emitlab(doobjectdestroy);
+         cleanupobjectstack;
+         { clear some stuff }
+         ungetiftemp(ref);
+         emitjmp(C_None,endexceptlabel);
+
+         if assigned(right) then
+           begin
+              { special handling for control flow instructions }
+              if fc_exit in flowcontrol then
+                begin
+                   { the address and object pop does secondtryexcept }
+                   emitlab(exitonlabel);
+                   emitjmp(C_None,oldaktexitlabel);
+                end;
+
+              if fc_break in flowcontrol then
+                begin
+                   { the address and object pop does secondtryexcept }
+                   emitlab(breakonlabel);
+                   emitjmp(C_None,oldaktbreaklabel);
+                end;
+
+              if fc_continue in flowcontrol then
+                begin
+                   { the address and object pop does secondtryexcept }
+                   emitlab(continueonlabel);
+                   emitjmp(C_None,oldaktcontinuelabel);
+                end;
+
+              aktexitlabel:=oldaktexitlabel;
+              aktexit2label:=oldaktexit2label;
+              if assigned(oldaktbreaklabel) then
+               begin
+                 aktcontinuelabel:=oldaktcontinuelabel;
+                 aktbreaklabel:=oldaktbreaklabel;
+               end;
+           end;
+
+         emitlab(nextonlabel);
+         flowcontrol:=oldflowcontrol+flowcontrol;
+         { next on node }
+         if assigned(left) then
+           begin
+              cleartempgen;
+              secondpass(left);
+           end;
+      end;
+
+{*****************************************************************************
+                             SecondTryFinally
+*****************************************************************************}
+
+    procedure ti386tryfinallynode.pass_2;
+      var
+         reraiselabel,
+         finallylabel,
+         endfinallylabel,
+         exitfinallylabel,
+         continuefinallylabel,
+         breakfinallylabel,
+         oldaktexitlabel,
+         oldaktexit2label,
+         oldaktcontinuelabel,
+         oldaktbreaklabel : pasmlabel;
+         oldexceptblock : tnode;
+         oldflowcontrol,tryflowcontrol : tflowcontrol;
+         decconst : longint;
+
+      begin
+         { check if child nodes do a break/continue/exit }
+         oldflowcontrol:=flowcontrol;
+         flowcontrol:=[];
+         { we modify EAX }
+         usedinproc:=usedinproc or ($80 shr byte(R_EAX));
+         getlabel(finallylabel);
+         getlabel(endfinallylabel);
+         getlabel(reraiselabel);
+
+         { the finally block must catch break, continue and exit }
+         { statements                                            }
+         oldaktexitlabel:=aktexitlabel;
+         oldaktexit2label:=aktexit2label;
+         getlabel(exitfinallylabel);
+         aktexitlabel:=exitfinallylabel;
+         aktexit2label:=exitfinallylabel;
+         if assigned(aktbreaklabel) then
+          begin
+            oldaktcontinuelabel:=aktcontinuelabel;
+            oldaktbreaklabel:=aktbreaklabel;
+            getlabel(breakfinallylabel);
+            getlabel(continuefinallylabel);
+            aktcontinuelabel:=continuefinallylabel;
+            aktbreaklabel:=breakfinallylabel;
+          end;
+
+         push_int(1); { Type of stack-frame must be pushed}
+         emitcall('FPC_PUSHEXCEPTADDR');
+         { allocate eax }
+         exprasmlist^.concat(new(pairegalloc,alloc(R_EAX)));
+         emit_reg(A_PUSH,S_L,R_EAX);
+         emitcall('FPC_SETJMP');
+         emit_reg(A_PUSH,S_L,R_EAX);
+         emit_reg_reg(A_TEST,S_L,R_EAX,R_EAX);
+         { deallocate eax }
+         exprasmlist^.concat(new(pairegalloc,dealloc(R_EAX)));
+         emitjmp(C_NE,finallylabel);
+
+         { try code }
+         if assigned(left) then
+           begin
+              oldexceptblock:=aktexceptblock;
+              aktexceptblock:=left;
+              secondpass(left);
+              tryflowcontrol:=flowcontrol;
+              if codegenerror then
+                exit;
+              aktexceptblock:=oldexceptblock;
+           end;
+
+         emitlab(finallylabel);
+         emitcall('FPC_POPADDRSTACK');
+         { finally code }
+         oldexceptblock:=aktexceptblock;
+         aktexceptblock:=right;
+         flowcontrol:=[];
+         secondpass(right);
+         if flowcontrol<>[] then
+           CGMessage(cg_e_control_flow_outside_finally);
+         aktexceptblock:=oldexceptblock;
+         if codegenerror then
+           exit;
+         { allocate eax }
+         exprasmlist^.concat(new(pairegalloc,alloc(R_EAX)));
+         emit_reg(A_POP,S_L,R_EAX);
+         emit_reg_reg(A_TEST,S_L,R_EAX,R_EAX);
+         emitjmp(C_E,endfinallylabel);
+         emit_reg(A_DEC,S_L,R_EAX);
+         emitjmp(C_Z,reraiselabel);
+         if fc_exit in tryflowcontrol then
+           begin
+              emit_reg(A_DEC,S_L,R_EAX);
+              emitjmp(C_Z,oldaktexitlabel);
+              decconst:=1;
+           end
+         else
+           decconst:=2;
+         if fc_break in tryflowcontrol then
+           begin
+              emit_const_reg(A_SUB,S_L,decconst,R_EAX);
+              emitjmp(C_Z,oldaktbreaklabel);
+              decconst:=1;
+           end
+         else
+           inc(decconst);
+         if fc_continue in tryflowcontrol then
+           begin
+              emit_const_reg(A_SUB,S_L,decconst,R_EAX);
+              emitjmp(C_Z,oldaktcontinuelabel);
+           end;
+         { deallocate eax }
+         exprasmlist^.concat(new(pairegalloc,dealloc(R_EAX)));
+         emitlab(reraiselabel);
+         emitcall('FPC_RERAISE');
+         { do some magic for exit,break,continue in the try block }
+         if fc_exit in tryflowcontrol then
+           begin
+              emitlab(exitfinallylabel);
+              { allocate eax }
+              exprasmlist^.concat(new(pairegalloc,alloc(R_EAX)));
+              emit_reg(A_POP,S_L,R_EAX);
+              exprasmlist^.concat(new(pairegalloc,alloc(R_EAX)));
+              emit_const(A_PUSH,S_L,2);
+              emitjmp(C_NONE,finallylabel);
+           end;
+         if fc_break in tryflowcontrol then
+          begin
+             emitlab(breakfinallylabel);
+             { allocate eax }
+             exprasmlist^.concat(new(pairegalloc,alloc(R_EAX)));
+             emit_reg(A_POP,S_L,R_EAX);
+             { deallocate eax }
+             exprasmlist^.concat(new(pairegalloc,dealloc(R_EAX)));
+             emit_const(A_PUSH,S_L,3);
+             emitjmp(C_NONE,finallylabel);
+           end;
+         if fc_continue in tryflowcontrol then
+           begin
+              emitlab(continuefinallylabel);
+              exprasmlist^.concat(new(pairegalloc,alloc(R_EAX)));
+              emit_reg(A_POP,S_L,R_EAX);
+              exprasmlist^.concat(new(pairegalloc,alloc(R_EAX)));
+              emit_const(A_PUSH,S_L,4);
+              emitjmp(C_NONE,finallylabel);
+           end;
+
+         emitlab(endfinallylabel);
+
+         aktexitlabel:=oldaktexitlabel;
+         aktexit2label:=oldaktexit2label;
+         if assigned(aktbreaklabel) then
+          begin
+            aktcontinuelabel:=oldaktcontinuelabel;
+            aktbreaklabel:=oldaktbreaklabel;
+          end;
+         flowcontrol:=oldflowcontrol+tryflowcontrol;
+      end;
+
+
+{*****************************************************************************
+                             SecondFail
+*****************************************************************************}
+
+    procedure ti386failnode.pass_2;
+      begin
+        emitjmp(C_None,faillabel);
+      end;
+
+
+begin
+   cwhilerepeatnode:=ti386whilerepeatnode;
+   cifnode:=ti386ifnode;
+   cfornode:=ti386fornode;
+   cexitnode:=ti386exitnode;
+   cbreaknode:=ti386breaknode;
+   ccontinuenode:=ti386continuenode;
+   cgotonode:=ti386gotonode;
+   clabelnode:=ti386labelnode;
+   craisenode:=ti386raisenode;
+   ctryexceptnode:=ti386tryexceptnode;
+   ctryfinallynode:=ti386tryfinallynode;
+   connode:=ti386onnode;
+   cfailnode:=ti386failnode;
+end.
+{
+  $Log$
+  Revision 1.1  2000-10-14 10:14:48  peter
+    * moehrendorf oct 2000 rewrite
+
+}

compiler/n386inl.pas

@@ -0,0 +1,1555 @@
+{
+    $Id$
+    Copyright (c) 1998-2000 by Florian Klaempfl
+
+    Generate i386 inline nodes
+
+    This program is free software; you can redistribute it and/or modify
+    it under the terms of the GNU General Public License as published by
+    the Free Software Foundation; either version 2 of the License, or
+    (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU General Public License for more details.
+
+    You should have received a copy of the GNU General Public License
+    along with this program; if not, write to the Free Software
+    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ ****************************************************************************
+}
+unit n386inl;
+
+{$i defines.inc}
+
+interface
+
+    uses
+       node,ninl;
+
+    type
+       ti386inlinenode = class(tinlinenode)
+          procedure pass_2;override;
+       end;
+
+implementation
+
+    uses
+      globtype,systems,
+      cutils,cobjects,verbose,globals,fmodule,
+      symconst,symtable,aasm,types,
+      hcodegen,temp_gen,pass_1,pass_2,
+      cpubase,cpuasm,
+      nbas,ncon,ncal,ncnv,nld,
+      cgai386,tgeni386,n386util;
+
+
+{*****************************************************************************
+                                Helpers
+*****************************************************************************}
+
+    { reverts the parameter list }
+    var nb_para : longint;
+
+    function reversparameter(p : tnode) : tnode;
+
+       var
+         hp1,hp2 : tnode;
+
+      begin
+         hp1:=nil;
+         nb_para := 0;
+         while assigned(p) do
+           begin
+              { pull out }
+              hp2:=p;
+              p:=tbinarynode(p).right;
+              inc(nb_para);
+              { pull in }
+              tbinarynode(hp2).right:=hp1;
+              hp1:=hp2;
+           end;
+         reversparameter:=hp1;
+       end;
+
+
+{*****************************************************************************
+                              TI386INLINENODE
+*****************************************************************************}
+
+    procedure StoreDirectFuncResult(var dest:tnode);
+      var
+        hp : tnode;
+        hdef : porddef;
+        hreg : tregister;
+        hregister : tregister;
+        oldregisterdef : boolean;
+        op : tasmop;
+        opsize : topsize;
+
+      begin
+        { Get the accumulator first so it can't be used in the dest }
+        if (dest.resulttype^.deftype=orddef) and
+          not(is_64bitint(dest.resulttype)) then
+          hregister:=getexplicitregister32(accumulator);
+        { process dest }
+        SecondPass(dest);
+        if Codegenerror then
+         exit;
+        { store the value }
+        Case dest.resulttype^.deftype of
+          floatdef:
+            if dest.location.loc=LOC_CFPUREGISTER then
+              begin
+                 floatstoreops(pfloatdef(dest.resulttype)^.typ,op,opsize);
+                 emit_reg(op,opsize,correct_fpuregister(dest.location.register,fpuvaroffset+1));
+              end
+            else
+              begin
+                 inc(fpuvaroffset);
+                 floatstore(PFloatDef(dest.resulttype)^.typ,dest.location.reference);
+                 { floatstore decrements the fpu var offset }
+                 { but in fact we didn't increment it       }
+              end;
+          orddef:
+            begin
+              if is_64bitint(dest.resulttype) then
+                begin
+                   emit_movq_reg_loc(R_EDX,R_EAX,dest.location);
+                end
+              else
+               begin
+                 Case dest.resulttype^.size of
+                  1 : hreg:=regtoreg8(hregister);
+                  2 : hreg:=regtoreg16(hregister);
+                  4 : hreg:=hregister;
+                 End;
+                 emit_mov_reg_loc(hreg,dest.location);
+                 If (cs_check_range in aktlocalswitches) and
+                    {no need to rangecheck longints or cardinals on 32bit processors}
+                    not((porddef(dest.resulttype)^.typ = s32bit) and
+                        (porddef(dest.resulttype)^.low = longint($80000000)) and
+                        (porddef(dest.resulttype)^.high = $7fffffff)) and
+                    not((porddef(dest.resulttype)^.typ = u32bit) and
+                        (porddef(dest.resulttype)^.low = 0) and
+                        (porddef(dest.resulttype)^.high = longint($ffffffff))) then
+                  Begin
+                    {do not register this temporary def}
+                    OldRegisterDef := RegisterDef;
+                    RegisterDef := False;
+                    hdef:=nil;
+                    Case PordDef(dest.resulttype)^.typ of
+                      u8bit,u16bit,u32bit:
+                        begin
+                          new(hdef,init(u32bit,0,$ffffffff));
+                          hreg:=hregister;
+                        end;
+                      s8bit,s16bit,s32bit:
+                        begin
+                          new(hdef,init(s32bit,$80000000,$7fffffff));
+                          hreg:=hregister;
+                        end;
+                    end;
+                    { create a fake node }
+                    hp := cnothingnode.create;
+                    hp.location.loc := LOC_REGISTER;
+                    hp.location.register := hreg;
+                    if assigned(hdef) then
+                      hp.resulttype:=hdef
+                    else
+                      hp.resulttype:=dest.resulttype;
+                    { emit the range check }
+                    emitrangecheck(hp,dest.resulttype);
+                    if assigned(hdef) then
+                      Dispose(hdef, Done);
+                    RegisterDef := OldRegisterDef;
+                    hp.free;
+                  End;
+                 ungetregister(hregister);
+               end;
+            End;
+          else
+            internalerror(66766766);
+        end;
+        { free used registers }
+        del_locref(dest.location);
+      end;
+
+    procedure ti386inlinenode.pass_2;
+       const
+         {tfloattype = (s32real,s64real,s80real,s64bit,f16bit,f32bit);}
+{        float_name: array[tfloattype] of string[8]=
+           ('S32REAL','S64REAL','S80REAL','S64BIT','F16BIT','F32BIT'); }
+         incdecop:array[in_inc_x..in_dec_x] of tasmop=(A_INC,A_DEC);
+         addsubop:array[in_inc_x..in_dec_x] of tasmop=(A_ADD,A_SUB);
+       var
+         aktfile : treference;
+         ft : tfiletyp;
+         opsize : topsize;
+         op,
+         asmop : tasmop;
+         pushed : tpushed;
+         {inc/dec}
+         addconstant : boolean;
+         addvalue : longint;
+
+
+      procedure handlereadwrite(doread,doln : boolean);
+      { produces code for READ(LN) and WRITE(LN) }
+
+        procedure loadstream;
+          const
+            io:array[boolean] of string[7]=('_OUTPUT','_INPUT');
+          var
+            r : preference;
+          begin
+            new(r);
+            reset_reference(r^);
+            r^.symbol:=newasmsymbol(
+            'U_'+upper(target_info.system_unit)+io[doread]);
+{$ifndef noAllocEdi}
+            getexplicitregister32(R_EDI);
+{$endif noAllocEdi}
+            emit_ref_reg(A_LEA,S_L,r,R_EDI)
+          end;
+
+        const
+           rdwrprefix:array[boolean] of string[15]=('FPC_WRITE_TEXT_','FPC_READ_TEXT_');
+        var
+           node       : tcallparanode;
+           hp         : tnode;
+           typedtyp,
+           pararesult : pdef;
+           orgfloattype : tfloattype;
+           dummycoll  : tparaitem;
+           iolabel    : pasmlabel;
+           npara      : longint;
+           esireloaded : boolean;
+
+        begin
+           { here we don't use register calling conventions }
+           dummycoll.init;
+           dummycoll.register:=R_NO;
+           { I/O check }
+           if (cs_check_io in aktlocalswitches) and
+              not(po_iocheck in aktprocsym^.definition^.procoptions) then
+             begin
+                getaddrlabel(iolabel);
+                emitlab(iolabel);
+             end
+           else
+             iolabel:=nil;
+           { for write of real with the length specified }
+           hp:=nil;
+           { reserve temporary pointer to data variable }
+           aktfile.symbol:=nil;
+           gettempofsizereference(4,aktfile);
+           { first state text data }
+           ft:=ft_text;
+           { and state a parameter ? }
+           if left=nil then
+             begin
+                { the following instructions are for "writeln;" }
+                loadstream;
+                { save @aktfile in temporary variable }
+                emit_reg_ref(A_MOV,S_L,R_EDI,newreference(aktfile));
+{$ifndef noAllocEdi}
+                ungetregister32(R_EDI);
+{$endif noAllocEdi}
+             end
+           else
+             begin
+                { revers paramters }
+                node:=tcallparanode(reversparameter(left));
+
+                left := node;
+                npara := nb_para;
+                { calculate data variable }
+                { is first parameter a file type ? }
+                if node.left.resulttype^.deftype=filedef then
+                  begin
+                     ft:=pfiledef(node.left.resulttype)^.filetyp;
+                     if ft=ft_typed then
+                       typedtyp:=pfiledef(node.left.resulttype)^.typedfiletype.def;
+                     secondpass(node.left);
+                     if codegenerror then
+                       exit;
+
+                     { save reference in temporary variables }
+                     if node.left.location.loc<>LOC_REFERENCE then
+                       begin
+                          CGMessage(cg_e_illegal_expression);
+                          exit;
+                       end;
+{$ifndef noAllocEdi}
+                     getexplicitregister32(R_EDI);
+{$endif noAllocEdi}
+
+                     emit_ref_reg(A_LEA,S_L,newreference(node.left.location.reference),R_EDI);
+                     del_reference(node.left.location.reference);
+                     { skip to the next parameter }
+                     node:=tcallparanode(node.right);
+                  end
+                else
+                  begin
+                  { load stdin/stdout stream }
+                     loadstream;
+                  end;
+
+                { save @aktfile in temporary variable }
+                emit_reg_ref(A_MOV,S_L,R_EDI,newreference(aktfile));
+{$ifndef noAllocEdi}
+                ungetregister32(R_EDI);
+{$endif noAllocEdi}
+                if doread then
+                { parameter by READ gives call by reference }
+                  dummycoll.paratyp:=vs_var
+                { an WRITE Call by "Const" }
+                else
+                  dummycoll.paratyp:=vs_const;
+
+                { because of secondcallparan, which otherwise attaches }
+                if ft=ft_typed then
+                  { this is to avoid copy of simple const parameters }
+                  {dummycoll.data:=new(pformaldef,init)}
+                  dummycoll.paratype.setdef(cformaldef)
+                else
+                  { I think, this isn't a good solution (FK) }
+                  dummycoll.paratype.reset;
+
+                while assigned(node) do
+                  begin
+                     esireloaded:=false;
+                     pushusedregisters(pushed,$ff);
+                     hp:=node;
+                     node:=tcallparanode(node.right);
+                     tcallparanode(hp).right:=nil;
+                     if cpf_is_colon_para in tcallparanode(hp).callparaflags then
+                       CGMessage(parser_e_illegal_colon_qualifier);
+                     { when float is written then we need bestreal to be pushed
+                       convert here else we loose the old float type }
+                     if (not doread) and
+                        (ft<>ft_typed) and
+                        (tcallparanode(hp).left.resulttype^.deftype=floatdef) then
+                      begin
+                        orgfloattype:=pfloatdef(tcallparanode(hp).left.resulttype)^.typ;
+                        tcallparanode(hp).left:=gentypeconvnode(tcallparanode(hp).left,bestrealdef^);
+                        firstpass(tcallparanode(hp).left);
+                      end;
+                     { when read ord,floats are functions, so they need this
+                       parameter as their destination instead of being pushed }
+                     if doread and
+                        (ft<>ft_typed) and
+                        (tcallparanode(hp).resulttype^.deftype in [orddef,floatdef]) then
+                      begin
+                      end
+                     else
+                      begin
+                        if ft=ft_typed then
+                          never_copy_const_param:=true;
+                        { reset data type }
+                        dummycoll.paratype.reset;
+                        { create temporary defs for high tree generation }
+                        if doread and (is_shortstring(tcallparanode(hp).resulttype)) then
+                          dummycoll.paratype.setdef(openshortstringdef)
+                        else
+                          if (is_chararray(tcallparanode(hp).resulttype)) then
+                            dummycoll.paratype.setdef(openchararraydef);
+                        tcallparanode(hp).secondcallparan(@dummycoll,false,false,false,0,0);
+                        if ft=ft_typed then
+                          never_copy_const_param:=false;
+                      end;
+                     tcallparanode(hp).right:=node;
+                     if codegenerror then
+                       exit;
+
+                     emit_push_mem(aktfile);
+                     if (ft=ft_typed) then
+                       begin
+                          { OK let's try this }
+                          { first we must only allow the right type }
+                          { we have to call blockread or blockwrite }
+                          { but the real problem is that            }
+                          { reset and rewrite should have set       }
+                          { the type size                          }
+                          { as recordsize for that file !!!!    }
+                          { how can we make that                    }
+                          { I think that is only possible by adding }
+                          { reset and rewrite to the inline list a call }
+                          { allways read only one record by element }
+                            push_int(typedtyp^.size);
+                            if doread then
+                              emitcall('FPC_TYPED_READ')
+                            else
+                              emitcall('FPC_TYPED_WRITE');
+                       end
+                     else
+                       begin
+                          { save current position }
+                          pararesult:=tcallparanode(hp).left.resulttype;
+                          { handle possible field width  }
+                          { of course only for write(ln) }
+                          if not doread then
+                            begin
+                               { handle total width parameter }
+                              if assigned(node) and (cpf_is_colon_para in node.callparaflags) then
+                                begin
+                                   hp:=node;
+                                   node:=tcallparanode(node.right);
+                                   tcallparanode(hp).right:=nil;
+                                   dummycoll.paratype.setdef(hp.resulttype);
+                                   dummycoll.paratyp:=vs_value;
+                                   tcallparanode(hp).secondcallparan(@dummycoll,false,false,false,0,0);
+                                   tcallparanode(hp).right:=node;
+                                   if codegenerror then
+                                     exit;
+                                end
+                              else
+                                if pararesult^.deftype<>floatdef then
+                                  push_int(0)
+                                else
+                                  push_int(-32767);
+                            { a second colon para for a float ? }
+                              if assigned(node) and (cpf_is_colon_para in node.callparaflags) then
+                                begin
+                                   hp:=node;
+                                   node:=tcallparanode(node.right);
+                                   tcallparanode(hp).right:=nil;
+                                   dummycoll.paratype.setdef(hp.resulttype);
+                                   dummycoll.paratyp:=vs_value;
+                                   tcallparanode(hp).secondcallparan(@dummycoll,false,false,false,0,0);
+                                   tcallparanode(hp).right:=node;
+                                   if pararesult^.deftype<>floatdef then
+                                     CGMessage(parser_e_illegal_colon_qualifier);
+                                   if codegenerror then
+                                     exit;
+                                end
+                              else
+                                begin
+                                  if pararesult^.deftype=floatdef then
+                                    push_int(-1);
+                                end;
+                             { push also the real type for floats }
+                              if pararesult^.deftype=floatdef then
+                                push_int(ord(orgfloattype));
+                            end;
+                          case pararesult^.deftype of
+                            stringdef :
+                              begin
+                                emitcall(rdwrprefix[doread]+pstringdef(pararesult)^.stringtypname);
+                              end;
+                            pointerdef :
+                              begin
+                                if is_pchar(pararesult) then
+                                  emitcall(rdwrprefix[doread]+'PCHAR_AS_POINTER')
+                              end;
+                            arraydef :
+                              begin
+                                if is_chararray(pararesult) then
+                                  emitcall(rdwrprefix[doread]+'PCHAR_AS_ARRAY')
+                              end;
+                            floatdef :
+                              begin
+                                emitcall(rdwrprefix[doread]+'FLOAT');
+                                {
+                                if pfloatdef(resulttype)^.typ<>f32bit then
+                                  dec(fpuvaroffset);
+                                }
+                                if doread then
+                                  begin
+                                     maybe_loadesi;
+                                     esireloaded:=true;
+                                     StoreDirectFuncResult(tcallparanode(hp).left);
+                                  end;
+                              end;
+                            orddef :
+                              begin
+                                case porddef(pararesult)^.typ of
+                                  s8bit,s16bit,s32bit :
+                                    emitcall(rdwrprefix[doread]+'SINT');
+                                  u8bit,u16bit,u32bit :
+                                    emitcall(rdwrprefix[doread]+'UINT');
+                                  uchar :
+                                    emitcall(rdwrprefix[doread]+'CHAR');
+                                  s64bit :
+                                    emitcall(rdwrprefix[doread]+'INT64');
+                                  u64bit :
+                                    emitcall(rdwrprefix[doread]+'QWORD');
+                                  bool8bit,
+                                  bool16bit,
+                                  bool32bit :
+                                    emitcall(rdwrprefix[doread]+'BOOLEAN');
+                                end;
+                                if doread then
+                                  begin
+                                     maybe_loadesi;
+                                     esireloaded:=true;
+                                     StoreDirectFuncResult(tcallparanode(hp).left);
+                                  end;
+                              end;
+                          end;
+                       end;
+                   { load ESI in methods again }
+                     popusedregisters(pushed);
+                     if not(esireloaded) then
+                       maybe_loadesi;
+                  end;
+             end;
+         { Insert end of writing for textfiles }
+           if ft=ft_text then
+             begin
+               pushusedregisters(pushed,$ff);
+               emit_push_mem(aktfile);
+               if doread then
+                begin
+                  if doln then
+                    emitcall('FPC_READLN_END')
+                  else
+                    emitcall('FPC_READ_END');
+                end
+               else
+                begin
+                  if doln then
+                    emitcall('FPC_WRITELN_END')
+                  else
+                    emitcall('FPC_WRITE_END');
+                end;
+               popusedregisters(pushed);
+               maybe_loadesi;
+             end;
+         { Insert IOCheck if set }
+           if assigned(iolabel) then
+             begin
+                { registers are saved in the procedure }
+                emit_sym(A_PUSH,S_L,iolabel);
+                emitcall('FPC_IOCHECK');
+             end;
+         { Freeup all used temps }
+           ungetiftemp(aktfile);
+           if assigned(left) then
+             begin
+                left:=reversparameter(left);
+                if npara<>nb_para then
+                  CGMessage(cg_f_internal_error_in_secondinline);
+                hp:=left;
+                while assigned(hp) do
+                  begin
+                     if assigned(tcallparanode(hp).left) then
+                       if (tcallparanode(hp).left.location.loc in [LOC_MEM,LOC_REFERENCE]) then
+                         ungetiftemp(tcallparanode(hp).left.location.reference);
+                     hp:=tcallparanode(hp).right;
+                  end;
+             end;
+        end;
+
+      procedure handle_str;
+
+        var
+           hp,
+           node : tcallparanode;
+           dummycoll : tparaitem;
+           //hp2 : tstringconstnode;
+           is_real : boolean;
+           realtype : tfloattype;
+           procedureprefix : string;
+
+          begin
+           dummycoll.init;
+           dummycoll.register:=R_NO;
+           pushusedregisters(pushed,$ff);
+           node:=tcallparanode(left);
+           is_real:=false;
+           while assigned(node.right) do node:=tcallparanode(node.right);
+           { if a real parameter somewhere then call REALSTR }
+           if (node.left.resulttype^.deftype=floatdef) then
+            begin
+              is_real:=true;
+              realtype:=pfloatdef(node.left.resulttype)^.typ;
+            end;
+
+           node:=tcallparanode(left);
+           { we have at least two args }
+           { with at max 2 colon_para in between }
+
+           { string arg }
+           hp:=node;
+           node:=tcallparanode(node.right);
+           hp.right:=nil;
+           dummycoll.paratyp:=vs_var;
+           if is_shortstring(hp.resulttype) then
+             dummycoll.paratype.setdef(openshortstringdef)
+           else
+             dummycoll.paratype.setdef(hp.resulttype);
+           procedureprefix:='FPC_'+pstringdef(hp.resulttype)^.stringtypname+'_';
+           tcallparanode(hp).secondcallparan(@dummycoll,false,false,false,0,0);
+           if codegenerror then
+             exit;
+
+           dummycoll.paratyp:=vs_const;
+           left.free;
+           left:=nil;
+           { second arg }
+           hp:=node;
+           node:=tcallparanode(node.right);
+           hp.right:=nil;
+
+           { if real push real type }
+           if is_real then
+             push_int(ord(realtype));
+
+           { frac  para }
+           if (cpf_is_colon_para in hp.callparaflags) and assigned(node) and
+              (cpf_is_colon_para in node.callparaflags) then
+             begin
+                dummycoll.paratype.setdef(hp.resulttype);
+                dummycoll.paratyp:=vs_value;
+                tcallparanode(hp).secondcallparan(@dummycoll,false,false,false,0,0);
+                if codegenerror then
+                  exit;
+                hp.free;
+                hp:=node;
+                node:=tcallparanode(node.right);
+                hp.right:=nil;
+             end
+           else
+             if is_real then
+             push_int(-1);
+
+           { third arg, length only if is_real }
+           if (cpf_is_colon_para in hp.callparaflags) then
+             begin
+                dummycoll.paratype.setdef(hp.resulttype);
+                dummycoll.paratyp:=vs_value;
+                tcallparanode(hp).secondcallparan(@dummycoll,false,false,false,0,0);
+                if codegenerror then
+                  exit;
+                hp.free;
+                hp:=node;
+                node:=tcallparanode(node.right);
+                hp.right:=nil;
+             end
+           else
+             if is_real then
+               push_int(-32767)
+             else
+               push_int(-1);
+
+           { Convert float to bestreal }
+           if is_real then
+            begin
+              hp.left:=gentypeconvnode(hp.left,bestrealdef^);
+              firstpass(hp.left);
+            end;
+
+           { last arg longint or real }
+           dummycoll.paratype.setdef(hp.resulttype);
+           dummycoll.paratyp:=vs_value;
+           tcallparanode(hp).secondcallparan(@dummycoll,false,false,false,0,0);
+           if codegenerror then
+             exit;
+
+           if is_real then
+             emitcall(procedureprefix+'FLOAT')
+           else
+             case porddef(hp.resulttype)^.typ of
+                u32bit:
+                  emitcall(procedureprefix+'CARDINAL');
+
+                u64bit:
+                  emitcall(procedureprefix+'QWORD');
+
+                s64bit:
+                  emitcall(procedureprefix+'INT64');
+
+                else
+                  emitcall(procedureprefix+'LONGINT');
+             end;
+           hp.free;
+
+           popusedregisters(pushed);
+        end;
+
+
+        Procedure Handle_Val;
+        var
+           hp,node,
+           code_para, dest_para : tcallparanode;
+           hreg,hreg2: TRegister;
+           hdef: POrdDef;
+           procedureprefix : string;
+           hr, hr2: TReference;
+           dummycoll : tparaitem;
+           has_code, has_32bit_code, oldregisterdef: boolean;
+           r : preference;
+
+          begin
+           dummycoll.init;
+           dummycoll.register:=R_NO;
+           node:=tcallparanode(left);
+           hp:=node;
+           node:=tcallparanode(node.right);
+           hp.right:=nil;
+          {if we have 3 parameters, we have a code parameter}
+           has_code := Assigned(node.right);
+           has_32bit_code := false;
+           reset_reference(hr);
+           hreg := R_NO;
+
+           If has_code then
+             Begin
+               {code is an orddef, that's checked in tcinl}
+               code_para := hp;
+               hp := node;
+               node := tcallparanode(node.right);
+               hp.right := nil;
+               has_32bit_code := (porddef(tcallparanode(code_para).left.resulttype)^.typ in [u32bit,s32bit]);
+             End;
+
+          {hp = destination now, save for later use}
+           dest_para := hp;
+
+          {if EAX is already in use, it's a register variable. Since we don't
+           need another register besides EAX, release the one we got}
+           If hreg <> R_EAX Then ungetregister32(hreg);
+
+          {load and push the address of the destination}
+           dummycoll.paratyp:=vs_var;
+           dummycoll.paratype.setdef(dest_para.resulttype);
+           dest_para.secondcallparan(@dummycoll,false,false,false,0,0);
+           if codegenerror then
+             exit;
+
+          {save the regvars}
+           pushusedregisters(pushed,$ff);
+
+          {now that we've already pushed the addres of dest_para.left on the
+           stack, we can put the real parameters on the stack}
+
+           If has_32bit_code Then
+             Begin
+               dummycoll.paratyp:=vs_var;
+               dummycoll.paratype.setdef(code_para.resulttype);
+               code_para.secondcallparan(@dummycoll,false,false,false,0,0);
+               if codegenerror then
+                 exit;
+               code_para.free;
+             End
+           Else
+             Begin
+           {only 32bit code parameter is supported, so fake one}
+               GetTempOfSizeReference(4,hr);
+               emitpushreferenceaddr(hr);
+             End;
+
+          {node = first parameter = string}
+           dummycoll.paratyp:=vs_const;
+           dummycoll.paratype.setdef(node.resulttype);
+           node.secondcallparan(@dummycoll,false,false,false,0,0);
+           if codegenerror then
+             exit;
+
+           Case dest_para.resulttype^.deftype of
+             floatdef:
+               begin
+                  procedureprefix := 'FPC_VAL_REAL_';
+                  if pfloatdef(resulttype)^.typ<>f32bit then
+                    inc(fpuvaroffset);
+               end;
+             orddef:
+               if is_64bitint(dest_para.resulttype) then
+                 begin
+                    if is_signed(dest_para.resulttype) then
+                      procedureprefix := 'FPC_VAL_INT64_'
+                    else
+                      procedureprefix := 'FPC_VAL_QWORD_';
+                 end
+               else
+                 begin
+                    if is_signed(dest_para.resulttype) then
+                      begin
+                        {if we are converting to a signed number, we have to include the
+                         size of the destination, so the Val function can extend the sign
+                         of the result to allow proper range checking}
+                        emit_const(A_PUSH,S_L,dest_para.resulttype^.size);
+                        procedureprefix := 'FPC_VAL_SINT_'
+                      end
+                    else
+                      procedureprefix := 'FPC_VAL_UINT_';
+                 end;
+           End;
+           emitcall(procedureprefix+pstringdef(node.resulttype)^.stringtypname);
+           { before disposing node we need to ungettemp !! PM }
+           if node.left.location.loc in [LOC_REFERENCE,LOC_MEM] then
+             ungetiftemp(node.left.location.reference);
+           node.free;
+           left := nil;
+
+          {reload esi in case the dest_para/code_para is a class variable or so}
+           maybe_loadesi;
+
+           If (dest_para.resulttype^.deftype = orddef) Then
+             Begin
+              {store the result in a safe place, because EAX may be used by a
+               register variable}
+               hreg := getexplicitregister32(R_EAX);
+               emit_reg_reg(A_MOV,S_L,R_EAX,hreg);
+               if is_64bitint(dest_para.resulttype) then
+                 begin
+                    hreg2:=getexplicitregister32(R_EDX);
+                    emit_reg_reg(A_MOV,S_L,R_EDX,hreg2);
+                 end;
+              {as of now, hreg now holds the location of the result, if it was
+               integer}
+             End;
+
+           { restore the register vars}
+
+           popusedregisters(pushed);
+
+           If has_code and Not(has_32bit_code) Then
+             {only 16bit code is possible}
+             Begin
+              {load the address of the code parameter}
+               secondpass(code_para.left);
+              {move the code to its destination}
+{$ifndef noAllocEdi}
+               getexplicitregister32(R_EDI);
+{$endif noAllocEdi}
+               emit_ref_reg(A_MOV,S_L,NewReference(hr),R_EDI);
+               emit_mov_reg_loc(R_DI,code_para.left.location);
+{$ifndef noAllocEdi}
+               ungetregister32(R_EDI);
+{$endif noAllocEdi}
+               code_para.free;
+             End;
+
+          {restore the address of the result}
+{$ifndef noAllocEdi}
+           getexplicitregister32(R_EDI);
+{$endif noAllocEdi}
+           emit_reg(A_POP,S_L,R_EDI);
+
+          {set up hr2 to a refernce with EDI as base register}
+           reset_reference(hr2);
+           hr2.base := R_EDI;
+
+          {save the function result in the destination variable}
+           Case dest_para.left.resulttype^.deftype of
+             floatdef:
+               floatstore(PFloatDef(dest_para.left.resulttype)^.typ, hr2);
+             orddef:
+               Case PordDef(dest_para.left.resulttype)^.typ of
+                 u8bit,s8bit:
+                   emit_reg_ref(A_MOV, S_B,
+                     RegToReg8(hreg),newreference(hr2));
+                 u16bit,s16bit:
+                   emit_reg_ref(A_MOV, S_W,
+                     RegToReg16(hreg),newreference(hr2));
+                 u32bit,s32bit:
+                   emit_reg_ref(A_MOV, S_L,
+                     hreg,newreference(hr2));
+                 u64bit,s64bit:
+                   begin
+                      emit_reg_ref(A_MOV, S_L,
+                        hreg,newreference(hr2));
+                      r:=newreference(hr2);
+                      inc(r^.offset,4);
+                      emit_reg_ref(A_MOV, S_L,
+                        hreg2,r);
+                   end;
+               End;
+           End;
+{$ifndef noAllocEdi}
+           ungetregister32(R_EDI);
+{$endif noAllocEdi}
+           If (cs_check_range in aktlocalswitches) and
+              (dest_para.left.resulttype^.deftype = orddef) and
+              (not(is_64bitint(dest_para.left.resulttype))) and
+            {the following has to be changed to 64bit checking, once Val
+             returns 64 bit values (unless a special Val function is created
+             for that)}
+            {no need to rangecheck longints or cardinals on 32bit processors}
+               not((porddef(dest_para.left.resulttype)^.typ = s32bit) and
+                   (porddef(dest_para.left.resulttype)^.low = longint($80000000)) and
+                   (porddef(dest_para.left.resulttype)^.high = $7fffffff)) and
+               not((porddef(dest_para.left.resulttype)^.typ = u32bit) and
+                   (porddef(dest_para.left.resulttype)^.low = 0) and
+                   (porddef(dest_para.left.resulttype)^.high = longint($ffffffff))) then
+             Begin
+               hp:=tcallparanode(dest_para.left.getcopy);
+               hp.location.loc := LOC_REGISTER;
+               hp.location.register := hreg;
+              {do not register this temporary def}
+               OldRegisterDef := RegisterDef;
+               RegisterDef := False;
+               Case PordDef(dest_para.left.resulttype)^.typ of
+                 u8bit,u16bit,u32bit: new(hdef,init(u32bit,0,$ffffffff));
+                 s8bit,s16bit,s32bit: new(hdef,init(s32bit,$80000000,$7fffffff));
+               end;
+               hp.resulttype := hdef;
+               emitrangecheck(hp,dest_para.left.resulttype);
+               hp.right := nil;
+               Dispose(hp.resulttype, Done);
+               RegisterDef := OldRegisterDef;
+               hp.free;
+             End;
+          {dest_para.right is already nil}
+           dest_para.free;
+           UnGetIfTemp(hr);
+        end;
+
+      var
+         r : preference;
+         //hp : tcallparanode;
+         hp2 : tstringconstnode;
+         l : longint;
+         ispushed : boolean;
+         hregister : tregister;
+         otlabel,oflabel{,l1}   : pasmlabel;
+         oldpushedparasize : longint;
+
+      begin
+      { save & reset pushedparasize }
+         oldpushedparasize:=pushedparasize;
+         pushedparasize:=0;
+         case inlinenumber of
+            in_assert_x_y:
+              begin
+                 { the node should be removed in the firstpass }
+                 if not (cs_do_assertion in aktlocalswitches) then
+                  internalerror(7123458);
+                 otlabel:=truelabel;
+                 oflabel:=falselabel;
+                 getlabel(truelabel);
+                 getlabel(falselabel);
+                 secondpass(tcallparanode(left).left);
+                 maketojumpbool(tcallparanode(left).left);
+                 emitlab(falselabel);
+                 { erroraddr }
+                 emit_reg(A_PUSH,S_L,R_EBP);
+                 { lineno }
+                 emit_const(A_PUSH,S_L,aktfilepos.line);
+                 { filename string }
+                 hp2:=genstringconstnode(current_module^.sourcefiles^.get_file_name(aktfilepos.fileindex),st_shortstring);
+                 secondpass(hp2);
+                 if codegenerror then
+                  exit;
+                 emitpushreferenceaddr(hp2.location.reference);
+                 hp2.free;
+                 { push msg }
+                 secondpass(tcallparanode(tcallparanode(left).right).left);
+                 emitpushreferenceaddr(tcallparanode(tcallparanode(left).right).left.location.reference);
+                 { call }
+                 emitcall('FPC_ASSERT');
+                 emitlab(truelabel);
+                 truelabel:=otlabel;
+                 falselabel:=oflabel;
+              end;
+            in_lo_word,
+            in_hi_word :
+              begin
+                 secondpass(left);
+                 location.loc:=LOC_REGISTER;
+                 if left.location.loc<>LOC_REGISTER then
+                   begin
+                     if left.location.loc=LOC_CREGISTER then
+                       begin
+                          location.register:=reg32toreg16(getregister32);
+                          emit_reg_reg(A_MOV,S_W,left.location.register,
+                            location.register);
+                       end
+                     else
+                       begin
+                          del_reference(left.location.reference);
+                          location.register:=reg32toreg16(getregister32);
+                          emit_ref_reg(A_MOV,S_W,newreference(left.location.reference),
+                            location.register);
+                       end;
+                   end
+                 else location.register:=left.location.register;
+                 if inlinenumber=in_hi_word then
+                   emit_const_reg(A_SHR,S_W,8,location.register);
+                 location.register:=reg16toreg8(location.register);
+              end;
+            in_sizeof_x,
+            in_typeof_x :
+              begin
+                 { for both cases load vmt }
+                 if left.nodetype=typen then
+                   begin
+                      location.register:=getregister32;
+                      emit_sym_ofs_reg(A_MOV,
+                        S_L,newasmsymbol(pobjectdef(left.resulttype)^.vmt_mangledname),0,
+                        location.register);
+                   end
+                 else
+                   begin
+                      secondpass(left);
+                      del_reference(left.location.reference);
+                      location.loc:=LOC_REGISTER;
+                      location.register:=getregister32;
+                      { load VMT pointer }
+                      inc(left.location.reference.offset,
+                        pobjectdef(left.resulttype)^.vmt_offset);
+                      emit_ref_reg(A_MOV,S_L,
+                      newreference(left.location.reference),
+                        location.register);
+                   end;
+                 { in sizeof load size }
+                 if inlinenumber=in_sizeof_x then
+                   begin
+                      new(r);
+                      reset_reference(r^);
+                      r^.base:=location.register;
+                      emit_ref_reg(A_MOV,S_L,r,
+                        location.register);
+                   end;
+              end;
+            in_lo_long,
+            in_hi_long :
+              begin
+                 secondpass(left);
+                 location.loc:=LOC_REGISTER;
+                 if left.location.loc<>LOC_REGISTER then
+                   begin
+                      if left.location.loc=LOC_CREGISTER then
+                        begin
+                           location.register:=getregister32;
+                           emit_reg_reg(A_MOV,S_L,left.location.register,
+                             location.register);
+                        end
+                      else
+                        begin
+                           del_reference(left.location.reference);
+                           location.register:=getregister32;
+                           emit_ref_reg(A_MOV,S_L,newreference(left.location.reference),
+                             location.register);
+                        end;
+                   end
+                 else location.register:=left.location.register;
+                 if inlinenumber=in_hi_long then
+                   emit_const_reg(A_SHR,S_L,16,location.register);
+                 location.register:=reg32toreg16(location.register);
+              end;
+            in_lo_qword,
+            in_hi_qword:
+              begin
+                 secondpass(left);
+                 location.loc:=LOC_REGISTER;
+                 case left.location.loc of
+                    LOC_CREGISTER:
+                      begin
+                         location.register:=getregister32;
+                         if inlinenumber=in_hi_qword then
+                           emit_reg_reg(A_MOV,S_L,left.location.registerhigh,
+                             location.register)
+                         else
+                           emit_reg_reg(A_MOV,S_L,left.location.registerlow,
+                             location.register)
+                      end;
+                    LOC_MEM,LOC_REFERENCE:
+                      begin
+                         del_reference(left.location.reference);
+                         location.register:=getregister32;
+                         r:=newreference(left.location.reference);
+                         if inlinenumber=in_hi_qword then
+                           inc(r^.offset,4);
+                         emit_ref_reg(A_MOV,S_L,
+                           r,location.register);
+                      end;
+                    LOC_REGISTER:
+                      begin
+                         if inlinenumber=in_hi_qword then
+                           begin
+                              location.register:=left.location.registerhigh;
+                              ungetregister32(left.location.registerlow);
+                           end
+                         else
+                           begin
+                              location.register:=left.location.registerlow;
+                              ungetregister32(left.location.registerhigh);
+                           end;
+                      end;
+                 end;
+              end;
+            in_length_string :
+              begin
+                 secondpass(left);
+                 set_location(location,left.location);
+                 { length in ansi strings is at offset -8 }
+                 if is_ansistring(left.resulttype) then
+                   dec(location.reference.offset,8)
+                 { char is always 1, so make it a constant value }
+                 else if is_char(left.resulttype) then
+                   begin
+                     clear_location(location);
+                     location.loc:=LOC_MEM;
+                     location.reference.is_immediate:=true;
+                     location.reference.offset:=1;
+                   end;
+              end;
+            in_pred_x,
+            in_succ_x:
+              begin
+                 secondpass(left);
+                 if not (cs_check_overflow in aktlocalswitches) then
+                   if inlinenumber=in_pred_x then
+                     asmop:=A_DEC
+                   else
+                     asmop:=A_INC
+                 else
+                   if inlinenumber=in_pred_x then
+                     asmop:=A_SUB
+                   else
+                     asmop:=A_ADD;
+                 case resulttype^.size of
+                   8 : opsize:=S_L;
+                   4 : opsize:=S_L;
+                   2 : opsize:=S_W;
+                   1 : opsize:=S_B;
+                 else
+                   internalerror(10080);
+                 end;
+                 location.loc:=LOC_REGISTER;
+                 if resulttype^.size=8 then
+                   begin
+                      if left.location.loc<>LOC_REGISTER then
+                        begin
+                           if left.location.loc=LOC_CREGISTER then
+                             begin
+                                location.registerlow:=getregister32;
+                                location.registerhigh:=getregister32;
+                                emit_reg_reg(A_MOV,opsize,left.location.registerlow,
+                                  location.registerlow);
+                                emit_reg_reg(A_MOV,opsize,left.location.registerhigh,
+                                  location.registerhigh);
+                             end
+                           else
+                             begin
+                                del_reference(left.location.reference);
+                                location.registerlow:=getregister32;
+                                location.registerhigh:=getregister32;
+                                emit_ref_reg(A_MOV,opsize,newreference(left.location.reference),
+                                  location.registerlow);
+                                r:=newreference(left.location.reference);
+                                inc(r^.offset,4);
+                                emit_ref_reg(A_MOV,opsize,r,
+                                  location.registerhigh);
+                             end;
+                        end
+                      else
+                        begin
+                           location.registerhigh:=left.location.registerhigh;
+                           location.registerlow:=left.location.registerlow;
+                        end;
+                      if inlinenumber=in_succ_x then
+                        begin
+                           emit_const_reg(A_ADD,opsize,1,
+                             location.registerlow);
+                           emit_const_reg(A_ADC,opsize,0,
+                             location.registerhigh);
+                        end
+                      else
+                        begin
+                           emit_const_reg(A_SUB,opsize,1,
+                             location.registerlow);
+                           emit_const_reg(A_SBB,opsize,0,
+                             location.registerhigh);
+                        end;
+                   end
+                 else
+                   begin
+                      if left.location.loc<>LOC_REGISTER then
+                        begin
+                           { first, we've to release the source location ... }
+                           if left.location.loc in [LOC_MEM,LOC_REFERENCE] then
+                             del_reference(left.location.reference);
+
+                           location.register:=getregister32;
+                           if (resulttype^.size=2) then
+                             location.register:=reg32toreg16(location.register);
+                           if (resulttype^.size=1) then
+                             location.register:=reg32toreg8(location.register);
+                           if left.location.loc=LOC_CREGISTER then
+                             emit_reg_reg(A_MOV,opsize,left.location.register,
+                               location.register)
+                           else
+                           if left.location.loc=LOC_FLAGS then
+                             emit_flag2reg(left.location.resflags,location.register)
+                           else
+                             emit_ref_reg(A_MOV,opsize,newreference(left.location.reference),
+                               location.register);
+                        end
+                      else location.register:=left.location.register;
+                      if not (cs_check_overflow in aktlocalswitches) then
+                        emit_reg(asmop,opsize,
+                        location.register)
+                      else
+                        emit_const_reg(asmop,opsize,1,
+                        location.register);
+                   end;
+                 emitoverflowcheck(self);
+                 emitrangecheck(self,resulttype);
+              end;
+            in_dec_x,
+            in_inc_x :
+              begin
+              { set defaults }
+                addvalue:=1;
+                addconstant:=true;
+              { load first parameter, must be a reference }
+                secondpass(tcallparanode(left).left);
+                case tcallparanode(left).left.resulttype^.deftype of
+                  orddef,
+                 enumdef : begin
+                             case tcallparanode(left).left.resulttype^.size of
+                              1 : opsize:=S_B;
+                              2 : opsize:=S_W;
+                              4 : opsize:=S_L;
+                              8 : opsize:=S_L;
+                             end;
+                           end;
+              pointerdef : begin
+                             opsize:=S_L;
+                             if porddef(ppointerdef(tcallparanode(left).left.resulttype)^.pointertype.def)=voiddef then
+                              addvalue:=1
+                             else
+                              addvalue:=ppointerdef(tcallparanode(left).left.resulttype)^.pointertype.def^.size;
+                           end;
+                else
+                 internalerror(10081);
+                end;
+              { second argument specified?, must be a s32bit in register }
+                if assigned(tcallparanode(left).right) then
+                 begin
+                   ispushed:=maybe_push(tcallparanode(tcallparanode(left).right).left.registers32,
+                     tcallparanode(left).left,false);
+                   secondpass(tcallparanode(tcallparanode(left).right).left);
+                   if ispushed then
+                     restore(tcallparanode(left).left,false);
+                 { when constant, just multiply the addvalue }
+                   if is_constintnode(tcallparanode(tcallparanode(left).right).left) then
+                    addvalue:=addvalue*get_ordinal_value(tcallparanode(tcallparanode(left).right).left)
+                   else
+                    begin
+                      case tcallparanode(tcallparanode(left).right).left.location.loc of
+                   LOC_REGISTER,
+                  LOC_CREGISTER : hregister:=tcallparanode(tcallparanode(left).right).left.location.register;
+                        LOC_MEM,
+                  LOC_REFERENCE : begin
+                                    del_reference(tcallparanode(tcallparanode(left).right).left.location.reference);
+                                    hregister:=getregister32;
+                                    emit_ref_reg(A_MOV,S_L,
+                                      newreference(tcallparanode(tcallparanode(left).right).left.location.reference),hregister);
+                                  end;
+                       else
+                        internalerror(10082);
+                       end;
+                    { insert multiply with addvalue if its >1 }
+                      if addvalue>1 then
+                       emit_const_reg(A_IMUL,opsize,
+                         addvalue,hregister);
+                      addconstant:=false;
+                    end;
+                 end;
+              { write the add instruction }
+                if addconstant then
+                 begin
+                   if (addvalue=1) and not(cs_check_overflow in aktlocalswitches) then
+                     begin
+                        if tcallparanode(left).left.location.loc=LOC_CREGISTER then
+                          emit_reg(incdecop[inlinenumber],opsize,
+                            tcallparanode(left).left.location.register)
+                        else
+                          emit_ref(incdecop[inlinenumber],opsize,
+                            newreference(tcallparanode(left).left.location.reference))
+                     end
+                   else
+                     begin
+                        if tcallparanode(left).left.location.loc=LOC_CREGISTER then
+                          emit_const_reg(addsubop[inlinenumber],opsize,
+                            addvalue,tcallparanode(left).left.location.register)
+                        else
+                          emit_const_ref(addsubop[inlinenumber],opsize,
+                            addvalue,newreference(tcallparanode(left).left.location.reference));
+                     end
+                 end
+                else
+                 begin
+                    { BUG HERE : detected with nasm :
+                      hregister is allways 32 bit
+                      it should be converted to 16 or 8 bit depending on op_size  PM }
+                    { still not perfect :
+                      if hregister is already a 16 bit reg ?? PM }
+                    { makeregXX is the solution (FK) }
+                    case opsize of
+                      S_B : hregister:=makereg8(hregister);
+                      S_W : hregister:=makereg16(hregister);
+                    end;
+                    if tcallparanode(left).left.location.loc=LOC_CREGISTER then
+                      emit_reg_reg(addsubop[inlinenumber],opsize,
+                        hregister,tcallparanode(left).left.location.register)
+                    else
+                      emit_reg_ref(addsubop[inlinenumber],opsize,
+                        hregister,newreference(tcallparanode(left).left.location.reference));
+                    case opsize of
+                      S_B : hregister:=reg8toreg32(hregister);
+                      S_W : hregister:=reg16toreg32(hregister);
+                    end;
+                   ungetregister32(hregister);
+                 end;
+                emitoverflowcheck(tcallparanode(left).left);
+                emitrangecheck(tcallparanode(left).left,tcallparanode(left).left.resulttype);
+              end;
+            in_typeinfo_x:
+               begin
+                  ttypenode(tcallparanode(left).left).typenodetype^.generate_rtti;
+                  location.register:=getregister32;
+                  new(r);
+                  reset_reference(r^);
+                  r^.symbol:=ttypenode(tcallparanode(left).left).typenodetype^.rtti_label;
+                  emit_ref_reg(A_MOV,S_L,r,location.register);
+               end;
+            in_assigned_x :
+              begin
+                 secondpass(tcallparanode(left).left);
+                 location.loc:=LOC_FLAGS;
+                 if (tcallparanode(left).left.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then
+                   begin
+                      emit_reg_reg(A_OR,S_L,
+                        tcallparanode(left).left.location.register,
+                        tcallparanode(left).left.location.register);
+                      ungetregister32(tcallparanode(left).left.location.register);
+                   end
+                 else
+                   begin
+                      emit_const_ref(A_CMP,S_L,0,
+                        newreference(tcallparanode(left).left.location.reference));
+                      del_reference(tcallparanode(left).left.location.reference);
+                   end;
+                 location.resflags:=F_NE;
+              end;
+             in_reset_typedfile,in_rewrite_typedfile :
+               begin
+                  pushusedregisters(pushed,$ff);
+                  emit_const(A_PUSH,S_L,pfiledef(left.resulttype)^.typedfiletype.def^.size);
+                  secondpass(left);
+                  emitpushreferenceaddr(left.location.reference);
+                  if inlinenumber=in_reset_typedfile then
+                    emitcall('FPC_RESET_TYPED')
+                  else
+                    emitcall('FPC_REWRITE_TYPED');
+                  popusedregisters(pushed);
+               end;
+            in_write_x :
+              handlereadwrite(false,false);
+            in_writeln_x :
+              handlereadwrite(false,true);
+            in_read_x :
+              handlereadwrite(true,false);
+            in_readln_x :
+              handlereadwrite(true,true);
+            in_str_x_string :
+              begin
+                 handle_str;
+                 maybe_loadesi;
+              end;
+            in_val_x :
+              Begin
+                handle_val;
+              End;
+            in_include_x_y,
+            in_exclude_x_y:
+              begin
+                 secondpass(tcallparanode(left).left);
+                 if tcallparanode(tcallparanode(left).right).left.nodetype=ordconstn then
+                   begin
+                      { calculate bit position }
+                      l:=1 shl (tordconstnode(tcallparanode(tcallparanode(left).right).left).value mod 32);
+
+                      { determine operator }
+                      if inlinenumber=in_include_x_y then
+                        asmop:=A_OR
+                      else
+                        begin
+                           asmop:=A_AND;
+                           l:=not(l);
+                        end;
+                      if (tcallparanode(left).left.location.loc=LOC_REFERENCE) then
+                        begin
+                           inc(tcallparanode(left).left.location.reference.offset,
+                             (tordconstnode(tcallparanode(tcallparanode(left).right).left).value div 32)*4);
+                           emit_const_ref(asmop,S_L,
+                             l,newreference(tcallparanode(left).left.location.reference));
+                           del_reference(tcallparanode(left).left.location.reference);
+                        end
+                      else
+                        { LOC_CREGISTER }
+                        emit_const_reg(asmop,S_L,
+                          l,tcallparanode(left).left.location.register);
+                   end
+                 else
+                   begin
+                      { generate code for the element to set }
+                      ispushed:=maybe_push(tcallparanode(tcallparanode(left).right).left.registers32,
+                        tcallparanode(left).left,false);
+                      secondpass(tcallparanode(tcallparanode(left).right).left);
+                      if ispushed then
+                        restore(tcallparanode(left).left,false);
+                      { determine asm operator }
+                      if inlinenumber=in_include_x_y then
+                        asmop:=A_BTS
+                      else
+                        asmop:=A_BTR;
+                      if psetdef(left.resulttype)^.settype=smallset then
+                        begin
+                           if tcallparanode(tcallparanode(left).right).left.location.loc in [LOC_CREGISTER,LOC_REGISTER] then
+                             { we don't need a mod 32 because this is done automatically  }
+                             { by the bts instruction. For proper checking we would       }
+                             { need a cmp and jmp, but this should be done by the         }
+                             { type cast code which does range checking if necessary (FK) }
+                             hregister:=makereg32(tcallparanode(tcallparanode(left).right).left.location.register)
+                           else
+                             begin
+                                getexplicitregister32(R_EDI);
+                                hregister:=R_EDI;
+                                opsize:=def2def_opsize(
+                                  tcallparanode(tcallparanode(left).right).left.resulttype,u32bitdef);
+                                if opsize in [S_B,S_W,S_L] then
+                                 op:=A_MOV
+                                else
+                                 op:=A_MOVZX;
+                                emit_ref_reg(op,opsize,
+                                  newreference(
+                                    tcallparanode(tcallparanode(left).right).left.location.reference),R_EDI);
+                             end;
+                          if (tcallparanode(left).left.location.loc=LOC_REFERENCE) then
+                            emit_reg_ref(asmop,S_L,hregister,
+                              newreference(tcallparanode(left).left.location.reference))
+                          else
+                            emit_reg_reg(asmop,S_L,hregister,
+                              tcallparanode(left).left.location.register);
+                        if hregister = R_EDI then
+                          ungetregister32(R_EDI);
+                        end
+                      else
+                        begin
+                           pushsetelement(tcallparanode(tcallparanode(left).right).left);
+                           { normset is allways a ref }
+                           emitpushreferenceaddr(tcallparanode(left).left.location.reference);
+                           if inlinenumber=in_include_x_y then
+                             emitcall('FPC_SET_SET_BYTE')
+                           else
+                             emitcall('FPC_SET_UNSET_BYTE');
+                           {CGMessage(cg_e_include_not_implemented);}
+                        end;
+                   end;
+              end;
+            in_pi:
+              begin
+                emit_none(A_FLDPI,S_NO);
+                inc(fpuvaroffset);
+              end;
+            in_sin_extended,
+            in_arctan_extended,
+            in_abs_extended,
+            in_sqr_extended,
+            in_sqrt_extended,
+            in_ln_extended,
+            in_cos_extended:
+              begin
+                 secondpass(left);
+                 case left.location.loc of
+                    LOC_FPU:
+                      ;
+                    LOC_CFPUREGISTER:
+                      begin
+                         emit_reg(A_FLD,S_NO,
+                           correct_fpuregister(left.location.register,fpuvaroffset));
+                         inc(fpuvaroffset);
+                      end;
+                    LOC_REFERENCE,LOC_MEM:
+                      begin
+                         floatload(pfloatdef(left.resulttype)^.typ,left.location.reference);
+                         del_reference(left.location.reference);
+                      end
+                    else
+                      internalerror(309991);
+                 end;
+                 case inlinenumber of
+                    in_sin_extended,
+                    in_cos_extended:
+                      begin
+                         if inlinenumber=in_sin_extended then
+                           emit_none(A_FSIN,S_NO)
+                         else
+                           emit_none(A_FCOS,S_NO);
+                         {
+                         getlabel(l1);
+                         emit_reg(A_FNSTSW,S_NO,R_AX);
+                         emit_none(A_SAHF,S_NO);
+                         emitjmp(C_NP,l1);
+                         emit_reg(A_FSTP,S_NO,R_ST0);
+                         emit_none(A_FLDZ,S_NO);
+                         emitlab(l1);
+                         }
+                      end;
+                    in_arctan_extended:
+                      begin
+                         emit_none(A_FLD1,S_NO);
+                         emit_none(A_FPATAN,S_NO);
+                      end;
+                    in_abs_extended:
+                      emit_none(A_FABS,S_NO);
+                    in_sqr_extended:
+                      begin
+                         (* emit_reg(A_FLD,S_NO,R_ST0);
+                         { emit_none(A_FMULP,S_NO); nasm does not accept this PM }
+                         emit_reg_reg(A_FMULP,S_NO,R_ST0,R_ST1);
+                           can be shorten to *)
+                         emit_reg_reg(A_FMUL,S_NO,R_ST0,R_ST0);
+                      end;
+                    in_sqrt_extended:
+                      emit_none(A_FSQRT,S_NO);
+                    in_ln_extended:
+                      begin
+                         emit_none(A_FLDLN2,S_NO);
+                         emit_none(A_FXCH,S_NO);
+                         emit_none(A_FYL2X,S_NO);
+                      end;
+                 end;
+              end;
+{$ifdef SUPPORT_MMX}
+            in_mmx_pcmpeqb..in_mmx_pcmpgtw:
+              begin
+                 if left.location.loc=LOC_REGISTER then
+                   begin
+                      {!!!!!!!}
+                   end
+                 else if tcallparanode(left).left.location.loc=LOC_REGISTER then
+                   begin
+                      {!!!!!!!}
+                   end
+                 else
+                   begin
+                      {!!!!!!!}
+                   end;
+              end;
+{$endif SUPPORT_MMX}
+            else internalerror(9);
+         end;
+         { reset pushedparasize }
+         pushedparasize:=oldpushedparasize;
+      end;
+
+begin
+   cinlinenode:=ti386inlinenode;
+end.
+{
+  $Log$
+  Revision 1.1  2000-10-14 10:14:49  peter
+    * moehrendorf oct 2000 rewrite
+
+}

compiler/n386ld.pas

@@ -0,0 +1,1070 @@
+{
+    $Id$
+    Copyright (c) 1998-2000 by Florian Klaempfl
+
+    Generate i386 assembler for load/assignment nodes
+
+    This program is free software; you can redistribute it and/or modify
+    it under the terms of the GNU General Public License as published by
+    the Free Software Foundation; either version 2 of the License, or
+    (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU General Public License for more details.
+
+    You should have received a copy of the GNU General Public License
+    along with this program; if not, write to the Free Software
+    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ ****************************************************************************
+}
+unit n386ld;
+
+{$i defines.inc}
+
+interface
+
+    uses
+      node,nld;
+
+    type
+       ti386loadnode = class(tloadnode)
+          procedure pass_2;override;
+       end;
+
+       ti386assignmentnode = class(tassignmentnode)
+          procedure pass_2;override;
+       end;
+
+       ti386funcretnode = class(tfuncretnode)
+          procedure pass_2;override;
+       end;
+
+       ti386arrayconstructornode = class(tarrayconstructornode)
+          procedure pass_2;override;
+       end;
+
+implementation
+
+    uses
+      globtype,systems,
+      cobjects,verbose,globals,fmodule,
+      symconst,symtable,aasm,types,
+      hcodegen,temp_gen,pass_2,
+      nmem,ncon,ncnv,
+      cpubase,cpuasm,
+      cgai386,tgeni386,n386cnv,n386util,cresstr;
+
+{*****************************************************************************
+                             SecondLoad
+*****************************************************************************}
+
+    procedure ti386loadnode.pass_2;
+      var
+         hregister : tregister;
+         symtabletype : tsymtabletype;
+         i : longint;
+         hp : preference;
+         s : pasmsymbol;
+         popeax : boolean;
+         pushed : tpushed;
+         hr : treference;
+
+      begin
+         simple_loadn:=true;
+         reset_reference(location.reference);
+         case symtableentry^.typ of
+              { this is only for toasm and toaddr }
+              absolutesym :
+                 begin
+                    location.reference.symbol:=nil;
+                    if (pabsolutesym(symtableentry)^.abstyp=toaddr) then
+                     begin
+                       if pabsolutesym(symtableentry)^.absseg then
+                        location.reference.segment:=R_FS;
+                       location.reference.offset:=pabsolutesym(symtableentry)^.address;
+                     end
+                    else
+                     location.reference.symbol:=newasmsymbol(symtableentry^.mangledname);
+                 end;
+              constsym:
+                begin
+                   if pconstsym(symtableentry)^.consttyp=constresourcestring then
+                     begin
+                         pushusedregisters(pushed,$ff);
+                         emit_const(A_PUSH,S_L,
+                           pconstsym(symtableentry)^.resstrindex);
+                         emit_sym(A_PUSH,S_L,newasmsymbol(pconstsym(symtableentry)^.owner^.name^+'_RESOURCESTRINGLIST'));
+                         emitcall('FPC_GETRESOURCESTRING');
+
+                         hregister:=getexplicitregister32(R_EAX);
+                         emit_reg_reg(A_MOV,S_L,R_EAX,hregister);
+                         gettempansistringreference(hr);
+                         decrstringref(resulttype,hr);
+                         emit_reg_ref(A_MOV,S_L,hregister,
+                           newreference(hr));
+                        ungetregister32(hregister);
+                        popusedregisters(pushed);
+
+                        location.loc:=LOC_MEM;
+                        location.reference:=hr;
+                     end
+                   else
+                     internalerror(22798);
+                end;
+              varsym :
+                 begin
+                    hregister:=R_NO;
+                    { C variable }
+                    if (vo_is_C_var in pvarsym(symtableentry)^.varoptions) then
+                      begin
+                         location.reference.symbol:=newasmsymbol(symtableentry^.mangledname);
+                      end
+                    { DLL variable }
+                    else if (vo_is_dll_var in pvarsym(symtableentry)^.varoptions) then
+                      begin
+                         hregister:=getregister32;
+                         location.reference.symbol:=newasmsymbol(symtableentry^.mangledname);
+                         emit_ref_reg(A_MOV,S_L,newreference(location.reference),hregister);
+                         location.reference.symbol:=nil;
+                         location.reference.base:=hregister;
+                      end
+                    { external variable }
+                    else if (vo_is_external in pvarsym(symtableentry)^.varoptions) then
+                      begin
+                         location.reference.symbol:=newasmsymbol(symtableentry^.mangledname);
+                      end
+                    { thread variable }
+                    else if (vo_is_thread_var in pvarsym(symtableentry)^.varoptions) then
+                      begin
+                         popeax:=not(R_EAX in unused);
+                         if popeax then
+                           emit_reg(A_PUSH,S_L,R_EAX);
+                         location.reference.symbol:=newasmsymbol(symtableentry^.mangledname);
+                         emit_ref(A_PUSH,S_L,newreference(location.reference));
+                         { the called procedure isn't allowed to change }
+                         { any register except EAX                    }
+                         emitcall('FPC_RELOCATE_THREADVAR');
+
+                         reset_reference(location.reference);
+                         location.reference.base:=getregister32;
+                         emit_reg_reg(A_MOV,S_L,R_EAX,location.reference.base);
+                         if popeax then
+                           emit_reg(A_POP,S_L,R_EAX);
+
+                      end
+                    { normal variable }
+                    else
+                      begin
+                         symtabletype:=symtable^.symtabletype;
+                         { in case it is a register variable: }
+                         if pvarsym(symtableentry)^.reg<>R_NO then
+                           begin
+                              if pvarsym(symtableentry)^.reg in [R_ST0..R_ST7] then
+                                begin
+                                   location.loc:=LOC_CFPUREGISTER;
+                                   location.register:=pvarsym(symtableentry)^.reg;
+                                end
+                              else
+                                begin
+                                   location.loc:=LOC_CREGISTER;
+                                   location.register:=pvarsym(symtableentry)^.reg;
+                                   unused:=unused-[pvarsym(symtableentry)^.reg];
+                                end;
+                           end
+                         else
+                           begin
+                              { first handle local and temporary variables }
+                              if (symtabletype in [parasymtable,inlinelocalsymtable,
+                                                   inlineparasymtable,localsymtable]) then
+                                begin
+                                   location.reference.base:=procinfo^.framepointer;
+                                   if (symtabletype in [inlinelocalsymtable,
+                                                        localsymtable]) then
+                                     location.reference.offset:=
+                                       pvarsym(symtableentry)^.address-symtable^.address_fixup
+                                   else
+                                     location.reference.offset:=
+                                       pvarsym(symtableentry)^.address+symtable^.address_fixup;
+
+                                   if (symtabletype in [localsymtable,inlinelocalsymtable]) then
+                                     begin
+                                        if use_esp_stackframe then
+                                          dec(location.reference.offset,
+                                            pvarsym(symtableentry)^.getvaluesize)
+                                        else
+                                          location.reference.offset:=-location.reference.offset;
+                                     end;
+                                   if (lexlevel>(symtable^.symtablelevel)) then
+                                     begin
+                                        hregister:=getregister32;
+
+                                        { make a reference }
+                                        hp:=new_reference(procinfo^.framepointer,
+                                          procinfo^.framepointer_offset);
+
+                                        emit_ref_reg(A_MOV,S_L,hp,hregister);
+
+                                        simple_loadn:=false;
+                                        i:=lexlevel-1;
+                                        while i>(symtable^.symtablelevel) do
+                                          begin
+                                             { make a reference }
+                                             hp:=new_reference(hregister,8);
+                                             emit_ref_reg(A_MOV,S_L,hp,hregister);
+                                             dec(i);
+                                          end;
+                                        location.reference.base:=hregister;
+                                     end;
+                                end
+                              else
+                                case symtabletype of
+                                   unitsymtable,globalsymtable,
+                                   staticsymtable :
+                                     begin
+                                       location.reference.symbol:=newasmsymbol(symtableentry^.mangledname);
+                                     end;
+                                   stt_exceptsymtable:
+                                     begin
+                                        location.reference.base:=procinfo^.framepointer;
+                                        location.reference.offset:=pvarsym(symtableentry)^.address;
+                                     end;
+                                   objectsymtable:
+                                     begin
+                                        getexplicitregister32(R_ESI);
+                                        if (sp_static in pvarsym(symtableentry)^.symoptions) then
+                                          begin
+                                             location.reference.symbol:=newasmsymbol(symtableentry^.mangledname);
+                                          end
+                                        else
+                                          begin
+                                             location.reference.base:=R_ESI;
+                                             location.reference.offset:=pvarsym(symtableentry)^.address;
+                                          end;
+                                     end;
+                                   withsymtable:
+                                     begin
+                                        { make a reference }
+                                        { symtable datasize field
+                                          contains the offset of the temp
+                                          stored }
+{                                       hp:=new_reference(procinfo^.framepointer,
+                                          symtable^.datasize);
+
+                                        emit_ref_reg(A_MOV,S_L,hp,hregister);}
+
+                                        if nf_islocal in tnode(pwithsymtable(symtable)^.withnode).flags then
+                                         begin
+                                           location.reference:=twithnode(pwithsymtable(symtable)^.withnode).withreference^;
+                                         end
+                                        else
+                                         begin
+                                           hregister:=getregister32;
+                                           location.reference.base:=hregister;
+                                           emit_ref_reg(A_MOV,S_L,
+                                             newreference(twithnode(pwithsymtable(symtable)^.withnode).withreference^),
+                                             hregister);
+                                         end;
+                                        inc(location.reference.offset,pvarsym(symtableentry)^.address);
+                                     end;
+                                end;
+                           end;
+                         { in case call by reference, then calculate. Open array
+                           is always an reference! }
+                         if (pvarsym(symtableentry)^.varspez in [vs_var,vs_out]) or
+                            is_open_array(pvarsym(symtableentry)^.vartype.def) or
+                            is_array_of_const(pvarsym(symtableentry)^.vartype.def) or
+                            ((pvarsym(symtableentry)^.varspez=vs_const) and
+                             push_addr_param(pvarsym(symtableentry)^.vartype.def)) then
+                           begin
+                              simple_loadn:=false;
+                              if hregister=R_NO then
+                                hregister:=getregister32;
+                              if location.loc=LOC_CREGISTER then
+                                begin
+                                   emit_reg_reg(A_MOV,S_L,
+                                     location.register,hregister);
+                                   location.loc:=LOC_REFERENCE;
+                                end
+                              else
+                                begin
+                                   emit_ref_reg(A_MOV,S_L,
+                                     newreference(location.reference),
+                                     hregister);
+                                end;
+                              reset_reference(location.reference);
+                              location.reference.base:=hregister;
+                          end;
+                      end;
+                 end;
+              procsym:
+                 begin
+                    if assigned(left) then
+                      begin
+                         secondpass(left);
+                         location.loc:=LOC_MEM;
+                         gettempofsizereference(8,location.reference);
+
+                         { load class instance address }
+                         case left.location.loc of
+
+                            LOC_CREGISTER,
+                            LOC_REGISTER:
+                              begin
+                                 hregister:=left.location.register;
+                                 ungetregister32(left.location.register);
+                                 if (left.resulttype^.deftype<>classrefdef) and
+                                    (left.resulttype^.deftype<>objectdef) and
+                                    not(pobjectdef(left.resulttype)^.is_class) then
+                                   CGMessage(cg_e_illegal_expression);
+                              end;
+
+                            LOC_MEM,
+                            LOC_REFERENCE:
+                              begin
+{$ifndef noAllocEdi}
+                                 getexplicitregister32(R_EDI);
+{$endif noAllocEdi}
+                                 hregister:=R_EDI;
+                                 if pobjectdef(left.resulttype)^.is_class then
+                                   emit_ref_reg(A_MOV,S_L,
+                                     newreference(left.location.reference),R_EDI)
+                                 else
+                                   emit_ref_reg(A_LEA,S_L,
+                                     newreference(left.location.reference),R_EDI);
+                                 del_reference(left.location.reference);
+                                 ungetiftemp(left.location.reference);
+                              end;
+                            else internalerror(26019);
+                         end;
+
+                         { store the class instance address }
+                         new(hp);
+                         hp^:=location.reference;
+                         inc(hp^.offset,4);
+                         emit_reg_ref(A_MOV,S_L,
+                           hregister,hp);
+
+                         { virtual method ? }
+                         if (po_virtualmethod in pprocsym(symtableentry)^.definition^.procoptions) then
+                           begin
+                              new(hp);
+                              reset_reference(hp^);
+                              hp^.base:=hregister;
+                              { load vmt pointer }
+                              emit_ref_reg(A_MOV,S_L,
+                                hp,R_EDI);
+{$IfDef regallocfix}
+                              del_reference(hp^);
+{$EndIf regallocfix}
+                              { load method address }
+                              new(hp);
+                              reset_reference(hp^);
+                              hp^.base:=R_EDI;
+                              hp^.offset:=pprocsym(symtableentry)^.definition^._class^.vmtmethodoffset(
+                                pprocsym(symtableentry)^.definition^.extnumber);
+                              emit_ref_reg(A_MOV,S_L,
+                                hp,R_EDI);
+                              { ... and store it }
+                              emit_reg_ref(A_MOV,S_L,
+                                R_EDI,newreference(location.reference));
+{$ifndef noAllocEdi}
+                              ungetregister32(R_EDI);
+{$endif noAllocEdi}
+                           end
+                         else
+                           begin
+{$ifndef noAllocEdi}
+                              ungetregister32(R_EDI);
+{$endif noAllocEdi}
+                              s:=newasmsymbol(pprocsym(symtableentry)^.definition^.mangledname);
+                              emit_sym_ofs_ref(A_MOV,S_L,s,0,
+                                newreference(location.reference));
+                           end;
+                      end
+                    else
+                      begin
+                         {!!!!! Be aware, work on virtual methods too }
+                         location.reference.symbol:=newasmsymbol(pprocsym(symtableentry)^.definition^.mangledname);
+                      end;
+                 end;
+              typedconstsym :
+                 begin
+                    location.reference.symbol:=newasmsymbol(symtableentry^.mangledname);
+                 end;
+              else internalerror(4);
+         end;
+      end;
+
+
+{*****************************************************************************
+                             SecondAssignment
+*****************************************************************************}
+
+    procedure ti386assignmentnode.pass_2;
+      var
+         opsize : topsize;
+         otlabel,hlabel,oflabel : pasmlabel;
+         fputyp : tfloattype;
+         loc : tloc;
+         r : preference;
+         ai : paicpu;
+         op : tasmop;
+         pushed : boolean;
+         regspushed : tpushed;
+         regs_to_push: byte;
+         ungettemp : boolean;
+
+      begin
+         otlabel:=truelabel;
+         oflabel:=falselabel;
+         getlabel(truelabel);
+         getlabel(falselabel);
+         { calculate left sides }
+         if not(nf_concat_string in flags) then
+           secondpass(left);
+
+         if codegenerror then
+           exit;
+
+         if not(left.location.loc in [LOC_REFERENCE,LOC_CFPUREGISTER,
+           LOC_CREGISTER,LOC_CMMXREGISTER]) then
+           begin
+              CGMessage(cg_e_illegal_expression);
+              exit;
+           end;
+
+
+         loc:=left.location.loc;
+         { lets try to optimize this (PM)            }
+         { define a dest_loc that is the location      }
+         { and a ptree to verify that it is the right }
+         { place to insert it                    }
+{$ifdef test_dest_loc}
+         if (aktexprlevel<4) then
+           begin
+              dest_loc_known:=true;
+              dest_loc:=left.location;
+              dest_loc_tree:=right;
+           end;
+{$endif test_dest_loc}
+
+         { left can't be never a 64 bit LOC_REGISTER, so the 3. arg }
+         { can be false                                             }
+         pushed:=maybe_push(right.registers32,left,false);
+         secondpass(right);
+
+         { restoring here is nonsense for LOC_JMP !! }
+         { This generated code that was after a jmp and before any
+           label => unreachable !!
+           Could this be tested somehow ?? PM }
+         if pushed and (right.location.loc <>LOC_JUMP) then
+           restore(left,false);
+
+         if codegenerror then
+           exit;
+
+{$ifdef test_dest_loc}
+         dest_loc_known:=false;
+         if in_dest_loc then
+           begin
+              truelabel:=otlabel;
+              falselabel:=oflabel;
+              in_dest_loc:=false;
+              exit;
+           end;
+{$endif test_dest_loc}
+         if left.resulttype^.deftype=stringdef then
+           begin
+              if is_ansistring(left.resulttype) then
+                begin
+                  { before pushing any parameter, we have to save all used      }
+                  { registers, but before that we have to release the       }
+                  { registers of that node to save uneccessary pushed       }
+                  { so be careful, if you think you can optimize that code (FK) }
+
+                  { nevertheless, this has to be changed, because otherwise the }
+                  { register is released before it's contents are pushed ->     }
+                  { problems with the optimizer (JM)                            }
+                  del_reference(left.location.reference);
+                  ungettemp:=false;
+                  { Find out which registers have to be pushed (JM) }
+                  regs_to_push := $ff;
+                  remove_non_regvars_from_loc(right.location,regs_to_push);
+                  { And push them (JM) }
+                  pushusedregisters(regspushed,regs_to_push);
+                  case right.location.loc of
+                     LOC_REGISTER,LOC_CREGISTER:
+                       begin
+                          exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L,right.location.register)));
+                          ungetregister32(right.location.register);
+                       end;
+                     LOC_REFERENCE,LOC_MEM:
+                       begin
+                          { First release the registers because emit_push_mem may  }
+                          { load the reference in edi before pushing and then the  }
+                          { dealloc is too late (and optimizations are missed (JM) }
+                          del_reference(right.location.reference);
+                          { This one doesn't need extra registers (JM) }
+                          emit_push_mem(right.location.reference);
+                          ungettemp:=true;
+                       end;
+                  end;
+                  emitpushreferenceaddr(left.location.reference);
+                  del_reference(left.location.reference);
+                  emitcall('FPC_ANSISTR_ASSIGN');
+                  maybe_loadesi;
+                  popusedregisters(regspushed);
+                  if ungettemp then
+                    ungetiftemp(right.location.reference);
+                end
+              else
+              if is_shortstring(left.resulttype) and
+                not (nf_concat_string in flags) then
+                begin
+                  if is_ansistring(right.resulttype) then
+                    begin
+                      if (right.nodetype=stringconstn) and
+                         (tstringconstnode(right).len=0) then
+                        begin
+                          emit_const_ref(A_MOV,S_B,
+                            0,newreference(left.location.reference));
+                          del_reference(left.location.reference);
+                        end
+                      else
+                        loadansi2short(right,left);
+                    end
+                  else
+                    begin
+                       { we do not need destination anymore }
+                       del_reference(left.location.reference);
+                       {del_reference(right.location.reference);
+                        done in loadshortstring }
+                       loadshortstring(right,left);
+                       ungetiftemp(right.location.reference);
+                    end;
+                end
+              else if is_longstring(left.resulttype) then
+                begin
+                end
+              else
+                begin
+                  { its the only thing we have to do }
+                  del_reference(right.location.reference);
+                end
+           end
+        else case right.location.loc of
+            LOC_REFERENCE,
+            LOC_MEM : begin
+                         { extra handling for ordinal constants }
+                         if (right.nodetype in [ordconstn,fixconstn]) or
+                            (loc=LOC_CREGISTER) then
+                           begin
+                              case left.resulttype^.size of
+                                 1 : opsize:=S_B;
+                                 2 : opsize:=S_W;
+                                 4 : opsize:=S_L;
+                                 { S_L is correct, the copy is done }
+                                 { with two moves                   }
+                                 8 : opsize:=S_L;
+                              end;
+                              if loc=LOC_CREGISTER then
+                                begin
+                                  emit_ref_reg(A_MOV,opsize,
+                                    newreference(right.location.reference),
+                                    left.location.register);
+                                  if is_64bitint(right.resulttype) then
+                                    begin
+                                       r:=newreference(right.location.reference);
+                                       inc(r^.offset,4);
+                                       emit_ref_reg(A_MOV,opsize,r,
+                                         left.location.registerhigh);
+                                    end;
+{$IfDef regallocfix}
+                                  del_reference(right.location.reference);
+{$EndIf regallocfix}
+                                end
+                              else
+                                begin
+                                  if is_64bitint(right.resulttype) then
+                                    begin
+                                       emit_const_ref(A_MOV,opsize,
+                                         lo(tordconstnode(right).value),
+                                         newreference(left.location.reference));
+                                       r:=newreference(left.location.reference);
+                                       inc(r^.offset,4);
+                                       emit_const_ref(A_MOV,opsize,
+                                         hi(tordconstnode(right).value),r);
+                                    end
+                                  else
+                                    begin
+                                       emit_const_ref(A_MOV,opsize,
+                                         right.location.reference.offset,
+                                         newreference(left.location.reference));
+                                    end;
+{$IfDef regallocfix}
+                                  del_reference(left.location.reference);
+{$EndIf regallocfix}
+                                {emit_const_loc(A_MOV,opsize,
+                                    right.location.reference.offset,
+                                    left.location);}
+                                end;
+
+                           end
+                         else if loc=LOC_CFPUREGISTER then
+                           begin
+                              floatloadops(pfloatdef(right.resulttype)^.typ,op,opsize);
+                              emit_ref(op,opsize,
+                                newreference(right.location.reference));
+                              emit_reg(A_FSTP,S_NO,
+                                correct_fpuregister(left.location.register,fpuvaroffset+1));
+                           end
+                         else
+                           begin
+                              if (right.resulttype^.needs_inittable) and
+                                ( (right.resulttype^.deftype<>objectdef) or
+                                  not(pobjectdef(right.resulttype)^.is_class)) then
+                                begin
+                                   { this would be a problem }
+                                   if not(left.resulttype^.needs_inittable) then
+                                     internalerror(3457);
+
+                                   { increment source reference counter }
+                                   new(r);
+                                   reset_reference(r^);
+                                   r^.symbol:=right.resulttype^.get_inittable_label;
+                                   emitpushreferenceaddr(r^);
+
+                                   emitpushreferenceaddr(right.location.reference);
+                                   emitcall('FPC_ADDREF');
+                                   { decrement destination reference counter }
+                                   new(r);
+                                   reset_reference(r^);
+                                   r^.symbol:=left.resulttype^.get_inittable_label;
+                                   emitpushreferenceaddr(r^);
+                                   emitpushreferenceaddr(left.location.reference);
+                                   emitcall('FPC_DECREF');
+                                end;
+
+{$ifdef regallocfix}
+                              concatcopy(right.location.reference,
+                                left.location.reference,left.resulttype^.size,true,false);
+                              ungetiftemp(right.location.reference);
+{$Else regallocfix}
+                              concatcopy(right.location.reference,
+                                left.location.reference,left.resulttype^.size,false,false);
+                              ungetiftemp(right.location.reference);
+{$endif regallocfix}
+                           end;
+                      end;
+{$ifdef SUPPORT_MMX}
+            LOC_CMMXREGISTER,
+            LOC_MMXREGISTER:
+              begin
+                 if loc=LOC_CMMXREGISTER then
+                   emit_reg_reg(A_MOVQ,S_NO,
+                   right.location.register,left.location.register)
+                 else
+                   emit_reg_ref(A_MOVQ,S_NO,
+                     right.location.register,newreference(left.location.reference));
+              end;
+{$endif SUPPORT_MMX}
+            LOC_REGISTER,
+            LOC_CREGISTER : begin
+                              case right.resulttype^.size of
+                                 1 : opsize:=S_B;
+                                 2 : opsize:=S_W;
+                                 4 : opsize:=S_L;
+                                 8 : opsize:=S_L;
+                              end;
+                              { simplified with op_reg_loc       }
+                              if loc=LOC_CREGISTER then
+                                begin
+                                  emit_reg_reg(A_MOV,opsize,
+                                    right.location.register,
+                                    left.location.register);
+                                 ungetregister(right.location.register);
+                                end
+                              else
+                                Begin
+                                  emit_reg_ref(A_MOV,opsize,
+                                    right.location.register,
+                                    newreference(left.location.reference));
+                                  ungetregister(right.location.register);
+{$IfDef regallocfix}
+                                  del_reference(left.location.reference);
+{$EndIf regallocfix}
+                                end;
+                              if is_64bitint(right.resulttype) then
+                                begin
+                                   { simplified with op_reg_loc  }
+                                   if loc=LOC_CREGISTER then
+                                     emit_reg_reg(A_MOV,opsize,
+                                       right.location.registerhigh,
+                                       left.location.registerhigh)
+                                   else
+                                     begin
+                                        r:=newreference(left.location.reference);
+                                        inc(r^.offset,4);
+                                        emit_reg_ref(A_MOV,opsize,
+                                          right.location.registerhigh,r);
+                                     end;
+                                end;
+                              {emit_reg_loc(A_MOV,opsize,
+                                  right.location.register,
+                                  left.location);      }
+
+                           end;
+            LOC_FPU : begin
+                              if (left.resulttype^.deftype=floatdef) then
+                               fputyp:=pfloatdef(left.resulttype)^.typ
+                              else
+                               if (right.resulttype^.deftype=floatdef) then
+                                fputyp:=pfloatdef(right.resulttype)^.typ
+                              else
+                               if (right.nodetype=typeconvn) and
+                                  (ttypeconvnode(right).left.resulttype^.deftype=floatdef) then
+                                fputyp:=pfloatdef(ttypeconvnode(right).left.resulttype)^.typ
+                              else
+                                fputyp:=s32real;
+                              case loc of
+                                 LOC_CFPUREGISTER:
+                                   begin
+                                      emit_reg(A_FSTP,S_NO,
+                                        correct_fpuregister(left.location.register,fpuvaroffset));
+                                      dec(fpuvaroffset);
+                                   end;
+                                 LOC_REFERENCE:
+                                   floatstore(fputyp,left.location.reference);
+                                 else
+                                   internalerror(48991);
+                              end;
+                           end;
+            LOC_CFPUREGISTER: begin
+                              if (left.resulttype^.deftype=floatdef) then
+                               fputyp:=pfloatdef(left.resulttype)^.typ
+                              else
+                               if (right.resulttype^.deftype=floatdef) then
+                                fputyp:=pfloatdef(right.resulttype)^.typ
+                              else
+                               if (right.nodetype=typeconvn) and
+                                  (ttypeconvnode(right).left.resulttype^.deftype=floatdef) then
+                                fputyp:=pfloatdef(ttypeconvnode(right).left.resulttype)^.typ
+                              else
+                                fputyp:=s32real;
+                              emit_reg(A_FLD,S_NO,
+                                correct_fpuregister(right.location.register,fpuvaroffset));
+                              inc(fpuvaroffset);
+                              case loc of
+                                 LOC_CFPUREGISTER:
+                                   begin
+                                      emit_reg(A_FSTP,S_NO,
+                                        correct_fpuregister(right.location.register,fpuvaroffset));
+                                      dec(fpuvaroffset);
+                                   end;
+                                 LOC_REFERENCE:
+                                   floatstore(fputyp,left.location.reference);
+                                 else
+                                   internalerror(48992);
+                              end;
+                           end;
+            LOC_JUMP     : begin
+                              getlabel(hlabel);
+                              emitlab(truelabel);
+                              if pushed then
+                                restore(left,false);
+                              if loc=LOC_CREGISTER then
+                                emit_const_reg(A_MOV,S_B,
+                                  1,left.location.register)
+                              else
+                                emit_const_ref(A_MOV,S_B,
+                                  1,newreference(left.location.reference));
+                              {emit_const_loc(A_MOV,S_B,
+                                  1,left.location);}
+                              emitjmp(C_None,hlabel);
+                              emitlab(falselabel);
+                              if pushed then
+                                restore(left,false);
+                              if loc=LOC_CREGISTER then
+                                emit_reg_reg(A_XOR,S_B,
+                                  left.location.register,
+                                  left.location.register)
+                              else
+                                begin
+                                  emit_const_ref(A_MOV,S_B,
+                                    0,newreference(left.location.reference));
+{$IfDef regallocfix}
+                                  del_reference(left.location.reference);
+{$EndIf regallocfix}
+                                 end;
+                              emitlab(hlabel);
+                           end;
+            LOC_FLAGS    : begin
+                              if loc=LOC_CREGISTER then
+                                emit_flag2reg(right.location.resflags,left.location.register)
+                              else
+                                begin
+                                  ai:=new(paicpu,op_ref(A_Setcc,S_B,newreference(left.location.reference)));
+                                  ai^.SetCondition(flag_2_cond[right.location.resflags]);
+                                  exprasmlist^.concat(ai);
+                                end;
+{$IfDef regallocfix}
+                              del_reference(left.location.reference);
+{$EndIf regallocfix}
+                           end;
+         end;
+         truelabel:=otlabel;
+         falselabel:=oflabel;
+      end;
+
+
+{*****************************************************************************
+                             SecondFuncRet
+*****************************************************************************}
+
+    procedure ti386funcretnode.pass_2;
+      var
+         hr : tregister;
+         hp : preference;
+         pp : pprocinfo;
+         hr_valid : boolean;
+      begin
+         reset_reference(location.reference);
+         hr_valid:=false;
+         if (not inlining_procedure) and
+            (procinfo<>pprocinfo(funcretprocinfo)) then
+           begin
+              hr:=getregister32;
+              hr_valid:=true;
+              hp:=new_reference(procinfo^.framepointer,
+                procinfo^.framepointer_offset);
+              emit_ref_reg(A_MOV,S_L,hp,hr);
+              pp:=procinfo^.parent;
+              { walk up the stack frame }
+              while pp<>pprocinfo(funcretprocinfo) do
+                begin
+                   hp:=new_reference(hr,
+                     pp^.framepointer_offset);
+                   emit_ref_reg(A_MOV,S_L,hp,hr);
+                   pp:=pp^.parent;
+                end;
+              location.reference.base:=hr;
+              location.reference.offset:=pp^.return_offset;
+           end
+         else
+           begin
+             location.reference.base:=procinfo^.framepointer;
+             location.reference.offset:=procinfo^.return_offset;
+           end;
+         if ret_in_param(rettype.def) then
+           begin
+              if not hr_valid then
+                hr:=getregister32;
+              emit_ref_reg(A_MOV,S_L,newreference(location.reference),hr);
+              location.reference.base:=hr;
+              location.reference.offset:=0;
+           end;
+      end;
+
+
+{*****************************************************************************
+                           SecondArrayConstruct
+*****************************************************************************}
+
+      const
+        vtInteger    = 0;
+        vtBoolean    = 1;
+        vtChar       = 2;
+        vtExtended   = 3;
+        vtString     = 4;
+        vtPointer    = 5;
+        vtPChar      = 6;
+        vtObject     = 7;
+        vtClass      = 8;
+        vtWideChar   = 9;
+        vtPWideChar  = 10;
+        vtAnsiString = 11;
+        vtCurrency   = 12;
+        vtVariant    = 13;
+        vtInterface  = 14;
+        vtWideString = 15;
+        vtInt64      = 16;
+        vtQWord      = 17;
+
+    procedure ti386arrayconstructornode.pass_2;
+      var
+        hp    : tarrayconstructornode;
+        href  : treference;
+        lt    : pdef;
+        vaddr : boolean;
+        vtype : longint;
+        freetemp,
+        dovariant : boolean;
+        elesize : longint;
+      begin
+        dovariant:=(nf_forcevaria in flags) or parraydef(resulttype)^.isvariant;
+        if dovariant then
+         elesize:=8
+        else
+         begin
+           elesize:=parraydef(resulttype)^.elesize;
+           if elesize>4 then
+            internalerror(8765678);
+         end;
+        if not(nf_cargs in flags) then
+         begin
+           reset_reference(location.reference);
+           { Allocate always a temp, also if no elements are required, to
+             be sure that location is valid (PFV) }
+            if parraydef(resulttype)^.highrange=-1 then
+              gettempofsizereference(elesize,location.reference)
+            else
+              gettempofsizereference((parraydef(resulttype)^.highrange+1)*elesize,location.reference);
+           href:=location.reference;
+         end;
+        hp:=self;
+        while assigned(hp) do
+         begin
+           if assigned(hp.left) then
+            begin
+              freetemp:=true;
+              secondpass(hp.left);
+              if codegenerror then
+               exit;
+              if dovariant then
+               begin
+                 { find the correct vtype value }
+                 vtype:=$ff;
+                 vaddr:=false;
+                 lt:=hp.left.resulttype;
+                 case lt^.deftype of
+                   enumdef,
+                   orddef :
+                     begin
+                       if is_64bitint(lt) then
+                         begin
+                            case porddef(lt)^.typ of
+                               s64bit:
+                                 vtype:=vtInt64;
+                               u64bit:
+                                 vtype:=vtQWord;
+                            end;
+                            freetemp:=false;
+                            vaddr:=true;
+                         end
+                       else if (lt^.deftype=enumdef) or
+                         is_integer(lt) then
+                         vtype:=vtInteger
+                       else
+                         if is_boolean(lt) then
+                           vtype:=vtBoolean
+                         else
+                           if (lt^.deftype=orddef) and (porddef(lt)^.typ=uchar) then
+                             vtype:=vtChar;
+                     end;
+                   floatdef :
+                     begin
+                       vtype:=vtExtended;
+                       vaddr:=true;
+                       freetemp:=false;
+                     end;
+                   procvardef,
+                   pointerdef :
+                     begin
+                       if is_pchar(lt) then
+                         vtype:=vtPChar
+                       else
+                         vtype:=vtPointer;
+                     end;
+                   classrefdef :
+                     vtype:=vtClass;
+                   objectdef :
+                     begin
+                       vtype:=vtObject;
+                     end;
+                   stringdef :
+                     begin
+                       if is_shortstring(lt) then
+                        begin
+                          vtype:=vtString;
+                          vaddr:=true;
+                          freetemp:=false;
+                        end
+                       else
+                        if is_ansistring(lt) then
+                         begin
+                           vtype:=vtAnsiString;
+                           freetemp:=false;
+                         end;
+                     end;
+                 end;
+                 if vtype=$ff then
+                   internalerror(14357);
+                 { write C style pushes or an pascal array }
+                 if nf_cargs in flags then
+                  begin
+                    if vaddr then
+                     begin
+                       emit_to_mem(hp.left.location,hp.left.resulttype);
+                       emit_push_lea_loc(hp.left.location,freetemp);
+                       del_reference(hp.left.location.reference);
+                     end
+                    else
+                     emit_push_loc(hp.left.location);
+                    inc(pushedparasize);
+                  end
+                 else
+                  begin
+                    { write changing field update href to the next element }
+                    inc(href.offset,4);
+                    if vaddr then
+                     begin
+                       emit_to_mem(hp.left.location,hp.left.resulttype);
+                       emit_lea_loc_ref(hp.left.location,href,freetemp);
+                     end
+                    else
+                     begin
+                       emit_mov_loc_ref(hp.left.location,href,S_L,freetemp);
+                     end;
+                    { update href to the vtype field and write it }
+                    dec(href.offset,4);
+                    emit_const_ref(A_MOV,S_L,vtype,newreference(href));
+                    { goto next array element }
+                    inc(href.offset,8);
+                  end;
+               end
+              else
+              { normal array constructor of the same type }
+               begin
+                 case elesize of
+                   1 :
+                     emit_mov_loc_ref(hp.left.location,href,S_B,freetemp);
+                   2 :
+                     emit_mov_loc_ref(hp.left.location,href,S_W,freetemp);
+                   4 :
+                     emit_mov_loc_ref(hp.left.location,href,S_L,freetemp);
+                   else
+                     internalerror(87656781);
+                 end;
+                 inc(href.offset,elesize);
+               end;
+            end;
+           { load next entry }
+           hp:=tarrayconstructornode(hp.right);
+         end;
+      end;
+
+begin
+   cloadnode:=ti386loadnode;
+   cassignmentnode:=ti386assignmentnode;
+   cfuncretnode:=ti386funcretnode;
+   carrayconstructornode:=ti386arrayconstructornode;
+end.
+{
+  $Log$
+  Revision 1.1  2000-10-14 10:14:49  peter
+    * moehrendorf oct 2000 rewrite
+
+}

compiler/n386mat.pas

@@ -20,7 +20,7 @@
 
  ****************************************************************************
 }
-unit cg386mat;
+unit n386mat;
 
 {$i defines.inc}
 
@@ -29,21 +29,22 @@ interface
     uses
       node,nmat;
 
-    ti386moddivnode = class(tmoddivnode)
-       procedure pass_2;override;
-    end;
+    type
+      ti386moddivnode = class(tmoddivnode)
+         procedure pass_2;override;
+      end;
 
-    ti386shlshrnode = class(tshlshrnode)
-       procedure pass_2;override;
-    end;
+      ti386shlshrnode = class(tshlshrnode)
+         procedure pass_2;override;
+      end;
 
-    ti386unaryminusnode = class(tunaryminus)
-       procedure pass_2;override;
-    end;
+      ti386unaryminusnode = class(tunaryminusnode)
+         procedure pass_2;override;
+      end;
 
-    ti386notnode = class(tnotnode)
-       procedure pass_2;override;
-    end;
+      ti386notnode = class(tnotnode)
+         procedure pass_2;override;
+      end;
 
 implementation
 
@@ -52,8 +53,9 @@ implementation
       cutils,cobjects,verbose,globals,
       symconst,symtable,aasm,types,
       hcodegen,temp_gen,pass_2,
+      ncon,
       cpubase,cpuasm,
-      cgai386,tgeni386;
+      cgai386,tgeni386,n386util;
 
 {*****************************************************************************
                              TI386MODDIVNODE
@@ -104,7 +106,7 @@ implementation
                 typename:='QWORD'
               else
                 typename:='INT64';
-              if treetype=divn then
+              if nodetype=divn then
                 opname:='DIV_'
               else
                 opname:='MOD_';
@@ -138,8 +140,8 @@ implementation
                 end
               else hreg1:=left.location.register;
 
-                if (treetype=divn) and (right.treetype=ordconstn) and
-                    ispowerof2(right.tordconstnode(value),power) then
+                if (nodetype=divn) and (right.nodetype=ordconstn) and
+                    ispowerof2(tordconstnode(right).value,power) then
                   Begin
                     shrdiv := true;
                     {for signed numbers, the numerator must be adjusted before the
@@ -196,7 +198,7 @@ implementation
                       emit_const_reg(A_SHR,S_L,power,hreg1);
                   End
                 else
-                  if (treetype=modn) and (right.treetype=ordconstn) and
+                  if (nodetype=modn) and (right.nodetype=ordconstn) and
                     ispowerof2(tordconstnode(right).value,power) and Not(is_signed(left.resulttype)) Then
                    {is there a similar trick for MOD'ing signed numbers? (JM)}
                    Begin
@@ -262,7 +264,7 @@ implementation
                    else
                      emit_reg(A_IDIV,S_L,R_EDI);
                    ungetregister32(R_EDI);
-                   if treetype=divn then
+                   if nodetype=divn then
                      begin
                         { if result register is busy then copy }
                         if popeax then
@@ -373,12 +375,12 @@ implementation
                 end;
 
               { shifting by a constant directly coded: }
-              if (right.treetype=ordconstn) then
+              if (right.nodetype=ordconstn) then
                 begin
                    { shrd/shl works only for values <=31 !! }
-                   if right.tordconstnode(value)>31 then
+                   if tordconstnode(right).value>31 then
                      begin
-                        if treetype=shln then
+                        if nodetype=shln then
                           begin
                              emit_reg_reg(A_XOR,S_L,hregisterhigh,
                                hregisterhigh);
@@ -397,7 +399,7 @@ implementation
                      end
                    else
                      begin
-                        if treetype=shln then
+                        if nodetype=shln then
                           begin
                              emit_const_reg_reg(A_SHLD,S_L,tordconstnode(right).value and 31,
                                hregisterlow,hregisterhigh);
@@ -475,7 +477,7 @@ implementation
 
                    { the damned shift instructions work only til a count of 32 }
                    { so we've to do some tricks here                           }
-                   if treetype=shln then
+                   if nodetype=shln then
                      begin
                         getlabel(l1);
                         getlabel(l2);
@@ -561,13 +563,13 @@ implementation
                 hregister1:=left.location.register;
 
               { determine operator }
-              if treetype=shln then
+              if nodetype=shln then
                 op:=A_SHL
               else
                 op:=A_SHR;
 
               { shifting by a constant directly coded: }
-              if (right.treetype=ordconstn) then
+              if (right.nodetype=ordconstn) then
                 begin
                    { l shl 32 should 0 imho, but neither TP nor Delphi do it in this way (FK)
                    if right.value<=31 then
@@ -985,7 +987,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.3  2000-09-30 16:08:45  peter
+  Revision 1.4  2000-10-14 10:14:49  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.3  2000/09/30 16:08:45  peter
     * more cg11 updates
 
   Revision 1.2  2000/09/24 15:06:18  peter

compiler/n386mem.pas

@@ -0,0 +1,1022 @@
+{
+    $Id$
+    Copyright (c) 1998-2000 by Florian Klaempfl
+
+    Generate i386 assembler for in memory related nodes
+
+    This program is free software; you can redistribute it and/or modify
+    it under the terms of the GNU General Public License as published by
+    the Free Software Foundation; either version 2 of the License, or
+    (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU General Public License for more details.
+
+    You should have received a copy of the GNU General Public License
+    along with this program; if not, write to the Free Software
+    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ ****************************************************************************
+}
+unit n386mem;
+
+{$i defines.inc}
+
+interface
+
+    uses
+      node,nmem;
+
+    type
+       ti386loadvmtnode = class(tloadvmtnode)
+          procedure pass_2;override;
+       end;
+
+       ti386hnewnode = class(thnewnode)
+          procedure pass_2;override;
+       end;
+
+       ti386newnode = class(tnewnode)
+          procedure pass_2;override;
+       end;
+
+       ti386hdisposenode = class(thdisposenode)
+          procedure pass_2;override;
+       end;
+
+       ti386simplenewdisposenode = class(tsimplenewdisposenode)
+          procedure pass_2;override;
+       end;
+
+       ti386addrnode = class(taddrnode)
+          procedure pass_2;override;
+       end;
+
+       ti386doubleaddrnode = class(tdoubleaddrnode)
+          procedure pass_2;override;
+       end;
+
+       ti386derefnode = class(tderefnode)
+          procedure pass_2;override;
+       end;
+
+       ti386subscriptnode = class(tsubscriptnode)
+          procedure pass_2;override;
+       end;
+
+       ti386vecnode = class(tvecnode)
+          procedure pass_2;override;
+       end;
+
+       ti386selfnode = class(tselfnode)
+          procedure pass_2;override;
+       end;
+
+       ti386withnode = class(twithnode)
+          procedure pass_2;override;
+       end;
+
+implementation
+
+    uses
+{$ifdef delphi}
+      sysutils,
+{$else}
+      strings,
+{$endif}
+{$ifdef GDB}
+      gdb,
+{$endif GDB}
+      globtype,systems,
+      cutils,cobjects,verbose,globals,
+      symconst,symtable,aasm,types,
+      hcodegen,temp_gen,pass_2,
+      pass_1,nld,ncon,nadd,
+      cpubase,cpuasm,
+      cgai386,tgeni386,n386util;
+
+{*****************************************************************************
+                            TI386LOADNODE
+*****************************************************************************}
+
+    procedure ti386loadvmtnode.pass_2;
+      begin
+         location.register:=getregister32;
+         emit_sym_ofs_reg(A_MOV,
+            S_L,newasmsymbol(pobjectdef(pclassrefdef(resulttype)^.pointertype.def)^.vmt_mangledname),0,
+            location.register);
+      end;
+
+
+{*****************************************************************************
+                            TI386HNEWNODE
+*****************************************************************************}
+
+    procedure ti386hnewnode.pass_2;
+      begin
+      end;
+
+
+{*****************************************************************************
+                            TI386NEWNODE
+*****************************************************************************}
+
+    procedure ti386newnode.pass_2;
+      var
+         pushed : tpushed;
+         r : preference;
+      begin
+         if assigned(left) then
+           begin
+              secondpass(left);
+              location.register:=left.location.register;
+           end
+         else
+           begin
+              pushusedregisters(pushed,$ff);
+
+              gettempofsizereference(target_os.size_of_pointer,location.reference);
+
+              { determines the size of the mem block }
+              push_int(ppointerdef(resulttype)^.pointertype.def^.size);
+              emit_push_lea_loc(location,false);
+              emitcall('FPC_GETMEM');
+
+              if ppointerdef(resulttype)^.pointertype.def^.needs_inittable then
+                begin
+                   new(r);
+                   reset_reference(r^);
+                   r^.symbol:=ppointerdef(left.resulttype)^.pointertype.def^.get_inittable_label;
+                   emitpushreferenceaddr(r^);
+                   dispose(r);
+                   { push pointer we just allocated, we need to initialize the
+                     data located at that pointer not the pointer self (PFV) }
+                   emit_push_loc(location);
+                   emitcall('FPC_INITIALIZE');
+                end;
+              popusedregisters(pushed);
+              { may be load ESI }
+              maybe_loadesi;
+           end;
+         if codegenerror then
+           exit;
+      end;
+
+
+{*****************************************************************************
+                         TI386HDISPOSENODE
+*****************************************************************************}
+
+    procedure ti386hdisposenode.pass_2;
+      begin
+         secondpass(left);
+         if codegenerror then
+           exit;
+         reset_reference(location.reference);
+         case left.location.loc of
+            LOC_REGISTER:
+              location.reference.index:=left.location.register;
+            LOC_CREGISTER:
+              begin
+                 location.reference.index:=getregister32;
+                 emit_reg_reg(A_MOV,S_L,
+                   left.location.register,
+                   location.reference.index);
+              end;
+            LOC_MEM,LOC_REFERENCE :
+              begin
+                 del_reference(left.location.reference);
+                 location.reference.index:=getregister32;
+                 emit_ref_reg(A_MOV,S_L,newreference(left.location.reference),
+                   location.reference.index);
+              end;
+         end;
+      end;
+
+
+{*****************************************************************************
+                         TI386SIMPLENEWDISPOSENODE
+*****************************************************************************}
+
+    procedure ti386simplenewdisposenode.pass_2;
+
+      var
+         pushed : tpushed;
+         r : preference;
+
+      begin
+         secondpass(left);
+         if codegenerror then
+           exit;
+
+         pushusedregisters(pushed,$ff);
+
+         { call the mem handling procedures }
+         case nodetype of
+           simpledisposen:
+             begin
+                if ppointerdef(left.resulttype)^.pointertype.def^.needs_inittable then
+                  begin
+                     new(r);
+                     reset_reference(r^);
+                     r^.symbol:=ppointerdef(left.resulttype)^.pointertype.def^.get_inittable_label;
+                     emitpushreferenceaddr(r^);
+                     dispose(r);
+                     { push pointer adress }
+                     emit_push_loc(left.location);
+                     emitcall('FPC_FINALIZE');
+                  end;
+                emit_push_lea_loc(left.location,true);
+                emitcall('FPC_FREEMEM');
+             end;
+           simplenewn:
+             begin
+                { determines the size of the mem block }
+                push_int(ppointerdef(left.resulttype)^.pointertype.def^.size);
+                emit_push_lea_loc(left.location,true);
+                emitcall('FPC_GETMEM');
+                if ppointerdef(left.resulttype)^.pointertype.def^.needs_inittable then
+                  begin
+                     new(r);
+                     reset_reference(r^);
+                     r^.symbol:=ppointerdef(left.resulttype)^.pointertype.def^.get_inittable_label;
+                     emitpushreferenceaddr(r^);
+                     dispose(r);
+                     emit_push_loc(left.location);
+                     emitcall('FPC_INITIALIZE');
+                  end;
+             end;
+         end;
+         popusedregisters(pushed);
+         { may be load ESI }
+         maybe_loadesi;
+      end;
+
+
+{*****************************************************************************
+                             TI386ADDRNODE
+*****************************************************************************}
+
+    procedure ti386addrnode.pass_2;
+      begin
+         secondpass(left);
+
+         { when loading procvar we do nothing with this node, so load the
+           location of left }
+         if nf_procvarload in flags then
+          begin
+            set_location(location,left.location);
+            exit;
+          end;
+
+         location.loc:=LOC_REGISTER;
+         del_reference(left.location.reference);
+         location.register:=getregister32;
+         {@ on a procvar means returning an address to the procedure that
+           is stored in it.}
+         { yes but left.symtableentry can be nil
+           for example on @self !! }
+         { symtableentry can be also invalid, if left is no tree node }
+         if (m_tp_procvar in aktmodeswitches) and
+           (left.nodetype=loadn) and
+           assigned(tloadnode(left).symtableentry) and
+           (tloadnode(left).symtableentry^.typ=varsym) and
+           (pvarsym(tloadnode(left).symtableentry)^.vartype.def^.deftype=procvardef) then
+           emit_ref_reg(A_MOV,S_L,
+             newreference(left.location.reference),
+             location.register)
+         else
+           emit_ref_reg(A_LEA,S_L,
+             newreference(left.location.reference),
+             location.register);
+           { for use of other segments }
+           if left.location.reference.segment<>R_NO then
+             location.segment:=left.location.reference.segment;
+      end;
+
+
+{*****************************************************************************
+                         TI386DOUBLEADDRNODE
+*****************************************************************************}
+
+    procedure ti386doubleaddrnode.pass_2;
+      begin
+         secondpass(left);
+         location.loc:=LOC_REGISTER;
+         del_reference(left.location.reference);
+         location.register:=getregister32;
+         emit_ref_reg(A_LEA,S_L,
+         newreference(left.location.reference),
+           location.register);
+      end;
+
+
+{*****************************************************************************
+                           TI386DEREFNODE
+*****************************************************************************}
+
+    procedure ti386derefnode.pass_2;
+      var
+         hr : tregister;
+      begin
+         secondpass(left);
+         reset_reference(location.reference);
+         case left.location.loc of
+            LOC_REGISTER:
+              location.reference.base:=left.location.register;
+            LOC_CREGISTER:
+              begin
+                 { ... and reserve one for the pointer }
+                 hr:=getregister32;
+                 emit_reg_reg(A_MOV,S_L,left.location.register,hr);
+                 location.reference.base:=hr;
+              end;
+            else
+              begin
+                 { free register }
+                 del_reference(left.location.reference);
+
+                 { ...and reserve one for the pointer }
+                 hr:=getregister32;
+                 emit_ref_reg(
+                   A_MOV,S_L,newreference(left.location.reference),
+                   hr);
+                 location.reference.base:=hr;
+              end;
+         end;
+         if ppointerdef(left.resulttype)^.is_far then
+          location.reference.segment:=R_FS;
+         if not ppointerdef(left.resulttype)^.is_far and
+            (cs_gdb_heaptrc in aktglobalswitches) and
+            (cs_checkpointer in aktglobalswitches) then
+              begin
+                 emit_reg(
+                   A_PUSH,S_L,location.reference.base);
+                 emitcall('FPC_CHECKPOINTER');
+              end;
+      end;
+
+
+{*****************************************************************************
+                          TI386SUBSCRIPTNODE
+*****************************************************************************}
+
+    procedure ti386subscriptnode.pass_2;
+      var
+         hr : tregister;
+      begin
+         secondpass(left);
+         if codegenerror then
+           exit;
+         { classes must be dereferenced implicit }
+         if (left.resulttype^.deftype=objectdef) and
+           pobjectdef(left.resulttype)^.is_class then
+           begin
+             reset_reference(location.reference);
+             case left.location.loc of
+                LOC_REGISTER:
+                  location.reference.base:=left.location.register;
+                LOC_CREGISTER:
+                  begin
+                     { ... and reserve one for the pointer }
+                     hr:=getregister32;
+                     emit_reg_reg(A_MOV,S_L,left.location.register,hr);
+                       location.reference.base:=hr;
+                  end;
+                else
+                  begin
+                     { free register }
+                     del_reference(left.location.reference);
+
+                     { ... and reserve one for the pointer }
+                     hr:=getregister32;
+                     emit_ref_reg(
+                       A_MOV,S_L,newreference(left.location.reference),
+                       hr);
+                     location.reference.base:=hr;
+                  end;
+             end;
+           end
+         else
+           set_location(location,left.location);
+
+         inc(location.reference.offset,vs^.address);
+      end;
+
+
+{*****************************************************************************
+                             TI386VECNODE
+*****************************************************************************}
+
+    procedure ti386vecnode.pass_2;
+      var
+        is_pushed : boolean;
+        ind,hr : tregister;
+        //_p : tnode;
+
+          function get_mul_size:longint;
+          begin
+            if nf_memindex in flags then
+             get_mul_size:=1
+            else
+             begin
+               if (left.resulttype^.deftype=arraydef) then
+                get_mul_size:=parraydef(left.resulttype)^.elesize
+               else
+                get_mul_size:=resulttype^.size;
+             end
+          end;
+
+          procedure calc_emit_mul;
+          var
+             l1,l2 : longint;
+          begin
+            l1:=get_mul_size;
+            case l1 of
+             1,2,4,8 : location.reference.scalefactor:=l1;
+            else
+              begin
+                 if ispowerof2(l1,l2) then
+                   emit_const_reg(A_SHL,S_L,l2,ind)
+                 else
+                   emit_const_reg(A_IMUL,S_L,l1,ind);
+              end;
+            end;
+          end;
+
+      var
+         extraoffset : longint;
+         { rl stores the resulttype of the left node, this is necessary }
+         { to detect if it is an ansistring                          }
+         { because in constant nodes which constant index              }
+         { the left tree is removed                                  }
+         t   : tnode;
+         hp  : preference;
+         href : treference;
+         tai : Paicpu;
+         pushed : tpushed;
+         hightree : tnode;
+         hl,otl,ofl : pasmlabel;
+      begin
+         secondpass(left);
+         { we load the array reference to location }
+
+         { an ansistring needs to be dereferenced }
+         if is_ansistring(left.resulttype) or
+           is_widestring(left.resulttype) then
+           begin
+              reset_reference(location.reference);
+              if nf_callunique in flags then
+                begin
+                   if left.location.loc<>LOC_REFERENCE then
+                     begin
+                        CGMessage(cg_e_illegal_expression);
+                        exit;
+                     end;
+                   pushusedregisters(pushed,$ff);
+                   emitpushreferenceaddr(left.location.reference);
+                   if is_ansistring(left.resulttype) then
+                     emitcall('FPC_ANSISTR_UNIQUE')
+                   else
+                     emitcall('FPC_WIDESTR_UNIQUE');
+                   maybe_loadesi;
+                   popusedregisters(pushed);
+                end;
+
+              if left.location.loc in [LOC_REGISTER,LOC_CREGISTER] then
+                begin
+                   location.reference.base:=left.location.register;
+                end
+              else
+                begin
+                   del_reference(left.location.reference);
+                   location.reference.base:=getregister32;
+                   emit_ref_reg(A_MOV,S_L,
+                     newreference(left.location.reference),
+                     location.reference.base);
+                end;
+
+              { check for a zero length string,
+                we can use the ansistring routine here }
+              if (cs_check_range in aktlocalswitches) then
+                begin
+                   pushusedregisters(pushed,$ff);
+                   emit_reg(A_PUSH,S_L,location.reference.base);
+                   emitcall('FPC_ANSISTR_CHECKZERO');
+                   maybe_loadesi;
+                   popusedregisters(pushed);
+                end;
+
+              if is_ansistring(left.resulttype) then
+                { in ansistrings S[1] is pchar(S)[0] !! }
+                dec(location.reference.offset)
+              else
+                begin
+                   { in widestrings S[1] is pwchar(S)[0] !! }
+                   dec(location.reference.offset,2);
+                   emit_const_reg(A_SHL,S_L,
+                     1,location.reference.base);
+                end;
+
+              { we've also to keep left up-to-date, because it is used   }
+              { if a constant array index occurs, subject to change (FK) }
+              set_location(left.location,location);
+           end
+         else
+           set_location(location,left.location);
+
+         { offset can only differ from 0 if arraydef }
+         if left.resulttype^.deftype=arraydef then
+           dec(location.reference.offset,
+               get_mul_size*parraydef(left.resulttype)^.lowrange);
+         if right.nodetype=ordconstn then
+           begin
+              { offset can only differ from 0 if arraydef }
+              if (left.resulttype^.deftype=arraydef) then
+                begin
+                   if not(is_open_array(left.resulttype)) and
+                      not(is_array_of_const(left.resulttype)) then
+                     begin
+                        if (tordconstnode(right).value>parraydef(left.resulttype)^.highrange) or
+                           (tordconstnode(right).value<parraydef(left.resulttype)^.lowrange) then
+                           begin
+                              if (cs_check_range in aktlocalswitches) then
+                                CGMessage(parser_e_range_check_error)
+                              else
+                                CGMessage(parser_w_range_check_error);
+                           end;
+                        dec(left.location.reference.offset,
+                            get_mul_size*parraydef(left.resulttype)^.lowrange);
+                     end
+                   else
+                     begin
+                        { range checking for open arrays !!!! }
+                        {!!!!!!!!!!!!!!!!!}
+                     end;
+                end
+              else if (left.resulttype^.deftype=stringdef) then
+                begin
+                   if (tordconstnode(right).value=0) and not(is_shortstring(left.resulttype)) then
+                     CGMessage(cg_e_can_access_element_zero);
+
+                   if (cs_check_range in aktlocalswitches) then
+                     case pstringdef(left.resulttype)^.string_typ of
+                        { it's the same for ansi- and wide strings }
+                        st_widestring,
+                        st_ansistring:
+                          begin
+                             pushusedregisters(pushed,$ff);
+                             push_int(tordconstnode(right).value);
+                             hp:=newreference(location.reference);
+                             dec(hp^.offset,7);
+                             emit_ref(A_PUSH,S_L,hp);
+                             emitcall('FPC_ANSISTR_RANGECHECK');
+                             popusedregisters(pushed);
+                             maybe_loadesi;
+                          end;
+
+                        st_shortstring:
+                          begin
+                             {!!!!!!!!!!!!!!!!!}
+                          end;
+
+                        st_longstring:
+                          begin
+                             {!!!!!!!!!!!!!!!!!}
+                          end;
+                     end;
+                end;
+              inc(left.location.reference.offset,
+                  get_mul_size*tordconstnode(right).value);
+              if nf_memseg in flags then
+                left.location.reference.segment:=R_FS;
+              {
+              left.resulttype:=resulttype;
+              disposetree(right);
+              _p:=left;
+              putnode(p);
+              p:=_p;
+              }
+              set_location(location,left.location);
+           end
+         else
+         { not nodetype=ordconstn }
+           begin
+              if (cs_regalloc in aktglobalswitches) and
+              { if we do range checking, we don't }
+              { need that fancy code (it would be }
+              { buggy)                            }
+                not(cs_check_range in aktlocalswitches) and
+                (left.resulttype^.deftype=arraydef) then
+                begin
+                   extraoffset:=0;
+                   if (right.nodetype=addn) then
+                     begin
+                        if taddnode(right).right.nodetype=ordconstn then
+                          begin
+                             extraoffset:=tordconstnode(taddnode(right).right).value;
+                             t:=taddnode(right).left;
+                             { First pass processed this with the assumption   }
+                             { that there was an add node which may require an }
+                             { extra register. Fake it or die with IE10 (JM)   }
+                             t.registers32 := taddnode(right).registers32;
+                             taddnode(right).left:=nil;
+                             right.free;
+                             right:=t;
+                          end
+                        else if tordconstnode(taddnode(right).left).nodetype=ordconstn then
+                          begin
+                             extraoffset:=tordconstnode(taddnode(right).left).value;
+                             t:=taddnode(right).right;
+                             t.registers32 :=  right.registers32;
+                             taddnode(right).right:=nil;
+                             right.free;
+                             right:=t;
+                          end;
+                     end
+                   else if (right.nodetype=subn) then
+                     begin
+                        if taddnode(right).right.nodetype=ordconstn then
+                          begin
+{ this was "extraoffset:=right.right.value;" Looks a bit like
+  copy-paste bug :) (JM) }
+                             extraoffset:=-tordconstnode(taddnode(right).right).value;
+                             t:=taddnode(right).left;
+                             t.registers32 :=  right.registers32;
+                             taddnode(right).left:=nil;
+                             right.free;
+                             right:=t;
+                          end
+{ You also have to negate right.right in this case! I can't add an
+  unaryminusn without causing a crash, so I've disabled it (JM)
+                        else if right.left.nodetype=ordconstn then
+                          begin
+                             extraoffset:=right.left.value;
+                             t:=right.right;
+                             t^.registers32 :=  right.registers32;
+                             putnode(right);
+                             putnode(right.left);
+                             right:=t;
+                         end;}
+                     end;
+                   inc(location.reference.offset,
+                       get_mul_size*extraoffset);
+                end;
+              { calculate from left to right }
+              if (location.loc<>LOC_REFERENCE) and
+                 (location.loc<>LOC_MEM) then
+                CGMessage(cg_e_illegal_expression);
+              if (right.location.loc=LOC_JUMP) then
+               begin
+                 otl:=truelabel;
+                 getlabel(truelabel);
+                 ofl:=falselabel;
+                 getlabel(falselabel);
+               end;
+              is_pushed:=maybe_push(right.registers32,self,false);
+              secondpass(right);
+              if is_pushed then
+                restore(self,false);
+              { here we change the location of right
+                and the update was forgotten so it
+                led to wrong code in emitrangecheck later PM
+                so make range check before }
+
+              if cs_check_range in aktlocalswitches then
+               begin
+                 if left.resulttype^.deftype=arraydef then
+                   begin
+                     if is_open_array(left.resulttype) or
+                        is_array_of_const(left.resulttype) then
+                      begin
+                        reset_reference(href);
+                        parraydef(left.resulttype)^.genrangecheck;
+                        href.symbol:=newasmsymbol(parraydef(left.resulttype)^.getrangecheckstring);
+                        href.offset:=4;
+                        getsymonlyin(tloadnode(left).symtable,
+                          'high'+pvarsym(tloadnode(left).symtableentry)^.name);
+                        hightree:=genloadnode(pvarsym(srsym),tloadnode(left).symtable);
+                        firstpass(hightree);
+                        secondpass(hightree);
+                        emit_mov_loc_ref(hightree.location,href,S_L,true);
+                        hightree.free;
+                      end;
+                     emitrangecheck(right,left.resulttype);
+                   end;
+               end;
+
+              case right.location.loc of
+                 LOC_REGISTER:
+                   begin
+                      ind:=right.location.register;
+                      case right.resulttype^.size of
+                         1:
+                           begin
+                              hr:=reg8toreg32(ind);
+                              emit_reg_reg(A_MOVZX,S_BL,ind,hr);
+                              ind:=hr;
+                           end;
+                         2:
+                           begin
+                              hr:=reg16toreg32(ind);
+                              emit_reg_reg(A_MOVZX,S_WL,ind,hr);
+                              ind:=hr;
+                           end;
+                      end;
+                   end;
+                 LOC_CREGISTER:
+                   begin
+                      ind:=getregister32;
+                      case right.resulttype^.size of
+                         1:
+                           emit_reg_reg(A_MOVZX,S_BL,right.location.register,ind);
+                         2:
+                           emit_reg_reg(A_MOVZX,S_WL,right.location.register,ind);
+                         4:
+                           emit_reg_reg(A_MOV,S_L,right.location.register,ind);
+                      end;
+                   end;
+                 LOC_FLAGS:
+                   begin
+                      ind:=getregister32;
+                      emit_flag2reg(right.location.resflags,reg32toreg8(ind));
+                      emit_reg_reg(A_MOVZX,S_BL,reg32toreg8(ind),ind);
+                   end;
+                 LOC_JUMP :
+                   begin
+                     ind:=getregister32;
+                     emitlab(truelabel);
+                     truelabel:=otl;
+                     emit_const_reg(A_MOV,S_L,1,ind);
+                     getlabel(hl);
+                     emitjmp(C_None,hl);
+                     emitlab(falselabel);
+                     falselabel:=ofl;
+                     emit_reg_reg(A_XOR,S_L,ind,ind);
+                     emitlab(hl);
+                   end;
+                 LOC_REFERENCE,LOC_MEM :
+                   begin
+                      del_reference(right.location.reference);
+                      ind:=getregister32;
+                      { Booleans are stored in an 8 bit memory location, so
+                        the use of MOVL is not correct }
+                      case right.resulttype^.size of
+                       1 : tai:=new(paicpu,op_ref_reg(A_MOVZX,S_BL,newreference(right.location.reference),ind));
+                       2 : tai:=new(Paicpu,op_ref_reg(A_MOVZX,S_WL,newreference(right.location.reference),ind));
+                       4 : tai:=new(Paicpu,op_ref_reg(A_MOV,S_L,newreference(right.location.reference),ind));
+                      end;
+                      exprasmlist^.concat(tai);
+                   end;
+                 else
+                   internalerror(5913428);
+                end;
+
+            { produce possible range check code: }
+              if cs_check_range in aktlocalswitches then
+               begin
+                 if left.resulttype^.deftype=arraydef then
+                   begin
+                     { done defore (PM) }
+                   end
+                 else if (left.resulttype^.deftype=stringdef) then
+                   begin
+                      case pstringdef(left.resulttype)^.string_typ of
+                         { it's the same for ansi- and wide strings }
+                         st_widestring,
+                         st_ansistring:
+                           begin
+                              pushusedregisters(pushed,$ff);
+                              emit_reg(A_PUSH,S_L,ind);
+                              hp:=newreference(location.reference);
+                              dec(hp^.offset,7);
+                              emit_ref(A_PUSH,S_L,hp);
+                              emitcall('FPC_ANSISTR_RANGECHECK');
+                              popusedregisters(pushed);
+                              maybe_loadesi;
+                           end;
+                         st_shortstring:
+                           begin
+                              {!!!!!!!!!!!!!!!!!}
+                           end;
+                         st_longstring:
+                           begin
+                              {!!!!!!!!!!!!!!!!!}
+                           end;
+                      end;
+                   end;
+               end;
+
+              if location.reference.index=R_NO then
+               begin
+                 location.reference.index:=ind;
+                 calc_emit_mul;
+               end
+              else
+               begin
+                 if location.reference.base=R_NO then
+                  begin
+                    case location.reference.scalefactor of
+                     2 : emit_const_reg(A_SHL,S_L,1,location.reference.index);
+                     4 : emit_const_reg(A_SHL,S_L,2,location.reference.index);
+                     8 : emit_const_reg(A_SHL,S_L,3,location.reference.index);
+                    end;
+                    calc_emit_mul;
+                    location.reference.base:=location.reference.index;
+                    location.reference.index:=ind;
+                  end
+                 else
+                  begin
+                    emit_ref_reg(
+                      A_LEA,S_L,newreference(location.reference),
+                      location.reference.index);
+                    ungetregister32(location.reference.base);
+                    { the symbol offset is loaded,             }
+                    { so release the symbol name and set symbol  }
+                    { to nil                                 }
+                    location.reference.symbol:=nil;
+                    location.reference.offset:=0;
+                    calc_emit_mul;
+                    location.reference.base:=location.reference.index;
+                    location.reference.index:=ind;
+                  end;
+               end;
+
+              if nf_memseg in flags then
+                location.reference.segment:=R_FS;
+           end;
+      end;
+
+{*****************************************************************************
+                            TI386SELFNODE
+*****************************************************************************}
+
+    procedure ti386selfnode.pass_2;
+      begin
+         reset_reference(location.reference);
+         getexplicitregister32(R_ESI);
+         if (resulttype^.deftype=classrefdef) or
+           ((resulttype^.deftype=objectdef)
+             and pobjectdef(resulttype)^.is_class
+           ) then
+           location.register:=R_ESI
+         else
+           location.reference.base:=R_ESI;
+      end;
+
+
+{*****************************************************************************
+                            TI386WITHNODE
+*****************************************************************************}
+
+    procedure ti386withnode.pass_2;
+      var
+        usetemp,with_expr_in_temp : boolean;
+{$ifdef GDB}
+        withstartlabel,withendlabel : pasmlabel;
+        pp : pchar;
+        mangled_length  : longint;
+
+      const
+        withlevel : longint = 0;
+{$endif GDB}
+      begin
+         if assigned(left) then
+            begin
+               secondpass(left);
+               if left.location.reference.segment<>R_NO then
+                 message(parser_e_no_with_for_variable_in_other_segments);
+
+               new(withreference);
+
+               usetemp:=false;
+               if (left.nodetype=loadn) and
+                  (tloadnode(left).symtable=aktprocsym^.definition^.localst) then
+                 begin
+                    { for locals use the local storage }
+                    withreference^:=left.location.reference;
+                    include(flags,nf_islocal);
+                 end
+               else
+                { call can have happend with a property }
+                if (left.resulttype^.deftype=objectdef) and
+                   pobjectdef(left.resulttype)^.is_class then
+                 begin
+{$ifndef noAllocEdi}
+                    getexplicitregister32(R_EDI);
+{$endif noAllocEdi}
+                    emit_mov_loc_reg(left.location,R_EDI);
+                    usetemp:=true;
+                 end
+               else
+                 begin
+{$ifndef noAllocEdi}
+                   getexplicitregister32(R_EDI);
+{$endif noAllocEdi}
+                   emit_lea_loc_reg(left.location,R_EDI,false);
+                   usetemp:=true;
+                 end;
+
+               release_loc(left.location);
+
+               { if the with expression is stored in a temp    }
+               { area we must make it persistent and shouldn't }
+               { release it (FK)                               }
+               if (left.location.loc in [LOC_MEM,LOC_REFERENCE]) and
+                 istemp(left.location.reference) then
+                 begin
+                    normaltemptopersistant(left.location.reference.offset);
+                    with_expr_in_temp:=true;
+                 end
+               else
+                 with_expr_in_temp:=false;
+
+               { if usetemp is set the value must be in %edi }
+               if usetemp then
+                begin
+                  gettempofsizereference(4,withreference^);
+                  normaltemptopersistant(withreference^.offset);
+                  { move to temp reference }
+                  emit_reg_ref(A_MOV,S_L,R_EDI,newreference(withreference^));
+{$ifndef noAllocEdi}
+                  ungetregister32(R_EDI);
+{$endif noAllocEdi}
+{$ifdef GDB}
+                  if (cs_debuginfo in aktmoduleswitches) then
+                    begin
+                      inc(withlevel);
+                      getaddrlabel(withstartlabel);
+                      getaddrlabel(withendlabel);
+                      emitlab(withstartlabel);
+                      withdebuglist^.concat(new(pai_stabs,init(strpnew(
+                         '"with'+tostr(withlevel)+':'+tostr(symtablestack^.getnewtypecount)+
+                         '=*'+left.resulttype^.numberstring+'",'+
+                         tostr(N_LSYM)+',0,0,'+tostr(withreference^.offset)))));
+                      mangled_length:=length(aktprocsym^.definition^.mangledname);
+                      getmem(pp,mangled_length+50);
+                      strpcopy(pp,'192,0,0,'+withstartlabel^.name);
+                      if (target_os.use_function_relative_addresses) then
+                        begin
+                          strpcopy(strend(pp),'-');
+                          strpcopy(strend(pp),aktprocsym^.definition^.mangledname);
+                        end;
+                      withdebuglist^.concat(new(pai_stabn,init(strnew(pp))));
+                    end;
+{$endif GDB}
+                  del_reference(left.location.reference);
+                end;
+
+               { right can be optimize out !!! }
+               if assigned(right) then
+                 secondpass(right);
+
+               if usetemp then
+                 begin
+                   ungetpersistanttemp(withreference^.offset);
+{$ifdef GDB}
+                   if (cs_debuginfo in aktmoduleswitches) then
+                     begin
+                       emitlab(withendlabel);
+                       strpcopy(pp,'224,0,0,'+withendlabel^.name);
+                      if (target_os.use_function_relative_addresses) then
+                        begin
+                          strpcopy(strend(pp),'-');
+                          strpcopy(strend(pp),aktprocsym^.definition^.mangledname);
+                        end;
+                       withdebuglist^.concat(new(pai_stabn,init(strnew(pp))));
+                       freemem(pp,mangled_length+50);
+                       dec(withlevel);
+                     end;
+{$endif GDB}
+                 end;
+
+               if with_expr_in_temp then
+                 ungetpersistanttemp(left.location.reference.offset);
+
+               dispose(withreference);
+               withreference:=nil;
+            end;
+       end;
+
+begin
+   cloadvmtnode:=ti386loadvmtnode;
+   chnewnode:=ti386hnewnode;
+   cnewnode:=ti386newnode;
+   chdisposenode:=ti386hdisposenode;
+   csimplenewdisposenode:=ti386simplenewdisposenode;
+   caddrnode:=ti386addrnode;
+   cdoubleaddrnode:=ti386doubleaddrnode;
+   cderefnode:=ti386derefnode;
+   csubscriptnode:=ti386subscriptnode;
+   cvecnode:=ti386vecnode;
+   cselfnode:=ti386selfnode;
+   cwithnode:=ti386withnode;
+end.
+{
+  $Log$
+  Revision 1.1  2000-10-14 10:14:49  peter
+    * moehrendorf oct 2000 rewrite
+
+}

compiler/n386set.pas

@@ -34,7 +34,7 @@ interface
           procedure pass_2;override;
        end;
 
-       ti386innode = class(tsetinnode)
+       ti386innode = class(tinnode)
           procedure pass_2;override;
        end;
        ti386casenode = class(tcasenode)
@@ -48,8 +48,9 @@ implementation
       cobjects,verbose,globals,
       symconst,symtable,aasm,types,
       hcodegen,temp_gen,pass_2,
+      ncon,
       cpubase,cpuasm,
-      cgai386,tgeni386;
+      cgai386,tgeni386,n386util;
 
      const
        bytes2Sxx:array[1..8] of Topsize=(S_B,S_W,S_NO,S_L,S_NO,S_NO,S_NO,S_Q);
@@ -176,11 +177,11 @@ implementation
                      (left.resulttype^.deftype=enumdef) and (penumdef(left.resulttype)^.max<=32));
 
          { Can we generate jumps? Possible for all types of sets }
-         genjumps:=(right.treetype=setconstn) and
-                   analizeset(right.value_set,use_small);
+         genjumps:=(right.nodetype=setconstn) and
+                   analizeset(tsetconstnode(right).value_set,use_small);
          { calculate both operators }
          { the complex one first }
-         firstcomplex(p);
+         firstcomplex(self);
          secondpass(left);
          { Only process the right if we are not generating jumps }
          if not genjumps then
@@ -194,8 +195,8 @@ implementation
           exit;
 
          { ofcourse not commutative }
-         if swaped then
-          swaptree(p);
+         if nf_swaped in flags then
+          swapleftright;
 
          if genjumps then
           begin
@@ -348,7 +349,7 @@ implementation
             handle smallsets separate, because it allows faster checks }
             if use_small then
              begin
-               if left.treetype=ordconstn then
+               if left.nodetype=ordconstn then
                 begin
                   location.resflags:=F_NE;
                   case right.location.loc of
@@ -356,12 +357,12 @@ implementation
                      LOC_CREGISTER:
                       begin
                          emit_const_reg(A_TEST,S_L,
-                           1 shl (left.value and 31),right.location.register);
+                           1 shl (tordconstnode(left).value and 31),right.location.register);
                          ungetregister32(right.location.register);
                        end
                   else
                    begin
-                     emit_const_ref(A_TEST,S_L,1 shl (left.value and 31),
+                     emit_const_ref(A_TEST,S_L,1 shl (tordconstnode(left).value and 31),
                        newreference(right.location.reference));
                      del_reference(right.location.reference);
                    end;
@@ -430,13 +431,13 @@ implementation
                   getlabel(l2);
 
                   { Is this treated in firstpass ?? }
-                  if left.treetype=ordconstn then
+                  if left.nodetype=ordconstn then
                     begin
                       hr:=getregister32;
                       left.location.loc:=LOC_REGISTER;
                       left.location.register:=hr;
                       emit_const_reg(A_MOV,S_L,
-                            left.value,hr);
+                            tordconstnode(left).value,hr);
                     end;
                   case left.location.loc of
                      LOC_REGISTER,
@@ -495,11 +496,11 @@ implementation
                 end { of right.location.reference.is_immediate }
                { do search in a normal set which could have >32 elementsm
                  but also used if the left side contains higher values > 32 }
-               else if left.treetype=ordconstn then
+               else if left.nodetype=ordconstn then
                 begin
                   location.resflags:=F_NE;
-                  inc(right.location.reference.offset,left.value shr 3);
-                  emit_const_ref(A_TEST,S_B,1 shl (left.value and 7),
+                  inc(right.location.reference.offset,tordconstnode(left).value shr 3);
+                  emit_const_ref(A_TEST,S_B,1 shl (tordconstnode(left).value and 7),
                     newreference(right.location.reference));
                   del_reference(right.location.reference);
                 end
@@ -548,21 +549,21 @@ implementation
            lesslabel,greaterlabel : pasmlabel;
 
        begin
-         emitlab(_at);
+         emitlab(p^._at);
          { calculate labels for left and right }
-         if (less=nil) then
+         if (p^.less=nil) then
            lesslabel:=elselabel
          else
-           lesslabel:=less^._at;
-         if (greater=nil) then
+           lesslabel:=p^.less^._at;
+         if (p^.greater=nil) then
            greaterlabel:=elselabel
          else
-           greaterlabel:=greater^._at;
+           greaterlabel:=p^.greater^._at;
            { calculate labels for left and right }
          { no range label: }
-         if _low=_high then
+         if p^._low=p^._high then
            begin
-              emit_const_reg(A_CMP,opsize,_low,hregister);
+              emit_const_reg(A_CMP,opsize,p^._low,hregister);
               if greaterlabel=lesslabel then
                 emitjmp(C_NE,lesslabel)
               else
@@ -570,20 +571,20 @@ implementation
                    emitjmp(jmp_le,lesslabel);
                    emitjmp(jmp_gt,greaterlabel);
                 end;
-              emitjmp(C_None,statement);
+              emitjmp(C_None,p^.statement);
            end
          else
            begin
-              emit_const_reg(A_CMP,opsize,_low,hregister);
+              emit_const_reg(A_CMP,opsize,p^._low,hregister);
               emitjmp(jmp_le,lesslabel);
-              emit_const_reg(A_CMP,opsize,_high,hregister);
+              emit_const_reg(A_CMP,opsize,p^._high,hregister);
               emitjmp(jmp_gt,greaterlabel);
-              emitjmp(C_None,statement);
+              emitjmp(C_None,p^.statement);
            end;
-          if assigned(less) then
-           gentreejmp(less);
-          if assigned(greater) then
-           gentreejmp(greater);
+          if assigned(p^.less) then
+           gentreejmp(p^.less);
+          if assigned(p^.greater) then
+           gentreejmp(p^.greater);
       end;
 
       procedure genlinearcmplist(hp : pcaserecord);
@@ -1036,11 +1037,11 @@ implementation
          while assigned(hp) do
            begin
               cleartempgen;
-              secondpass(hp.right);
+              secondpass(tbinarynode(hp).right);
               { don't come back to case line }
               aktfilepos:=exprasmlist^.getlasttaifilepos^;
               emitjmp(C_None,endlabel);
-              hp:=hp.left;
+              hp:=tbinarynode(hp).left;
            end;
          emitlab(elselabel);
          { ...and the else block }
@@ -1060,7 +1061,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.3  2000-09-30 16:08:45  peter
+  Revision 1.4  2000-10-14 10:14:49  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.3  2000/09/30 16:08:45  peter
     * more cg11 updates
 
   Revision 1.2  2000/09/24 20:17:44  florian

compiler/n386util.pas

@@ -34,19 +34,36 @@ interface
     function maybe_savetotemp(needed : byte;p : tnode;isint64 : boolean) : boolean;
 {$endif TEMPS_NOT_PUSH}
     procedure restore(p : tnode;isint64 : boolean);
+{$ifdef TEMPS_NOT_PUSH}
+    procedure restorefromtemp(p : tnode;isint64 : boolean);
+{$endif TEMPS_NOT_PUSH}
     procedure pushsetelement(p : tnode);
     procedure push_value_para(p:tnode;inlined,is_cdecl:boolean;
                               para_offset:longint;alignment : longint);
+    procedure loadshortstring(source,dest : tnode);
+    procedure loadlongstring(p:tbinarynode);
+    procedure loadansi2short(source,dest : tnode);
 
     procedure maketojumpbool(p : tnode);
     procedure emitoverflowcheck(p:tnode);
     procedure emitrangecheck(p:tnode;todef:pdef);
-    procedure firstcomplex(p : tnode);
+    procedure firstcomplex(p : tbinarynode);
 
 implementation
 
     uses
-      ncon;
+       globtype,globals,systems,verbose,
+       cutils,cobjects,
+       aasm,cpubase,cpuasm,
+{$ifdef GDB}
+       gdb,symconst,
+{$endif GDB}
+       types,
+       ncon,nld,
+       pass_1,pass_2,
+       hcodegen,tgeni386,temp_gen,
+       cgai386;
+
 
 {*****************************************************************************
                            Emit Push Functions
@@ -218,6 +235,43 @@ implementation
       end;
 
 
+{$ifdef TEMPS_NOT_PUSH}
+    procedure restorefromtemp(p : tnode;isint64 : boolean);
+      var
+         hregister :  tregister;
+         href : treference;
+
+      begin
+         hregister:=getregister32;
+         reset_reference(href);
+         href.base:=procinfo^.frame_pointer;
+         href.offset:=p.temp_offset;
+         emit_ref_reg(A_MOV,S_L,href,hregister);
+         if (p.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then
+           begin
+              p.location.register:=hregister;
+              if isint64 then
+                begin
+                   p.location.registerhigh:=getregister32;
+                   href.offset:=p.temp_offset+4;
+                   emit_ref_reg(A_MOV,S_L,p.location.registerhigh);
+                   { set correctly for release ! }
+                   href.offset:=p.temp_offset;
+                end;
+           end
+         else
+           begin
+              reset_reference(p.location.reference);
+              p.location.reference.base:=hregister;
+              { Why is this done? We can never be sure about p^.left
+                because otherwise secondload fails PM
+              set_location(p^.left^.location,p^.location);}
+           end;
+         ungetiftemp(href);
+      end;
+{$endif TEMPS_NOT_PUSH}
+
+
     procedure pushsetelement(p : tnode);
       var
          hr,hr16,hr32 : tregister;
@@ -795,7 +849,7 @@ implementation
         opsize : topsize;
         storepos : tfileposinfo;
       begin
-         if p.error then
+         if nf_error in p.flags then
            exit;
          storepos:=aktfilepos;
          aktfilepos:=p.fileinfo;
@@ -803,7 +857,7 @@ implementation
            begin
               if is_constboolnode(p) then
                 begin
-                   if p.value<>0 then
+                   if tordconstnode(p).value<>0 then
                      emitjmp(C_None,truelabel)
                    else
                      emitjmp(C_None,falselabel);
@@ -1045,41 +1099,224 @@ implementation
 
    { DO NOT RELY on the fact that the tnode is not yet swaped
      because of inlining code PM }
-    procedure firstcomplex(p : tnode);
+    procedure firstcomplex(p : tbinarynode);
       var
          hp : tnode;
       begin
          { always calculate boolean AND and OR from left to right }
-         if (p.treetype in [orn,andn]) and
-            (p.left^.resulttype^.deftype=orddef) and
-            (porddef(p.left^.resulttype)^.typ in [bool8bit,bool16bit,bool32bit]) then
+         if (p.nodetype in [orn,andn]) and
+            (p.left.resulttype^.deftype=orddef) and
+            (porddef(p.left.resulttype)^.typ in [bool8bit,bool16bit,bool32bit]) then
            begin
              { p.swaped:=false}
-             if p.swaped then
+             if nf_swaped in p.flags then
                internalerror(234234);
            end
          else
-           if (p.left^.registers32<p.right^.registers32) and
+           if (p.left.registers32<p.right.registers32) and
            { the following check is appropriate, because all }
            { 4 registers are rarely used and it is thereby   }
            { achieved that the extra code is being dropped   }
            { by exchanging not commutative operators     }
-              (p.right^.registers32<=4) then
+              (p.right.registers32<=4) then
             begin
               hp:=p.left;
               p.left:=p.right;
               p.right:=hp;
-              p.swaped:=not p.swaped;
+              if nf_swaped in p.flags then
+                exclude(p.flags,nf_swaped)
+              else
+                include(p.flags,nf_swaped);
             end;
          {else
            p.swaped:=false; do not modify }
       end;
-{$endif}
+
+{*****************************************************************************
+                           Emit Functions
+*****************************************************************************}
+
+    procedure push_shortstring_length(p:tnode);
+      var
+        hightree : tnode;
+      begin
+        if is_open_string(p.resulttype) then
+         begin
+           getsymonlyin(tloadnode(p).symtable,'high'+pvarsym(tloadnode(p).symtableentry)^.name);
+           hightree:=genloadnode(pvarsym(srsym),tloadnode(p).symtable);
+           firstpass(hightree);
+           secondpass(hightree);
+           push_value_para(hightree,false,false,0,4);
+           hightree.free;
+         end
+        else
+         begin
+           push_int(pstringdef(p.resulttype)^.len);
+         end;
+      end;
+
+{*****************************************************************************
+                           String functions
+*****************************************************************************}
+
+    procedure loadshortstring(source,dest : tnode);
+    {
+      Load a string, handles stringdef and orddef (char) types
+    }
+      begin
+         case source.resulttype^.deftype of
+            stringdef:
+              begin
+                 if (source.nodetype=stringconstn) and
+                   (str_length(source)=0) then
+                   emit_const_ref(
+                      A_MOV,S_B,0,newreference(dest.location.reference))
+                 else
+                   begin
+                     emitpushreferenceaddr(dest.location.reference);
+                     emitpushreferenceaddr(source.location.reference);
+                     push_shortstring_length(dest);
+                     emitcall('FPC_SHORTSTR_COPY');
+                     maybe_loadesi;
+                   end;
+              end;
+            orddef:
+              begin
+                 if source.nodetype=ordconstn then
+                   emit_const_ref(
+                      A_MOV,S_W,tordconstnode(source).value*256+1,newreference(dest.location.reference))
+                 else
+                   begin
+                      { not so elegant (goes better with extra register }
+{$ifndef noAllocEdi}
+                      getexplicitregister32(R_EDI);
+{$endif noAllocEdi}
+                      if (source.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then
+                        begin
+                           emit_reg_reg(A_MOV,S_L,makereg32(source.location.register),R_EDI);
+                           ungetregister(source.location.register);
+                        end
+                      else
+                        begin
+                           emit_ref_reg(A_MOV,S_L,newreference(source.location.reference),R_EDI);
+                           del_reference(source.location.reference);
+                        end;
+                      emit_const_reg(A_SHL,S_L,8,R_EDI);
+                      emit_const_reg(A_OR,S_L,1,R_EDI);
+                      emit_reg_ref(A_MOV,S_W,R_DI,newreference(dest.location.reference));
+{$ifndef noAllocEdi}
+                      ungetregister32(R_EDI);
+{$endif noAllocEdi}
+                   end;
+              end;
+         else
+           CGMessage(type_e_mismatch);
+         end;
+      end;
+
+    procedure loadlongstring(p:tbinarynode);
+    {
+      Load a string, handles stringdef and orddef (char) types
+    }
+      var
+         r : preference;
+
+      begin
+         case p.right.resulttype^.deftype of
+            stringdef:
+              begin
+                 if (p.right.nodetype=stringconstn) and
+                   (str_length(p.right)=0) then
+                   emit_const_ref(A_MOV,S_L,0,newreference(p.left.location.reference))
+                 else
+                   begin
+                     emitpushreferenceaddr(p.left.location.reference);
+                     emitpushreferenceaddr(p.right.location.reference);
+                     push_shortstring_length(p.left);
+                     emitcall('FPC_LONGSTR_COPY');
+                     maybe_loadesi;
+                   end;
+              end;
+            orddef:
+              begin
+                 emit_const_ref(A_MOV,S_L,1,newreference(p.left.location.reference));
+
+                 r:=newreference(p.left.location.reference);
+                 inc(r^.offset,4);
+
+                 if p.right.nodetype=ordconstn then
+                   emit_const_ref(A_MOV,S_B,tordconstnode(p.right).value,r)
+                 else
+                   begin
+                      case p.right.location.loc of
+                         LOC_REGISTER,LOC_CREGISTER:
+                           begin
+                              emit_reg_ref(A_MOV,S_B,p.right.location.register,r);
+                              ungetregister(p.right.location.register);
+                           end;
+                         LOC_MEM,LOC_REFERENCE:
+                           begin
+                              if not(R_EAX in unused) then
+                                emit_reg(A_PUSH,S_L,R_EAX);
+                              emit_ref_reg(A_MOV,S_B,newreference(p.right.location.reference),R_AL);
+                              emit_reg_ref(A_MOV,S_B,R_AL,r);
+
+                              if not(R_EAX in unused) then
+                                emit_reg(A_POP,S_L,R_EAX);
+                              del_reference(p.right.location.reference);
+                           end
+                         else
+                           internalerror(20799);
+                        end;
+                   end;
+              end;
+         else
+           CGMessage(type_e_mismatch);
+         end;
+      end;
+
+
+    procedure loadansi2short(source,dest : tnode);
+      var
+         pushed : tpushed;
+         regs_to_push: byte;
+      begin
+         { Find out which registers have to be pushed (JM) }
+         regs_to_push := $ff;
+         remove_non_regvars_from_loc(source.location,regs_to_push);
+         { Push them (JM) }
+         pushusedregisters(pushed,regs_to_push);
+         case source.location.loc of
+           LOC_REFERENCE,LOC_MEM:
+             begin
+                { Now release the location and registers (see cgai386.pas: }
+                { loadansistring for more info on the order) (JM)          }
+                ungetiftemp(source.location.reference);
+                del_reference(source.location.reference);
+                emit_push_mem(source.location.reference);
+             end;
+           LOC_REGISTER,LOC_CREGISTER:
+             begin
+                emit_reg(A_PUSH,S_L,source.location.register);
+                { Now release the register (JM) }
+                ungetregister32(source.location.register);
+             end;
+         end;
+         push_shortstring_length(dest);
+         emitpushreferenceaddr(dest.location.reference);
+         emitcall('FPC_ANSISTR_TO_SHORTSTR');
+         popusedregisters(pushed);
+         maybe_loadesi;
+      end;
+
 
 end.
 {
   $Log$
-  Revision 1.1  2000-10-01 19:58:40  peter
+  Revision 1.2  2000-10-14 10:14:50  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.1  2000/10/01 19:58:40  peter
     * new file
 
 }

compiler/nadd.pas

@@ -119,9 +119,9 @@ implementation
          { convert array constructors to sets, because there is no other operator
            possible for array constructors }
          if is_array_constructor(left.resulttype) then
-           arrayconstructor_to_set(tarrayconstructnode(left));
+           arrayconstructor_to_set(tarrayconstructornode(left));
          if is_array_constructor(right.resulttype) then
-           arrayconstructor_to_set(tarrayconstructnode(right));
+           arrayconstructor_to_set(tarrayconstructornode(right));
 
          { both left and right need to be valid }
          set_varstate(left,true);
@@ -1232,7 +1232,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.12  2000-10-01 19:48:23  peter
+  Revision 1.13  2000-10-14 10:14:50  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.12  2000/10/01 19:48:23  peter
     * lot of compile updates for cg11
 
   Revision 1.11  2000/09/30 16:08:45  peter

compiler/nbas.pas

@@ -0,0 +1,333 @@
+{
+    $Id$
+    Copyright (c) 2000 by Florian Klaempfl
+
+    This unit implements some basic nodes
+
+    This program is free software; you can redistribute it and/or modify
+    it under the terms of the GNU General Public License as published by
+    the Free Software Foundation; either version 2 of the License, or
+    (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU General Public License for more details.
+
+    You should have received a copy of the GNU General Public License
+    along with this program; if not, write to the Free Software
+    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ ****************************************************************************
+}
+unit nbas;
+
+{$i defines.inc}
+
+interface
+
+    uses
+       aasm,node;
+
+    type
+       tnothingnode = class(tnode)
+          constructor create;virtual;
+          function pass_1 : tnode;override;
+          procedure pass_2;override;
+       end;
+
+       terrornode = class(tnode)
+          constructor create;virtual;
+          function pass_1 : tnode;override;
+       end;
+
+       tasmnode = class(tnode)
+          p_asm : paasmoutput;
+          constructor create(p : paasmoutput);virtual;
+          function pass_1 : tnode;override;
+       end;
+
+       tstatementnode = class(tbinarynode)
+          constructor create(l,r : tnode);virtual;
+          function pass_1 : tnode;override;
+{$ifdef extdebug}
+          procedure dowrite;override;
+{$endif extdebug}
+       end;
+
+       tblocknode = class(tunarynode)
+          constructor create(l : tnode);virtual;
+          function pass_1 : tnode;override;
+       end;
+
+    var
+       cnothingnode : class of tnothingnode;
+       cerrornode : class of terrornode;
+       casmnode : class of tasmnode;
+       cstatementnode : class of tstatementnode;
+       cblocknode : class of tblocknode;
+
+implementation
+
+    uses
+      globtype,systems,
+      cutils,cobjects,verbose,globals,
+      symtable,types,
+      htypechk,
+      cpubase,cpuasm,
+      pass_1,
+      nflw
+{$ifdef newcg}
+      ,cgbase
+      ,tgcpu
+{$else newcg}
+      ,hcodegen
+  {$ifdef i386}
+      ,tgeni386
+  {$endif}
+  {$ifdef m68k}
+      ,tgen68k
+  {$endif}
+{$endif}
+      ;
+
+{*****************************************************************************
+                             TFIRSTNOTHING
+*****************************************************************************}
+
+    constructor tnothingnode.create;
+
+      begin
+         inherited create(nothingn);
+      end;
+
+    function tnothingnode.pass_1 : tnode;
+      begin
+         pass_1:=nil;
+         resulttype:=voiddef;
+      end;
+
+    procedure tnothingnode.pass_2;
+
+      begin
+         { avoid an abstract rte }
+      end;
+
+
+{*****************************************************************************
+                             TFIRSTERROR
+*****************************************************************************}
+
+    constructor terrornode.create;
+
+      begin
+         inherited create(errorn);
+      end;
+
+    function terrornode.pass_1 : tnode;
+      begin
+         pass_1:=nil;
+         include(flags,nf_error);
+         codegenerror:=true;
+         resulttype:=generrordef;
+      end;
+
+{*****************************************************************************
+                            TSTATEMENTNODE
+*****************************************************************************}
+
+    constructor tstatementnode.create(l,r : tnode);
+
+      begin
+         inherited create(statementn,l,r);
+      end;
+
+    function tstatementnode.pass_1 : tnode;
+      begin
+         pass_1:=nil;
+         { left is the next statement in the list }
+         resulttype:=voiddef;
+         { no temps over several statements }
+{$ifdef newcg}
+         tg.cleartempgen;
+{$else newcg}
+         cleartempgen;
+{$endif newcg}
+         { right is the statement itself calln assignn or a complex one }
+         {must_be_valid:=true; obsolete PM }
+         firstpass(right);
+         if (not (cs_extsyntax in aktmoduleswitches)) and
+            assigned(right.resulttype) and
+            (right.resulttype<>pdef(voiddef)) then
+           CGMessage(cg_e_illegal_expression);
+         if codegenerror then
+           exit;
+         registers32:=right.registers32;
+         registersfpu:=right.registersfpu;
+{$ifdef SUPPORT_MMX}
+         registersmmx:=right.registersmmx;
+{$endif SUPPORT_MMX}
+         { left is the next in the list }
+         firstpass(left);
+         if codegenerror then
+           exit;
+         if right.registers32>registers32 then
+           registers32:=right.registers32;
+         if right.registersfpu>registersfpu then
+           registersfpu:=right.registersfpu;
+{$ifdef SUPPORT_MMX}
+         if right.registersmmx>registersmmx then
+           registersmmx:=right.registersmmx;
+{$endif}
+      end;
+
+{$ifdef extdebug}
+    procedure tstatementnode.dowrite;
+
+      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(right);
+         writeln(')');
+         delete(writenodeindention,1,4);
+         { go on with the next statement }
+         writenode(left);
+      end;
+{$endif}
+
+{*****************************************************************************
+                             TBLOCKNODE
+*****************************************************************************}
+
+    constructor tblocknode.create(l : tnode);
+
+      begin
+         inherited create(blockn,l);
+      end;
+
+    function tblocknode.pass_1 : tnode;
+      var
+         hp : tstatementnode;
+         count : longint;
+      begin
+         pass_1:=nil;
+         count:=0;
+         hp:=tstatementnode(left);
+         while assigned(hp) do
+           begin
+              if cs_regalloc in aktglobalswitches then
+                begin
+                   { node transformations }
+
+                   { concat function result to exit }
+                   { this is wrong for string or other complex
+                     result types !!! }
+                   if ret_in_acc(procinfo^.returntype.def) and
+                      assigned(hp.left) and
+                      assigned(tstatementnode(hp.left).right) and
+                      (tstatementnode(hp.left).right.nodetype=exitn) and
+                      (hp.right.nodetype=assignn) and
+                      { !!!! this tbinarynode should be tassignmentnode }
+                      (tbinarynode(hp.right).left.nodetype=funcretn) then
+                      begin
+                         if assigned(texitnode(tstatementnode(hp.left).right).left) then
+                           CGMessage(cg_n_inefficient_code)
+                         else
+                           begin
+                              texitnode(tstatementnode(hp.left).right).left:=tstatementnode(hp.right).right;
+                              tstatementnode(hp.right).right:=nil;
+                              hp.right.free;
+                              hp.right:=nil;
+                           end;
+                      end
+                   { warning if unreachable code occurs and elimate this }
+                   else if (hp.right.nodetype in
+                     [exitn,breakn,continuen,goton]) and
+                     { statement node (JM) }
+                     assigned(hp.left) and
+                     { kind of statement! (JM) }
+                     assigned(tstatementnode(hp.left).right) and
+                     (tstatementnode(hp.left).right.nodetype<>labeln) then
+                     begin
+                        { use correct line number }
+                        aktfilepos:=hp.left.fileinfo;
+                        hp.left.free;
+                        hp.left:=nil;
+                        CGMessage(cg_w_unreachable_code);
+                        { old lines }
+                        aktfilepos:=hp.right.fileinfo;
+                     end;
+                end;
+              if assigned(hp.right) then
+                begin
+{$ifdef newcg}
+                   tg.cleartempgen;
+{$else newcg}
+                   cleartempgen;
+{$endif newcg}
+                   codegenerror:=false;
+                   firstpass(hp.right);
+                   if (not (cs_extsyntax in aktmoduleswitches)) and
+                      assigned(hp.right.resulttype) and
+                      (hp.right.resulttype<>pdef(voiddef)) then
+                     CGMessage(cg_e_illegal_expression);
+                   {if codegenerror then
+                     exit;}
+                   hp.registers32:=hp.right.registers32;
+                   hp.registersfpu:=hp.right.registersfpu;
+{$ifdef SUPPORT_MMX}
+                   hp.registersmmx:=hp.right.registersmmx;
+{$endif SUPPORT_MMX}
+                end
+              else
+                hp.registers32:=0;
+
+              if hp.registers32>registers32 then
+                registers32:=hp.registers32;
+              if hp.registersfpu>registersfpu then
+                registersfpu:=hp.registersfpu;
+{$ifdef SUPPORT_MMX}
+              if hp.registersmmx>registersmmx then
+                registersmmx:=hp.registersmmx;
+{$endif}
+              inc(count);
+              hp:=tstatementnode(hp.left);
+           end;
+      end;
+
+
+{*****************************************************************************
+                             TASMNODE
+*****************************************************************************}
+
+    constructor tasmnode.create(p : paasmoutput);
+
+      begin
+         inherited create(asmn);
+         p_asm:=p;
+      end;
+
+
+    function tasmnode.pass_1 : tnode;
+      begin
+         pass_1:=nil;
+         procinfo^.flags:=procinfo^.flags or pi_uses_asm;
+      end;
+
+begin
+   cnothingnode:=tnothingnode;
+   cerrornode:=terrornode;
+   casmnode:=tasmnode;
+   cstatementnode:=tstatementnode;
+   cblocknode:=tblocknode;
+end.
+{
+  $Log$
+  Revision 1.1  2000-10-14 10:14:50  peter
+    * moehrendorf oct 2000 rewrite
+
+}

compiler/ncal.pas

@@ -40,21 +40,35 @@ interface
           methodpointer : tnode;
           { only the processor specific nodes need to override this }
           { constructor                                             }
-          constructor create(v : pprocsym;st : psymtable);virtual;
+          constructor create(v : pprocsym;st : psymtable; mp : tnode);virtual;
           destructor destroy;override;
+          function getcopy : tnode;override;
           function pass_1 : tnode;override;
        end;
 
+       tcallparaflags = (
+          { flags used by tcallparanode }
+          cpf_exact_match_found,
+          cpf_convlevel1found,
+          cpf_convlevel2found,
+          cpf_is_colon_para
+          );
+
        tcallparanode = class(tbinarynode)
+          callparaflags : set of tcallparaflags;
           hightree : tnode;
           { only the processor specific nodes need to override this }
           { constructor                                             }
           constructor create(expr,next : tnode);virtual;
           destructor destroy;override;
+          function getcopy : tnode;override;
           procedure gen_high_tree(openstring:boolean);
           { tcallparanode doesn't use pass_1 }
           { tcallnode takes care of this     }
           procedure firstcallparan(defcoll : pparaitem;do_count : boolean);virtual;
+          procedure secondcallparan(defcoll : pparaitem;
+                   push_from_left_to_right,inlined,is_cdecl : boolean;
+                   para_alignment,para_offset : longint);virtual;abstract;
        end;
 
        tprocinlinenode = class(tnode)
@@ -101,7 +115,7 @@ interface
     function gencallnode(v : pprocsym;st : psymtable) : tnode;
 
       begin
-         gencallnode:=ccallnode.create(v,st);
+         gencallnode:=ccallnode.create(v,st,nil);
       end;
 
     function gencallparanode(expr,next : tnode) : tnode;
@@ -129,7 +143,9 @@ interface
       begin
          inherited create(callparan,expr,next);
          hightree:=nil;
-         expr.set_file_line(self);
+         if assigned(expr) then
+          expr.set_file_line(self);
+         callparaflags:=[];
       end;
 
     destructor tcallparanode.destroy;
@@ -139,6 +155,21 @@ interface
          inherited destroy;
       end;
 
+    function tcallparanode.getcopy : tnode;
+
+      var
+         n : tcallparanode;
+
+      begin
+         n:=tcallparanode(inherited getcopy);
+         n.callparaflags:=callparaflags;
+         if assigned(hightree) then
+           n.hightree:=hightree.getcopy
+         else
+           n.hightree:=nil;
+         result:=n;
+      end;
+
     procedure tcallparanode.firstcallparan(defcoll : pparaitem;do_count : boolean);
       var
         old_get_para_resulttype : boolean;
@@ -192,7 +223,7 @@ interface
               { Do we need arrayconstructor -> set conversion, then insert
                 it here before the arrayconstructor node breaks the tree
                 with its conversions of enum->ord }
-              if (left.nodetype=arrayconstructn) and
+              if (left.nodetype=arrayconstructorn) and
                  (defcoll^.paratype.def^.deftype=setdef) then
                 left:=gentypeconvnode(left,defcoll^.paratype.def);
 
@@ -202,7 +233,7 @@ interface
                  if is_array_of_const(defcoll^.paratype.def) then
                   begin
                     if assigned(aktcallprocsym) and
-                       (pocall_cdecl in aktcallprocsym^.definition^.proccalloptions) and
+                       (([pocall_cppdecl,pocall_cdecl]*aktcallprocsym^.definition^.proccalloptions)<>[]) and
                        (po_external in aktcallprocsym^.definition^.procoptions) then
                       include(left.flags,nf_cargs);
                     { force variant array }
@@ -211,7 +242,7 @@ interface
                  else
                   begin
                     include(left.flags,nf_novariaallowed);
-                    tarrayconstructnode(left).constructdef:=parraydef(defcoll^.paratype.def)^.elementtype.def;
+                    tarrayconstructornode(left).constructordef:=parraydef(defcoll^.paratype.def)^.elementtype.def;
                   end;
                end;
 
@@ -234,7 +265,7 @@ interface
                  old_get_para_resulttype:=get_para_resulttype;
                  allow_array_constructor:=true;
                  get_para_resulttype:=false;
-                  if (left.nodetype in [arrayconstructn,typeconvn]) then
+                  if (left.nodetype in [arrayconstructorn,typeconvn]) then
                    firstpass(left);
                  if not assigned(resulttype) then
                    resulttype:=left.resulttype;
@@ -455,14 +486,14 @@ interface
                                  TCALLNODE
  ****************************************************************************}
 
-    constructor tcallnode.create(v : pprocsym;st : psymtable);
+    constructor tcallnode.create(v : pprocsym;st : psymtable; mp : tnode);
 
       begin
          inherited create(calln,nil,nil);
          symtableprocentry:=v;
          symtableproc:=st;
          include(flags,nf_return_value_used);
-         methodpointer:=nil;
+         methodpointer:=mp;
          procdefinition:=nil;
       end;
 
@@ -473,6 +504,21 @@ interface
          inherited destroy;
       end;
 
+    function tcallnode.getcopy : tnode;
+      var
+        n : tcallnode;
+      begin
+        n:=tcallnode(inherited getcopy);
+        n.symtableprocentry:=symtableprocentry;
+        n.symtableproc:=symtableproc;
+        n.procdefinition:=procdefinition;
+        if assigned(methodpointer) then
+         n.methodpointer:=methodpointer.getcopy
+        else
+         n.methodpointer:=nil;
+        result:=n;
+      end;
+
     function tcallnode.pass_1 : tnode;
       type
          pprocdefcoll = ^tprocdefcoll;
@@ -512,20 +558,20 @@ interface
 
         begin
            { safety check }
-           if not (assigned(def) or assigned(resulttype)) then
+           if not (assigned(def) or assigned(p.resulttype)) then
             begin
               is_equal:=false;
               exit;
             end;
            { all types can be passed to a formaldef }
            is_equal:=(def^.deftype=formaldef) or
-             (types.is_equal(resulttype,def))
+             (types.is_equal(p.resulttype,def))
            { integer constants are compatible with all integer parameters if
              the specified value matches the range }
              or
              (
               (left.nodetype=ordconstn) and
-              is_integer(resulttype) and
+              is_integer(p.resulttype) and
               is_integer(def) and
               (tordconstnode(left).value>=porddef(def)^.low) and
               (tordconstnode(left).value<=porddef(def)^.high)
@@ -535,24 +581,24 @@ interface
            { when searching the correct overloaded procedure   }
              or
              (
-              (def^.deftype=stringdef) and (resulttype^.deftype=stringdef) and
-              (pstringdef(def)^.string_typ=pstringdef(resulttype)^.string_typ)
+              (def^.deftype=stringdef) and (p.resulttype^.deftype=stringdef) and
+              (pstringdef(def)^.string_typ=pstringdef(p.resulttype)^.string_typ)
              )
              or
              (
               (left.nodetype=stringconstn) and
-              (is_ansistring(resulttype) and is_pchar(def))
+              (is_ansistring(p.resulttype) and is_pchar(def))
              )
              or
              (
               (left.nodetype=ordconstn) and
-              (is_char(resulttype) and (is_shortstring(def) or is_ansistring(def)))
+              (is_char(p.resulttype) and (is_shortstring(def) or is_ansistring(def)))
              )
            { set can also be a not yet converted array constructor }
              or
              (
-              (def^.deftype=setdef) and (resulttype^.deftype=arraydef) and
-              (parraydef(resulttype)^.IsConstructor) and not(parraydef(resulttype)^.IsVariant)
+              (def^.deftype=setdef) and (p.resulttype^.deftype=arraydef) and
+              (parraydef(p.resulttype)^.IsConstructor) and not(parraydef(p.resulttype)^.IsVariant)
              )
            { in tp7 mode proc -> procvar is allowed }
              or
@@ -781,7 +827,7 @@ interface
                                begin
                                   if hp^.nextpara^.paratype.def=pt.resulttype then
                                     begin
-                                       include(pt.flags,nf_exact_match_found);
+                                       include(tcallparanode(pt).callparaflags,cpf_exact_match_found);
                                        hp^.nextpara^.argconvtyp:=act_exact;
                                     end
                                   else
@@ -794,8 +840,8 @@ interface
                                  hp^.nextpara^.convertlevel:=isconvertable(pt.resulttype,hp^.nextpara^.paratype.def,
                                      hcvt,tcallparanode(pt).left.nodetype,false);
                                  case hp^.nextpara^.convertlevel of
-                                  1 : include(pt.flags,nf_convlevel1found);
-                                  2 : include(pt.flags,nf_convlevel2found);
+                                  1 : include(tcallparanode(pt).callparaflags,cpf_convlevel1found);
+                                  2 : include(tcallparanode(pt).callparaflags,cpf_convlevel2found);
                                  end;
                                end;
 
@@ -982,7 +1028,7 @@ interface
                         pt:=left;
                         while assigned(pt) do
                           begin
-                             if nf_exact_match_found in pt.flags then
+                             if cpf_exact_match_found in tcallparanode(pt).callparaflags then
                                begin
                                  hp:=procs;
                                  procs:=nil;
@@ -1098,8 +1144,8 @@ interface
                         pt:=left;
                         while assigned(pt) do
                           begin
-                             if (nf_convlevel1found in pt.flags) and
-                               (nf_convlevel2found in pt.flags) then
+                             if (cpf_convlevel1found in tcallparanode(pt).callparaflags) and
+                               (cpf_convlevel2found in tcallparanode(pt).callparaflags) then
                                begin
                                  hp:=procs;
                                  procs:=nil;
@@ -1448,7 +1494,10 @@ interface
 
       begin
          n:=tprocinlinenode(inherited getcopy);
-         n.inlinetree:=inlinetree.getcopy;
+         if assigned(inlinetree) then
+           n.inlinetree:=inlinetree.getcopy
+         else
+           n.inlinetree:=nil;
          n.inlineprocsym:=inlineprocsym;
          n.retoffset:=retoffset;
          n.para_offset:=para_offset;
@@ -1472,7 +1521,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.8  2000-10-01 19:48:24  peter
+  Revision 1.9  2000-10-14 10:14:50  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.8  2000/10/01 19:48:24  peter
     * lot of compile updates for cg11
 
   Revision 1.7  2000/09/28 19:49:52  florian
@@ -1496,4 +1548,4 @@ end.
   Revision 1.1  2000/09/20 20:52:16  florian
     * initial revision
 
-}
+}

compiler/ncgbas.pas

@@ -0,0 +1,114 @@
+{
+    $Id$
+    Copyright (c) 2000 by Florian Klaempfl
+
+    This unit implements some basic nodes
+
+    This program is free software; you can redistribute it and/or modify
+    it under the terms of the GNU General Public License as published by
+    the Free Software Foundation; either version 2 of the License, or
+    (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU General Public License for more details.
+
+    You should have received a copy of the GNU General Public License
+    along with this program; if not, write to the Free Software
+    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ ****************************************************************************
+}
+unit ncgbas;
+
+  interface
+
+    uses
+       node;
+
+    type
+       tcgnothingnode = class(tnoethingnode)
+          procedure pass_2;override;
+       end;
+
+       tcgerrornode = class(terrornode)
+          procedure pass_2;override;
+       end;
+
+       tcgasmnode = class(tasmnode)
+          procedure pass_2;override;
+       end;
+
+       tcgstatementnode = class(tstatementnode)
+          procedure pass_2;override;
+       end;
+
+       tcgblocknode = class(tblocknode)
+          procedure pass_2;override;
+       end;
+
+  implementation
+
+    uses
+      globtype,systems,
+      cutils,cobjects,verbose,globals,
+      aasm,symtable,types,
+      htypechk,
+      cpubase,cpuasm,
+      nflw
+{$ifdef newcg}
+      ,cgbase
+      ,tgcpu
+{$else newcg}
+      ,hcodegen
+  {$ifdef i386}
+      ,tgeni386
+  {$endif}
+  {$ifdef m68k}
+      ,tgen68k
+  {$endif}
+{$endif}
+      ;
+{*****************************************************************************
+                             TFIRSTNOTHING
+*****************************************************************************}
+
+    procedure tnothingnode.pass_2;
+
+      begin
+      end;
+
+{*****************************************************************************
+                             TFIRSTERROR
+*****************************************************************************}
+
+{*****************************************************************************
+                            TSTATEMENTNODE
+*****************************************************************************}
+
+{*****************************************************************************
+                             TBLOCKNODE
+*****************************************************************************}
+
+    procedure tblocknode.pass_2;
+      begin
+      { do second pass on left node }
+        if assigned(p^.left) then
+         secondpass(p^.left);
+      end;
+
+
+begin
+   cnothingnode:=tcgnothingnode;
+   cerrornode:=tcgerrornode;
+   casmnode:=tcgasmnode;
+   cstatementnode:=tcgstatementnode;
+   cblocknode:=tcgblocknode;
+end.
+{
+  $Log$
+  Revision 1.1  2000-10-14 10:14:50  peter
+    * moehrendorf oct 2000 rewrite
+
+}

compiler/ncnv.pas

@@ -61,7 +61,7 @@ interface
           function first_pchar_to_string : tnode;virtual;
           function first_ansistring_to_pchar : tnode;virtual;
           function first_arrayconstructor_to_set : tnode;virtual;
-          function call_helper(c : tconverttype) : tnode;
+          function first_call_helper(c : tconverttype) : tnode;
        end;
 
        tasnode = class(tbinarynode)
@@ -80,7 +80,7 @@ interface
        cisnode : class of tisnode;
 
     function gentypeconvnode(node : tnode;t : pdef) : ttypeconvnode;
-    procedure arrayconstructor_to_set(var p : tarrayconstructnode);
+    procedure arrayconstructor_to_set(var p : tarrayconstructornode);
 
 implementation
 
@@ -107,7 +107,7 @@ implementation
                     Array constructor to Set Conversion
 *****************************************************************************}
 
-    procedure arrayconstructor_to_set(var p : tarrayconstructnode);
+    procedure arrayconstructor_to_set(var p : tarrayconstructornode);
 
       var
         constp      : tsetconstnode;
@@ -174,24 +174,21 @@ implementation
         constsethi:=0;
         constp:=csetconstnode.create(nil,nil);
         constp.value_set:=constset;
+        buildp:=constp;
         if assigned(p.left) then
          begin
            while assigned(p) do
             begin
               p4:=nil; { will contain the tree to create the set }
-            { split a range into p2 and p3 }
-              if p.left.nodetype=arrayconstructrangen then
+            {split a range into p2 and p3 }
+              if p.left.nodetype=arrayconstructorrangen then
                begin
-                 p2:=tarrayconstructorrangenode(p.left).left;
-                 p3:=tarrayconstructorrangenode(p.left).right;
-                 tarrayconstructorrangenode(p.left).left:=nil;
-                 tarrayconstructorrangenode(p.left).right:=nil;
-               { node is not used anymore }
-                 p.left.free;
+                 p2:=tarrayconstructorrangenode(p.left).left.getcopy;
+                 p3:=tarrayconstructorrangenode(p.left).right.getcopy;
                end
               else
                begin
-                 p2:=p.left;
+                 p2:=p.left.getcopy;
                  p3:=nil;
                end;
               firstpass(p2);
@@ -217,7 +214,6 @@ implementation
                             firstpass(p3);
                           end;
                          }
-
                          if assigned(pd) and not(is_equal(pd,p3.resulttype)) then
                            begin
                               aktfilepos:=p3.fileinfo;
@@ -313,8 +309,8 @@ implementation
                buildp:=caddnode.create(addn,buildp,p4);
             { load next and dispose current node }
               p2:=p;
-              p:=tarrayconstructnode(p.right);
-              tarrayconstructnode(p2).right:=nil;
+              p:=tarrayconstructornode(tarrayconstructornode(p2).right);
+              tarrayconstructornode(p2).right:=nil;
               p2.free;
             end;
           if (pd=nil) then
@@ -331,7 +327,7 @@ implementation
       { set the initial set type }
         constp.resulttype:=new(psetdef,init(pd,constsethi));
       { set the new tree }
-        p:=tarrayconstructnode(buildp);
+        p:=tarrayconstructornode(buildp);
       end;
 
 
@@ -392,8 +388,6 @@ implementation
 
 
     function ttypeconvnode.first_string_to_string : tnode;
-      var
-        t : tnode;
       begin
          first_string_to_string:=nil;
          if pstringdef(resulttype)^.string_typ<>
@@ -689,27 +683,23 @@ implementation
         hp : tnode;
       begin
         first_arrayconstructor_to_set:=nil;
-        if left.nodetype<>arrayconstructn then
+        if left.nodetype<>arrayconstructorn then
          internalerror(5546);
       { remove typeconv node }
         hp:=left;
         left:=nil;
       { create a set constructor tree }
-        // !!!!!!!arrayconstructor_to_set(hp);
-        internalerror(2609001);
-        {$warning FIX ME !!!!!!!!}
+        arrayconstructor_to_set(tarrayconstructornode(hp));
       { now firstpass the set }
         firstpass(hp);
         first_arrayconstructor_to_set:=hp;
       end;
 
-    function ttypeconvnode.call_helper(c : tconverttype) : tnode;
+    function ttypeconvnode.first_call_helper(c : tconverttype) : tnode;
 
-      {$warning FIX ME !!!!!!!!!}
-      {
       const
          firstconvert : array[tconverttype] of pointer = (
-           @ttypeconvnode.first_nothing), {equal}
+           @ttypeconvnode.first_nothing, {equal}
            @ttypeconvnode.first_nothing, {not_possible}
            @ttypeconvnode.first_string_to_string,
            @ttypeconvnode.first_char_to_string,
@@ -735,7 +725,6 @@ implementation
            @ttypeconvnode.first_load_smallset,
            @ttypeconvnode.first_cord_to_pointer
          );
-       }
       type
          tprocedureofobject = function : tnode of object;
 
@@ -748,11 +737,9 @@ implementation
       begin
          { this is a little bit dirty but it works }
          { and should be quite portable too        }
-         // !!!! r.proc:=firstconvert[c];
-         {$warning FIX ME !!!!!}
-         internalerror(2609002);
+         r.proc:=firstconvert[c];
          r.obj:=self;
-         call_helper:=tprocedureofobject(r){$ifdef FPC}();{$endif FPC}
+         first_call_helper:=tprocedureofobject(r){$ifdef FPC}();{$endif FPC}
       end;
 
     function ttypeconvnode.pass_1 : tnode;
@@ -898,7 +885,7 @@ implementation
                   begin
                     if not proc_to_procvar_equal(aprocdef,pprocvardef(resulttype)) then
                      CGMessage2(type_e_incompatible_types,aprocdef^.typename,resulttype^.typename);
-                    pass_1:=call_helper(convtype);
+                    pass_1:=first_call_helper(convtype);
                   end
                  else
                   CGMessage2(type_e_incompatible_types,left.resulttype^.typename,resulttype^.typename);
@@ -918,7 +905,7 @@ implementation
                  is_boolean(left.resulttype) then
                begin
                   convtype:=tc_bool_2_int;
-                  pass_1:=call_helper(convtype);
+                  pass_1:=first_call_helper(convtype);
                   exit;
                end;
               { ansistring to pchar }
@@ -926,7 +913,7 @@ implementation
                  is_ansistring(left.resulttype) then
                begin
                  convtype:=tc_ansistring_2_pchar;
-                 pass_1:=call_helper(convtype);
+                 pass_1:=first_call_helper(convtype);
                  exit;
                end;
               { do common tc_equal cast }
@@ -1078,7 +1065,7 @@ implementation
              exit;
           end;
         if convtype<>tc_equal then
-          pass_1:=call_helper(convtype);
+          pass_1:=first_call_helper(convtype);
       end;
 
 
@@ -1173,7 +1160,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.6  2000-10-01 19:48:24  peter
+  Revision 1.7  2000-10-14 10:14:50  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.6  2000/10/01 19:48:24  peter
     * lot of compile updates for cg11
 
   Revision 1.5  2000/09/28 19:49:52  florian
@@ -1190,4 +1180,4 @@ end.
 
   Revision 1.1  2000/09/25 15:37:14  florian
     * more fixes
-}
+}

compiler/ncon.pas

@@ -511,15 +511,12 @@ implementation
          n.len:=len;
          n.value_str:=getpcharcopy;
          n.lab_str:=lab_str;
+         getcopy:=n;
       end;
 
     function tstringconstnode.pass_1 : tnode;
       begin
          pass_1:=nil;
-{        if cs_ansistrings in aktlocalswitches then
-          resulttype:=cansistringdef
-         else
-          resulttype:=cshortstringdef; }
         case stringtype of
           st_shortstring :
             resulttype:=cshortstringdef;
@@ -616,7 +613,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.7  2000-09-28 19:49:52  florian
+  Revision 1.8  2000-10-14 10:14:50  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.7  2000/09/28 19:49:52  florian
   *** empty log message ***
 
   Revision 1.6  2000/09/27 20:25:44  florian

compiler/nflw.pas

@@ -36,14 +36,9 @@ interface
           constructor create(tt : tnodetype;l,r,_t1,_t2 : tnode);virtual;
           destructor destroy;override;
           function getcopy : tnode;override;
-       end;
-
-       tlabelednode = class(tunarynode)
-          labelnr : pasmlabel;
-          exceptionblock : tnode;
-          labsym : plabelsym;
-          destructor destroy;override;
-          function getcopy : tnode;override;
+{$ifdef extdebug}
+          procedure dowrite;override;
+{$endif extdebug}
        end;
 
        twhilerepeatnode = class(tloopnode)
@@ -56,50 +51,72 @@ interface
        end;
 
        tfornode = class(tloopnode)
-          constructor create(l,r,_t1,_t2 : tnode;back : boolean);
+          constructor create(l,r,_t1,_t2 : tnode;back : boolean);virtual;
           function pass_1 : tnode;override;
        end;
 
        texitnode = class(tunarynode)
-          constructor create;virtual;
+          constructor create(l:tnode);virtual;
           function pass_1 : tnode;override;
        end;
 
-       tgotonode = class(tlabelednode)
+       tbreaknode = class(tnode)
           constructor create;virtual;
           function pass_1 : tnode;override;
        end;
 
-       tlabelnode = class(tlabelednode)
+       tcontinuenode = class(tnode)
           constructor create;virtual;
           function pass_1 : tnode;override;
        end;
 
+       tgotonode = class(tnode)
+          labelnr : pasmlabel;
+          labsym : plabelsym;
+          constructor create(p : pasmlabel);virtual;
+          function getcopy : tnode;override;
+          function pass_1 : tnode;override;
+       end;
+
+       tlabelnode = class(tunarynode)
+          labelnr : pasmlabel;
+          exceptionblock : tnode;
+          labsym : plabelsym;
+          constructor create(p : pasmlabel;l:tnode);virtual;
+          function getcopy : tnode;override;
+          function pass_1 : tnode;override;
+       end;
+
        traisenode = class(tbinarynode)
           frametree : tnode;
-          constructor create;virtual;
+          constructor create(l,taddr,tframe:tnode);virtual;
           function getcopy : tnode;override;
           function pass_1 : tnode;override;
        end;
 
        ttryexceptnode = class(tloopnode)
-          constructor create;virtual;
+          constructor create(l,r,_t1 : tnode);virtual;
           function pass_1 : tnode;override;
        end;
 
        ttryfinallynode = class(tbinarynode)
-          constructor create;virtual;
+          constructor create(l,r:tnode);virtual;
           function pass_1 : tnode;override;
        end;
 
        tonnode = class(tbinarynode)
           exceptsymtable : psymtable;
           excepttype : pobjectdef;
-          constructor create;virtual;
+          constructor create(l,r:tnode);virtual;
           function pass_1 : tnode;override;
           function getcopy : tnode;override;
        end;
 
+       tfailnode = class(tnode)
+          constructor create;virtual;
+          function pass_1: tnode;override;
+       end;
+
     { for compatibilty }
     function genloopnode(t : tnodetype;l,r,n1 : tnode;back : boolean) : tnode;
 
@@ -108,15 +125,15 @@ interface
        cifnode : class of tifnode;
        cfornode : class of tfornode;
        cexitnode : class of texitnode;
+       cbreaknode : class of tbreaknode;
+       ccontinuenode : class of tcontinuenode;
        cgotonode : class of tgotonode;
        clabelnode : class of tlabelnode;
        craisenode : class of traisenode;
        ctryexceptnode : class of ttryexceptnode;
        ctryfinallynode : class of ttryfinallynode;
        connode : class of tonnode;
-       { the block node of the current exception block to check gotos }
-       aktexceptblock : tnode;
-
+       cfailnode : class of tfailnode;
 
 implementation
 
@@ -124,7 +141,7 @@ implementation
       globtype,systems,
       cutils,cobjects,verbose,globals,
       symconst,types,htypechk,pass_1,
-      ncon,nmem,nld,ncnv
+      ncon,nmem,nld,ncnv,nbas
 {$ifdef newcg}
       ,tgobj
       ,tgcpu
@@ -176,8 +193,10 @@ implementation
     destructor tloopnode.destroy;
 
       begin
-         t1.free;
-         t2.free;
+         if assigned(t1) then
+          t1.free;
+         if assigned(t2) then
+          t2.free;
          inherited destroy;
       end;
 
@@ -188,31 +207,28 @@ implementation
 
       begin
          p:=tloopnode(inherited getcopy);
-         p.t1:=t1.getcopy;
-         p.t2:=t2.getcopy;
+         if assigned(t1) then
+           p.t1:=t1.getcopy
+         else
+           p.t1:=nil;
+         if assigned(t2) then
+           p.t2:=t2.getcopy
+         else
+           p.t2:=nil;
          getcopy:=p;
       end;
 
-{****************************************************************************
-                                 TTLABELDNODE
-*****************************************************************************}
-
-   destructor tlabelednode.destroy;
-
-     begin
-     end;
-
-   function tlabelednode.getcopy : tnode;
-
-     var
-        p : tlabelednode;
+{$ifdef extdebug}
+    procedure tloopnode.dowrite;
+      begin
+        inherited dowrite;
+        writenodeindention:=writenodeindention+'    ';
+        writenode(t1);
+        writenode(t2);
+        delete(writenodeindention,1,4);
+      end;
+{$endif extdebug}
 
-     begin
-        p:=tlabelednode(inherited getcopy);
-        p.labelnr:=labelnr;
-        p.exceptionblock:=exceptionblock;
-        p.labsym:=labsym;
-     end;
 
 {****************************************************************************
                                TWHILEREPEATNODE
@@ -372,10 +388,8 @@ implementation
               { optimize }
               if tordconstnode(left).value=1 then
                 begin
-                   left.free;
                    hp:=right;
                    right:=nil;
-                   t1.free;
                    { we cannot set p to nil !!! }
                    if assigned(hp) then
                      pass_1:=hp
@@ -384,10 +398,8 @@ implementation
                 end
               else
                 begin
-                   left.free;
                    hp:=t1;
                    t1:=nil;
-                   right.free;
                    { we cannot set p to nil !!! }
                    if assigned(hp) then
                      pass_1:=hp
@@ -418,7 +430,7 @@ implementation
          old_t_times : longint;
          hp : tnode;
       begin
-         pass_1:=nil;
+         result:=nil;
          { Calc register weight }
          old_t_times:=t_times;
          if not(cs_littlesize in aktglobalswitches) then
@@ -430,8 +442,7 @@ implementation
               exit;
            end;
          { save counter var }
-         { tbinarynode should be tassignnode! }
-         t2:=tbinarynode(left).left.getcopy;
+         t2:=tassignmentnode(left).left.getcopy;
 
 {$ifdef newcg}
          tg.cleartempgen;
@@ -543,9 +554,10 @@ implementation
                              TEXITNODE
 *****************************************************************************}
 
-    constructor texitnode.create;
+    constructor texitnode.create(l:tnode);
 
       begin
+        inherited create(exitn,l);
       end;
 
     function texitnode.pass_1 : tnode;
@@ -580,30 +592,82 @@ implementation
       end;
 
 
+{*****************************************************************************
+                             TBREAKNODE
+*****************************************************************************}
+
+    constructor tbreaknode.create;
+
+      begin
+        inherited create(breakn);
+      end;
+
+    function tbreaknode.pass_1 : tnode;
+      begin
+        result:=nil;
+      end;
+
+
+{*****************************************************************************
+                             TCONTINUENODE
+*****************************************************************************}
+
+    constructor tcontinuenode.create;
+
+      begin
+        inherited create(continuen);
+      end;
+
+    function tcontinuenode.pass_1 : tnode;
+      begin
+        result:=nil;
+      end;
+
+
 {*****************************************************************************
                              TGOTONODE
 *****************************************************************************}
 
-    constructor tgotonode.create;
+    constructor tgotonode.create(p : pasmlabel);
 
       begin
+        inherited create(goton);
+        labelnr:=p;
       end;
 
+
     function tgotonode.pass_1 : tnode;
       begin
          pass_1:=nil;
          resulttype:=voiddef;
       end;
 
+   function tgotonode.getcopy : tnode;
+
+     var
+        p : tgotonode;
+
+     begin
+        p:=tgotonode(inherited getcopy);
+        p.labelnr:=labelnr;
+        p.labsym:=labsym;
+        result:=p;
+     end;
+
 {*****************************************************************************
                              TLABELNODE
 *****************************************************************************}
 
-    constructor tlabelnode.create;
+    constructor tlabelnode.create(p : pasmlabel;l:tnode);
 
       begin
+        inherited create(labeln,l);
+        labelnr:=p;
+        exceptionblock:=nil;
+        labsym:=nil;
       end;
 
+
     function tlabelnode.pass_1 : tnode;
 
       begin
@@ -624,15 +688,28 @@ implementation
       end;
 
 
+   function tlabelnode.getcopy : tnode;
+
+     var
+        p : tlabelnode;
+
+     begin
+        p:=tlabelnode(inherited getcopy);
+        p.labelnr:=labelnr;
+        p.exceptionblock:=exceptionblock;
+        p.labsym:=labsym;
+        result:=p;
+     end;
+
 {*****************************************************************************
                             TRAISENODE
 *****************************************************************************}
 
-    constructor traisenode.create;
+    constructor traisenode.create(l,taddr,tframe:tnode);
 
       begin
-         inherited create(raisen,nil,nil);
-         frametree:=nil;
+         inherited create(raisen,l,taddr);
+         frametree:=tframe;
       end;
 
     function traisenode.getcopy : tnode;
@@ -642,7 +719,10 @@ implementation
 
       begin
          n:=traisenode(inherited getcopy);
-         n.frametree:=frametree;
+         if assigned(frametree) then
+           n.frametree:=frametree.getcopy
+         else
+           n.frametree:=nil;
          getcopy:=n;
       end;
 
@@ -689,9 +769,10 @@ implementation
                              TTRYEXCEPTNODE
 *****************************************************************************}
 
-    constructor ttryexceptnode.create;
+    constructor ttryexceptnode.create(l,r,_t1 : tnode);
 
       begin
+         inherited create(tryexceptn,l,r,_t1,nil);
       end;
 
     function ttryexceptnode.pass_1 : tnode;
@@ -748,9 +829,10 @@ implementation
                            TTRYFINALLYNODE
 *****************************************************************************}
 
-    constructor ttryfinallynode.create;
+    constructor ttryfinallynode.create(l,r:tnode);
 
       begin
+        inherited create(tryfinallyn,l,r);
       end;
 
     function ttryfinallynode.pass_1 : tnode;
@@ -791,10 +873,10 @@ implementation
                                 TONNODE
 *****************************************************************************}
 
-    constructor tonnode.create;
+    constructor tonnode.create(l,r:tnode);
 
       begin
-         inherited create(onn,nil,nil);
+         inherited create(onn,l,r);
          exceptsymtable:=nil;
          excepttype:=nil;
       end;
@@ -808,6 +890,7 @@ implementation
          n:=tonnode(inherited getcopy);
          n.exceptsymtable:=exceptsymtable;
          n.excepttype:=excepttype;
+         result:=n;
       end;
 
     function tonnode.pass_1 : tnode;
@@ -861,6 +944,23 @@ implementation
            end;
       end;
 
+{*****************************************************************************
+                                TONNODE
+*****************************************************************************}
+
+
+    constructor tfailnode.create;
+
+      begin
+         inherited create(failn);
+      end;
+
+    function tfailnode.pass_1 : tnode;
+
+      begin
+         pass_1:=nil;
+      end;
+
 begin
    cwhilerepeatnode:=twhilerepeatnode;
    cifnode:=tifnode;
@@ -872,10 +972,14 @@ begin
    ctryexceptnode:=ttryexceptnode;
    ctryfinallynode:=ttryfinallynode;
    connode:=tonnode;
+   cfailnode:=tfailnode;
 end.
 {
   $Log$
-  Revision 1.5  2000-10-01 19:48:24  peter
+  Revision 1.6  2000-10-14 10:14:50  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.5  2000/10/01 19:48:24  peter
     * lot of compile updates for cg11
 
   Revision 1.4  2000/09/28 19:49:52  florian
@@ -890,4 +994,4 @@ end.
   Revision 1.1  2000/09/22 22:46:03  florian
     + initial revision
 
-}
+}

compiler/ninl.pas

@@ -51,7 +51,7 @@ implementation
       globtype,
       symconst,symtable,aasm,types,
       pass_1,
-      ncal,ncon,ncnv,nadd,nld,
+      ncal,ncon,ncnv,nadd,nld,nbas,
       cpubase
 {$ifdef newcg}
       ,cgbase
@@ -92,6 +92,7 @@ implementation
       begin
          n:=tinlinenode(inherited getcopy);
          n.inlinenumber:=inlinenumber;
+         result:=n;
       end;
 
 {$ifdef fpc}
@@ -107,7 +108,7 @@ implementation
 {$endif ndef NOCOLONCHECK}
          extra_register,
          isreal,
-         dowrite,
+         iswrite,
          file_is_typed : boolean;
 
       function do_lowhigh(adef : pdef) : tnode;
@@ -163,6 +164,7 @@ implementation
         begin
            hp:=genrealconstnode(r,bestrealdef^);
            firstpass(hp);
+           pass_1:=hp;
         end;
 
       procedure handleextendedfunction;
@@ -186,6 +188,7 @@ implementation
         end;
 
       begin
+         result:=nil;
          { if we handle writeln; left contains no valid address }
          if assigned(left) then
            begin
@@ -391,7 +394,7 @@ implementation
             if hp=nil then
              hp:=tnode.create(errorn);
             firstpass(hp);
-            pass_1:=hp;
+            result:=hp;
           end
          else
           begin
@@ -439,7 +442,7 @@ implementation
                           in_hi_qword : hp:=genordinalconstnode(tordconstnode(left).value shr 32,left.resulttype);
                          end;
                          firstpass(hp);
-                         pass_1:=hp;
+                         result:=hp;
                        end;
                     end;
                end;
@@ -456,12 +459,15 @@ implementation
                        (parraydef(left.resulttype)^.elesize<>1) then
                       hp:=caddnode.create(muln,hp,genordinalconstnode(parraydef(left.resulttype)^.elesize,s32bitdef));
                     firstpass(hp);
+                    result:=hp;
+                  end
+                 else
+                  begin
+                    if registers32<1 then
+                       registers32:=1;
+                    resulttype:=s32bitdef;
+                    location.loc:=LOC_REGISTER;
                   end;
-                 if hp.registers32<1 then
-                    hp.registers32:=1;
-                 hp.resulttype:=s32bitdef;
-                 hp.location.loc:=LOC_REGISTER;
-                 pass_1:=hp;
                end;
 
              in_typeof_x:
@@ -480,7 +486,7 @@ implementation
                     begin
                        hp:=genordinalconstnode(tordconstnode(left).value,s32bitdef);
                        firstpass(hp);
-                       pass_1:=hp;
+                       result:=hp;
                     end
                   else
                     begin
@@ -497,7 +503,7 @@ implementation
                                   left:=nil;
                                   include(hp.flags,nf_explizit);
                                   firstpass(hp);
-                                  pass_1:=hp;
+                                  result:=hp;
                                end;
                             uwidechar:
                                begin
@@ -505,7 +511,7 @@ implementation
                                   left:=nil;
                                   include(hp.flags,nf_explizit);
                                   firstpass(hp);
-                                  pass_1:=hp;
+                                  result:=hp;
                                end;
                             bool8bit:
                                begin
@@ -514,7 +520,7 @@ implementation
                                   ttypeconvnode(hp).convtype:=tc_bool_2_int;
                                   include(hp.flags,nf_explizit);
                                   firstpass(hp);
-                                  pass_1:=hp;
+                                  result:=hp;
                                end
                            end
                          { can this happen ? }
@@ -525,7 +531,7 @@ implementation
                            begin
                               hp:=left;
                               left:=nil;
-                              pass_1:=hp;
+                              result:=hp;
                            end
                        else if (left.resulttype^.deftype=enumdef) then
                          begin
@@ -533,7 +539,7 @@ implementation
                             left:=nil;
                             include(hp.flags,nf_explizit);
                             firstpass(hp);
-                            pass_1:=hp;
+                            result:=hp;
                          end
                        else
                          begin
@@ -550,7 +556,7 @@ implementation
                   left:=nil;
                   include(hp.flags,nf_explizit);
                   firstpass(hp);
-                  pass_1:=hp;
+                  result:=hp;
                end;
 
              in_length_string:
@@ -580,14 +586,14 @@ implementation
                     begin
                        hp:=genordinalconstnode(tstringconstnode(left).len,s32bitdef);
                        firstpass(hp);
-                       pass_1:=hp;
+                       result:=hp;
                     end
                   { length of char is one allways }
                   else if is_constcharnode(left) then
                     begin
                        hp:=genordinalconstnode(1,s32bitdef);
                        firstpass(hp);
-                       pass_1:=hp;
+                       result:=hp;
                     end;
                end;
 
@@ -605,9 +611,17 @@ implementation
                   location.loc:=LOC_FLAGS;
                end;
 
-             in_ofs_x,
+             in_ofs_x :
+               internalerror(2000101001);
+
              in_seg_x :
-               set_varstate(left,false);
+               begin
+                 set_varstate(left,false);
+                 hp:=genordinalconstnode(0,s32bitdef);
+                 firstpass(hp);
+                 result:=hp;
+               end;
+
              in_pred_x,
              in_succ_x:
                begin
@@ -639,7 +653,7 @@ implementation
                            else
                              hp:=genordinalconstnode(tordconstnode(left).value-1,left.resulttype);
                            firstpass(hp);
-                           pass_1:=hp;
+                           result:=hp;
                          end;
                     end;
                end;
@@ -706,9 +720,9 @@ implementation
                   file_is_typed:=false;
                   if assigned(left) then
                     begin
-                       dowrite:=(inlinenumber in [in_write_x,in_writeln_x]);
+                       iswrite:=(inlinenumber in [in_write_x,in_writeln_x]);
                        tcallparanode(left).firstcallparan(nil,true);
-                       set_varstate(left,dowrite);
+                       set_varstate(left,iswrite);
                        { now we can check }
                        hp:=left;
                        while assigned(tcallparanode(hp).right) do
@@ -739,11 +753,11 @@ implementation
                                  if not is_equal(hpp.resulttype,pfiledef(hp.resulttype)^.typedfiletype.def) then
                                    CGMessage(type_e_mismatch);
                                  { generate the high() value for the shortstring }
-                                 if ((not dowrite) and is_shortstring(tcallparanode(hpp).left.resulttype)) or
+                                 if ((not iswrite) and is_shortstring(tcallparanode(hpp).left.resulttype)) or
                                     (is_chararray(tcallparanode(hpp).left.resulttype)) then
                                    tcallparanode(hpp).gen_high_tree(true);
                                  { read(ln) is call by reference (JM) }
-                                 if not dowrite then
+                                 if not iswrite then
                                    make_not_regable(tcallparanode(hpp).left);
                                  hpp:=tcallparanode(hpp).right;
                                end;
@@ -781,7 +795,7 @@ implementation
                                       stringdef :
                                         begin
                                           { generate the high() value for the shortstring }
-                                          if (not dowrite) and
+                                          if (not iswrite) and
                                              is_shortstring(tcallparanode(hp).left.resulttype) then
                                             tcallparanode(hp).gen_high_tree(true);
                                         end;
@@ -803,19 +817,19 @@ implementation
                                               ;
                                             u8bit,s8bit,
                                             u16bit,s16bit :
-                                              if dowrite then
+                                              if iswrite then
                                                 tcallparanode(hp).left:=gentypeconvnode(tcallparanode(hp).left,s32bitdef);
                                             bool8bit,
                                             bool16bit,
                                             bool32bit :
-                                              if dowrite then
+                                              if iswrite then
                                                 tcallparanode(hp).left:=gentypeconvnode(tcallparanode(hp).left,booldef)
                                               else
                                                 CGMessage(type_e_cant_read_write_type);
                                             else
                                               CGMessage(type_e_cant_read_write_type);
                                           end;
-                                          if not(dowrite) and
+                                          if not(iswrite) and
                                             not(is_64bitint(tcallparanode(hp).left.resulttype)) then
                                             extra_register:=true;
                                         end;
@@ -831,9 +845,9 @@ implementation
                                     end;
 
                                     { some format options ? }
-                                    if nf_is_colon_para in hp.flags then
+                                    if cpf_is_colon_para in tcallparanode(hp).callparaflags then
                                       begin
-                                         if nf_is_colon_para in tcallparanode(hp).right.flags then
+                                         if cpf_is_colon_para in tcallparanode(tcallparanode(hp).right).callparaflags then
                                            begin
                                               frac_para:=hp;
                                               length_para:=tcallparanode(hp).right;
@@ -900,7 +914,7 @@ implementation
                    genordinalconstnode(tcallparanode(left).left.resulttype^.size,s32bitdef),left);
                  left:=nil;
                  firstpass(hp);
-                 pass_1:=hp;
+                 result:=hp;
               end;
 
              { the firstpass of the arg has been done in firstcalln ? }
@@ -954,7 +968,7 @@ implementation
                   if not assigned(tcallparanode(hp).resulttype) then
                     exit;
                   { check and convert the first param }
-                  if (nf_is_colon_para in hp.flags) or
+                  if (cpf_is_colon_para in tcallparanode(hp).callparaflags) or
                      not assigned(hp.resulttype) then
                     CGMessage(cg_e_illegal_expression);
 
@@ -983,7 +997,7 @@ implementation
 
                   { some format options ? }
                   hpp:=tcallparanode(left).right;
-                  if assigned(hpp) and (nf_is_colon_para in hpp.flags) then
+                  if assigned(hpp) and (cpf_is_colon_para in tcallparanode(hpp).callparaflags) then
                     begin
                       firstpass(tcallparanode(hpp).left);
                       set_varstate(tcallparanode(hpp).left,true);
@@ -992,7 +1006,7 @@ implementation
                       else
                         tcallparanode(hpp).left:=gentypeconvnode(tcallparanode(hpp).left,s32bitdef);
                       hpp:=tcallparanode(hpp).right;
-                      if assigned(hpp) and (nf_is_colon_para in hpp.flags) then
+                      if assigned(hpp) and (cpf_is_colon_para in tcallparanode(hpp).callparaflags) then
                         begin
                           if isreal then
                            begin
@@ -1154,13 +1168,13 @@ implementation
                             begin
                                hp:=do_lowhigh(left.resulttype);
                                firstpass(hp);
-                               pass_1:=hp;
+                               result:=hp;
                             end;
                           setdef:
                             begin
                                hp:=do_lowhigh(Psetdef(left.resulttype)^.elementtype.def);
                                firstpass(hp);
-                               pass_1:=hp;
+                               result:=hp;
                             end;
                          arraydef:
                             begin
@@ -1169,7 +1183,7 @@ implementation
                                  hp:=genordinalconstnode(Parraydef(left.resulttype)^.lowrange,
                                    Parraydef(left.resulttype)^.rangetype.def);
                                  firstpass(hp);
-                                 pass_1:=hp;
+                                 result:=hp;
                                end
                               else
                                begin
@@ -1179,14 +1193,14 @@ implementation
                                     getsymonlyin(tloadnode(left).symtable,'high'+pvarsym(tloadnode(left).symtableentry)^.name);
                                     hp:=genloadnode(pvarsym(srsym),tloadnode(left).symtable);
                                     firstpass(hp);
-                                    pass_1:=hp;
+                                    result:=hp;
                                   end
                                  else
                                   begin
                                     hp:=genordinalconstnode(Parraydef(left.resulttype)^.highrange,
                                       Parraydef(left.resulttype)^.rangetype.def);
                                     firstpass(hp);
-                                    pass_1:=hp;
+                                    result:=hp;
                                   end;
                                end;
                            end;
@@ -1196,7 +1210,7 @@ implementation
                                begin
                                  hp:=genordinalconstnode(0,u8bitdef);
                                  firstpass(hp);
-                                 pass_1:=hp;
+                                 result:=hp;
                                end
                               else
                                begin
@@ -1205,13 +1219,13 @@ implementation
                                     getsymonlyin(tloadnode(left).symtable,'high'+pvarsym(tloadnode(left).symtableentry)^.name);
                                     hp:=genloadnode(pvarsym(srsym),tloadnode(left).symtable);
                                     firstpass(hp);
-                                    pass_1:=hp;
+                                    result:=hp;
                                   end
                                  else
                                   begin
                                     hp:=genordinalconstnode(Pstringdef(left.resulttype)^.len,u8bitdef);
                                     firstpass(hp);
-                                    pass_1:=hp;
+                                    result:=hp;
                                   end;
                                end;
                            end;
@@ -1342,7 +1356,7 @@ implementation
                    can remove it if assertions are off }
                  if not(cs_do_assertion in aktlocalswitches) then
                    { we need a valid node, so insert a nothingn }
-                   pass_1:=cnothingnode.create;
+                   result:=cnothingnode.create;
                end;
 
               else
@@ -1353,8 +1367,9 @@ implementation
            if not assigned(resulttype) then
              resulttype:=generrordef;
            { ... also if the node will be replaced }
-           if not assigned(pass_1.resulttype) then
-             pass_1.resulttype:=generrordef;
+           if assigned(result) and
+              (not assigned(result.resulttype)) then
+             result.resulttype:=generrordef;
          dec(parsing_para_level);
        end;
 {$ifdef fpc}
@@ -1366,7 +1381,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.6  2000-10-01 19:48:24  peter
+  Revision 1.7  2000-10-14 10:14:50  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.6  2000/10/01 19:48:24  peter
     * lot of compile updates for cg11
 
   Revision 1.5  2000/09/28 19:49:52  florian

compiler/nld.pas

@@ -50,11 +50,7 @@ interface
 
        tfuncretnode = class(tnode)
           funcretprocinfo : pointer;
-{$IFDEF NEWST}
-          retsym : Psym;
-{$ELSE}
           rettype : ttype;
-{$ENDIF}
           constructor create;virtual;
           function getcopy : tnode;override;
           function pass_1 : tnode;override;
@@ -65,10 +61,10 @@ interface
           function pass_1 : tnode;override;
        end;
 
-       tarrayconstructnode = class(tbinarynode)
-          constructdef : pdef;
+       tarrayconstructornode = class(tbinarynode)
+          constructordef : pdef;
           constructor create(l,r : tnode);virtual;
-          function getcopy : tnode;
+          function getcopy : tnode;override;
           function pass_1 : tnode;override;
        end;
 
@@ -85,7 +81,7 @@ interface
        cassignmentnode : class of tassignmentnode;
        cfuncretnode : class of tfuncretnode;
        carrayconstructorrangenode : class of tarrayconstructorrangenode;
-       carrayconstructnode : class of tarrayconstructnode;
+       carrayconstructornode : class of tarrayconstructornode;
        ctypenode : class of ttypenode;
 
     function genloadnode(v : pvarsym;st : psymtable) : tloadnode;
@@ -120,11 +116,7 @@ implementation
 
       begin
          n:=cloadnode.create(v,st);
-{$ifdef NEWST}
-         n.resulttype:=v^.definition;
-{$else NEWST}
          n.resulttype:=v^.vartype.def;
-{$endif NEWST}
          genloadnode:=n;
       end;
 
@@ -134,12 +126,7 @@ implementation
 
       begin
          n:=cloadnode.create(v,st);
-{$ifdef NEWST}
-         n.resulttype:=nil; {We don't know which overloaded procedure is
-                              wanted...}
-{$else NEWST}
          n.resulttype:=v^.definition;
-{$endif NEWST}
          genloadcallnode:=n;
       end;
 
@@ -149,12 +136,7 @@ implementation
 
       begin
          n:=cloadnode.create(v,st);
-{$ifdef NEWST}
-         n.resulttype:=nil; {We don't know which overloaded procedure is
-                              wanted...}
-{$else NEWST}
          n.resulttype:=v^.definition;
-{$endif NEWST}
          n.left:=mp;
          genloadmethodcallnode:=n;
       end;
@@ -167,11 +149,7 @@ implementation
 
       begin
          n:=cloadnode.create(sym,st);
-{$ifdef NEWST}
-         n.resulttype:=sym^.definition;
-{$else NEWST}
          n.resulttype:=sym^.typedconsttype.def;
-{$endif NEWST}
          gentypedconstloadnode:=n;
       end;
 
@@ -201,12 +179,14 @@ implementation
          n:=tloadnode(inherited getcopy);
          n.symtable:=symtable;
          n.symtableentry:=symtableentry;
+         result:=n;
       end;
 
     function tloadnode.pass_1 : tnode;
       var
          p1 : tnode;
       begin
+         result:=nil;
          if (symtable^.symtabletype=withsymtable) and
             (pwithsymtable(symtable)^.direct_with) and
             (symtableentry^.typ=varsym) then
@@ -215,7 +195,7 @@ implementation
               p1:=gensubscriptnode(pvarsym(symtableentry),p1);
               left:=nil;
               firstpass(p1);
-              pass_1:=p1;
+              result:=p1;
               exit;
            end;
 
@@ -256,7 +236,7 @@ implementation
                    p1.resulttype:=resulttype;
                  end;
                 left:=nil;
-                pass_1:=p1;
+                result:=p1;
               end;
             constsym:
               begin
@@ -388,6 +368,7 @@ implementation
         hp : tnode;
 {$endif newoptimizations2}
       begin
+         result:=nil;
          { must be made unique }
          if assigned(left) then
            begin
@@ -527,16 +508,13 @@ implementation
       begin
          n:=tfuncretnode(inherited getcopy);
          n.funcretprocinfo:=funcretprocinfo;
-{$ifdef NEWST}
-         n.retsym:=retsym;
-{$else NEWST}
          n.rettype:=rettype;
-{$endif NEWST}
          getcopy:=n;
       end;
 
     function tfuncretnode.pass_1 : tnode;
       begin
+         result:=nil;
          resulttype:=rettype.def;
          location.loc:=LOC_REFERENCE;
          if ret_in_param(rettype.def) or
@@ -546,17 +524,18 @@ implementation
 
 
 {*****************************************************************************
-                           TARRAYCONSTRUCTRANGENODE
+                           TARRAYCONSTRUCTORRANGENODE
 *****************************************************************************}
 
     constructor tarrayconstructorrangenode.create(l,r : tnode);
 
       begin
-         inherited create(arrayconstructn,l,r);
+         inherited create(arrayconstructorrangen,l,r);
       end;
 
     function tarrayconstructorrangenode.pass_1 : tnode;
       begin
+        result:=nil;
         firstpass(left);
         set_varstate(left,true);
         firstpass(right);
@@ -567,32 +546,33 @@ implementation
 
 
 {****************************************************************************
-                            TARRAYCONSTRUCTNODE
+                            TARRAYCONSTRUCTORNODE
 *****************************************************************************}
 
-    constructor tarrayconstructnode.create(l,r : tnode);
+    constructor tarrayconstructornode.create(l,r : tnode);
 
       begin
-         inherited create(arrayconstructn,l,r);
-         constructdef:=nil;
+         inherited create(arrayconstructorn,l,r);
+         constructordef:=nil;
       end;
 
-    function tarrayconstructnode.getcopy : tnode;
+    function tarrayconstructornode.getcopy : tnode;
 
       var
-         n : tarrayconstructnode;
+         n : tarrayconstructornode;
 
       begin
-         n:=tarrayconstructnode(inherited getcopy);
-         n.constructdef:=constructdef;
+         n:=tarrayconstructornode(inherited getcopy);
+         n.constructordef:=constructordef;
+         result:=n;
       end;
 
-    function tarrayconstructnode.pass_1 : tnode;
+    function tarrayconstructornode.pass_1 : tnode;
       var
         pd : pdef;
         thp,
         chp,
-        hp : tarrayconstructnode;
+        hp : tarrayconstructornode;
         len : longint;
         varia : boolean;
 
@@ -621,17 +601,18 @@ implementation
            t.location.loc:=LOC_MEM;
         end;
       begin
+        result:=nil;
       { are we allowing array constructor? Then convert it to a set }
         if not allow_array_constructor then
          begin
-           hp:=tarrayconstructnode(getcopy);
+           hp:=tarrayconstructornode(getcopy);
            arrayconstructor_to_set(hp);
            firstpass(hp);
            pass_1:=hp;
            exit;
          end;
       { only pass left tree, right tree contains next construct if any }
-        pd:=constructdef;
+        pd:=constructordef;
         len:=0;
         varia:=false;
         if assigned(left) then
@@ -701,7 +682,7 @@ implementation
                   end;
                end;
               inc(len);
-              hp:=tarrayconstructnode(hp.right);
+              hp:=tarrayconstructornode(hp.right);
             end;
          { swap the tree for cargs }
            if (nf_cargs in flags) and (not(nf_cargswap in flags)) then
@@ -709,10 +690,10 @@ implementation
               chp:=nil;
               { we need a copy here, because self is destroyed }
               { by firstpass later                             }
-              hp:=tarrayconstructnode(getcopy);
+              hp:=tarrayconstructornode(getcopy);
               while assigned(hp) do
                begin
-                 thp:=tarrayconstructnode(hp.right);
+                 thp:=tarrayconstructornode(hp.right);
                  hp.right:=chp;
                  chp:=hp;
                  hp:=thp;
@@ -750,6 +731,7 @@ implementation
          n:=ttypenode(inherited getcopy);
          n.typenodetype:=typenodetype;
          n.typenodesym:=typenodesym;
+         result:=n;
       end;
 
     function ttypenode.pass_1 : tnode;
@@ -764,12 +746,15 @@ begin
    cassignmentnode:=tassignmentnode;
    cfuncretnode:=tfuncretnode;
    carrayconstructorrangenode:=tarrayconstructorrangenode;
-   carrayconstructnode:=tarrayconstructnode;
+   carrayconstructornode:=tarrayconstructornode;
    ctypenode:=ttypenode;
 end.
 {
   $Log$
-  Revision 1.5  2000-10-01 19:48:24  peter
+  Revision 1.6  2000-10-14 10:14:50  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.5  2000/10/01 19:48:24  peter
     * lot of compile updates for cg11
 
   Revision 1.4  2000/09/28 19:49:52  florian

compiler/nmem.pas

@@ -30,8 +30,8 @@ interface
        node,symtable,cpubase;
 
     type
-       tloadvmtnode = class(tnode)
-          constructor create;virtual;
+       tloadvmtnode = class(tunarynode)
+          constructor create(l : tnode);virtual;
           function pass_1 : tnode;override;
        end;
 
@@ -73,7 +73,7 @@ interface
        tsubscriptnode = class(tunarynode)
           vs : pvarsym;
           constructor create(varsym : psym;l : tnode);virtual;
-          function getcopy : tnode;
+          function getcopy : tnode;override;
           function pass_1 : tnode;override;
        end;
 
@@ -98,7 +98,7 @@ interface
           withreference:preference;
 {$ENDIF NEWST}
           constructor create(symtable : pwithsymtable;l,r : tnode;count : longint);virtual;
-          function getcopy : tnode;
+          function getcopy : tnode;override;
           function pass_1 : tnode;override;
        end;
 
@@ -140,9 +140,6 @@ implementation
 
     function genselfnode(_class : pdef) : tselfnode;
 
-      var
-         p : tnode;
-
       begin
          genselfnode:=cselfnode.create(_class);
       end;
@@ -188,10 +185,10 @@ implementation
                             TLOADVMTNODE
 *****************************************************************************}
 
-    constructor tloadvmtnode.create;
+    constructor tloadvmtnode.create(l : tnode);
 
       begin
-         inherited create(loadvmtn);
+         inherited create(loadvmtn,l);
       end;
 
     function tloadvmtnode.pass_1 : tnode;
@@ -842,6 +839,7 @@ implementation
          p.withsymtable:=withsymtable;
          p.tablecount:=tablecount;
          p.withreference:=withreference;
+         result:=p;
       end;
 
     function twithnode.pass_1 : tnode;
@@ -884,7 +882,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.5  2000-10-01 19:48:24  peter
+  Revision 1.6  2000-10-14 10:14:51  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.5  2000/10/01 19:48:24  peter
     * lot of compile updates for cg11
 
   Revision 1.4  2000/09/28 19:49:52  florian

compiler/node.inc

@@ -49,6 +49,15 @@
       begin
       end;
 
+    procedure tnode.toggleflag(f : tnodeflags);
+
+      begin
+         if f in flags then
+           exclude(flags,f)
+         else
+           include(flags,f);
+      end;
+
     destructor tnode.destroy;
 
       begin
@@ -65,6 +74,8 @@
     function tnode.pass_1 : tnode;
 
       begin
+         pass_1:=nil;
+
          if not(assigned(resulttype)) then
            det_resulttype;
 
@@ -84,10 +95,15 @@
       begin
          ischild:=false;
       end;
+
 {$ifdef EXTDEBUG}
     procedure tnode.dowrite;
+      begin
+        dowritenodetype;
+      end;
 
-      const treetype2str : array[tnodetype] of string[20] = (
+    procedure tnode.dowritenodetype;
+      const nodetype2str : array[tnodetype] of string[20] = (
           'addn',
           'muln',
           'subn',
@@ -123,6 +139,7 @@
           'umminusn',
           'asmn',
           'vecn',
+          'pointerconstn',
           'stringconstn',
           'funcretn',
           'selfn',
@@ -166,11 +183,10 @@
           'arrayconstructn',
           'arrayconstructrangen',
           'nothingn',
-          'loadvmtn',
-          'pointerconstn');
+          'loadvmtn');
 
       begin
-         write(indention,'(',treetype2str[nodetype]);
+         write(writenodeindention,'(',nodetype2str[nodetype]);
       end;
 {$endif EXTDEBUG}
 
@@ -188,15 +204,21 @@
          docompare:=true;
       end;
 
+
     function tnode.getcopy : tnode;
 
       var
          p : tnode;
 
       begin
+         if not(assigned(self)) then
+           begin
+              getcopy:=nil;
+              exit;
+           end;
          { this is quite tricky because we need a node of the current }
          { node type and not one of tnode!                            }
-         p:=tnode(classtype).createforcopy;
+         p:=tnodeclass(classtype).createforcopy;
          p.nodetype:=nodetype;
          p.location:=location;
          p.parent:=parent;
@@ -256,7 +278,10 @@
 
       begin
          p:=tunarynode(inherited getcopy);
-         p.left:=left.getcopy;
+         if assigned(left) then
+           p.left:=left.getcopy
+         else
+           p.left:=nil;
          getcopy:=p;
       end;
 
@@ -266,9 +291,10 @@
       begin
          inherited dowrite;
          writeln(',');
+         writenodeindention:=writenodeindention+'    ';
          writenode(left);
-         writeln(')');
-         dec(byte(indention[0]),2);
+         write(')');
+         delete(writenodeindention,1,4);
       end;
 {$endif}
 
@@ -365,7 +391,10 @@
 
       begin
          p:=tbinarynode(inherited getcopy);
-         p.right:=right.getcopy;
+         if assigned(right) then
+           p.right:=right.getcopy
+         else
+           p.right:=nil;
          getcopy:=p;
       end;
 
@@ -409,6 +438,19 @@
          end;
       end;
 
+{$ifdef extdebug}
+    procedure tbinarynode.dowrite;
+
+      begin
+         inherited dowrite;
+         writeln(',');
+         writenodeindention:=writenodeindention+'    ';
+         writenode(right);
+         write(')');
+         delete(writenodeindention,1,4);
+      end;
+{$endif}
+
 {****************************************************************************
                             TBINOPYNODE
  ****************************************************************************}
@@ -427,9 +469,30 @@
             left.isequal(tbinopnode(p).right) and
             right.isequal(tbinopnode(p).left));
       end;
+
+
+{****************************************************************************
+                                 WRITENODE
+ ****************************************************************************}
+
+{$ifdef EXTDEBUG}
+     procedure writenode(t:tnode);
+     begin
+       if assigned(t) then
+        t.dowrite
+       else
+        write(writenodeindention,'nil');
+       if writenodeindention='' then
+        writeln;
+     end;
+{$endif EXTDEBUG}
+
 {
   $Log$
-  Revision 1.8  2000-10-01 19:48:24  peter
+  Revision 1.9  2000-10-14 10:14:51  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.8  2000/10/01 19:48:24  peter
     * lot of compile updates for cg11
 
   Revision 1.7  2000/09/29 15:45:23  florian

compiler/nodeh.inc

@@ -102,8 +102,8 @@
           failn,           {Represents the fail statement.}
           starstarn,       {Represents the ** operator exponentiation }
           procinlinen,     {Procedures that can be inlined }
-          arrayconstructn, {Construction node for [...] parsing}
-          arrayconstructrangen, {Range element to allow sets in array construction tree}
+          arrayconstructorn, {Construction node for [...] parsing}
+          arrayconstructorrangen, {Range element to allow sets in array construction tree}
           { added for optimizations where we cannot suppress }
           nothingn,
           loadvmtn
@@ -122,12 +122,6 @@
          nf_return_value_used,
          nf_static_call,
 
-         { flags used by tcallparanode }
-         nf_exact_match_found,
-         nf_convlevel1found,
-         nf_convlevel2found,
-         nf_is_colon_para,
-
          { flags used by loop nodes }
          nf_backward,  { set if it is a for ... downto ... do loop }
          nf_varstate,  { do we need to parse childs to set var state }
@@ -144,14 +138,14 @@
          nf_islocal,
 
          { tloadnode }
-         nf_absolute,   { 20th }
+         nf_absolute,
          nf_first,
 
          { tassignmentnode }
          nf_concat_string,
 
          { tfuncretnode }
-         nf_is_first_funcret,
+         nf_is_first_funcret, { 20th }
 
          { tarrayconstructnode }
          nf_cargs,
@@ -166,8 +160,14 @@
          nf_inlineconst,
 
          { general }
-         nf_isproperty,  { 30th }
-         nf_varstateset
+         nf_isproperty,
+         nf_varstateset,
+
+         { tasmnode }
+         nf_object_preserved,
+
+         { taddnode }
+         nf_use_strconcat
        );
 
        tnodeflagset = set of tnodeflags;
@@ -197,6 +197,7 @@
           fileinfo : tfileposinfo;
           localswitches : tlocalswitches;
 {$ifdef extdebug}
+          maxfirstpasscount,
           firstpasscount : longint;
 {$endif extdebug}
           list : paasmoutput;
@@ -204,7 +205,10 @@
           { this constructor is only for creating copies of class }
           { the fields are copied by getcopy                      }
           constructor createforcopy;
-          destructor destroy;virtual;
+          destructor destroy;override;
+
+          { toggles the flag }
+          procedure toggleflag(f : tnodeflags);
 
           { the 1.1 code generator may override pass_1 }
           { and it need not to implement det_* then    }
@@ -231,6 +235,7 @@
           { direct, because there is no test for nil, use writenode  }
           { to write a complete tree                                 }
           procedure dowrite;virtual;
+          procedure dowritenodetype;virtual;
 {$endif EXTDEBUG}
           procedure concattolist(l : plinkedlist);virtual;
           function ischild(p : tnode) : boolean;virtual;
@@ -242,15 +247,16 @@
        { one child, you have to use it if you want to use         }
        { true- and falselabel                                     }
        tparentnode = class(tnode)
+{$ifdef newcg}
           falselabel,truelabel : pasmlabel;
+{$endif newcg}
        end;
 
+       tnodeclass = class of tnode;
+
        punarynode = ^tunarynode;
        tunarynode = class(tparentnode)
           left : tnode;
-{$ifdef extdebug}
-          procedure dowrite;override;
-{$endif extdebug}
           constructor create(tt : tnodetype;l : tnode);
           procedure concattolist(l : plinkedlist);override;
           function ischild(p : tnode) : boolean;override;
@@ -259,6 +265,9 @@
           function docompare(p : tnode) : boolean;override;
           function getcopy : tnode;override;
           procedure left_max;
+{$ifdef extdebug}
+          procedure dowrite;override;
+{$endif extdebug}
        end;
 
        pbinarynode = ^tbinarynode;
@@ -273,6 +282,9 @@
           procedure swapleftright;
           function getcopy : tnode;override;
           procedure left_right_max;
+{$ifdef extdebug}
+          procedure dowrite;override;
+{$endif extdebug}
        end;
 
        pbinopnode = ^tbinopnode;
@@ -281,9 +293,19 @@
           function docompare(p : tnode) : boolean;override;
        end;
 
+{$ifdef EXTDEBUG}
+     var
+       writenodeindention : string;
+
+     procedure writenode(t:tnode);
+{$endif EXTDEBUG}
+
 {
   $Log$
-  Revision 1.11  2000-10-01 19:48:24  peter
+  Revision 1.12  2000-10-14 10:14:51  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.11  2000/10/01 19:48:24  peter
     * lot of compile updates for cg11
 
   Revision 1.10  2000/09/28 19:49:52  florian

compiler/nset.pas

@@ -210,7 +210,7 @@ implementation
          { Convert array constructor first to set }
          if is_array_constructor(right.resulttype) then
           begin
-            arrayconstructor_to_set(tarrayconstructnode(right));
+            arrayconstructor_to_set(tarrayconstructornode(right));
             firstpass(right);
             if codegenerror then
              exit;
@@ -503,7 +503,10 @@ implementation
 
       begin
          p:=tcasenode(inherited getcopy);
-         p.elseblock:=elseblock.getcopy;
+         if assigned(elseblock) then
+           p.elseblock:=elseblock.getcopy
+         else
+           p.elseblock:=nil;
          p.nodes:=copycaserecord(nodes);
          getcopy:=p;
       end;
@@ -516,7 +519,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.4  2000-10-01 19:48:25  peter
+  Revision 1.5  2000-10-14 10:14:51  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.4  2000/10/01 19:48:25  peter
     * lot of compile updates for cg11
 
   Revision 1.3  2000/09/27 18:14:31  florian

compiler/cg386add.pas → compiler/old/cg386add.pas

@@ -2374,7 +2374,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.8  2000-09-24 21:19:48  peter
+  Revision 1.1  2000-10-14 10:14:56  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.8  2000/09/24 21:19:48  peter
     * delphi compile fixes
 
   Revision 1.7  2000/09/21 12:23:49  jonas

compiler/cg386cal.pas → compiler/old/cg386cal.pas

@@ -1594,7 +1594,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.11  2000-09-24 21:19:48  peter
+  Revision 1.1  2000-10-14 10:14:56  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.11  2000/09/24 21:19:48  peter
     * delphi compile fixes
 
   Revision 1.10  2000/09/19 23:09:07  pierre

compiler/cg386cnv.pas → compiler/old/cg386cnv.pas

@@ -1568,7 +1568,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.7  2000-09-24 21:19:49  peter
+  Revision 1.1  2000-10-14 10:14:56  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.7  2000/09/24 21:19:49  peter
     * delphi compile fixes
 
   Revision 1.6  2000/08/29 18:31:32  peter

compiler/cg386con.pas → compiler/old/cg386con.pas

@@ -461,7 +461,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.4  2000-09-24 21:19:49  peter
+  Revision 1.1  2000-10-14 10:14:56  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.4  2000/09/24 21:19:49  peter
     * delphi compile fixes
 
   Revision 1.3  2000/08/16 13:06:06  florian

compiler/cg386flw.pas → compiler/old/cg386flw.pas

@@ -1237,7 +1237,10 @@ do_jmp:
 end.
 {
   $Log$
-  Revision 1.6  2000-09-24 21:19:49  peter
+  Revision 1.1  2000-10-14 10:14:56  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.6  2000/09/24 21:19:49  peter
     * delphi compile fixes
 
   Revision 1.5  2000/08/29 18:41:02  peter

compiler/cg386inl.pas → compiler/old/cg386inl.pas

@@ -1540,7 +1540,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.9  2000-09-24 21:19:49  peter
+  Revision 1.1  2000-10-14 10:14:56  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.9  2000/09/24 21:19:49  peter
     * delphi compile fixes
 
   Revision 1.8  2000/09/24 15:06:11  peter

compiler/cg386ld.pas → compiler/old/cg386ld.pas

@@ -1048,7 +1048,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.7  2000-09-30 16:08:45  peter
+  Revision 1.1  2000-10-14 10:14:57  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.7  2000/09/30 16:08:45  peter
     * more cg11 updates
 
   Revision 1.6  2000/09/24 21:19:49  peter

compiler/cg386mat.pas → compiler/old/cg386mat.pas

@@ -991,7 +991,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.7  2000-09-24 21:19:49  peter
+  Revision 1.1  2000-10-14 10:14:57  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.7  2000/09/24 21:19:49  peter
     * delphi compile fixes
 
   Revision 1.6  2000/09/18 10:15:48  jonas

compiler/cg386mem.pas → compiler/old/cg386mem.pas

@@ -966,7 +966,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.7  2000-09-24 21:19:49  peter
+  Revision 1.1  2000-10-14 10:14:57  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.7  2000/09/24 21:19:49  peter
     * delphi compile fixes
 
   Revision 1.6  2000/08/27 16:11:49  peter

compiler/cg386set.pas → compiler/old/cg386set.pas

@@ -1059,7 +1059,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.7  2000-09-24 21:19:49  peter
+  Revision 1.1  2000-10-14 10:14:57  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.7  2000/09/24 21:19:49  peter
     * delphi compile fixes
 
   Revision 1.6  2000/08/12 06:47:56  florian

compiler/cg68kadd.pas → compiler/old/cg68kadd.pas

@@ -1284,7 +1284,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.2  2000-07-13 11:32:36  michael
+  Revision 1.1  2000-10-14 10:14:57  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.2  2000/07/13 11:32:36  michael
   + removed logs
 
 }

compiler/cg68kcal.pas → compiler/old/cg68kcal.pas

@@ -1070,7 +1070,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.2  2000-07-13 11:32:36  michael
+  Revision 1.1  2000-10-14 10:14:57  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.2  2000/07/13 11:32:36  michael
   + removed logs
 
 }

compiler/cg68kcnv.pas → compiler/old/cg68kcnv.pas

@@ -1359,7 +1359,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.2  2000-07-13 11:32:36  michael
+  Revision 1.1  2000-10-14 10:14:57  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.2  2000/07/13 11:32:36  michael
   + removed logs
 
 }

compiler/cg68kcon.pas → compiler/old/cg68kcon.pas

@@ -372,7 +372,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.2  2000-07-13 11:32:36  michael
+  Revision 1.1  2000-10-14 10:14:57  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.2  2000/07/13 11:32:36  michael
   + removed logs
 
 }

compiler/cg68kflw.pas → compiler/old/cg68kflw.pas

@@ -773,7 +773,10 @@ do_jmp:
 end.
 {
   $Log$
-  Revision 1.2  2000-07-13 11:32:36  michael
+  Revision 1.1  2000-10-14 10:14:57  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.2  2000/07/13 11:32:36  michael
   + removed logs
 
 }

compiler/cg68kinl.pas → compiler/old/cg68kinl.pas

@@ -900,7 +900,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.2  2000-07-13 11:32:36  michael
+  Revision 1.1  2000-10-14 10:14:57  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.2  2000/07/13 11:32:36  michael
   + removed logs
 
 }

compiler/cg68kld.pas → compiler/old/cg68kld.pas

@@ -471,7 +471,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.2  2000-07-13 11:32:37  michael
+  Revision 1.1  2000-10-14 10:14:57  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.2  2000/07/13 11:32:37  michael
   + removed logs
 
 }

compiler/cg68kmat.pas → compiler/old/cg68kmat.pas

@@ -449,7 +449,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.2  2000-07-13 11:32:37  michael
+  Revision 1.1  2000-10-14 10:14:57  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.2  2000/07/13 11:32:37  michael
   + removed logs
 
 }

compiler/cg68kmem.pas → compiler/old/cg68kmem.pas

@@ -725,7 +725,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.2  2000-07-13 11:32:37  michael
+  Revision 1.1  2000-10-14 10:14:57  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.2  2000/07/13 11:32:37  michael
   + removed logs
 
 }

compiler/cg68kset.pas → compiler/old/cg68kset.pas

@@ -813,7 +813,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.2  2000-07-13 11:32:37  michael
+  Revision 1.1  2000-10-14 10:14:57  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.2  2000/07/13 11:32:37  michael
   + removed logs
 
 }

compiler/tcadd.pas → compiler/old/tcadd.pas

@@ -1298,7 +1298,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.11  2000-09-24 21:19:52  peter
+  Revision 1.1  2000-10-14 10:14:57  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.11  2000/09/24 21:19:52  peter
     * delphi compile fixes
 
   Revision 1.10  2000/09/21 12:22:17  jonas

compiler/tccal.pas → compiler/old/tccal.pas

@@ -1331,7 +1331,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.10  2000-09-24 21:19:52  peter
+  Revision 1.1  2000-10-14 10:14:58  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.10  2000/09/24 21:19:52  peter
     * delphi compile fixes
 
   Revision 1.9  2000/08/27 16:11:54  peter

compiler/tccnv.pas → compiler/old/tccnv.pas

@@ -1042,7 +1042,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.9  2000-09-24 21:19:52  peter
+  Revision 1.1  2000-10-14 10:14:58  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.9  2000/09/24 21:19:52  peter
     * delphi compile fixes
 
   Revision 1.8  2000/09/24 15:06:31  peter

compiler/tccon.pas → compiler/old/tccon.pas

@@ -139,7 +139,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.3  2000-09-24 21:19:53  peter
+  Revision 1.1  2000-10-14 10:14:58  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.3  2000/09/24 21:19:53  peter
     * delphi compile fixes
 
   Revision 1.2  2000/07/13 11:32:51  michael

compiler/tcflw.pas → compiler/old/tcflw.pas

@@ -640,7 +640,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.9  2000-09-24 21:19:53  peter
+  Revision 1.1  2000-10-14 10:14:58  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.9  2000/09/24 21:19:53  peter
     * delphi compile fixes
 
   Revision 1.8  2000/09/10 21:19:40  peter

compiler/tcinl.pas → compiler/old/tcinl.pas

@@ -1367,7 +1367,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.8  2000-10-05 14:42:31  jonas
+  Revision 1.1  2000-10-14 10:14:58  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.8  2000/10/05 14:42:31  jonas
     * fixed inc/dec with a 64bit type (merged from fixes branch)
 
   Revision 1.7  2000/09/24 21:19:53  peter

compiler/tcld.pas → compiler/old/tcld.pas

@@ -518,7 +518,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.8  2000-09-24 21:19:53  peter
+  Revision 1.1  2000-10-14 10:14:58  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.8  2000/09/24 21:19:53  peter
     * delphi compile fixes
 
   Revision 1.7  2000/08/27 16:11:55  peter

compiler/tcmat.pas → compiler/old/tcmat.pas

@@ -486,7 +486,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.5  2000-09-24 21:19:53  peter
+  Revision 1.1  2000-10-14 10:14:58  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.5  2000/09/24 21:19:53  peter
     * delphi compile fixes
 
   Revision 1.4  2000/08/17 12:03:48  florian

compiler/tcmem.pas → compiler/old/tcmem.pas

@@ -646,7 +646,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.8  2000-09-24 21:19:53  peter
+  Revision 1.1  2000-10-14 10:14:58  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.8  2000/09/24 21:19:53  peter
     * delphi compile fixes
 
   Revision 1.7  2000/08/27 16:11:55  peter

compiler/tcset.pas → compiler/old/tcset.pas

@@ -329,7 +329,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.4  2000-09-24 21:19:53  peter
+  Revision 1.1  2000-10-14 10:14:58  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.4  2000/09/24 21:19:53  peter
     * delphi compile fixes
 
   Revision 1.3  2000/08/12 06:46:26  florian

compiler/tree.pas → compiler/old/tree.pas

@@ -1981,7 +1981,10 @@ unit tree;
 end.
 {
   $Log$
-  Revision 1.11  2000-10-01 19:48:25  peter
+  Revision 1.1  2000-10-14 10:14:58  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.11  2000/10/01 19:48:25  peter
     * lot of compile updates for cg11
 
   Revision 1.10  2000/09/27 18:14:31  florian

compiler/parser.pas

@@ -54,9 +54,9 @@ implementation
       cgbase,
 {$endif newcg}
 {$ifdef GDB}
-       gdb,
+      gdb,
 {$endif GDB}
-      comphook,tree,scanner,pbase,ptype,psystem,pmodules,cresstr;
+      comphook,scanner,pbase,ptype,psystem,pmodules,cresstr;
 
 
     procedure initparser;
@@ -594,7 +594,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.6  2000-10-01 19:48:25  peter
+  Revision 1.7  2000-10-14 10:14:51  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.6  2000/10/01 19:48:25  peter
     * lot of compile updates for cg11
 
   Revision 1.5  2000/09/24 15:06:20  peter
@@ -610,4 +613,4 @@ end.
   Revision 1.2  2000/07/13 11:32:44  michael
   + removed logs
 
-}
+}

compiler/pass_1.pas

@@ -1,9 +1,8 @@
-{$ifndef cg11}
 {
     $Id$
     Copyright (c) 1998-2000 by Florian Klaempfl
 
-    This unit implements the first pass of the code generator
+    This unit handles the typecheck and node conversion pass
 
     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
@@ -25,359 +24,6 @@ unit pass_1;
 
 {$i defines.inc}
 
-interface
-
-    uses
-       tree;
-
-    procedure firstpass(var p : ptree);
-    function  do_firstpass(var p : ptree) : boolean;
-
-
-implementation
-
-    uses
-      globtype,systems,
-      cutils,cobjects,verbose,globals,
-      aasm,symtable,types,
-      htypechk,
-      tcadd,tccal,tccnv,tccon,tcflw,
-      tcinl,tcld,tcmat,tcmem,tcset,cpubase,cpuasm
-{$ifdef newcg}
-      ,cgbase
-      ,tgcpu
-{$else newcg}
-      ,hcodegen
-{$ifdef i386}
-      ,tgeni386
-{$endif}
-{$ifdef m68k}
-      ,tgen68k
-{$endif}
-{$endif}
-      ;
-
-{*****************************************************************************
-                              FirstPass
-*****************************************************************************}
-
-    type
-       firstpassproc = procedure(var p : ptree);
-
-    procedure firstnothing(var p : ptree);
-      begin
-         p^.resulttype:=voiddef;
-      end;
-
-
-    procedure firsterror(var p : ptree);
-      begin
-         p^.error:=true;
-         codegenerror:=true;
-         p^.resulttype:=generrordef;
-      end;
-
-
-    procedure firststatement(var p : ptree);
-      begin
-         { left is the next statement in the list }
-         p^.resulttype:=voiddef;
-         { no temps over several statements }
-{$ifdef newcg}
-         tg.cleartempgen;
-{$else newcg}
-         cleartempgen;
-{$endif newcg}
-         { right is the statement itself calln assignn or a complex one }
-         {must_be_valid:=true; obsolete PM }
-         firstpass(p^.right);
-         if (not (cs_extsyntax in aktmoduleswitches)) and
-            assigned(p^.right^.resulttype) and
-            (p^.right^.resulttype<>pdef(voiddef)) then
-           CGMessage(cg_e_illegal_expression);
-         if codegenerror then
-           exit;
-         p^.registers32:=p^.right^.registers32;
-         p^.registersfpu:=p^.right^.registersfpu;
-{$ifdef SUPPORT_MMX}
-         p^.registersmmx:=p^.right^.registersmmx;
-{$endif SUPPORT_MMX}
-         { left is the next in the list }
-         firstpass(p^.left);
-         if codegenerror then
-           exit;
-         if p^.right^.registers32>p^.registers32 then
-           p^.registers32:=p^.right^.registers32;
-         if p^.right^.registersfpu>p^.registersfpu then
-           p^.registersfpu:=p^.right^.registersfpu;
-{$ifdef SUPPORT_MMX}
-         if p^.right^.registersmmx>p^.registersmmx then
-           p^.registersmmx:=p^.right^.registersmmx;
-{$endif}
-      end;
-
-
-    procedure firstblock(var p : ptree);
-      var
-         hp : ptree;
-         count : longint;
-      begin
-         count:=0;
-         hp:=p^.left;
-         while assigned(hp) do
-           begin
-              if cs_regalloc in aktglobalswitches then
-                begin
-                   { Codeumstellungen }
-
-                   { Funktionsresultate an exit anh„ngen }
-                   { this is wrong for string or other complex
-                     result types !!! }
-                   if ret_in_acc(procinfo^.returntype.def) and
-                      assigned(hp^.left) and
-                      assigned(hp^.left^.right) and
-                      (hp^.left^.right^.treetype=exitn) and
-                      (hp^.right^.treetype=assignn) and
-                      (hp^.right^.left^.treetype=funcretn) then
-                      begin
-                         if assigned(hp^.left^.right^.left) then
-                           CGMessage(cg_n_inefficient_code)
-                         else
-                           begin
-                              hp^.left^.right^.left:=hp^.right^.right;
-                              hp^.right^.right:=nil;
-                              disposetree(hp^.right);
-                              hp^.right:=nil;
-                           end;
-                      end
-                   { warning if unreachable code occurs and elimate this }
-                   else if (hp^.right^.treetype in
-                     [exitn,breakn,continuen,goton]) and
-                     { statement node (JM) }
-                     assigned(hp^.left) and
-                     { kind of statement! (JM) }
-                     assigned(hp^.left^.right) and
-                     (hp^.left^.right^.treetype<>labeln) then
-                     begin
-                        { use correct line number }
-                        aktfilepos:=hp^.left^.fileinfo;
-                        disposetree(hp^.left);
-                        hp^.left:=nil;
-                        CGMessage(cg_w_unreachable_code);
-                        { old lines }
-                        aktfilepos:=hp^.right^.fileinfo;
-                     end;
-                end;
-              if assigned(hp^.right) then
-                begin
-{$ifdef newcg}
-                   tg.cleartempgen;
-{$else newcg}
-                   cleartempgen;
-{$endif newcg}
-                   codegenerror:=false;
-                   firstpass(hp^.right);
-                   if (not (cs_extsyntax in aktmoduleswitches)) and
-                      assigned(hp^.right^.resulttype) and
-                      (hp^.right^.resulttype<>pdef(voiddef)) then
-                     CGMessage(cg_e_illegal_expression);
-                   {if codegenerror then
-                     exit;}
-                   hp^.registers32:=hp^.right^.registers32;
-                   hp^.registersfpu:=hp^.right^.registersfpu;
-{$ifdef SUPPORT_MMX}
-                   hp^.registersmmx:=hp^.right^.registersmmx;
-{$endif SUPPORT_MMX}
-                end
-              else
-                hp^.registers32:=0;
-
-              if hp^.registers32>p^.registers32 then
-                p^.registers32:=hp^.registers32;
-              if hp^.registersfpu>p^.registersfpu then
-                p^.registersfpu:=hp^.registersfpu;
-{$ifdef SUPPORT_MMX}
-              if hp^.registersmmx>p^.registersmmx then
-                p^.registersmmx:=hp^.registersmmx;
-{$endif}
-              inc(count);
-              hp:=hp^.left;
-           end;
-      end;
-
-
-
-    procedure firstasm(var p : ptree);
-      begin
-        procinfo^.flags:=procinfo^.flags or pi_uses_asm;
-      end;
-
-
-
-    procedure firstpass(var p : ptree);
-      const
-         procedures : array[ttreetyp] of firstpassproc =
-            (firstadd,   {addn}
-             firstadd,   {muln}
-             firstadd,   {subn}
-             firstmoddiv,      {divn}
-             firstadd,   {symdifn}
-             firstmoddiv,      {modn}
-             firstassignment,  {assignn}
-             firstload, {loadn}
-             firstrange,       {range}
-             firstadd,   {ltn}
-             firstadd,   {lten}
-             firstadd,   {gtn}
-             firstadd,   {gten}
-             firstadd,   {equaln}
-             firstadd,   {unequaln}
-             firstin,     {inn}
-             firstadd,   {orn}
-             firstadd,   {xorn}
-             firstshlshr,      {shrn}
-             firstshlshr,      {shln}
-             firstadd,   {slashn}
-             firstadd,   {andn}
-             firstsubscript,   {subscriptn}
-             firstderef,       {derefn}
-             firstaddr, {addrn}
-             firstdoubleaddr,  {doubleaddrn}
-             firstordconst,    {ordconstn}
-             firsttypeconv,    {typeconvn}
-             firstcalln,       {calln}
-             firstnothing,     {callparan}
-             firstrealconst,   {realconstn}
-             firstfixconst,    {fixconstn}
-             firstunaryminus,  {unaryminusn}
-             firstasm,         {asmn}
-             firstvec,         {vecn}
-             firstpointerconst,{pointerconstn}
-             firststringconst, {stringconstn}
-             firstfuncret,     {funcretn}
-             firstself, {selfn}
-             firstnot,   {notn}
-             firstinline,      {inlinen}
-             firstniln, {niln}
-             firsterror,       {errorn}
-             firsttype, {typen}
-             firsthnew, {hnewn}
-             firsthdispose,    {hdisposen}
-             firstnew,   {newn}
-             firstsimplenewdispose, {simpledisposen}
-             firstsetelement,  {setelementn}
-             firstsetconst,    {setconstn}
-             firstblock,       {blockn}
-             firststatement,   {statementn}
-             firstnothing,     {loopn}
-             firstif,     {ifn}
-             firstnothing,     {breakn}
-             firstnothing,     {continuen}
-             first_while_repeat, {repeatn}
-             first_while_repeat, {whilen}
-             firstfor,   {forn}
-             firstexit, {exitn}
-             firstwith, {withn}
-             firstcase, {casen}
-             firstlabel,       {labeln}
-             firstgoto, {goton}
-             firstsimplenewdispose, {simplenewn}
-             firsttryexcept,   {tryexceptn}
-             firstraise,       {raisen}
-             firstnothing,     {switchesn}
-             firsttryfinally,  {tryfinallyn}
-             firston,     {onn}
-             firstis,     {isn}
-             firstas,     {asn}
-             firsterror,       {caretn}
-             firstnothing,     {failn}
-             firstadd,   {starstarn}
-             firstprocinline,  {procinlinen}
-             firstarrayconstruct, {arrayconstructn}
-             firstarrayconstructrange, {arrayconstructrangen}
-             firstnothing,     {nothingn}
-             firstloadvmt      {loadvmtn}
-             );
-      var
-         oldcodegenerror  : boolean;
-         oldlocalswitches : tlocalswitches;
-         oldpos    : tfileposinfo;
-{$ifdef extdebug}
-         str1,str2 : string;
-         oldp      : ptree;
-         not_first : boolean;
-{$endif extdebug}
-      begin
-{$ifdef extdebug}
-         inc(total_of_firstpass);
-         if (p^.firstpasscount>0) and only_one_pass then
-           exit;
-{$endif extdebug}
-         oldcodegenerror:=codegenerror;
-         oldpos:=aktfilepos;
-         oldlocalswitches:=aktlocalswitches;
-{$ifdef extdebug}
-         if p^.firstpasscount>0 then
-           begin
-              move(p^,str1[1],sizeof(ttree));
-              str1[0]:=char(sizeof(ttree));
-              new(oldp);
-              oldp^:=p^;
-              not_first:=true;
-              inc(firstpass_several);
-           end
-         else
-           not_first:=false;
-{$endif extdebug}
-
-         if not p^.error then
-           begin
-              codegenerror:=false;
-              aktfilepos:=p^.fileinfo;
-              aktlocalswitches:=p^.localswitches;
-              procedures[p^.treetype](p);
-              aktlocalswitches:=oldlocalswitches;
-              aktfilepos:=oldpos;
-              p^.error:=codegenerror;
-              codegenerror:=codegenerror or oldcodegenerror;
-           end
-         else
-           codegenerror:=true;
-{$ifdef extdebug}
-         if not_first then
-           begin
-              { dirty trick to compare two ttree's (PM) }
-              move(p^,str2[1],sizeof(ttree));
-              str2[0]:=char(sizeof(ttree));
-              if str1<>str2 then
-                begin
-                   comment(v_debug,'tree changed after first counting pass '
-                     +tostr(longint(p^.treetype)));
-                   compare_trees(oldp,p);
-                end;
-              dispose(oldp);
-           end;
-         if count_ref then
-           inc(p^.firstpasscount);
-{$endif extdebug}
-      end;
-
-
-    function do_firstpass(var p : ptree) : boolean;
-      begin
-         aktexceptblock:=nil;
-         codegenerror:=false;
-         firstpass(p);
-         do_firstpass:=codegenerror;
-      end;
-
-
-end.
-{$else tnode}
-unit pass_1;
-
-{$i defines.inc}
-
 interface
 
     uses
@@ -386,38 +32,9 @@ interface
     procedure firstpass(var p : tnode);
     function  do_firstpass(var p : tnode) : boolean;
 
-    type
-       tnothingnode = class(tnode)
-          constructor create;virtual;
-          function pass_1 : tnode;override;
-       end;
-
-       terrornode = class(tnode)
-          constructor create;virtual;
-          function pass_1 : tnode;override;
-       end;
-
-       tasmnode = class(tnode)
-          constructor create;virtual;
-          function pass_1 : tnode;override;
-       end;
-
-       tstatementnode = class(tbinarynode)
-          constructor create(l,r : tnode);virtual;
-          function pass_1 : tnode;override;
-       end;
-
-       tblocknode = class(tbinarynode)
-          constructor create(l,r : tnode);virtual;
-          function pass_1 : tnode;override;
-       end;
-
     var
-       cnothingnode : class of tnothingnode;
-       cerrornode : class of terrornode;
-       casmnode : class of tasmnode;
-       cstatementnode : class of tstatementnode;
-       cblocknode : class of tblocknode;
+       { the block node of the current exception block to check gotos }
+       aktexceptblock : tnode;
 
 implementation
 
@@ -426,8 +43,7 @@ implementation
       cutils,cobjects,verbose,globals,
       aasm,symtable,types,
       htypechk,
-      cpubase,cpuasm,
-      nflw
+      cpubase,cpuasm
 {$ifdef newcg}
       ,cgbase
       ,tgcpu
@@ -442,209 +58,6 @@ implementation
 {$endif}
       ;
 
-{*****************************************************************************
-                             TFIRSTNOTHING
-*****************************************************************************}
-
-    constructor tnothingnode.create;
-
-      begin
-         inherited create(nothingn);
-      end;
-
-    function tnothingnode.pass_1 : tnode;
-      begin
-         pass_1:=nil;
-         resulttype:=voiddef;
-      end;
-
-
-{*****************************************************************************
-                             TFIRSTERROR
-*****************************************************************************}
-
-    constructor terrornode.create;
-
-      begin
-         inherited create(errorn);
-      end;
-
-    function terrornode.pass_1 : tnode;
-      begin
-         pass_1:=nil;
-         include(flags,nf_error);
-         codegenerror:=true;
-         resulttype:=generrordef;
-      end;
-
-{*****************************************************************************
-                            TSTATEMENTNODE
-*****************************************************************************}
-
-    constructor tstatementnode.create(l,r : tnode);
-
-      begin
-         inherited create(statementn,l,r);
-      end;
-
-    function tstatementnode.pass_1 : tnode;
-      begin
-         pass_1:=nil;
-         { left is the next statement in the list }
-         resulttype:=voiddef;
-         { no temps over several statements }
-{$ifdef newcg}
-         tg.cleartempgen;
-{$else newcg}
-         cleartempgen;
-{$endif newcg}
-         { right is the statement itself calln assignn or a complex one }
-         {must_be_valid:=true; obsolete PM }
-         firstpass(right);
-         if (not (cs_extsyntax in aktmoduleswitches)) and
-            assigned(right.resulttype) and
-            (right.resulttype<>pdef(voiddef)) then
-           CGMessage(cg_e_illegal_expression);
-         if codegenerror then
-           exit;
-         registers32:=right.registers32;
-         registersfpu:=right.registersfpu;
-{$ifdef SUPPORT_MMX}
-         registersmmx:=right.registersmmx;
-{$endif SUPPORT_MMX}
-         { left is the next in the list }
-         firstpass(left);
-         if codegenerror then
-           exit;
-         if right.registers32>registers32 then
-           registers32:=right.registers32;
-         if right.registersfpu>registersfpu then
-           registersfpu:=right.registersfpu;
-{$ifdef SUPPORT_MMX}
-         if right.registersmmx>registersmmx then
-           registersmmx:=right.registersmmx;
-{$endif}
-      end;
-
-
-{*****************************************************************************
-                             TBLOCKNODE
-*****************************************************************************}
-
-    constructor tblocknode.create(l,r : tnode);
-
-      begin
-         inherited create(blockn,l,r);
-      end;
-
-    function tblocknode.pass_1 : tnode;
-      var
-         hp : tstatementnode;
-         count : longint;
-      begin
-         pass_1:=nil;
-         count:=0;
-         hp:=tstatementnode(left);
-         while assigned(hp) do
-           begin
-              if cs_regalloc in aktglobalswitches then
-                begin
-                   { node transformations }
-
-                   { concat function result to exit }
-                   { this is wrong for string or other complex
-                     result types !!! }
-                   if ret_in_acc(procinfo^.returntype.def) and
-                      assigned(hp.left) and
-                      assigned(tstatementnode(hp.left).right) and
-                      (tstatementnode(hp.left).right.nodetype=exitn) and
-                      (hp.right.nodetype=assignn) and
-                      { !!!! this tbinarynode should be tassignmentnode }
-                      (tbinarynode(hp.right).left.nodetype=funcretn) then
-                      begin
-                         if assigned(texitnode(tstatementnode(hp.left).right).left) then
-                           CGMessage(cg_n_inefficient_code)
-                         else
-                           begin
-                              texitnode(tstatementnode(hp.left).right).left:=tstatementnode(hp.right).right;
-                              tstatementnode(hp.right).right:=nil;
-                              hp.right.free;
-                              hp.right:=nil;
-                           end;
-                      end
-                   { warning if unreachable code occurs and elimate this }
-                   else if (hp.right.nodetype in
-                     [exitn,breakn,continuen,goton]) and
-                     { statement node (JM) }
-                     assigned(hp.left) and
-                     { kind of statement! (JM) }
-                     assigned(tstatementnode(hp.left).right) and
-                     (tstatementnode(hp.left).right.nodetype<>labeln) then
-                     begin
-                        { use correct line number }
-                        aktfilepos:=hp.left.fileinfo;
-                        hp.left.free;
-                        hp.left:=nil;
-                        CGMessage(cg_w_unreachable_code);
-                        { old lines }
-                        aktfilepos:=hp.right.fileinfo;
-                     end;
-                end;
-              if assigned(hp.right) then
-                begin
-{$ifdef newcg}
-                   tg.cleartempgen;
-{$else newcg}
-                   cleartempgen;
-{$endif newcg}
-                   codegenerror:=false;
-                   firstpass(hp.right);
-                   if (not (cs_extsyntax in aktmoduleswitches)) and
-                      assigned(hp.right.resulttype) and
-                      (hp.right.resulttype<>pdef(voiddef)) then
-                     CGMessage(cg_e_illegal_expression);
-                   {if codegenerror then
-                     exit;}
-                   hp.registers32:=hp.right.registers32;
-                   hp.registersfpu:=hp.right.registersfpu;
-{$ifdef SUPPORT_MMX}
-                   hp.registersmmx:=hp.right.registersmmx;
-{$endif SUPPORT_MMX}
-                end
-              else
-                hp.registers32:=0;
-
-              if hp.registers32>registers32 then
-                registers32:=hp.registers32;
-              if hp.registersfpu>registersfpu then
-                registersfpu:=hp.registersfpu;
-{$ifdef SUPPORT_MMX}
-              if hp.registersmmx>registersmmx then
-                registersmmx:=hp.registersmmx;
-{$endif}
-              inc(count);
-              hp:=tstatementnode(hp.left);
-           end;
-      end;
-
-
-{*****************************************************************************
-                             TASMNODE
-*****************************************************************************}
-
-    constructor tasmnode.create;
-
-      begin
-         inherited create(asmn);
-      end;
-
-
-    function tasmnode.pass_1 : tnode;
-      begin
-         pass_1:=nil;
-         procinfo^.flags:=procinfo^.flags or pi_uses_asm;
-      end;
-
 {*****************************************************************************
                             Global procedures
 *****************************************************************************}
@@ -657,8 +70,10 @@ implementation
          oldpos    : tfileposinfo;
          hp : tnode;
 {$ifdef extdebug}
+   {$ifdef dummy}
          str1,str2 : string;
          oldp      : tnode;
+   {$endif}
          not_first : boolean;
 {$endif extdebug}
       begin
@@ -673,10 +88,12 @@ implementation
 {$ifdef extdebug}
          if p.firstpasscount>0 then
            begin
+    {$ifdef dummy}
               move(p^,str1[1],sizeof(ttree));
               str1[0]:=char(sizeof(ttree));
               new(oldp);
-              oldp^:=p^;
+              old^:=p^;
+    {$endif}
               not_first:=true;
               inc(firstpass_several);
            end
@@ -707,6 +124,7 @@ implementation
 {$ifdef extdebug}
          if not_first then
            begin
+    {$ifdef dummy}
               { dirty trick to compare two ttree's (PM) }
               move(p^,str2[1],sizeof(ttree));
               str2[0]:=char(sizeof(ttree));
@@ -717,6 +135,7 @@ implementation
                    compare_trees(oldp,p);
                 end;
               dispose(oldp);
+    {$endif dummy}
            end;
          if count_ref then
            inc(p.firstpasscount);
@@ -732,17 +151,13 @@ implementation
          do_firstpass:=codegenerror;
       end;
 
-begin
-   cnothingnode:=tnothingnode;
-   cerrornode:=terrornode;
-   casmnode:=tasmnode;
-   cstatementnode:=tstatementnode;
-   cblocknode:=tblocknode;
 end.
-{$endif cg11}
 {
   $Log$
-  Revision 1.8  2000-10-01 19:48:25  peter
+  Revision 1.9  2000-10-14 10:14:51  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.8  2000/10/01 19:48:25  peter
     * lot of compile updates for cg11
 
   Revision 1.7  2000/09/30 16:08:45  peter

compiler/pass_2.pas

@@ -27,15 +27,21 @@ unit pass_2;
 interface
 
 uses
-  tree;
+   node;
 
+    type
+       tenumflowcontrol = (fc_exit,fc_break,fc_continue);
+       tflowcontrol = set of tenumflowcontrol;
+
+    var
+       flowcontrol : tflowcontrol;
 { produces assembler for the expression in variable p }
 { and produces an assembler node at the end        }
-procedure generatecode(var p : ptree);
+procedure generatecode(var p : tnode);
 
 { produces the actual code }
-function do_secondpass(var p : ptree) : boolean;
-procedure secondpass(var p : ptree);
+function do_secondpass(var p : tnode) : boolean;
+procedure secondpass(var p : tnode);
 
 
 implementation
@@ -44,22 +50,15 @@ implementation
      globtype,systems,
      cobjects,comphook,verbose,globals,fmodule,
      symconst,symtable,types,aasm,scanner,
-     pass_1,hcodegen,temp_gen,cpubase,cpuasm,regvars
-{$ifndef newcg}
-     ,tcflw
-{$endif newcg}
+     pass_1,hcodegen,temp_gen,cpubase,cpuasm,regvars,nflw
 {$ifdef GDB}
      ,gdb
 {$endif}
 {$ifdef i386}
      ,tgeni386,cgai386
-     ,cg386con,cg386mat,cg386cnv,cg386set,cg386add
-     ,cg386mem,cg386cal,cg386ld,cg386flw,cg386inl
 {$endif}
 {$ifdef m68k}
      ,tgen68k,cga68k
-     ,cg68kcon,cg68kmat,cg68kcnv,cg68kset,cg68kadd
-     ,cg68kmem,cg68kcal,cg68kld,cg68kflw,cg68kinl
 {$endif}
      ;
 
@@ -67,167 +66,6 @@ implementation
                               SecondPass
 *****************************************************************************}
 
-    type
-       secondpassproc = procedure(var p : ptree);
-
-    procedure secondnothing(var p : ptree);
-
-      begin
-      end;
-
-    procedure seconderror(var p : ptree);
-
-      begin
-         p^.error:=true;
-         codegenerror:=true;
-      end;
-
-
-    procedure secondstatement(var p : ptree);
-
-      var
-         hp : ptree;
-      begin
-         hp:=p;
-         while assigned(hp) do
-          begin
-            if assigned(hp^.right) then
-             begin
-               cleartempgen;
-               {!!!!!!
-               oldrl:=temptoremove;
-               temptoremove:=new(plinkedlist,init);
-               }
-               secondpass(hp^.right);
-               { !!!!!!!
-                 some temporary data which can't be released elsewhere
-               removetemps(exprasmlist,temptoremove);
-               dispose(temptoremove,done);
-               temptoremove:=oldrl;
-               }
-             end;
-            hp:=hp^.left;
-          end;
-      end;
-
-
-    procedure secondblockn(var p : ptree);
-      begin
-      { do second pass on left node }
-        if assigned(p^.left) then
-         secondpass(p^.left);
-      end;
-
-
-    procedure secondasm(var p : ptree);
-
-        procedure ReLabel(var p:pasmsymbol);
-        begin
-          if p^.proclocal then
-           begin
-             if not assigned(p^.altsymbol) then
-              begin
-                p^.GenerateAltSymbol;
-                UsedAsmSymbolListInsert(p);
-              end;
-             p:=p^.altsymbol;
-           end;
-        end;
-
-      var
-        hp,hp2 : pai;
-        localfixup,parafixup,
-        i : longint;
-        skipnode : boolean;
-      begin
-         if inlining_procedure then
-           begin
-             InitUsedAsmSymbolList;
-             localfixup:=aktprocsym^.definition^.localst^.address_fixup;
-             parafixup:=aktprocsym^.definition^.parast^.address_fixup;
-             hp:=pai(p^.p_asm^.first);
-             while assigned(hp) do
-              begin
-                hp2:=pai(hp^.getcopy);
-                skipnode:=false;
-                case hp2^.typ of
-                  ait_label :
-                     begin
-                       { regenerate the labels by setting altsymbol }
-                       ReLabel(pasmsymbol(pai_label(hp2)^.l));
-                     end;
-                  ait_const_rva,
-                  ait_const_symbol :
-                     begin
-                       ReLabel(pai_const_symbol(hp2)^.sym);
-                     end;
-                  ait_instruction :
-                     begin
-{$ifdef i386}
-                       { fixup the references }
-                       for i:=1 to paicpu(hp2)^.ops do
-                        begin
-                          with paicpu(hp2)^.oper[i-1] do
-                           begin
-                             case typ of
-                               top_ref :
-                                 begin
-                                   case ref^.options of
-                                     ref_parafixup :
-                                       ref^.offsetfixup:=parafixup;
-                                     ref_localfixup :
-                                       ref^.offsetfixup:=localfixup;
-                                   end;
-                                   if assigned(ref^.symbol) then
-                                    ReLabel(ref^.symbol);
-                                 end;
-                               top_symbol :
-                                 begin
-                                   ReLabel(sym);
-                                 end;
-                              end;
-                           end;
-                        end;
-{$endif i386}
-                     end;
-                   ait_marker :
-                     begin
-                     { it's not an assembler block anymore }
-                       if (pai_marker(hp2)^.kind in [AsmBlockStart, AsmBlockEnd]) then
-                        skipnode:=true;
-                     end;
-                   else
-                end;
-                if not skipnode then
-                 exprasmlist^.concat(hp2)
-                else
-                 dispose(hp2,done);
-                hp:=pai(hp^.next);
-              end;
-             { restore used symbols }
-             UsedAsmSymbolListResetAltSym;
-             DoneUsedAsmSymbolList;
-           end
-         else
-           begin
-             { if the routine is an inline routine, then we must hold a copy
-               becuase it can be necessary for inlining later }
-             if (pocall_inline in aktprocsym^.definition^.proccalloptions) then
-               exprasmlist^.concatlistcopy(p^.p_asm)
-             else
-               exprasmlist^.concatlist(p^.p_asm);
-           end;
-         if not p^.object_preserved then
-          begin
-{$ifdef i386}
-            maybe_loadesi;
-{$endif}
-{$ifdef m68k}
-            maybe_loada5;
-{$endif}
-          end;
-       end;
-
 {$ifdef logsecondpass}
      procedure logsecond(const s: string; entry: boolean);
      var p: pchar;
@@ -239,90 +77,7 @@ implementation
      end;
 {$endif logsecondpass}
 
-     procedure secondpass(var p : ptree);
-       const
-         procedures : array[ttreetyp] of secondpassproc =
-            (secondadd,  {addn}
-             secondadd,  {muln}
-             secondadd,  {subn}
-             secondmoddiv,      {divn}
-             secondadd,  {symdifn}
-             secondmoddiv,      {modn}
-             secondassignment,  {assignn}
-             secondload,        {loadn}
-             secondnothing,     {range}
-             secondadd,  {ltn}
-             secondadd,  {lten}
-             secondadd,  {gtn}
-             secondadd,  {gten}
-             secondadd,  {equaln}
-             secondadd,  {unequaln}
-             secondin,    {inn}
-             secondadd,  {orn}
-             secondadd,  {xorn}
-             secondshlshr,      {shrn}
-             secondshlshr,      {shln}
-             secondadd,  {slashn}
-             secondadd,  {andn}
-             secondsubscriptn,  {subscriptn}
-             secondderef,       {derefn}
-             secondaddr,        {addrn}
-             seconddoubleaddr,  {doubleaddrn}
-             secondordconst,    {ordconstn}
-             secondtypeconv,    {typeconvn}
-             secondcalln,       {calln}
-             secondnothing,     {callparan}
-             secondrealconst,   {realconstn}
-             secondfixconst,    {fixconstn}
-             secondunaryminus,  {unaryminusn}
-             secondasm,         {asmn}
-             secondvecn,        {vecn}
-             secondpointerconst, {pointerconstn}
-             secondstringconst, {stringconstn}
-             secondfuncret,     {funcretn}
-             secondselfn,       {selfn}
-             secondnot,  {notn}
-             secondinline,      {inlinen}
-             secondniln,        {niln}
-             seconderror,       {errorn}
-             secondnothing,     {typen}
-             secondhnewn,       {hnewn}
-             secondhdisposen,   {hdisposen}
-             secondnewn,        {newn}
-             secondsimplenewdispose, {simpledisposen}
-             secondsetelement,  {setelementn}
-             secondsetconst,    {setconstn}
-             secondblockn,      {blockn}
-             secondstatement,   {statementn}
-             secondnothing,     {loopn}
-             secondifn,  {ifn}
-             secondbreakn,      {breakn}
-             secondcontinuen,   {continuen}
-             second_while_repeatn, {repeatn}
-             second_while_repeatn, {whilen}
-             secondfor,  {forn}
-             secondexitn,       {exitn}
-             secondwith,        {withn}
-             secondcase,        {casen}
-             secondlabel,       {labeln}
-             secondgoto,        {goton}
-             secondsimplenewdispose, {simplenewn}
-             secondtryexcept,   {tryexceptn}
-             secondraise,       {raisen}
-             secondnothing,     {switchesn}
-             secondtryfinally,  {tryfinallyn}
-             secondon,    {onn}
-             secondis,    {isn}
-             secondas,    {asn}
-             seconderror,       {caretn}
-             secondfail,        {failn}
-             secondadd,  {starstarn}
-             secondprocinline,  {procinlinen}
-             secondarrayconstruct, {arrayconstructn}
-             secondnothing,     {arrayconstructrangen}
-             secondnothing,     {nothingn}
-             secondloadvmt      {loadvmtn}
-             );
+     procedure secondpass(var p : tnode);
 {$ifdef logsecondpass}
       secondnames: array[ttreetyp] of string[13] =
             ('add-addn',  {addn}
@@ -416,7 +171,7 @@ implementation
          prevp : pptree;
 {$endif TEMPREGDEBUG}
       begin
-         if not(p^.error) then
+         if not(nf_error in p.flags) then
           begin
             oldcodegenerror:=codegenerror;
             oldlocalswitches:=aktlocalswitches;
@@ -427,17 +182,18 @@ implementation
             curptree:=@p;
             p^.usableregs:=usablereg32;
 {$endif TEMPREGDEBUG}
-            aktfilepos:=p^.fileinfo;
-            aktlocalswitches:=p^.localswitches;
+            aktfilepos:=p.fileinfo;
+            aktlocalswitches:=p.localswitches;
             codegenerror:=false;
 {$ifdef logsecondpass}
-            logsecond('second'+secondnames[p^.treetype],true);
+            logsecond('second'+secondnames[p.nodetype],true);
 {$endif logsecondpass}
-            procedures[p^.treetype](p);
+            p.pass_2;
 {$ifdef logsecondpass}
-            logsecond('second'+secondnames[p^.treetype],false);
+            logsecond('second'+secondnames[p.nodetype],false);
 {$endif logsecondpass}
-            p^.error:=codegenerror;
+            if codegenerror then
+              include(p.flags,nf_error);
 
             codegenerror:=codegenerror or oldcodegenerror;
             aktlocalswitches:=oldlocalswitches;
@@ -446,9 +202,9 @@ implementation
             curptree:=prevp;
 {$endif TEMPREGDEBUG}
 {$ifdef EXTTEMPREGDEBUG}
-            if p^.usableregs-usablereg32>p^.reallyusedregs then
-              p^.reallyusedregs:=p^.usableregs-usablereg32;
-            if p^.reallyusedregs<p^.registers32 then
+            if p.usableregs-usablereg32>p.reallyusedregs then
+              p.reallyusedregs:=p.usableregs-usablereg32;
+            if p.reallyusedregs<p.registers32 then
               Comment(V_Debug,'registers32 overestimated '+tostr(p^.registers32)+
                 '>'+tostr(p^.reallyusedregs));
 {$endif EXTTEMPREGDEBUG}
@@ -458,10 +214,10 @@ implementation
       end;
 
 
-    function do_secondpass(var p : ptree) : boolean;
+    function do_secondpass(var p : tnode) : boolean;
       begin
          codegenerror:=false;
-         if not(p^.error) then
+         if not(nf_error in p.flags) then
            secondpass(p);
          do_secondpass:=codegenerror;
       end;
@@ -474,7 +230,7 @@ implementation
              pvarsym(p)^.refs:=1;
       end;
 
-    procedure generatecode(var p : ptree);
+    procedure generatecode(var p : tnode);
       begin
          cleartempgen;
          flowcontrol:=[];
@@ -545,7 +301,7 @@ implementation
               do_secondpass(p);
 
               if assigned(procinfo^.def) then
-                procinfo^.def^.fpu_used:=p^.registersfpu;
+                procinfo^.def^.fpu_used:=p.registersfpu;
 
            end;
          procinfo^.aktproccode^.concatlist(exprasmlist);
@@ -555,7 +311,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.8  2000-09-24 15:06:21  peter
+  Revision 1.9  2000-10-14 10:14:51  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.8  2000/09/24 15:06:21  peter
     * use defines.inc
 
   Revision 1.7  2000/08/27 16:11:51  peter
@@ -585,4 +344,4 @@ end.
   Revision 1.2  2000/07/13 11:32:44  michael
   + removed logs
 
-}
+}

compiler/pdecobj.pas

@@ -0,0 +1,1085 @@
+{
+    $Id$
+    Copyright (c) 1998-2000 by Florian Klaempfl
+
+    Does object types for Free Pascal
+
+    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 pdecobj;
+
+{$i defines.inc}
+
+  interface
+
+    uses
+      globtype,symtable
+      {$IFDEF NEWST}
+      ,symbols,defs
+      {$ENDIF NEWST};
+
+    { parses a object declaration }
+    function object_dec(const n : stringid;fd : pobjectdef) : pdef;
+
+  implementation
+
+    uses
+{$ifdef Delphi}
+      SysUtils,
+{$endif}
+      cutils,cobjects,globals,verbose,systems,tokens,
+      aasm,symconst,types,
+{$ifdef GDB}
+      gdb,
+{$endif}
+      hcodegen,hcgdata,
+      node,nld,ncon,ncnv,pass_1,
+      scanner,
+      pbase,pexpr,pdecl,psub,pdecsub,pdecvar,ptype;
+
+    function object_dec(const n : stringid;fd : pobjectdef) : pdef;
+    { this function parses an object or class declaration }
+      var
+         actmembertype : tsymoptions;
+         there_is_a_destructor : boolean;
+         classtype : (ct_object,ct_class,ct_interfacecom,ct_interfaceraw,ct_cppclass);
+         childof : pobjectdef;
+         aktclass : pobjectdef;
+
+      procedure constructor_head;
+
+        begin
+           consume(_CONSTRUCTOR);
+           { must be at same level as in implementation }
+           inc(lexlevel);
+           parse_proc_head(potype_constructor);
+           dec(lexlevel);
+
+           if (cs_constructor_name in aktglobalswitches) and (aktprocsym^.name<>'INIT') then
+            Message(parser_e_constructorname_must_be_init);
+
+           include(aktclass^.objectoptions,oo_has_constructor);
+           consume(_SEMICOLON);
+             begin
+                if (aktclass^.is_class) then
+                  begin
+                     { CLASS constructors return the created instance }
+                     aktprocsym^.definition^.rettype.def:=aktclass;
+                  end
+                else
+                  begin
+                     { OBJECT constructors return a boolean }
+                     aktprocsym^.definition^.rettype.setdef(booldef);
+                  end;
+             end;
+        end;
+
+
+      procedure property_dec;
+
+        var
+           sym : psym;
+           propertyparas : plinkedlist;
+
+        { returns the matching procedure to access a property }
+        function get_procdef : pprocdef;
+
+          var
+             p : pprocdef;
+
+          begin
+             p:=pprocsym(sym)^.definition;
+             get_procdef:=nil;
+             while assigned(p) do
+               begin
+                  if equal_paras(p^.para,propertyparas,cp_value_equal_const) then
+                    break;
+                  p:=p^.nextoverloaded;
+               end;
+             get_procdef:=p;
+          end;
+
+        var
+           hp2,datacoll : pparaitem;
+           p : ppropertysym;
+           overriden : psym;
+           hs : string;
+           varspez : tvarspez;
+           sc : pstringcontainer;
+           s : string;
+           tt : ttype;
+           declarepos : tfileposinfo;
+           pp : pprocdef;
+           pt : tnode;
+           propname : stringid;
+
+        begin
+           { check for a class }
+           if not(aktclass^.is_class) then
+            Message(parser_e_syntax_error);
+           consume(_PROPERTY);
+           new(propertyparas,init);
+           datacoll:=nil;
+           if token=_ID then
+             begin
+                p:=new(ppropertysym,init(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 in propertyparas }
+                     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 token=_OUT then
+                         begin
+                            consume(_OUT);
+                            varspez:=vs_out;
+                         end
+                       else varspez:=vs_value;
+                       sc:=idlist;
+{$ifdef fixLeaksOnError}
+                       strContStack.push(sc);
+{$endif fixLeaksOnError}
+                       if token=_COLON then
+                         begin
+                            consume(_COLON);
+                            if token=_ARRAY then
+                              begin
+                                 {
+                                 if (varspez<>vs_const) and
+                                   (varspez<>vs_var) then
+                                   begin
+                                      varspez:=vs_const;
+                                      Message(parser_e_illegal_open_parameter);
+                                   end;
+                                 }
+                                 consume(_ARRAY);
+                                 consume(_OF);
+                                 { define range and type of range }
+                                 tt.setdef(new(parraydef,init(0,-1,s32bitdef)));
+                                 { define field type }
+                                 single_type(parraydef(tt.def)^.elementtype,s,false);
+                              end
+                            else
+                              single_type(tt,s,false);
+                         end
+                       else
+                         tt.setdef(cformaldef);
+                       repeat
+                         s:=sc^.get_with_tokeninfo(declarepos);
+                         if s='' then
+                          break;
+                         new(hp2,init);
+                         hp2^.paratyp:=varspez;
+                         hp2^.paratype:=tt;
+                         propertyparas^.insert(hp2);
+                       until false;
+{$ifdef fixLeaksOnError}
+                       if strContStack.pop <> sc then
+                         writeln('problem with strContStack in ptype');
+{$endif fixLeaksOnError}
+                       dispose(sc,done);
+                     until not try_to_consume(_SEMICOLON);
+                     dec(testcurobject);
+                     consume(_RECKKLAMMER);
+                  end;
+                { overriden property ?                                 }
+                { force property interface, if there is a property parameter }
+                if (token=_COLON) or not(propertyparas^.empty) then
+                  begin
+                     consume(_COLON);
+                     single_type(p^.proptype,hs,false);
+                     if (idtoken=_INDEX) then
+                       begin
+                          consume(_INDEX);
+                          pt:=comp_expr(true);
+                          do_firstpass(pt);
+                          if is_ordinal(pt.resulttype) and
+                             (not is_64bitint(pt.resulttype)) then
+                            p^.index:=tordconstnode(pt).value
+                          else
+                            begin
+                              Message(parser_e_invalid_property_index_value);
+                              p^.index:=0;
+                            end;
+                          p^.indextype.setdef(pt.resulttype);
+                          include(p^.propoptions,ppo_indexed);
+                          { concat a longint to the para template }
+                          new(hp2,init);
+                          hp2^.paratyp:=vs_value;
+                          hp2^.paratype:=p^.indextype;
+                          propertyparas^.insert(hp2);
+                          pt.free;
+                       end;
+                     { the parser need to know if a property has parameters }
+                     if not(propertyparas^.empty) then
+                       include(p^.propoptions,ppo_hasparameters);
+                  end
+                else
+                  begin
+                     { do an property override }
+                     overriden:=search_class_member(aktclass,propname);
+                     if assigned(overriden) and (overriden^.typ=propertysym) then
+                       begin
+                         p^.dooverride(ppropertysym(overriden));
+                       end
+                     else
+                       begin
+                         p^.proptype.setdef(generrordef);
+                         message(parser_e_no_property_found_to_override);
+                       end;
+                  end;
+                if (sp_published in current_object_option) and
+                   not(p^.proptype.def^.is_publishable) then
+                  Message(parser_e_cant_publish_that_property);
+
+                { create data defcoll to allow correct parameter checks }
+                new(datacoll,init);
+                datacoll^.paratyp:=vs_value;
+                datacoll^.paratype:=p^.proptype;
+
+                if (idtoken=_READ) then
+                  begin
+                     p^.readaccess^.clear;
+                     consume(_READ);
+                     sym:=search_class_member(aktclass,pattern);
+                     if not(assigned(sym)) then
+                       begin
+                         Message1(sym_e_unknown_id,pattern);
+                         consume(_ID);
+                       end
+                     else
+                       begin
+                          consume(_ID);
+                          while (token=_POINT) and
+                                ((sym^.typ=varsym) and
+                                 (pvarsym(sym)^.vartype.def^.deftype=recorddef)) do
+                           begin
+                             p^.readaccess^.addsym(sym);
+                             consume(_POINT);
+                             getsymonlyin(precorddef(pvarsym(sym)^.vartype.def)^.symtable,pattern);
+                             if not assigned(srsym) then
+                               Message1(sym_e_illegal_field,pattern);
+                             sym:=srsym;
+                             consume(_ID);
+                           end;
+                       end;
+
+                     if assigned(sym) then
+                       begin
+                          { search the matching definition }
+                          case sym^.typ of
+                            procsym :
+                              begin
+                                 pp:=get_procdef;
+                                 if not(assigned(pp)) or
+                                    not(is_equal(pp^.rettype.def,p^.proptype.def)) then
+                                   Message(parser_e_ill_property_access_sym);
+                                 p^.readaccess^.setdef(pp);
+                              end;
+                            varsym :
+                              begin
+                                if not(propertyparas^.empty) or
+                                   not(is_equal(pvarsym(sym)^.vartype.def,p^.proptype.def)) then
+                                  Message(parser_e_ill_property_access_sym);
+                              end;
+                            else
+                              Message(parser_e_ill_property_access_sym);
+                          end;
+                          p^.readaccess^.addsym(sym);
+                       end;
+                  end;
+                if (idtoken=_WRITE) then
+                  begin
+                     p^.writeaccess^.clear;
+                     consume(_WRITE);
+                     sym:=search_class_member(aktclass,pattern);
+                     if not(assigned(sym)) then
+                       begin
+                         Message1(sym_e_unknown_id,pattern);
+                         consume(_ID);
+                       end
+                     else
+                       begin
+                          consume(_ID);
+                          while (token=_POINT) and
+                                ((sym^.typ=varsym) and
+                                 (pvarsym(sym)^.vartype.def^.deftype=recorddef)) do
+                           begin
+                             p^.writeaccess^.addsym(sym);
+                             consume(_POINT);
+                             getsymonlyin(precorddef(pvarsym(sym)^.vartype.def)^.symtable,pattern);
+                             if not assigned(srsym) then
+                               Message1(sym_e_illegal_field,pattern);
+                             sym:=srsym;
+                             consume(_ID);
+                           end;
+                       end;
+
+                     if assigned(sym) then
+                       begin
+                          { search the matching definition }
+                          case sym^.typ of
+                            procsym :
+                              begin
+                                 { insert data entry to check access method }
+                                 propertyparas^.insert(datacoll);
+                                 pp:=get_procdef;
+                                 { ... and remove it }
+                                 propertyparas^.remove(datacoll);
+                                 if not(assigned(pp)) then
+                                   Message(parser_e_ill_property_access_sym);
+                                 p^.writeaccess^.setdef(pp);
+                              end;
+                            varsym :
+                              begin
+                                 if not(propertyparas^.empty) or
+                                    not(is_equal(pvarsym(sym)^.vartype.def,p^.proptype.def)) then
+                                   Message(parser_e_ill_property_access_sym);
+                              end
+                            else
+                              Message(parser_e_ill_property_access_sym);
+                          end;
+                          p^.writeaccess^.addsym(sym);
+                       end;
+                  end;
+                include(p^.propoptions,ppo_stored);
+                if (idtoken=_STORED) then
+                  begin
+                     consume(_STORED);
+                     p^.storedaccess^.clear;
+                     case token of
+                        _ID:
+                           { 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
+                                sym:=search_class_member(aktclass,pattern);
+                                if not(assigned(sym)) then
+                                  begin
+                                    Message1(sym_e_unknown_id,pattern);
+                                    consume(_ID);
+                                  end
+                                else
+                                  begin
+                                     consume(_ID);
+                                     while (token=_POINT) and
+                                           ((sym^.typ=varsym) and
+                                            (pvarsym(sym)^.vartype.def^.deftype=recorddef)) do
+                                      begin
+                                        p^.storedaccess^.addsym(sym);
+                                        consume(_POINT);
+                                        getsymonlyin(precorddef(pvarsym(sym)^.vartype.def)^.symtable,pattern);
+                                        if not assigned(srsym) then
+                                          Message1(sym_e_illegal_field,pattern);
+                                        sym:=srsym;
+                                        consume(_ID);
+                                      end;
+                                  end;
+
+                                if assigned(sym) then
+                                  begin
+                                     { only non array properties can be stored }
+                                     case sym^.typ of
+                                       procsym :
+                                         begin
+                                           pp:=pprocsym(sym)^.definition;
+                                           while assigned(pp) do
+                                             begin
+                                                { the stored function shouldn't have any parameters }
+                                                if pp^.para^.empty then
+                                                  break;
+                                                 pp:=pp^.nextoverloaded;
+                                             end;
+                                           { found we a procedure and does it really return a bool? }
+                                           if not(assigned(pp)) or
+                                              not(is_equal(pp^.rettype.def,booldef)) then
+                                             Message(parser_e_ill_property_storage_sym);
+                                           p^.storedaccess^.setdef(pp);
+                                         end;
+                                       varsym :
+                                         begin
+                                           if not(propertyparas^.empty) or
+                                              not(is_equal(pvarsym(sym)^.vartype.def,booldef)) then
+                                             Message(parser_e_stored_property_must_be_boolean);
+                                         end;
+                                       else
+                                         Message(parser_e_ill_property_storage_sym);
+                                     end;
+                                     p^.storedaccess^.addsym(sym);
+                                  end;
+                             end;
+                        _FALSE:
+                          begin
+                             consume(_FALSE);
+                             exclude(p^.propoptions,ppo_stored);
+                          end;
+                        _TRUE:
+                          consume(_TRUE);
+                     end;
+                  end;
+                if (idtoken=_DEFAULT) then
+                  begin
+                     consume(_DEFAULT);
+                     if not(is_ordinal(p^.proptype.def) or
+                            is_64bitint(p^.proptype.def) or
+                            ((p^.proptype.def^.deftype=setdef) and
+                             (psetdef(p^.proptype.def)^.settype=smallset))) or
+                        not(propertyparas^.empty) 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);
+                     do_firstpass(pt);
+                     if (p^.proptype.def^.deftype=setdef) and
+                        (pt.nodetype=arrayconstructorn) then
+                       begin
+                         arrayconstructor_to_set(tarrayconstructornode(pt));
+                         do_firstpass(pt);
+                       end;
+                     pt:=gentypeconvnode(pt,p^.proptype.def);
+                     do_firstpass(pt);
+                     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 (idtoken=_NODEFAULT) then
+                  begin
+                     consume(_NODEFAULT);
+                     p^.default:=0;
+                  end;
+                symtablestack^.insert(p);
+                { default property ? }
+                consume(_SEMICOLON);
+                if (idtoken=_DEFAULT) then
+                  begin
+                     consume(_DEFAULT);
+                     { overriding a default propertyp is allowed
+                     p2:=search_default_property(aktclass);
+                     if assigned(p2) then
+                       message1(parser_e_only_one_default_property,
+                         pobjectdef(p2^.owner^.defowner)^.objname^)
+                     else
+                     }
+                       begin
+                          include(p^.propoptions,ppo_defaultproperty);
+                          if propertyparas^.empty then
+                            message(parser_e_property_need_paras);
+                       end;
+                     consume(_SEMICOLON);
+                  end;
+                { clean up }
+                if assigned(datacoll) then
+                  dispose(datacoll,done);
+             end
+           else
+             begin
+                consume(_ID);
+                consume(_SEMICOLON);
+             end;
+           dispose(propertyparas,done);
+        end;
+
+
+      procedure destructor_head;
+        begin
+           consume(_DESTRUCTOR);
+           inc(lexlevel);
+           parse_proc_head(potype_destructor);
+           dec(lexlevel);
+           if (cs_constructor_name in aktglobalswitches) and (aktprocsym^.name<>'DONE') then
+            Message(parser_e_destructorname_must_be_done);
+           include(aktclass^.objectoptions,oo_has_destructor);
+           consume(_SEMICOLON);
+           if not(aktprocsym^.definition^.para^.empty) then
+             if not (m_tp in aktmodeswitches) then
+               Message(parser_e_no_paras_for_destructor);
+           { no return value }
+           aktprocsym^.definition^.rettype.def:=voiddef;
+        end;
+
+      var
+         hs      : string;
+         pcrd       : pclassrefdef;
+         tt     : ttype;
+         oldprocinfo : pprocinfo;
+         oldprocsym : pprocsym;
+         oldparse_only : boolean;
+         methodnametable,intmessagetable,
+         strmessagetable,classnamelabel,
+         fieldtablelabel : pasmlabel;
+         storetypecanbeforward : boolean;
+
+      procedure setclassattributes;
+
+        begin
+           if classtype=ct_class then
+             begin
+                include(aktclass^.objectoptions,oo_is_class);
+                if (cs_generate_rtti in aktlocalswitches) or
+                    (assigned(aktclass^.childof) and
+                     (oo_can_have_published in aktclass^.childof^.objectoptions)) then
+                  begin
+                     include(aktclass^.objectoptions,oo_can_have_published);
+                     { in "publishable" classes the default access type is published }
+                     actmembertype:=[sp_published];
+                     { don't know if this is necessary (FK) }
+                     current_object_option:=[sp_published];
+                  end;
+             end;
+        end;
+
+     procedure setclassparent;
+
+        begin
+           { is the current class tobject?   }
+           { so you could define your own tobject }
+           if (cs_compilesystem in aktmoduleswitches) and
+              (upper(n)='TOBJECT') then
+             begin
+                if assigned(fd) then
+                  aktclass:=fd
+                else
+                  aktclass:=new(pobjectdef,init(n,nil));
+                class_tobject:=aktclass;
+             end
+           else
+             begin
+                childof:=class_tobject;
+                if assigned(fd) then
+                  begin
+                     { the forward of the child must be resolved to get
+                       correct field addresses
+                     }
+                     if (oo_is_forward in childof^.objectoptions) then
+                       Message1(parser_e_forward_declaration_must_be_resolved,childof^.objname^);
+                     aktclass:=fd;
+                     aktclass^.set_parent(childof);
+                  end
+                else
+                  begin
+                     aktclass:=new(pobjectdef,init(n,childof));
+                     aktclass^.set_parent(childof);
+                  end;
+             end;
+         end;
+
+      { generates the vmt for classes as well as for objects }
+      procedure writevmt;
+
+        var
+           vmtlist : taasmoutput;
+{$ifdef WITHDMT}
+           dmtlabel : pasmlabel;
+{$endif WITHDMT}
+
+        begin
+{$ifdef WITHDMT}
+           dmtlabel:=gendmt(aktclass);
+{$endif WITHDMT}
+           { this generates the entries }
+           vmtlist.init;
+           genvmt(@vmtlist,aktclass);
+
+           { write tables for classes, this must be done before the actual
+             class is written, because we need the labels defined }
+           if classtype=ct_class then
+            begin
+              methodnametable:=genpublishedmethodstable(aktclass);
+              fieldtablelabel:=aktclass^.generate_field_table;
+              { rtti }
+              if (oo_can_have_published in aktclass^.objectoptions) then
+               aktclass^.generate_rtti;
+              { write class name }
+              getdatalabel(classnamelabel);
+              datasegment^.concat(new(pai_label,init(classnamelabel)));
+              datasegment^.concat(new(pai_const,init_8bit(length(aktclass^.objname^))));
+              datasegment^.concat(new(pai_string,init(aktclass^.objname^)));
+              { generate message and dynamic tables }
+              if (oo_has_msgstr in aktclass^.objectoptions) then
+                strmessagetable:=genstrmsgtab(aktclass);
+              if (oo_has_msgint in aktclass^.objectoptions) then
+                intmessagetable:=genintmsgtab(aktclass)
+              else
+                datasegment^.concat(new(pai_const,init_32bit(0)));
+            end;
+
+          { write debug info }
+{$ifdef GDB}
+          if (cs_debuginfo in aktmoduleswitches) then
+           begin
+             do_count_dbx:=true;
+             if assigned(aktclass^.owner) and assigned(aktclass^.owner^.name) then
+               datasegment^.concat(new(pai_stabs,init(strpnew('"vmt_'+aktclass^.owner^.name^+n+':S'+
+                 typeglobalnumber('__vtbl_ptr_type')+'",'+tostr(N_STSYM)+',0,0,'+aktclass^.vmt_mangledname))));
+           end;
+{$endif GDB}
+           datasegment^.concat(new(pai_symbol,initdataname_global(aktclass^.vmt_mangledname,0)));
+
+           { determine the size with symtable^.datasize, because }
+           { size gives back 4 for classes                    }
+           datasegment^.concat(new(pai_const,init_32bit(aktclass^.symtable^.datasize)));
+           datasegment^.concat(new(pai_const,init_32bit(-aktclass^.symtable^.datasize)));
+{$ifdef WITHDMT}
+           if classtype=ct_object then
+             begin
+                if assigned(dmtlabel) then
+                  datasegment^.concat(new(pai_const_symbol,init(dmtlabel)))
+                else
+                  datasegment^.concat(new(pai_const,init_32bit(0)));
+             end;
+{$endif WITHDMT}
+           { write pointer to parent VMT, this isn't implemented in TP }
+           { but this is not used in FPC ? (PM) }
+           { it's not used yet, but the delphi-operators as and is need it (FK) }
+           { it is not written for parents that don't have any vmt !! }
+           if assigned(aktclass^.childof) and
+              (oo_has_vmt in aktclass^.childof^.objectoptions) then
+             datasegment^.concat(new(pai_const_symbol,initname(aktclass^.childof^.vmt_mangledname)))
+           else
+             datasegment^.concat(new(pai_const,init_32bit(0)));
+
+           { write extended info for classes, for the order see rtl/inc/objpash.inc }
+           if classtype=ct_class then
+            begin
+              { pointer to class name string }
+              datasegment^.concat(new(pai_const_symbol,init(classnamelabel)));
+              { pointer to dynamic table }
+              if (oo_has_msgint in aktclass^.objectoptions) then
+                datasegment^.concat(new(pai_const_symbol,init(intmessagetable)))
+              else
+                datasegment^.concat(new(pai_const,init_32bit(0)));
+              { pointer to method table }
+              if assigned(methodnametable) then
+                datasegment^.concat(new(pai_const_symbol,init(methodnametable)))
+              else
+                datasegment^.concat(new(pai_const,init_32bit(0)));
+              { pointer to field table }
+              datasegment^.concat(new(pai_const_symbol,init(fieldtablelabel)));
+              { pointer to type info of published section }
+              if (oo_can_have_published in aktclass^.objectoptions) then
+                datasegment^.concat(new(pai_const_symbol,initname(aktclass^.rtti_name)))
+              else
+                datasegment^.concat(new(pai_const,init_32bit(0)));
+              { inittable for con-/destruction }
+              {
+              if aktclass^.needs_inittable then
+              }
+              { we generate the init table for classes always, because needs_inittable }
+              { for classes is always false, it applies only for objects               }
+              datasegment^.concat(new(pai_const_symbol,init(aktclass^.get_inittable_label)));
+              {
+              else
+                datasegment^.concat(new(pai_const,init_32bit(0)));
+              }
+              { auto table }
+              datasegment^.concat(new(pai_const,init_32bit(0)));
+              { interface table }
+              datasegment^.concat(new(pai_const,init_32bit(0)));
+              { table for string messages }
+              if (oo_has_msgstr in aktclass^.objectoptions) then
+                datasegment^.concat(new(pai_const_symbol,init(strmessagetable)))
+              else
+                datasegment^.concat(new(pai_const,init_32bit(0)));
+            end;
+           datasegment^.concatlist(@vmtlist);
+           vmtlist.done;
+           { write the size of the VMT }
+           datasegment^.concat(new(pai_symbol_end,initname(aktclass^.vmt_mangledname)));
+        end;
+
+      function readobjecttype : boolean;
+
+        begin
+           readobjecttype:=true;
+           { distinguish classes and objects }
+           case token of
+              _OBJECT:
+                begin
+                   classtype:=ct_object;
+                   consume(_OBJECT)
+                end;
+              _CPPCLASS:
+                begin
+                   classtype:=ct_cppclass;
+                   consume(_CPPCLASS);
+                end;
+{$ifdef SUPPORT_INTERFACE}
+              _INTERFACE:
+                begin
+                   if aktinterfacetype=it_interfacecom then
+                     objecttype:=ct_interfacecom
+                   else {it_interfaceraw}
+                     objecttype:=ct_interfaceraw;
+                   consume(_INTERFACE);
+                   { forward declaration }
+                   if not(assigned(fd)) and (token=_SEMICOLON) then
+                     begin
+                       { also anonym objects aren't allow (o : object a : longint; end;) }
+                       if n='' then
+                         Message(parser_f_no_anonym_objects);
+                       aktclass:=new(pobjectdef,init(objecttype,n,nil));
+                       if (cs_compilesystem in aktmoduleswitches) and
+                          (objecttype=odt_interfacecom) and (n='IUNKNOWN') then
+                         interface_iunknown:=aktclass;
+                       include(aktclass^.objectoptions,[oo_is_forward]);
+                     end;
+                end;
+{$endif SUPPORT_INTERFACE}
+              _CLASS:
+                begin
+                   classtype:=ct_class;
+                   consume(_CLASS);
+                   if not(assigned(fd)) and (token=_OF) then
+                     begin
+                        { a hack, but it's easy to handle }
+                        { class reference type }
+                        consume(_OF);
+                        single_type(tt,hs,typecanbeforward);
+
+                        { accept hp1, if is a forward def or a class }
+                        if (tt.def^.deftype=forwarddef) or
+                           ((tt.def^.deftype=objectdef) and pobjectdef(tt.def)^.is_class) then
+                          begin
+                             pcrd:=new(pclassrefdef,init(tt.def));
+                             object_dec:=pcrd;
+                          end
+                        else
+                          begin
+                             object_dec:=generrordef;
+                             Message1(type_e_class_type_expected,generrordef^.typename);
+                          end;
+                        typecanbeforward:=storetypecanbeforward;
+                        readobjecttype:=false;
+                        exit;
+                     end
+                   { forward class }
+                   else if not(assigned(fd)) and (token=_SEMICOLON) then
+                     begin
+                        { also anonym objects aren't allow (o : object a : longint; end;) }
+                        if n='' then
+                          Message(parser_f_no_anonym_objects);
+                        aktclass:=new(pobjectdef,init(n,nil));
+                        if (cs_compilesystem in aktmoduleswitches) and (n='TOBJECT') then
+                          class_tobject:=aktclass;
+                        aktclass^.objectoptions:=aktclass^.objectoptions+[oo_is_class,oo_is_forward];
+                        { all classes must have a vmt !!  at offset zero }
+                        if not(oo_has_vmt in aktclass^.objectoptions) then
+                          aktclass^.insertvmt;
+
+                        object_dec:=aktclass;
+                        typecanbeforward:=storetypecanbeforward;
+                        readobjecttype:=false;
+                        exit;
+                     end;
+                end;
+              else
+                begin
+                   classtype:=ct_class; { this is error but try to recover }
+                   consume(_OBJECT);
+                end;
+           end;
+        end;
+
+      procedure readparentclasses;
+
+        begin
+
+           { reads the parent class }
+           if token=_LKLAMMER then
+             begin
+                consume(_LKLAMMER);
+                id_type(tt,pattern,false);
+                childof:=pobjectdef(tt.def);
+                if (childof^.deftype<>objectdef) then
+                 begin
+                   Message1(type_e_class_type_expected,childof^.typename);
+                   childof:=nil;
+                   aktclass:=new(pobjectdef,init(n,nil));
+                 end
+                else
+                 begin
+                   { a mix of class, interfaces, objects and cppclasses
+                     isn't allowed }
+                   case classtype of
+                      ct_class:
+                        if not(childof^.is_class) and
+                          not(childof^.is_interface) then
+                          Message(parser_e_mix_of_classes_and_objects);
+                      ct_interfaceraw,
+                      ct_interfacecom:
+                        if not(childof^.is_interface) then
+                          Message(parser_e_mix_of_classes_and_objects);
+                      ct_cppclass:
+                        if not(childof^.is_cppclass) then
+                          Message(parser_e_mix_of_classes_and_objects);
+                      ct_object:
+                        if not(childof^.is_object) then
+                          Message(parser_e_mix_of_classes_and_objects);
+                   end;
+                   { the forward of the child must be resolved to get
+                     correct field addresses }
+                   if assigned(fd) then
+                    begin
+                      if (oo_is_forward in childof^.objectoptions) then
+                       Message1(parser_e_forward_declaration_must_be_resolved,childof^.objname^);
+                      aktclass:=fd;
+                      { we must inherit several options !!
+                        this was missing !!
+                        all is now done in set_parent
+                        including symtable datasize setting PM }
+                      fd^.set_parent(childof);
+                    end
+                   else
+                    aktclass:=new(pobjectdef,init(n,childof));
+                 end;
+                consume(_RKLAMMER);
+             end
+           { if no parent class, then a class get tobject as parent }
+           else if classtype=ct_class then
+             setclassparent
+           else
+             aktclass:=new(pobjectdef,init(n,nil));
+        end;
+
+      procedure chkcpp;
+
+        begin
+           if aktclass^.is_cppclass then
+             begin
+                {
+                include(aktprocsym^.definition^.proccalloptions,pocall_cppdecl);
+                aktprocsym^.definition^.setmangledname(
+                  target_os.Cprefix+aktprocsym^.definition^.cplusplusmangledname(realname));
+                }
+             end;
+        end;
+
+      var
+        temppd : pprocdef;
+      begin
+         {Nowadays aktprocsym may already have a value, so we need to save
+          it.}
+         oldprocsym:=aktprocsym;
+         { forward is resolved }
+         if assigned(fd) then
+           exclude(fd^.objectoptions,oo_is_forward);
+
+         there_is_a_destructor:=false;
+         actmembertype:=[sp_public];
+
+         { objects and class types can't be declared local }
+         if (symtablestack^.symtabletype<>globalsymtable) and
+           (symtablestack^.symtabletype<>staticsymtable) then
+           Message(parser_e_no_local_objects);
+
+         storetypecanbeforward:=typecanbeforward;
+         { for tp mode don't allow forward types }
+         if (m_tp in aktmodeswitches) and
+            not (m_delphi in aktmodeswitches) then
+           typecanbeforward:=false;
+
+         if not(readobjecttype) then
+           exit;
+
+         { also anonym objects aren't allow (o : object a : longint; end;) }
+         if n='' then
+           Message(parser_f_no_anonym_objects);
+
+         readparentclasses;
+
+         { default access is public }
+         actmembertype:=[sp_public];
+
+         { set class flags and inherits published, if necessary? }
+         setclassattributes;
+
+         aktobjectdef:=aktclass;
+         aktclass^.symtable^.next:=symtablestack;
+         symtablestack:=aktclass^.symtable;
+         testcurobject:=1;
+         curobjectname:=Upper(n);
+
+         { new procinfo }
+         oldprocinfo:=procinfo;
+         new(procinfo,init);
+         procinfo^._class:=aktclass;
+
+
+       { short class declaration ? }
+         if (classtype<>ct_class) or (token<>_SEMICOLON) then
+          begin
+          { Parse componenten }
+            repeat
+              if (sp_private in actmembertype) then
+                include(aktclass^.objectoptions,oo_has_private);
+              if (sp_protected in actmembertype) then
+                include(aktclass^.objectoptions,oo_has_protected);
+              case token of
+              _ID : begin
+                      case idtoken of
+                       _PRIVATE : begin
+                                    consume(_PRIVATE);
+                                    actmembertype:=[sp_private];
+                                    current_object_option:=[sp_private];
+                                  end;
+                     _PROTECTED : begin
+                                    consume(_PROTECTED);
+                                    current_object_option:=[sp_protected];
+                                    actmembertype:=[sp_protected];
+                                  end;
+                        _PUBLIC : begin
+                                    consume(_PUBLIC);
+                                    current_object_option:=[sp_public];
+                                    actmembertype:=[sp_public];
+                                  end;
+                     _PUBLISHED : begin
+                                    if not(oo_can_have_published in aktclass^.objectoptions) then
+                                     Message(parser_e_cant_have_published);
+                                    consume(_PUBLISHED);
+                                    current_object_option:=[sp_published];
+                                    actmembertype:=[sp_published];
+                                  end;
+                      else
+                        read_var_decs(false,true,false);
+                      end;
+                    end;
+        _PROPERTY : property_dec;
+       _PROCEDURE,
+        _FUNCTION,
+           _CLASS : begin
+                      oldparse_only:=parse_only;
+                      parse_only:=true;
+                      parse_proc_dec;
+{$ifndef newcg}
+                      parse_object_proc_directives(aktprocsym);
+{$endif newcg}
+                      { check if there are duplicates }
+                      check_identical_proc(temppd);
+                      if (po_msgint in aktprocsym^.definition^.procoptions) then
+                        include(aktclass^.objectoptions,oo_has_msgint);
+
+                      if (po_msgstr in aktprocsym^.definition^.procoptions) then
+                        include(aktclass^.objectoptions,oo_has_msgstr);
+
+                      if (po_virtualmethod in aktprocsym^.definition^.procoptions) then
+                        include(aktclass^.objectoptions,oo_has_virtual);
+
+                      chkcpp;
+
+                      parse_only:=oldparse_only;
+                    end;
+     _CONSTRUCTOR : begin
+                      if not(sp_public in actmembertype) then
+                        Message(parser_w_constructor_should_be_public);
+                      oldparse_only:=parse_only;
+                      parse_only:=true;
+                      constructor_head;
+{$ifndef newcg}
+                      parse_object_proc_directives(aktprocsym);
+{$endif newcg}
+                      if (po_virtualmethod in aktprocsym^.definition^.procoptions) then
+                        include(aktclass^.objectoptions,oo_has_virtual);
+
+                      chkcpp;
+
+                      parse_only:=oldparse_only;
+                    end;
+      _DESTRUCTOR : begin
+                      if there_is_a_destructor then
+                        Message(parser_n_only_one_destructor);
+                      there_is_a_destructor:=true;
+                      if not(sp_public in actmembertype) then
+                        Message(parser_w_destructor_should_be_public);
+                      oldparse_only:=parse_only;
+                      parse_only:=true;
+                      destructor_head;
+{$ifndef newcg}
+                      parse_object_proc_directives(aktprocsym);
+{$endif newcg}
+                      if (po_virtualmethod in aktprocsym^.definition^.procoptions) then
+                        include(aktclass^.objectoptions,oo_has_virtual);
+
+                      chkcpp;
+
+                      parse_only:=oldparse_only;
+                    end;
+             _END : begin
+                      consume(_END);
+                      break;
+                    end;
+              else
+               consume(_ID); { Give a ident expected message, like tp7 }
+              end;
+            until false;
+            current_object_option:=[sp_public];
+          end;
+         testcurobject:=0;
+         curobjectname:='';
+         typecanbeforward:=storetypecanbeforward;
+
+         { generate vmt space if needed }
+         if not(oo_has_vmt in aktclass^.objectoptions) and
+            ([oo_has_virtual,oo_has_constructor,oo_has_destructor,oo_is_class]*aktclass^.objectoptions<>[]) then
+           aktclass^.insertvmt;
+         if (cs_create_smart in aktmoduleswitches) then
+           datasegment^.concat(new(pai_cut,init));
+
+         if (oo_has_vmt in aktclass^.objectoptions) then
+           writevmt;
+
+         { restore old state }
+         symtablestack:=symtablestack^.next;
+         aktobjectdef:=nil;
+         {Restore procinfo}
+         dispose(procinfo,done);
+         procinfo:=oldprocinfo;
+         {Restore the aktprocsym.}
+         aktprocsym:=oldprocsym;
+
+         object_dec:=aktclass;
+      end;
+
+end.
+{
+  $Log$
+  Revision 1.1  2000-10-14 10:14:51  peter
+    * moehrendorf oct 2000 rewrite
+
+}

compiler/pdecsub.pas

@@ -0,0 +1,1823 @@
+{
+    $Id$
+    Copyright (c) 1998-2000 by Florian Klaempfl, Daniel Mantione
+
+    Does the parsing of the procedures/functions
+
+    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 pdecsub;
+
+{$i defines.inc}
+
+interface
+
+    uses
+      cobjects,tokens,symconst,symtable;
+
+    const
+      pd_global    = $1;    { directive must be global }
+      pd_body      = $2;    { directive needs a body }
+      pd_implemen  = $4;    { directive can be used implementation section }
+      pd_interface = $8;    { directive can be used interface section }
+      pd_object    = $10;   { directive can be used object declaration }
+      pd_procvar   = $20;   { directive can be used procvar declaration }
+      pd_notobject = $40;   { directive can not be used object declaration }
+
+    function  is_proc_directive(tok:ttoken):boolean;
+    function  check_identical_proc(var p : pprocdef) : boolean;
+
+    procedure parameter_dec(aktprocdef:pabstractprocdef);
+
+    procedure parse_proc_directives(Anames:Pstringcontainer;var pdflags:word);
+
+    procedure parse_proc_head(options:tproctypeoption);
+    procedure parse_proc_dec;
+    procedure parse_var_proc_directives(var sym : psym);
+    procedure parse_object_proc_directives(var sym : pprocsym);
+
+
+implementation
+
+    uses
+{$ifdef delphi}
+       sysutils,
+{$else delphi}
+       strings,
+{$endif delphi}
+       { common }
+       cutils,
+       { global }
+       globtype,globals,verbose,
+       systems,cpuinfo,
+       { aasm }
+       aasm,
+       { symtable }
+       types,
+{$ifdef GDB}
+       gdb,
+{$endif}
+       { pass 1 }
+       node,pass_1,htypechk,
+       nmat,nadd,ncal,nmem,nset,ncnv,ninl,ncon,nld,nflw,
+       { parser }
+       fmodule,scanner,
+       pbase,pexpr,ptype,pdecl,
+       { linking }
+       import,gendef,
+       { codegen }
+{$ifdef newcg}
+       cgbase
+{$else}
+       hcodegen
+{$endif}
+       ;
+
+    var
+      realname : string;  { contains the real name of a procedure as it's typed }
+
+
+    procedure parameter_dec(aktprocdef:pabstractprocdef);
+      {
+        handle_procvar needs the same changes
+      }
+      var
+        is_procvar : boolean;
+        sc      : Pstringcontainer;
+        s       : string;
+        hpos,
+        storetokenpos : tfileposinfo;
+        tt      : ttype;
+        hvs,
+        vs      : Pvarsym;
+        hs1,hs2 : string;
+        varspez : Tvarspez;
+        inserthigh : boolean;
+        pdefaultvalue : pconstsym;
+        defaultrequired : boolean;
+      begin
+        { reset }
+        defaultrequired:=false;
+        { parsing a proc or procvar ? }
+        is_procvar:=(aktprocdef^.deftype=procvardef);
+        consume(_LKLAMMER);
+        inc(testcurobject);
+        repeat
+          if try_to_consume(_VAR) then
+            varspez:=vs_var
+          else
+            if try_to_consume(_CONST) then
+              varspez:=vs_const
+          else
+            if try_to_consume(_OUT) then
+              varspez:=vs_out
+          else
+              varspez:=vs_value;
+          inserthigh:=false;
+          pdefaultvalue:=nil;
+          tt.reset;
+          { self is only allowed in procvars and class methods }
+          if (idtoken=_SELF) and
+             (is_procvar or
+              (assigned(procinfo^._class) and procinfo^._class^.is_class)) then
+            begin
+              if not is_procvar then
+               begin
+{$ifndef UseNiceNames}
+                 hs2:=hs2+'$'+'self';
+{$else UseNiceNames}
+                 hs2:=hs2+tostr(length('self'))+'self';
+{$endif UseNiceNames}
+                 vs:=new(Pvarsym,initdef('@',procinfo^._class));
+                 vs^.varspez:=vs_var;
+               { insert the sym in the parasymtable }
+                 pprocdef(aktprocdef)^.parast^.insert(vs);
+                 include(aktprocdef^.procoptions,po_containsself);
+                 inc(procinfo^.selfpointer_offset,vs^.address);
+               end;
+              consume(idtoken);
+              consume(_COLON);
+              single_type(tt,hs1,false);
+              aktprocdef^.concatpara(tt,vs_value,nil);
+              { check the types for procedures only }
+              if not is_procvar then
+               CheckTypes(tt.def,procinfo^._class);
+            end
+          else
+            begin
+             { read identifiers }
+               sc:=idlist;
+{$ifdef fixLeaksOnError}
+               strContStack.push(sc);
+{$endif fixLeaksOnError}
+             { read type declaration, force reading for value and const paras }
+               if (token=_COLON) or (varspez=vs_value) then
+                begin
+                  consume(_COLON);
+                { check for an open array }
+                  if token=_ARRAY then
+                   begin
+                     consume(_ARRAY);
+                     consume(_OF);
+                   { define range and type of range }
+                     tt.setdef(new(Parraydef,init(0,-1,s32bitdef)));
+                   { array of const ? }
+                     if (token=_CONST) and (m_objpas in aktmodeswitches) then
+                      begin
+                        consume(_CONST);
+                        srsym:=nil;
+                        getsymonlyin(systemunit,'TVARREC');
+                        if not assigned(srsym) then
+                         InternalError(1234124);
+                        Parraydef(tt.def)^.elementtype:=ptypesym(srsym)^.restype;
+                        Parraydef(tt.def)^.IsArrayOfConst:=true;
+                        hs1:='array_of_const';
+                      end
+                     else
+                      begin
+                        { define field type }
+                        single_type(parraydef(tt.def)^.elementtype,hs1,false);
+                        hs1:='array_of_'+hs1;
+                      end;
+                     inserthigh:=true;
+                   end
+                  else
+                   begin
+                     { open string ? }
+                     if (varspez=vs_var) and
+                             (
+                               (
+                                 ((token=_STRING) or (idtoken=_SHORTSTRING)) and
+                                 (cs_openstring in aktmoduleswitches) and
+                                 not(cs_ansistrings in aktlocalswitches)
+                               ) or
+                             (idtoken=_OPENSTRING)) then
+                      begin
+                        consume(token);
+                        tt.setdef(openshortstringdef);
+                        hs1:='openstring';
+                        inserthigh:=true;
+                      end
+                     else
+                      begin
+                        { everything else }
+                        single_type(tt,hs1,false);
+                      end;
+                     { default parameter }
+                     if (m_default_para in aktmodeswitches) then
+                      begin
+                        if try_to_consume(_EQUAL) then
+                         begin
+                           s:=sc^.get_with_tokeninfo(hpos);
+                           if not sc^.empty then
+                            Comment(V_Error,'default value only allowed for one parameter');
+                           sc^.insert_with_tokeninfo(s,hpos);
+                           { prefix 'def' to the parameter name }
+                           pdefaultvalue:=ReadConstant('$def'+Upper(s),hpos);
+                           if assigned(pdefaultvalue) then
+                            pprocdef(aktprocdef)^.parast^.insert(pdefaultvalue);
+                           defaultrequired:=true;
+                         end
+                        else
+                         begin
+                           if defaultrequired then
+                            Comment(V_Error,'default parameter required');
+                         end;
+                      end;
+                   end;
+                end
+               else
+                begin
+{$ifndef UseNiceNames}
+                  hs1:='$$$';
+{$else UseNiceNames}
+                  hs1:='var';
+{$endif UseNiceNames}
+                  tt.setdef(cformaldef);
+                end;
+               if not is_procvar then
+                hs2:=pprocdef(aktprocdef)^.mangledname;
+               storetokenpos:=tokenpos;
+               while not sc^.empty do
+                begin
+                  s:=sc^.get_with_tokeninfo(tokenpos);
+                  aktprocdef^.concatpara(tt,varspez,pdefaultvalue);
+                  { For proc vars we only need the definitions }
+                  if not is_procvar then
+                   begin
+{$ifndef UseNiceNames}
+                     hs2:=hs2+'$'+hs1;
+{$else UseNiceNames}
+                     hs2:=hs2+tostr(length(hs1))+hs1;
+{$endif UseNiceNames}
+                     vs:=new(pvarsym,init(s,tt));
+                     vs^.varspez:=varspez;
+                   { we have to add this to avoid var param to be in registers !!!}
+                   { I don't understand the comment above,                          }
+                   { but I suppose the comment is wrong and                         }
+                   { it means that the address of var parameters can be placed      }
+                   { in a register (FK)                                             }
+                     if (varspez in [vs_var,vs_const,vs_out]) and push_addr_param(tt.def) then
+                       include(vs^.varoptions,vo_regable);
+
+                   { insert the sym in the parasymtable }
+                     pprocdef(aktprocdef)^.parast^.insert(vs);
+
+                   { do we need a local copy? Then rename the varsym, do this after the
+                     insert so the dup id checking is done correctly }
+                     if (varspez=vs_value) and
+                        push_addr_param(tt.def) and
+                        not(is_open_array(tt.def) or is_array_of_const(tt.def)) then
+                       pprocdef(aktprocdef)^.parast^.rename(vs^.name,'val'+vs^.name);
+
+                   { also need to push a high value? }
+                     if inserthigh then
+                      begin
+                        hvs:=new(Pvarsym,initdef('$high'+Upper(s),s32bitdef));
+                        hvs^.varspez:=vs_const;
+                        pprocdef(aktprocdef)^.parast^.insert(hvs);
+                      end;
+
+                   end;
+                end;
+{$ifdef fixLeaksOnError}
+               if PStringContainer(strContStack.pop) <> sc then
+                  writeln('problem with strContStack in pdecl (1)');
+{$endif fixLeaksOnError}
+               dispose(sc,done);
+               tokenpos:=storetokenpos;
+            end;
+          { set the new mangled name }
+          if not is_procvar then
+            pprocdef(aktprocdef)^.setmangledname(hs2);
+        until not try_to_consume(_SEMICOLON);
+        dec(testcurobject);
+        consume(_RKLAMMER);
+      end;
+
+
+
+
+procedure parse_proc_head(options:tproctypeoption);
+var sp:stringid;
+    pd:Pprocdef;
+    paramoffset:longint;
+    sym:Psym;
+    hs:string;
+    st : psymtable;
+    overloaded_level:word;
+    storepos,procstartfilepos : tfileposinfo;
+begin
+{ Save the position where this procedure really starts and set col to 1 which
+  looks nicer }
+  procstartfilepos:=tokenpos;
+{  procstartfilepos.column:=1; I do not agree here !!
+   lets keep excat position PM }
+
+  if (options=potype_operator) then
+    begin
+      sp:=overloaded_names[optoken];
+      realname:=sp;
+    end
+  else
+    begin
+      sp:=pattern;
+      realname:=orgpattern;
+      consume(_ID);
+    end;
+
+{ method ? }
+  if not(parse_only) and
+     (lexlevel=normal_function_level) and
+     try_to_consume(_POINT) then
+   begin
+     storepos:=tokenpos;
+     tokenpos:=procstartfilepos;
+     getsym(sp,true);
+     sym:=srsym;
+     tokenpos:=storepos;
+     { load proc name }
+     sp:=pattern;
+     realname:=orgpattern;
+     procstartfilepos:=tokenpos;
+     { qualifier is class name ? }
+     if (sym^.typ<>typesym) or
+        (ptypesym(sym)^.restype.def^.deftype<>objectdef) then
+       begin
+          Message(parser_e_class_id_expected);
+          aktprocsym:=nil;
+          consume(_ID);
+       end
+     else
+       begin
+          { used to allow private syms to be seen }
+          aktobjectdef:=pobjectdef(ptypesym(sym)^.restype.def);
+          procinfo^._class:=pobjectdef(ptypesym(sym)^.restype.def);
+          aktprocsym:=pprocsym(procinfo^._class^.symtable^.search(sp));
+          consume(_ID);
+          {The procedure has been found. So it is
+           a global one. Set the flags to mark this.}
+          procinfo^.flags:=procinfo^.flags or pi_is_global;
+          aktobjectdef:=nil;
+          { we solve this below }
+          if not(assigned(aktprocsym)) then
+            Message(parser_e_methode_id_expected);
+       end;
+   end
+  else
+   begin
+     { check for constructor/destructor which is not allowed here }
+     if (not parse_only) and
+        (options in [potype_constructor,potype_destructor]) then
+        Message(parser_e_constructors_always_objects);
+
+     tokenpos:=procstartfilepos;
+     aktprocsym:=pprocsym(symtablestack^.search(sp));
+
+     if not(parse_only) then
+       begin
+         {The procedure we prepare for is in the implementation
+          part of the unit we compile. It is also possible that we
+          are compiling a program, which is also some kind of
+          implementaion part.
+
+          We need to find out if the procedure is global. If it is
+          global, it is in the global symtable.}
+         if not assigned(aktprocsym) and
+            (symtablestack^.symtabletype=staticsymtable) then
+          begin
+            {Search the procedure in the global symtable.}
+            aktprocsym:=Pprocsym(search_a_symtable(sp,globalsymtable));
+            if assigned(aktprocsym) then
+             begin
+               {Check if it is a procedure.}
+               if aktprocsym^.typ<>procsym then
+                DuplicateSym(aktprocsym);
+               {The procedure has been found. So it is
+                a global one. Set the flags to mark this.}
+               procinfo^.flags:=procinfo^.flags or pi_is_global;
+             end;
+          end;
+       end;
+   end;
+
+{ Create the mangledname }
+{$ifndef UseNiceNames}
+  if assigned(procinfo^._class) then
+   begin
+     if (pos('_$$_',procprefix)=0) then
+      hs:=procprefix+'_$$_'+procinfo^._class^.objname^+'_$$_'+sp
+     else
+      hs:=procprefix+'_$'+sp;
+   end
+  else
+   begin
+     if lexlevel=normal_function_level then
+      hs:=procprefix+'_'+sp
+     else
+      hs:=procprefix+'_$'+sp;
+   end;
+{$else UseNiceNames}
+  if assigned(procinfo^._class) then
+   begin
+     if (pos('_5Class_',procprefix)=0) then
+      hs:=procprefix+'_5Class_'+procinfo^._class^.name^+'_'+tostr(length(sp))+sp
+     else
+      hs:=procprefix+'_'+tostr(length(sp))+sp;
+   end
+  else
+   begin
+     if lexlevel=normal_function_level then
+      hs:=procprefix+'_'+tostr(length(sp))+sp
+     else
+      hs:=lowercase(procprefix)+'_'+tostr(length(sp))+sp;
+   end;
+{$endif UseNiceNames}
+
+  if assigned(aktprocsym) then
+   begin
+     { Check if overloaded is a procsym, we use a different error message
+       for tp7 so it looks more compatible }
+     if aktprocsym^.typ<>procsym then
+      begin
+        if (m_fpc in aktmodeswitches) then
+         Message1(parser_e_overloaded_no_procedure,aktprocsym^.name)
+        else
+         DuplicateSym(aktprocsym);
+        { try to recover by creating a new aktprocsym }
+        tokenpos:=procstartfilepos;
+        aktprocsym:=new(pprocsym,init(sp));
+      end;
+   end
+  else
+   begin
+     { create a new procsym and set the real filepos }
+     tokenpos:=procstartfilepos;
+     { for operator we have only one definition for each overloaded
+       operation }
+     if (options=potype_operator) then
+       begin
+          { create the procsym with saving the original case }
+          aktprocsym:=new(pprocsym,init('$'+sp));
+          { the only problem is that nextoverloaded might not be in a unit
+            known for the unit itself }
+          { not anymore PM }
+          if assigned(overloaded_operators[optoken]) then
+            aktprocsym^.definition:=overloaded_operators[optoken]^.definition;
+{$ifndef DONOTCHAINOPERATORS}
+          overloaded_operators[optoken]:=aktprocsym;
+{$endif DONOTCHAINOPERATORS}
+       end
+      else
+       aktprocsym:=new(pprocsym,init(sp));
+     symtablestack^.insert(aktprocsym);
+   end;
+
+  st:=symtablestack;
+  pd:=new(pprocdef,init);
+  pd^.symtablelevel:=symtablestack^.symtablelevel;
+
+  if assigned(procinfo^._class) then
+    pd^._class := procinfo^._class;
+
+  { set the options from the caller (podestructor or poconstructor) }
+  pd^.proctypeoption:=options;
+
+  { calculate the offset of the parameters }
+  paramoffset:=8;
+
+  { calculate frame pointer offset }
+  if lexlevel>normal_function_level then
+    begin
+      procinfo^.framepointer_offset:=paramoffset;
+      inc(paramoffset,target_os.size_of_pointer);
+      { this is needed to get correct framepointer push for local
+        forward functions !! }
+      pd^.parast^.symtablelevel:=lexlevel;
+    end;
+
+  if assigned (procinfo^._Class)  and
+     not(procinfo^._Class^.is_class) and
+     (pd^.proctypeoption in [potype_constructor,potype_destructor]) then
+    inc(paramoffset,target_os.size_of_pointer);
+
+  { self pointer offset                       }
+  { self isn't pushed in nested procedure of methods }
+  if assigned(procinfo^._class) and (lexlevel=normal_function_level) then
+    begin
+      procinfo^.selfpointer_offset:=paramoffset;
+      if assigned(aktprocsym^.definition) and
+         not(po_containsself in aktprocsym^.definition^.procoptions) then
+        inc(paramoffset,target_os.size_of_pointer);
+    end;
+
+  { con/-destructor flag ? }
+  if assigned (procinfo^._Class) and
+     procinfo^._class^.is_class and
+     (pd^.proctypeoption in [potype_destructor,potype_constructor]) then
+    inc(paramoffset,target_os.size_of_pointer);
+
+  procinfo^.para_offset:=paramoffset;
+
+  pd^.parast^.datasize:=0;
+
+  pd^.nextoverloaded:=aktprocsym^.definition;
+  aktprocsym^.definition:=pd;
+  { this is probably obsolete now PM }
+  aktprocsym^.definition^.fileinfo:=procstartfilepos;
+  aktprocsym^.definition^.setmangledname(hs);
+  aktprocsym^.definition^.procsym:=aktprocsym;
+
+  if not parse_only then
+    begin
+       overloaded_level:=0;
+       { we need another procprefix !!! }
+       { count, but only those in the same unit !!}
+       while assigned(pd) and
+          (pd^.owner^.symtabletype in [globalsymtable,staticsymtable]) do
+         begin
+            { only count already implemented functions }
+            if  not(pd^.forwarddef) then
+              inc(overloaded_level);
+            pd:=pd^.nextoverloaded;
+         end;
+       if overloaded_level>0 then
+         procprefix:=hs+'$'+tostr(overloaded_level)+'$'
+       else
+         procprefix:=hs+'$';
+    end;
+
+  { this must also be inserted in the right symtable !! PM }
+  { otherwise we get subbtle problems with
+    definitions of args defs in staticsymtable for
+    implementation of a global method }
+  if token=_LKLAMMER then
+    parameter_dec(aktprocsym^.definition);
+
+  { so we only restore the symtable now }
+  symtablestack:=st;
+  if (options=potype_operator) then
+    overloaded_operators[optoken]:=aktprocsym;
+end;
+
+
+procedure parse_proc_dec;
+var
+  hs : string;
+  isclassmethod : boolean;
+begin
+  inc(lexlevel);
+{ read class method }
+  if token=_CLASS then
+   begin
+     consume(_CLASS);
+     isclassmethod:=true;
+   end
+  else
+   isclassmethod:=false;
+  case token of
+     _FUNCTION : begin
+                   consume(_FUNCTION);
+                   parse_proc_head(potype_none);
+                   if token<>_COLON then
+                    begin
+                       if not(aktprocsym^.definition^.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(aktprocsym^.definition^.rettype,hs,false);
+                      aktprocsym^.definition^.test_if_fpu_result;
+                      dec(testcurobject);
+                    end;
+                 end;
+    _PROCEDURE : begin
+                   consume(_PROCEDURE);
+                   parse_proc_head(potype_none);
+                   aktprocsym^.definition^.rettype.def:=voiddef;
+                 end;
+  _CONSTRUCTOR : begin
+                   consume(_CONSTRUCTOR);
+                   parse_proc_head(potype_constructor);
+                   if assigned(procinfo^._class) and
+                      procinfo^._class^.is_class then
+                    begin
+                      { CLASS constructors return the created instance }
+                      aktprocsym^.definition^.rettype.def:=procinfo^._class;
+                    end
+                   else
+                    begin
+                      { OBJECT constructors return a boolean }
+{$IfDef GDB}
+                      { GDB doesn't like unnamed types !}
+                      aktprocsym^.definition^.rettype.def:=globaldef('boolean');
+{$else GDB}
+                      aktprocsym^.definition^.rettype.def:=new(porddef,init(bool8bit,0,1));
+{$Endif GDB}
+                    end;
+                 end;
+   _DESTRUCTOR : begin
+                   consume(_DESTRUCTOR);
+                   parse_proc_head(potype_destructor);
+                   aktprocsym^.definition^.rettype.def:=voiddef;
+                 end;
+     _OPERATOR : begin
+                   if lexlevel>normal_function_level then
+                     Message(parser_e_no_local_operator);
+                   consume(_OPERATOR);
+                   if not(token in [_PLUS..last_overloaded]) then
+                     Message(parser_e_overload_operator_failed);
+                   optoken:=token;
+                   consume(Token);
+                   procinfo^.flags:=procinfo^.flags or pi_operator;
+                   parse_proc_head(potype_operator);
+                   if token<>_ID then
+                     begin
+                        opsym:=nil;
+                        if not(m_result in aktmodeswitches) then
+                          consume(_ID);
+                     end
+                   else
+                     begin
+                       opsym:=new(pvarsym,initdef(pattern,voiddef));
+                       consume(_ID);
+                     end;
+                   if not try_to_consume(_COLON) then
+                     begin
+                       consume(_COLON);
+                       aktprocsym^.definition^.rettype.def:=generrordef;
+                       consume_all_until(_SEMICOLON);
+                     end
+                   else
+                    begin
+                      single_type(aktprocsym^.definition^.rettype,hs,false);
+                      aktprocsym^.definition^.test_if_fpu_result;
+                      if (optoken in [_EQUAL,_GT,_LT,_GTE,_LTE]) and
+                         ((aktprocsym^.definition^.rettype.def^.deftype<>
+                         orddef) or (porddef(aktprocsym^.definition^.
+                         rettype.def)^.typ<>bool8bit)) then
+                        Message(parser_e_comparative_operator_return_boolean);
+                       if assigned(opsym) then
+                         opsym^.vartype.def:=aktprocsym^.definition^.rettype.def;
+                       { We need to add the return type in the mangledname
+                         to allow overloading with just different results !! (PM) }
+                       aktprocsym^.definition^.setmangledname(
+                         aktprocsym^.definition^.mangledname+'$$'+hs);
+                       if (optoken=_ASSIGNMENT) and
+                          is_equal(aktprocsym^.definition^.rettype.def,
+                             pvarsym(aktprocsym^.definition^.parast^.symindex^.first)^.vartype.def) then
+                         message(parser_e_no_such_assignment)
+                       else if not isoperatoracceptable(aktprocsym^.definition,optoken) then
+                         Message(parser_e_overload_impossible);
+                     end;
+                 end;
+  end;
+  if isclassmethod and
+     assigned(aktprocsym) then
+    include(aktprocsym^.definition^.procoptions,po_classmethod);
+  { support procedure proc;stdcall export; in Delphi mode only }
+  if not((m_delphi in aktmodeswitches) and
+     is_proc_directive(token)) then
+   consume(_SEMICOLON);
+  dec(lexlevel);
+end;
+
+
+{****************************************************************************
+                        Procedure directive handlers
+****************************************************************************}
+
+procedure pd_far(const procnames:Tstringcontainer);
+begin
+  Message(parser_w_proc_far_ignored);
+end;
+
+procedure pd_near(const procnames:Tstringcontainer);
+begin
+  Message(parser_w_proc_near_ignored);
+end;
+
+procedure pd_export(const procnames:Tstringcontainer);
+begin
+  if assigned(procinfo^._class) then
+    Message(parser_e_methods_dont_be_export);
+  if lexlevel<>normal_function_level then
+    Message(parser_e_dont_nest_export);
+  { only os/2 needs this }
+  if target_info.target=target_i386_os2 then
+   begin
+     procnames.insert(realname);
+     procinfo^.exported:=true;
+     if cs_link_deffile in aktglobalswitches then
+       deffile.AddExport(aktprocsym^.definition^.mangledname);
+   end;
+end;
+
+procedure pd_inline(const procnames:Tstringcontainer);
+begin
+  if not(cs_support_inline in aktmoduleswitches) then
+   Message(parser_e_proc_inline_not_supported);
+end;
+
+procedure pd_forward(const procnames:Tstringcontainer);
+begin
+  aktprocsym^.definition^.forwarddef:=true;
+end;
+
+procedure pd_stdcall(const procnames:Tstringcontainer);
+begin
+end;
+
+procedure pd_safecall(const procnames:Tstringcontainer);
+begin
+end;
+
+procedure pd_alias(const procnames:Tstringcontainer);
+begin
+  consume(_COLON);
+  procnames.insert(get_stringconst);
+end;
+
+procedure pd_asmname(const procnames:Tstringcontainer);
+begin
+  aktprocsym^.definition^.setmangledname(target_os.Cprefix+pattern);
+  if token=_CCHAR then
+    consume(_CCHAR)
+  else
+    consume(_CSTRING);
+  { we don't need anything else }
+  aktprocsym^.definition^.forwarddef:=false;
+end;
+
+procedure pd_intern(const procnames:Tstringcontainer);
+begin
+  consume(_COLON);
+  aktprocsym^.definition^.extnumber:=get_intconst;
+end;
+
+procedure pd_interrupt(const procnames:Tstringcontainer);
+begin
+{$ifndef i386}
+  Message(parser_w_proc_interrupt_ignored);
+{$else i386}
+  if lexlevel<>normal_function_level then
+    Message(parser_e_dont_nest_interrupt);
+{$endif i386}
+end;
+
+procedure pd_system(const procnames:Tstringcontainer);
+begin
+  aktprocsym^.definition^.setmangledname(realname);
+end;
+
+procedure pd_abstract(const procnames:Tstringcontainer);
+begin
+  if (po_virtualmethod in aktprocsym^.definition^.procoptions) then
+    include(aktprocsym^.definition^.procoptions,po_abstractmethod)
+  else
+    Message(parser_e_only_virtual_methods_abstract);
+  { the method is defined }
+  aktprocsym^.definition^.forwarddef:=false;
+end;
+
+procedure pd_virtual(const procnames:Tstringcontainer);
+{$ifdef WITHDMT}
+var
+  pt : tnode;
+{$endif WITHDMT}
+begin
+  if (aktprocsym^.definition^.proctypeoption=potype_constructor) and
+     not(aktprocsym^.definition^._class^.is_class) then
+    Message(parser_e_constructor_cannot_be_not_virtual);
+{$ifdef WITHDMT}
+  if not(aktprocsym^.definition^._class^.is_class) and
+    (token<>_SEMICOLON) then
+    begin
+       { any type of parameter is allowed here! }
+
+       pt:=comp_expr(true);
+       do_firstpass(pt);
+       if is_constintnode(pt) then
+         begin
+           include(aktprocsym^.definition^.procoptions,po_msgint);
+           aktprocsym^.definition^.messageinf.i:=pt^.value;
+         end
+       else
+         Message(parser_e_ill_msg_expr);
+       disposetree(pt);
+    end;
+{$endif WITHDMT}
+end;
+
+procedure pd_static(const procnames:Tstringcontainer);
+begin
+  if (cs_static_keyword in aktmoduleswitches) then
+    begin
+      include(aktprocsym^.symoptions,sp_static);
+      include(aktprocsym^.definition^.procoptions,po_staticmethod);
+    end;
+end;
+
+procedure pd_override(const procnames:Tstringcontainer);
+begin
+  if not(aktprocsym^.definition^._class^.is_class) then
+    Message(parser_e_no_object_override);
+end;
+
+procedure pd_overload(const procnames:Tstringcontainer);
+begin
+end;
+
+procedure pd_message(const procnames:Tstringcontainer);
+var
+  pt : tnode;
+begin
+  { check parameter type }
+  if not(po_containsself in aktprocsym^.definition^.procoptions) and
+     ((aktprocsym^.definition^.minparacount<>1) or
+      (aktprocsym^.definition^.maxparacount<>1) or
+      (pparaitem(aktprocsym^.definition^.para^.first)^.paratyp<>vs_var)) then
+   Message(parser_e_ill_msg_param);
+  pt:=comp_expr(true);
+  do_firstpass(pt);
+  if pt.nodetype=stringconstn then
+    begin
+      include(aktprocsym^.definition^.procoptions,po_msgstr);
+      aktprocsym^.definition^.messageinf.str:=strnew(tstringconstnode(pt).value_str);
+    end
+  else
+   if is_constintnode(pt) then
+    begin
+      include(aktprocsym^.definition^.procoptions,po_msgint);
+      aktprocsym^.definition^.messageinf.i:=tordconstnode(pt).value;
+    end
+  else
+    Message(parser_e_ill_msg_expr);
+  pt.free;
+end;
+
+
+procedure resetvaluepara(p:pnamedindexobject);
+begin
+  if psym(p)^.typ=varsym then
+    with pvarsym(p)^ do
+       if copy(name,1,3)='val' then
+          aktprocsym^.definition^.parast^.symsearch^.rename(name,copy(name,4,length(name)));
+end;
+
+
+procedure pd_cdecl(const procnames:Tstringcontainer);
+begin
+  if aktprocsym^.definition^.deftype<>procvardef then
+    aktprocsym^.definition^.setmangledname(target_os.Cprefix+realname);
+  { do not copy on local !! }
+  if (aktprocsym^.definition^.deftype=procdef) and
+     assigned(aktprocsym^.definition^.parast) then
+    aktprocsym^.definition^.parast^.foreach({$ifdef FPCPROCVAR}@{$endif}resetvaluepara);
+end;
+
+procedure pd_cppdecl(const procnames:Tstringcontainer);
+begin
+  if aktprocsym^.definition^.deftype<>procvardef then
+    aktprocsym^.definition^.setmangledname(
+      target_os.Cprefix+aktprocsym^.definition^.cplusplusmangledname(realname));
+  { do not copy on local !! }
+  if (aktprocsym^.definition^.deftype=procdef) and
+     assigned(aktprocsym^.definition^.parast) then
+    aktprocsym^.definition^.parast^.foreach({$ifdef FPCPROCVAR}@{$endif}resetvaluepara);
+end;
+
+
+procedure pd_pascal(const procnames:Tstringcontainer);
+var st,parast : psymtable;
+    lastps,ps : psym;
+begin
+   new(st,init(parasymtable));
+   parast:=aktprocsym^.definition^.parast;
+   lastps:=nil;
+   while assigned(parast^.symindex^.first) and (lastps<>psym(parast^.symindex^.first)) do
+     begin
+       ps:=psym(parast^.symindex^.first);
+       while assigned(ps^.indexnext) and (psym(ps^.indexnext)<>lastps) do
+         ps:=psym(ps^.indexnext);
+       ps^.owner:=st;
+       { recalculate the corrected offset }
+       { the really_insert_in_data procedure
+         for parasymtable should only calculateoffset PM }
+       ps^.insert_in_data;
+       { reset the owner correctly }
+       ps^.owner:=parast;
+       lastps:=ps;
+     end;
+end;
+
+
+procedure pd_register(const procnames:Tstringcontainer);
+begin
+  Message1(parser_w_proc_directive_ignored,'REGISTER');
+end;
+
+
+procedure pd_reintroduce(const procnames:Tstringcontainer);
+begin
+  Message1(parser_w_proc_directive_ignored,'REINTRODUCE');
+end;
+
+
+procedure pd_syscall(const procnames:Tstringcontainer);
+begin
+  aktprocsym^.definition^.forwarddef:=false;
+  aktprocsym^.definition^.extnumber:=get_intconst;
+end;
+
+
+procedure pd_external(const procnames:Tstringcontainer);
+{
+  If import_dll=nil the procedure is assumed to be in another
+  object file. In that object file it should have the name to
+  which import_name is pointing to. Otherwise, the procedure is
+  assumed to be in the DLL to which import_dll is pointing to. In
+  that case either import_nr<>0 or import_name<>nil is true, so
+  the procedure is either imported by number or by name. (DM)
+}
+var
+  import_dll,
+  import_name : string;
+  import_nr   : word;
+begin
+  aktprocsym^.definition^.forwarddef:=false;
+{ If the procedure should be imported from a DLL, a constant string follows.
+  This isn't really correct, an contant string expression follows
+  so we check if an semicolon follows, else a string constant have to
+  follow (FK) }
+  import_nr:=0;
+  import_name:='';
+  if not(token=_SEMICOLON) and not(idtoken=_NAME) then
+    begin
+      import_dll:=get_stringconst;
+      if (idtoken=_NAME) then
+       begin
+         consume(_NAME);
+         import_name:=get_stringconst;
+       end;
+      if (idtoken=_INDEX) then
+       begin
+         {After the word index follows the index number in the DLL.}
+         consume(_INDEX);
+         import_nr:=get_intconst;
+       end;
+      if (import_nr=0) and (import_name='') then
+        {if (aktprocsym^.definition^.options and pocdecl)<>0 then
+          import_name:=aktprocsym^.definition^.mangledname
+        else
+          Message(parser_w_empty_import_name);}
+        { this should work both for win32 and Linux !! PM }
+        import_name:=realname;
+      if not(current_module^.uses_imports) then
+       begin
+         current_module^.uses_imports:=true;
+         importlib^.preparelib(current_module^.modulename^);
+       end;
+      if not(m_repeat_forward in aktmodeswitches) then
+        begin
+          { we can only have one overloaded here ! }
+          if assigned(aktprocsym^.definition^.nextoverloaded) then
+            importlib^.importprocedure(aktprocsym^.definition^.nextoverloaded^.mangledname,
+              import_dll,import_nr,import_name)
+          else
+            importlib^.importprocedure(aktprocsym^.mangledname,import_dll,import_nr,import_name);
+        end
+      else
+        importlib^.importprocedure(aktprocsym^.mangledname,import_dll,import_nr,import_name);
+    end
+  else
+    begin
+      if (idtoken=_NAME) then
+       begin
+         consume(_NAME);
+         import_name:=get_stringconst;
+         aktprocsym^.definition^.setmangledname(import_name);
+       end
+      else
+       begin
+         { external shouldn't override the cdecl/system name }
+         if not (pocall_clearstack in aktprocsym^.definition^.proccalloptions) then
+           aktprocsym^.definition^.setmangledname(aktprocsym^.name);
+       end;
+    end;
+end;
+
+type
+   pd_handler=procedure(const procnames:Tstringcontainer);
+   proc_dir_rec=record
+     idtok     : ttoken;
+     pd_flags  : longint;
+     handler   : pd_handler;
+     pocall    : tproccalloptions;
+     pooption  : tprocoptions;
+     mutexclpocall : tproccalloptions;
+     mutexclpotype : tproctypeoptions;
+     mutexclpo     : tprocoptions;
+   end;
+const
+  {Should contain the number of procedure directives we support.}
+  num_proc_directives=32;
+  proc_direcdata:array[1..num_proc_directives] of proc_dir_rec=
+   (
+    (
+      idtok:_ABSTRACT;
+      pd_flags : pd_interface+pd_object;
+      handler  : {$ifdef FPCPROCVAR}@{$endif}pd_abstract;
+      pocall   : [];
+      pooption : [po_abstractmethod];
+      mutexclpocall : [pocall_internproc,pocall_inline];
+      mutexclpotype : [potype_constructor,potype_destructor];
+      mutexclpo     : [po_exports,po_interrupt,po_external]
+    ),(
+      idtok:_ALIAS;
+      pd_flags : pd_implemen+pd_body;
+      handler  : {$ifdef FPCPROCVAR}@{$endif}pd_alias;
+      pocall   : [];
+      pooption : [];
+      mutexclpocall : [pocall_inline];
+      mutexclpotype : [];
+      mutexclpo     : [po_external]
+    ),(
+      idtok:_ASMNAME;
+      pd_flags : pd_interface+pd_implemen;
+      handler  : {$ifdef FPCPROCVAR}@{$endif}pd_asmname;
+      pocall   : [pocall_cdecl,pocall_clearstack];
+      pooption : [po_external];
+      mutexclpocall : [pocall_internproc];
+      mutexclpotype : [];
+      mutexclpo     : [po_external]
+    ),(
+      idtok:_ASSEMBLER;
+      pd_flags : pd_implemen+pd_body;
+      handler  : nil;
+      pocall   : [];
+      pooption : [po_assembler];
+      mutexclpocall : [];
+      mutexclpotype : [];
+      mutexclpo     : [po_external]
+    ),(
+      idtok:_CDECL;
+      pd_flags : pd_interface+pd_implemen+pd_body+pd_procvar;
+      handler  : {$ifdef FPCPROCVAR}@{$endif}pd_cdecl;
+      pocall   : [pocall_cdecl,pocall_clearstack];
+      pooption : [po_savestdregs];
+      mutexclpocall : [pocall_cppdecl,pocall_internproc,pocall_leftright,pocall_inline];
+      mutexclpotype : [];
+      mutexclpo     : [po_assembler,po_external]
+    ),(
+      idtok:_DYNAMIC;
+      pd_flags : pd_interface+pd_object;
+      handler  : {$ifdef FPCPROCVAR}@{$endif}pd_virtual;
+      pocall   : [];
+      pooption : [po_virtualmethod];
+      mutexclpocall : [pocall_internproc,pocall_inline];
+      mutexclpotype : [];
+      mutexclpo     : [po_exports,po_interrupt,po_external]
+    ),(
+      idtok:_EXPORT;
+      pd_flags : pd_body+pd_global+pd_interface+pd_implemen{??};
+      handler  : {$ifdef FPCPROCVAR}@{$endif}pd_export;
+      pocall   : [];
+      pooption : [po_exports];
+      mutexclpocall : [pocall_internproc,pocall_inline];
+      mutexclpotype : [];
+      mutexclpo     : [po_external,po_interrupt]
+    ),(
+      idtok:_EXTERNAL;
+      pd_flags : pd_implemen+pd_interface;
+      handler  : {$ifdef FPCPROCVAR}@{$endif}pd_external;
+      pocall   : [];
+      pooption : [po_external];
+      mutexclpocall : [pocall_internproc,pocall_inline,pocall_palmossyscall];
+      mutexclpotype : [];
+      mutexclpo     : [po_exports,po_interrupt,po_assembler]
+    ),(
+      idtok:_FAR;
+      pd_flags : pd_implemen+pd_body+pd_interface+pd_procvar;
+      handler  : {$ifdef FPCPROCVAR}@{$endif}pd_far;
+      pocall   : [];
+      pooption : [];
+      mutexclpocall : [pocall_internproc,pocall_inline];
+      mutexclpotype : [];
+      mutexclpo     : []
+    ),(
+      idtok:_FORWARD;
+      pd_flags : pd_implemen;
+      handler  : {$ifdef FPCPROCVAR}@{$endif}pd_forward;
+      pocall   : [];
+      pooption : [];
+      mutexclpocall : [pocall_internproc,pocall_inline];
+      mutexclpotype : [];
+      mutexclpo     : [po_external]
+    ),(
+      idtok:_INLINE;
+      pd_flags : pd_implemen+pd_body;
+      handler  : {$ifdef FPCPROCVAR}@{$endif}pd_inline;
+      pocall   : [pocall_inline];
+      pooption : [];
+      mutexclpocall : [pocall_internproc];
+      mutexclpotype : [potype_constructor,potype_destructor];
+      mutexclpo     : [po_exports,po_external,po_interrupt]
+    ),(
+      idtok:_INTERNCONST;
+      pd_flags : pd_implemen+pd_body;
+      handler  : {$ifdef FPCPROCVAR}@{$endif}pd_intern;
+      pocall   : [pocall_internconst];
+      pooption : [];
+      mutexclpocall : [];
+      mutexclpotype : [potype_operator];
+      mutexclpo     : []
+    ),(
+      idtok:_INTERNPROC;
+      pd_flags : pd_implemen;
+      handler  : {$ifdef FPCPROCVAR}@{$endif}pd_intern;
+      pocall   : [pocall_internproc];
+      pooption : [];
+      mutexclpocall : [pocall_inline,pocall_clearstack,pocall_leftright,pocall_cdecl,pocall_cppdecl];
+      mutexclpotype : [potype_constructor,potype_destructor,potype_operator];
+      mutexclpo     : [po_exports,po_external,po_interrupt,po_assembler,po_iocheck]
+    ),(
+      idtok:_INTERRUPT;
+      pd_flags : pd_implemen+pd_body;
+      handler  : {$ifdef FPCPROCVAR}@{$endif}pd_interrupt;
+      pocall   : [];
+      pooption : [po_interrupt];
+      mutexclpocall : [pocall_internproc,pocall_cdecl,pocall_cppdecl,pocall_clearstack,pocall_leftright,pocall_inline];
+      mutexclpotype : [potype_constructor,potype_destructor,potype_operator];
+      mutexclpo     : [po_external]
+    ),(
+      idtok:_IOCHECK;
+      pd_flags : pd_implemen+pd_body;
+      handler  : nil;
+      pocall   : [];
+      pooption : [po_iocheck];
+      mutexclpocall : [pocall_internproc];
+      mutexclpotype : [];
+      mutexclpo     : [po_external]
+    ),(
+      idtok:_MESSAGE;
+      pd_flags : pd_interface+pd_object;
+      handler  : {$ifdef FPCPROCVAR}@{$endif}pd_message;
+      pocall   : [];
+      pooption : []; { can be po_msgstr or po_msgint }
+      mutexclpocall : [pocall_inline,pocall_internproc];
+      mutexclpotype : [potype_constructor,potype_destructor,potype_operator];
+      mutexclpo     : [po_interrupt,po_external]
+    ),(
+      idtok:_NEAR;
+      pd_flags : pd_implemen+pd_body+pd_procvar;
+      handler  : {$ifdef FPCPROCVAR}@{$endif}pd_near;
+      pocall   : [];
+      pooption : [];
+      mutexclpocall : [pocall_internproc];
+      mutexclpotype : [];
+      mutexclpo     : []
+    ),(
+      idtok:_OVERLOAD;
+      pd_flags : pd_implemen+pd_interface+pd_body;
+      handler  : {$ifdef FPCPROCVAR}@{$endif}pd_overload;
+      pocall   : [];
+      pooption : [po_overload];
+      mutexclpocall : [pocall_internproc];
+      mutexclpotype : [];
+      mutexclpo     : []
+    ),(
+      idtok:_OVERRIDE;
+      pd_flags : pd_interface+pd_object;
+      handler  : {$ifdef FPCPROCVAR}@{$endif}pd_override;
+      pocall   : [];
+      pooption : [po_overridingmethod,po_virtualmethod];
+      mutexclpocall : [pocall_inline,pocall_internproc];
+      mutexclpotype : [];
+      mutexclpo     : [po_exports,po_external,po_interrupt]
+    ),(
+      idtok:_PASCAL;
+      pd_flags : pd_implemen+pd_body+pd_procvar;
+      handler  : {$ifdef FPCPROCVAR}@{$endif}pd_pascal;
+      pocall   : [pocall_leftright];
+      pooption : [];
+      mutexclpocall : [pocall_internproc];
+      mutexclpotype : [];
+      mutexclpo     : [po_external]
+    ),(
+      idtok:_POPSTACK;
+      pd_flags : pd_interface+pd_implemen+pd_body+pd_procvar;
+      handler  : nil;
+      pocall   : [pocall_clearstack];
+      pooption : [];
+      mutexclpocall : [pocall_inline,pocall_internproc];
+      mutexclpotype : [];
+      mutexclpo     : [po_assembler,po_external]
+    ),(
+      idtok:_PUBLIC;
+      pd_flags : pd_implemen+pd_body+pd_global+pd_notobject;
+      handler  : nil;
+      pocall   : [];
+      pooption : [];
+      mutexclpocall : [pocall_internproc,pocall_inline];
+      mutexclpotype : [];
+      mutexclpo     : [po_external]
+    ),(
+      idtok:_REGISTER;
+      pd_flags : pd_interface+pd_implemen+pd_body+pd_procvar;
+      handler  : {$ifdef FPCPROCVAR}@{$endif}pd_register;
+      pocall   : [pocall_register];
+      pooption : [];
+      mutexclpocall : [pocall_leftright,pocall_cdecl,pocall_internproc,pocall_cppdecl];
+      mutexclpotype : [];
+      mutexclpo     : [po_external]
+    ),(
+      idtok:_REINTRODUCE;
+      pd_flags : pd_interface+pd_object;
+      handler  : {$ifdef FPCPROCVAR}@{$endif}pd_reintroduce;
+      pocall   : [];
+      pooption : [];
+      mutexclpocall : [];
+      mutexclpotype : [];
+      mutexclpo     : []
+    ),(
+      idtok:_SAFECALL;
+      pd_flags : pd_interface+pd_implemen+pd_body+pd_procvar;
+      handler  : {$ifdef FPCPROCVAR}@{$endif}pd_safecall;
+      pocall   : [pocall_safecall];
+      pooption : [po_savestdregs];
+      mutexclpocall : [pocall_leftright,pocall_cdecl,pocall_cppdecl,pocall_internproc,pocall_inline];
+      mutexclpotype : [];
+      mutexclpo     : [po_external]
+    ),(
+      idtok:_SAVEREGISTERS;
+      pd_flags : pd_interface+pd_implemen+pd_body+pd_procvar;
+      handler  : nil;
+      pocall   : [];
+      pooption : [po_saveregisters];
+      mutexclpocall : [pocall_internproc];
+      mutexclpotype : [];
+      mutexclpo     : [po_external]
+    ),(
+      idtok:_STATIC;
+      pd_flags : pd_interface+pd_object;
+      handler  : {$ifdef FPCPROCVAR}@{$endif}pd_static;
+      pocall   : [];
+      pooption : [po_staticmethod];
+      mutexclpocall : [pocall_inline,pocall_internproc];
+      mutexclpotype : [potype_constructor,potype_destructor];
+      mutexclpo     : [po_external,po_interrupt,po_exports]
+    ),(
+      idtok:_STDCALL;
+      pd_flags : pd_interface+pd_implemen+pd_body+pd_procvar;
+      handler  : {$ifdef FPCPROCVAR}@{$endif}pd_stdcall;
+      pocall   : [pocall_stdcall];
+      pooption : [po_savestdregs];
+      mutexclpocall : [pocall_leftright,pocall_cdecl,pocall_cppdecl,pocall_inline,pocall_internproc];
+      mutexclpotype : [];
+      mutexclpo     : [po_external]
+    ),(
+      idtok:_SYSCALL;
+      pd_flags : pd_interface;
+      handler  : {$ifdef FPCPROCVAR}@{$endif}pd_syscall;
+      pocall   : [pocall_palmossyscall];
+      pooption : [];
+      mutexclpocall : [pocall_cdecl,pocall_cppdecl,pocall_inline,pocall_internproc];
+      mutexclpotype : [];
+      mutexclpo     : [po_external,po_assembler,po_interrupt,po_exports]
+    ),(
+      idtok:_SYSTEM;
+      pd_flags : pd_implemen;
+      handler  : {$ifdef FPCPROCVAR}@{$endif}pd_system;
+      pocall   : [pocall_clearstack];
+      pooption : [];
+      mutexclpocall : [pocall_leftright,pocall_inline,pocall_internproc];
+      mutexclpotype : [];
+      mutexclpo     : [po_external,po_assembler,po_interrupt]
+    ),(
+      idtok:_VIRTUAL;
+      pd_flags : pd_interface+pd_object;
+      handler  : {$ifdef FPCPROCVAR}@{$endif}pd_virtual;
+      pocall   : [];
+      pooption : [po_virtualmethod];
+      mutexclpocall : [pocall_inline,pocall_internproc];
+      mutexclpotype : [];
+      mutexclpo     : [po_external,po_interrupt,po_exports]
+    ),(
+      idtok:_CPPDECL;
+      pd_flags : pd_interface+pd_implemen+pd_body+pd_procvar;
+      handler  : {$ifdef FPCPROCVAR}@{$endif}pd_cppdecl;
+      pocall   : [pocall_cppdecl,pocall_clearstack];
+      pooption : [po_savestdregs];
+      mutexclpocall : [pocall_cdecl,pocall_internproc,pocall_leftright,pocall_inline];
+      mutexclpotype : [];
+      mutexclpo     : [po_assembler,po_external]
+    )
+   );
+
+
+function is_proc_directive(tok:ttoken):boolean;
+var
+  i : longint;
+begin
+  is_proc_directive:=false;
+  for i:=1 to num_proc_directives do
+   if proc_direcdata[i].idtok=idtoken then
+    begin
+      is_proc_directive:=true;
+      exit;
+    end;
+end;
+
+
+function parse_proc_direc(const proc_names:Tstringcontainer;var pdflags:word):boolean;
+{
+  Parse the procedure directive, returns true if a correct directive is found
+}
+var
+  p     : longint;
+  found : boolean;
+  name  : string;
+begin
+  parse_proc_direc:=false;
+  name:=pattern;
+  found:=false;
+  for p:=1 to num_proc_directives do
+   if proc_direcdata[p].idtok=idtoken then
+    begin
+      found:=true;
+      break;
+    end;
+
+{ Check if the procedure directive is known }
+  if not found then
+   begin
+      { parsing a procvar type the name can be any
+        next variable !! }
+      if (pdflags and (pd_procvar or pd_object))=0 then
+        Message1(parser_w_unknown_proc_directive_ignored,name);
+      exit;
+   end;
+
+  { static needs a special treatment }
+  if (idtoken=_STATIC) and not (cs_static_keyword in aktmoduleswitches) then
+    exit;
+
+{ Conflicts between directives ? }
+  if (aktprocsym^.definition^.proctypeoption in proc_direcdata[p].mutexclpotype) or
+     ((aktprocsym^.definition^.proccalloptions*proc_direcdata[p].mutexclpocall)<>[]) or
+     ((aktprocsym^.definition^.procoptions*proc_direcdata[p].mutexclpo)<>[]) then
+   begin
+     Message1(parser_e_proc_dir_conflict,name);
+     exit;
+   end;
+
+{ Check if the directive is only for objects }
+  if ((proc_direcdata[p].pd_flags and pd_object)<>0) and
+     not assigned(aktprocsym^.definition^._class) then
+    begin
+      exit;
+    end;
+{ check if method and directive not for object public }
+  if ((proc_direcdata[p].pd_flags and pd_notobject)<>0) and
+     assigned(aktprocsym^.definition^._class) then
+    begin
+      exit;
+    end;
+
+{ consume directive, and turn flag on }
+  consume(token);
+  parse_proc_direc:=true;
+
+{ Check the pd_flags if the directive should be allowed }
+  if ((pdflags and pd_interface)<>0) and
+     ((proc_direcdata[p].pd_flags and pd_interface)=0) then
+    begin
+      Message1(parser_e_proc_dir_not_allowed_in_interface,name);
+      exit;
+    end;
+  if ((pdflags and pd_implemen)<>0) and
+     ((proc_direcdata[p].pd_flags and pd_implemen)=0) then
+    begin
+      Message1(parser_e_proc_dir_not_allowed_in_implementation,name);
+      exit;
+    end;
+  if ((pdflags and pd_procvar)<>0) and
+     ((proc_direcdata[p].pd_flags and pd_procvar)=0) then
+    begin
+      Message1(parser_e_proc_dir_not_allowed_in_procvar,name);
+      exit;
+    end;
+
+{ Return the new pd_flags }
+  if (proc_direcdata[p].pd_flags and pd_body)=0 then
+    pdflags:=pdflags and (not pd_body);
+  if (proc_direcdata[p].pd_flags and pd_global)<>0 then
+    pdflags:=pdflags or pd_global;
+
+{ Add the correct flag }
+  aktprocsym^.definition^.proccalloptions:=aktprocsym^.definition^.proccalloptions+proc_direcdata[p].pocall;
+  aktprocsym^.definition^.procoptions:=aktprocsym^.definition^.procoptions+proc_direcdata[p].pooption;
+
+ { Adjust positions of args for cdecl or stdcall }
+   if (aktprocsym^.definition^.deftype=procdef) and
+      (([pocall_cdecl,pocall_cppdecl,pocall_stdcall]*aktprocsym^.definition^.proccalloptions)<>[]) then
+     aktprocsym^.definition^.parast^.set_alignment(target_os.size_of_longint);
+
+{ Call the handler }
+  if pointer({$ifndef FPC}@{$endif}proc_direcdata[p].handler)<>nil then
+    proc_direcdata[p].handler(proc_names);
+end;
+
+
+procedure parse_proc_directives(Anames:Pstringcontainer;var pdflags:word);
+{
+  Parse the procedure directives. It does not matter if procedure directives
+  are written using ;procdir; or ['procdir'] syntax.
+}
+var
+  res : boolean;
+begin
+  while token in [_ID,_LECKKLAMMER] do
+   begin
+     if try_to_consume(_LECKKLAMMER) then
+      begin
+        repeat
+          parse_proc_direc(Anames^,pdflags);
+        until not try_to_consume(_COMMA);
+        consume(_RECKKLAMMER);
+        { we always expect at least '[];' }
+        res:=true;
+      end
+     else
+      res:=parse_proc_direc(Anames^,pdflags);
+   { A procedure directive normally followed by a semicolon, but in
+     a const section we should stop when _EQUAL is found }
+     if res then
+      begin
+        if (block_type=bt_const) and
+           (token=_EQUAL) then
+         break;
+        { support procedure proc;stdcall export; in Delphi mode only }
+        if not((m_delphi in aktmodeswitches) and
+               is_proc_directive(token)) then
+         consume(_SEMICOLON);
+      end
+     else
+      break;
+   end;
+end;
+
+procedure parse_var_proc_directives(var sym : psym);
+var
+  anames  : pstringcontainer;
+  pdflags : word;
+  oldsym  : pprocsym;
+  pd      : pabstractprocdef;
+begin
+  oldsym:=aktprocsym;
+  anames:=new(pstringcontainer,init);
+  pdflags:=pd_procvar;
+  { we create a temporary aktprocsym to read the directives }
+  aktprocsym:=new(pprocsym,init(sym^.name));
+  case sym^.typ of
+    varsym :
+      pd:=pabstractprocdef(pvarsym(sym)^.vartype.def);
+    typedconstsym :
+      pd:=pabstractprocdef(ptypedconstsym(sym)^.typedconsttype.def);
+    typesym :
+      pd:=pabstractprocdef(ptypesym(sym)^.restype.def);
+    else
+      internalerror(994932432);
+  end;
+  if pd^.deftype<>procvardef then
+   internalerror(994932433);
+  pabstractprocdef(aktprocsym^.definition):=pd;
+  { names should never be used anyway }
+  inc(lexlevel);
+  parse_proc_directives(anames,pdflags);
+  dec(lexlevel);
+  aktprocsym^.definition:=nil;
+  dispose(aktprocsym,done);
+  dispose(anames,done);
+  aktprocsym:=oldsym;
+end;
+
+
+procedure parse_object_proc_directives(var sym : pprocsym);
+var
+  anames : pstringcontainer;
+  pdflags : word;
+begin
+  pdflags:=pd_object;
+  anames:=new(pstringcontainer,init);
+  inc(lexlevel);
+  parse_proc_directives(anames,pdflags);
+  dec(lexlevel);
+  dispose(anames,done);
+  if (po_containsself in aktprocsym^.definition^.procoptions) and
+     (([po_msgstr,po_msgint]*aktprocsym^.definition^.procoptions)=[]) then
+    Message(parser_e_self_in_non_message_handler);
+end;
+
+{***************************************************************************}
+
+function check_identical_proc(var p : pprocdef) : boolean;
+{
+  Search for idendical definitions,
+  if there is a forward, then kill this.
+
+  Returns the result of the forward check.
+
+  Removed from unter_dec to keep the source readable
+}
+var
+  hd,pd : Pprocdef;
+  storeparast : psymtable;
+  ad,fd : psym;
+  s : string;
+begin
+  check_identical_proc:=false;
+  p:=nil;
+  pd:=aktprocsym^.definition;
+  if assigned(pd) then
+   begin
+   { Is there an overload/forward ? }
+     if assigned(pd^.nextoverloaded) then
+      begin
+      { walk the procdef list }
+        while (assigned(pd)) and (assigned(pd^.nextoverloaded)) do
+         begin
+           hd:=pd^.nextoverloaded;
+
+           { check the parameters }
+           if (not(m_repeat_forward in aktmodeswitches) and
+               (aktprocsym^.definition^.maxparacount=0)) or
+              (equal_paras(aktprocsym^.definition^.para,hd^.para,cp_none) and
+              { for operators equal_paras is not enough !! }
+              ((aktprocsym^.definition^.proctypeoption<>potype_operator) or (optoken<>_ASSIGNMENT) or
+               is_equal(hd^.rettype.def,aktprocsym^.definition^.rettype.def))) then
+             begin
+               if not equal_paras(aktprocsym^.definition^.para,hd^.para,cp_all) and
+                  ((m_repeat_forward in aktmodeswitches) or
+                   (aktprocsym^.definition^.maxparacount>0)) then
+                 begin
+                    MessagePos1(aktprocsym^.definition^.fileinfo,parser_e_header_dont_match_forward,
+                                aktprocsym^.demangledName);
+                    exit;
+                 end;
+               if hd^.forwarddef then
+               { remove the forward definition  but don't delete it,      }
+               { the symtable is the owner !!  }
+                 begin
+                 { Check if the procedure type and return type are correct }
+                   if (hd^.proctypeoption<>aktprocsym^.definition^.proctypeoption) or
+                      (not(is_equal(hd^.rettype.def,aktprocsym^.definition^.rettype.def)) and
+                      (m_repeat_forward in aktmodeswitches)) then
+                     begin
+                       MessagePos1(aktprocsym^.definition^.fileinfo,parser_e_header_dont_match_forward,
+                                   aktprocsym^.demangledName);
+                       exit;
+                     end;
+                   { Check calling convention, no check for internconst,internproc which
+                     are only defined in interface or implementation }
+                   if (hd^.proccalloptions-[pocall_internconst,pocall_internproc]<>
+                       aktprocsym^.definition^.proccalloptions-[pocall_internconst,pocall_internproc]) then
+                    begin
+                      { only trigger an error, becuase it doesn't hurt, for delphi check
+                        if the current implementation has no proccalloptions, then
+                        take the options from the interface }
+                      if (m_delphi in aktmodeswitches) then
+                       begin
+                         if (aktprocsym^.definition^.proccalloptions=[]) then
+                          aktprocsym^.definition^.proccalloptions:=hd^.proccalloptions
+                         else
+                          MessagePos(aktprocsym^.definition^.fileinfo,parser_e_call_convention_dont_match_forward);
+                       end
+                      else
+                       MessagePos(aktprocsym^.definition^.fileinfo,parser_e_call_convention_dont_match_forward);
+                      { set the mangledname to the interface name so it doesn't trigger
+                        the Note about different manglednames (PFV) }
+                      aktprocsym^.definition^.setmangledname(hd^.mangledname);
+                    end;
+                   { manglednames are equal? }
+                   hd^.count:=false;
+                   if (m_repeat_forward in aktmodeswitches) or
+                      aktprocsym^.definition^.haspara then
+                    begin
+                      if (hd^.mangledname<>aktprocsym^.definition^.mangledname) then
+                       begin
+                         if not(po_external in aktprocsym^.definition^.procoptions) then
+                           MessagePos2(aktprocsym^.definition^.fileinfo,parser_n_interface_name_diff_implementation_name,hd^.mangledname,
+                             aktprocsym^.definition^.mangledname);
+                       { reset the mangledname of the interface part to be sure }
+                       { this is wrong because the mangled name might have been used already !! }
+                          if hd^.is_used then
+                            renameasmsymbol(hd^.mangledname,aktprocsym^.definition^.mangledname);
+                          hd^.setmangledname(aktprocsym^.definition^.mangledname);
+                       { so we need to keep the name of interface !!
+                         No!!!! The procedure directives can change the mangledname.
+                         I fixed this by first calling check_identical_proc and then doing
+                         the proc directives, but this is not a good solution.(DM)}
+                         { this is also wrong (PM)
+                         aktprocsym^.definition^.setmangledname(hd^.mangledname);}
+                       end
+                      else
+                       begin
+                       { If mangled names are equal, therefore    }
+                       { they have the same number of parameters  }
+                       { Therefore we can check the name of these }
+                       { parameters...                      }
+                         if hd^.forwarddef and aktprocsym^.definition^.forwarddef then
+                           begin
+                             MessagePos1(aktprocsym^.definition^.fileinfo,
+                                         parser_e_function_already_declared_public_forward,aktprocsym^.demangledName);
+                             check_identical_proc:=true;
+                           { Remove other forward from the list to reduce errors }
+                             pd^.nextoverloaded:=pd^.nextoverloaded^.nextoverloaded;
+                             exit;
+                           end;
+                         ad:=psym(hd^.parast^.symindex^.first);
+                         fd:=psym(aktprocsym^.definition^.parast^.symindex^.first);
+                         if assigned(ad) and assigned(fd) then
+                           begin
+                             while assigned(ad) and assigned(fd) do
+                               begin
+                                 s:=ad^.name;
+                                 if s<>fd^.name then
+                                   begin
+                                     MessagePos3(aktprocsym^.definition^.fileinfo,parser_e_header_different_var_names,
+                                       aktprocsym^.name,s,fd^.name);
+                                     break;
+                                   end;
+                               { it is impossible to have a nil pointer }
+                               { for only one parameter - since they    }
+                               { have the same number of parameters.    }
+                               { Left = next parameter.          }
+                                 ad:=psym(ad^.left);
+                                 fd:=psym(fd^.left);
+                               end;
+                           end;
+                       end;
+                    end;
+                 { also the para_offset }
+                   hd^.parast^.address_fixup:=aktprocsym^.definition^.parast^.address_fixup;
+                   hd^.count:=true;
+
+                 { remove pd^.nextoverloaded from the list }
+                 { and add aktprocsym^.definition }
+                   pd^.nextoverloaded:=pd^.nextoverloaded^.nextoverloaded;
+                   hd^.nextoverloaded:=aktprocsym^.definition^.nextoverloaded;
+                 { Alert! All fields of aktprocsym^.definition that are modified
+                   by the procdir handlers must be copied here!.}
+                   hd^.forwarddef:=false;
+                   hd^.hasforward:=true;
+                   hd^.proccalloptions:=hd^.proccalloptions + aktprocsym^.definition^.proccalloptions;
+                   hd^.procoptions:=hd^.procoptions + aktprocsym^.definition^.procoptions;
+                   if aktprocsym^.definition^.extnumber=-1 then
+                     aktprocsym^.definition^.extnumber:=hd^.extnumber
+                   else
+                     if hd^.extnumber=-1 then
+                       hd^.extnumber:=aktprocsym^.definition^.extnumber;
+                   { switch parast for warning in implementation  PM }
+                   if (m_repeat_forward in aktmodeswitches) or
+                      aktprocsym^.definition^.haspara then
+                     begin
+                        storeparast:=hd^.parast;
+                        hd^.parast:=aktprocsym^.definition^.parast;
+                        aktprocsym^.definition^.parast:=storeparast;
+                     end;
+                   if pd=aktprocsym^.definition then
+                     p:=nil
+                   else
+                     p:=pd;
+                   aktprocsym^.definition:=hd;
+                   check_identical_proc:=true;
+                 end
+               else
+               { abstract methods aren't forward defined, but this }
+               { needs another error message                   }
+                 if not(po_abstractmethod in pd^.nextoverloaded^.procoptions) then
+                   MessagePos(aktprocsym^.definition^.fileinfo,parser_e_overloaded_have_same_parameters)
+                 else
+                   MessagePos(aktprocsym^.definition^.fileinfo,parser_e_abstract_no_definition);
+               break;
+             end;
+
+           { check for allowing overload directive }
+           if not(m_fpc in aktmodeswitches) then
+            begin
+              { overload directive turns on overloading }
+              if ((po_overload in aktprocsym^.definition^.procoptions) or
+                  ((po_overload in hd^.procoptions))) then
+               begin
+                 { check if all procs have overloading, but not if the proc was
+                   already declared forward, then the check is already done }
+                 if not(hd^.hasforward) and
+                    (aktprocsym^.definition^.forwarddef=hd^.forwarddef) and
+                    not((po_overload in aktprocsym^.definition^.procoptions) and
+                        ((po_overload in hd^.procoptions))) then
+                  begin
+                    MessagePos1(aktprocsym^.definition^.fileinfo,parser_e_no_overload_for_all_procs,aktprocsym^.name);
+                    break;
+                  end;
+               end
+              else
+               begin
+                 if not(hd^.forwarddef) then
+                  begin
+                    MessagePos(aktprocsym^.definition^.fileinfo,parser_e_procedure_overloading_is_off);
+                    break;
+                  end;
+               end;
+            end;
+
+           { try next overloaded }
+           pd:=pd^.nextoverloaded;
+         end;
+      end
+     else
+      begin
+      { there is no overloaded, so its always identical with itself }
+        check_identical_proc:=true;
+      end;
+   end;
+{ insert opsym only in the right symtable }
+  if ((procinfo^.flags and pi_operator)<>0) and assigned(opsym)
+     and not parse_only then
+    begin
+      if ret_in_param(aktprocsym^.definition^.rettype.def) then
+        begin
+          pprocdef(aktprocsym^.definition)^.parast^.insert(opsym);
+        { this increases the data size }
+        { correct this to get the right ret $value }
+          dec(pprocdef(aktprocsym^.definition)^.parast^.datasize,opsym^.getpushsize);
+          { this allows to read the funcretoffset }
+          opsym^.address:=-4;
+          opsym^.varspez:=vs_var;
+        end
+      else
+        pprocdef(aktprocsym^.definition)^.localst^.insert(opsym);
+    end;
+end;
+
+
+
+procedure checkvaluepara(p:pnamedindexobject);
+var
+  vs : pvarsym;
+  s  : string;
+begin
+  with pvarsym(p)^ do
+   begin
+     if copy(name,1,3)='val' then
+      begin
+        s:=Copy(name,4,255);
+        if not(po_assembler in aktprocsym^.definition^.procoptions) then
+         begin
+           vs:=new(Pvarsym,initdef(s,vartype.def));
+           vs^.fileinfo:=fileinfo;
+           vs^.varspez:=varspez;
+           aktprocsym^.definition^.localst^.insert(vs);
+           include(vs^.varoptions,vo_is_local_copy);
+           vs^.varstate:=vs_assigned;
+           localvarsym:=vs;
+           inc(refs); { the para was used to set the local copy ! }
+           { warnings only on local copy ! }
+           varstate:=vs_used;
+         end
+        else
+         begin
+           aktprocsym^.definition^.parast^.rename(name,s);
+         end;
+      end;
+   end;
+end;
+
+end.
+{
+  $Log$
+  Revision 1.1  2000-10-14 10:14:51  peter
+    * moehrendorf oct 2000 rewrite
+
+}

compiler/pdecvar.pas

@@ -0,0 +1,533 @@
+{
+    $Id$
+    Copyright (c) 1998-2000 by Florian Klaempfl
+
+    Parses variable declarations. Used for var statement and record
+    definitions
+
+    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 pdecvar;
+
+{$i defines.inc}
+
+{$define UseUnionSymtable}
+
+interface
+
+    procedure read_var_decs(is_record,is_object,is_threadvar:boolean);
+
+
+implementation
+
+    uses
+       { common }
+       cutils,cobjects,
+       { global }
+       globtype,globals,tokens,verbose,
+       systems,cpuinfo,
+       { aasm }
+       aasm,
+       { symtable }
+       symconst,symtable,types,fmodule,
+{$ifdef GDB}
+       gdb,
+{$endif}
+       { pass 1 }
+       node,pass_1,htypechk,
+       nmat,nadd,ncal,nmem,nset,ncnv,ninl,ncon,nld,nflw,
+       { parser }
+       scanner,
+       pbase,pexpr,ptype,ptconst,pdecsub,
+       { link }
+       import,
+       { codegen }
+{$ifdef newcg}
+       cgbase
+{$else}
+       hcodegen
+{$endif}
+       ;
+
+    const
+       variantrecordlevel : longint = 0;
+
+    procedure read_var_decs(is_record,is_object,is_threadvar:boolean);
+    { reads the filed of a record into a        }
+    { symtablestack, if record=false        }
+    { variants are forbidden, so this procedure }
+    { can be used to read object fields  }
+    { if absolute is true, ABSOLUTE and file    }
+    { types are allowed                  }
+    { => the procedure is also used to read     }
+    { a sequence of variable declaration        }
+
+      procedure insert_syms(st : psymtable;sc : pstringcontainer;tt : ttype;is_threadvar : boolean);
+      { inserts the symbols of sc in st with def as definition or sym as ptypesym, sc is disposed }
+        var
+           s : string;
+           filepos : tfileposinfo;
+           ss : pvarsym;
+        begin
+           filepos:=tokenpos;
+           while not sc^.empty do
+             begin
+                s:=sc^.get_with_tokeninfo(tokenpos);
+                ss:=new(pvarsym,init(s,tt));
+                if is_threadvar then
+                  include(ss^.varoptions,vo_is_thread_var);
+                st^.insert(ss);
+                { static data fields are inserted in the globalsymtable }
+                if (st^.symtabletype=objectsymtable) and
+                   (sp_static in current_object_option) then
+                  begin
+                     s:=lower(st^.name^)+'_'+s;
+                     st^.defowner^.owner^.insert(new(pvarsym,init(s,tt)));
+                  end;
+             end;
+{$ifdef fixLeaksOnError}
+             if strContStack.pop <> sc then
+               writeln('problem with strContStack in pdecl (2)');
+{$endif fixLeaksOnError}
+           dispose(sc,done);
+           tokenpos:=filepos;
+        end;
+
+      var
+         sc : pstringcontainer;
+         s : stringid;
+         old_block_type : tblock_type;
+         declarepos,storetokenpos : tfileposinfo;
+         symdone : boolean;
+         { to handle absolute }
+         abssym : pabsolutesym;
+         l    : longint;
+         code : integer;
+         { c var }
+         newtype : ptypesym;
+         is_dll,
+         is_gpc_name,is_cdecl,extern_aktvarsym,export_aktvarsym : boolean;
+         old_current_object_option : tsymoptions;
+         dll_name,
+         C_name : string;
+         tt,casetype : ttype;
+         { Delphi initialized vars }
+         pconstsym : ptypedconstsym;
+         { maxsize contains the max. size of a variant }
+         { startvarrec contains the start of the variant part of a record }
+         maxsize,maxalignment,startvarrecalign,startvarrecsize : longint;
+         pt : tnode;
+{$ifdef UseUnionSymtable}
+         unionsymtable : psymtable;
+         offset : longint;
+         uniondef : precorddef;
+         unionsym : pvarsym;
+         uniontype : ttype;
+{$endif UseUnionSymtable}
+      begin
+         old_current_object_option:=current_object_option;
+         { all variables are public if not in a object declaration }
+         if not is_object then
+          current_object_option:=[sp_public];
+         old_block_type:=block_type;
+         block_type:=bt_type;
+         is_gpc_name:=false;
+         { Force an expected ID error message }
+         if not (token in [_ID,_CASE,_END]) then
+          consume(_ID);
+         { read vars }
+         while (token=_ID) and
+               not(is_object and (idtoken in [_PUBLIC,_PRIVATE,_PUBLISHED,_PROTECTED])) do
+           begin
+             C_name:=orgpattern;
+             sc:=idlist;
+{$ifdef fixLeaksOnError}
+             strContStack.push(sc);
+{$endif fixLeaksOnError}
+             consume(_COLON);
+             if (m_gpc in aktmodeswitches) and
+                not(is_record or is_object or is_threadvar) and
+                (token=_ID) and (orgpattern='__asmname__') then
+               begin
+                 consume(_ID);
+                 C_name:=pattern;
+                 if token=_CCHAR then
+                  consume(_CCHAR)
+                 else
+                  consume(_CSTRING);
+                 Is_gpc_name:=true;
+               end;
+             { this is needed for Delphi mode at least
+               but should be OK for all modes !! (PM) }
+             ignore_equal:=true;
+             read_type(tt,'');
+             if (variantrecordlevel>0) and tt.def^.needs_inittable then
+               Message(parser_e_cant_use_inittable_here);
+             ignore_equal:=false;
+             symdone:=false;
+             if is_gpc_name then
+               begin
+                  storetokenpos:=tokenpos;
+                  s:=sc^.get_with_tokeninfo(tokenpos);
+                  if not sc^.empty then
+                   Message(parser_e_absolute_only_one_var);
+{$ifdef fixLeaksOnError}
+                   if strContStack.pop <> sc then
+                     writeln('problem with strContStack in pdecl (3)');
+{$endif fixLeaksOnError}
+                  dispose(sc,done);
+                  aktvarsym:=new(pvarsym,init_C(s,target_os.Cprefix+C_name,tt));
+                  include(aktvarsym^.varoptions,vo_is_external);
+                  symtablestack^.insert(aktvarsym);
+                  tokenpos:=storetokenpos;
+                  symdone:=true;
+               end;
+             { check for absolute }
+             if not symdone and
+                (idtoken=_ABSOLUTE) and not(is_record or is_object or is_threadvar) then
+              begin
+                consume(_ABSOLUTE);
+                { only allowed for one var }
+                s:=sc^.get_with_tokeninfo(declarepos);
+                if not sc^.empty then
+                 Message(parser_e_absolute_only_one_var);
+{$ifdef fixLeaksOnError}
+                 if strContStack.pop <> sc then
+                   writeln('problem with strContStack in pdecl (4)');
+{$endif fixLeaksOnError}
+                dispose(sc,done);
+                { parse the rest }
+                if token=_ID then
+                 begin
+                   getsym(pattern,true);
+                   consume(_ID);
+                   { support unit.variable }
+                   if srsym^.typ=unitsym then
+                    begin
+                      consume(_POINT);
+                      getsymonlyin(punitsym(srsym)^.unitsymtable,pattern);
+                      consume(_ID);
+                    end;
+                   { we should check the result type of srsym }
+                   if not (srsym^.typ in [varsym,typedconstsym,funcretsym]) then
+                     Message(parser_e_absolute_only_to_var_or_const);
+                   storetokenpos:=tokenpos;
+                   tokenpos:=declarepos;
+                   abssym:=new(pabsolutesym,init(s,tt));
+                   abssym^.abstyp:=tovar;
+                   abssym^.ref:=srsym;
+                   symtablestack^.insert(abssym);
+                   tokenpos:=storetokenpos;
+                 end
+                else
+                 if (token=_CSTRING) or (token=_CCHAR) then
+                  begin
+                    storetokenpos:=tokenpos;
+                    tokenpos:=declarepos;
+                    abssym:=new(pabsolutesym,init(s,tt));
+                    s:=pattern;
+                    consume(token);
+                    abssym^.abstyp:=toasm;
+                    abssym^.asmname:=stringdup(s);
+                    symtablestack^.insert(abssym);
+                    tokenpos:=storetokenpos;
+                  end
+                else
+                { absolute address ?!? }
+                 if token=_INTCONST then
+                  begin
+                    if (target_info.target=target_i386_go32v2) then
+                     begin
+                       storetokenpos:=tokenpos;
+                       tokenpos:=declarepos;
+                       abssym:=new(pabsolutesym,init(s,tt));
+                       abssym^.abstyp:=toaddr;
+                       abssym^.absseg:=false;
+                       s:=pattern;
+                       consume(_INTCONST);
+                       val(s,abssym^.address,code);
+                       if token=_COLON then
+                        begin
+                          consume(token);
+                          s:=pattern;
+                          consume(_INTCONST);
+                          val(s,l,code);
+                          abssym^.address:=abssym^.address shl 4+l;
+                          abssym^.absseg:=true;
+                        end;
+                       symtablestack^.insert(abssym);
+                       tokenpos:=storetokenpos;
+                     end
+                    else
+                     Message(parser_e_absolute_only_to_var_or_const);
+                  end
+                else
+                 Message(parser_e_absolute_only_to_var_or_const);
+                symdone:=true;
+              end;
+             { Handling of Delphi typed const = initialized vars ! }
+             { When should this be rejected ?
+               - in parasymtable
+               - in record or object
+               - ... (PM) }
+             if (m_delphi in aktmodeswitches) and (token=_EQUAL) and
+                not (symtablestack^.symtabletype in [parasymtable]) and
+                not is_record and not is_object then
+               begin
+                  storetokenpos:=tokenpos;
+                  s:=sc^.get_with_tokeninfo(tokenpos);
+                  if not sc^.empty then
+                    Message(parser_e_initialized_only_one_var);
+                  pconstsym:=new(ptypedconstsym,inittype(s,tt,false));
+                  symtablestack^.insert(pconstsym);
+                  tokenpos:=storetokenpos;
+                  consume(_EQUAL);
+                  readtypedconst(tt.def,pconstsym,false);
+                  symdone:=true;
+               end;
+             { for a record there doesn't need to be a ; before the END or ) }
+             if not((is_record or is_object) and (token in [_END,_RKLAMMER])) then
+               consume(_SEMICOLON);
+             { procvar handling }
+             if (tt.def^.deftype=procvardef) and (tt.def^.typesym=nil) then
+               begin
+                  newtype:=new(ptypesym,init('unnamed',tt));
+                  parse_var_proc_directives(psym(newtype));
+                  newtype^.restype.def:=nil;
+                  tt.def^.typesym:=nil;
+                  dispose(newtype,done);
+               end;
+             { Check for variable directives }
+             if not symdone and (token=_ID) then
+              begin
+                { Check for C Variable declarations }
+                if (m_cvar_support in aktmodeswitches) and
+                   not(is_record or is_object or is_threadvar) and
+                   (idtoken in [_EXPORT,_EXTERNAL,_PUBLIC,_CVAR]) then
+                 begin
+                   { only allowed for one var }
+                   s:=sc^.get_with_tokeninfo(declarepos);
+                   if not sc^.empty then
+                    Message(parser_e_absolute_only_one_var);
+{$ifdef fixLeaksOnError}
+                   if strContStack.pop <> sc then
+                     writeln('problem with strContStack in pdecl (5)');
+{$endif fixLeaksOnError}
+                   dispose(sc,done);
+                   { defaults }
+                   is_dll:=false;
+                   is_cdecl:=false;
+                   extern_aktvarsym:=false;
+                   export_aktvarsym:=false;
+                   { cdecl }
+                   if idtoken=_CVAR then
+                    begin
+                      consume(_CVAR);
+                      consume(_SEMICOLON);
+                      is_cdecl:=true;
+                      C_name:=target_os.Cprefix+C_name;
+                    end;
+                   { external }
+                   if idtoken=_EXTERNAL then
+                    begin
+                      consume(_EXTERNAL);
+                      extern_aktvarsym:=true;
+                    end;
+                   { export }
+                   if idtoken in [_EXPORT,_PUBLIC] then
+                    begin
+                      consume(_ID);
+                      if extern_aktvarsym or
+                         (symtablestack^.symtabletype in [parasymtable,localsymtable]) then
+                       Message(parser_e_not_external_and_export)
+                      else
+                       export_aktvarsym:=true;
+                    end;
+                   { external and export need a name after when no cdecl is used }
+                   if not is_cdecl then
+                    begin
+                      { dll name ? }
+                      if (extern_aktvarsym) and (idtoken<>_NAME) then
+                       begin
+                         is_dll:=true;
+                         dll_name:=get_stringconst;
+                       end;
+                      consume(_NAME);
+                      C_name:=get_stringconst;
+                    end;
+                   { consume the ; when export or external is used }
+                   if extern_aktvarsym or export_aktvarsym then
+                    consume(_SEMICOLON);
+                   { insert in the symtable }
+                   storetokenpos:=tokenpos;
+                   tokenpos:=declarepos;
+                   if is_dll then
+                    aktvarsym:=new(pvarsym,init_dll(s,tt))
+                   else
+                    aktvarsym:=new(pvarsym,init_C(s,C_name,tt));
+                   { set some vars options }
+                   if export_aktvarsym then
+                    begin
+                      inc(aktvarsym^.refs);
+                      include(aktvarsym^.varoptions,vo_is_exported);
+                    end;
+                   if extern_aktvarsym then
+                    include(aktvarsym^.varoptions,vo_is_external);
+                   { insert in the stack/datasegment }
+                   symtablestack^.insert(aktvarsym);
+                   tokenpos:=storetokenpos;
+                   { now we can insert it in the import lib if its a dll, or
+                     add it to the externals }
+                   if extern_aktvarsym then
+                    begin
+                      if is_dll then
+                       begin
+                         if not(current_module^.uses_imports) then
+                          begin
+                            current_module^.uses_imports:=true;
+                            importlib^.preparelib(current_module^.modulename^);
+                          end;
+                         importlib^.importvariable(aktvarsym^.mangledname,dll_name,C_name)
+                       end
+                    end;
+                   symdone:=true;
+                 end
+                else
+                 if (is_object) and (cs_static_keyword in aktmoduleswitches) and (idtoken=_STATIC) then
+                  begin
+                    include(current_object_option,sp_static);
+                    insert_syms(symtablestack,sc,tt,false);
+                    exclude(current_object_option,sp_static);
+                    consume(_STATIC);
+                    consume(_SEMICOLON);
+                    symdone:=true;
+                  end;
+              end;
+             { insert it in the symtable, if not done yet }
+             if not symdone then
+               begin
+                  { save object option, because we can turn of the sp_published }
+                  if (sp_published in current_object_option) and
+                    (not((tt.def^.deftype=objectdef) and (pobjectdef(tt.def)^.is_class))) then
+                   begin
+                     Message(parser_e_cant_publish_that);
+                     exclude(current_object_option,sp_published);
+                   end
+                  else
+                   if (sp_published in current_object_option) and
+                      not(oo_can_have_published in pobjectdef(tt.def)^.objectoptions) then
+                    begin
+                      Message(parser_e_only_publishable_classes_can__be_published);
+                      exclude(current_object_option,sp_published);
+                    end;
+                  insert_syms(symtablestack,sc,tt,is_threadvar);
+                  current_object_option:=old_current_object_option;
+               end;
+           end;
+         { Check for Case }
+         if is_record and (token=_CASE) then
+           begin
+              maxsize:=0;
+              maxalignment:=0;
+              consume(_CASE);
+              s:=pattern;
+              getsym(s,false);
+              { may be only a type: }
+              if assigned(srsym) and (srsym^.typ in [typesym,unitsym]) then
+                read_type(casetype,'')
+              else
+                begin
+                  consume(_ID);
+                  consume(_COLON);
+                  read_type(casetype,'');
+                  symtablestack^.insert(new(pvarsym,init(s,casetype)));
+                end;
+              if not(is_ordinal(casetype.def)) or is_64bitint(casetype.def)  then
+               Message(type_e_ordinal_expr_expected);
+              consume(_OF);
+{$ifdef UseUnionSymtable}
+              UnionSymtable:=new(psymtable,init(recordsymtable));
+              UnionSymtable^.next:=symtablestack;
+              registerdef:=false;
+              UnionDef:=new(precorddef,init(unionsymtable));
+              registerdef:=true;
+              symtablestack:=UnionSymtable;
+{$endif UseUnionSymtable}
+              startvarrecsize:=symtablestack^.datasize;
+              startvarrecalign:=symtablestack^.dataalignment;
+              repeat
+                repeat
+                  pt:=comp_expr(true);
+                  do_firstpass(pt);
+                  if not(pt.nodetype=ordconstn) then
+                    Message(cg_e_illegal_expression);
+                  pt.free;
+                  if token=_COMMA then
+                   consume(_COMMA)
+                  else
+                   break;
+                until false;
+                consume(_COLON);
+                { read the vars }
+                consume(_LKLAMMER);
+                inc(variantrecordlevel);
+                if token<>_RKLAMMER then
+                  read_var_decs(true,false,false);
+                dec(variantrecordlevel);
+                consume(_RKLAMMER);
+                { calculates maximal variant size }
+                maxsize:=max(maxsize,symtablestack^.datasize);
+                maxalignment:=max(maxalignment,symtablestack^.dataalignment);
+                { the items of the next variant are overlayed }
+                symtablestack^.datasize:=startvarrecsize;
+                symtablestack^.dataalignment:=startvarrecalign;
+                if (token<>_END) and (token<>_RKLAMMER) then
+                  consume(_SEMICOLON)
+                else
+                  break;
+              until (token=_END) or (token=_RKLAMMER);
+              { at last set the record size to that of the biggest variant }
+              symtablestack^.datasize:=maxsize;
+              symtablestack^.dataalignment:=maxalignment;
+{$ifdef UseUnionSymtable}
+              uniontype.def:=uniondef;
+              uniontype.sym:=nil;
+              UnionSym:=new(pvarsym,init('case',uniontype));
+              symtablestack:=symtablestack^.next;
+              { we do NOT call symtablestack^.insert
+               on purpose PM }
+              offset:=align_from_size(symtablestack^.datasize,maxalignment);
+              symtablestack^.datasize:=offset+unionsymtable^.datasize;
+              if maxalignment>symtablestack^.dataalignment then
+                symtablestack^.dataalignment:=maxalignment;
+              UnionSymtable^.Insert_in(symtablestack,offset);
+              UnionSym^.owner:=nil;
+              dispose(unionsym,done);
+              dispose(uniondef,done);
+{$endif UseUnionSymtable}
+           end;
+         block_type:=old_block_type;
+         current_object_option:=old_current_object_option;
+      end;
+
+end.
+{
+  $Log$
+  Revision 1.1  2000-10-14 10:14:51  peter
+    * moehrendorf oct 2000 rewrite
+
+}

compiler/pexports.pas

@@ -29,28 +29,37 @@ interface
     { reads an exports statement in a library }
     procedure read_exports;
 
+
 implementation
 
     uses
-{$ifdef delphi}
-      sysutils,
-{$else}
-      strings,
-{$endif}
-      globtype,systems,tokens,
-      cutils,cobjects,globals,verbose,
-      scanner,symconst,symtable,pbase,
-      export,GenDef,tree,pass_1,pexpr;
+       { common }
+       cutils,cobjects,
+       { global }
+       globtype,globals,tokens,verbose,
+       systems,cpuinfo,
+       { aasm }
+       aasm,
+       { symtable }
+       symconst,symtable,types,
+       { pass 1 }
+       node,pass_1,
+       ncon,
+       { parser }
+       scanner,
+       pbase,pexpr,pdecl,pdecsub,pdecvar,
+       { link }
+       gendef,export
+       ;
 
-    procedure read_exports;
 
+    procedure read_exports;
       var
-         hp : pexported_item;
-         DefString:string;
-         ProcName:string;
-         InternalProcName:string;
-         pt : ptree;
-
+         hp        : pexported_item;
+         DefString : string;
+         ProcName  : string;
+         InternalProcName : string;
+         pt        : tnode;
       begin
          DefString:='';
          InternalProcName:='';
@@ -100,15 +109,15 @@ implementation
                              consume(_INDEX);
                              pt:=comp_expr(true);
                              do_firstpass(pt);
-                             if pt^.treetype=ordconstn then
-                               hp^.index:=pt^.value
+                             if pt.nodetype=ordconstn then
+                               hp^.index:=tordconstnode(pt).value
                              else
                                 begin
                                    hp^.index:=0;
                                    consume(_INTCONST);
                                 end;
                              hp^.options:=hp^.options or eo_index;
-                             disposetree(pt);
+                             pt.free;
                              if target_os.id=os_i386_win32 then
                                DefString:=ProcName+'='+InternalProcName+' @ '+tostr(hp^.index)
                              else
@@ -119,15 +128,15 @@ implementation
                              consume(_NAME);
                              pt:=comp_expr(true);
                              do_firstpass(pt);
-                             if pt^.treetype=stringconstn then
-                               hp^.name:=stringdup(strpas(pt^.value_str))
+                             if pt.nodetype=stringconstn then
+                               hp^.name:=stringdup(strpas(tstringconstnode(pt).value_str))
                              else
                                 begin
                                    hp^.name:=stringdup('');
                                    consume(_CSTRING);
                                 end;
                              hp^.options:=hp^.options or eo_name;
-                             disposetree(pt);
+                             pt.free;
                              DefString:=hp^.name^+'='+InternalProcName;
                           end;
                         if (idtoken=_RESIDENT) then
@@ -160,7 +169,10 @@ end.
 
 {
   $Log$
-  Revision 1.5  2000-09-24 21:19:50  peter
+  Revision 1.6  2000-10-14 10:14:51  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.5  2000/09/24 21:19:50  peter
     * delphi compile fixes
 
   Revision 1.4  2000/09/24 15:06:21  peter
@@ -173,4 +185,4 @@ end.
   Revision 1.2  2000/07/13 11:32:44  michael
   + removed logs
 
-}
+}

compiler/psub.pas

@@ -2,7 +2,7 @@
     $Id$
     Copyright (c) 1998-2000 by Florian Klaempfl, Daniel Mantione
 
-    Does the parsing of the procedures/functions
+    Does the parsing and codegeneration at subroutine level
 
     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
@@ -26,2068 +26,812 @@ unit psub;
 
 interface
 
-uses
-  cobjects,
-  symconst,tokens,symtable;
-
-const
-  pd_global    = $1;    { directive must be global }
-  pd_body      = $2;    { directive needs a body }
-  pd_implemen  = $4;    { directive can be used implementation section }
-  pd_interface = $8;    { directive can be used interface section }
-  pd_object    = $10;   { directive can be used object declaration }
-  pd_procvar   = $20;   { directive can be used procvar declaration }
-  pd_notobject    = $40;{ directive can not be used object declaration }
-
-procedure compile_proc_body(const proc_names:Tstringcontainer;
-                            make_global,parent_has_class:boolean);
-procedure parse_proc_head(options:tproctypeoption);
-procedure parse_proc_dec;
-function  is_proc_directive(tok:ttoken):boolean;
-procedure parse_var_proc_directives(var sym : psym);
-procedure parse_object_proc_directives(var sym : pprocsym);
-procedure read_proc;
-function check_identical_proc(var p : pprocdef) : boolean;
+    uses
+       cobjects;
+
+    procedure compile_proc_body(const proc_names:Tstringcontainer;
+                                make_global,parent_has_class:boolean);
+
+    { reads the declaration blocks }
+    procedure read_declarations(islibrary : boolean);
+
+    { reads declarations in the interface part of a unit }
+    procedure read_interface_declarations;
+
 
 implementation
 
-uses
-{$ifdef delphi}
-  sysutils,
-{$else}
-  strings,
-{$endif}
-  globtype,systems,
-  cutils,globals,verbose,fmodule,
-  scanner,aasm,tree,types,
-  import,gendef,htypechk,
-{$ifdef newcg}
-  cgbase,
-{$else newcg}
-  hcodegen,temp_gen,
-{$endif newcg}
-  pass_1,cpubase,cpuasm
+    uses
+       { common }
+       cutils,
+       { global }
+       globtype,globals,tokens,verbose,
+       systems,cpuinfo,
+       { aasm }
+       cpubase,aasm,
+       { symtable }
+       symconst,symtable,types,
+       ppu,fmodule,
+       { pass 1 }
+       node,pass_1,
+       nbas,
+       { pass 2 }
 {$ifndef NOPASS2}
-  ,pass_2
+       pass_2,
 {$endif}
-{$ifdef GDB}
-  ,gdb
-{$endif GDB}
+       { parser }
+       scanner,
+       pbase,pexpr,pstatmnt,pdecl,pdecsub,pexports,
+       { codegen }
 {$ifdef newcg}
-  {$ifndef NOOPT}
-    ,aopt
-  {$endif}
+       cgbase,
+       tgcpu,cgobj,
+       {$ifndef NOOPT}
+        ,aopt
+       {$endif}
 {$else}
-  {$ifdef i386}
-    ,tgeni386
-    ,cgai386
-    {$ifndef NOOPT}
-      ,aopt386
-    {$endif}
-  {$endif}
-  {$ifdef m68k}
-    ,tgen68k,cga68k
-  {$endif}
-{$endif newcg}
-  { parser specific stuff }
-  ,pbase,ptype,pdecl,pexpr,pstatmnt
-{$ifdef newcg}
-  ,tgcpu,convtree,cgobj,tgeni386  { for the new code generator tgeni386 is only a dummy }
-{$endif newcg}
-  ;
-
-var
-  realname:string;  { contains the real name of a procedure as it's typed }
-
-
-procedure parse_proc_head(options:tproctypeoption);
-var sp:stringid;
-    pd:Pprocdef;
-    paramoffset:longint;
-    sym:Psym;
-    hs:string;
-    st : psymtable;
-    overloaded_level:word;
-    storepos,procstartfilepos : tfileposinfo;
-begin
-{ Save the position where this procedure really starts and set col to 1 which
-  looks nicer }
-  procstartfilepos:=tokenpos;
-{  procstartfilepos.column:=1; I do not agree here !!
-   lets keep excat position PM }
-
-  if (options=potype_operator) then
-    begin
-      sp:=overloaded_names[optoken];
-      realname:=sp;
-    end
-  else
-    begin
-      sp:=pattern;
-      realname:=orgpattern;
-      consume(_ID);
-    end;
-
-{ method ? }
-  if not(parse_only) and
-     (lexlevel=normal_function_level) and
-     try_to_consume(_POINT) then
-   begin
-     storepos:=tokenpos;
-     tokenpos:=procstartfilepos;
-     getsym(sp,true);
-     sym:=srsym;
-     tokenpos:=storepos;
-     { load proc name }
-     sp:=pattern;
-     realname:=orgpattern;
-     procstartfilepos:=tokenpos;
-     { qualifier is class name ? }
-     if (sym^.typ<>typesym) or
-        (ptypesym(sym)^.restype.def^.deftype<>objectdef) then
-       begin
-          Message(parser_e_class_id_expected);
-          aktprocsym:=nil;
-          consume(_ID);
-       end
-     else
-       begin
-          { used to allow private syms to be seen }
-          aktobjectdef:=pobjectdef(ptypesym(sym)^.restype.def);
-          procinfo^._class:=pobjectdef(ptypesym(sym)^.restype.def);
-          aktprocsym:=pprocsym(procinfo^._class^.symtable^.search(sp));
-          consume(_ID);
-          {The procedure has been found. So it is
-           a global one. Set the flags to mark this.}
-          procinfo^.flags:=procinfo^.flags or pi_is_global;
-          aktobjectdef:=nil;
-          { we solve this below }
-          if not(assigned(aktprocsym)) then
-            Message(parser_e_methode_id_expected);
-       end;
-   end
-  else
-   begin
-     { check for constructor/destructor which is not allowed here }
-     if (not parse_only) and
-        (options in [potype_constructor,potype_destructor]) then
-        Message(parser_e_constructors_always_objects);
-
-     tokenpos:=procstartfilepos;
-     aktprocsym:=pprocsym(symtablestack^.search(sp));
-
-     if not(parse_only) then
-       begin
-         {The procedure we prepare for is in the implementation
-          part of the unit we compile. It is also possible that we
-          are compiling a program, which is also some kind of
-          implementaion part.
-
-          We need to find out if the procedure is global. If it is
-          global, it is in the global symtable.}
-         if not assigned(aktprocsym) and
-            (symtablestack^.symtabletype=staticsymtable) then
+       hcodegen,
+       temp_gen
+       {$ifdef i386}
+         ,tgeni386
+         ,cgai386
+         {$ifndef NOOPT}
+           ,aopt386
+         {$endif}
+       {$endif}
+{$endif}
+       ;
+
+
+{****************************************************************************
+                      PROCEDURE/FUNCTION BODY PARSING
+****************************************************************************}
+
+    function block(islibrary : boolean) : tnode;
+      var
+         funcretsym : pfuncretsym;
+         storepos : tfileposinfo;
+      begin
+         { do we have an assembler block without the po_assembler?
+           we should allow this for Delphi compatibility (PFV) }
+         if (token=_ASM) and (m_delphi in aktmodeswitches) then
+          include(aktprocsym^.definition^.procoptions,po_assembler);
+
+         { Handle assembler block different }
+         if (po_assembler in aktprocsym^.definition^.procoptions) then
           begin
-            {Search the procedure in the global symtable.}
-            aktprocsym:=Pprocsym(search_a_symtable(sp,globalsymtable));
-            if assigned(aktprocsym) then
-             begin
-               {Check if it is a procedure.}
-               if aktprocsym^.typ<>procsym then
-                DuplicateSym(aktprocsym);
-               {The procedure has been found. So it is
-                a global one. Set the flags to mark this.}
-               procinfo^.flags:=procinfo^.flags or pi_is_global;
-             end;
+            read_declarations(false);
+            block:=assembler_block;
+            exit;
           end;
-       end;
-   end;
-
-{ Create the mangledname }
-{$ifndef UseNiceNames}
-  if assigned(procinfo^._class) then
-   begin
-     if (pos('_$$_',procprefix)=0) then
-      hs:=procprefix+'_$$_'+procinfo^._class^.objname^+'_$$_'+sp
-     else
-      hs:=procprefix+'_$'+sp;
-   end
-  else
-   begin
-     if lexlevel=normal_function_level then
-      hs:=procprefix+'_'+sp
-     else
-      hs:=procprefix+'_$'+sp;
-   end;
-{$else UseNiceNames}
-  if assigned(procinfo^._class) then
-   begin
-     if (pos('_5Class_',procprefix)=0) then
-      hs:=procprefix+'_5Class_'+procinfo^._class^.name^+'_'+tostr(length(sp))+sp
-     else
-      hs:=procprefix+'_'+tostr(length(sp))+sp;
-   end
-  else
-   begin
-     if lexlevel=normal_function_level then
-      hs:=procprefix+'_'+tostr(length(sp))+sp
-     else
-      hs:=lowercase(procprefix)+'_'+tostr(length(sp))+sp;
-   end;
-{$endif UseNiceNames}
-
-  if assigned(aktprocsym) then
-   begin
-     { Check if overloaded is a procsym, we use a different error message
-       for tp7 so it looks more compatible }
-     if aktprocsym^.typ<>procsym then
-      begin
-        if (m_fpc in aktmodeswitches) then
-         Message1(parser_e_overloaded_no_procedure,aktprocsym^.name)
-        else
-         DuplicateSym(aktprocsym);
-        { try to recover by creating a new aktprocsym }
-        tokenpos:=procstartfilepos;
-        aktprocsym:=new(pprocsym,init(sp));
-      end;
-   end
-  else
-   begin
-     { create a new procsym and set the real filepos }
-     tokenpos:=procstartfilepos;
-     { for operator we have only one definition for each overloaded
-       operation }
-     if (options=potype_operator) then
-       begin
-          { create the procsym with saving the original case }
-          aktprocsym:=new(pprocsym,init('$'+sp));
-          { the only problem is that nextoverloaded might not be in a unit
-            known for the unit itself }
-          { not anymore PM }
-          if assigned(overloaded_operators[optoken]) then
-            aktprocsym^.definition:=overloaded_operators[optoken]^.definition;
-{$ifndef DONOTCHAINOPERATORS}
-          overloaded_operators[optoken]:=aktprocsym;
-{$endif DONOTCHAINOPERATORS}
-       end
-      else
-       aktprocsym:=new(pprocsym,init(sp));
-     symtablestack^.insert(aktprocsym);
-   end;
-
-  st:=symtablestack;
-  pd:=new(pprocdef,init);
-  pd^.symtablelevel:=symtablestack^.symtablelevel;
-
-  if assigned(procinfo^._class) then
-    pd^._class := procinfo^._class;
-
-  { set the options from the caller (podestructor or poconstructor) }
-  pd^.proctypeoption:=options;
-
-  { calculate the offset of the parameters }
-  paramoffset:=8;
-
-  { calculate frame pointer offset }
-  if lexlevel>normal_function_level then
-    begin
-      procinfo^.framepointer_offset:=paramoffset;
-      inc(paramoffset,target_os.size_of_pointer);
-      { this is needed to get correct framepointer push for local
-        forward functions !! }
-      pd^.parast^.symtablelevel:=lexlevel;
-    end;
-
-  if assigned (procinfo^._Class)  and
-     not(procinfo^._Class^.is_class) and
-     (pd^.proctypeoption in [potype_constructor,potype_destructor]) then
-    inc(paramoffset,target_os.size_of_pointer);
-
-  { self pointer offset                       }
-  { self isn't pushed in nested procedure of methods }
-  if assigned(procinfo^._class) and (lexlevel=normal_function_level) then
-    begin
-      procinfo^.selfpointer_offset:=paramoffset;
-      if assigned(aktprocsym^.definition) and
-         not(po_containsself in aktprocsym^.definition^.procoptions) then
-        inc(paramoffset,target_os.size_of_pointer);
-    end;
-
-  { con/-destructor flag ? }
-  if assigned (procinfo^._Class) and
-     procinfo^._class^.is_class and
-     (pd^.proctypeoption in [potype_destructor,potype_constructor]) then
-    inc(paramoffset,target_os.size_of_pointer);
-
-  procinfo^.para_offset:=paramoffset;
-
-  pd^.parast^.datasize:=0;
-
-  pd^.nextoverloaded:=aktprocsym^.definition;
-  aktprocsym^.definition:=pd;
-  { this is probably obsolete now PM }
-  aktprocsym^.definition^.fileinfo:=procstartfilepos;
-  aktprocsym^.definition^.setmangledname(hs);
-  aktprocsym^.definition^.procsym:=aktprocsym;
-
-  if not parse_only then
-    begin
-       overloaded_level:=0;
-       { we need another procprefix !!! }
-       { count, but only those in the same unit !!}
-       while assigned(pd) and
-          (pd^.owner^.symtabletype in [globalsymtable,staticsymtable]) do
-         begin
-            { only count already implemented functions }
-            if  not(pd^.forwarddef) then
-              inc(overloaded_level);
-            pd:=pd^.nextoverloaded;
-         end;
-       if overloaded_level>0 then
-         procprefix:=hs+'$'+tostr(overloaded_level)+'$'
-       else
-         procprefix:=hs+'$';
-    end;
-
-  { this must also be inserted in the right symtable !! PM }
-  { otherwise we get subbtle problems with
-    definitions of args defs in staticsymtable for
-    implementation of a global method }
-  if token=_LKLAMMER then
-    parameter_dec(aktprocsym^.definition);
-
-  { so we only restore the symtable now }
-  symtablestack:=st;
-  if (options=potype_operator) then
-    overloaded_operators[optoken]:=aktprocsym;
-end;
-
-
-procedure parse_proc_dec;
-var
-  hs : string;
-  isclassmethod : boolean;
-begin
-  inc(lexlevel);
-{ read class method }
-  if token=_CLASS then
-   begin
-     consume(_CLASS);
-     isclassmethod:=true;
-   end
-  else
-   isclassmethod:=false;
-  case token of
-     _FUNCTION : begin
-                   consume(_FUNCTION);
-                   parse_proc_head(potype_none);
-                   if token<>_COLON then
-                    begin
-                       if not(aktprocsym^.definition^.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(aktprocsym^.definition^.rettype,hs,false);
-                      aktprocsym^.definition^.test_if_fpu_result;
-                      dec(testcurobject);
-                    end;
-                 end;
-    _PROCEDURE : begin
-                   consume(_PROCEDURE);
-                   parse_proc_head(potype_none);
-                   aktprocsym^.definition^.rettype.def:=voiddef;
-                 end;
-  _CONSTRUCTOR : begin
-                   consume(_CONSTRUCTOR);
-                   parse_proc_head(potype_constructor);
-                   if assigned(procinfo^._class) and
-                      procinfo^._class^.is_class then
-                    begin
-                      { CLASS constructors return the created instance }
-                      aktprocsym^.definition^.rettype.def:=procinfo^._class;
-                    end
+
+         if procinfo^.returntype.def<>pdef(voiddef) then
+           begin
+              { if the current is a function aktprocsym is non nil }
+              { and there is a local symtable set }
+              storepos:=tokenpos;
+              tokenpos:=aktprocsym^.fileinfo;
+              funcretsym:=new(pfuncretsym,init(aktprocsym^.name,procinfo));
+              { insert in local symtable }
+              symtablestack^.insert(funcretsym);
+              tokenpos:=storepos;
+              if ret_in_acc(procinfo^.returntype.def) or (procinfo^.returntype.def^.deftype=floatdef) then
+                procinfo^.return_offset:=-funcretsym^.address;
+              procinfo^.funcretsym:=funcretsym;
+              { insert result also if support is on }
+              if (m_result in aktmodeswitches) then
+               begin
+                 procinfo^.resultfuncretsym:=new(pfuncretsym,init('RESULT',procinfo));
+                 symtablestack^.insert(procinfo^.resultfuncretsym);
+               end;
+           end;
+         read_declarations(islibrary);
+
+         { temporary space is set, while the BEGIN of the procedure }
+         if (symtablestack^.symtabletype=localsymtable) then
+           procinfo^.firsttemp_offset := -symtablestack^.datasize
+         else
+           procinfo^.firsttemp_offset := 0;
+
+         { space for the return value }
+         { !!!!!   this means that we can not set the return value
+         in a subfunction !!!!! }
+         { because we don't know yet where the address is }
+         if procinfo^.returntype.def<>pdef(voiddef) then
+           begin
+              if ret_in_acc(procinfo^.returntype.def) or (procinfo^.returntype.def^.deftype=floatdef) then
+              { if (procinfo^.retdef^.deftype=orddef) or
+                 (procinfo^.retdef^.deftype=pointerdef) or
+                 (procinfo^.retdef^.deftype=enumdef) or
+                 (procinfo^.retdef^.deftype=procvardef) or
+                 (procinfo^.retdef^.deftype=floatdef) or
+                 (
+                   (procinfo^.retdef^.deftype=setdef) and
+                   (psetdef(procinfo^.retdef)^.settype=smallset)
+                 ) then  }
+                begin
+                   { the space has been set in the local symtable }
+                   procinfo^.return_offset:=-funcretsym^.address;
+                   if ((procinfo^.flags and pi_operator)<>0) and
+                     assigned(opsym) then
+                     {opsym^.address:=procinfo^.para_offset; is wrong PM }
+                     opsym^.address:=-procinfo^.return_offset;
+                   { eax is modified by a function }
+{$ifndef newcg}
+{$ifdef i386}
+                   usedinproc:=usedinproc or ($80 shr byte(R_EAX));
+
+                   if is_64bitint(procinfo^.returntype.def) then
+                     usedinproc:=usedinproc or ($80 shr byte(R_EDX))
+{$endif}
+{$ifdef m68k}
+                   usedinproc:=usedinproc or ($800 shr word(R_D0));
+
+                   if is_64bitint(procinfo^.retdef) then
+                     usedinproc:=usedinproc or ($800 shr byte(R_D1))
+{$endif}
+{$endif newcg}
+                end;
+           end;
+
+         {Unit initialization?.}
+         if (lexlevel=unit_init_level) and (current_module^.is_unit)
+            or islibrary then
+           begin
+             if (token=_END) then
+                begin
+                   consume(_END);
+                   { We need at least a node, else the entry/exit code is not
+                     generated and thus no PASCALMAIN symbol which we need (PFV) }
+                   if islibrary then
+                    block:=cnothingnode.create
                    else
-                    begin
-                      { OBJECT constructors return a boolean }
-{$IfDef GDB}
-                      { GDB doesn't like unnamed types !}
-                      aktprocsym^.definition^.rettype.def:=globaldef('boolean');
-{$else GDB}
-                      aktprocsym^.definition^.rettype.def:=new(porddef,init(bool8bit,0,1));
-{$Endif GDB}
-                    end;
-                 end;
-   _DESTRUCTOR : begin
-                   consume(_DESTRUCTOR);
-                   parse_proc_head(potype_destructor);
-                   aktprocsym^.definition^.rettype.def:=voiddef;
-                 end;
-     _OPERATOR : begin
-                   if lexlevel>normal_function_level then
-                     Message(parser_e_no_local_operator);
-                   consume(_OPERATOR);
-                   if not(token in [_PLUS..last_overloaded]) then
-                     Message(parser_e_overload_operator_failed);
-                   optoken:=token;
-                   consume(Token);
-                   procinfo^.flags:=procinfo^.flags or pi_operator;
-                   parse_proc_head(potype_operator);
-                   if token<>_ID then
+                    block:=nil;
+                end
+              else
+                begin
+                   if token=_INITIALIZATION then
                      begin
-                        opsym:=nil;
-                        if not(m_result in aktmodeswitches) then
-                          consume(_ID);
+                        current_module^.flags:=current_module^.flags or uf_init;
+                        block:=statement_block(_INITIALIZATION);
                      end
-                   else
+                   else if (token=_FINALIZATION) then
                      begin
-                       opsym:=new(pvarsym,initdef(pattern,voiddef));
-                       consume(_ID);
-                     end;
-                   if not try_to_consume(_COLON) then
-                     begin
-                       consume(_COLON);
-                       aktprocsym^.definition^.rettype.def:=generrordef;
-                       consume_all_until(_SEMICOLON);
+                        if (current_module^.flags and uf_finalize)<>0 then
+                          block:=statement_block(_FINALIZATION)
+                        else
+                          begin
+                          { can we allow no INITIALIZATION for DLL ??
+                            I think it should work PM }
+                             block:=nil;
+                             exit;
+                          end;
                      end
                    else
-                    begin
-                      single_type(aktprocsym^.definition^.rettype,hs,false);
-                      aktprocsym^.definition^.test_if_fpu_result;
-                      if (optoken in [_EQUAL,_GT,_LT,_GTE,_LTE]) and
-                         ((aktprocsym^.definition^.rettype.def^.deftype<>
-                         orddef) or (porddef(aktprocsym^.definition^.
-                         rettype.def)^.typ<>bool8bit)) then
-                        Message(parser_e_comparative_operator_return_boolean);
-                       if assigned(opsym) then
-                         opsym^.vartype.def:=aktprocsym^.definition^.rettype.def;
-                       { We need to add the return type in the mangledname
-                         to allow overloading with just different results !! (PM) }
-                       aktprocsym^.definition^.setmangledname(
-                         aktprocsym^.definition^.mangledname+'$$'+hs);
-                       if (optoken=_ASSIGNMENT) and
-                          is_equal(aktprocsym^.definition^.rettype.def,
-                             pvarsym(aktprocsym^.definition^.parast^.symindex^.first)^.vartype.def) then
-                         message(parser_e_no_such_assignment)
-                       else if not isoperatoracceptable(aktprocsym^.definition,optoken) then
-                         Message(parser_e_overload_impossible);
+                     begin
+                        current_module^.flags:=current_module^.flags or uf_init;
+                        block:=statement_block(_BEGIN);
                      end;
-                 end;
-  end;
-  if isclassmethod and
-     assigned(aktprocsym) then
-    include(aktprocsym^.definition^.procoptions,po_classmethod);
-  { support procedure proc;stdcall export; in Delphi mode only }
-  if not((m_delphi in aktmodeswitches) and
-     is_proc_directive(token)) then
-   consume(_SEMICOLON);
-  dec(lexlevel);
-end;
+                end;
+            end
+         else
+            block:=statement_block(_BEGIN);
+      end;
 
 
 {****************************************************************************
-                        Procedure directive handlers
+                       PROCEDURE/FUNCTION COMPILING
 ****************************************************************************}
 
-procedure pd_far(const procnames:Tstringcontainer);
-begin
-  Message(parser_w_proc_far_ignored);
-end;
-
-procedure pd_near(const procnames:Tstringcontainer);
-begin
-  Message(parser_w_proc_near_ignored);
-end;
-
-procedure pd_export(const procnames:Tstringcontainer);
-begin
-  if assigned(procinfo^._class) then
-    Message(parser_e_methods_dont_be_export);
-  if lexlevel<>normal_function_level then
-    Message(parser_e_dont_nest_export);
-  { only os/2 needs this }
-  if target_info.target=target_i386_os2 then
-   begin
-     procnames.insert(realname);
-     procinfo^.exported:=true;
-     if cs_link_deffile in aktglobalswitches then
-       deffile.AddExport(aktprocsym^.definition^.mangledname);
-   end;
-end;
-
-procedure pd_inline(const procnames:Tstringcontainer);
-begin
-  if not(cs_support_inline in aktmoduleswitches) then
-   Message(parser_e_proc_inline_not_supported);
-end;
-
-procedure pd_forward(const procnames:Tstringcontainer);
-begin
-  aktprocsym^.definition^.forwarddef:=true;
-end;
-
-procedure pd_stdcall(const procnames:Tstringcontainer);
-begin
-end;
-
-procedure pd_safecall(const procnames:Tstringcontainer);
-begin
-end;
-
-procedure pd_alias(const procnames:Tstringcontainer);
-begin
-  consume(_COLON);
-  procnames.insert(get_stringconst);
-end;
-
-procedure pd_asmname(const procnames:Tstringcontainer);
-begin
-  aktprocsym^.definition^.setmangledname(target_os.Cprefix+pattern);
-  if token=_CCHAR then
-    consume(_CCHAR)
-  else
-    consume(_CSTRING);
-  { we don't need anything else }
-  aktprocsym^.definition^.forwarddef:=false;
-end;
-
-procedure pd_intern(const procnames:Tstringcontainer);
-begin
-  consume(_COLON);
-  aktprocsym^.definition^.extnumber:=get_intconst;
-end;
-
-procedure pd_interrupt(const procnames:Tstringcontainer);
-begin
-{$ifndef i386}
-  Message(parser_w_proc_interrupt_ignored);
-{$else i386}
-  if lexlevel<>normal_function_level then
-    Message(parser_e_dont_nest_interrupt);
-{$endif i386}
-end;
-
-procedure pd_system(const procnames:Tstringcontainer);
-begin
-  aktprocsym^.definition^.setmangledname(realname);
-end;
-
-procedure pd_abstract(const procnames:Tstringcontainer);
-begin
-  if (po_virtualmethod in aktprocsym^.definition^.procoptions) then
-    include(aktprocsym^.definition^.procoptions,po_abstractmethod)
-  else
-    Message(parser_e_only_virtual_methods_abstract);
-  { the method is defined }
-  aktprocsym^.definition^.forwarddef:=false;
-end;
-
-procedure pd_virtual(const procnames:Tstringcontainer);
-{$ifdef WITHDMT}
-var
-  pt : ptree;
-{$endif WITHDMT}
-begin
-  if (aktprocsym^.definition^.proctypeoption=potype_constructor) and
-     not(aktprocsym^.definition^._class^.is_class) then
-    Message(parser_e_constructor_cannot_be_not_virtual);
-{$ifdef WITHDMT}
-  if not(aktprocsym^.definition^._class^.is_class) and
-    (token<>_SEMICOLON) then
-    begin
-       { any type of parameter is allowed here! }
-
-       pt:=comp_expr(true);
-       do_firstpass(pt);
-       if is_constintnode(pt) then
-         begin
-           include(aktprocsym^.definition^.procoptions,po_msgint);
-           aktprocsym^.definition^.messageinf.i:=pt^.value;
-         end
-       else
-         Message(parser_e_ill_msg_expr);
-       disposetree(pt);
-    end;
-{$endif WITHDMT}
-end;
-
-procedure pd_static(const procnames:Tstringcontainer);
-begin
-  if (cs_static_keyword in aktmoduleswitches) then
-    begin
-      include(aktprocsym^.symoptions,sp_static);
-      include(aktprocsym^.definition^.procoptions,po_staticmethod);
-    end;
-end;
-
-procedure pd_override(const procnames:Tstringcontainer);
-begin
-  if not(aktprocsym^.definition^._class^.is_class) then
-    Message(parser_e_no_object_override);
-end;
-
-procedure pd_overload(const procnames:Tstringcontainer);
-begin
-end;
-
-procedure pd_message(const procnames:Tstringcontainer);
-var
-  pt : ptree;
-begin
-  { check parameter type }
-  if not(po_containsself in aktprocsym^.definition^.procoptions) and
-     ((aktprocsym^.definition^.minparacount<>1) or
-      (aktprocsym^.definition^.maxparacount<>1) or
-      (pparaitem(aktprocsym^.definition^.para^.first)^.paratyp<>vs_var)) then
-   Message(parser_e_ill_msg_param);
-  pt:=comp_expr(true);
-  do_firstpass(pt);
-  if pt^.treetype=stringconstn then
-    begin
-      include(aktprocsym^.definition^.procoptions,po_msgstr);
-      aktprocsym^.definition^.messageinf.str:=strnew(pt^.value_str);
-    end
-  else
-   if is_constintnode(pt) then
-    begin
-      include(aktprocsym^.definition^.procoptions,po_msgint);
-      aktprocsym^.definition^.messageinf.i:=pt^.value;
-    end
-  else
-    Message(parser_e_ill_msg_expr);
-  disposetree(pt);
-end;
-
-
-procedure resetvaluepara(p:pnamedindexobject);
-begin
-  if psym(p)^.typ=varsym then
-    with pvarsym(p)^ do
-       if copy(name,1,3)='val' then
-          aktprocsym^.definition^.parast^.symsearch^.rename(name,copy(name,4,length(name)));
-end;
-
-
-procedure pd_cdecl(const procnames:Tstringcontainer);
-begin
-  if aktprocsym^.definition^.deftype<>procvardef then
-    aktprocsym^.definition^.setmangledname(target_os.Cprefix+realname);
-  { do not copy on local !! }
-  if (aktprocsym^.definition^.deftype=procdef) and
-     assigned(aktprocsym^.definition^.parast) then
-    aktprocsym^.definition^.parast^.foreach({$ifdef FPCPROCVAR}@{$endif}resetvaluepara);
-end;
-
-
-procedure pd_pascal(const procnames:Tstringcontainer);
-var st,parast : psymtable;
-    lastps,ps : psym;
-begin
-   new(st,init(parasymtable));
-   parast:=aktprocsym^.definition^.parast;
-   lastps:=nil;
-   while assigned(parast^.symindex^.first) and (lastps<>psym(parast^.symindex^.first)) do
-     begin
-       ps:=psym(parast^.symindex^.first);
-       while assigned(ps^.indexnext) and (psym(ps^.indexnext)<>lastps) do
-         ps:=psym(ps^.indexnext);
-       ps^.owner:=st;
-       { recalculate the corrected offset }
-       { the really_insert_in_data procedure
-         for parasymtable should only calculateoffset PM }
-       ps^.insert_in_data;
-       { reset the owner correctly }
-       ps^.owner:=parast;
-       lastps:=ps;
-     end;
-end;
-
-
-procedure pd_register(const procnames:Tstringcontainer);
-begin
-  Message1(parser_w_proc_directive_ignored,'REGISTER');
-end;
-
-
-procedure pd_reintroduce(const procnames:Tstringcontainer);
-begin
-  Message1(parser_w_proc_directive_ignored,'REINTRODUCE');
-end;
-
-
-procedure pd_syscall(const procnames:Tstringcontainer);
-begin
-  aktprocsym^.definition^.forwarddef:=false;
-  aktprocsym^.definition^.extnumber:=get_intconst;
-end;
-
-
-procedure pd_external(const procnames:Tstringcontainer);
-{
-  If import_dll=nil the procedure is assumed to be in another
-  object file. In that object file it should have the name to
-  which import_name is pointing to. Otherwise, the procedure is
-  assumed to be in the DLL to which import_dll is pointing to. In
-  that case either import_nr<>0 or import_name<>nil is true, so
-  the procedure is either imported by number or by name. (DM)
-}
-var
-  import_dll,
-  import_name : string;
-  import_nr   : word;
-begin
-  aktprocsym^.definition^.forwarddef:=false;
-{ If the procedure should be imported from a DLL, a constant string follows.
-  This isn't really correct, an contant string expression follows
-  so we check if an semicolon follows, else a string constant have to
-  follow (FK) }
-  import_nr:=0;
-  import_name:='';
-  if not(token=_SEMICOLON) and not(idtoken=_NAME) then
-    begin
-      import_dll:=get_stringconst;
-      if (idtoken=_NAME) then
-       begin
-         consume(_NAME);
-         import_name:=get_stringconst;
-       end;
-      if (idtoken=_INDEX) then
-       begin
-         {After the word index follows the index number in the DLL.}
-         consume(_INDEX);
-         import_nr:=get_intconst;
-       end;
-      if (import_nr=0) and (import_name='') then
-        {if (aktprocsym^.definition^.options and pocdecl)<>0 then
-          import_name:=aktprocsym^.definition^.mangledname
-        else
-          Message(parser_w_empty_import_name);}
-        { this should work both for win32 and Linux !! PM }
-        import_name:=realname;
-      if not(current_module^.uses_imports) then
-       begin
-         current_module^.uses_imports:=true;
-         importlib^.preparelib(current_module^.modulename^);
-       end;
-      if not(m_repeat_forward in aktmodeswitches) then
-        begin
-          { we can only have one overloaded here ! }
-          if assigned(aktprocsym^.definition^.nextoverloaded) then
-            importlib^.importprocedure(aktprocsym^.definition^.nextoverloaded^.mangledname,
-              import_dll,import_nr,import_name)
-          else
-            importlib^.importprocedure(aktprocsym^.mangledname,import_dll,import_nr,import_name);
-        end
-      else
-        importlib^.importprocedure(aktprocsym^.mangledname,import_dll,import_nr,import_name);
-    end
-  else
-    begin
-      if (idtoken=_NAME) then
-       begin
-         consume(_NAME);
-         import_name:=get_stringconst;
-         aktprocsym^.definition^.setmangledname(import_name);
-       end
-      else
-       begin
-         { external shouldn't override the cdecl/system name }
-         if not (pocall_clearstack in aktprocsym^.definition^.proccalloptions) then
-           aktprocsym^.definition^.setmangledname(aktprocsym^.name);
-       end;
-    end;
-end;
-
-type
-   pd_handler=procedure(const procnames:Tstringcontainer);
-   proc_dir_rec=record
-     idtok     : ttoken;
-     pd_flags  : longint;
-     handler   : pd_handler;
-     pocall    : tproccalloptions;
-     pooption  : tprocoptions;
-     mutexclpocall : tproccalloptions;
-     mutexclpotype : tproctypeoptions;
-     mutexclpo     : tprocoptions;
-   end;
-const
-  {Should contain the number of procedure directives we support.}
-  num_proc_directives=31;
-  proc_direcdata:array[1..num_proc_directives] of proc_dir_rec=
-   (
-    (
-      idtok:_ABSTRACT;
-      pd_flags : pd_interface+pd_object;
-      handler  : {$ifdef FPCPROCVAR}@{$endif}pd_abstract;
-      pocall   : [];
-      pooption : [po_abstractmethod];
-      mutexclpocall : [pocall_internproc,pocall_inline];
-      mutexclpotype : [potype_constructor,potype_destructor];
-      mutexclpo     : [po_exports,po_interrupt,po_external]
-    ),(
-      idtok:_ALIAS;
-      pd_flags : pd_implemen+pd_body;
-      handler  : {$ifdef FPCPROCVAR}@{$endif}pd_alias;
-      pocall   : [];
-      pooption : [];
-      mutexclpocall : [pocall_inline];
-      mutexclpotype : [];
-      mutexclpo     : [po_external]
-    ),(
-      idtok:_ASMNAME;
-      pd_flags : pd_interface+pd_implemen;
-      handler  : {$ifdef FPCPROCVAR}@{$endif}pd_asmname;
-      pocall   : [pocall_cdecl,pocall_clearstack];
-      pooption : [po_external];
-      mutexclpocall : [pocall_internproc];
-      mutexclpotype : [];
-      mutexclpo     : [po_external]
-    ),(
-      idtok:_ASSEMBLER;
-      pd_flags : pd_implemen+pd_body;
-      handler  : nil;
-      pocall   : [];
-      pooption : [po_assembler];
-      mutexclpocall : [];
-      mutexclpotype : [];
-      mutexclpo     : [po_external]
-    ),(
-      idtok:_CDECL;
-      pd_flags : pd_interface+pd_implemen+pd_body+pd_procvar;
-      handler  : {$ifdef FPCPROCVAR}@{$endif}pd_cdecl;
-      pocall   : [pocall_cdecl,pocall_clearstack];
-      pooption : [po_savestdregs];
-      mutexclpocall : [pocall_internproc,pocall_leftright,pocall_inline];
-      mutexclpotype : [];
-      mutexclpo     : [po_assembler,po_external]
-    ),(
-      idtok:_DYNAMIC;
-      pd_flags : pd_interface+pd_object;
-      handler  : {$ifdef FPCPROCVAR}@{$endif}pd_virtual;
-      pocall   : [];
-      pooption : [po_virtualmethod];
-      mutexclpocall : [pocall_internproc,pocall_inline];
-      mutexclpotype : [];
-      mutexclpo     : [po_exports,po_interrupt,po_external]
-    ),(
-      idtok:_EXPORT;
-      pd_flags : pd_body+pd_global+pd_interface+pd_implemen{??};
-      handler  : {$ifdef FPCPROCVAR}@{$endif}pd_export;
-      pocall   : [];
-      pooption : [po_exports];
-      mutexclpocall : [pocall_internproc,pocall_inline];
-      mutexclpotype : [];
-      mutexclpo     : [po_external,po_interrupt]
-    ),(
-      idtok:_EXTERNAL;
-      pd_flags : pd_implemen+pd_interface;
-      handler  : {$ifdef FPCPROCVAR}@{$endif}pd_external;
-      pocall   : [];
-      pooption : [po_external];
-      mutexclpocall : [pocall_internproc,pocall_inline,pocall_palmossyscall];
-      mutexclpotype : [];
-      mutexclpo     : [po_exports,po_interrupt,po_assembler]
-    ),(
-      idtok:_FAR;
-      pd_flags : pd_implemen+pd_body+pd_interface+pd_procvar;
-      handler  : {$ifdef FPCPROCVAR}@{$endif}pd_far;
-      pocall   : [];
-      pooption : [];
-      mutexclpocall : [pocall_internproc,pocall_inline];
-      mutexclpotype : [];
-      mutexclpo     : []
-    ),(
-      idtok:_FORWARD;
-      pd_flags : pd_implemen;
-      handler  : {$ifdef FPCPROCVAR}@{$endif}pd_forward;
-      pocall   : [];
-      pooption : [];
-      mutexclpocall : [pocall_internproc,pocall_inline];
-      mutexclpotype : [];
-      mutexclpo     : [po_external]
-    ),(
-      idtok:_INLINE;
-      pd_flags : pd_implemen+pd_body;
-      handler  : {$ifdef FPCPROCVAR}@{$endif}pd_inline;
-      pocall   : [pocall_inline];
-      pooption : [];
-      mutexclpocall : [pocall_internproc];
-      mutexclpotype : [potype_constructor,potype_destructor];
-      mutexclpo     : [po_exports,po_external,po_interrupt]
-    ),(
-      idtok:_INTERNCONST;
-      pd_flags : pd_implemen+pd_body;
-      handler  : {$ifdef FPCPROCVAR}@{$endif}pd_intern;
-      pocall   : [pocall_internconst];
-      pooption : [];
-      mutexclpocall : [];
-      mutexclpotype : [potype_operator];
-      mutexclpo     : []
-    ),(
-      idtok:_INTERNPROC;
-      pd_flags : pd_implemen;
-      handler  : {$ifdef FPCPROCVAR}@{$endif}pd_intern;
-      pocall   : [pocall_internproc];
-      pooption : [];
-      mutexclpocall : [pocall_inline,pocall_clearstack,pocall_leftright,pocall_cdecl];
-      mutexclpotype : [potype_constructor,potype_destructor,potype_operator];
-      mutexclpo     : [po_exports,po_external,po_interrupt,po_assembler,po_iocheck]
-    ),(
-      idtok:_INTERRUPT;
-      pd_flags : pd_implemen+pd_body;
-      handler  : {$ifdef FPCPROCVAR}@{$endif}pd_interrupt;
-      pocall   : [];
-      pooption : [po_interrupt];
-      mutexclpocall : [pocall_internproc,pocall_cdecl,pocall_clearstack,pocall_leftright,pocall_inline];
-      mutexclpotype : [potype_constructor,potype_destructor,potype_operator];
-      mutexclpo     : [po_external]
-    ),(
-      idtok:_IOCHECK;
-      pd_flags : pd_implemen+pd_body;
-      handler  : nil;
-      pocall   : [];
-      pooption : [po_iocheck];
-      mutexclpocall : [pocall_internproc];
-      mutexclpotype : [];
-      mutexclpo     : [po_external]
-    ),(
-      idtok:_MESSAGE;
-      pd_flags : pd_interface+pd_object;
-      handler  : {$ifdef FPCPROCVAR}@{$endif}pd_message;
-      pocall   : [];
-      pooption : []; { can be po_msgstr or po_msgint }
-      mutexclpocall : [pocall_inline,pocall_internproc];
-      mutexclpotype : [potype_constructor,potype_destructor,potype_operator];
-      mutexclpo     : [po_interrupt,po_external]
-    ),(
-      idtok:_NEAR;
-      pd_flags : pd_implemen+pd_body+pd_procvar;
-      handler  : {$ifdef FPCPROCVAR}@{$endif}pd_near;
-      pocall   : [];
-      pooption : [];
-      mutexclpocall : [pocall_internproc];
-      mutexclpotype : [];
-      mutexclpo     : []
-    ),(
-      idtok:_OVERLOAD;
-      pd_flags : pd_implemen+pd_interface+pd_body;
-      handler  : {$ifdef FPCPROCVAR}@{$endif}pd_overload;
-      pocall   : [];
-      pooption : [po_overload];
-      mutexclpocall : [pocall_internproc];
-      mutexclpotype : [];
-      mutexclpo     : []
-    ),(
-      idtok:_OVERRIDE;
-      pd_flags : pd_interface+pd_object;
-      handler  : {$ifdef FPCPROCVAR}@{$endif}pd_override;
-      pocall   : [];
-      pooption : [po_overridingmethod,po_virtualmethod];
-      mutexclpocall : [pocall_inline,pocall_internproc];
-      mutexclpotype : [];
-      mutexclpo     : [po_exports,po_external,po_interrupt]
-    ),(
-      idtok:_PASCAL;
-      pd_flags : pd_implemen+pd_body+pd_procvar;
-      handler  : {$ifdef FPCPROCVAR}@{$endif}pd_pascal;
-      pocall   : [pocall_leftright];
-      pooption : [];
-      mutexclpocall : [pocall_internproc];
-      mutexclpotype : [];
-      mutexclpo     : [po_external]
-    ),(
-      idtok:_POPSTACK;
-      pd_flags : pd_interface+pd_implemen+pd_body+pd_procvar;
-      handler  : nil;
-      pocall   : [pocall_clearstack];
-      pooption : [];
-      mutexclpocall : [pocall_inline,pocall_internproc];
-      mutexclpotype : [];
-      mutexclpo     : [po_assembler,po_external]
-    ),(
-      idtok:_PUBLIC;
-      pd_flags : pd_implemen+pd_body+pd_global+pd_notobject;
-      handler  : nil;
-      pocall   : [];
-      pooption : [];
-      mutexclpocall : [pocall_internproc,pocall_inline];
-      mutexclpotype : [];
-      mutexclpo     : [po_external]
-    ),(
-      idtok:_REGISTER;
-      pd_flags : pd_interface+pd_implemen+pd_body+pd_procvar;
-      handler  : {$ifdef FPCPROCVAR}@{$endif}pd_register;
-      pocall   : [pocall_register];
-      pooption : [];
-      mutexclpocall : [pocall_leftright,pocall_cdecl,pocall_internproc];
-      mutexclpotype : [];
-      mutexclpo     : [po_external]
-    ),(
-      idtok:_REINTRODUCE;
-      pd_flags : pd_interface+pd_object;
-      handler  : {$ifdef FPCPROCVAR}@{$endif}pd_reintroduce;
-      pocall   : [];
-      pooption : [];
-      mutexclpocall : [];
-      mutexclpotype : [];
-      mutexclpo     : []
-    ),(
-      idtok:_SAFECALL;
-      pd_flags : pd_interface+pd_implemen+pd_body+pd_procvar;
-      handler  : {$ifdef FPCPROCVAR}@{$endif}pd_safecall;
-      pocall   : [pocall_safecall];
-      pooption : [po_savestdregs];
-      mutexclpocall : [pocall_leftright,pocall_cdecl,pocall_internproc,pocall_inline];
-      mutexclpotype : [];
-      mutexclpo     : [po_external]
-    ),(
-      idtok:_SAVEREGISTERS;
-      pd_flags : pd_interface+pd_implemen+pd_body+pd_procvar;
-      handler  : nil;
-      pocall   : [];
-      pooption : [po_saveregisters];
-      mutexclpocall : [pocall_internproc];
-      mutexclpotype : [];
-      mutexclpo     : [po_external]
-    ),(
-      idtok:_STATIC;
-      pd_flags : pd_interface+pd_object;
-      handler  : {$ifdef FPCPROCVAR}@{$endif}pd_static;
-      pocall   : [];
-      pooption : [po_staticmethod];
-      mutexclpocall : [pocall_inline,pocall_internproc];
-      mutexclpotype : [potype_constructor,potype_destructor];
-      mutexclpo     : [po_external,po_interrupt,po_exports]
-    ),(
-      idtok:_STDCALL;
-      pd_flags : pd_interface+pd_implemen+pd_body+pd_procvar;
-      handler  : {$ifdef FPCPROCVAR}@{$endif}pd_stdcall;
-      pocall   : [pocall_stdcall];
-      pooption : [po_savestdregs];
-      mutexclpocall : [pocall_leftright,pocall_cdecl,pocall_inline,pocall_internproc];
-      mutexclpotype : [];
-      mutexclpo     : [po_external]
-    ),(
-      idtok:_SYSCALL;
-      pd_flags : pd_interface;
-      handler  : {$ifdef FPCPROCVAR}@{$endif}pd_syscall;
-      pocall   : [pocall_palmossyscall];
-      pooption : [];
-      mutexclpocall : [pocall_cdecl,pocall_inline,pocall_internproc];
-      mutexclpotype : [];
-      mutexclpo     : [po_external,po_assembler,po_interrupt,po_exports]
-    ),(
-      idtok:_SYSTEM;
-      pd_flags : pd_implemen;
-      handler  : {$ifdef FPCPROCVAR}@{$endif}pd_system;
-      pocall   : [pocall_clearstack];
-      pooption : [];
-      mutexclpocall : [pocall_leftright,pocall_inline,pocall_internproc];
-      mutexclpotype : [];
-      mutexclpo     : [po_external,po_assembler,po_interrupt]
-    ),(
-      idtok:_VIRTUAL;
-      pd_flags : pd_interface+pd_object;
-      handler  : {$ifdef FPCPROCVAR}@{$endif}pd_virtual;
-      pocall   : [];
-      pooption : [po_virtualmethod];
-      mutexclpocall : [pocall_inline,pocall_internproc];
-      mutexclpotype : [];
-      mutexclpo     : [po_external,po_interrupt,po_exports]
-    )
-   );
-
-
-function is_proc_directive(tok:ttoken):boolean;
-var
-  i : longint;
-begin
-  is_proc_directive:=false;
-  for i:=1 to num_proc_directives do
-   if proc_direcdata[i].idtok=idtoken then
-    begin
-      is_proc_directive:=true;
-      exit;
-    end;
-end;
-
-
-function parse_proc_direc(const proc_names:Tstringcontainer;var pdflags:word):boolean;
-{
-  Parse the procedure directive, returns true if a correct directive is found
-}
-var
-  p     : longint;
-  found : boolean;
-  name  : string;
-begin
-  parse_proc_direc:=false;
-  name:=pattern;
-  found:=false;
-  for p:=1 to num_proc_directives do
-   if proc_direcdata[p].idtok=idtoken then
-    begin
-      found:=true;
-      break;
-    end;
-
-{ Check if the procedure directive is known }
-  if not found then
-   begin
-      { parsing a procvar type the name can be any
-        next variable !! }
-      if (pdflags and (pd_procvar or pd_object))=0 then
-        Message1(parser_w_unknown_proc_directive_ignored,name);
-      exit;
-   end;
-
-  { static needs a special treatment }
-  if (idtoken=_STATIC) and not (cs_static_keyword in aktmoduleswitches) then
-    exit;
-
-{ Conflicts between directives ? }
-  if (aktprocsym^.definition^.proctypeoption in proc_direcdata[p].mutexclpotype) or
-     ((aktprocsym^.definition^.proccalloptions*proc_direcdata[p].mutexclpocall)<>[]) or
-     ((aktprocsym^.definition^.procoptions*proc_direcdata[p].mutexclpo)<>[]) then
-   begin
-     Message1(parser_e_proc_dir_conflict,name);
-     exit;
-   end;
-
-{ Check if the directive is only for objects }
-  if ((proc_direcdata[p].pd_flags and pd_object)<>0) and
-     not assigned(aktprocsym^.definition^._class) then
-    begin
-      exit;
-    end;
-{ check if method and directive not for object public }
-  if ((proc_direcdata[p].pd_flags and pd_notobject)<>0) and
-     assigned(aktprocsym^.definition^._class) then
-    begin
-      exit;
-    end;
-
-{ consume directive, and turn flag on }
-  consume(token);
-  parse_proc_direc:=true;
-
-{ Check the pd_flags if the directive should be allowed }
-  if ((pdflags and pd_interface)<>0) and
-     ((proc_direcdata[p].pd_flags and pd_interface)=0) then
-    begin
-      Message1(parser_e_proc_dir_not_allowed_in_interface,name);
-      exit;
-    end;
-  if ((pdflags and pd_implemen)<>0) and
-     ((proc_direcdata[p].pd_flags and pd_implemen)=0) then
-    begin
-      Message1(parser_e_proc_dir_not_allowed_in_implementation,name);
-      exit;
-    end;
-  if ((pdflags and pd_procvar)<>0) and
-     ((proc_direcdata[p].pd_flags and pd_procvar)=0) then
-    begin
-      Message1(parser_e_proc_dir_not_allowed_in_procvar,name);
-      exit;
-    end;
-
-{ Return the new pd_flags }
-  if (proc_direcdata[p].pd_flags and pd_body)=0 then
-    pdflags:=pdflags and (not pd_body);
-  if (proc_direcdata[p].pd_flags and pd_global)<>0 then
-    pdflags:=pdflags or pd_global;
-
-{ Add the correct flag }
-  aktprocsym^.definition^.proccalloptions:=aktprocsym^.definition^.proccalloptions+proc_direcdata[p].pocall;
-  aktprocsym^.definition^.procoptions:=aktprocsym^.definition^.procoptions+proc_direcdata[p].pooption;
-
- { Adjust positions of args for cdecl or stdcall }
-   if (aktprocsym^.definition^.deftype=procdef) and
-      (([pocall_cdecl,pocall_stdcall]*aktprocsym^.definition^.proccalloptions)<>[]) then
-     aktprocsym^.definition^.parast^.set_alignment(target_os.size_of_longint);
-
-{ Call the handler }
-  if pointer({$ifndef FPC}@{$endif}proc_direcdata[p].handler)<>nil then
-    proc_direcdata[p].handler(proc_names);
-end;
-
-{***************************************************************************}
-
-function check_identical_proc(var p : pprocdef) : boolean;
-{
-  Search for idendical definitions,
-  if there is a forward, then kill this.
-
-  Returns the result of the forward check.
-
-  Removed from unter_dec to keep the source readable
-}
-var
-  hd,pd : Pprocdef;
-  storeparast : psymtable;
-  ad,fd : psym;
-  s : string;
-begin
-  check_identical_proc:=false;
-  p:=nil;
-  pd:=aktprocsym^.definition;
-  if assigned(pd) then
-   begin
-   { Is there an overload/forward ? }
-     if assigned(pd^.nextoverloaded) then
+    procedure compile_proc_body(const proc_names:Tstringcontainer;
+                                make_global,parent_has_class:boolean);
+      {
+        Compile the body of a procedure
+      }
+      var
+         oldexitlabel,oldexit2label : pasmlabel;
+         oldfaillabel,oldquickexitlabel:Pasmlabel;
+         _class,hp:Pobjectdef;
+         { switches can change inside the procedure }
+         entryswitches, exitswitches : tlocalswitches;
+         oldaktmaxfpuregisters,localmaxfpuregisters : longint;
+         { code for the subroutine as tree }
+         code:tnode;
+         { size of the local strackframe }
+         stackframe:longint;
+         { true when no stackframe is required }
+         nostackframe:boolean;
+         { number of bytes which have to be cleared by RET }
+         parasize:longint;
+         { filepositions }
+         entrypos,
+         savepos,
+         exitpos   : tfileposinfo;
       begin
-      { walk the procdef list }
-        while (assigned(pd)) and (assigned(pd^.nextoverloaded)) do
-         begin
-           hd:=pd^.nextoverloaded;
-
-           { check the parameters }
-           if (not(m_repeat_forward in aktmodeswitches) and
-               (aktprocsym^.definition^.maxparacount=0)) or
-              (equal_paras(aktprocsym^.definition^.para,hd^.para,cp_none) and
-              { for operators equal_paras is not enough !! }
-              ((aktprocsym^.definition^.proctypeoption<>potype_operator) or (optoken<>_ASSIGNMENT) or
-               is_equal(hd^.rettype.def,aktprocsym^.definition^.rettype.def))) then
-             begin
-               if not equal_paras(aktprocsym^.definition^.para,hd^.para,cp_all) and
-                  ((m_repeat_forward in aktmodeswitches) or
-                   (aktprocsym^.definition^.maxparacount>0)) then
-                 begin
-                    MessagePos1(aktprocsym^.definition^.fileinfo,parser_e_header_dont_match_forward,
-                                aktprocsym^.demangledName);
-                    exit;
-                 end;
-               if hd^.forwarddef then
-               { remove the forward definition  but don't delete it,      }
-               { the symtable is the owner !!  }
-                 begin
-                 { Check if the procedure type and return type are correct }
-                   if (hd^.proctypeoption<>aktprocsym^.definition^.proctypeoption) or
-                      (not(is_equal(hd^.rettype.def,aktprocsym^.definition^.rettype.def)) and
-                      (m_repeat_forward in aktmodeswitches)) then
-                     begin
-                       MessagePos1(aktprocsym^.definition^.fileinfo,parser_e_header_dont_match_forward,
-                                   aktprocsym^.demangledName);
-                       exit;
-                     end;
-                   { Check calling convention, no check for internconst,internproc which
-                     are only defined in interface or implementation }
-                   if (hd^.proccalloptions-[pocall_internconst,pocall_internproc]<>
-                       aktprocsym^.definition^.proccalloptions-[pocall_internconst,pocall_internproc]) then
-                    begin
-                      { only trigger an error, becuase it doesn't hurt, for delphi check
-                        if the current implementation has no proccalloptions, then
-                        take the options from the interface }
-                      if (m_delphi in aktmodeswitches) then
-                       begin
-                         if (aktprocsym^.definition^.proccalloptions=[]) then
-                          aktprocsym^.definition^.proccalloptions:=hd^.proccalloptions
-                         else
-                          MessagePos(aktprocsym^.definition^.fileinfo,parser_e_call_convention_dont_match_forward);
-                       end
-                      else
-                       MessagePos(aktprocsym^.definition^.fileinfo,parser_e_call_convention_dont_match_forward);
-                      { set the mangledname to the interface name so it doesn't trigger
-                        the Note about different manglednames (PFV) }
-                      aktprocsym^.definition^.setmangledname(hd^.mangledname);
-                    end;
-                   { manglednames are equal? }
-                   hd^.count:=false;
-                   if (m_repeat_forward in aktmodeswitches) or
-                      aktprocsym^.definition^.haspara then
-                    begin
-                      if (hd^.mangledname<>aktprocsym^.definition^.mangledname) then
-                       begin
-                         if not(po_external in aktprocsym^.definition^.procoptions) then
-                           MessagePos2(aktprocsym^.definition^.fileinfo,parser_n_interface_name_diff_implementation_name,hd^.mangledname,
-                             aktprocsym^.definition^.mangledname);
-                       { reset the mangledname of the interface part to be sure }
-                       { this is wrong because the mangled name might have been used already !! }
-                          if hd^.is_used then
-                            renameasmsymbol(hd^.mangledname,aktprocsym^.definition^.mangledname);
-                          hd^.setmangledname(aktprocsym^.definition^.mangledname);
-                       { so we need to keep the name of interface !!
-                         No!!!! The procedure directives can change the mangledname.
-                         I fixed this by first calling check_identical_proc and then doing
-                         the proc directives, but this is not a good solution.(DM)}
-                         { this is also wrong (PM)
-                         aktprocsym^.definition^.setmangledname(hd^.mangledname);}
-                       end
-                      else
-                       begin
-                       { If mangled names are equal, therefore    }
-                       { they have the same number of parameters  }
-                       { Therefore we can check the name of these }
-                       { parameters...                      }
-                         if hd^.forwarddef and aktprocsym^.definition^.forwarddef then
-                           begin
-                             MessagePos1(aktprocsym^.definition^.fileinfo,
-                                         parser_e_function_already_declared_public_forward,aktprocsym^.demangledName);
-                             check_identical_proc:=true;
-                           { Remove other forward from the list to reduce errors }
-                             pd^.nextoverloaded:=pd^.nextoverloaded^.nextoverloaded;
-                             exit;
-                           end;
-                         ad:=psym(hd^.parast^.symindex^.first);
-                         fd:=psym(aktprocsym^.definition^.parast^.symindex^.first);
-                         if assigned(ad) and assigned(fd) then
-                           begin
-                             while assigned(ad) and assigned(fd) do
-                               begin
-                                 s:=ad^.name;
-                                 if s<>fd^.name then
-                                   begin
-                                     MessagePos3(aktprocsym^.definition^.fileinfo,parser_e_header_different_var_names,
-                                       aktprocsym^.name,s,fd^.name);
-                                     break;
-                                   end;
-                               { it is impossible to have a nil pointer }
-                               { for only one parameter - since they    }
-                               { have the same number of parameters.    }
-                               { Left = next parameter.          }
-                                 ad:=psym(ad^.left);
-                                 fd:=psym(fd^.left);
-                               end;
-                           end;
-                       end;
-                    end;
-                 { also the para_offset }
-                   hd^.parast^.address_fixup:=aktprocsym^.definition^.parast^.address_fixup;
-                   hd^.count:=true;
-
-                 { remove pd^.nextoverloaded from the list }
-                 { and add aktprocsym^.definition }
-                   pd^.nextoverloaded:=pd^.nextoverloaded^.nextoverloaded;
-                   hd^.nextoverloaded:=aktprocsym^.definition^.nextoverloaded;
-                 { Alert! All fields of aktprocsym^.definition that are modified
-                   by the procdir handlers must be copied here!.}
-                   hd^.forwarddef:=false;
-                   hd^.hasforward:=true;
-                   hd^.proccalloptions:=hd^.proccalloptions + aktprocsym^.definition^.proccalloptions;
-                   hd^.procoptions:=hd^.procoptions + aktprocsym^.definition^.procoptions;
-                   if aktprocsym^.definition^.extnumber=-1 then
-                     aktprocsym^.definition^.extnumber:=hd^.extnumber
-                   else
-                     if hd^.extnumber=-1 then
-                       hd^.extnumber:=aktprocsym^.definition^.extnumber;
-                   { switch parast for warning in implementation  PM }
-                   if (m_repeat_forward in aktmodeswitches) or
-                      aktprocsym^.definition^.haspara then
-                     begin
-                        storeparast:=hd^.parast;
-                        hd^.parast:=aktprocsym^.definition^.parast;
-                        aktprocsym^.definition^.parast:=storeparast;
-                     end;
-                   if pd=aktprocsym^.definition then
-                     p:=nil
-                   else
-                     p:=pd;
-                   aktprocsym^.definition:=hd;
-                   check_identical_proc:=true;
-                 end
-               else
-               { abstract methods aren't forward defined, but this }
-               { needs another error message                   }
-                 if not(po_abstractmethod in pd^.nextoverloaded^.procoptions) then
-                   MessagePos(aktprocsym^.definition^.fileinfo,parser_e_overloaded_have_same_parameters)
-                 else
-                   MessagePos(aktprocsym^.definition^.fileinfo,parser_e_abstract_no_definition);
-               break;
-             end;
+         { calculate the lexical level }
+         inc(lexlevel);
+         if lexlevel>32 then
+          Message(parser_e_too_much_lexlevel);
+
+         { static is also important for local procedures !! }
+         if (po_staticmethod in aktprocsym^.definition^.procoptions) then
+           allow_only_static:=true
+         else if (lexlevel=normal_function_level) then
+           allow_only_static:=false;
+
+         { save old labels }
+         oldexitlabel:=aktexitlabel;
+         oldexit2label:=aktexit2label;
+         oldquickexitlabel:=quickexitlabel;
+         oldfaillabel:=faillabel;
+         { get new labels }
+         getlabel(aktexitlabel);
+         getlabel(aktexit2label);
+         { exit for fail in constructors }
+         if (aktprocsym^.definition^.proctypeoption=potype_constructor) then
+           begin
+             getlabel(faillabel);
+             getlabel(quickexitlabel);
+           end;
+         { reset break and continue labels }
+         block_type:=bt_general;
+         aktbreaklabel:=nil;
+         aktcontinuelabel:=nil;
 
-           { check for allowing overload directive }
-           if not(m_fpc in aktmodeswitches) then
-            begin
-              { overload directive turns on overloading }
-              if ((po_overload in aktprocsym^.definition^.procoptions) or
-                  ((po_overload in hd^.procoptions))) then
-               begin
-                 { check if all procs have overloading, but not if the proc was
-                   already declared forward, then the check is already done }
-                 if not(hd^.hasforward) and
-                    (aktprocsym^.definition^.forwarddef=hd^.forwarddef) and
-                    not((po_overload in aktprocsym^.definition^.procoptions) and
-                        ((po_overload in hd^.procoptions))) then
-                  begin
-                    MessagePos1(aktprocsym^.definition^.fileinfo,parser_e_no_overload_for_all_procs,aktprocsym^.name);
-                    break;
-                  end;
-               end
-              else
-               begin
-                 if not(hd^.forwarddef) then
-                  begin
-                    MessagePos(aktprocsym^.definition^.fileinfo,parser_e_procedure_overloading_is_off);
-                    break;
-                  end;
-               end;
-            end;
+         { insert symtables for the class, by only if it is no nested function }
+         if assigned(procinfo^._class) and not(parent_has_class) then
+           begin
+             { insert them in the reverse order ! }
+             hp:=nil;
+             repeat
+               _class:=procinfo^._class;
+               while _class^.childof<>hp do
+                 _class:=_class^.childof;
+               hp:=_class;
+               _class^.symtable^.next:=symtablestack;
+               symtablestack:=_class^.symtable;
+             until hp=procinfo^._class;
+           end;
 
-           { try next overloaded }
-           pd:=pd^.nextoverloaded;
-         end;
-      end
-     else
-      begin
-      { there is no overloaded, so its always identical with itself }
-        check_identical_proc:=true;
-      end;
-   end;
-{ insert opsym only in the right symtable }
-  if ((procinfo^.flags and pi_operator)<>0) and assigned(opsym)
-     and not parse_only then
-    begin
-      if ret_in_param(aktprocsym^.definition^.rettype.def) then
-        begin
-          pprocdef(aktprocsym^.definition)^.parast^.insert(opsym);
-        { this increases the data size }
-        { correct this to get the right ret $value }
-          dec(pprocdef(aktprocsym^.definition)^.parast^.datasize,opsym^.getpushsize);
-          { this allows to read the funcretoffset }
-          opsym^.address:=-4;
-          opsym^.varspez:=vs_var;
-        end
-      else
-        pprocdef(aktprocsym^.definition)^.localst^.insert(opsym);
-    end;
-end;
-
-procedure compile_proc_body(const proc_names:Tstringcontainer;
-                            make_global,parent_has_class:boolean);
-{
-  Compile the body of a procedure
-}
-var
-   oldexitlabel,oldexit2label : pasmlabel;
-   oldfaillabel,oldquickexitlabel:Pasmlabel;
-   _class,hp:Pobjectdef;
-   { switches can change inside the procedure }
-   entryswitches, exitswitches : tlocalswitches;
-   oldaktmaxfpuregisters,localmaxfpuregisters : longint;
-   { code for the subroutine as tree }
-{$ifdef newcg}
-   code:ptree;
-{$else newcg}
-   code:ptree;
-{$endif newcg}
-   { size of the local strackframe }
-   stackframe:longint;
-   { true when no stackframe is required }
-   nostackframe:boolean;
-   { number of bytes which have to be cleared by RET }
-   parasize:longint;
-   { filepositions }
-   entrypos,
-   savepos,
-   exitpos   : tfileposinfo;
-begin
-   { calculate the lexical level }
-   inc(lexlevel);
-   if lexlevel>32 then
-    Message(parser_e_too_much_lexlevel);
-
-   { static is also important for local procedures !! }
-   if (po_staticmethod in aktprocsym^.definition^.procoptions) then
-     allow_only_static:=true
-   else if (lexlevel=normal_function_level) then
-     allow_only_static:=false;
-
-   { save old labels }
-   oldexitlabel:=aktexitlabel;
-   oldexit2label:=aktexit2label;
-   oldquickexitlabel:=quickexitlabel;
-   oldfaillabel:=faillabel;
-   { get new labels }
-   getlabel(aktexitlabel);
-   getlabel(aktexit2label);
-   { exit for fail in constructors }
-   if (aktprocsym^.definition^.proctypeoption=potype_constructor) then
-     begin
-       getlabel(faillabel);
-       getlabel(quickexitlabel);
-     end;
-   { reset break and continue labels }
-   block_type:=bt_general;
-   aktbreaklabel:=nil;
-   aktcontinuelabel:=nil;
-
-   { insert symtables for the class, by only if it is no nested function }
-   if assigned(procinfo^._class) and not(parent_has_class) then
-     begin
-       { insert them in the reverse order ! }
-       hp:=nil;
-       repeat
-         _class:=procinfo^._class;
-         while _class^.childof<>hp do
-           _class:=_class^.childof;
-         hp:=_class;
-         _class^.symtable^.next:=symtablestack;
-         symtablestack:=_class^.symtable;
-       until hp=procinfo^._class;
-     end;
-
-   { insert parasymtable in symtablestack}
-   { only if lexlevel > 1 !!! global symtable should be right after staticsymtazble
-     for checking of same names used in interface and implementation !! }
-   if lexlevel>=normal_function_level then
-     begin
-        aktprocsym^.definition^.parast^.next:=symtablestack;
-        symtablestack:=aktprocsym^.definition^.parast;
-        symtablestack^.symtablelevel:=lexlevel;
-     end;
-   { insert localsymtable in symtablestack}
-   aktprocsym^.definition^.localst^.next:=symtablestack;
-   symtablestack:=aktprocsym^.definition^.localst;
-   symtablestack^.symtablelevel:=lexlevel;
-   { constant symbols are inserted in this symboltable }
-   constsymtable:=symtablestack;
-
-   { reset the temporary memory }
-   cleartempgen;
+         { insert parasymtable in symtablestack}
+         { only if lexlevel > 1 !!! global symtable should be right after staticsymtazble
+           for checking of same names used in interface and implementation !! }
+         if lexlevel>=normal_function_level then
+           begin
+              aktprocsym^.definition^.parast^.next:=symtablestack;
+              symtablestack:=aktprocsym^.definition^.parast;
+              symtablestack^.symtablelevel:=lexlevel;
+           end;
+         { insert localsymtable in symtablestack}
+         aktprocsym^.definition^.localst^.next:=symtablestack;
+         symtablestack:=aktprocsym^.definition^.localst;
+         symtablestack^.symtablelevel:=lexlevel;
+         { constant symbols are inserted in this symboltable }
+         constsymtable:=symtablestack;
+
+         { reset the temporary memory }
+         cleartempgen;
 
 {$ifdef newcg}
-   tg.usedinproc:=[];
-{$else newcg}
-   { no registers are used }
-   usedinproc:=0;
-{$endif newcg}
-   { save entry info }
-   entrypos:=aktfilepos;
-   entryswitches:=aktlocalswitches;
-   localmaxfpuregisters:=aktmaxfpuregisters;
-{$ifdef newcg}
-{$ifdef dummy}
-   { parse the code ... }
-   if (po_assembler in aktprocsym^.definition^.procoptions) then
-     code:=convtree2node(assembler_block)
-   else
-     code:=convtree2node(block(current_module^.islibrary));
-{$endif dummy}
-   { parse the code ... }
-   if (po_assembler in aktprocsym^.definition^.procoptions) then
-     code:=assembler_block
-   else
-     code:=block(current_module^.islibrary);
+         tg.usedinproc:=[];
 {$else newcg}
-   { parse the code ... }
-   if (po_assembler in aktprocsym^.definition^.procoptions) then
-     code:=assembler_block
-   else
-     code:=block(current_module^.islibrary);
+         { no registers are used }
+         usedinproc:=0;
 {$endif newcg}
-
-   { get a better entry point }
-   if assigned(code) then
-     entrypos:=code^.fileinfo;
-
-   { save exit info }
-   exitswitches:=aktlocalswitches;
-   exitpos:=last_endtoken_filepos;
-
-   { save current filepos }
-   savepos:=aktfilepos;
-
-   {When we are called to compile the body of a unit, aktprocsym should
-    point to the unit initialization. If the unit has no initialization,
-    aktprocsym=nil. But in that case code=nil. hus we should check for
-    code=nil, when we use aktprocsym.}
-
-   { set the framepointer to esp for assembler functions }
-   { but only if the are no local variables           }
-   { already done in assembler_block }
+         { save entry info }
+         entrypos:=aktfilepos;
+         entryswitches:=aktlocalswitches;
+         localmaxfpuregisters:=aktmaxfpuregisters;
+         { parse the code ... }
+         code:=block(current_module^.islibrary);
+         { get a better entry point }
+         if assigned(code) then
+           entrypos:=code.fileinfo;
+         { save exit info }
+         exitswitches:=aktlocalswitches;
+         exitpos:=last_endtoken_filepos;
+         { save current filepos }
+         savepos:=aktfilepos;
+
+         {When we are called to compile the body of a unit, aktprocsym should
+          point to the unit initialization. If the unit has no initialization,
+          aktprocsym=nil. But in that case code=nil. hus we should check for
+          code=nil, when we use aktprocsym.}
+
+         { set the framepointer to esp for assembler functions }
+         { but only if the are no local variables           }
+         { already done in assembler_block }
 {$ifdef newcg}
-   tg.setfirsttemp(procinfo^.firsttemp_offset);
+         tg.setfirsttemp(procinfo^.firsttemp_offset);
 {$else newcg}
-   setfirsttemp(procinfo^.firsttemp_offset);
+         setfirsttemp(procinfo^.firsttemp_offset);
 {$endif newcg}
 
-   { ... and generate assembler }
-   { but set the right switches for entry !! }
-   aktlocalswitches:=entryswitches;
-   oldaktmaxfpuregisters:=aktmaxfpuregisters;
-   aktmaxfpuregisters:=localmaxfpuregisters;
+         { ... and generate assembler }
+         { but set the right switches for entry !! }
+         aktlocalswitches:=entryswitches;
+         oldaktmaxfpuregisters:=aktmaxfpuregisters;
+         aktmaxfpuregisters:=localmaxfpuregisters;
 {$ifndef NOPASS2}
-{$ifdef newcg}
-   if assigned(code) then
-     generatecode(code);
-{$else newcg}
-   if assigned(code) then
-     generatecode(code);
-{$endif newcg}
-   { set switches to status at end of procedure }
-   aktlocalswitches:=exitswitches;
+         if assigned(code) then
+           generatecode(code);
+         { set switches to status at end of procedure }
+         aktlocalswitches:=exitswitches;
 
-   if assigned(code) then
-     begin
-        aktprocsym^.definition^.code:=code;
+         if assigned(code) then
+           begin
+              aktprocsym^.definition^.code:=code;
 
-        { the procedure is now defined }
-        aktprocsym^.definition^.forwarddef:=false;
+              { the procedure is now defined }
+              aktprocsym^.definition^.forwarddef:=false;
 {$ifdef newcg}
-        aktprocsym^.definition^.usedregisters:=tg.usedinproc;
+              aktprocsym^.definition^.usedregisters:=tg.usedinproc;
 {$else newcg}
-        aktprocsym^.definition^.usedregisters:=usedinproc;
+              aktprocsym^.definition^.usedregisters:=usedinproc;
 {$endif newcg}
-     end;
+           end;
 
 {$ifdef newcg}
-   stackframe:=tg.gettempsize;
+         stackframe:=tg.gettempsize;
 {$else newcg}
-   stackframe:=gettempsize;
+         stackframe:=gettempsize;
 {$endif newcg}
 
-   { first generate entry code with the correct position and switches }
-   aktfilepos:=entrypos;
-   aktlocalswitches:=entryswitches;
+         { first generate entry code with the correct position and switches }
+         aktfilepos:=entrypos;
+         aktlocalswitches:=entryswitches;
 {$ifdef newcg}
-   if assigned(code) then
-     cg^.g_entrycode(procinfo^.aktentrycode,proc_names,make_global,stackframe,parasize,nostackframe,false);
+         if assigned(code) then
+           cg^.g_entrycode(procinfo^.aktentrycode,proc_names,make_global,stackframe,parasize,nostackframe,false);
 {$else newcg}
-   if assigned(code) then
-     genentrycode(procinfo^.aktentrycode,proc_names,make_global,stackframe,parasize,nostackframe,false);
+         if assigned(code) then
+           genentrycode(procinfo^.aktentrycode,proc_names,make_global,stackframe,parasize,nostackframe,false);
 {$endif newcg}
 
-   { now generate exit code with the correct position and switches }
-   aktfilepos:=exitpos;
-   aktlocalswitches:=exitswitches;
-   if assigned(code) then
-     begin
+         { now generate exit code with the correct position and switches }
+         aktfilepos:=exitpos;
+         aktlocalswitches:=exitswitches;
+         if assigned(code) then
+           begin
 {$ifdef newcg}
-       cg^.g_exitcode(procinfo^.aktexitcode,parasize,nostackframe,false);
+             cg^.g_exitcode(procinfo^.aktexitcode,parasize,nostackframe,false);
 {$else newcg}
-       genexitcode(procinfo^.aktexitcode,parasize,nostackframe,false);
+             genexitcode(procinfo^.aktexitcode,parasize,nostackframe,false);
 {$endif newcg}
-       procinfo^.aktproccode^.insertlist(procinfo^.aktentrycode);
-       procinfo^.aktproccode^.concatlist(procinfo^.aktexitcode);
+             procinfo^.aktproccode^.insertlist(procinfo^.aktentrycode);
+             procinfo^.aktproccode^.concatlist(procinfo^.aktexitcode);
 {$ifdef i386}
- {$ifndef NoOpt}
-       if (cs_optimize in aktglobalswitches) and
-       { do not optimize pure assembler procedures }
-         ((procinfo^.flags and pi_is_assembler)=0)  then
-           Optimize(procinfo^.aktproccode);
- {$endif NoOpt}
-{$endif}
-       { save local data (casetable) also in the same file }
-       if assigned(procinfo^.aktlocaldata) and
-          (not procinfo^.aktlocaldata^.empty) then
-         begin
-            procinfo^.aktproccode^.concat(new(pai_section,init(sec_data)));
-            procinfo^.aktproccode^.concatlist(procinfo^.aktlocaldata);
-            procinfo^.aktproccode^.concat(new(pai_section,init(sec_code)));
-         end;
-       { now we can insert a cut }
-       if (cs_create_smart in aktmoduleswitches) then
-         codesegment^.concat(new(pai_cut,init));
+   {$ifndef NoOpt}
+             if (cs_optimize in aktglobalswitches) and
+             { do not optimize pure assembler procedures }
+               ((procinfo^.flags and pi_is_assembler)=0)  then
+                 Optimize(procinfo^.aktproccode);
+   {$endif NoOpt}
+{$endif i386}
+             { save local data (casetable) also in the same file }
+             if assigned(procinfo^.aktlocaldata) and
+                (not procinfo^.aktlocaldata^.empty) then
+               begin
+                  procinfo^.aktproccode^.concat(new(pai_section,init(sec_data)));
+                  procinfo^.aktproccode^.concatlist(procinfo^.aktlocaldata);
+                  procinfo^.aktproccode^.concat(new(pai_section,init(sec_code)));
+               end;
+             { now we can insert a cut }
+             if (cs_create_smart in aktmoduleswitches) then
+               codesegment^.concat(new(pai_cut,init));
 
-       { add the procedure to the codesegment }
-       codesegment^.concatlist(procinfo^.aktproccode);
-     end;
-{$else}
-   if assigned(code) then
-    firstpass(code);
+             { add the procedure to the codesegment }
+             codesegment^.concatlist(procinfo^.aktproccode);
+           end;
+{$else NOPASS2}
+         if assigned(code) then
+          firstpass(code);
 {$endif NOPASS2}
 
-   { ... remove symbol tables, for the browser leave the static table }
-{    if (cs_browser in aktmoduleswitches) and (symtablestack^.symtabletype=staticsymtable) then
-    symtablestack^.next:=symtablestack^.next^.next
-   else }
-   if lexlevel>=normal_function_level then
-     symtablestack:=symtablestack^.next^.next
-   else
-     symtablestack:=symtablestack^.next;
-
-   { ... check for unused symbols      }
-   { but only if there is no asm block }
-   if assigned(code) then
-     begin
-       if (Errorcount=0) then
-         begin
-           aktprocsym^.definition^.localst^.check_forwards;
-           aktprocsym^.definition^.localst^.checklabels;
-         end;
-       if (procinfo^.flags and pi_uses_asm)=0 then
-         begin
-            { not for unit init, becuase the var can be used in finalize,
-              it will be done in proc_unit }
-            if not(aktprocsym^.definition^.proctypeoption
-               in [potype_proginit,potype_unitinit,potype_unitfinalize]) then
-               aktprocsym^.definition^.localst^.allsymbolsused;
-            aktprocsym^.definition^.parast^.allsymbolsused;
-         end;
-     end;
-
-   { the local symtables can be deleted, but the parast   }
-   { doesn't, (checking definitons when calling a        }
-   { function                                        }
-   { not for a inline procedure !!               (PM)   }
-   { at lexlevel = 1 localst is the staticsymtable itself }
-   { so no dispose here !!                              }
-   if assigned(code) and
-      not(cs_browser in aktmoduleswitches) and
-      not(pocall_inline in aktprocsym^.definition^.proccalloptions) then
-     begin
-       if lexlevel>=normal_function_level then
-         dispose(aktprocsym^.definition^.localst,done);
-       aktprocsym^.definition^.localst:=nil;
-     end;
+         { ... remove symbol tables, for the browser leave the static table }
+      {    if (cs_browser in aktmoduleswitches) and (symtablestack^.symtabletype=staticsymtable) then
+          symtablestack^.next:=symtablestack^.next^.next
+         else }
+         if lexlevel>=normal_function_level then
+           symtablestack:=symtablestack^.next^.next
+         else
+           symtablestack:=symtablestack^.next;
+
+         { ... check for unused symbols      }
+         { but only if there is no asm block }
+         if assigned(code) then
+           begin
+             if (Errorcount=0) then
+               begin
+                 aktprocsym^.definition^.localst^.check_forwards;
+                 aktprocsym^.definition^.localst^.checklabels;
+               end;
+             if (procinfo^.flags and pi_uses_asm)=0 then
+               begin
+                  { not for unit init, becuase the var can be used in finalize,
+                    it will be done in proc_unit }
+                  if not(aktprocsym^.definition^.proctypeoption
+                     in [potype_proginit,potype_unitinit,potype_unitfinalize]) then
+                     aktprocsym^.definition^.localst^.allsymbolsused;
+                  aktprocsym^.definition^.parast^.allsymbolsused;
+               end;
+           end;
 
-{$ifdef newcg}
-   { all registers can be used again }
-   tg.resetusableregisters;
-   { only now we can remove the temps }
-   tg.resettempgen;
-{$else newcg}
-   { all registers can be used again }
-   resetusableregisters;
-   { only now we can remove the temps }
-   resettempgen;
-{$endif newcg}
+         { the local symtables can be deleted, but the parast   }
+         { doesn't, (checking definitons when calling a        }
+         { function                                        }
+         { not for a inline procedure !!               (PM)   }
+         { at lexlevel = 1 localst is the staticsymtable itself }
+         { so no dispose here !!                              }
+         if assigned(code) and
+            not(cs_browser in aktmoduleswitches) and
+            not(pocall_inline in aktprocsym^.definition^.proccalloptions) then
+           begin
+             if lexlevel>=normal_function_level then
+               dispose(aktprocsym^.definition^.localst,done);
+             aktprocsym^.definition^.localst:=nil;
+           end;
 
-   { remove code tree, if not inline procedure }
-   if assigned(code) and not(pocall_inline in aktprocsym^.definition^.proccalloptions) then
 {$ifdef newcg}
-     {!!!!!!! dispose(code,done); }
-     disposetree(code);
+         { all registers can be used again }
+         tg.resetusableregisters;
+         { only now we can remove the temps }
+         tg.resettempgen;
 {$else newcg}
-     disposetree(code);
+         { all registers can be used again }
+         resetusableregisters;
+         { only now we can remove the temps }
+         resettempgen;
 {$endif newcg}
 
-   { remove class member symbol tables }
-   while symtablestack^.symtabletype=objectsymtable do
-     symtablestack:=symtablestack^.next;
-
-   aktmaxfpuregisters:=oldaktmaxfpuregisters;
-
-   { restore filepos, the switches are already set }
-   aktfilepos:=savepos;
-   { restore labels }
-   aktexitlabel:=oldexitlabel;
-   aktexit2label:=oldexit2label;
-   quickexitlabel:=oldquickexitlabel;
-   faillabel:=oldfaillabel;
+         { remove code tree, if not inline procedure }
+         if assigned(code) and not(pocall_inline in aktprocsym^.definition^.proccalloptions) then
+           code.free;
+
+         { remove class member symbol tables }
+         while symtablestack^.symtabletype=objectsymtable do
+           symtablestack:=symtablestack^.next;
+
+         aktmaxfpuregisters:=oldaktmaxfpuregisters;
+
+         { restore filepos, the switches are already set }
+         aktfilepos:=savepos;
+         { restore labels }
+         aktexitlabel:=oldexitlabel;
+         aktexit2label:=oldexit2label;
+         quickexitlabel:=oldquickexitlabel;
+         faillabel:=oldfaillabel;
+
+         { reset to normal non static function }
+         if (lexlevel=normal_function_level) then
+           allow_only_static:=false;
+         { previous lexlevel }
+         dec(lexlevel);
+      end;
 
-   { reset to normal non static function }
-   if (lexlevel=normal_function_level) then
-     allow_only_static:=false;
-   { previous lexlevel }
-   dec(lexlevel);
-end;
 
+{****************************************************************************
+                        PROCEDURE/FUNCTION PARSING
+****************************************************************************}
 
-procedure parse_proc_directives(Anames:Pstringcontainer;var pdflags:word);
-{
-  Parse the procedure directives. It does not matter if procedure directives
-  are written using ;procdir; or ['procdir'] syntax.
-}
-var
-  res : boolean;
-begin
-  while token in [_ID,_LECKKLAMMER] do
-   begin
-     if try_to_consume(_LECKKLAMMER) then
+      procedure checkvaluepara(p:pnamedindexobject);
+      var
+        vs : pvarsym;
+        s  : string;
       begin
-        repeat
-          parse_proc_direc(Anames^,pdflags);
-        until not try_to_consume(_COMMA);
-        consume(_RECKKLAMMER);
-        { we always expect at least '[];' }
-        res:=true;
-      end
-     else
-      res:=parse_proc_direc(Anames^,pdflags);
-   { A procedure directive normally followed by a semicolon, but in
-     a const section we should stop when _EQUAL is found }
-     if res then
-      begin
-        if (block_type=bt_const) and
-           (token=_EQUAL) then
-         break;
-        { support procedure proc;stdcall export; in Delphi mode only }
-        if not((m_delphi in aktmodeswitches) and
-               is_proc_directive(token)) then
-         consume(_SEMICOLON);
-      end
-     else
-      break;
-   end;
-end;
-
-procedure parse_var_proc_directives(var sym : psym);
-var
-  anames  : pstringcontainer;
-  pdflags : word;
-  oldsym  : pprocsym;
-  pd      : pabstractprocdef;
-begin
-  oldsym:=aktprocsym;
-  anames:=new(pstringcontainer,init);
-  pdflags:=pd_procvar;
-  { we create a temporary aktprocsym to read the directives }
-  aktprocsym:=new(pprocsym,init(sym^.name));
-  case sym^.typ of
-    varsym :
-      pd:=pabstractprocdef(pvarsym(sym)^.vartype.def);
-    typedconstsym :
-      pd:=pabstractprocdef(ptypedconstsym(sym)^.typedconsttype.def);
-    typesym :
-      pd:=pabstractprocdef(ptypesym(sym)^.restype.def);
-    else
-      internalerror(994932432);
-  end;
-  if pd^.deftype<>procvardef then
-   internalerror(994932433);
-  pabstractprocdef(aktprocsym^.definition):=pd;
-  { names should never be used anyway }
-  inc(lexlevel);
-  parse_proc_directives(anames,pdflags);
-  dec(lexlevel);
-  aktprocsym^.definition:=nil;
-  dispose(aktprocsym,done);
-  dispose(anames,done);
-  aktprocsym:=oldsym;
-end;
-
-procedure parse_object_proc_directives(var sym : pprocsym);
-var
-  anames : pstringcontainer;
-  pdflags : word;
-begin
-  pdflags:=pd_object;
-  anames:=new(pstringcontainer,init);
-  inc(lexlevel);
-  parse_proc_directives(anames,pdflags);
-  dec(lexlevel);
-  dispose(anames,done);
-  if (po_containsself in aktprocsym^.definition^.procoptions) and
-     (([po_msgstr,po_msgint]*aktprocsym^.definition^.procoptions)=[]) then
-    Message(parser_e_self_in_non_message_handler);
-end;
-
-procedure checkvaluepara(p:pnamedindexobject);
-var
-  vs : pvarsym;
-  s  : string;
-begin
-  with pvarsym(p)^ do
-   begin
-     if copy(name,1,3)='val' then
-      begin
-        s:=Copy(name,4,255);
-        if not(po_assembler in aktprocsym^.definition^.procoptions) then
+        with pvarsym(p)^ do
          begin
-           vs:=new(Pvarsym,initdef(s,vartype.def));
-           vs^.fileinfo:=fileinfo;
-           vs^.varspez:=varspez;
-           aktprocsym^.definition^.localst^.insert(vs);
-           include(vs^.varoptions,vo_is_local_copy);
-           vs^.varstate:=vs_assigned;
-           localvarsym:=vs;
-           inc(refs); { the para was used to set the local copy ! }
-           { warnings only on local copy ! }
-           varstate:=vs_used;
-         end
-        else
-         begin
-           aktprocsym^.definition^.parast^.rename(name,s);
+           if copy(name,1,3)='val' then
+            begin
+              s:=Copy(name,4,255);
+              if not(po_assembler in aktprocsym^.definition^.procoptions) then
+               begin
+                 vs:=new(Pvarsym,initdef(s,vartype.def));
+                 vs^.fileinfo:=fileinfo;
+                 vs^.varspez:=varspez;
+                 aktprocsym^.definition^.localst^.insert(vs);
+                 include(vs^.varoptions,vo_is_local_copy);
+                 vs^.varstate:=vs_assigned;
+                 localvarsym:=vs;
+                 inc(refs); { the para was used to set the local copy ! }
+                 { warnings only on local copy ! }
+                 varstate:=vs_used;
+               end
+              else
+               begin
+                 aktprocsym^.definition^.parast^.rename(name,s);
+               end;
+            end;
          end;
       end;
-   end;
-end;
 
 
-procedure read_proc;
-{
-  Parses the procedure directives, then parses the procedure body, then
-  generates the code for it
-}
-var
-  oldprefix     : string;
-  oldprocsym       : Pprocsym;
-  oldprocinfo      : pprocinfo;
-  oldconstsymtable : Psymtable;
-  oldfilepos       : tfileposinfo;
-  names           : Pstringcontainer;
-  pdflags         : word;
-  prevdef,stdef   : pprocdef;
-begin
-{ save old state }
-   oldprocsym:=aktprocsym;
-   oldprefix:=procprefix;
-   oldconstsymtable:=constsymtable;
-   oldprocinfo:=procinfo;
-{ create a new procedure }
-   new(names,init);
+    procedure read_proc;
+      {
+        Parses the procedure directives, then parses the procedure body, then
+        generates the code for it
+      }
+      var
+        oldprefix     : string;
+        oldprocsym       : Pprocsym;
+        oldprocinfo      : pprocinfo;
+        oldconstsymtable : Psymtable;
+        oldfilepos       : tfileposinfo;
+        names           : Pstringcontainer;
+        pdflags         : word;
+        prevdef,stdef   : pprocdef;
+      begin
+      { save old state }
+         oldprocsym:=aktprocsym;
+         oldprefix:=procprefix;
+         oldconstsymtable:=constsymtable;
+         oldprocinfo:=procinfo;
+      { create a new procedure }
+         new(names,init);
 {$ifdef fixLeaksOnError}
-   strContStack.push(names);
+         strContStack.push(names);
 {$endif fixLeaksOnError}
-   codegen_newprocedure;
-   with procinfo^ do
-    begin
-      parent:=oldprocinfo;
-    { clear flags }
-      flags:=0;
-    { standard frame pointer }
-      framepointer:=frame_pointer;
-      { funcret_is_valid:=false; }
-      funcret_state:=vs_declared;
-    { is this a nested function of a method ? }
-      if assigned(oldprocinfo) then
-        _class:=oldprocinfo^._class;
-    end;
-
-   parse_proc_dec;
-
-   procinfo^.sym:=aktprocsym;
-   procinfo^.def:=aktprocsym^.definition;
-
-{ set the default function options }
-   if parse_only then
-    begin
-      aktprocsym^.definition^.forwarddef:=true;
-      { set also the interface flag, for better error message when the
-        implementation doesn't much this header }
-      aktprocsym^.definition^.interfacedef:=true;
-      pdflags:=pd_interface;
-    end
-   else
-    begin
-      pdflags:=pd_body;
-      if current_module^.in_implementation then
-       pdflags:=pdflags or pd_implemen;
-      if (not current_module^.is_unit) or (cs_create_smart in aktmoduleswitches) then
-       pdflags:=pdflags or pd_global;
-      procinfo^.exported:=false;
-      aktprocsym^.definition^.forwarddef:=false;
-    end;
-
-{ parse the directives that may follow }
-   inc(lexlevel);
-   parse_proc_directives(names,pdflags);
-   dec(lexlevel);
-
-{ set aktfilepos to the beginning of the function declaration }
-   oldfilepos:=aktfilepos;
-   aktfilepos:=aktprocsym^.definition^.fileinfo;
-
-{ search for forward declarations }
-   if not check_identical_proc(prevdef) then
-     begin
-     { A method must be forward defined (in the object declaration) }
-       if assigned(procinfo^._class) and (not assigned(oldprocinfo^._class)) then
-        begin
-          Message1(parser_e_header_dont_match_any_member,aktprocsym^.demangledName);
-          aktprocsym^.write_parameter_lists(aktprocsym^.definition);
-        end
-       else
-        begin
-          { Give a better error if there is a forward def in the interface and only
-            a single implementation }
-          if (not aktprocsym^.definition^.forwarddef) and
-             assigned(aktprocsym^.definition^.nextoverloaded) and
-             aktprocsym^.definition^.nextoverloaded^.forwarddef and
-             aktprocsym^.definition^.nextoverloaded^.interfacedef and
-             not(assigned(aktprocsym^.definition^.nextoverloaded^.nextoverloaded)) then
-           begin
-             Message1(parser_e_header_dont_match_forward,aktprocsym^.demangledName);
-             aktprocsym^.write_parameter_lists(aktprocsym^.definition);
-           end
-          else
+         codegen_newprocedure;
+         with procinfo^ do
+          begin
+            parent:=oldprocinfo;
+          { clear flags }
+            flags:=0;
+          { standard frame pointer }
+            framepointer:=frame_pointer;
+            { funcret_is_valid:=false; }
+            funcret_state:=vs_declared;
+          { is this a nested function of a method ? }
+            if assigned(oldprocinfo) then
+              _class:=oldprocinfo^._class;
+          end;
+
+         parse_proc_dec;
+
+         procinfo^.sym:=aktprocsym;
+         procinfo^.def:=aktprocsym^.definition;
+
+      { set the default function options }
+         if parse_only then
+          begin
+            aktprocsym^.definition^.forwarddef:=true;
+            { set also the interface flag, for better error message when the
+              implementation doesn't much this header }
+            aktprocsym^.definition^.interfacedef:=true;
+            pdflags:=pd_interface;
+          end
+         else
+          begin
+            pdflags:=pd_body;
+            if current_module^.in_implementation then
+             pdflags:=pdflags or pd_implemen;
+            if (not current_module^.is_unit) or (cs_create_smart in aktmoduleswitches) then
+             pdflags:=pdflags or pd_global;
+            procinfo^.exported:=false;
+            aktprocsym^.definition^.forwarddef:=false;
+          end;
+
+      { parse the directives that may follow }
+         inc(lexlevel);
+         parse_proc_directives(names,pdflags);
+         dec(lexlevel);
+
+      { set aktfilepos to the beginning of the function declaration }
+         oldfilepos:=aktfilepos;
+         aktfilepos:=aktprocsym^.definition^.fileinfo;
+
+      { search for forward declarations }
+         if not check_identical_proc(prevdef) then
            begin
-           { check the global flag }
-             if (procinfo^.flags and pi_is_global)<>0 then
-               Message(parser_e_overloaded_must_be_all_global);
+           { A method must be forward defined (in the object declaration) }
+             if assigned(procinfo^._class) and (not assigned(oldprocinfo^._class)) then
+              begin
+                Message1(parser_e_header_dont_match_any_member,aktprocsym^.demangledName);
+                aktprocsym^.write_parameter_lists(aktprocsym^.definition);
+              end
+             else
+              begin
+                { Give a better error if there is a forward def in the interface and only
+                  a single implementation }
+                if (not aktprocsym^.definition^.forwarddef) and
+                   assigned(aktprocsym^.definition^.nextoverloaded) and
+                   aktprocsym^.definition^.nextoverloaded^.forwarddef and
+                   aktprocsym^.definition^.nextoverloaded^.interfacedef and
+                   not(assigned(aktprocsym^.definition^.nextoverloaded^.nextoverloaded)) then
+                 begin
+                   Message1(parser_e_header_dont_match_forward,aktprocsym^.demangledName);
+                   aktprocsym^.write_parameter_lists(aktprocsym^.definition);
+                 end
+                else
+                 begin
+                 { check the global flag }
+                   if (procinfo^.flags and pi_is_global)<>0 then
+                     Message(parser_e_overloaded_must_be_all_global);
+                 end;
+              end;
            end;
-        end;
-     end;
 
-   { set return type here, becuase the aktprocsym^.definition can be
-     changed by check_identical_proc (PFV) }
-   procinfo^.returntype.def:=aktprocsym^.definition^.rettype.def;
+         { set return type here, becuase the aktprocsym^.definition can be
+           changed by check_identical_proc (PFV) }
+         procinfo^.returntype.def:=aktprocsym^.definition^.rettype.def;
 
 {$ifdef i386}
-   if (po_interrupt in aktprocsym^.definition^.procoptions) then
-     begin
-       { we push Flags and CS as long
-         to cope with the IRETD
-         and we save 6 register + 4 selectors }
-       inc(procinfo^.para_offset,8+6*4+4*2);
-     end;
+         if (po_interrupt in aktprocsym^.definition^.procoptions) then
+           begin
+             { we push Flags and CS as long
+               to cope with the IRETD
+               and we save 6 register + 4 selectors }
+             inc(procinfo^.para_offset,8+6*4+4*2);
+           end;
 {$endif i386}
 
-   { pointer to the return value ? }
-   if ret_in_param(procinfo^.returntype.def) then
-    begin
-      procinfo^.return_offset:=procinfo^.para_offset;
-      inc(procinfo^.para_offset,target_os.size_of_pointer);
-    end;
-   { allows to access the parameters of main functions in nested functions }
-   aktprocsym^.definition^.parast^.address_fixup:=procinfo^.para_offset;
-
-   { 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 aktprocsym^.definition^.forwarddef) then
-     aktprocsym^.definition^.parast^.foreach({$ifdef FPCPROCVAR}@{$endif}checkvaluepara);
-
-{ restore file pos }
-   aktfilepos:=oldfilepos;
-
-{ compile procedure when a body is needed }
-   if (pdflags and pd_body)<>0 then
-     begin
-       Message1(parser_p_procedure_start,aktprocsym^.demangledname);
-       names^.insert(aktprocsym^.definition^.mangledname);
-      { set _FAIL as keyword if constructor }
-      if (aktprocsym^.definition^.proctypeoption=potype_constructor) then
-        tokeninfo^[_FAIL].keyword:=m_all;
-      if assigned(aktprocsym^.definition^._class) then
-        tokeninfo^[_SELF].keyword:=m_all;
-
-       compile_proc_body(names^,((pdflags and pd_global)<>0),assigned(oldprocinfo^._class));
-
-      { reset _FAIL as normal }
-      if (aktprocsym^.definition^.proctypeoption=potype_constructor) then
-        tokeninfo^[_FAIL].keyword:=m_none;
-      if assigned(aktprocsym^.definition^._class) and (lexlevel=main_program_level) then
-        tokeninfo^[_SELF].keyword:=m_none;
-       consume(_SEMICOLON);
-     end;
-{ close }
+         { pointer to the return value ? }
+         if ret_in_param(procinfo^.returntype.def) then
+          begin
+            procinfo^.return_offset:=procinfo^.para_offset;
+            inc(procinfo^.para_offset,target_os.size_of_pointer);
+          end;
+         { allows to access the parameters of main functions in nested functions }
+         aktprocsym^.definition^.parast^.address_fixup:=procinfo^.para_offset;
+
+         { 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 aktprocsym^.definition^.forwarddef) then
+           aktprocsym^.definition^.parast^.foreach({$ifdef FPCPROCVAR}@{$endif}checkvaluepara);
+
+      { restore file pos }
+         aktfilepos:=oldfilepos;
+
+      { compile procedure when a body is needed }
+         if (pdflags and pd_body)<>0 then
+           begin
+             Message1(parser_p_procedure_start,aktprocsym^.demangledname);
+             names^.insert(aktprocsym^.definition^.mangledname);
+            { set _FAIL as keyword if constructor }
+            if (aktprocsym^.definition^.proctypeoption=potype_constructor) then
+              tokeninfo^[_FAIL].keyword:=m_all;
+            if assigned(aktprocsym^.definition^._class) then
+              tokeninfo^[_SELF].keyword:=m_all;
+
+             compile_proc_body(names^,((pdflags and pd_global)<>0),assigned(oldprocinfo^._class));
+
+            { reset _FAIL as normal }
+            if (aktprocsym^.definition^.proctypeoption=potype_constructor) then
+              tokeninfo^[_FAIL].keyword:=m_none;
+            if assigned(aktprocsym^.definition^._class) and (lexlevel=main_program_level) then
+              tokeninfo^[_SELF].keyword:=m_none;
+             consume(_SEMICOLON);
+           end;
+      { close }
 {$ifdef fixLeaksOnError}
-   if names <> strContStack.pop then
-     writeln('problem with strContStack in psub!');
+         if names <> strContStack.pop then
+           writeln('problem with strContStack in psub!');
 {$endif fixLeaksOnError}
-   dispose(names,done);
-   codegen_doneprocedure;
-{ Restore old state }
-   constsymtable:=oldconstsymtable;
-   { from now on all refernece to mangledname means
-     that the function is already used }
-   aktprocsym^.definition^.count:=true;
-   { restore the interface order to maintain CRC values PM }
-   if assigned(prevdef) and assigned(aktprocsym^.definition^.nextoverloaded) then
-     begin
-       stdef:=aktprocsym^.definition;
-       aktprocsym^.definition:=stdef^.nextoverloaded;
-       stdef^.nextoverloaded:=prevdef^.nextoverloaded;
-       prevdef^.nextoverloaded:=stdef;
-     end;
-   aktprocsym:=oldprocsym;
-   procprefix:=oldprefix;
-   procinfo:=oldprocinfo;
-   opsym:=nil;
-end;
+         dispose(names,done);
+         codegen_doneprocedure;
+      { Restore old state }
+         constsymtable:=oldconstsymtable;
+         { from now on all refernece to mangledname means
+           that the function is already used }
+         aktprocsym^.definition^.count:=true;
+         { restore the interface order to maintain CRC values PM }
+         if assigned(prevdef) and assigned(aktprocsym^.definition^.nextoverloaded) then
+           begin
+             stdef:=aktprocsym^.definition;
+             aktprocsym^.definition:=stdef^.nextoverloaded;
+             stdef^.nextoverloaded:=prevdef^.nextoverloaded;
+             prevdef^.nextoverloaded:=stdef;
+           end;
+         aktprocsym:=oldprocsym;
+         procprefix:=oldprefix;
+         procinfo:=oldprocinfo;
+         opsym:=nil;
+      end;
+
+
+{****************************************************************************
+                             DECLARATION PARSING
+****************************************************************************}
+
+    procedure read_declarations(islibrary : boolean);
+
+        procedure Not_supported_for_inline(t : ttoken);
+        begin
+           if assigned(aktprocsym) and
+              (pocall_inline in aktprocsym^.definition^.proccalloptions) then
+             Begin
+                Message1(parser_w_not_supported_for_inline,tokenstring(t));
+                Message(parser_w_inlining_disabled);
+                exclude(aktprocsym^.definition^.proccalloptions,pocall_inline);
+             End;
+        end;
+
+      begin
+         repeat
+           case token of
+              _LABEL:
+                begin
+                   Not_supported_for_inline(token);
+                   label_dec;
+                end;
+              _CONST:
+                begin
+                   Not_supported_for_inline(token);
+                   const_dec;
+                end;
+              _TYPE:
+                begin
+                   Not_supported_for_inline(token);
+                   type_dec;
+                end;
+              _VAR:
+                var_dec;
+              _THREADVAR:
+                threadvar_dec;
+              _CONSTRUCTOR,_DESTRUCTOR,
+              _FUNCTION,_PROCEDURE,_OPERATOR,_CLASS:
+                begin
+                   Not_supported_for_inline(token);
+                   read_proc;
+                end;
+              _RESOURCESTRING:
+                resourcestring_dec;
+              _EXPORTS:
+                begin
+                   Not_supported_for_inline(token);
+                   { here we should be at lexlevel 1, no ? PM }
+                   if (lexlevel<>main_program_level) or
+                      (current_module^.is_unit) then
+                     begin
+                        Message(parser_e_syntax_error);
+                        consume_all_until(_SEMICOLON);
+                     end
+                   else if islibrary or (target_info.target=target_i386_WIN32)
+                   or (target_info.target=target_i386_Netware) then  // AD
+                     read_exports;
+                end
+              else break;
+           end;
+         until false;
+      end;
+
+
+    procedure read_interface_declarations;
+      begin
+         {Since the body is now parsed at lexlevel 1, and the declarations
+          must be parsed at the same lexlevel we increase the lexlevel.}
+         inc(lexlevel);
+         repeat
+           case token of
+             _CONST :
+               const_dec;
+             _TYPE :
+               type_dec;
+             _VAR :
+               var_dec;
+             _THREADVAR :
+               threadvar_dec;
+             _RESOURCESTRING:
+               resourcestring_dec;
+             _FUNCTION,
+             _PROCEDURE,
+             _OPERATOR :
+               read_proc;
+             else
+               break;
+           end;
+         until false;
+         dec(lexlevel);
+      end;
 
 end.
 {
   $Log$
-  Revision 1.15  2000-09-24 21:33:47  peter
+  Revision 1.16  2000-10-14 10:14:52  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.15  2000/09/24 21:33:47  peter
     * message updates merges
 
   Revision 1.14  2000/09/24 21:19:51  peter

compiler/psystem.pas

@@ -38,7 +38,7 @@ procedure createconstdefs;
 implementation
 
 uses
-  globtype,globals,symconst,tree;
+  globtype,globals,symconst,ninl;
 
 procedure insertinternsyms(p : psymtable);
 {
@@ -255,7 +255,10 @@ end;
 end.
 {
   $Log$
-  Revision 1.5  2000-09-24 15:06:24  peter
+  Revision 1.6  2000-10-14 10:14:52  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.5  2000/09/24 15:06:24  peter
     * use defines.inc
 
   Revision 1.4  2000/08/27 20:19:39  peter
@@ -268,4 +271,4 @@ end.
   Revision 1.2  2000/07/13 11:32:47  michael
   + removed logs
 
-}
+}

compiler/ptconst.pas

@@ -44,11 +44,11 @@ implementation
        globtype,systems,tokens,cpuinfo,
        cutils,cobjects,globals,scanner,
        symconst,aasm,types,verbose,
-       tree,pass_1,
+       { pass 1 }
+       node,pass_1,
+       nmat,nadd,ncal,nmem,nset,ncnv,ninl,ncon,nld,nflw,
        { parser specific stuff }
        pbase,pexpr,
-       { processor specific stuff }
-       cpubase,
        { codegen }
 {$ifdef newcg}
        cgbase,
@@ -69,7 +69,7 @@ implementation
          j : longint;
 {$endif m68k}
          len,base  : longint;
-         p,hp      : ptree;
+         p,hp      : tnode;
          i,l,offset,
          strlength : longint;
          curconstsegment : paasmoutput;
@@ -84,8 +84,8 @@ implementation
 
       procedure check_range;
         begin
-           if ((p^.value>porddef(def)^.high) or
-               (p^.value<porddef(def)^.low)) then
+           if ((tordconstnode(p).value>porddef(def)^.high) or
+               (tordconstnode(p).value<porddef(def)^.low)) then
              begin
                 if (cs_check_range in aktlocalswitches) then
                   Message(parser_e_range_check_error)
@@ -94,13 +94,6 @@ implementation
              end;
         end;
 
-(*      function is_po_equal(o1,o2:longint):boolean;
-        begin
-        { assembler does not affect }
-          is_po_equal:=(o1 and not(poassembler))=
-                       (o2 and not(poassembler));
-        end; *)
-
 {$R-}  {Range check creates problem with init_8bit(-1) !!}
       begin
          if no_change_allowed then
@@ -113,277 +106,273 @@ implementation
                  p:=comp_expr(true);
                  do_firstpass(p);
                  case porddef(def)^.typ of
+                    bool8bit :
+                      begin
+                         if is_constboolnode(p) then
+                           curconstsegment^.concat(new(pai_const,init_8bit(tordconstnode(p).value)))
+                         else
+                           Message(cg_e_illegal_expression);
+                      end;
+                    bool16bit :
+                      begin
+                         if is_constboolnode(p) then
+                           curconstsegment^.concat(new(pai_const,init_16bit(tordconstnode(p).value)))
+                         else
+                           Message(cg_e_illegal_expression);
+                      end;
+                    bool32bit :
+                      begin
+                         if is_constboolnode(p) then
+                           curconstsegment^.concat(new(pai_const,init_32bit(tordconstnode(p).value)))
+                         else
+                           Message(cg_e_illegal_expression);
+                      end;
+                    uchar :
+                      begin
+                         if is_constcharnode(p) then
+                           curconstsegment^.concat(new(pai_const,init_8bit(tordconstnode(p).value)))
+                         else
+                           Message(cg_e_illegal_expression);
+                      end;
+                    uwidechar :
+                      begin
+                         if is_constcharnode(p) then
+                           curconstsegment^.concat(new(pai_const,init_16bit(tordconstnode(p).value)))
+                         else
+                           Message(cg_e_illegal_expression);
+                      end;
                     s8bit,
-                    u8bit : begin
-                               if not is_constintnode(p) then
-                               { is't an int expected }
-                                 Message(cg_e_illegal_expression)
-                               else
-                                 begin
-                                    curconstsegment^.concat(new(pai_const,init_8bit(p^.value)));
-                                    check_range;
-                                 end;
-                            end;
-                    s32bit : begin
-                                if not is_constintnode(p) then
-                                  Message(cg_e_illegal_expression)
-                                else
-                                  begin
-                                     curconstsegment^.concat(new(pai_const,init_32bit(p^.value)));
-                                     check_range;
-                                  end;
-                            end;
-                    u32bit : begin
-                                if not is_constintnode(p) then
-                                  Message(cg_e_illegal_expression)
-                                else
-                                   curconstsegment^.concat(new(pai_const,init_32bit(p^.value)));
-                             end;
-                    bool8bit : begin
-                                  if not is_constboolnode(p) then
-                                    Message(cg_e_illegal_expression);
-                                  curconstsegment^.concat(new(pai_const,init_8bit(p^.value)));
-                               end;
-                    bool16bit : begin
-                                  if not is_constboolnode(p) then
-                                    Message(cg_e_illegal_expression);
-                                  curconstsegment^.concat(new(pai_const,init_16bit(p^.value)));
-                               end;
-                    bool32bit : begin
-                                  if not is_constboolnode(p) then
-                                    Message(cg_e_illegal_expression);
-                                  curconstsegment^.concat(new(pai_const,init_32bit(p^.value)));
-                               end;
-                    uchar : begin
-                                if not is_constcharnode(p) then
-                                  Message(cg_e_illegal_expression);
-                                curconstsegment^.concat(new(pai_const,init_8bit(p^.value)));
-                            end;
-                    uwidechar : begin
-                                if not is_constcharnode(p) then
-                                  Message(cg_e_illegal_expression);
-                                curconstsegment^.concat(new(pai_const,init_16bit(p^.value)));
-                            end;
+                    u8bit :
+                      begin
+                         if is_constintnode(p) then
+                           begin
+                              curconstsegment^.concat(new(pai_const,init_8bit(tordconstnode(p).value)));
+                              check_range;
+                           end
+                         else
+                           Message(cg_e_illegal_expression);
+                      end;
                     u16bit,
-                    s16bit : begin
-                                if not is_constintnode(p) then
-                                  Message(cg_e_illegal_expression);
-                                curconstsegment^.concat(new(pai_const,init_16bit(p^.value)));
-                                check_range;
-                            end;
+                    s16bit :
+                      begin
+                         if is_constintnode(p) then
+                           begin
+                             curconstsegment^.concat(new(pai_const,init_16bit(tordconstnode(p).value)));
+                             check_range;
+                           end
+                         else
+                           Message(cg_e_illegal_expression);
+                     end;
+                    s32bit,
+                    u32bit :
+                      begin
+                         if is_constintnode(p) then
+                           begin
+                              curconstsegment^.concat(new(pai_const,init_32bit(tordconstnode(p).value)));
+                              if porddef(def)^.typ<>u32bit then
+                               check_range;
+                           end
+                         else
+                           Message(cg_e_illegal_expression);
+                      end;
                     s64bit,
                     u64bit:
                       begin
-                         if not is_constintnode(p) then
-                           Message(cg_e_illegal_expression)
-                         else
+                         if is_constintnode(p) then
                            begin
                               {!!!!! hmmm, we can write yet only consts til 2^32-1 :( (FK) }
-                              curconstsegment^.concat(new(pai_const,init_32bit(p^.value)));
+                              curconstsegment^.concat(new(pai_const,init_32bit(tordconstnode(p).value)));
                               curconstsegment^.concat(new(pai_const,init_32bit(0)));
-                           end;
+                           end
+                         else
+                           Message(cg_e_illegal_expression);
                       end;
                     else
                       internalerror(3799);
                  end;
-                 disposetree(p);
+                 p.free;
               end;
          floatdef:
            begin
               p:=comp_expr(true);
               do_firstpass(p);
               if is_constrealnode(p) then
-                value:=p^.value_real
+                value:=trealconstnode(p).value_real
               else if is_constintnode(p) then
-                value:=p^.value
+                value:=tordconstnode(p).value
               else
                 Message(cg_e_illegal_expression);
 
               case pfloatdef(def)^.typ of
-                 s32real : curconstsegment^.concat(new(pai_real_32bit,init(value)));
-                 s64real : curconstsegment^.concat(new(pai_real_64bit,init(value)));
-                 s80real : curconstsegment^.concat(new(pai_real_80bit,init(value)));
-                 s64comp  : curconstsegment^.concat(new(pai_comp_64bit,init(value)));
-                 f32bit : curconstsegment^.concat(new(pai_const,init_32bit(trunc(value*65536))));
-              else internalerror(18);
+                 s32real :
+                   curconstsegment^.concat(new(pai_real_32bit,init(value)));
+                 s64real :
+                   curconstsegment^.concat(new(pai_real_64bit,init(value)));
+                 s80real :
+                   curconstsegment^.concat(new(pai_real_80bit,init(value)));
+                 s64comp :
+                   curconstsegment^.concat(new(pai_comp_64bit,init(value)));
+                 f32bit :
+                   curconstsegment^.concat(new(pai_const,init_32bit(trunc(value*65536))));
+                 else
+                   internalerror(18);
               end;
-              disposetree(p);
+              p.free;
            end;
          classrefdef:
            begin
               p:=comp_expr(true);
               do_firstpass(p);
-              case p^.treetype of
+              case p.nodetype of
                  loadvmtn:
                    begin
-                      if not(pobjectdef(pclassrefdef(p^.resulttype)^.pointertype.def)^.is_related(
+                      if not(pobjectdef(pclassrefdef(p.resulttype)^.pointertype.def)^.is_related(
                         pobjectdef(pclassrefdef(def)^.pointertype.def))) then
                         Message(cg_e_illegal_expression);
                       curconstsegment^.concat(new(pai_const_symbol,init(newasmsymbol(pobjectdef(
-                        pclassrefdef(p^.resulttype)^.pointertype.def)^.vmt_mangledname))));
+                        pclassrefdef(p.resulttype)^.pointertype.def)^.vmt_mangledname))));
                    end;
                  niln:
                    curconstsegment^.concat(new(pai_const,init_32bit(0)));
                  else Message(cg_e_illegal_expression);
               end;
-              disposetree(p);
+              p.free;
            end;
          pointerdef:
            begin
               p:=comp_expr(true);
               do_firstpass(p);
-              if (p^.treetype=typeconvn) and
-                 ((p^.left^.treetype=addrn) or (p^.left^.treetype=niln)) and
-                 is_equal(def,p^.resulttype) then
+              if (p.nodetype=typeconvn) and
+                 (ttypeconvnode(p).left.nodetype in [addrn,niln]) and
+                 is_equal(def,p.resulttype) then
                 begin
-                   hp:=p^.left;
-                   putnode(p);
+                   hp:=ttypeconvnode(p).left;
+                   ttypeconvnode(p).left:=nil;
+                   p.free;
                    p:=hp;
                 end;
               { allows horrible ofs(typeof(TButton)^) code !! }
-              if (p^.treetype=addrn) and (p^.left^.treetype=derefn) then
+              if (p.nodetype=addrn) and
+                 (taddrnode(p).left.nodetype=derefn) then
                 begin
-                   hp:=p^.left^.left;
-                   p^.left^.left:=nil;
-                   disposetree(p);
+                   hp:=tderefnode(taddrnode(p).left).left;
+                   tderefnode(taddrnode(p).left).left:=nil;
+                   p.free;
                    p:=hp;
                 end;
               { nil pointer ? }
-              if p^.treetype=niln then
+              if p.nodetype=niln then
                 curconstsegment^.concat(new(pai_const,init_32bit(0)))
               { maybe pchar ? }
               else
                 if is_char(ppointerdef(def)^.pointertype.def) and
-                   (p^.treetype<>addrn) then
+                   (p.nodetype<>addrn) then
                   begin
                     getdatalabel(ll);
                     curconstsegment^.concat(new(pai_const_symbol,init(ll)));
                     consts^.concat(new(pai_label,init(ll)));
-                    if p^.treetype=stringconstn then
+                    if p.nodetype=stringconstn then
                       begin
-                        len:=p^.length;
+                        len:=tstringconstnode(p).len;
                         { For tp7 the maximum lentgh can be 255 }
                         if (m_tp in aktmodeswitches) and
                            (len>255) then
                          len:=255;
                         getmem(ca,len+2);
-                        move(p^.value_str^,ca^,len+1);
+                        move(tstringconstnode(p).value_str^,ca^,len+1);
                         consts^.concat(new(pai_string,init_length_pchar(ca,len+1)));
                       end
                     else
                       if is_constcharnode(p) then
-                        consts^.concat(new(pai_string,init(char(byte(p^.value))+#0)))
+                        consts^.concat(new(pai_string,init(char(byte(tordconstnode(p).value))+#0)))
                     else
                       Message(cg_e_illegal_expression);
                 end
               else
-                if p^.treetype=addrn then
+                if p.nodetype=addrn then
                   begin
-                    hp:=p^.left;
-                    while assigned(hp) and (hp^.treetype in [subscriptn,vecn]) do
-                      hp:=hp^.left;
-                    if (is_equal(ppointerdef(p^.resulttype)^.pointertype.def,ppointerdef(def)^.pointertype.def) or
-                       (is_equal(ppointerdef(p^.resulttype)^.pointertype.def,voiddef)) or
+                    hp:=taddrnode(p).left;
+                    while assigned(hp) and (hp.nodetype in [subscriptn,vecn]) do
+                      hp:=tbinarynode(hp).left;
+                    if (is_equal(ppointerdef(p.resulttype)^.pointertype.def,ppointerdef(def)^.pointertype.def) or
+                       (is_equal(ppointerdef(p.resulttype)^.pointertype.def,voiddef)) or
                        (is_equal(ppointerdef(def)^.pointertype.def,voiddef))) and
-                       (hp^.treetype=loadn) then
+                       (hp.nodetype=loadn) then
                       begin
-                        do_firstpass(p^.left);
-                        hp:=p^.left;
+                        do_firstpass(taddrnode(p).left);
+                        hp:=taddrnode(p).left;
                         offset:=0;
-                        while assigned(hp) and (hp^.treetype<>loadn) do
+                        while assigned(hp) and (hp.nodetype<>loadn) do
                           begin
-                             case hp^.treetype of
-                               vecn       :
+                             case hp.nodetype of
+                               vecn :
                                  begin
-                                    if (hp^.left^.resulttype^.deftype=stringdef) then
-                                      begin
-                                         { this seems OK for shortstring and ansistrings PM }
-                                         { it is wrong for widestrings !! }
-                                         len:=1;
-                                         base:=0;
-                                      end
-                                    else if (hp^.left^.resulttype^.deftype=arraydef) then
-                                      begin
-                                         len:=parraydef(hp^.left^.resulttype)^.elesize;
-                                         base:=parraydef(hp^.left^.resulttype)^.lowrange;
-                                      end
-                                    else
-                                      Message(cg_e_illegal_expression);
-                                    if is_constintnode(hp^.right) then
-                                      inc(offset,len*(get_ordinal_value(hp^.right)-base))
-                                    else
-                                      Message(cg_e_illegal_expression);
-                                      {internalerror(9779);}
+                                   case tvecnode(hp).left.resulttype^.deftype of
+                                     stringdef :
+                                       begin
+                                          { this seems OK for shortstring and ansistrings PM }
+                                          { it is wrong for widestrings !! }
+                                          len:=1;
+                                          base:=0;
+                                       end;
+                                     arraydef :
+                                       begin
+                                          len:=parraydef(tvecnode(hp).left.resulttype)^.elesize;
+                                          base:=parraydef(tvecnode(hp).left.resulttype)^.lowrange;
+                                       end
+                                     else
+                                       Message(cg_e_illegal_expression);
+                                   end;
+                                   if is_constintnode(tvecnode(hp).right) then
+                                     inc(offset,len*(get_ordinal_value(tvecnode(hp).right)-base))
+                                   else
+                                     Message(cg_e_illegal_expression);
                                  end;
-
-                               subscriptn : inc(offset,hp^.vs^.address)
-                             else
-                               Message(cg_e_illegal_expression);
+                               subscriptn :
+                                 inc(offset,tsubscriptnode(hp).vs^.address)
+                               else
+                                 Message(cg_e_illegal_expression);
                              end;
-                             hp:=hp^.left;
+                             hp:=tbinarynode(hp).left;
                           end;
-                        if hp^.symtableentry^.typ=constsym then
+                        if tloadnode(hp).symtableentry^.typ=constsym then
                           Message(type_e_variable_id_expected);
-                        curconstsegment^.concat(new(pai_const_symbol,initname_offset(hp^.symtableentry^.mangledname,offset)));
-                        (*if token=POINT then
-                          begin
-                             offset:=0;
-                             while token=_POINT do
-                               begin
-                                  consume(_POINT);
-                                  lsym:=pvarsym(precdef(
-                                        ppointerdef(p^.resulttype)^.pointertype.def)^.symtable^.search(pattern));
-                                  if assigned(sym) then
-                                    offset:=offset+lsym^.address
-                                  else
-                                    begin
-                                       Message1(sym_e_illegal_field,pattern);
-                                    end;
-                                  consume(_ID);
-                               end;
-                             curconstsegment^.concat(new(pai_const_symbol_offset,init(
-                               strpnew(p^.left^.symtableentry^.mangledname),offset)));
-                          end
-                        else
-                          begin
-                             curconstsegment^.concat(new(pai_const,init_symbol(
-                               strpnew(p^.left^.symtableentry^.mangledname))));
-                          end;   *)
+                        curconstsegment^.concat(new(pai_const_symbol,initname_offset(tloadnode(hp).symtableentry^.mangledname,offset)));
                       end
                     else
                       Message(cg_e_illegal_expression);
                   end
               else
               { allow typeof(Object type)}
-                if (p^.treetype=inlinen) and
-                   (p^.inlinenumber=in_typeof_x) then
+                if (p.nodetype=inlinen) and
+                   (tinlinenode(p).inlinenumber=in_typeof_x) then
                   begin
-                    if (p^.left^.treetype=typen) then
+                    if (tinlinenode(p).left.nodetype=typen) then
                       begin
                         curconstsegment^.concat(new(pai_const_symbol,
-                          initname(pobjectdef(p^.left^.resulttype)^.vmt_mangledname)));
+                          initname(pobjectdef(tinlinenode(p).left.resulttype)^.vmt_mangledname)));
                       end
                     else
                       Message(cg_e_illegal_expression);
                   end
               else
                 Message(cg_e_illegal_expression);
-              disposetree(p);
+              p.free;
            end;
          setdef:
            begin
               p:=comp_expr(true);
               do_firstpass(p);
-              if p^.treetype=setconstn then
+              if p.nodetype=setconstn then
                 begin
                    { we only allow const sets }
-                   if assigned(p^.left) then
+                   if assigned(tsetconstnode(p).left) then
                      Message(cg_e_illegal_expression)
                    else
                      begin
 {$ifdef i386}
                         for l:=0 to def^.size-1 do
-                          curconstsegment^.concat(new(pai_const,init_8bit(p^.value_set^[l])));
+                          curconstsegment^.concat(new(pai_const,init_8bit(tsetconstnode(p).value_set^[l])));
 {$endif}
 {$ifdef m68k}
                         j:=0;
@@ -391,10 +380,10 @@ implementation
                         { HORRIBLE HACK because of endian       }
                         { now use intel endian for constant sets }
                          begin
-                           curconstsegment^.concat(new(pai_const,init_8bit(p^.value_set^[j+3])));
-                           curconstsegment^.concat(new(pai_const,init_8bit(p^.value_set^[j+2])));
-                           curconstsegment^.concat(new(pai_const,init_8bit(p^.value_set^[j+1])));
-                           curconstsegment^.concat(new(pai_const,init_8bit(p^.value_set^[j])));
+                           curconstsegment^.concat(new(pai_const,init_8bit(tordconstnode(p).value_set^[j+3])));
+                           curconstsegment^.concat(new(pai_const,init_8bit(tordconstnode(p).value_set^[j+2])));
+                           curconstsegment^.concat(new(pai_const,init_8bit(tordconstnode(p).value_set^[j+1])));
+                           curconstsegment^.concat(new(pai_const,init_8bit(tordconstnode(p).value_set^[j])));
                            Inc(j,4);
                          end;
 {$endif}
@@ -402,20 +391,20 @@ implementation
                 end
               else
                 Message(cg_e_illegal_expression);
-              disposetree(p);
+              p.free;
            end;
          enumdef:
            begin
               p:=comp_expr(true);
               do_firstpass(p);
-              if p^.treetype=ordconstn then
+              if p.nodetype=ordconstn then
                 begin
-                  if is_equal(p^.resulttype,def) then
+                  if is_equal(p.resulttype,def) then
                    begin
-                     case p^.resulttype^.size of
-                       1 : curconstsegment^.concat(new(pai_const,init_8bit(p^.value)));
-                       2 : curconstsegment^.concat(new(pai_const,init_16bit(p^.value)));
-                       4 : curconstsegment^.concat(new(pai_const,init_32bit(p^.value)));
+                     case p.resulttype^.size of
+                       1 : curconstsegment^.concat(new(pai_const,init_8bit(tordconstnode(p).value)));
+                       2 : curconstsegment^.concat(new(pai_const,init_16bit(tordconstnode(p).value)));
+                       4 : curconstsegment^.concat(new(pai_const,init_32bit(tordconstnode(p).value)));
                      end;
                    end
                   else
@@ -423,27 +412,27 @@ implementation
                 end
               else
                 Message(cg_e_illegal_expression);
-              disposetree(p);
+              p.free;
            end;
          stringdef:
            begin
               p:=comp_expr(true);
               do_firstpass(p);
               { load strval and strlength of the constant tree }
-              if p^.treetype=stringconstn then
+              if p.nodetype=stringconstn then
                 begin
-                  strlength:=p^.length;
-                  strval:=p^.value_str;
+                  strlength:=tstringconstnode(p).len;
+                  strval:=tstringconstnode(p).value_str;
                 end
               else if is_constcharnode(p) then
                 begin
-                  strval:=pchar(@p^.value);
+                  strval:=pchar(@tordconstnode(p).value);
                   strlength:=1
                 end
               else if is_constresourcestringnode(p) then
                 begin
-                  strval:=pchar(tpointerord(pconstsym(p^.symtableentry)^.value));
-                  strlength:=pconstsym(p^.symtableentry)^.len;
+                  strval:=pchar(tpointerord(pconstsym(tloadnode(p).symtableentry)^.value));
+                  strlength:=pconstsym(tloadnode(p).symtableentry)^.len;
                 end
               else
                 begin
@@ -521,7 +510,7 @@ implementation
                      end;
                  end;
                end;
-              disposetree(p);
+              p.free;
            end;
          arraydef:
            begin
@@ -542,19 +531,19 @@ implementation
                 begin
                    p:=comp_expr(true);
                    do_firstpass(p);
-                   if p^.treetype=stringconstn then
+                   if p.nodetype=stringconstn then
                     begin
-                      len:=p^.length;
+                      len:=tstringconstnode(p).len;
                       { For tp7 the maximum lentgh can be 255 }
                       if (m_tp in aktmodeswitches) and
                          (len>255) then
                        len:=255;
-                      ca:=p^.value_str;
+                      ca:=tstringconstnode(p).value_str;
                     end
                    else
                      if is_constcharnode(p) then
                       begin
-                        ca:=pchar(@p^.value);
+                        ca:=pchar(@tordconstnode(p).value);
                         len:=1;
                       end
                    else
@@ -575,7 +564,7 @@ implementation
                           {Fill the remaining positions with #0.}
                           curconstsegment^.concat(new(pai_const,init_8bit(0)));
                      end;
-                   disposetree(p);
+                   p.free;
                 end
               else
                 begin
@@ -604,43 +593,43 @@ implementation
               do_firstpass(p);
               if codegenerror then
                begin
-                 disposetree(p);
+                 p.free;
                  exit;
                end;
               { convert calln to loadn }
-              if p^.treetype=calln then
+              if p.nodetype=calln then
                begin
-                 if (p^.symtableprocentry^.owner^.symtabletype=objectsymtable) and
-                    (pobjectdef(p^.symtableprocentry^.owner^.defowner)^.is_class) then
-                  hp:=genloadmethodcallnode(pprocsym(p^.symtableprocentry),p^.symtableproc,
-                        getcopy(p^.methodpointer))
+                 if (tcallnode(p).symtableprocentry^.owner^.symtabletype=objectsymtable) and
+                    (pobjectdef(tcallnode(p).symtableprocentry^.owner^.defowner)^.is_class) then
+                  hp:=genloadmethodcallnode(pprocsym(tcallnode(p).symtableprocentry),tcallnode(p).symtableproc,
+                        tcallnode(p).methodpointer.getcopy)
                  else
-                  hp:=genloadcallnode(pprocsym(p^.symtableprocentry),p^.symtableproc);
-                 disposetree(p);
+                  hp:=genloadcallnode(pprocsym(tcallnode(p).symtableprocentry),tcallnode(p).symtableproc);
+                 p.free;
                  do_firstpass(hp);
                  p:=hp;
                  if codegenerror then
                   begin
-                    disposetree(p);
+                    p.free;
                     exit;
                   end;
                end
-              else if (p^.treetype=addrn) and assigned(p^.left) and
-                (p^.left^.treetype=calln) then
+              else if (p.nodetype=addrn) and assigned(taddrnode(p).left) and
+                (taddrnode(p).left.nodetype=calln) then
                 begin
-                   if (p^.left^.symtableprocentry^.owner^.symtabletype=objectsymtable) and
-                      (pobjectdef(p^.left^.symtableprocentry^.owner^.defowner)^.is_class) then
-                    hp:=genloadmethodcallnode(pprocsym(p^.left^.symtableprocentry),
-                    p^.left^.symtableproc,getcopy(p^.left^.methodpointer))
+                   if (tcallnode(taddrnode(p).left).symtableprocentry^.owner^.symtabletype=objectsymtable) and
+                      (pobjectdef(tcallnode(taddrnode(p).left).symtableprocentry^.owner^.defowner)^.is_class) then
+                    hp:=genloadmethodcallnode(pprocsym(tcallnode(taddrnode(p).left).symtableprocentry),
+                    tcallnode(taddrnode(p).left).symtableproc,tcallnode(taddrnode(p).left).methodpointer.getcopy)
                    else
-                    hp:=genloadcallnode(pprocsym(p^.left^.symtableprocentry),
-                      p^.left^.symtableproc);
-                   disposetree(p);
+                    hp:=genloadcallnode(pprocsym(tcallnode(taddrnode(p).left).symtableprocentry),
+                      tcallnode(taddrnode(p).left).symtableproc);
+                   p.free;
                    do_firstpass(hp);
                    p:=hp;
                    if codegenerror then
                     begin
-                       disposetree(p);
+                       p.free;
                        exit;
                     end;
                 end;
@@ -649,34 +638,36 @@ implementation
               do_firstpass(p);
               if codegenerror then
                begin
-                 disposetree(p);
+                 p.free;
                  exit;
                end;
               { remove typeconvn, that will normally insert a lea
                 instruction which is not necessary for us }
-              if p^.treetype=typeconvn then
+              if p.nodetype=typeconvn then
                begin
-                 hp:=p^.left;
-                 putnode(p);
+                 hp:=ttypeconvnode(p).left;
+                 ttypeconvnode(p).left:=nil;
+                 p.free;
                  p:=hp;
                end;
               { remove addrn which we also don't need here }
-              if p^.treetype=addrn then
+              if p.nodetype=addrn then
                begin
-                 hp:=p^.left;
-                 putnode(p);
+                 hp:=taddrnode(p).left;
+                 taddrnode(p).left:=nil;
+                 p.free;
                  p:=hp;
                end;
               { we now need to have a loadn with a procsym }
-              if (p^.treetype=loadn) and
-                 (p^.symtableentry^.typ=procsym) then
+              if (p.nodetype=loadn) and
+                 (tloadnode(p).symtableentry^.typ=procsym) then
                begin
                  curconstsegment^.concat(new(pai_const_symbol,
-                   initname(pprocsym(p^.symtableentry)^.definition^.mangledname)));
+                   initname(pprocsym(tloadnode(p).symtableentry)^.definition^.mangledname)));
                end
               else
                Message(cg_e_illegal_expression);
-              disposetree(p);
+              p.free;
            end;
          { reads a typed constant record }
          recorddef:
@@ -810,7 +801,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.8  2000-09-30 13:23:04  peter
+  Revision 1.9  2000-10-14 10:14:52  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.8  2000/09/30 13:23:04  peter
     * const array of char and pchar length fixed (merged)
 
   Revision 1.7  2000/09/24 15:06:25  peter
@@ -832,4 +826,4 @@ end.
   Revision 1.2  2000/07/13 11:32:47  michael
   + removed logs
 
-}
+}

compiler/ra386att.pas

@@ -27,23 +27,35 @@ Unit Ra386att;
 Interface
 
 uses
-  tree;
+  node;
 
-   function assemble: ptree;
+   function assemble: tnode;
 
 
 Implementation
 
-Uses
-  globtype,
-  cutils,cobjects,systems,verbose,globals,
-  fmodule,aasm,types,symconst,symtable,scanner,cpubase,
-{$ifdef NEWCG}
-  cgbase,
+    uses
+       { common }
+       cutils,cobjects,
+       { global }
+       globtype,globals,verbose,
+       systems,cpuinfo,
+       { aasm }
+       cpubase,aasm,
+       { symtable }
+       symconst,symtable,types,
+       { pass 1 }
+       nbas,
+       { parser }
+       scanner,
+       ra386,rautils,
+       { codegen }
+{$ifdef newcg}
+       cgbase
 {$else}
-  hcodegen,
+       hcodegen
 {$endif}
-  rautils,ra386;
+       ;
 
 type
  tasmtoken = (
@@ -1845,7 +1857,7 @@ Begin
 end;
 
 
-Function Assemble: Ptree;
+Function Assemble: tnode;
 Var
   hl         : PAsmLabel;
   commname   : string;
@@ -2074,7 +2086,7 @@ Begin
      curlist^.Concat(new(pai_section,init(sec_code)));
    end;
   { Return the list in an asmnode }
-  assemble:=genasmnode(curlist);
+  assemble:=casmnode.create(curlist);
   Message1(asmr_d_finish_reading,'AT&T');
 end;
 
@@ -2102,7 +2114,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.5  2000-09-24 21:19:51  peter
+  Revision 1.6  2000-10-14 10:14:52  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.5  2000/09/24 21:19:51  peter
     * delphi compile fixes
 
   Revision 1.4  2000/09/24 15:06:26  peter
@@ -2115,4 +2130,4 @@ end.
   Revision 1.2  2000/07/13 11:32:48  michael
   + removed logs
 
-}
+}

compiler/ra386dir.pas

@@ -27,23 +27,36 @@ unit Ra386dir;
 interface
 
     uses
-      tree;
+      node;
 
-     function assemble : ptree;
+     function assemble : tnode;
 
   implementation
 
-     uses
-        fmodule,globals,scanner,aasm,cpubase,cpuasm,
-        cutils,cobjects,symconst,symtable,types,verbose,
-{$ifdef NEWCG}
-        cgbase,
+    uses
+       { common }
+       cutils,cobjects,
+       { global }
+       globtype,globals,verbose,
+       systems,cpuinfo,
+       { aasm }
+       cpubase,aasm,
+       { symtable }
+       symconst,symtable,types,
+       { pass 1 }
+       nbas,
+       { parser }
+       scanner,
+       ra386,rautils,
+       { codegen }
+{$ifdef newcg}
+       cgbase
 {$else}
-        hcodegen,
+       hcodegen
 {$endif}
-        rautils,ra386;
+       ;
 
-    function assemble : ptree;
+    function assemble : tnode;
 
       var
          retstr,s,hs : string;
@@ -269,13 +282,16 @@ interface
            end;
          end;
        writeasmline;
-       assemble:=genasmnode(code);
+       assemble:=casmnode.create(code);
      end;
 
 end.
 {
   $Log$
-  Revision 1.4  2000-09-24 15:06:26  peter
+  Revision 1.5  2000-10-14 10:14:52  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.4  2000/09/24 15:06:26  peter
     * use defines.inc
 
   Revision 1.3  2000/08/27 16:11:52  peter
@@ -285,4 +301,4 @@ end.
   Revision 1.2  2000/07/13 11:32:48  michael
   + removed logs
 
-}
+}

compiler/ra386int.pas

@@ -27,24 +27,35 @@ Unit Ra386int;
 Interface
 
 uses
-  tree;
+  node;
 
-function assemble: ptree;
+function assemble: tnode;
 
 
 Implementation
 
-Uses
-  globtype,
-  cutils,cobjects,systems,verbose,globals,
-  fmodule,aasm,types,scanner,symconst,symtable,cpubase,
-{$ifdef NEWCG}
-  cgbase,
+    uses
+       { common }
+       cutils,cobjects,
+       { global }
+       globtype,globals,verbose,
+       systems,cpuinfo,
+       { aasm }
+       cpubase,aasm,
+       { symtable }
+       symconst,symtable,types,
+       { pass 1 }
+       nbas,
+       { parser }
+       scanner,
+       ra386,rautils,
+       { codegen }
+{$ifdef newcg}
+       cgbase
 {$else}
-  hcodegen,
+       hcodegen
 {$endif}
-  rautils,ra386;
-
+       ;
 
 type
   tasmtoken = (
@@ -1776,7 +1787,7 @@ Begin
 end;
 
 
-Function Assemble: Ptree;
+Function Assemble: tnode;
 Var
   hl : PAsmLabel;
   instr : T386IntelInstruction;
@@ -1877,7 +1888,7 @@ Begin
   LocalLabelList^.CheckEmitted;
   dispose(LocalLabelList,Done);
   { Return the list in an asmnode }
-  assemble:=genasmnode(curlist);
+  assemble:=casmnode.create(curlist);
   Message1(asmr_d_finish_reading,'intel');
 end;
 
@@ -1905,7 +1916,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.7  2000-09-24 21:19:51  peter
+  Revision 1.8  2000-10-14 10:14:52  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.7  2000/09/24 21:19:51  peter
     * delphi compile fixes
 
   Revision 1.6  2000/09/24 15:06:26  peter
@@ -1924,4 +1938,4 @@ end.
   Revision 1.2  2000/07/13 11:32:48  michael
   + removed logs
 
-}
+}

compiler/regvars.pas

@@ -26,42 +26,24 @@ unit regvars;
 
 interface
 
-uses
-  aasm,
-{$ifdef CG11}
-  node
-{$else CG11}
-  tree
-{$endif CG11}
-  ;
-
-{$ifdef CG11}
-procedure assign_regvars(p: tnode);
-procedure load_regvars(asml: paasmoutput; p: tnode);
-{$else CG11}
-procedure assign_regvars(p: ptree);
-procedure load_regvars(asml: paasmoutput; p: ptree);
-{$endif CG11}
-procedure cleanup_regvars(asml: paasmoutput);
+    uses
+       aasm,
+       node;
+
+    procedure assign_regvars(p: tnode);
+    procedure load_regvars(asml: paasmoutput; p: tnode);
+    procedure cleanup_regvars(asml: paasmoutput);
+
 
 implementation
 
-   uses
-     globtype,systems,comphook,
-     cutils,cobjects,verbose,globals,
-     symconst,symtable,types,
-     hcodegen,temp_gen,cpubase,cpuasm
-{$ifndef newcg}
-   {$ifndef CG11}
-     ,tcflw
-   {$endif}
-{$endif newcg}
-{$ifdef GDB}
-     ,gdb
-{$endif}
+    uses
+      globtype,systems,comphook,
+      cutils,cobjects,verbose,globals,
+      symconst,symtable,types,
+      hcodegen,temp_gen,cpubase,cpuasm
 {$ifdef i386}
      ,tgeni386,cgai386
-
 {$endif}
 {$ifdef m68k}
      ,tgen68k,cga68k
@@ -177,7 +159,7 @@ implementation
       end;
 {$endif i386}
 
-{$ifdef CG11}
+
     procedure assign_regvars(p: tnode);
           { register variables }
     var
@@ -465,301 +447,13 @@ implementation
             asml^.insert(new(pai_asm_comment,init(strpnew('Register variable assignment:'))));
         end;
     end;
-{$else CG11}
-    procedure assign_regvars(p: ptree);
-          { register variables }
-    var
-      regvarinfo: pregvarinfo;
-      i: longint;
-    begin
-      { max. optimizations     }
-      { only if no asm is used }
-      { and no try statement   }
-      if (cs_regalloc in aktglobalswitches) and
-         ((procinfo^.flags and (pi_uses_asm or pi_uses_exceptions))=0) then
-        begin
-          new(regvarinfo);
-          fillchar(regvarinfo^,sizeof(regvarinfo^),0);
-          aktprocsym^.definition^.regvarinfo := regvarinfo;
-          if (p^.registers32<4) then
-            begin
-              parasym:=false;
-              symtablestack^.foreach({$ifdef FPCPROCVAR}@{$endif}searchregvars);
-              { copy parameter into a register ? }
-              parasym:=true;
-              symtablestack^.next^.foreach({$ifdef FPCPROCVAR}@{$endif}searchregvars);
-              { hold needed registers free }
-              for i:=maxvarregs downto maxvarregs-p^.registers32+1 do
-                begin
-                  regvarinfo^.regvars[i]:=nil;
-                  regvarinfo^.regvars_para[i] := false;
-                end;
-              { now assign register }
-              for i:=1 to maxvarregs-p^.registers32 do
-                begin
-                  if assigned(regvarinfo^.regvars[i]) and
-                    (reg_pushes[varregs[i]] < regvarinfo^.regvars[i]^.refs) then
-                    begin
-                      { register is no longer available for }
-                      { expressions                          }
-                      { search the register which is the most }
-                      { unused                                        }
-                      usableregs:=usableregs-[varregs[i]];
-                      is_reg_var[varregs[i]]:=true;
-                      dec(c_usableregs);
-
-                      { possibly no 32 bit register are needed }
-                      { call by reference/const ? }
-                      if (regvarinfo^.regvars[i]^.varspez=vs_var) or
-                         ((regvarinfo^.regvars[i]^.varspez=vs_const) and
-                           push_addr_param(regvarinfo^.regvars[i]^.vartype.def)) then
-                        begin
-                           regvarinfo^.regvars[i]^.reg:=varregs[i];
-                        end
-                      else
-                       if (regvarinfo^.regvars[i]^.vartype.def^.deftype in [orddef,enumdef]) and
-                          (porddef(regvarinfo^.regvars[i]^.vartype.def)^.size=1) then
-                        begin
-{$ifdef i386}
-                          regvarinfo^.regvars[i]^.reg:=reg32toreg8(varregs[i]);
-{$endif}
-                        end
-                      else
-                       if (regvarinfo^.regvars[i]^.vartype.def^.deftype in [orddef,enumdef]) and
-                          (porddef(regvarinfo^.regvars[i]^.vartype.def)^.size=2) then
-                         begin
-{$ifdef i386}
-                           regvarinfo^.regvars[i]^.reg:=reg32toreg16(varregs[i]);
-{$endif}
-                         end
-                      else
-                        begin
-                          regvarinfo^.regvars[i]^.reg:=varregs[i];
-                        end;
-                      if regvarinfo^.regvars_para[i] then
-                        unused:=unused - [regvarinfo^.regvars[i]^.reg];
-                      { procedure uses this register }
-{$ifdef i386}
-                      usedinproc:=usedinproc or ($80 shr byte(varregs[i]));
-{$endif i386}
-{$ifdef m68k}
-                      usedinproc:=usedinproc or ($800 shr word(varregs[i]));
-{$endif m68k}
-                    end
-                  else
-                    begin
-                      regvarinfo^.regvars[i] := nil;
-                      regvarinfo^.regvars_para[i] := false;
-                    end;
-                end;
-            end;
-            if ((p^.registersfpu+1)<maxfpuvarregs) then
-              begin
-                parasym:=false;
-                symtablestack^.foreach({$ifdef FPCPROCVAR}@{$endif}searchfpuregvars);
-{$ifdef dummy}
-                { copy parameter into a register ? }
-                parasym:=true;
-                symtablestack^.next^.foreach({$ifdef FPCPROCVAR}@{$endif}searchregvars);
-{$endif dummy}
-                { hold needed registers free }
-
-                { in non leaf procedures we must be very careful }
-                { with assigning registers             }
-                if aktmaxfpuregisters=-1 then
-                  begin
-                   if (procinfo^.flags and pi_do_call)<>0 then
-                     begin
-                      for i:=maxfpuvarregs downto 2 do
-                      regvarinfo^.fpuregvars[i]:=nil;
-                     end
-                   else
-                     begin
-                      for i:=maxfpuvarregs downto maxfpuvarregs-p^.registersfpu do
-                        regvarinfo^.fpuregvars[i]:=nil;
-                     end;
-                  end
-                else
-                  begin
-                    for i:=aktmaxfpuregisters+1 to maxfpuvarregs do
-                      regvarinfo^.fpuregvars[i]:=nil;
-                  end;
-                { now assign register }
-                for i:=1 to maxfpuvarregs do
-                  begin
-                   if assigned(regvarinfo^.fpuregvars[i]) then
-                     begin
-{$ifdef i386}
-                       { reserve place on the FPU stack }
-                       regvarinfo^.fpuregvars[i]^.reg:=correct_fpuregister(R_ST0,i-1);
-{$endif i386}
-{$ifdef m68k}
-                       regvarinfo^.fpuregvars[i]^.reg:=fpuvarregs[i];
-{$endif m68k}
-                     end;
-                  end;
-              end;
-        end;
-    end;
-
-    procedure load_regvars(asml: paasmoutput; p: ptree);
-    var
-      i: longint;
-      hr      : preference;
-      regvarinfo: pregvarinfo;
-{$ifdef i386}
-      opsize: topsize;
-      opcode: tasmop;
-      signed: boolean;
-{$endif i386}
-    begin
-      if (cs_regalloc in aktglobalswitches) and
-         ((procinfo^.flags and (pi_uses_asm or pi_uses_exceptions))=0) then
-        begin
-          regvarinfo := pregvarinfo(aktprocsym^.definition^.regvarinfo);
-          { can happen when inlining assembler procedures (JM) }
-          if not assigned(regvarinfo) then
-            exit;
-          for i:=1 to maxvarregs do
-            begin
-              { parameter must be load }
-              if regvarinfo^.regvars_para[i] then
-                begin
-{$ifdef i386}
-                  asml^.concat(new(pairegalloc,alloc(reg32(regvarinfo^.regvars[i]^.reg))));
-{$endif i386}
-                  { procinfo is there actual,    }
-                  { because we can't never be in a }
-                  { nested procedure        }
-                  { when loading parameter to reg  }
-                  new(hr);
-                  reset_reference(hr^);
-                  hr^.offset:=pvarsym(regvarinfo^.regvars[i])^.address+procinfo^.para_offset;
-                  hr^.base:=procinfo^.framepointer;
-{$ifdef i386}
-                { zero the regvars because the upper 48bits must be clear }
-                { for 8bits vars when using them with btrl (JM)           }
-                  signed :=
-                    (pvarsym(regvarinfo^.regvars[i])^.vartype.def^.deftype =
-                      orddef) and
-                    is_signed(pvarsym(regvarinfo^.regvars[i])^.vartype.def);
-                  case regsize(regvarinfo^.regvars[i]^.reg) of
-                    S_L:
-                      begin
-                        opsize := S_L;
-                        opcode := A_MOV;
-                      end;
-                    S_W:
-                      begin
-                        opsize := S_WL;
-                        if signed then
-                          opcode := A_MOVSX
-                        else opcode := A_MOVZX;
-                      end;
-                    S_B:
-                      begin
-                        opsize := S_BL;
-                        if signed then
-                          opcode := A_MOVSX
-                        else opcode := A_MOVZX;
-                      end;
-                  end;
-                  asml^.concat(new(paicpu,op_ref_reg(opcode,opsize,
-                    hr,reg32(regvarinfo^.regvars[i]^.reg))));
-{$endif i386}
-{$ifdef m68k}
-                  asml^.concat(new(paicpu,op_ref_reg(A_MOVE,regsize(regvarinfo^.regvars[i]^.reg),
-                    hr,regvarinfo^.regvars[i]^.reg)));
-{$endif m68k}
-                end
-            end;
-          for i:=1 to maxvarregs do
-            begin
-             if assigned(regvarinfo^.regvars[i]) then
-               begin
-{$ifdef i386}
-                if not(regvarinfo^.regvars_para[i]) then
-                  begin
-                    asml^.concat(new(pairegalloc,alloc(reg32(regvarinfo^.regvars[i]^.reg))));
-                    { zero the regvars because the upper 48bits must be clear }
-                    { for 8bits vars when using them with btrl (JM)           }
-                    if (regsize(regvarinfo^.regvars[i]^.reg) in [S_B,S_W]) then
-                      asml^.concat(new(paicpu,op_reg_reg(A_XOR,S_L,
-                        reg32(regvarinfo^.regvars[i]^.reg),
-                        reg32(regvarinfo^.regvars[i]^.reg))));
-                  end;
-{$endif i386}
-                if cs_asm_source in aktglobalswitches then
-                asml^.insert(new(pai_asm_comment,init(strpnew(regvarinfo^.regvars[i]^.name+
-                  ' with weight '+tostr(regvarinfo^.regvars[i]^.refs)+' assigned to register '+
-                  reg2str(regvarinfo^.regvars[i]^.reg)))));
-                if (status.verbosity and v_debug)=v_debug then
-                Message3(cg_d_register_weight,reg2str(regvarinfo^.regvars[i]^.reg),
-                  tostr(regvarinfo^.regvars[i]^.refs),regvarinfo^.regvars[i]^.name);
-               end;
-            end;
-          for i:=1 to maxfpuvarregs do
-            begin
-              if assigned(regvarinfo^.fpuregvars[i]) then
-                begin
-{$ifdef i386}
-                  { reserve place on the FPU stack }
-                  regvarinfo^.fpuregvars[i]^.reg:=correct_fpuregister(R_ST0,i-1);
-                  asml^.concat(new(paicpu,op_none(A_FLDZ,S_NO)));
-{$endif i386}
-{$ifdef dummy}
-                  { parameter must be load }
-                  if regvarinfo^.fpuregvars_para[i] then
-                    begin
-                      { procinfo is there actual,    }
-                      { because we can't never be in a }
-                      { nested procedure        }
-                      { when loading parameter to reg  }
-                      new(hr);
-                      reset_reference(hr^);
-                      hr^.offset:=pvarsym(regvarinfo^.regvars[i])^.address+procinfo^.para_offset;
-                      hr^.base:=procinfo^.framepointer;
-{$ifdef i386}
-                      asml^.concat(new(paicpu,op_ref_reg(A_MOV,regsize(regvarinfo^.regvars[i]^.reg),
-                        hr,regvarinfo^.regvars[i]^.reg)));
-{$endif i386}
-{$ifdef m68k}
-                      asml^.concat(new(paicpu,op_ref_reg(A_MOVE,regsize(regvarinfo^.regvars[i]^.reg),
-                        hr,regvarinfo^.regvars[i]^.reg)));
-{$endif m68k}
-                    end;
-{$endif dummy}
-                end;
-            end;
-          if assigned(p) then
-            if cs_asm_source in aktglobalswitches then
-              asml^.insert(new(pai_asm_comment,init(strpnew(tostr(p^.registersfpu)+
-              ' registers on FPU stack used by temp. expressions'))));
-          for i:=1 to maxfpuvarregs do
-            begin
-               if assigned(regvarinfo^.fpuregvars[i]) then
-                 begin
-                    if cs_asm_source in aktglobalswitches then
-                      asml^.insert(new(pai_asm_comment,init(strpnew(regvarinfo^.fpuregvars[i]^.name+
-                        ' with weight '+tostr(regvarinfo^.fpuregvars[i]^.refs)+' assigned to register '+
-                        reg2str(regvarinfo^.fpuregvars[i]^.reg)))));
-                    if (status.verbosity and v_debug)=v_debug then
-                      Message3(cg_d_register_weight,reg2str(regvarinfo^.fpuregvars[i]^.reg),
-                        tostr(regvarinfo^.fpuregvars[i]^.refs),regvarinfo^.fpuregvars[i]^.name);
-                 end;
-            end;
-          if cs_asm_source in aktglobalswitches then
-            asml^.insert(new(pai_asm_comment,init(strpnew('Register variable assignment:'))));
-        end;
-    end;
-{$endif CG11}
 
 
     procedure cleanup_regvars(asml: paasmoutput);
     var
       i: longint;
     begin
-    {$ifdef i386}
+{$ifdef i386}
       { can happen when inlining assembler procedures (JM) }
       if not assigned(aktprocsym^.definition^.regvarinfo) then
         exit;
@@ -775,14 +469,17 @@ implementation
               if assigned(regvars[i]) then
                 asml^.concat(new(pairegalloc,dealloc(reg32(regvars[i]^.reg))));
           end;
-    {$endif i386}
+{$endif i386}
     end;
 
 end.
 
 {
   $Log$
-  Revision 1.9  2000-10-01 19:48:25  peter
+  Revision 1.10  2000-10-14 10:14:52  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.9  2000/10/01 19:48:25  peter
     * lot of compile updates for cg11
 
   Revision 1.8  2000/09/30 16:08:45  peter

compiler/symconst.pas

@@ -141,7 +141,8 @@ type
     pocall_system,
     pocall_inline,        { Procedure is an assembler macro }
     pocall_internproc,    { Procedure has compiler magic}
-    pocall_internconst    { procedure has constant evaluator intern }
+    pocall_internconst,   { procedure has constant evaluator intern }
+    pocall_cppdecl        { C++ calling conventions }
   );
   tproccalloptions=set of tproccalloption;
 
@@ -280,7 +281,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.7  2000-09-24 15:06:28  peter
+  Revision 1.8  2000-10-14 10:14:52  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.7  2000/09/24 15:06:28  peter
     * use defines.inc
 
   Revision 1.6  2000/08/21 11:27:44  pierre
@@ -298,4 +302,4 @@ end.
   Revision 1.2  2000/07/13 11:32:49  michael
   + removed logs
 
-}
+}

compiler/symdef.inc

@@ -154,8 +154,10 @@
 
     function tdef.typename:string;
       begin
-        if assigned(typesym) then
-         typename:=Upper(typesym^.name)
+        if assigned(typesym) and not(deftype=procvardef) and
+          assigned(typesym^._realname) and
+          (typesym^._realname^[1]<>'$') then
+         typename:=typesym^._realname^
         else
          typename:=gettypename;
       end;
@@ -2548,12 +2550,12 @@
           str  : string[30];
         end;
       const
-        proccallopts=12;
+        proccallopts=13;
         proccallopt : array[1..proccallopts] of tproccallopt=(
            (mask:pocall_none;         str:''),
            (mask:pocall_clearstack;   str:'ClearStack'),
            (mask:pocall_leftright;    str:'LeftRight'),
-           (mask:pocall_cdecl;        str:'Cdecl'),
+           (mask:pocall_cdecl;        str:'CDecl'),
            (mask:pocall_register;     str:'Register'),
            (mask:pocall_stdcall;      str:'StdCall'),
            (mask:pocall_safecall;     str:'SafeCall'),
@@ -2561,7 +2563,8 @@
            (mask:pocall_system;       str:'System'),
            (mask:pocall_inline;       str:'Inline'),
            (mask:pocall_internproc;   str:'InternProc'),
-           (mask:pocall_internconst;  str:'InternConst')
+           (mask:pocall_internconst;  str:'InternConst'),
+           (mask:pocall_cdecl;        str:'CPPDecl')
         );
       var
         s : string;
@@ -2869,13 +2872,8 @@ Const local_symtable_index : longint = $8001;
            dispose(parast,done);
          if assigned(localst) and (localst^.symtabletype<>staticsymtable) then
            dispose(localst,done);
-{$ifdef CG11}
          if (pocall_inline in proccalloptions) and assigned(code) then
            tnode(code).free;
-{$else}
-         if (pocall_inline in proccalloptions) and assigned(code) then
-           disposetree(ptree(code));
-{$endif}
          if assigned(regvarinfo) then
            dispose(pregvarinfo(regvarinfo));
          if (po_msgstr in procoptions) then
@@ -3085,16 +3083,15 @@ Const local_symtable_index : longint = $8001;
           procname:=Copy(s,1,l-1);
       end;
 
-{$IfDef GDB}
-    function tprocdef.cplusplusmangledname : string;
+    function tprocdef.cplusplusmangledname(const rn : string) : string;
 
       function getcppparaname(p : pdef) : string;
 
         const
            ordtype2str : array[tbasetype] of string[2] = (
              '','','c',
-             'Uc','Us','Ul',
-             'Sc','s','l',
+             'Uc','Us','Ui',
+             'Sc','s','i',
              'b','b','b',
              'Us','x','w');
 
@@ -3118,11 +3115,10 @@ Const local_symtable_index : longint = $8001;
          param : pparaitem;
 
       begin
-         { we need this in lowercase letters! }
-         s := procsym^.name;
+         s := rn;
          if procsym^.owner^.symtabletype=objectsymtable then
            begin
-              s2:=upper(pobjectdef(procsym^.owner^.defowner)^.objname^);
+              s2:=upper(pobjectdef(procsym^.owner^.defowner)^.typesym^.realname);
               case proctypeoption of
                  potype_destructor:
                    s:='_$_'+tostr(length(s2))+s2;
@@ -3133,25 +3129,28 @@ Const local_symtable_index : longint = $8001;
               end;
 
            end
-         else s:=s+'_';
+         else s:=s+'__';
+
+         s:=s+'F';
 
          { concat modifiers }
          { !!!!! }
 
          { now we handle the parameters }
          param := pparaitem(para^.first);
-         while assigned(param) do
-           begin
-              s2:=getcppparaname(param^.paratype.def);
-              if param^.paratyp in [vs_var,vs_out] then
-                s2:='R'+s2;
-              s:=s+s2;
-              param:=pparaitem(param^.next);
-           end;
+         if assigned(param) then
+           while assigned(param) do
+             begin
+                s2:=getcppparaname(param^.paratype.def);
+                if param^.paratyp in [vs_var,vs_out] then
+                  s2:='R'+s2;
+                s:=s+s2;
+                param:=pparaitem(param^.next);
+             end
+         else
+           s:=s+'v';
          cplusplusmangledname:=s;
       end;
-{$EndIf GDB}
-
 
     procedure tprocdef.setmangledname(const s : string);
       begin
@@ -3336,7 +3335,6 @@ Const local_symtable_index : longint = $8001;
          is_publishable:=(po_methodpointer in procoptions);
       end;
 
-
     function tprocvardef.gettypename : string;
       begin
          if assigned(rettype.def) and
@@ -3376,6 +3374,8 @@ Const local_symtable_index : longint = $8001;
         objname:=stringdup(n);
 {$ifdef GDB}
         writing_stabs:=false;
+        classglobalnb:=0;
+        classptrglobalnb:=0;
 {$endif GDB}
      end;
 
@@ -3410,6 +3410,8 @@ Const local_symtable_index : longint = $8001;
            class_tobject:=@self;
 {$ifdef GDB}
          writing_stabs:=false;
+         classglobalnb:=0;
+         classptrglobalnb:=0;
 {$endif GDB}
        end;
 
@@ -3695,12 +3697,14 @@ Const local_symtable_index : longint = $8001;
                 ipd := pd;
                 while assigned(ipd^.nextoverloaded) do ipd := ipd^.nextoverloaded;
                 if (po_virtualmethod in pd^.procoptions) then
-                   begin
-                   lindex := pd^.extnumber;
-                   {doesnt seem to be necessary
-                   lindex := lindex or $80000000;}
-                   virtualind := '*'+tostr(lindex)+';'+ipd^._class^.numberstring+';'
-                   end else virtualind := '.';
+                  begin
+                    lindex := pd^.extnumber;
+                    {doesnt seem to be necessary
+                    lindex := lindex or $80000000;}
+                    virtualind := '*'+tostr(lindex)+';'+ipd^._class^.classnumberstring+';'
+                  end
+                 else
+                  virtualind := '.';
 
                  { used by gdbpas to recognize constructor and destructors }
                  if (pd^.proctypeoption=potype_constructor) then
@@ -3770,11 +3774,13 @@ Const local_symtable_index : longint = $8001;
     function tobjectdef.stabstring : pchar;
       var anc : pobjectdef;
           oldrec : pchar;
-          oldrecsize : longint;
+          storenb, oldrecsize : longint;
           str_end : string;
       begin
         if not (is_class) or writing_stabs then
           begin
+            storenb:=globalnb;
+            globalnb:=classptrglobalnb;
             oldrec := stabrecstring;
             oldrecsize:=stabrecsize;
             stabrecsize:=memsizeinc;
@@ -3788,15 +3794,11 @@ Const local_symtable_index : longint = $8001;
               end;
             {virtual table to implement yet}
             RecOffset := 0;
-            if is_class then
-              inc(globalnb);
             symtable^.foreach({$ifdef FPCPROCVAR}@{$endif}addname);
-            if is_class then
-              dec(globalnb);
             if (oo_has_vmt in objectoptions) then
               if not assigned(childof) or not(oo_has_vmt in childof^.objectoptions) then
                  begin
-                    strpcopy(strend(stabrecstring),'$vf'+numberstring+':'+typeglobalnumber('vtblarray')
+                    strpcopy(strend(stabrecstring),'$vf'+classnumberstring+':'+typeglobalnumber('vtblarray')
                       +','+tostr(vmt_offset*8)+';');
                  end;
             symtable^.foreach({$ifdef FPCPROCVAR}@{$endif}addprocname);
@@ -3806,11 +3808,7 @@ Const local_symtable_index : longint = $8001;
                  while assigned(anc^.childof) and (oo_has_vmt in anc^.childof^.objectoptions) do
                    anc := anc^.childof;
                  { just in case anc = self }
-                 if is_class then
-                   inc(globalnb);
                  str_end:=';~%'+anc^.classnumberstring+';';
-                 if is_class then
-                   dec(globalnb);
               end
             else
               str_end:=';';
@@ -3819,6 +3817,7 @@ Const local_symtable_index : longint = $8001;
             freemem(stabrecstring,stabrecsize);
             stabrecstring := oldrec;
             stabrecsize:=oldrecsize;
+            globalnb:=storenb;
           end
         else
           begin
@@ -3828,32 +3827,52 @@ Const local_symtable_index : longint = $8001;
 
    procedure tobjectdef.set_globalnb;
      begin
-         globalnb :=PGlobalTypeCount^;
+         classglobalnb:=PGlobalTypeCount^;
+         globalnb:=classglobalnb;
          inc(PglobalTypeCount^);
-         { classes need two type numbers }
+         { classes need two type numbers, the globalnb is set to the ptr }
          if is_class then
            begin
-             globalnb :=PGlobalTypeCount^;
+             classptrglobalnb:=PGlobalTypeCount^;
+             globalnb:=classptrglobalnb;
              inc(PglobalTypeCount^);
            end;
      end;
 
    function tobjectdef.classnumberstring : string;
+     var
+       onb : word;
      begin
        if globalnb=0 then
-         begin
-           numberstring;
-         end;
+         numberstring;
        if is_class then
          begin
-           dec(globalnb);
+           onb:=globalnb;
+           globalnb:=classglobalnb;
            classnumberstring:=numberstring;
-           inc(globalnb);
+           globalnb:=onb;
          end
        else
          classnumberstring:=numberstring;
      end;
 
+   function tobjectdef.classptrnumberstring : string;
+     var
+       onb : word;
+     begin
+       if globalnb=0 then
+         numberstring;
+       if is_class then
+         begin
+           onb:=globalnb;
+           globalnb:=classptrglobalnb;
+           classptrnumberstring:=numberstring;
+           globalnb:=onb;
+         end
+       else
+         classptrnumberstring:=numberstring;
+     end;
+
     procedure tobjectdef.concatstabto(asmlist : paasmoutput);
       var st : pstring;
       begin
@@ -3868,23 +3887,25 @@ Const local_symtable_index : longint = $8001;
         begin
           if globalnb=0 then
             set_globalnb;
+          { Write the record class itself }
           writing_stabs:=true;
-          dec(globalnb);
-          inherited concatstabto(asmlist);
-          inc(globalnb);
-          writing_stabs:=false;
-          is_def_stab_written:=not_written;
           if assigned(typesym) then
             begin
               st:=typesym^._name;
               typesym^._name:=stringdup(' ');
             end;
+          globalnb:=classglobalnb;
           inherited concatstabto(asmlist);
           if assigned(typesym) then
             begin
               stringdispose(typesym^._name);
               typesym^._name:=st;
             end;
+          globalnb:=classptrglobalnb;
+          writing_stabs:=false;
+          { Write the invisible pointer class }
+          is_def_stab_written:=not_written;
+          inherited concatstabto(asmlist);
         end;
       end;
 {$endif GDB}
@@ -4245,6 +4266,7 @@ Const local_symtable_index : longint = $8001;
          rttilist^.concat(new(pai_const,init_16bit(count)));
 
          { count is used to write nameindex   }
+
          { but we need an offset of the owner }
          { to give each property an own slot  }
          if assigned(childof) and (oo_can_have_published in childof^.objectoptions) then
@@ -4320,7 +4342,10 @@ Const local_symtable_index : longint = $8001;
 
 {
   $Log$
-  Revision 1.21  2000-10-04 23:16:48  pierre
+  Revision 1.22  2000-10-14 10:14:52  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.21  2000/10/04 23:16:48  pierre
    * object stabs fix (merged)
 
   Revision 1.20  2000/10/01 19:48:25  peter

compiler/symdefh.inc

@@ -194,6 +194,8 @@
           { and no vmt field for objects without virtuals }
           vmt_offset : longint;
 {$ifdef GDB}
+          classglobalnb,
+          classptrglobalnb : word;
           writing_stabs : boolean;
 {$endif GDB}
           constructor init(const n : string;c : pobjectdef);
@@ -222,6 +224,7 @@
           function stabstring : pchar;virtual;
           procedure set_globalnb;virtual;
           function  classnumberstring : string;
+          function  classptrnumberstring : string;
           procedure concatstabto(asmlist : paasmoutput);virtual;
 {$endif GDB}
           { init/final }
@@ -459,9 +462,9 @@
           procedure load_references;
           function  write_references : boolean;
           function  procname: string;
+          function  cplusplusmangledname(const rn : string) : string;
           { debug }
 {$ifdef GDB}
-          function  cplusplusmangledname : string;
           function  stabstring : pchar;virtual;
           procedure concatstabto(asmlist : paasmoutput);virtual;
 {$endif GDB}
@@ -554,7 +557,10 @@
 
 {
   $Log$
-  Revision 1.10  2000-09-24 15:06:29  peter
+  Revision 1.11  2000-10-14 10:14:53  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.10  2000/09/24 15:06:29  peter
     * use defines.inc
 
   Revision 1.9  2000/09/19 23:08:03  pierre
@@ -588,4 +594,4 @@
   Revision 1.2  2000/07/13 11:32:49  michael
   + removed logs
 
-}
+}

compiler/symtable.pas

@@ -473,11 +473,7 @@ implementation
      version,verbose,
      types,ppu,
      gendef,fmodule,finput
-{$ifdef CG11}
      ,node
-{$else CG11}
-     ,tree
-{$endif CG11}
      ,cresstr
 {$ifdef newcg}
      ,cgbase
@@ -487,8 +483,8 @@ implementation
 {$ifdef BrowserLog}
      ,browlog
 {$endif BrowserLog}
-     ,cpuasm
      ,scanner
+     ,cpuasm
      ;
 
   var
@@ -2284,7 +2280,9 @@ implementation
 
     constructor tunitsymtable.loadasunit;
       var
+{$ifdef GDB}
         storeGlobalTypeCount : pword;
+{$endif GDB}
         b : byte;
       begin
          unitsym:=nil;
@@ -2882,7 +2880,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.9  2000-10-01 19:48:25  peter
+  Revision 1.10  2000-10-14 10:14:53  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.9  2000/10/01 19:48:25  peter
     * lot of compile updates for cg11
 
   Revision 1.8  2000/09/24 15:06:29  peter
@@ -2910,4 +2911,4 @@ end.
   Revision 1.2  2000/07/13 11:32:50  michael
   + removed logs
 
-}
+}

compiler/tgeni386.pas

@@ -29,11 +29,7 @@ interface
     uses
        cobjects,globals,
        hcodegen,verbose,aasm,
-{$ifdef CG11}
        node,
-{$else}
-       tree,
-{$endif}
        cpubase,cpuasm
        ;
 
@@ -96,11 +92,11 @@ interface
 {$ifdef SUPPORT_MMX}
        regvar_longintarray = array[R_EAX..R_MM6] of longint;
        regvar_booleanarray = array[R_EAX..R_MM6] of boolean;
-       regvar_ptreearray = array[R_EAX..R_MM6] of {$ifdef CG11}tnode{$else}ptree{$endif};
+       regvar_ptreearray = array[R_EAX..R_MM6] of tnode;
 {$else SUPPORT_MMX}
        regvar_longintarray = array[R_EAX..R_EDI] of longint;
        regvar_booleanarray = array[R_EAX..R_EDI] of boolean;
-       regvar_ptreearray = array[R_EAX..R_EDI] of {$ifdef CG11}tnode{$else}ptree{$endif};
+       regvar_ptreearray = array[R_EAX..R_EDI] of tnode;
 {$endif SUPPORT_MMX}
 
     var
@@ -657,7 +653,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.7  2000-09-30 16:08:46  peter
+  Revision 1.8  2000-10-14 10:14:56  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.7  2000/09/30 16:08:46  peter
     * more cg11 updates
 
   Revision 1.6  2000/09/24 15:06:32  peter

compiler/tokens.pas

@@ -164,6 +164,7 @@ type
     _STRING,
     _SYSTEM,
     _ASMNAME,
+    _CPPDECL,
     _DEFAULT,
     _DISPOSE,
     _DYNAMIC,
@@ -368,6 +369,7 @@ const
       (str:'STRING'        ;special:false;keyword:m_all;op:NOTOKEN),
       (str:'SYSTEM'        ;special:false;keyword:m_none;op:NOTOKEN),
       (str:'ASMNAME'       ;special:false;keyword:m_none;op:NOTOKEN),
+      (str:'CPPDECL'       ;special:false;keyword:m_none;op:NOTOKEN),
       (str:'DEFAULT'       ;special:false;keyword:m_none;op:NOTOKEN),
       (str:'DISPOSE'       ;special:false;keyword:m_all;op:NOTOKEN),
       (str:'DYNAMIC'       ;special:false;keyword:m_none;op:NOTOKEN),
@@ -466,7 +468,10 @@ end;
 end.
 {
   $Log$
-  Revision 1.4  2000-09-24 15:06:32  peter
+  Revision 1.5  2000-10-14 10:14:56  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.4  2000/09/24 15:06:32  peter
     * use defines.inc
 
   Revision 1.3  2000/07/13 12:08:28  michael
@@ -475,4 +480,4 @@ end.
   Revision 1.2  2000/07/13 11:32:52  michael
   + removed logs
 
-}
+}

compiler/types.pas

@@ -29,9 +29,7 @@ interface
     uses
        cobjects,
        cpuinfo,
-{$ifdef CG11}
        node,
-{$endif}
        symtable;
 
     type
@@ -147,7 +145,6 @@ interface
     { to use on other types                              }
     function is_subequal(def1, def2: pdef): boolean;
 
-{$ifdef CG11}
      type
        tconverttype = (
           tc_equal,
@@ -186,7 +183,6 @@ interface
     function isconvertable(def_from,def_to : pdef;
              var doconv : tconverttype;fromtreetype : tnodetype;
              explicit : boolean) : byte;
-{$endif CG11}
 
     { same as is_equal, but with error message if failed }
     function CheckTypes(def1,def2 : pdef) : boolean;
@@ -235,10 +231,6 @@ implementation
 
     uses
        globtype,globals,
-{$ifndef CG11}
-       htypechk,
-       tree,
-{$endif}
        verbose,symconst,tokens;
 
     var
@@ -1161,7 +1153,6 @@ implementation
         end; { endif assigned ... }
       end;
 
-{$ifdef CG11}
     function assignment_overloaded(from_def,to_def : pdef) : pprocdef;
        var
           passproc : pprocdef;
@@ -1390,7 +1381,7 @@ implementation
                             end
                            else
                             if isconvertable(parraydef(def_from)^.elementtype.def,
-                                             parraydef(def_to)^.elementtype.def,hct,arrayconstructn,false)<>0 then
+                                             parraydef(def_to)^.elementtype.def,hct,arrayconstructorn,false)<>0 then
                              begin
                                doconv:=hct;
                                b:=2;
@@ -1427,7 +1418,7 @@ implementation
                    begin
                      { string constant (which can be part of array constructor)
                        to zero terminated string constant }
-                     if (fromtreetype in [arrayconstructn,stringconstn]) and
+                     if (fromtreetype in [arrayconstructorn,stringconstn]) and
                         is_pchar(def_to) then
                       begin
                         doconv:=tc_cstring_2_pchar;
@@ -1647,7 +1638,7 @@ implementation
          end;
         isconvertable:=b;
       end;
-{$endif CG11}
+
 
     function CheckTypes(def1,def2 : pdef) : boolean;
 
@@ -1678,7 +1669,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.13  2000-10-01 19:48:26  peter
+  Revision 1.14  2000-10-14 10:14:56  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.13  2000/10/01 19:48:26  peter
     * lot of compile updates for cg11
 
   Revision 1.12  2000/09/30 16:08:46  peter