* moved entry and exitcode to ncgutil and cgobj

  * foreach gets extra argument for passing local data to the
    iterator function
  * -CR checks also class typecasts at runtime by changing them
    into as
  * fixed compiler to cycle with the -CR option
  * fixed stabs with elf writer, finally the global variables can
    be watched
  * removed a lot of routines from cga unit and replaced them by
    calls to cgobj
  * u32bit-s32bit updates for and,or,xor nodes. When one element is
    u32bit then the other is typecasted also to u32bit without giving
    a rangecheck warning/error.
  * fixed pascal calling method with reversing also the high tree in
    the parast, detected by tcalcst3 test

compiler/cclasses.pas

@@ -177,8 +177,8 @@ interface
        Pdictionaryhasharray=^Tdictionaryhasharray;
        Tdictionaryhasharray=array[0..hasharraysize-1] of TNamedIndexItem;
 
-       TnamedIndexCallback = procedure(p:TNamedIndexItem) of object;
-       TnamedIndexStaticCallback = procedure(p:TNamedIndexItem);
+       TnamedIndexCallback = procedure(p:TNamedIndexItem;arg:pointer) of object;
+       TnamedIndexStaticCallback = procedure(p:TNamedIndexItem;arg:pointer);
 
        Tdictionary=class
        private
@@ -197,8 +197,8 @@ interface
          procedure clear;
          function  delete(const s:string):TNamedIndexItem;
          function  empty:boolean;
-         procedure foreach(proc2call:TNamedIndexcallback);
-         procedure foreach_static(proc2call:TNamedIndexStaticCallback);
+         procedure foreach(proc2call:TNamedIndexcallback;arg:pointer);
+         procedure foreach_static(proc2call:TNamedIndexStaticCallback;arg:pointer);
          function  insert(obj:TNamedIndexItem):TNamedIndexItem;
          function  rename(const olds,News : string):TNamedIndexItem;
          function  search(const s:string):TNamedIndexItem;
@@ -225,8 +225,8 @@ interface
         constructor Create(Agrowsize:integer);
         destructor  destroy;override;
         procedure clear;
-        procedure foreach(proc2call : Tnamedindexcallback);
-        procedure foreach_static(proc2call : Tnamedindexstaticcallback);
+        procedure foreach(proc2call : Tnamedindexcallback;arg:pointer);
+        procedure foreach_static(proc2call : Tnamedindexstaticcallback;arg:pointer);
         procedure deleteindex(p:TNamedIndexItem);
         procedure delete(var p:TNamedIndexItem);
         procedure insert(p:TNamedIndexItem);
@@ -851,7 +851,7 @@ end;
 {$ifdef hashdebug}
       var
         i, unused, slots_with_col, collissions, treecount, maxcol: longint;
-{$endif hashdebug}        
+{$endif hashdebug}
       begin
         if not noclear then
          clear;
@@ -1046,15 +1046,15 @@ end;
       end;
 
 
-    procedure Tdictionary.foreach(proc2call:TNamedIndexcallback);
+    procedure Tdictionary.foreach(proc2call:TNamedIndexcallback;arg:pointer);
 
-        procedure a(p:TNamedIndexItem);
+        procedure a(p:TNamedIndexItem;arg:pointer);
         begin
-          proc2call(p);
+          proc2call(p,arg);
           if assigned(p.FLeft) then
-           a(p.FLeft);
+           a(p.FLeft,arg);
           if assigned(p.FRight) then
-           a(p.FRight);
+           a(p.FRight,arg);
         end;
 
       var
@@ -1064,23 +1064,23 @@ end;
          begin
            for i:=low(FHashArray^) to high(FHashArray^) do
             if assigned(FHashArray^[i]) then
-             a(FHashArray^[i]);
+             a(FHashArray^[i],arg);
          end
         else
          if assigned(FRoot) then
-          a(FRoot);
+          a(FRoot,arg);
       end;
 
 
-    procedure Tdictionary.foreach_static(proc2call:TNamedIndexStaticCallback);
+    procedure Tdictionary.foreach_static(proc2call:TNamedIndexStaticCallback;arg:pointer);
 
-        procedure a(p:TNamedIndexItem);
+        procedure a(p:TNamedIndexItem;arg:pointer);
         begin
-          proc2call(p);
+          proc2call(p,arg);
           if assigned(p.FLeft) then
-           a(p.FLeft);
+           a(p.FLeft,arg);
           if assigned(p.FRight) then
-           a(p.FRight);
+           a(p.FRight,arg);
         end;
 
       var
@@ -1090,11 +1090,11 @@ end;
          begin
            for i:=low(FHashArray^) to high(FHashArray^) do
             if assigned(FHashArray^[i]) then
-             a(FHashArray^[i]);
+             a(FHashArray^[i],arg);
          end
         else
          if assigned(FRoot) then
-          a(FRoot);
+          a(FRoot,arg);
       end;
 
 
@@ -1382,23 +1382,23 @@ end;
       end;
 
 
-    procedure tindexarray.foreach(proc2call : Tnamedindexcallback);
+    procedure tindexarray.foreach(proc2call : Tnamedindexcallback;arg:pointer);
       var
         i : integer;
       begin
         for i:=1 to count do
          if assigned(data^[i]) then
-          proc2call(data^[i]);
+          proc2call(data^[i],arg);
       end;
 
 
-    procedure tindexarray.foreach_static(proc2call : Tnamedindexstaticcallback);
+    procedure tindexarray.foreach_static(proc2call : Tnamedindexstaticcallback;arg:pointer);
       var
         i : integer;
       begin
         for i:=1 to count do
          if assigned(data^[i]) then
-          proc2call(data^[i]);
+          proc2call(data^[i],arg);
       end;
 
 
@@ -1728,7 +1728,24 @@ end;
 end.
 {
   $Log$
-  Revision 1.9  2001-11-18 18:43:13  peter
+  Revision 1.10  2002-05-12 16:53:04  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.9  2001/11/18 18:43:13  peter
     * overloading supported in child classes
     * fixed parsing of classes with private and virtual and overloaded
       so it is compatible with delphi

compiler/cg64f32.pas

@@ -475,7 +475,7 @@ unit cg64f32;
              if got_scratch then
                free_scratch_reg(list,hreg);
              { For all other values we have a range check error }
-             a_call_name(list,'FPC_RANGEERROR',0);
+             a_call_name(list,'FPC_RANGEERROR');
 
              { if the high dword = 0, the low dword can be considered a }
              { simple cardinal                                          }
@@ -515,7 +515,7 @@ unit cg64f32;
                  if got_scratch then
                    free_scratch_reg(list,hreg);
 
-                 a_call_name(list,'FPC_RANGEERROR',0);
+                 a_call_name(list,'FPC_RANGEERROR');
 
                  { if we get here, the 64bit value lies between }
                  { longint($80000000) and -1 (JM)               }
@@ -573,7 +573,7 @@ unit cg64f32;
                { !!! freeing of register should happen directly after compare! (JM) }
                if got_scratch then
                  free_scratch_reg(list,hreg);
-               a_call_name(list,'FPC_RANGEERROR',0);
+               a_call_name(list,'FPC_RANGEERROR');
                a_label(list,poslabel);
              end;
       end;
@@ -591,7 +591,24 @@ begin
 end.
 {
   $Log$
-  Revision 1.9  2002-04-25 20:16:38  peter
+  Revision 1.10  2002-05-12 16:53:04  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.9  2002/04/25 20:16:38  peter
     * moved more routines from cga/n386util
 
   Revision 1.8  2002/04/21 15:28:51  carl

compiler/cgobj.pas

@@ -58,6 +58,9 @@ unit cgobj;
           {                 basic routines                 }
           constructor create;
 
+          { returns the tcgsize corresponding with the size of reg }
+          class function reg_cgsize(const reg: tregister) : tcgsize; virtual;
+
           {# Emit a label to the instruction stream. }
           procedure a_label(list : taasmoutput;l : tasmlabel);virtual;
 
@@ -82,23 +85,6 @@ unit cgobj;
           }
           procedure free_scratch_reg(list : taasmoutput;r : tregister);
 
-          {************************************************}
-          { code generation for subroutine entry/exit code }
-
-          { helper routines }
-          procedure g_initialize_data(list : taasmoutput;p : tsym);
-          procedure g_incr_data(list : taasmoutput;p : tsym);
-          procedure g_finalize_data(list : taasmoutput;p : tnamedindexitem);
-          procedure g_copyvalueparas(list : taasmoutput;p : tnamedindexitem);
-
-          procedure g_entrycode(alist : TAAsmoutput;make_global:boolean;
-                           stackframe:longint;
-                           var parasize:longint;var nostackframe:boolean;
-                           inlined : boolean);
-
-          procedure g_exitcode(list : taasmoutput;parasize : longint;
-            nostackframe,inlined : boolean);
-
           { passing parameters, per default the parameter is pushed }
           { nr gives the number of the parameter (enumerated from   }
           { left to right), this allows to move the parameter to    }
@@ -172,11 +158,11 @@ unit cgobj;
               second the destination
           }
 
-          {# Emits instruction to call the method specified by symbol name @var(s) with offset
-             to symbol in @var(offset). This routine must be overriden for each new target cpu.
+          {# Emits instruction to call the method specified by symbol name.
+             This routine must be overriden for each new target cpu.
           }
-          procedure a_call_name(list : taasmoutput;const s : string;
-            offset : longint);virtual; abstract;
+          procedure a_call_name(list : taasmoutput;const s : string);virtual; abstract;
+          procedure a_call_ref(list : taasmoutput;const ref : treference);virtual; abstract;
 
           { move instructions }
           procedure a_load_const_reg(list : taasmoutput;size : tcgsize;a : aword;register : tregister);virtual; abstract;
@@ -190,6 +176,7 @@ unit cgobj;
           procedure a_load_loc_reg(list : taasmoutput;const loc: tlocation; reg : tregister);
           procedure a_load_loc_ref(list : taasmoutput;const loc: tlocation; const ref : treference);
           procedure a_load_sym_ofs_reg(list: taasmoutput; const sym: tasmsymbol; ofs: longint; reg: tregister);virtual; abstract;
+          procedure a_loadaddr_ref_reg(list : taasmoutput;const ref : treference;r : tregister);virtual; abstract;
 
           { fpu move instructions }
           procedure a_loadfpu_reg_reg(list: taasmoutput; reg1, reg2: tregister); virtual; abstract;
@@ -244,42 +231,13 @@ unit cgobj;
 
           procedure g_flags2reg(list: taasmoutput; const f: tresflags; reg: TRegister); virtual; abstract;
 
-          procedure a_loadaddr_ref_reg(list : taasmoutput;const ref : treference;r : tregister);virtual; abstract;
-          procedure g_stackframe_entry(list : taasmoutput;localsize : longint);virtual; abstract;
-          { restores the frame pointer at procedure exit, for the }
-          { i386 it generates a simple leave                      }
-          procedure g_restore_frame_pointer(list : taasmoutput);virtual; abstract;
-
           { some processors like the PPC doesn't allow to change the stack in }
           { a procedure, so we need to maintain an extra stack for the        }
           { result values of setjmp in exception code                         }
           { this two procedures are for pushing an exception value,           }
           { they can use the scratch registers                                }
-          procedure g_push_exception_value_reg(list : taasmoutput;reg : tregister);virtual; abstract;
-          procedure g_push_exception_value_const(list : taasmoutput;reg : tregister);virtual; abstract;
-          { that procedure pops a exception value                             }
-          procedure g_pop_exception_value_reg(list : taasmoutput;reg : tregister);virtual; abstract;
-          procedure g_return_from_proc(list : taasmoutput;parasize : aword);virtual; abstract;
-          {********************************************************}
-          { these methods can be overriden for extra functionality }
-
-          {# Emits instructions which should be emitted when entering
-             a routine declared as @var(interrupt). The default
-             behavior does nothing, should be overriden as required.
-          }
-          procedure g_interrupt_stackframe_entry(list : taasmoutput);virtual;
-
-          {# Emits instructions which should be emitted when exiting
-             a routine declared as @var(interrupt). The default
-             behavior does nothing, should be overriden as required.
-          }
-          procedure g_interrupt_stackframe_exit(list : taasmoutput);virtual;
-
-          {# Emits instructions when compilation is done in profile
-             mode (this is set as a command line option). The default
-             behavior does nothing, should be overriden as required.
-          }
-          procedure g_profilecode(list : taasmoutput);virtual;
+          procedure g_push_exception(list : taasmoutput;const exceptbuf:treference;l:AWord; exceptlabel:TAsmLabel);virtual;abstract;
+          procedure g_pop_exception(list : taasmoutput;endexceptlabel:tasmlabel);virtual;abstract;
 
           procedure g_maybe_loadself(list : taasmoutput);virtual; abstract;
           {# This should emit the opcode to copy len bytes from the source
@@ -334,10 +292,38 @@ unit cgobj;
           { generates overflow checking code for a node }
           procedure g_overflowcheck(list: taasmoutput; const p: tnode); virtual; abstract;
 
+          {**********************************}
+          {    entry/exit code helpers       }
 
-          { returns the tcgsize corresponding with the size of reg }
-          class function reg_cgsize(const reg: tregister) : tcgsize; virtual;
+          procedure g_copyvaluepara_openarray(list : taasmoutput;const ref:treference;elesize:integer); virtual; abstract;
+          {# Emits instructions which should be emitted when entering
+             a routine declared as @var(interrupt). The default
+             behavior does nothing, should be overriden as required.
+          }
+          procedure g_interrupt_stackframe_entry(list : taasmoutput);virtual;
 
+          {# Emits instructions which should be emitted when exiting
+             a routine declared as @var(interrupt). The default
+             behavior does nothing, should be overriden as required.
+          }
+          procedure g_interrupt_stackframe_exit(list : taasmoutput;selfused,accused,acchiused:boolean);virtual;
+
+          {# Emits instructions when compilation is done in profile
+             mode (this is set as a command line option). The default
+             behavior does nothing, should be overriden as required.
+          }
+          procedure g_profilecode(list : taasmoutput);virtual;
+          procedure g_stackframe_entry(list : taasmoutput;localsize : longint);virtual; abstract;
+          { restores the frame pointer at procedure exit }
+          procedure g_restore_frame_pointer(list : taasmoutput);virtual; abstract;
+          procedure g_return_from_proc(list : taasmoutput;parasize : aword);virtual; abstract;
+          procedure g_call_constructor_helper(list : taasmoutput);virtual;abstract;
+          procedure g_call_destructor_helper(list : taasmoutput);virtual;abstract;
+          procedure g_call_fail_helper(list : taasmoutput);virtual;abstract;
+          procedure g_save_standard_registers(list : taasmoutput);virtual;abstract;
+          procedure g_restore_standard_registers(list : taasmoutput);virtual;abstract;
+          procedure g_save_all_registers(list : taasmoutput);virtual;abstract;
+          procedure g_restore_all_registers(list : taasmoutput;selfused,accused,acchiused:boolean);virtual;abstract;
        end;
 
     var
@@ -347,7 +333,7 @@ unit cgobj;
 
     uses
        globals,globtype,options,systems,cgbase,
-       verbose,types,tgobj,symdef,cga,tainst,rgobj;
+       verbose,types,tgobj,symdef,tainst,rgobj;
 
     const
       max_scratch_regs = high(scratch_regs) - low(scratch_regs) + 1;
@@ -417,25 +403,6 @@ unit cgobj;
          a_reg_dealloc(list,r);
       end;
 
-{*****************************************************************************
-            this methods must be overridden for extra functionality
-******************************************************************************}
-
-    procedure tcg.g_interrupt_stackframe_entry(list : taasmoutput);
-
-      begin
-      end;
-
-    procedure tcg.g_interrupt_stackframe_exit(list : taasmoutput);
-
-      begin
-      end;
-
-    procedure tcg.g_profilecode(list : taasmoutput);
-
-      begin
-      end;
-
 {*****************************************************************************
           for better code generation these methods should be overridden
 ******************************************************************************}
@@ -495,554 +462,10 @@ unit cgobj;
          free_scratch_reg(list,hr);
       end;
 
-{*****************************************************************************
-                  Code generation for subroutine entry- and exit code
- *****************************************************************************}
-
-    { generates the code for initialisation of local data }
-    procedure tcg.g_initialize_data(list : taasmoutput;p : tsym);
-
-{      var
-         hr : treference; }
-
-      begin
-(*
-         if (tsym(p)^.typ=varsym) and
-            assigned(pvarsym(p)^.vartype.def) and
-            not((pvarsym(p)^.vartype.def^.deftype=objectdef) and
-              pobjectdef(pvarsym(p)^.vartype.def)^.is_class) and
-            pvarsym(p)^.vartype.def^.needs_inittable then
-           begin
-              procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally;
-              reset_reference(hr);
-              if tsym(p)^.owner^.symtabletype=localsymtable then
-                begin
-                   hr.base:=procinfo^.framepointer;
-                   hr.offset:=-pvarsym(p)^.address;
-                end
-              else
-                begin
-                   hr.symbol:=newasmsymbol(pvarsym(p)^.mangledname);
-                end;
-              g_initialize(list,pvarsym(p)^.vartype.def,hr,false);
-           end;
-*)
-        runerror(211);
-      end;
-
-
-    { generates the code for incrementing the reference count of parameters }
-    procedure tcg.g_incr_data(list : taasmoutput;p : tsym);
-
-{      var
-         hr : treference; }
-
-      begin
-(*
-         if (tsym(p)^.typ=varsym) and
-            not((pvarsym(p)^.vartype.def^.deftype=objectdef) and
-              pobjectdef(pvarsym(p)^.vartype.def)^.is_class) and
-            pvarsym(p)^.vartype.def^.needs_inittable and
-            ((pvarsym(p)^.varspez=vs_value)) then
-           begin
-              procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally;
-              reset_reference(hr);
-              hr.symbol:=pvarsym(p)^.vartype.def^.get_inittable_label;
-              a_param_ref_addr(list,hr,2);
-              reset_reference(hr);
-              hr.base:=procinfo^.framepointer;
-              hr.offset:=pvarsym(p)^.address+procinfo^.para_offset;
-              a_param_ref_addr(list,hr,1);
-              reset_reference(hr);
-              a_call_name(list,'FPC_ADDREF',0);
-           end;
-*)
-        runerror(211);
-      end;
-
-
-    { generates the code for finalisation of local data }
-    procedure tcg.g_finalize_data(list : taasmoutput;p : tnamedindexitem);
-
- {     var
-         hr : treference; }
-
-      begin
-(*
-         if (tsym(p)^.typ=varsym) and
-            assigned(pvarsym(p)^.vartype.def) and
-            not((pvarsym(p)^.vartype.def^.deftype=objectdef) and
-            pobjectdef(pvarsym(p)^.vartype.def)^.is_class) and
-            pvarsym(p)^.vartype.def^.needs_inittable then
-           begin
-              { not all kind of parameters need to be finalized  }
-              if (tsym(p)^.owner^.symtabletype=parasymtable) and
-                ((pvarsym(p)^.varspez=vs_var)  or
-                 (pvarsym(p)^.varspez=vs_const) { and
-                 (dont_copy_const_param(pvarsym(p)^.definition)) } ) then
-                exit;
-              procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally;
-              reset_reference(hr);
-              case tsym(p)^.owner^.symtabletype of
-                 localsymtable:
-                   begin
-                      hr.base:=procinfo^.framepointer;
-                      hr.offset:=-pvarsym(p)^.address;
-                   end;
-                 parasymtable:
-                   begin
-                      hr.base:=procinfo^.framepointer;
-                      hr.offset:=pvarsym(p)^.address+procinfo^.para_offset;
-                   end;
-                 else
-                   hr.symbol:=newasmsymbol(pvarsym(p)^.mangledname);
-              end;
-              g_finalize(list,pvarsym(p)^.vartype.def,hr,false);
-           end;
-*)
-        runerror(211);
-      end;
-
-
-    { generates the code to make local copies of the value parameters }
-    procedure tcg.g_copyvalueparas(list : taasmoutput;p : tnamedindexitem);
-      begin
-         runerror(255);
-      end;
-
-(*
-    var
-       _list : taasmoutput;
 
-    { wrappers for the methods, because TP doesn't know procedures }
-    { of objects                                                   }
-
-    procedure _copyvalueparas(s : tnamedindexitem);{$ifndef FPC}far;{$endif}
-
-      begin
-         cg^.g_copyvalueparas(_list,s);
-      end;
-
-    procedure _finalize_data(s : tnamedindexitem);{$ifndef FPC}far;{$endif}
-
-      begin
-         cg^.g_finalize_data(_list,s);
-      end;
-
-    procedure _incr_data(s : tnamedindexitem);{$ifndef FPC}far;{$endif}
-
-      begin
-         cg^.g_incr_data(_list,tsym(s));
-      end;
-
-    procedure _initialize_data(s : tnamedindexitem);{$ifndef FPC}far;{$endif}
-
-      begin
-         cg^.g_initialize_data(_list,tsym(s));
-      end;
-*)
-
-    { generates the entry code for a procedure }
-    procedure tcg.g_entrycode(alist : TAAsmoutput;make_global:boolean;
-                     stackframe:longint;
-                     var parasize:longint;var nostackframe:boolean;
-                     inlined : boolean);
-
-
-(*
-      var
-         hs : string;
-         hp : pused_unit;
-         initcode : taasmoutput;
-{$ifdef GDB}
-         stab_function_name : Pai_stab_function_name;
-{$endif GDB}
-         hr : treference;
-         r : tregister;
-*)
-
-      begin
-(*
-         { Align }
-         if (not inlined) then
-           begin
-              { gprof uses 16 byte granularity !! }
-              if (cs_profile in aktmoduleswitches) then
-                list^.insert(new(pai_align,init(16)))
-              else
-                if not(cs_littlesize in aktglobalswitches) then
-                  list^.insert(new(pai_align,init(4)));
-          end;
-         { save registers on cdecl }
-         if (po_savestdregs in aktprocsym^.definition^.procoptions) then
-           begin
-              for r:=firstreg to lastreg do
-                begin
-                   if (r in registers_saved_on_cdecl) then
-                     if (r in (tg.availabletempregsint+
-                               tg.availabletempregsfpu+
-                               tg.availabletempregsmm)) then
-                       begin
-                          if not(r in tg.usedinproc) then
-                            {!!!!!!!!!!!! a_push_reg(list,r) }
-                       end
-                     else
-                       {!!!!!!!! a_push_reg(list,r) };
-                end;
-           end;
-        { omit stack frame ? }
-        if not inlined then
-          if procinfo^.framepointer=STACK_POINTER_REG then
-            begin
-               CGMessage(cg_d_stackframe_omited);
-               nostackframe:=true;
-               if (aktprocsym^.definition^.proctypeoption in [potype_unitinit,potype_proginit,potype_unitfinalize]) then
-                 parasize:=0
-               else
-                 parasize:=aktprocsym^.definition^.parast^.datasize+procinfo^.para_offset-pointersize;
-            end
-          else
-            begin
-               if (aktprocsym^.definition^.proctypeoption in [potype_unitinit,potype_proginit,potype_unitfinalize]) then
-                 parasize:=0
-               else
-                 parasize:=aktprocsym^.definition^.parast^.datasize+procinfo^.para_offset-pointersize*2;
-               nostackframe:=false;
-               if (po_interrupt in aktprocsym^.definition^.procoptions) then
-                 g_interrupt_stackframe_entry(list);
-
-               g_stackframe_entry(list,stackframe);
-
-               if (cs_check_stack in aktlocalswitches) and
-                 (tf_supports_stack_checking in target_info.flags) then
-                 g_stackcheck(@initcode,stackframe);
-            end;
-
-         if cs_profile in aktmoduleswitches then
-           g_profilecode(@initcode);
-          if (not inlined) and (aktprocsym^.definition^.proctypeoption in [potype_unitinit]) then
-            begin
-
-              { needs the target a console flags ? }
-              if tf_needs_isconsole in target_info.flags then
-                begin
-                   hr.symbol:=newasmsymbol('U_'+target_info.system_unit+'_ISCONSOLE');
-                   if apptype=at_cui then
-                     a_load_const_ref(list,OS_8,1,hr)
-                   else
-                     a_load_const_ref(list,OS_8,0,hr);
-                   dispose(hr.symbol,done);
-                end;
-
-              hp:=pused_unit(usedunits.first);
-              while assigned(hp) do
-                begin
-                   { call the unit init code and make it external }
-                   if (hp^.u^.flags and uf_init)<>0 then
-                     a_call_name(list,
-                       'INIT$$'+hp^.u^.modulename^,0);
-                    hp:=Pused_unit(hp^.next);
-                end;
-           end;
-
-{$ifdef dummy}
-         { a constructor needs a help procedure }
-         if (aktprocsym^.definition^.options and poconstructor)<>0 then
-           begin
-             if procinfo^._class^.isclass then
-               begin
-                 list^.concat(new(paicpu,op_sym(A_CALL,S_NO,newasmsymbol('FPC_NEW_CLASS'))));
-                 list^.concat(new(paicpu,op_cond_sym(A_Jcc,C_Z,S_NO,quickexitlabel)));
-               end
-             else
-               begin
-                 {
-                 list^.insert(new(pai_labeled,init(A_JZ,quickexitlabel)));
-                 list^.insert(new(paicpu,op_csymbol(A_CALL,S_NO,
-                   newcsymbol('FPC_HELP_CONSTRUCTOR',0))));
-                 list^.insert(new(paicpu,op_const_reg(A_MOV,S_L,procinfo^._class^.vmt_offset,R_EDI)));
-                 concat_external('FPC_HELP_CONSTRUCTOR',EXT_NEAR);
-                 }
-               end;
-           end;
-{$endif dummy}
-  {$ifdef GDB}
-         if (cs_debuginfo in aktmoduleswitches) then
-           list^.insert(new(pai_force_line,init));
-  {$endif GDB}
-
-         { initialize return value }
-         if assigned(procinfo^.returntype.def) and
-           is_ansistring(procinfo^.returntype.def) or
-           is_widestring(procinfo^.returntype.def) then
-           begin
-              reset_reference(hr);
-              hr.offset:=procinfo^.return_offset;
-              hr.base:=procinfo^.framepointer;
-              a_load_const_ref(list,OS_32,0,hr);
-           end;
-
-         _list:=list;
-         { generate copies of call by value parameters }
-         if (po_assembler in aktprocsym^.definition^.procoptions) then
-            aktprocsym^.definition^.parast^.foreach({$ifdef FPCPROCVAR}@{$endif}_copyvalueparas);
-
-         { initialisizes local data }
-         aktprocsym^.definition^.localst^.foreach({$ifdef FPCPROCVAR}@{$endif}_initialize_data);
-         { add a reference to all call by value/const parameters }
-         aktprocsym^.definition^.parast^.foreach({$ifdef FPCPROCVAR}@{$endif}_incr_data);
-
-         if (cs_profile in aktmoduleswitches) or
-           (aktprocsym^.definition^.owner^.symtabletype=globalsymtable) or
-           (assigned(procinfo^._class) and (procinfo^._class^.owner^.symtabletype=globalsymtable)) then
-           make_global:=true;
-         if not inlined then
-           begin
-              hs:=proc_names.get;
-
-  {$ifdef GDB}
-              if (cs_debuginfo in aktmoduleswitches) and target_os.use_function_relative_addresses then
-                stab_function_name := new(pai_stab_function_name,init(strpnew(hs)));
-  {$endif GDB}
-
-              { insert the names for the procedure }
-              while hs<>'' do
-                begin
-                   if make_global then
-                     exprasmlist^.insert(new(pai_symbol,initname_global(hs,0)))
-                   else
-                     exprasmlist^.insert(new(pai_symbol,initname(hs,0)));
-
-  {$ifdef GDB}
-                   if (cs_debuginfo in aktmoduleswitches) then
-                     begin
-                       if target_os.use_function_relative_addresses then
-                         list^.insert(new(pai_stab_function_name,init(strpnew(hs))));
-                    end;
-  {$endif GDB}
-
-                  hs:=proc_names.get;
-               end;
-          end;
-
-  {$ifdef GDB}
-         if (not inlined) and (cs_debuginfo in aktmoduleswitches) then
-           begin
-              if target_os.use_function_relative_addresses then
-                  list^.insert(stab_function_name);
-              if make_global or ((procinfo^.flags and pi_is_global) <> 0) then
-                  aktprocsym^.is_global := True;
-              list^.insert(new(pai_stabs,init(aktprocsym^.stabstring)));
-              aktprocsym^.isstabwritten:=true;
-            end;
-  {$endif GDB}
-*)
-      runerror(211);
-    end;
-
-    procedure tcg.g_exitcode(list : taasmoutput;parasize:longint;nostackframe,inlined:boolean);
-(*
-      var
-  {$ifdef GDB}
-         mangled_length : longint;
-         p : pchar;
-  {$endif GDB}
-         nofinal,noreraiselabel : tasmlabel;
-         hr : treference;
-         r : tregister;
-*)
-      begin
-(*
-         if aktexitlabel^.is_used then
-           list^.insert(new(pai_label,init(aktexitlabel)));
-
-         { call the destructor help procedure }
-         if (aktprocsym^.definition^.proctypeoption=potype_destructor) then
-           begin
-             if procinfo^._class^.is_class then
-               a_call_name(list,'FPC_DISPOSE_CLASS',0)
-             else
-               begin
-                  if procinfo^._class^.needs_inittable then
-                    begin
-                       getlabel(nofinal);
-                       {!!!!!!!!!!
-                       reset_reference(hr);
-                       hr.base:=R_EBP;
-                       hr.offset:=8;
-                       a_cmp_reg_const_label(list,OS_ADDR,OZ_EQ,
-                       }
-                       reset_reference(hr);
-                       hr.symbol:=procinfo^._class^.get_inittable_label;
-                       a_paramaddr_ref(list,hr,2);
-                       a_param_reg(list,OS_ADDR,self_pointer_reg,1);
-                       a_call_name(list,'FPC_FINALIZE',0);
-                       a_label(list,nofinal);
-                    end;
-                  { vmt_offset_reg can be a scratch register, }
-                  { but it must be always the same            }
-                  a_reg_alloc(list,vmt_offset_reg);
-                  a_load_const_reg(list,OS_32,procinfo^._class^.vmt_offset,vmt_offset_reg);
-                  a_call_name(list,'FPC_HELP_DESTRUCTOR',0);
-                  a_reg_dealloc(list,vmt_offset_reg);
-               end;
-           end;
-
-         { finalize temporary data }
-         g_finalizetempansistrings(list);
-
-         _list:=list;
-
-         { finalize local data }
-         aktprocsym^.definition^.localst^.foreach({$ifdef FPCPROCVAR}@{$endif}_finalize_data);
-
-         { finalize paras data }
-         if assigned(aktprocsym^.definition^.parast) then
-           aktprocsym^.definition^.parast^.foreach({$ifdef FPCPROCVAR}@{$endif}_finalize_data);
-
-         { do we need to handle exceptions because of ansi/widestrings ? }
-         if (procinfo^.flags and pi_needs_implicit_finally)<>0 then
-           begin
-              getlabel(noreraiselabel);
-
-              a_call_name(list,'FPC_POPADDRSTACK',0);
-              a_reg_alloc(list,accumulator);
-              g_pop_exception_value_reg(list,accumulator);
-              a_cmp_const_reg_label(list,OS_32,OC_EQ,0,accumulator,noreraiselabel);
-              a_reg_dealloc(list,accumulator);
-
-              { must be the return value finalized before reraising the exception? }
-              if (procinfo^.returntype.def<>tdef(voiddef)) and
-                (procinfo^.returntype.def^.needs_inittable) and
-                ((procinfo^.returntype.def^.deftype<>objectdef) or
-                not(pobjectdef(procinfo^.returntype.def)^.is_class)) then
-                begin
-                   reset_reference(hr);
-                   hr.offset:=procinfo^.return_offset;
-                   hr.base:=procinfo^.framepointer;
-                   g_finalize(list,procinfo^.returntype.def,hr,ret_in_param(procinfo^.returntype.def));
-                end;
-
-              a_call_name(list,'FPC_RERAISE',0);
-              a_label(list,noreraiselabel);
-           end;
-
-         { call __EXIT for main program }
-         if (not DLLsource) and (not inlined) and (aktprocsym^.definition^.proctypeoption=potype_proginit) then
-           a_call_name(list,'FPC_DO_EXIT',0);
-
-         { handle return value }
-         if not(po_assembler in aktprocsym^.definition^.procoptions) then
-             if (aktprocsym^.definition^.proctypeoption<>potype_constructor) then
-               { handle_return_value(inlined) }
-             else
-               begin
-                  { return self in EAX }
-                  a_label(list,quickexitlabel);
-                  a_reg_alloc(list,accumulator);
-                  a_load_reg_reg(list,OS_ADDR,self_pointer_reg,accumulator);
-                  a_reg_dealloc(list,self_pointer_reg);
-                  a_label(list,quickexitlabel);
-                  { we can't clear the zero flag because the Alpha     }
-                  { for example doesn't have flags, we have to compare }
-                  { the accu. in the caller                            }
-               end;
-
-         { stabs uses the label also ! }
-         if aktexit2label^.is_used or
-            ((cs_debuginfo in aktmoduleswitches) and not inlined) then
-           a_label(list,aktexit2label);
-
-{$ifdef dummy}
-         { should we restore edi ? }
-         { for all i386 gcc implementations }
-         {!!!!!!!!!!! I don't know how to handle register saving yet }
-         if (po_savestdregs in aktprocsym^.definition^.procoptions) then
-           begin
-             if (aktprocsym^.definition^.usedregisters and ($80 shr byte(R_EBX)))<>0 then
-              exprasmlist^.concat(new(paicpu,op_reg(A_POP,S_L,R_EBX)));
-             exprasmlist^.concat(new(paicpu,op_reg(A_POP,S_L,R_ESI)));
-             exprasmlist^.concat(new(paicpu,op_reg(A_POP,S_L,R_EDI)));
-             { here we could reset R_EBX
-               but that is risky because it only works
-               if genexitcode is called after genentrycode
-               so lets skip this for the moment PM
-             aktprocsym^.definition^.usedregisters:=
-               aktprocsym^.definition^.usedregisters or not ($80 shr byte(R_EBX));
-             }
-           end;
-{$endif dummy}
-         if not(nostackframe) and not inlined then
-           g_restore_frame_pointer(list);
-         { at last, the return is generated }
-
-         if not inlined then
-           if po_interrupt in aktprocsym^.definition^.procoptions then
-             g_interrupt_stackframe_exit(list)
-         else
-           g_return_from_proc(list,parasize);
-         list^.concat(new(pai_symbol_end,initname(aktprocsym^.definition^.mangledname)));
-
-    {$ifdef GDB}
-         if (cs_debuginfo in aktmoduleswitches) and not inlined  then
-             begin
-                aktprocsym^.concatstabto(list);
-                if assigned(procinfo^._class) then
-                  if (not assigned(procinfo^.parent) or
-                     not assigned(procinfo^.parent^._class)) then
-                    list^.concat(new(pai_stabs,init(strpnew(
-                     '"$t:v'+procinfo^._class^.numberstring+'",'+
-                     tostr(N_PSYM)+',0,0,'+tostr(procinfo^.selfpointer_offset)))));
-                  {!!!!!!!!!!!!
-                  else
-                    list^.concat(new(pai_stabs,init(strpnew(
-                     '"$t:r'+procinfo^._class^.numberstring+'",'+
-                     tostr(N_RSYM)+',0,0,'+tostr(GDB_i386index[R_ESI])))));
-                  }
-                if (tdef(aktprocsym^.definition^.rettype.def) <> tdef(voiddef)) then
-                  begin
-                    if ret_in_param(aktprocsym^.definition^.rettype.def) then
-                      list^.concat(new(pai_stabs,init(strpnew(
-                       '"'+aktprocsym^.name+':X*'+aktprocsym^.definition^.rettype.def^.numberstring+'",'+
-                       tostr(N_PSYM)+',0,0,'+tostr(procinfo^.return_offset)))))
-                    else
-                      list^.concat(new(pai_stabs,init(strpnew(
-                       '"'+aktprocsym^.name+':X'+aktprocsym^.definition^.rettype.def^.numberstring+'",'+
-                       tostr(N_PSYM)+',0,0,'+tostr(procinfo^.return_offset)))));
-                    if (m_result in aktmodeswitches) then
-                      if ret_in_param(aktprocsym^.definition^.rettype.def) then
-                        list^.concat(new(pai_stabs,init(strpnew(
-                         '"RESULT:X*'+aktprocsym^.definition^.rettype.def^.numberstring+'",'+
-                         tostr(N_PSYM)+',0,0,'+tostr(procinfo^.return_offset)))))
-                      else
-                        list^.concat(new(pai_stabs,init(strpnew(
-                         '"RESULT:X'+aktprocsym^.definition^.rettype.def^.numberstring+'",'+
-                         tostr(N_PSYM)+',0,0,'+tostr(procinfo^.return_offset)))));
-                  end;
-                mangled_length:=length(aktprocsym^.definition^.mangledname);
-                getmem(p,mangled_length+50);
-                strpcopy(p,'192,0,0,');
-                strpcopy(strend(p),aktprocsym^.definition^.mangledname);
-                list^.concat(new(pai_stabn,init(strnew(p))));
-                {list^.concat(new(pai_stabn,init(strpnew('192,0,0,'
-                 +aktprocsym^.definition^.mangledname))));
-                p[0]:='2';p[1]:='2';p[2]:='4';
-                strpcopy(strend(p),'_end');}
-                freemem(p,mangled_length+50);
-                list^.concat(new(pai_stabn,init(
-                  strpnew('224,0,0,'+aktexit2label^.name))));
-                 { strpnew('224,0,0,'
-                 +aktprocsym^.definition^.mangledname+'_end'))));}
-             end;
-    {$endif GDB}
-*)
-        runerror(211);
-      end;
-
-{*****************************************************************************
+{****************************************************************************
                        some generic implementations
- ****************************************************************************}
-
+****************************************************************************}
 
     procedure tcg.a_load_ref_ref(list : taasmoutput;size : tcgsize;const sref : treference;const dref : treference);
 
@@ -1397,7 +820,7 @@ unit cgobj;
         if delsource then
          reference_release(list,source);
         a_param_const(list,OS_INT,len,1);
-        a_call_name(list,'FPC_SHORTSTR_COPY',0);
+        a_call_name(list,'FPC_SHORTSTR_COPY');
         g_maybe_loadself(list);
       end;
 
@@ -1423,14 +846,14 @@ unit cgobj;
          if incrfunc<>'' then
           begin
             a_param_ref(list,OS_ADDR,ref,1);
-            a_call_name(list,incrfunc,0);
+            a_call_name(list,incrfunc);
           end
          else
           begin
             reference_reset_symbol(href,tstoreddef(t).get_rtti_label(initrtti),0);
             a_paramaddr_ref(list,href,2);
             a_paramaddr_ref(list,ref,1);
-            a_call_name(list,'FPC_ADDREF',0);
+            a_call_name(list,'FPC_ADDREF');
          end;
       end;
 
@@ -1454,14 +877,14 @@ unit cgobj;
          if decrfunc<>'' then
           begin
             a_paramaddr_ref(list,ref,1);
-            a_call_name(list,decrfunc,0);
+            a_call_name(list,decrfunc);
           end
          else
           begin
             reference_reset_symbol(href,tstoreddef(t).get_rtti_label(initrtti),0);
             a_paramaddr_ref(list,href,2);
             a_paramaddr_ref(list,ref,1);
-            a_call_name(list,'FPC_DECREF',0);
+            a_call_name(list,'FPC_DECREF');
          end;
       end;
 
@@ -1482,7 +905,7 @@ unit cgobj;
                 a_param_ref(list,OS_ADDR,ref,1)
               else
                 a_paramaddr_ref(list,ref,1);
-              a_call_name(list,'FPC_INITIALIZE',0);
+              a_call_name(list,'FPC_INITIALIZE');
            end;
       end;
 
@@ -1503,7 +926,7 @@ unit cgobj;
                 a_param_ref(list,OS_ADDR,ref,1)
               else
                 a_paramaddr_ref(list,ref,1);
-              a_call_name(list,'FPC_FINALIZE',0);
+              a_call_name(list,'FPC_FINALIZE');
            end;
       end;
 
@@ -1542,7 +965,7 @@ unit cgobj;
         { Note that these checks are mostly processor independent, they only }
         { have to be changed once we introduce 64bit subrange types          }
         if (fromdef = todef) and
-          { then fromdef and todef can only be orddefs }
+           (fromdef.deftype=orddef) and
            (((sizeof(aword) = 4) and
              (((torddef(fromdef).typ = s32bit) and
                (lfrom = low(longint)) and
@@ -1580,7 +1003,7 @@ unit cgobj;
                  { if low(to) > maxlongint also range error }
                  (lto > awordsignedmax) then
                 begin
-                  a_call_name(list,'FPC_RANGEERROR',0);
+                  a_call_name(list,'FPC_RANGEERROR');
                   exit
                 end;
               { from is signed and to is unsigned -> when looking at from }
@@ -1595,7 +1018,7 @@ unit cgobj;
               if (lfrom > awordsignedmax) or
                  (hto < 0) then
                 begin
-                  a_call_name(list,'FPC_RANGEERROR',0);
+                  a_call_name(list,'FPC_RANGEERROR');
                   exit
                 end;
               { from is unsigned and to is signed -> when looking at to }
@@ -1619,7 +1042,7 @@ unit cgobj;
         a_cmp_const_reg_label(list,OS_INT,OC_BE,aword(longint((hto-lto) and $ffffffff)),hreg,neglabel);
         { !!! should happen right after the compare (JM) }
         free_scratch_reg(list,hreg);
-        a_call_name(list,'FPC_RANGEERROR',0);
+        a_call_name(list,'FPC_RANGEERROR');
         a_label(list,neglabel);
       end;
 
@@ -1628,17 +1051,52 @@ unit cgobj;
 
       begin
          a_param_const(list,OS_32,stackframesize,1);
-         a_call_name(list,'FPC_STACKCHECK',0);
+         a_call_name(list,'FPC_STACKCHECK');
       end;
 
 
+{*****************************************************************************
+                            Entry/Exit Code Functions
+*****************************************************************************}
+
+    procedure tcg.g_interrupt_stackframe_entry(list : taasmoutput);
+      begin
+      end;
+
+
+    procedure tcg.g_interrupt_stackframe_exit(list : taasmoutput;selfused,accused,acchiused:boolean);
+      begin
+      end;
+
+
+    procedure tcg.g_profilecode(list : taasmoutput);
+      begin
+      end;
+
 
 finalization
   cg.free;
 end.
 {
   $Log$
-  Revision 1.19  2002-04-26 15:19:04  peter
+  Revision 1.20  2002-05-12 16:53:04  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.19  2002/04/26 15:19:04  peter
     * use saveregisters for incr routines, saves also problems with
       the optimizer
 
@@ -1766,5 +1224,4 @@ end.
 
   Revision 1.1  2000/07/13 06:30:07  michael
     + Initial import
-
 }

compiler/compiler.pas

@@ -121,7 +121,7 @@ function Compile(const cmd:string):longint;
 implementation
 
 uses
-  cpubase,cpuasm;
+  cpuasm;
 
 var
   CompilerInitedAfterArgs,
@@ -337,7 +337,24 @@ end;
 end.
 {
   $Log$
-  Revision 1.25  2002-04-15 19:53:54  peter
+  Revision 1.26  2002-05-12 16:53:05  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.25  2002/04/15 19:53:54  peter
     * fixed conflicts between the last 2 commits
 
   Revision 1.24  2002/04/15 18:56:42  carl

compiler/fppu.pas

@@ -58,7 +58,7 @@ interface
           procedure load_interface;
           procedure load_symtable_refs;
           procedure load_usedunits;
-          procedure writeusedmacro(p:TNamedIndexItem);
+          procedure writeusedmacro(p:TNamedIndexItem;arg:pointer);
           procedure writeusedmacros;
           procedure writesourcefiles;
           procedure writeusedunit;
@@ -345,7 +345,7 @@ uses
     PPU Reading/Writing Helpers
 ***********************************}
 
-    procedure tppumodule.writeusedmacro(p:TNamedIndexItem);
+    procedure tppumodule.writeusedmacro(p:TNamedIndexItem;arg:pointer);
       begin
         if tmacro(p).is_used or tmacro(p).defined_at_startup then
           begin
@@ -359,7 +359,7 @@ uses
     procedure tppumodule.writeusedmacros;
       begin
         ppufile.do_crc:=false;
-        current_scanner.macros.foreach({$ifdef FPCPROCVAR}@{$endif}writeusedmacro);
+        current_scanner.macros.foreach({$ifdef FPCPROCVAR}@{$endif}writeusedmacro,nil);
         ppufile.writeentry(ibusedmacros);
         ppufile.do_crc:=true;
       end;
@@ -1173,7 +1173,24 @@ uses
 end.
 {
   $Log$
-  Revision 1.13  2002-04-04 19:05:56  peter
+  Revision 1.14  2002-05-12 16:53:05  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.13  2002/04/04 19:05:56  peter
     * removed unused units
     * use tlocation.size in cg.a_*loc*() routines
 

compiler/globtype.pas

@@ -79,7 +79,7 @@ interface
        { Switches which can be changed locally }
        tlocalswitch = (cs_localnone,
          { codegen }
-         cs_check_overflow,cs_check_range,cs_check_object_ext,
+         cs_check_overflow,cs_check_range,cs_check_object,
          cs_check_io,cs_check_stack,
          cs_omitstackframe,cs_do_assertion,cs_generate_rtti,
          cs_full_boolean_eval,cs_typed_const_writable,
@@ -119,7 +119,8 @@ interface
          { browser }
          cs_browser_log,
          { debugger }
-         cs_gdb_dbx,cs_gdb_gsym,cs_gdb_heaptrc,cs_gdb_lineinfo,cs_checkpointer,
+         cs_gdb_dbx,cs_gdb_gsym,cs_gdb_heaptrc,cs_gdb_lineinfo,
+         cs_checkpointer,
          { assembling }
          cs_asm_leave,cs_asm_extern,cs_asm_pipe,cs_asm_source,
          cs_asm_regalloc,cs_asm_tempalloc,cs_asm_nodes,
@@ -214,6 +215,7 @@ interface
        tnormalset = set of byte; { 256 elements set }
        pnormalset = ^tnormalset;
 
+       pboolean   = ^boolean;
        pdouble    = ^double;
        pbyte      = ^byte;
        pword      = ^word;
@@ -253,7 +255,24 @@ implementation
 end.
 {
   $Log$
-  Revision 1.22  2002-04-21 19:02:03  peter
+  Revision 1.23  2002-05-12 16:53:05  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.22  2002/04/21 19:02:03  peter
     * removed newn and disposen nodes, the code is now directly
       inlined from pexpr
     * -an option that will write the secondpass nodes to the .s file, this

compiler/i386/ag386att.pas

@@ -39,10 +39,10 @@ interface
 
     TAttSuffix = (AttSufNONE,AttSufINT,AttSufFPU,AttSufFPUint);
 
-    const      
+    const
       gas_op2str:op2strtable={$i i386att.inc}
       gas_needsuffix:array[tasmop] of TAttSuffix={$i i386atts.inc}
-      
+
       gas_reg2str : reg2strtable = ('',
         '%eax','%ecx','%edx','%ebx','%esp','%ebp','%esi','%edi',
         '%ax','%cx','%dx','%bx','%sp','%bp','%si','%di',
@@ -55,7 +55,7 @@ interface
         '%mm0','%mm1','%mm2','%mm3','%mm4','%mm5','%mm6','%mm7',
         '%xmm0','%xmm1','%xmm2','%xmm3','%xmm4','%xmm5','%xmm6','%xmm7'
        );
-      
+
      gas_opsize2str : array[topsize] of string[2] = ('',
        'b','w','l','bw','bl','wl',
        's','l','q',
@@ -66,22 +66,8 @@ interface
   implementation
 
     uses
-{$ifdef Delphi}
-      dmisc,
-{$else Delphi}
-      dos,
-{$endif Delphi}
-      cutils,globtype,systems,
-      fmodule,finput,verbose,cpuasm,tainst
-{$ifdef GDB}
-  {$ifdef delphi}
-      ,sysutils
-  {$else}
-      ,strings
-  {$endif}
-      ,gdb
-{$endif GDB}
-      ;
+      cutils,systems,
+      verbose,cpuasm;
 
 
 
@@ -352,7 +338,24 @@ initialization
 end.
 {
   $Log$
-  Revision 1.18  2002-04-15 19:12:10  carl
+  Revision 1.19  2002-05-12 16:53:16  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.18  2002/04/15 19:12:10  carl
   + target_info.size_of_pointer -> pointer_size
   + some cleanup of unused types/variables
   * move several constants from cpubase to their specific units

compiler/i386/ag386int.pas

@@ -35,9 +35,9 @@ interface
         Function  DoAssemble:boolean;override;
         procedure WriteExternals;
       end;
-      
 
-      
+
+
 
   implementation
 
@@ -691,7 +691,7 @@ ait_stab_function_name : ;
     var
       currentasmlist : TExternalAssembler;
 
-    procedure writeexternal(p:tnamedindexitem);
+    procedure writeexternal(p:tnamedindexitem;arg:pointer);
       begin
         if tasmsymbol(p).defbind=AB_EXTERNAL then
           begin
@@ -706,7 +706,7 @@ ait_stab_function_name : ;
     procedure T386IntelAssembler.WriteExternals;
       begin
         currentasmlist:=self;
-        AsmSymbolList.foreach_static({$ifdef fpcprocvar}@{$endif}writeexternal);
+        AsmSymbolList.foreach_static({$ifdef fpcprocvar}@{$endif}writeexternal,nil);
       end;
 
 
@@ -824,7 +824,24 @@ initialization
 end.
 {
   $Log$
-  Revision 1.17  2002-04-15 19:12:09  carl
+  Revision 1.18  2002-05-12 16:53:16  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.17  2002/04/15 19:12:09  carl
   + target_info.size_of_pointer -> pointer_size
   + some cleanup of unused types/variables
   * move several constants from cpubase to their specific units

compiler/i386/ag386nsm.pas

@@ -35,8 +35,8 @@ interface
         procedure WriteAsmList;override;
         procedure WriteExternals;
       end;
-      
-      
+
+
 
   implementation
 
@@ -727,7 +727,7 @@ interface
     var
       currentasmlist : TExternalAssembler;
 
-    procedure writeexternal(p:tnamedindexitem);
+    procedure writeexternal(p:tnamedindexitem;arg:pointer);
       begin
         if tasmsymbol(p).defbind=AB_EXTERNAL then
          currentasmlist.AsmWriteln('EXTERN'#9+p.name);
@@ -736,7 +736,7 @@ interface
     procedure T386NasmAssembler.WriteExternals;
       begin
         currentasmlist:=self;
-        AsmSymbolList.foreach_static({$ifdef fpcprocvar}@{$endif}writeexternal);
+        AsmSymbolList.foreach_static({$ifdef fpcprocvar}@{$endif}writeexternal,nil);
       end;
 
 
@@ -846,7 +846,7 @@ interface
               '.idata2','.idata4','.idata5','.idata6','.idata7','.edata',
               '.stab','.stabstr')
           );
-          
+
        as_i386_nasmwdosx_info : tasminfo =
           (
             id           : as_i386_nasmwdosx;
@@ -866,7 +866,7 @@ interface
               '.idata2','.idata4','.idata5','.idata6','.idata7','.edata',
               '.stab','.stabstr')
           );
-          
+
 
        as_i386_nasmelf_info : tasminfo =
           (
@@ -892,13 +892,30 @@ interface
 initialization
   RegisterAssembler(as_i386_nasmcoff_info,T386NasmAssembler);
   RegisterAssembler(as_i386_nasmwin32_info,T386NasmAssembler);
-  RegisterAssembler(as_i386_nasmwdosx_info,T386NasmAssembler); 
+  RegisterAssembler(as_i386_nasmwdosx_info,T386NasmAssembler);
   RegisterAssembler(as_i386_nasmobj_info,T386NasmAssembler);
   RegisterAssembler(as_i386_nasmelf_info,T386NasmAssembler);
 end.
 {
   $Log$
-  Revision 1.16  2002-04-15 19:12:09  carl
+  Revision 1.17  2002-05-12 16:53:16  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.16  2002/04/15 19:12:09  carl
   + target_info.size_of_pointer -> pointer_size
   + some cleanup of unused types/variables
   * move several constants from cpubase to their specific units

compiler/i386/cga.pas

@@ -37,7 +37,6 @@ interface
     function def_opsize(p1:tdef):topsize;
     function def_getreg(p1:tdef):tregister;
 
-    procedure emitlab(var l : tasmlabel);
     procedure emitjmp(c : tasmcond;var l : tasmlabel);
 
     procedure emit_none(i : tasmop;s : topsize);
@@ -57,49 +56,6 @@ interface
 
 
     procedure emit_sym(i : tasmop;s : topsize;op : tasmsymbol);
-    procedure emit_sym_ofs(i : tasmop;s : topsize;op : tasmsymbol;ofs : longint);
-    procedure emit_sym_ofs_reg(i : tasmop;s : topsize;op : tasmsymbol;ofs:longint;reg : tregister);
-
-    procedure emitcall(const routine:string);
-
-    { remove non regvar registers in loc from regs (in the format }
-    { pushusedregisters uses)                                     }
-    procedure remove_non_regvars_from_loc(const t: tlocation; var regs: tregisterset);
-
-    procedure push_int(l : longint);
-    procedure emit_push_mem(const ref : treference);
-    procedure emitpushreferenceaddr(const ref : treference);
-
-    procedure maybe_loadself;
-    procedure emitloadord2reg(const location:Tlocation;orddef:torddef;destreg:Tregister;delloc:boolean);
-    procedure concatcopy(source,dest : treference;size : longint;delsource : boolean;loadref:boolean);
-
-    procedure genentrycode(alist : TAAsmoutput;make_global:boolean;
-                           stackframe:longint;
-                           var parasize:longint;var nostackframe:boolean;
-                           inlined : boolean);
-    procedure genexitcode(alist : TAAsmoutput;parasize:longint;
-                          nostackframe,inlined:boolean);
-
-    { if a unit doesn't have a explicit init/final code,  }
-    { we've to generate one, if the units has ansistrings }
-    { in the interface or implementation                  }
-    procedure genimplicitunitfinal(alist : TAAsmoutput);
-    procedure genimplicitunitinit(alist : TAAsmoutput);
-{$ifdef test_dest_loc}
-
-const
-  { used to avoid temporary assignments }
-  dest_loc_known : boolean = false;
-  in_dest_loc    : boolean = false;
-  dest_loc_tree  : ptree = nil;
-
-var
-  dest_loc : tlocation;
-
-procedure mov_reg_to_dest(p : ptree; s : topsize; reg : tregister);
-
-{$endif test_dest_loc}
 
 
 implementation
@@ -128,10 +84,6 @@ implementation
  {$define __NOWINPECOFF__}
 {$endif}
 
-{$ifndef __NOWINPECOFF__}
-  const
-     winstackpagesize = 4096;
-{$endif}
 
 
 {*****************************************************************************
@@ -162,14 +114,6 @@ implementation
                               Emit Assembler
 *****************************************************************************}
 
-    procedure emitlab(var l : tasmlabel);
-      begin
-         if not l.is_set then
-          exprasmList.concat(Tai_label.Create(l))
-         else
-          internalerror(7453984);
-      end;
-
     procedure emitjmp(c : tasmcond;var l : tasmlabel);
       var
         ai : taicpu;
@@ -247,1719 +191,27 @@ implementation
         exprasmList.concat(Taicpu.Op_sym(i,s,op));
       end;
 
-    procedure emit_sym_ofs(i : tasmop;s : topsize;op : tasmsymbol;ofs : longint);
-      begin
-        exprasmList.concat(Taicpu.Op_sym_ofs(i,s,op,ofs));
-      end;
-
-    procedure emit_sym_ofs_reg(i : tasmop;s : topsize;op : tasmsymbol;ofs:longint;reg : tregister);
-      begin
-        exprasmList.concat(Taicpu.Op_sym_ofs_reg(i,s,op,ofs,reg));
-      end;
-
-    procedure emitcall(const routine:string);
-      begin
-        exprasmList.concat(Taicpu.Op_sym(A_CALL,S_NO,newasmsymbol(routine)));
-      end;
-
-    { only usefull in startup code }
-    procedure emitinsertcall(const routine:string);
-      begin
-        exprasmList.insert(Taicpu.Op_sym(A_CALL,S_NO,newasmsymbol(routine)));
-      end;
-
-
-    procedure remove_non_regvars_from_loc(const t: tlocation; var regs: tregisterset);
-    begin
-      case t.loc of
-        LOC_REGISTER:
-          begin
-            { can't be a regvar, since it would be LOC_CREGISTER then }
-            exclude(regs,t.register);
-            if t.registerhigh <> R_NO then
-              exclude(regs,t.registerhigh);
-          end;
-        LOC_CREFERENCE,LOC_REFERENCE:
-          begin
-            if not(cs_regalloc in aktglobalswitches) or
-               (t.reference.base in rg.usableregsint) then
-              exclude(regs,t.reference.base);
-            if not(cs_regalloc in aktglobalswitches) or
-               (t.reference.index in rg.usableregsint) then
-            exclude(regs,t.reference.index);
-          end;
-      end;
-    end;
-
-
-
-{*****************************************************************************
-                           Emit Push Functions
-*****************************************************************************}
-
-    procedure push_int(l : longint);
-      begin
-         if (l = 0) and
-            not(aktoptprocessor in [Class386, ClassP6]) and
-            not(cs_littlesize in aktglobalswitches)
-           Then
-             begin
-               rg.getexplicitregisterint(exprasmlist,R_EDI);
-               emit_reg_reg(A_XOR,S_L,R_EDI,R_EDI);
-               exprasmList.concat(Taicpu.Op_reg(A_PUSH,S_L,R_EDI));
-               rg.ungetregisterint(exprasmlist,R_EDI);
-             end
-           else
-             exprasmList.concat(Taicpu.Op_const(A_PUSH,S_L,aword(l)));
-      end;
-
-    procedure emit_push_mem(const ref : treference);
-
-      begin
-             if not(aktoptprocessor in [Class386, ClassP6]) and
-                not(cs_littlesize in aktglobalswitches)
-               then
-                 begin
-                   rg.getexplicitregisterint(exprasmlist,R_EDI);
-                   emit_ref_reg(A_MOV,S_L,ref,R_EDI);
-                   exprasmList.concat(Taicpu.Op_reg(A_PUSH,S_L,R_EDI));
-                   rg.ungetregisterint(exprasmlist,R_EDI);
-                 end
-               else exprasmList.concat(Taicpu.Op_ref(A_PUSH,S_L,ref));
-      end;
-
-
-    procedure emitpushreferenceaddr(const ref : treference);
-      begin
-              if ref.segment<>R_NO then
-                CGMessage(cg_e_cant_use_far_pointer_there);
-              if (ref.base=R_NO) and (ref.index=R_NO) then
-                exprasmList.concat(Taicpu.Op_sym_ofs(A_PUSH,S_L,ref.symbol,ref.offset))
-              else if (ref.base=R_NO) and (ref.index<>R_NO) and
-                 (ref.offset=0) and (ref.scalefactor=0) and (ref.symbol=nil) then
-                exprasmList.concat(Taicpu.Op_reg(A_PUSH,S_L,ref.index))
-              else if (ref.base<>R_NO) and (ref.index=R_NO) and
-                 (ref.offset=0) and (ref.symbol=nil) then
-                exprasmList.concat(Taicpu.Op_reg(A_PUSH,S_L,ref.base))
-              else
-                begin
-                   rg.getexplicitregisterint(exprasmlist,R_EDI);
-                   emit_ref_reg(A_LEA,S_L,ref,R_EDI);
-                   exprasmList.concat(Taicpu.Op_reg(A_PUSH,S_L,R_EDI));
-                   rg.ungetregisterint(exprasmlist,R_EDI);
-                end;
-        end;
-
-
-{*****************************************************************************
-                           Emit Functions
-*****************************************************************************}
-
-    procedure concatcopy(source,dest : treference;size : longint;delsource,loadref : boolean);
-
-      {const
-         isizes : array[0..3] of topsize=(S_L,S_B,S_W,S_B);
-         ishr : array[0..3] of byte=(2,0,1,0);}
-
-      var
-         ecxpushed : boolean;
-         oldsourceoffset,
-         helpsize : longint;
-         i : byte;
-         reg8,reg32 : tregister;
-         swap : boolean;
-
-         procedure maybepushecx;
-         begin
-           if not(R_ECX in rg.unusedregsint) then
-             begin
-               exprasmList.concat(Taicpu.Op_reg(A_PUSH,S_L,R_ECX));
-               ecxpushed:=true;
-             end
-           else rg.getexplicitregisterint(exprasmlist,R_ECX);
-         end;
-
-      begin
-         oldsourceoffset:=source.offset;
-         if (not loadref) and
-            ((size<=8) or
-             (not(cs_littlesize in aktglobalswitches ) and (size<=12))) then
-           begin
-              helpsize:=size shr 2;
-              rg.getexplicitregisterint(exprasmlist,R_EDI);
-              for i:=1 to helpsize do
-                begin
-                   emit_ref_reg(A_MOV,S_L,source,R_EDI);
-                   If (size = 4) and delsource then
-                     reference_release(exprasmlist,source);
-                   exprasmList.concat(Taicpu.Op_reg_ref(A_MOV,S_L,R_EDI,dest));
-                   inc(source.offset,4);
-                   inc(dest.offset,4);
-                   dec(size,4);
-                end;
-              if size>1 then
-                begin
-                   emit_ref_reg(A_MOV,S_W,source,R_DI);
-                   If (size = 2) and delsource then
-                     reference_release(exprasmlist,source);
-                   exprasmList.concat(Taicpu.Op_reg_ref(A_MOV,S_W,R_DI,dest));
-                   inc(source.offset,2);
-                   inc(dest.offset,2);
-                   dec(size,2);
-                end;
-              rg.ungetregisterint(exprasmlist,R_EDI);
-              if size>0 then
-                begin
-                   { and now look for an 8 bit register }
-                   swap:=false;
-                   if R_EAX in rg.unusedregsint then reg8:=rg.makeregsize(rg.getexplicitregisterint(exprasmlist,R_EAX),OS_8)
-                   else if R_EDX in rg.unusedregsint then reg8:=rg.makeregsize(rg.getexplicitregisterint(exprasmlist,R_EDX),OS_8)
-                   else if R_EBX in rg.unusedregsint then reg8:=rg.makeregsize(rg.getexplicitregisterint(exprasmlist,R_EBX),OS_8)
-                   else if R_ECX in rg.unusedregsint then reg8:=rg.makeregsize(rg.getexplicitregisterint(exprasmlist,R_ECX),OS_8)
-                   else
-                      begin
-                         swap:=true;
-                         { we need only to check 3 registers, because }
-                         { one is always not index or base          }
-                         if (dest.base<>R_EAX) and (dest.index<>R_EAX) then
-                           begin
-                              reg8:=R_AL;
-                              reg32:=R_EAX;
-                           end
-                         else if (dest.base<>R_EBX) and (dest.index<>R_EBX) then
-                           begin
-                              reg8:=R_BL;
-                              reg32:=R_EBX;
-                           end
-                         else if (dest.base<>R_ECX) and (dest.index<>R_ECX) then
-                           begin
-                              reg8:=R_CL;
-                              reg32:=R_ECX;
-                           end;
-                      end;
-                   if swap then
-                     { was earlier XCHG, of course nonsense }
-                     begin
-                       rg.getexplicitregisterint(exprasmlist,R_EDI);
-                       emit_reg_reg(A_MOV,S_L,reg32,R_EDI);
-                     end;
-                   emit_ref_reg(A_MOV,S_B,source,reg8);
-                   If delsource then
-                     reference_release(exprasmlist,source);
-                   exprasmList.concat(Taicpu.Op_reg_ref(A_MOV,S_B,reg8,dest));
-                   if swap then
-                     begin
-                       emit_reg_reg(A_MOV,S_L,R_EDI,reg32);
-                       rg.ungetregisterint(exprasmlist,R_EDI);
-                     end
-                   else
-                     rg.ungetregister(exprasmlist,reg8);
-                end;
-           end
-         else
-           begin
-              rg.getexplicitregisterint(exprasmlist,R_EDI);
-              emit_ref_reg(A_LEA,S_L,dest,R_EDI);
-              exprasmList.concat(Tairegalloc.Alloc(R_ESI));
-              if loadref then
-                emit_ref_reg(A_MOV,S_L,source,R_ESI)
-              else
-                begin
-                  emit_ref_reg(A_LEA,S_L,source,R_ESI);
-                  if delsource then
-                    reference_release(exprasmlist,source);
-                end;
-
-              exprasmList.concat(Taicpu.Op_none(A_CLD,S_NO));
-              ecxpushed:=false;
-              if cs_littlesize in aktglobalswitches  then
-                begin
-                   maybepushecx;
-                   emit_const_reg(A_MOV,S_L,size,R_ECX);
-                   exprasmList.concat(Taicpu.Op_none(A_REP,S_NO));
-                   exprasmList.concat(Taicpu.Op_none(A_MOVSB,S_NO));
-                end
-              else
-                begin
-                   helpsize:=size shr 2;
-                   size:=size and 3;
-                   if helpsize>1 then
-                    begin
-                      maybepushecx;
-                      emit_const_reg(A_MOV,S_L,helpsize,R_ECX);
-                      exprasmList.concat(Taicpu.Op_none(A_REP,S_NO));
-                    end;
-                   if helpsize>0 then
-                    exprasmList.concat(Taicpu.Op_none(A_MOVSD,S_NO));
-                   if size>1 then
-                     begin
-                        dec(size,2);
-                        exprasmList.concat(Taicpu.Op_none(A_MOVSW,S_NO));
-                     end;
-                   if size=1 then
-                     exprasmList.concat(Taicpu.Op_none(A_MOVSB,S_NO));
-                end;
-              rg.ungetregisterint(exprasmlist,R_EDI);
-              exprasmList.concat(Tairegalloc.DeAlloc(R_ESI));
-              if ecxpushed then
-                exprasmList.concat(Taicpu.Op_reg(A_POP,S_L,R_ECX))
-              else
-                rg.ungetregisterint(exprasmlist,R_ECX);
-
-              { loading SELF-reference again }
-              maybe_loadself;
-           end;
-         if delsource then
-           begin
-             source.offset:=oldsourceoffset;
-             tg.ungetiftemp(exprasmlist,source);
-           end;
-      end;
-
-
-    procedure emitloadord2reg(const location:Tlocation;orddef:torddef;
-                              destreg:Tregister;delloc:boolean);
-
-    {A lot smaller and less bug sensitive than the original unfolded loads.}
-
-    var tai:Taicpu;
-
-    begin
-        tai := nil;
-        case location.loc of
-            LOC_REGISTER,LOC_CREGISTER:
-                begin
-                    case orddef.typ of
-                        u8bit,uchar,bool8bit:
-                            tai:=Taicpu.Op_reg_reg(A_MOVZX,S_BL,location.register,destreg);
-                        s8bit:
-                            tai:=Taicpu.Op_reg_reg(A_MOVSX,S_BL,location.register,destreg);
-                        u16bit,uwidechar,bool16bit:
-                            tai:=Taicpu.Op_reg_reg(A_MOVZX,S_WL,location.register,destreg);
-                        s16bit:
-                            tai:=Taicpu.Op_reg_reg(A_MOVSX,S_WL,location.register,destreg);
-                        u32bit,bool32bit,s32bit:
-                            if location.register <> destreg then
-                              tai:=Taicpu.Op_reg_reg(A_MOV,S_L,location.register,destreg);
-                        else
-                          internalerror(330);
-                    end;
-                    if delloc then
-                        rg.ungetregister(exprasmlist,location.register);
-                end;
-            LOC_CONSTANT:
-                begin
-                  tai:=Taicpu.Op_const_reg(A_MOV,S_L,location.value,destreg)
-                end;
-            LOC_CREFERENCE,
-            LOC_REFERENCE:
-                begin
-                       case orddef.typ of
-                         u8bit,uchar,bool8bit:
-                            tai:=Taicpu.Op_ref_reg(A_MOVZX,S_BL,location.reference,destreg);
-                         s8bit:
-                            tai:=Taicpu.Op_ref_reg(A_MOVSX,S_BL,location.reference,destreg);
-                         u16bit,uwidechar,bool16bit:
-                            tai:=Taicpu.Op_ref_reg(A_MOVZX,S_WL,location.reference,destreg);
-                         s16bit:
-                            tai:=Taicpu.Op_ref_reg(A_MOVSX,S_WL,location.reference,destreg);
-                         u32bit,bool32bit:
-                            tai:=Taicpu.Op_ref_reg(A_MOV,S_L,location.reference,destreg);
-                         s32bit:
-                            tai:=Taicpu.Op_ref_reg(A_MOV,S_L,location.reference,destreg);
-                         else
-                           internalerror(330);
-                     end;
-                    if delloc then
-                        reference_release(exprasmlist,location.reference);
-                end
-            else
-                internalerror(6);
-        end;
-        if assigned(tai) then
-          exprasmList.concat(tai);
-    end;
-
-    { if necessary ESI is reloaded after a call}
-    procedure maybe_loadself;
-
-      var
-         hp : treference;
-         p : pprocinfo;
-         i : longint;
-
-      begin
-         if assigned(procinfo^._class) then
-           begin
-              exprasmList.concat(Tairegalloc.Alloc(R_ESI));
-              if lexlevel>normal_function_level then
-                begin
-                   reference_reset_base(hp,procinfo^.framepointer,procinfo^.framepointer_offset);
-                   emit_ref_reg(A_MOV,S_L,hp,R_ESI);
-                   p:=procinfo^.parent;
-                   for i:=3 to lexlevel-1 do
-                     begin
-                        reference_reset_base(hp,R_ESI,p^.framepointer_offset);
-                        emit_ref_reg(A_MOV,S_L,hp,R_ESI);
-                        p:=p^.parent;
-                     end;
-                   reference_reset_base(hp,R_ESI,p^.selfpointer_offset);
-                   emit_ref_reg(A_MOV,S_L,hp,R_ESI);
-                end
-              else
-                begin
-                   reference_reset_base(hp,procinfo^.framepointer,procinfo^.selfpointer_offset);
-                   emit_ref_reg(A_MOV,S_L,hp,R_ESI);
-                end;
-           end;
-      end;
-
-
-{*****************************************************************************
-                            Entry/Exit Code Functions
-*****************************************************************************}
-
-  procedure genprofilecode;
-    var
-      pl : tasmlabel;
-    begin
-      if (po_assembler in aktprocdef.procoptions) then
-       exit;
-      case target_info.target of
-         target_i386_win32,
-         target_i386_freebsd,
-         target_i386_wdosx,
-         target_i386_linux:
-           begin
-              getaddrlabel(pl);
-              emitinsertcall(target_info.Cprefix+'mcount');
-              include(rg.usedinproc,R_EDX);
-              exprasmList.insert(Taicpu.Op_sym_ofs_reg(A_MOV,S_L,pl,0,R_EDX));
-              exprasmList.insert(Tai_section.Create(sec_code));
-              exprasmList.insert(Tai_const.Create_32bit(0));
-              exprasmList.insert(Tai_label.Create(pl));
-              exprasmList.insert(Tai_align.Create(4));
-              exprasmList.insert(Tai_section.Create(sec_data));
-           end;
-
-         target_i386_go32v2:
-           begin
-              emitinsertcall('MCOUNT');
-           end;
-      end;
-    end;
-
-
-    procedure generate_interrupt_stackframe_entry;
-      begin
-         { save the registers of an interrupt procedure }
-         exprasmList.insert(Taicpu.Op_reg(A_PUSH,S_L,R_EAX));
-         exprasmList.insert(Taicpu.Op_reg(A_PUSH,S_L,R_EBX));
-         exprasmList.insert(Taicpu.Op_reg(A_PUSH,S_L,R_ECX));
-         exprasmList.insert(Taicpu.Op_reg(A_PUSH,S_L,R_EDX));
-         exprasmList.insert(Taicpu.Op_reg(A_PUSH,S_L,R_ESI));
-         exprasmList.insert(Taicpu.Op_reg(A_PUSH,S_L,R_EDI));
-
-         { .... also the segment registers }
-         exprasmList.insert(Taicpu.Op_reg(A_PUSH,S_W,R_DS));
-         exprasmList.insert(Taicpu.Op_reg(A_PUSH,S_W,R_ES));
-         exprasmList.insert(Taicpu.Op_reg(A_PUSH,S_W,R_FS));
-         exprasmList.insert(Taicpu.Op_reg(A_PUSH,S_W,R_GS));
-      end;
-
-
-    procedure generate_interrupt_stackframe_exit;
-      begin
-         { restore the registers of an interrupt procedure }
-         { this was all with entrycode instead of exitcode !!}
-         procinfo^.aktexitcode.concat(Taicpu.Op_reg(A_POP,S_L,R_EAX));
-         procinfo^.aktexitcode.concat(Taicpu.Op_reg(A_POP,S_L,R_EBX));
-         procinfo^.aktexitcode.concat(Taicpu.Op_reg(A_POP,S_L,R_ECX));
-         procinfo^.aktexitcode.concat(Taicpu.Op_reg(A_POP,S_L,R_EDX));
-         procinfo^.aktexitcode.concat(Taicpu.Op_reg(A_POP,S_L,R_ESI));
-         procinfo^.aktexitcode.concat(Taicpu.Op_reg(A_POP,S_L,R_EDI));
-
-         { .... also the segment registers }
-         procinfo^.aktexitcode.concat(Taicpu.Op_reg(A_POP,S_W,R_DS));
-         procinfo^.aktexitcode.concat(Taicpu.Op_reg(A_POP,S_W,R_ES));
-         procinfo^.aktexitcode.concat(Taicpu.Op_reg(A_POP,S_W,R_FS));
-         procinfo^.aktexitcode.concat(Taicpu.Op_reg(A_POP,S_W,R_GS));
-
-        { this restores the flags }
-         procinfo^.aktexitcode.concat(Taicpu.Op_none(A_IRET,S_NO));
-      end;
-
-
-  { generates the code for threadvar initialisation }
-  procedure initialize_threadvar(p : tnamedindexitem);
-
-    var
-       hr : treference;
-
-    begin
-       if (tsym(p).typ=varsym) and
-          (vo_is_thread_var in tvarsym(p).varoptions) then
-         begin
-            exprasmList.concat(Taicpu.Op_const(A_PUSH,S_L,tvarsym(p).getsize));
-            reference_reset(hr);
-            hr.symbol:=newasmsymbol(tvarsym(p).mangledname);
-            emitpushreferenceaddr(hr);
-            rg.saveregvars(exprasmlist,all_registers);
-            emitcall('FPC_INIT_THREADVAR');
-         end;
-    end;
-
-
-  { generates the code for initialisation of local data }
-  procedure initialize_data(p : tnamedindexitem);
-
-    var
-       hr : treference;
-
-    begin
-       if (tsym(p).typ=varsym) and
-          assigned(tvarsym(p).vartype.def) and
-          not(is_class(tvarsym(p).vartype.def)) and
-          tvarsym(p).vartype.def.needs_inittable then
-         begin
-            if assigned(procinfo) then
-              procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally;
-            reference_reset(hr);
-            if tsym(p).owner.symtabletype in [localsymtable,inlinelocalsymtable] then
-              begin
-                 hr.base:=procinfo^.framepointer;
-                 hr.offset:=-tvarsym(p).address+tvarsym(p).owner.address_fixup;
-              end
-            else
-              begin
-                 hr.symbol:=newasmsymbol(tvarsym(p).mangledname);
-              end;
-            cg.g_initialize(exprasmlist,tvarsym(p).vartype.def,hr,false);
-         end;
-    end;
-
-  { generates the code for incrementing the reference count of parameters and
-    initialize out parameters }
-  procedure init_paras(p : tnamedindexitem);
-
-    var
-       hrv : treference;
-       hr: treference;
-
-    begin
-       if (tsym(p).typ=varsym) and
-          not is_class(tvarsym(p).vartype.def) and
-          tvarsym(p).vartype.def.needs_inittable then
-         begin
-           if (tvarsym(p).varspez=vs_value) then
-             begin
-               procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally;
-
-               reference_reset(hrv);
-               hrv.base:=procinfo^.framepointer;
-               if assigned(tvarsym(p).localvarsym) then
-                hrv.offset:=-tvarsym(p).localvarsym.address+tvarsym(p).localvarsym.owner.address_fixup
-               else
-                hrv.offset:=tvarsym(p).address+procinfo^.para_offset;
-
-               cg.g_incrrefcount(exprasmlist,tvarsym(p).vartype.def,hrv);
-             end
-           else if (tvarsym(p).varspez=vs_out) then
-             begin
-               reference_reset(hrv);
-               hrv.base:=procinfo^.framepointer;
-               hrv.offset:=tvarsym(p).address+procinfo^.para_offset;
-               rg.getexplicitregisterint(exprasmlist,R_EDI);
-               exprasmList.concat(Taicpu.Op_ref_reg(A_MOV,S_L,hrv,R_EDI));
-               reference_reset_base(hr,R_EDI,0);
-               cg.g_initialize(exprasmlist,tvarsym(p).vartype.def,hr,false);
-             end;
-         end;
-    end;
-
-  { generates the code for decrementing the reference count of parameters }
-  procedure final_paras(p : tnamedindexitem);
-    var
-       hrv : treference;
-    begin
-       if (tsym(p).typ=varsym) and
-          not is_class(tvarsym(p).vartype.def) and
-          tvarsym(p).vartype.def.needs_inittable then
-         begin
-           if (tvarsym(p).varspez=vs_value) then
-             begin
-               procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally;
-
-               reference_reset(hrv);
-               hrv.base:=procinfo^.framepointer;
-               if assigned(tvarsym(p).localvarsym) then
-                hrv.offset:=-tvarsym(p).localvarsym.address+tvarsym(p).localvarsym.owner.address_fixup
-               else
-                hrv.offset:=tvarsym(p).address+procinfo^.para_offset;
-
-               cg.g_decrrefcount(exprasmlist,tvarsym(p).vartype.def,hrv);
-             end;
-         end;
-    end;
-
-
-  { generates the code for finalisation of local data }
-  procedure finalize_data(p : tnamedindexitem);
-
-    var
-       hr : treference;
-
-    begin
-       if (tsym(p).typ=varsym) and
-          assigned(tvarsym(p).vartype.def) and
-          not(is_class(tvarsym(p).vartype.def)) and
-          tvarsym(p).vartype.def.needs_inittable then
-         begin
-            if assigned(procinfo) then
-              procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally;
-            reference_reset(hr);
-            case tsym(p).owner.symtabletype of
-               localsymtable,inlinelocalsymtable:
-                 begin
-                    hr.base:=procinfo^.framepointer;
-                    hr.offset:=-tvarsym(p).address+tvarsym(p).owner.address_fixup;
-                 end;
-               else
-                 hr.symbol:=newasmsymbol(tvarsym(p).mangledname);
-            end;
-            cg.g_finalize(exprasmlist,tvarsym(p).vartype.def,hr,false);
-         end;
-    end;
-
-
-  { generates the code to make local copies of the value parameters }
-  procedure copyvalueparas(p : tnamedindexitem);
-    var
-      href1,href2 : treference;
-      r    : treference;
-      power,len  : longint;
-      opsize : topsize;
-{$ifndef __NOWINPECOFF__}
-      again,ok : tasmlabel;
-{$endif}
-    begin
-       if (tsym(p).typ=varsym) and
-          (tvarsym(p).varspez=vs_value) and
-          (push_addr_param(tvarsym(p).vartype.def)) then
-        begin
-          if is_open_array(tvarsym(p).vartype.def) or
-             is_array_of_const(tvarsym(p).vartype.def) then
-           begin
-              { get stack space }
-              reference_reset_base(r,procinfo^.framepointer,tvarsym(p).address+4+procinfo^.para_offset);
-              rg.getexplicitregisterint(exprasmlist,R_EDI);
-              exprasmList.concat(Taicpu.op_ref_reg(A_MOV,S_L,r,R_EDI));
-              exprasmList.concat(Taicpu.op_reg(A_INC,S_L,R_EDI));
-              if (tarraydef(tvarsym(p).vartype.def).elesize<>1) then
-               begin
-                 if ispowerof2(tarraydef(tvarsym(p).vartype.def).elesize, power) then
-                   exprasmList.concat(Taicpu.op_const_reg(A_SHL,S_L,power,R_EDI))
-                 else
-                   exprasmList.concat(Taicpu.op_const_reg(A_IMUL,S_L,
-                     tarraydef(tvarsym(p).vartype.def).elesize,R_EDI));
-               end;
-{$ifndef NOTARGETWIN32}
-              { windows guards only a few pages for stack growing, }
-              { so we have to access every page first              }
-              if target_info.target=target_i386_win32 then
-                begin
-                   getlabel(again);
-                   getlabel(ok);
-                   emitlab(again);
-                   exprasmList.concat(Taicpu.op_const_reg(A_CMP,S_L,winstackpagesize,R_EDI));
-                   emitjmp(C_C,ok);
-                   exprasmList.concat(Taicpu.op_const_reg(A_SUB,S_L,winstackpagesize-4,R_ESP));
-                   exprasmList.concat(Taicpu.op_reg(A_PUSH,S_L,R_EAX));
-                   exprasmList.concat(Taicpu.op_const_reg(A_SUB,S_L,winstackpagesize,R_EDI));
-                   emitjmp(C_None,again);
-
-                   emitlab(ok);
-                   exprasmList.concat(Taicpu.op_reg_reg(A_SUB,S_L,R_EDI,R_ESP));
-                   rg.ungetregisterint(exprasmlist,R_EDI);
-                   { now reload EDI }
-                   reference_reset_base(r,procinfo^.framepointer,tvarsym(p).address+4+procinfo^.para_offset);
-                   rg.getexplicitregisterint(exprasmlist,R_EDI);
-                   exprasmList.concat(Taicpu.op_ref_reg(A_MOV,S_L,r,R_EDI));
-
-                   exprasmList.concat(Taicpu.op_reg(A_INC,S_L,R_EDI));
-
-                   if (tarraydef(tvarsym(p).vartype.def).elesize<>1) then
-                    begin
-                      if ispowerof2(tarraydef(tvarsym(p).vartype.def).elesize, power) then
-                        exprasmList.concat(Taicpu.op_const_reg(A_SHL,S_L,power,R_EDI))
-                      else
-                        exprasmList.concat(Taicpu.op_const_reg(A_IMUL,S_L,
-                          tarraydef(tvarsym(p).vartype.def).elesize,R_EDI));
-                    end;
-                end
-              else
-{$endif NOTARGETWIN32}
-                exprasmList.concat(Taicpu.op_reg_reg(A_SUB,S_L,R_EDI,R_ESP));
-              { load destination }
-              exprasmList.concat(Taicpu.op_reg_reg(A_MOV,S_L,R_ESP,R_EDI));
-
-              { don't destroy the registers! }
-              exprasmList.concat(Taicpu.op_reg(A_PUSH,S_L,R_ECX));
-              exprasmList.concat(Taicpu.op_reg(A_PUSH,S_L,R_ESI));
-
-              { load count }
-              reference_reset_base(r,procinfo^.framepointer,tvarsym(p).address+4+procinfo^.para_offset);
-              exprasmList.concat(Taicpu.op_ref_reg(A_MOV,S_L,r,R_ECX));
-
-              { load source }
-              reference_reset_base(r,procinfo^.framepointer,tvarsym(p).address+procinfo^.para_offset);
-              exprasmList.concat(Taicpu.op_ref_reg(A_MOV,S_L,r,R_ESI));
-
-              { scheduled .... }
-              exprasmList.concat(Taicpu.op_reg(A_INC,S_L,R_ECX));
-
-              { calculate size }
-              len:=tarraydef(tvarsym(p).vartype.def).elesize;
-              opsize:=S_B;
-              if (len and 3)=0 then
-               begin
-                 opsize:=S_L;
-                 len:=len shr 2;
-               end
-              else
-               if (len and 1)=0 then
-                begin
-                  opsize:=S_W;
-                  len:=len shr 1;
-                end;
-
-              if ispowerof2(len, power) then
-                exprasmList.concat(Taicpu.op_const_reg(A_SHL,S_L,power,R_ECX))
-              else
-                exprasmList.concat(Taicpu.op_const_reg(A_IMUL,S_L,len,R_ECX));
-              exprasmList.concat(Taicpu.op_none(A_REP,S_NO));
-              case opsize of
-                S_B : exprasmList.concat(Taicpu.Op_none(A_MOVSB,S_NO));
-                S_W : exprasmList.concat(Taicpu.Op_none(A_MOVSW,S_NO));
-                S_L : exprasmList.concat(Taicpu.Op_none(A_MOVSD,S_NO));
-              end;
-              rg.ungetregisterint(exprasmlist,R_EDI);
-              exprasmList.concat(Taicpu.op_reg(A_POP,S_L,R_ESI));
-              exprasmList.concat(Taicpu.op_reg(A_POP,S_L,R_ECX));
-
-              { patch the new address }
-              reference_reset_base(r,procinfo^.framepointer,tvarsym(p).address+procinfo^.para_offset);
-              exprasmList.concat(Taicpu.op_reg_ref(A_MOV,S_L,R_ESP,r));
-           end
-          else
-           if is_shortstring(tvarsym(p).vartype.def) then
-            begin
-              reference_reset_base(href1,procinfo^.framepointer,tvarsym(p).address+procinfo^.para_offset);
-              reference_reset_base(href2,procinfo^.framepointer,-tvarsym(p).localvarsym.address+tvarsym(p).localvarsym.owner.address_fixup);
-              cg.g_copyshortstring(exprasmlist,href1,href2,tstringdef(tvarsym(p).vartype.def).len,false,true);
-            end
-           else
-            begin
-              reference_reset_base(href1,procinfo^.framepointer,tvarsym(p).address+procinfo^.para_offset);
-              reference_reset_base(href2,procinfo^.framepointer,-tvarsym(p).localvarsym.address+tvarsym(p).localvarsym.owner.address_fixup);
-              concatcopy(href1,href2,tvarsym(p).vartype.def.size,true,true);
-            end;
-        end;
-    end;
-
-  procedure inittempvariables;
-
-    var
-       hp : ptemprecord;
-       r : treference;
-
-    begin
-       hp:=tg.templist;
-       while assigned(hp) do
-         begin
-           if hp^.temptype in [tt_ansistring,tt_freeansistring,
-             tt_widestring,tt_freewidestring,
-             tt_interfacecom] then
-             begin
-               procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally;
-               reference_reset_base(r,procinfo^.framepointer,hp^.pos);
-               emit_const_ref(A_MOV,S_L,0,r);
-             end;
-           hp:=hp^.next;
-         end;
-   end;
-
-  procedure finalizetempvariables;
-
-    var
-       hp : ptemprecord;
-       hr : treference;
-    begin
-       hp:=tg.templist;
-       while assigned(hp) do
-         begin
-            if hp^.temptype in [tt_ansistring,tt_freeansistring] then
-              begin
-                procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally;
-                reference_reset_base(hr,procinfo^.framepointer,hp^.pos);
-                emitpushreferenceaddr(hr);
-                emitcall('FPC_ANSISTR_DECR_REF');
-              end
-            else if hp^.temptype in [tt_widestring,tt_freewidestring] then
-              begin
-                procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally;
-                reference_reset_base(hr,procinfo^.framepointer,hp^.pos);
-                emitpushreferenceaddr(hr);
-                emitcall('FPC_WIDESTR_DECR_REF');
-              end
-            else if hp^.temptype=tt_interfacecom then
-              begin
-                procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally;
-                reference_reset_base(hr,procinfo^.framepointer,hp^.pos);
-                emitpushreferenceaddr(hr);
-                emitcall('FPC_INTF_DECR_REF');
-              end;
-            hp:=hp^.next;
-         end;
-   end;
-
-{$ifdef dummy}
-  var
-     ls : longint;
-
-  procedure largest_size(p : tnamedindexitem);
-
-    begin
-       if (tsym(p).typ=varsym) and
-         (tvarsym(p).getvaluesize>ls) then
-         ls:=tvarsym(p).getvaluesize;
-    end;
-{$endif dummy}
-
-  procedure alignstack(alist : TAAsmoutput);
-
-    begin
-{$ifdef dummy}
-       if (cs_optimize in aktglobalswitches) and
-         (aktoptprocessor in [classp5,classp6]) then
-         begin
-            ls:=0;
-            aktprocdef.localst.foreach({$ifndef TP}@{$endif}largest_size);
-            if ls>=8 then
-              aList.insert(Taicpu.Op_const_reg(A_AND,S_L,aword(-8),R_ESP));
-         end;
-{$endif dummy}
-    end;
-
-  procedure genentrycode(alist : TAAsmoutput;make_global:boolean;
-                         stackframe:longint;
-                         var parasize:longint;var nostackframe:boolean;
-                         inlined : boolean);
-  {
-    Generates the entry code for a procedure
-  }
-    var
-      hs : string;
-{$ifdef GDB}
-      stab_function_name : tai_stab_function_name;
-{$endif GDB}
-      hr : treference;
-      p : tsymtable;
-      r : treference;
-      oldlist,
-      oldexprasmlist : TAAsmoutput;
-      again : tasmlabel;
-      i : longint;
-      tempbuf,tempaddr : treference;
-
-    begin
-       oldexprasmlist:=exprasmlist;
-       exprasmlist:=alist;
-       if (not inlined) and (aktprocdef.proctypeoption=potype_proginit) then
-           begin
-              emitinsertcall('FPC_INITIALIZEUNITS');
-
-              { add global threadvars }
-              oldlist:=exprasmlist;
-              exprasmlist:=TAAsmoutput.Create;
-              p:=symtablestack;
-              while assigned(p) do
-                begin
-                   p.foreach_static({$ifndef TP}@{$endif}initialize_threadvar);
-                   p:=p.next;
-                end;
-              oldList.insertlist(exprasmlist);
-              exprasmlist.free;
-              exprasmlist:=oldlist;
-
-              { add local threadvars in units (only if needed because not all platforms
-                have threadvar support) }
-              if have_local_threadvars then
-                emitinsertcall('FPC_INITIALIZELOCALTHREADVARS');
-
-              { initialize profiling for win32 }
-              if (target_info.target in [target_I386_WIN32,target_I386_wdosx]) and
-                 (cs_profile in aktmoduleswitches) then
-                emitinsertcall('__monstartup');
-           end;
-
-{$ifdef GDB}
-      if (not inlined) and (cs_debuginfo in aktmoduleswitches) then
-        exprasmList.insert(Tai_force_line.Create);
-{$endif GDB}
-
-      { a constructor needs a help procedure }
-      if (aktprocdef.proctypeoption=potype_constructor) then
-        begin
-          if is_class(procinfo^._class) then
-            begin
-              procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally;
-              exprasmList.insert(Taicpu.Op_cond_sym(A_Jcc,C_Z,S_NO,faillabel));
-              emitinsertcall('FPC_NEW_CLASS');
-            end
-          else if is_object(procinfo^._class) then
-            begin
-              exprasmList.insert(Taicpu.Op_cond_sym(A_Jcc,C_Z,S_NO,faillabel));
-              emitinsertcall('FPC_HELP_CONSTRUCTOR');
-              rg.getexplicitregisterint(exprasmlist,R_EDI);
-              exprasmList.insert(Taicpu.Op_const_reg(A_MOV,S_L,procinfo^._class.vmt_offset,R_EDI));
-            end
-          else
-            Internalerror(200006161);
-        end;
-
-      { don't load ESI, does the caller }
-      { we must do it for local function }
-      { that can be called from a foreach_static }
-      { of another object than self !! PM }
-
-         if assigned(procinfo^._class) and  { !!!!! shouldn't we load ESI always? }
-            (lexlevel>normal_function_level) then
-           maybe_loadself;
-
-      { When message method contains self as a parameter,
-        we must load it into ESI }
-      If (po_containsself in aktprocdef.procoptions) then
-        begin
-           reference_reset_base(hr,procinfo^.framepointer,procinfo^.selfpointer_offset);
-           exprasmList.insert(Taicpu.Op_ref_reg(A_MOV,S_L,hr,R_ESI));
-           exprasmList.insert(Tairegalloc.Alloc(R_ESI));
-        end;
-      { should we save edi,esi,ebx like C ? }
-      if (po_savestdregs in aktprocdef.procoptions) then
-       begin
-         if (R_EBX in aktprocdef.usedregisters) then
-           exprasmList.insert(Taicpu.Op_reg(A_PUSH,S_L,R_EBX));
-         exprasmList.insert(Taicpu.Op_reg(A_PUSH,S_L,R_ESI));
-         exprasmList.insert(Taicpu.Op_reg(A_PUSH,S_L,R_EDI));
-       end;
-
-      { for the save all registers we can simply use a pusha,popa which
-        push edi,esi,ebp,esp(ignored),ebx,edx,ecx,eax }
-      if (po_saveregisters in aktprocdef.procoptions) then
-        begin
-          exprasmList.insert(Taicpu.Op_none(A_PUSHA,S_L));
-        end;
-
-      { omit stack frame ? }
-      if (not inlined) then
-        if (procinfo^.framepointer=STACK_POINTER_REG) then
-          begin
-              CGMessage(cg_d_stackframe_omited);
-              nostackframe:=true;
-              if (aktprocdef.proctypeoption in [potype_unitinit,potype_proginit,potype_unitfinalize]) then
-                parasize:=0
-              else
-                parasize:=aktprocdef.parast.datasize+procinfo^.para_offset-4;
-              if stackframe<>0 then
-                exprasmList.insert(Taicpu.op_const_reg(A_SUB,S_L,stackframe,R_ESP));
-          end
-        else
-          begin
-              alignstack(alist);
-              if (aktprocdef.proctypeoption in [potype_unitinit,potype_proginit,potype_unitfinalize]) then
-                parasize:=0
-              else
-                parasize:=aktprocdef.parast.datasize+procinfo^.para_offset-target_info.first_parm_offset;
-              nostackframe:=false;
-              if stackframe<>0 then
-               begin
-{$ifndef __NOWINPECOFF__}
-                 { windows guards only a few pages for stack growing, }
-                 { so we have to access every page first              }
-                 if (target_info.target=target_i386_win32) and
-                    (stackframe>=winstackpagesize) then
-                   begin
-                     if stackframe div winstackpagesize<=5 then
-                       begin
-                          exprasmList.insert(Taicpu.Op_const_reg(A_SUB,S_L,stackframe-4,R_ESP));
-                          for i:=1 to stackframe div winstackpagesize do
-                            begin
-                               reference_reset_base(hr,R_ESP,stackframe-i*winstackpagesize);
-                               exprasmList.concat(Taicpu.op_const_ref(A_MOV,S_L,0,hr));
-                            end;
-                          exprasmList.concat(Taicpu.op_reg(A_PUSH,S_L,R_EAX));
-                       end
-                     else
-                       begin
-                          getlabel(again);
-                          rg.getexplicitregisterint(exprasmlist,R_EDI);
-                          exprasmList.concat(Taicpu.op_const_reg(A_MOV,S_L,stackframe div winstackpagesize,R_EDI));
-                          emitlab(again);
-                          exprasmList.concat(Taicpu.op_const_reg(A_SUB,S_L,winstackpagesize-4,R_ESP));
-                          exprasmList.concat(Taicpu.op_reg(A_PUSH,S_L,R_EAX));
-                          exprasmList.concat(Taicpu.op_reg(A_DEC,S_L,R_EDI));
-                          emitjmp(C_NZ,again);
-                          rg.ungetregisterint(exprasmlist,R_EDI);
-                          exprasmList.concat(Taicpu.op_const_reg(A_SUB,S_L,stackframe mod winstackpagesize,R_ESP));
-                       end
-                   end
-                 else
-{$endif __NOWINPECOFF__}
-                   exprasmList.insert(Taicpu.Op_const_reg(A_SUB,S_L,stackframe,R_ESP));
-                 if (cs_check_stack in aktlocalswitches) then
-                   begin
-                      emitinsertcall('FPC_STACKCHECK');
-                      exprasmList.insert(Taicpu.Op_const(A_PUSH,S_L,stackframe));
-                   end;
-                 if cs_profile in aktmoduleswitches then
-                   genprofilecode;
-                 exprasmList.insert(Taicpu.Op_reg_reg(A_MOV,S_L,R_ESP,R_EBP));
-                 exprasmList.insert(Taicpu.Op_reg(A_PUSH,S_L,R_EBP));
-               end { endif stackframe <> 0 }
-              else
-               begin
-                 if cs_profile in aktmoduleswitches then
-                   genprofilecode;
-                 exprasmList.insert(Taicpu.Op_reg_reg(A_MOV,S_L,R_ESP,R_EBP));
-                 exprasmList.insert(Taicpu.Op_reg(A_PUSH,S_L,R_EBP));
-               end;
-          end;
-
-      if (po_interrupt in aktprocdef.procoptions) then
-          generate_interrupt_stackframe_entry;
-
-      { initialize return value }
-      if (not is_void(aktprocdef.rettype.def)) and
-         (aktprocdef.rettype.def.needs_inittable) then
-        begin
-           procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally;
-           reference_reset_base(r,procinfo^.framepointer,procinfo^.return_offset);
-           cg.g_initialize(exprasmlist,aktprocdef.rettype.def,r,ret_in_param(aktprocdef.rettype.def));
-        end;
-
-      { initialisize local data like ansistrings }
-      case aktprocdef.proctypeoption of
-         potype_unitinit:
-           begin
-              { using current_module.globalsymtable is hopefully      }
-              { more robust than symtablestack and symtablestack.next }
-              tsymtable(current_module.globalsymtable).foreach_static({$ifndef TP}@{$endif}initialize_data);
-              tsymtable(current_module.localsymtable).foreach_static({$ifndef TP}@{$endif}initialize_data);
-           end;
-         { units have seperate code for initilization and finalization }
-         potype_unitfinalize: ;
-         else
-           aktprocdef.localst.foreach_static({$ifndef TP}@{$endif}initialize_data);
-      end;
-
-      { initialisizes temp. ansi/wide string data }
-      inittempvariables;
-
-      { generate copies of call by value parameters }
-      if not(po_assembler in aktprocdef.procoptions) and
-         not(aktprocdef.proccalloption in [pocall_cdecl,pocall_cppdecl,pocall_palmossyscall,pocall_system]) then
-        aktprocdef.parast.foreach_static({$ifndef TP}@{$endif}copyvalueparas);
-
-      if assigned( aktprocdef.parast) then
-        aktprocdef.parast.foreach_static({$ifndef TP}@{$endif}init_paras);
-
-      { do we need an exception frame because of ansi/widestrings/interfaces ? }
-      if not inlined and
-         ((procinfo^.flags and pi_needs_implicit_finally)<>0) and
-      { but it's useless in init/final code of units }
-        not(aktprocdef.proctypeoption in [potype_unitfinalize,potype_unitinit]) then
-        begin
-            include(rg.usedinproc,R_EAX);
-
-            exprasmList.concat(Taicpu.op_const_reg(A_SUB,S_L,36,R_ESP));
-            exprasmList.concat(Taicpu.op_reg_reg(A_MOV,S_L,R_ESP,R_EDI));
-
-            reference_reset(tempaddr);
-            tempaddr.base:=R_EDI;
-            emitpushreferenceaddr(tempaddr);
-
-            reference_reset(tempbuf);
-            tempbuf.base:=R_EDI;
-            tempbuf.offset:=12;
-            emitpushreferenceaddr(tempbuf);
-
-            { Type of stack-frame must be pushed}
-            exprasmList.concat(Taicpu.op_const(A_PUSH,S_L,1));
-            emitcall('FPC_PUSHEXCEPTADDR');
-
-            exprasmList.concat(Taicpu.op_reg(A_PUSH,S_L,R_EAX));
-            emitcall('FPC_SETJMP');
-            exprasmList.concat(Taicpu.op_reg(A_PUSH,S_L,R_EAX));
-            exprasmList.concat(Taicpu.op_reg_reg(A_TEST,S_L,R_EAX,R_EAX));
-            emitjmp(C_NE,aktexitlabel);
-            { probably we've to reload self here }
-            maybe_loadself;
-        end;
-
-      if not inlined then
-       begin
-         if (cs_profile in aktmoduleswitches) or
-            (aktprocdef.owner.symtabletype=globalsymtable) or
-            (assigned(procinfo^._class) and (procinfo^._class.owner.symtabletype=globalsymtable)) then
-              make_global:=true;
-
-         hs:=aktprocdef.aliasnames.getfirst;
-
-{$ifdef GDB}
-         if (cs_debuginfo in aktmoduleswitches) and target_info.use_function_relative_addresses then
-           stab_function_name := Tai_stab_function_name.Create(strpnew(hs));
-{$EndIf GDB}
-
-         while hs<>'' do
-          begin
-            if make_global then
-              exprasmList.insert(Tai_symbol.Createname_global(hs,0))
-            else
-              exprasmList.insert(Tai_symbol.Createname(hs,0));
-
-{$ifdef GDB}
-            if (cs_debuginfo in aktmoduleswitches) and
-               target_info.use_function_relative_addresses then
-              exprasmList.insert(Tai_stab_function_name.Create(strpnew(hs)));
-{$endif GDB}
-
-            hs:=aktprocdef.aliasnames.getfirst;
-          end;
-
-         if make_global or ((procinfo^.flags and pi_is_global) <> 0) then
-          aktprocsym.is_global := True;
-
-{$ifdef GDB}
-         if (cs_debuginfo in aktmoduleswitches) then
-          begin
-            if target_info.use_function_relative_addresses then
-             exprasmList.insert(stab_function_name);
-            exprasmList.insert(Tai_stabs.Create(aktprocdef.stabstring));
-            aktprocsym.isstabwritten:=true;
-          end;
-{$endif GDB}
-
-         { Align, gprof uses 16 byte granularity }
-         if (cs_profile in aktmoduleswitches) then
-          exprasmList.insert(Tai_align.Create_op(16,$90))
-         else
-          exprasmList.insert(Tai_align.Create(aktalignment.procalign));
-       end;
-       if inlined then
-         load_regvars(exprasmlist,nil);
-      exprasmlist:=oldexprasmlist;
-  end;
-
-
-  procedure handle_return_value(inlined : boolean;var uses_eax,uses_edx : boolean);
-    var
-       hr : treference;
-  begin
-      if not is_void(aktprocdef.rettype.def) then
-          begin
-              {if ((procinfo^.flags and pi_operator)<>0) and
-                 assigned(otsym) then
-                procinfo^.funcret_is_valid:=
-                  procinfo^.funcret_is_valid or (otsym.refs>0);}
-              if (tfuncretsym(aktprocdef.funcretsym).funcretstate<>vs_assigned) and not inlined { and
-                ((procinfo^.flags and pi_uses_asm)=0)} then
-               CGMessage(sym_w_function_result_not_set);
-              reference_reset_base(hr,procinfo^.framepointer,procinfo^.return_offset);
-              if (aktprocdef.rettype.def.deftype in [orddef,enumdef]) then
-                begin
-                  uses_eax:=true;
-                  exprasmList.concat(Tairegalloc.Alloc(R_EAX));
-                  case aktprocdef.rettype.def.size of
-                   8:
-                     begin
-                        emit_ref_reg(A_MOV,S_L,hr,R_EAX);
-                        reference_reset_base(hr,procinfo^.framepointer,procinfo^.return_offset+4);
-                        exprasmList.concat(Tairegalloc.Alloc(R_EDX));
-                        emit_ref_reg(A_MOV,S_L,hr,R_EDX);
-                        uses_edx:=true;
-                     end;
-
-                   4:
-                     emit_ref_reg(A_MOV,S_L,hr,R_EAX);
-
-                   2:
-                     emit_ref_reg(A_MOV,S_W,hr,R_AX);
-
-                   1:
-                     emit_ref_reg(A_MOV,S_B,hr,R_AL);
-                  end;
-                end
-              else
-                if ret_in_acc(aktprocdef.rettype.def) then
-                  begin
-                    uses_eax:=true;
-                    exprasmList.concat(Tairegalloc.Alloc(R_EAX));
-                    emit_ref_reg(A_MOV,S_L,hr,R_EAX);
-                  end
-              else
-                 if (aktprocdef.rettype.def.deftype=floatdef) then
-                   begin
-                      cg.a_loadfpu_ref_reg(exprasmlist,
-                        def_cgsize(aktprocdef.rettype.def),hr,R_ST);
-                   end;
-          end
-  end;
-
-
-  procedure handle_fast_exit_return_value;
-    var
-       hr : treference;
-    begin
-      if not is_void(aktprocdef.rettype.def) then
-          begin
-              reference_reset_base(hr,procinfo^.framepointer,procinfo^.return_offset);
-              if (aktprocdef.rettype.def.deftype in [orddef,enumdef]) then
-                begin
-                  case aktprocdef.rettype.def.size of
-                   8:
-                     begin
-                        emit_reg_ref(A_MOV,S_L,R_EAX,hr);
-                        reference_reset_base(hr,procinfo^.framepointer,procinfo^.return_offset+4);
-                        emit_reg_ref(A_MOV,S_L,R_EDX,hr);
-                     end;
-
-                   4:
-                     emit_reg_ref(A_MOV,S_L,R_EAX,hr);
-
-                   2:
-                     emit_reg_ref(A_MOV,S_W,R_AX,hr);
-
-                   1:
-                     emit_reg_ref(A_MOV,S_B,R_AL,hr);
-                  end;
-                end
-              else
-                if ret_in_acc(aktprocdef.rettype.def) then
-                  begin
-                    emit_reg_ref(A_MOV,S_L,R_EAX,hr);
-                  end
-              else
-                 if (aktprocdef.rettype.def.deftype=floatdef) then
-                   begin
-                      cg.a_loadfpu_reg_ref(exprasmlist,
-                        def_cgsize(aktprocdef.rettype.def),
-                        R_ST,hr);
-                   end;
-          end
-     end;
-
-
-  procedure genexitcode(alist : TAAsmoutput;parasize:longint;nostackframe,inlined:boolean);
-
-    var
-{$ifdef GDB}
-       mangled_length : longint;
-       p : pchar;
-       st : string[2];
-{$endif GDB}
-       stabsendlabel,nofinal,okexitlabel,
-       noreraiselabel,nodestroycall : tasmlabel;
-       hr : treference;
-       uses_eax,uses_edx,uses_esi : boolean;
-       oldexprasmlist : TAAsmoutput;
-       ai : taicpu;
-       pd : tprocdef;
-
-  begin
-      oldexprasmlist:=exprasmlist;
-      exprasmlist:=alist;
-
-      if aktexit2label.is_used and
-         ((procinfo^.flags and (pi_needs_implicit_finally or pi_uses_exceptions)) <> 0) then
-        begin
-          exprasmlist.concat(taicpu.op_sym(A_JMP,S_NO,aktexitlabel));
-          exprasmlist.concat(tai_label.create(aktexit2label));
-          handle_fast_exit_return_value;
-        end;
-
-      if aktexitlabel.is_used then
-        exprasmList.concat(Tai_label.Create(aktexitlabel));
-
-      cleanup_regvars(alist);
-
-      { call the destructor help procedure }
-      if (aktprocdef.proctypeoption=potype_destructor) and
-         assigned(procinfo^._class) then
-        begin
-          if is_class(procinfo^._class) then
-            begin
-              emitinsertcall('FPC_DISPOSE_CLASS');
-            end
-          else if is_object(procinfo^._class) then
-            begin
-              emitinsertcall('FPC_HELP_DESTRUCTOR');
-              rg.getexplicitregisterint(exprasmlist,R_EDI);
-              exprasmList.insert(Taicpu.Op_const_reg(A_MOV,S_L,procinfo^._class.vmt_offset,R_EDI));
-              { must the object be finalized ? }
-              if procinfo^._class.needs_inittable then
-                begin
-                   getlabel(nofinal);
-                   exprasmList.insert(Tai_label.Create(nofinal));
-                   emitinsertcall('FPC_FINALIZE');
-                   rg.ungetregisterint(exprasmlist,R_EDI);
-                   exprasmList.insert(Taicpu.Op_reg(A_PUSH,S_L,R_ESI));
-                   exprasmList.insert(Taicpu.Op_sym(A_PUSH,S_L,procinfo^._class.get_rtti_label(initrtti)));
-                   ai:=Taicpu.Op_sym(A_Jcc,S_NO,nofinal);
-                   ai.SetCondition(C_Z);
-                   exprasmList.insert(ai);
-                   reference_reset_base(hr,R_EBP,8);
-                   exprasmList.insert(Taicpu.Op_const_ref(A_CMP,S_L,0,hr));
-                end;
-            end
-          else
-            begin
-              Internalerror(200006161);
-            end;
-        end;
-
-      { finalize temporary data }
-      finalizetempvariables;
-
-      { finalize local data like ansistrings}
-      case aktprocdef.proctypeoption of
-         potype_unitfinalize:
-           begin
-              { using current_module.globalsymtable is hopefully      }
-              { more robust than symtablestack and symtablestack.next }
-              tsymtable(current_module.globalsymtable).foreach_static({$ifndef TP}@{$endif}finalize_data);
-              tsymtable(current_module.localsymtable).foreach_static({$ifndef TP}@{$endif}finalize_data);
-           end;
-         { units have seperate code for initialization and finalization }
-         potype_unitinit: ;
-         else
-           aktprocdef.localst.foreach_static({$ifndef TP}@{$endif}finalize_data);
-      end;
-
-      { finalize paras data }
-      if assigned(aktprocdef.parast) then
-        aktprocdef.parast.foreach_static({$ifndef TP}@{$endif}final_paras);
-
-      { do we need to handle exceptions because of ansi/widestrings ? }
-      if not inlined and
-         ((procinfo^.flags and pi_needs_implicit_finally)<>0) and
-      { but it's useless in init/final code of units }
-        not(aktprocdef.proctypeoption in [potype_unitfinalize,potype_unitinit]) then
-        begin
-           { the exception helper routines modify all registers }
-           aktprocdef.usedregisters:=all_registers;
-
-           getlabel(noreraiselabel);
-           emitcall('FPC_POPADDRSTACK');
-           exprasmList.concat(Tairegalloc.Alloc(R_EAX));
-           exprasmList.concat(Taicpu.op_reg(A_POP,S_L,R_EAX));
-           exprasmList.concat(Taicpu.op_reg_reg(A_TEST,S_L,R_EAX,R_EAX));
-           rg.ungetregisterint(exprasmlist,R_EAX);
-           emitjmp(C_E,noreraiselabel);
-           if (aktprocdef.proctypeoption=potype_constructor) then
-             begin
-                if assigned(procinfo^._class) then
-                  begin
-                     pd:=procinfo^._class.searchdestructor;
-                     if assigned(pd) then
-                       begin
-                          getlabel(nodestroycall);
-                          reference_reset_base(hr,procinfo^.framepointer,procinfo^.selfpointer_offset);
-                          emit_const_ref(A_CMP,S_L,0,hr);
-                          emitjmp(C_E,nodestroycall);
-                          if is_class(procinfo^._class) then
-                            begin
-                               emit_const(A_PUSH,S_L,1);
-                               emit_reg(A_PUSH,S_L,R_ESI);
-                            end
-                          else if is_object(procinfo^._class) then
-                            begin
-                               emit_reg(A_PUSH,S_L,R_ESI);
-                               emit_sym(A_PUSH,S_L,newasmsymbol(procinfo^._class.vmt_mangledname));
-                            end
-                          else
-                            begin
-                              Internalerror(200006161);
-                            end;
-                          if (po_virtualmethod in pd.procoptions) then
-                            begin
-                               reference_reset_base(hr,R_ESI,0);
-                               emit_ref_reg(A_MOV,S_L,hr,R_EDI);
-                               reference_reset_base(hr,R_EDI,procinfo^._class.vmtmethodoffset(pd.extnumber));
-                               emit_ref(A_CALL,S_NO,hr);
-                            end
-                          else
-                            emitcall(pd.mangledname);
-                          { not necessary because the result is never assigned in the
-                            case of an exception (FK)
-                          emit_const_reg(A_MOV,S_L,0,R_ESI);
-                          emit_const_ref(A_MOV,S_L,0,reference_reset_base(procinfo^.framepointer,8));
-                          }
-                          emitlab(nodestroycall);
-                       end;
-                  end
-             end
-           else
-           { must be the return value finalized before reraising the exception? }
-           if (not is_void(aktprocdef.rettype.def)) and
-             (aktprocdef.rettype.def.needs_inittable) and
-             ((aktprocdef.rettype.def.deftype<>objectdef) or
-              not is_class(aktprocdef.rettype.def)) then
-             begin
-                reference_reset_base(hr,procinfo^.framepointer,procinfo^.return_offset);
-                cg.g_finalize(exprasmlist,aktprocdef.rettype.def,hr,ret_in_param(aktprocdef.rettype.def));
-             end;
-
-           emitcall('FPC_RERAISE');
-           emitlab(noreraiselabel);
-        end;
-
-      { call __EXIT for main program }
-      if (not DLLsource) and (not inlined) and (aktprocdef.proctypeoption=potype_proginit) then
-       begin
-         emitcall('FPC_DO_EXIT');
-       end;
-
-      { handle return value, this is not done for assembler routines when
-        they didn't reference the result variable }
-      uses_eax:=false;
-      uses_edx:=false;
-      uses_esi:=false;
-      if not(po_assembler in aktprocdef.procoptions) or
-         (assigned(aktprocdef.funcretsym) and
-          (tfuncretsym(aktprocdef.funcretsym).refcount>1)) then
-        begin
-          if (aktprocdef.proctypeoption<>potype_constructor) then
-            handle_return_value(inlined,uses_eax,uses_edx)
-          else
-            begin
-                { successful constructor deletes the zero flag }
-                { and returns self in eax                   }
-                { eax must be set to zero if the allocation failed !!! }
-                getlabel(okexitlabel);
-                emitjmp(C_NONE,okexitlabel);
-                emitlab(faillabel);
-                if is_class(procinfo^._class) then
-                  begin
-                    reference_reset_base(hr,procinfo^.framepointer,8);
-                    emit_ref_reg(A_MOV,S_L,hr,R_ESI);
-                    emitcall('FPC_HELP_FAIL_CLASS');
-                  end
-                else if is_object(procinfo^._class) then
-                  begin
-                    reference_reset_base(hr,procinfo^.framepointer,12);
-                    emit_ref_reg(A_MOV,S_L,hr,R_ESI);
-                    rg.getexplicitregisterint(exprasmlist,R_EDI);
-                    emit_const_reg(A_MOV,S_L,procinfo^._class.vmt_offset,R_EDI);
-                    emitcall('FPC_HELP_FAIL');
-                    rg.ungetregisterint(exprasmlist,R_EDI);
-                  end
-                else
-                  Internalerror(200006161);
-
-              emitlab(okexitlabel);
-
-              { for classes this is done after the call to }
-              { AfterConstruction                          }
-              if is_object(procinfo^._class) then
-                begin
-                  exprasmList.concat(Tairegalloc.Alloc(R_EAX));
-                  emit_reg_reg(A_MOV,S_L,R_ESI,R_EAX);
-                  uses_eax:=true;
-                end;
-              emit_reg_reg(A_TEST,S_L,R_ESI,R_ESI);
-              uses_esi:=true;
-            end;
-        end;
-
-      if aktexit2label.is_used and not aktexit2label.is_set then
-        emitlab(aktexit2label);
-
-      if ((cs_debuginfo in aktmoduleswitches) and not inlined) then
-        begin
-          getlabel(stabsendlabel);
-          emitlab(stabsendlabel);
-        end;
-      { gives problems for long mangled names }
-      {List.concat(Tai_symbol.Create(aktprocdef.mangledname+'_end'));}
-
-      { should we restore edi ? }
-      { for all i386 gcc implementations }
-      if (po_savestdregs in aktprocdef.procoptions) then
-        begin
-          if (R_EBX in aktprocdef.usedregisters) then
-           exprasmList.concat(Taicpu.Op_reg(A_POP,S_L,R_EBX));
-          exprasmList.concat(Taicpu.Op_reg(A_POP,S_L,R_ESI));
-          exprasmList.concat(Taicpu.Op_reg(A_POP,S_L,R_EDI));
-          { here we could reset R_EBX
-            but that is risky because it only works
-            if genexitcode is called after genentrycode
-            so lets skip this for the moment PM
-          aktprocdef.usedregisters:=
-            aktprocdef.usedregisters or not ($80 shr byte(R_EBX));
-          }
-        end;
-
-      { for the save all registers we can simply use a pusha,popa which
-        push edi,esi,ebp,esp(ignored),ebx,edx,ecx,eax }
-      if (po_saveregisters in aktprocdef.procoptions) then
-        begin
-          if uses_esi then
-           begin
-             reference_reset_base(hr,R_ESP,4);
-             exprasmList.concat(Taicpu.Op_reg_ref(A_MOV,S_L,R_ESI,hr));
-           end;
-          if uses_edx then
-           begin
-             reference_reset_base(hr,R_ESP,20);
-             exprasmList.concat(Taicpu.Op_reg_ref(A_MOV,S_L,R_EDX,hr));
-           end;
-          if uses_eax then
-           begin
-             reference_reset_base(hr,R_ESP,28);
-             exprasmList.concat(Taicpu.Op_reg_ref(A_MOV,S_L,R_EAX,hr));
-           end;
-          exprasmList.concat(Taicpu.Op_none(A_POPA,S_L));
-          { We add a NOP because of the 386DX CPU bugs with POPAD }
-          exprasmlist.concat(taicpu.op_none(A_NOP,S_L));
-        end;
-      if not(nostackframe) then
-        begin
-          if not inlined then
-            exprasmList.concat(Taicpu.Op_none(A_LEAVE,S_NO));
-        end
-      else
-        begin
-          if (tg.gettempsize<>0) and not inlined then
-            exprasmList.insert(Taicpu.op_const_reg(A_ADD,S_L,tg.gettempsize,R_ESP));
-        end;
-
-      { parameters are limited to 65535 bytes because }
-      { ret allows only imm16                    }
-      if (parasize>65535) and not(po_clearstack in aktprocdef.procoptions) then
-       CGMessage(cg_e_parasize_too_big);
-
-      { at last, the return is generated }
-
-      if not inlined then
-      if (po_interrupt in aktprocdef.procoptions) then
-          begin
-             if uses_esi then
-              begin
-                reference_reset_base(hr,R_ESP,16);
-                exprasmList.concat(Taicpu.Op_reg_ref(A_MOV,S_L,R_ESI,hr));
-              end;
-             if uses_edx then
-               begin
-                 reference_reset_base(hr,R_ESP,12);
-                 exprasmList.concat(Tairegalloc.Alloc(R_EAX));
-                 exprasmList.concat(Taicpu.Op_reg_ref(A_MOV,S_L,R_EDX,hr));
-               end;
-             if uses_eax then
-               begin
-                 reference_reset_base(hr,R_ESP,0);
-                 exprasmList.concat(Tairegalloc.Alloc(R_EAX));
-                 exprasmList.concat(Taicpu.Op_reg_ref(A_MOV,S_L,R_EAX,hr));
-               end;
-             generate_interrupt_stackframe_exit;
-          end
-      else
-       begin
-       {Routines with the poclearstack flag set use only a ret.}
-       { also routines with parasize=0     }
-         if (po_clearstack in aktprocdef.procoptions) then
-           begin
-{$ifndef OLD_C_STACK}
-             { complex return values are removed from stack in C code PM }
-             if ret_in_param(aktprocdef.rettype.def) then
-               exprasmList.concat(Taicpu.Op_const(A_RET,S_NO,4))
-             else
-{$endif not OLD_C_STACK}
-               exprasmList.concat(Taicpu.Op_none(A_RET,S_NO));
-           end
-         else if (parasize=0) then
-          exprasmList.concat(Taicpu.Op_none(A_RET,S_NO))
-         else
-          exprasmList.concat(Taicpu.Op_const(A_RET,S_NO,parasize));
-       end;
-
-      if not inlined then
-        exprasmList.concat(Tai_symbol_end.Createname(aktprocdef.mangledname));
-
-{$ifdef GDB}
-      if (cs_debuginfo in aktmoduleswitches) and not inlined  then
-          begin
-              aktprocdef.concatstabto(exprasmlist);
-              if assigned(procinfo^._class) then
-                if (not assigned(procinfo^.parent) or
-                   not assigned(procinfo^.parent^._class)) then
-                  begin
-                    if (po_classmethod in aktprocdef.procoptions) or
-                       ((po_virtualmethod in aktprocdef.procoptions) and
-                        (potype_constructor=aktprocdef.proctypeoption)) or
-                       (po_staticmethod in aktprocdef.procoptions) then
-                      begin
-                        exprasmList.concat(Tai_stabs.Create(strpnew(
-                         '"pvmt:p'+tstoreddef(pvmttype.def).numberstring+'",'+
-                         tostr(N_tsym)+',0,0,'+tostr(procinfo^.selfpointer_offset))));
-                      end
-                    else
-                      begin
-                        if not(is_class(procinfo^._class)) then
-                          st:='v'
-                        else
-                          st:='p';
-                        exprasmList.concat(Tai_stabs.Create(strpnew(
-                         '"$t:'+st+procinfo^._class.numberstring+'",'+
-                         tostr(N_tsym)+',0,0,'+tostr(procinfo^.selfpointer_offset))));
-                      end;
-                  end
-                else
-                  begin
-                    if not is_class(procinfo^._class) then
-                      st:='*'
-                    else
-                      st:='';
-                    exprasmList.concat(Tai_stabs.Create(strpnew(
-                     '"$t:r'+st+procinfo^._class.numberstring+'",'+
-                     tostr(N_RSYM)+',0,0,'+tostr(GDB_i386index[R_ESI]))));
-                  end;
-
-              { define calling EBP as pseudo local var PM }
-              { this enables test if the function is a local one !! }
-              if  assigned(procinfo^.parent) and (lexlevel>normal_function_level) then
-                exprasmList.concat(Tai_stabs.Create(strpnew(
-                 '"parent_ebp:'+tstoreddef(voidpointertype.def).numberstring+'",'+
-                 tostr(N_LSYM)+',0,0,'+tostr(procinfo^.framepointer_offset))));
-
-              if (not is_void(aktprocdef.rettype.def)) then
-                begin
-                  if ret_in_param(aktprocdef.rettype.def) then
-                    exprasmList.concat(Tai_stabs.Create(strpnew(
-                     '"'+aktprocsym.name+':X*'+tstoreddef(aktprocdef.rettype.def).numberstring+'",'+
-                     tostr(N_tsym)+',0,0,'+tostr(procinfo^.return_offset))))
-                  else
-                    exprasmList.concat(Tai_stabs.Create(strpnew(
-                     '"'+aktprocsym.name+':X'+tstoreddef(aktprocdef.rettype.def).numberstring+'",'+
-                     tostr(N_tsym)+',0,0,'+tostr(procinfo^.return_offset))));
-                  if (m_result in aktmodeswitches) then
-                    if ret_in_param(aktprocdef.rettype.def) then
-                      exprasmList.concat(Tai_stabs.Create(strpnew(
-                       '"RESULT:X*'+tstoreddef(aktprocdef.rettype.def).numberstring+'",'+
-                       tostr(N_tsym)+',0,0,'+tostr(procinfo^.return_offset))))
-                    else
-                      exprasmList.concat(Tai_stabs.Create(strpnew(
-                       '"RESULT:X'+tstoreddef(aktprocdef.rettype.def).numberstring+'",'+
-                       tostr(N_tsym)+',0,0,'+tostr(procinfo^.return_offset))));
-                end;
-              mangled_length:=length(aktprocdef.mangledname);
-              getmem(p,2*mangled_length+50);
-              strpcopy(p,'192,0,0,');
-              strpcopy(strend(p),aktprocdef.mangledname);
-              if (target_info.use_function_relative_addresses) then
-                begin
-                  strpcopy(strend(p),'-');
-                  strpcopy(strend(p),aktprocdef.mangledname);
-                end;
-              exprasmList.concat(Tai_stabn.Create(strnew(p)));
-              {List.concat(Tai_stabn.Create(strpnew('192,0,0,'
-               +aktprocdef.mangledname))));
-              p[0]:='2';p[1]:='2';p[2]:='4';
-              strpcopy(strend(p),'_end');}
-              strpcopy(p,'224,0,0,'+stabsendlabel.name);
-              if (target_info.use_function_relative_addresses) then
-                begin
-                  strpcopy(strend(p),'-');
-                  strpcopy(strend(p),aktprocdef.mangledname);
-                end;
-              exprasmList.concatlist(withdebuglist);
-              exprasmList.concat(Tai_stabn.Create(strnew(p)));
-               { strpnew('224,0,0,'
-               +aktprocdef.mangledname+'_end'))));}
-              freemem(p,2*mangled_length+50);
-          end;
-{$endif GDB}
-       if inlined then
-         cleanup_regvars(exprasmlist);
-      exprasmlist:=oldexprasmlist;
-  end;
-
-    procedure genimplicitunitfinal(alist : TAAsmoutput);
-
-      begin
-         { using current_module.globalsymtable is hopefully      }
-         { more robust than symtablestack and symtablestack.next }
-         tsymtable(current_module.globalsymtable).foreach_static({$ifndef TP}@{$endif}finalize_data);
-         tsymtable(current_module.localsymtable).foreach_static({$ifndef TP}@{$endif}finalize_data);
-         exprasmList.insert(Tai_symbol.Createname_global('FINALIZE$$'+current_module.modulename^,0));
-         exprasmList.insert(Tai_symbol.Createname_global(target_info.cprefix+current_module.modulename^+'_finalize',0));
-{$ifdef GDB}
-         if (cs_debuginfo in aktmoduleswitches) and
-           target_info.use_function_relative_addresses then
-           exprasmList.insert(Tai_stab_function_name.Create(strpnew('FINALIZE$$'+current_module.modulename^)));
-{$endif GDB}
-         exprasmList.concat(Taicpu.Op_none(A_RET,S_NO));
-         aList.concatlist(exprasmlist);
-      end;
-
-    procedure genimplicitunitinit(alist : TAAsmoutput);
-
-      begin
-         { using current_module.globalsymtable is hopefully      }
-         { more robust than symtablestack and symtablestack.next }
-         tsymtable(current_module.globalsymtable).foreach_static({$ifndef TP}@{$endif}finalize_data);
-         tsymtable(current_module.localsymtable).foreach_static({$ifndef TP}@{$endif}finalize_data);
-         exprasmList.insert(Tai_symbol.Createname_global('INIT$$'+current_module.modulename^,0));
-         exprasmList.insert(Tai_symbol.Createname_global(target_info.cprefix+current_module.modulename^+'_init',0));
-{$ifdef GDB}
-         if (cs_debuginfo in aktmoduleswitches) and
-           target_info.use_function_relative_addresses then
-           exprasmList.insert(Tai_stab_function_name.Create(strpnew('INIT$$'+current_module.modulename^)));
-{$endif GDB}
-         exprasmList.concat(Taicpu.Op_none(A_RET,S_NO));
-         aList.concatlist(exprasmlist);
-      end;
-
-{$ifdef test_dest_loc}
-       procedure mov_reg_to_dest(p : ptree; s : topsize; reg : tregister);
-
-         begin
-            if (dest_loc.loc=LOC_CREGISTER) or (dest_loc.loc=LOC_REGISTER) then
-              begin
-                emit_reg_reg(A_MOV,s,reg,dest_loc.register);
-                set_location(p^.location,dest_loc);
-                in_dest_loc:=true;
-              end
-            else
-            if (dest_loc.loc=LOC_REFERENCE) or (dest_loc.loc=LOC_CREFERENCE) then
-              begin
-                exprasmList.concat(Taicpu.Op_reg_ref(A_MOV,s,reg,dest_loc.reference));
-                set_location(p^.location,dest_loc);
-                in_dest_loc:=true;
-              end
-            else
-              internalerror(20080);
-         end;
-
-{$endif test_dest_loc}
-{$ifdef __NOWINPECOFF__}
- {$undef __NOWINPECOFF__}
-{$endif}
-
 end.
 {
   $Log$
-  Revision 1.27  2002-04-25 20:16:39  peter
+  Revision 1.28  2002-05-12 16:53:16  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.27  2002/04/25 20:16:39  peter
     * moved more routines from cga/n386util
 
   Revision 1.26  2002/04/21 15:29:53  carl

compiler/i386/cpuasm.pas

@@ -46,7 +46,7 @@ uses
 
 const
   MaxPrefixes=4;
-  
+
 {*****************************************************************************
                               Instruction table
 *****************************************************************************}
@@ -147,7 +147,7 @@ type
      procedure Swatoperands;
 {$endif NOAG386BIN}
   end;
-  
+
   procedure InitAsm;
   procedure DoneAsm;
 
@@ -159,23 +159,6 @@ uses
   ogbase,
   ag386att;
 
-const  
-{ Convert reg to operand type }
-  reg_2_type:array[firstreg..lastreg] of longint = (OT_NONE,
-    OT_REG_EAX,OT_REG_ECX,OT_REG32,OT_REG32,OT_REG32,OT_REG32,OT_REG32,OT_REG32,
-    OT_REG_AX,OT_REG_CX,OT_REG_DX,OT_REG16,OT_REG16,OT_REG16,OT_REG16,OT_REG16,
-    OT_REG_AL,OT_REG_CL,OT_REG8,OT_REG8,OT_REG8,OT_REG8,OT_REG8,OT_REG8,
-    OT_REG_CS,OT_REG_DESS,OT_REG_DESS,OT_REG_DESS,OT_REG_FSGS,OT_REG_FSGS,
-    OT_FPU0,OT_FPU0,OT_FPUREG,OT_FPUREG,OT_FPUREG,OT_FPUREG,OT_FPUREG,OT_FPUREG,OT_FPUREG,
-    OT_REG_DREG,OT_REG_DREG,OT_REG_DREG,OT_REG_DREG,OT_REG_DREG,OT_REG_DREG,
-    OT_REG_CREG,OT_REG_CREG,OT_REG_CREG,OT_REG_CR4,
-    OT_REG_TREG,OT_REG_TREG,OT_REG_TREG,OT_REG_TREG,OT_REG_TREG,
-    OT_MMXREG,OT_MMXREG,OT_MMXREG,OT_MMXREG,OT_MMXREG,OT_MMXREG,OT_MMXREG,OT_MMXREG,
-    OT_XMMREG,OT_XMMREG,OT_XMMREG,OT_XMMREG,OT_XMMREG,OT_XMMREG,OT_XMMREG,OT_XMMREG
-  );
-  
-
-
 {****************************************************************************
                               TAI_ALIGN
  ****************************************************************************}
@@ -1680,7 +1663,24 @@ end;
 end.
 {
   $Log$
-  Revision 1.20  2002-04-15 19:44:20  peter
+  Revision 1.21  2002-05-12 16:53:16  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.20  2002/04/15 19:44:20  peter
     * fixed stackcheck that would be called recursively when a stack
       error was found
     * generic changeregsize(reg,size) for i386 register resizing

compiler/i386/cpubase.pas

@@ -465,10 +465,10 @@ type
 
 const
   general_registers = [R_EAX,R_EBX,R_ECX,R_EDX];
-  
-  {# Table of registers which can be allocated by the code generator       
-     internally, when generating the code.                             
-  }   
+
+  {# Table of registers which can be allocated by the code generator
+     internally, when generating the code.
+  }
   { legend:                                                                }
   { xxxregs = set of all possibly used registers of that type in the code  }
   {           generator                                                    }
@@ -504,7 +504,7 @@ const
     LOC_CREGISTER,LOC_MMXREGISTER,LOC_CMMXREGISTER];
 
 {*****************************************************************************
-                          Default generic sizes 
+                          Default generic sizes
 *****************************************************************************}
    {# Defines the default address size for a processor, }
    OS_ADDR = OS_32;
@@ -523,10 +523,10 @@ const
   stack_pointer_reg = R_ESP;
   {# Frame pointer register }
   frame_pointer_reg = R_EBP;
-  {# Self pointer register : contains the instance address of an 
+  {# Self pointer register : contains the instance address of an
      object or class. }
   self_pointer_reg  = R_ESI;
-  {# Register for addressing absolute data in a position independant way, 
+  {# Register for addressing absolute data in a position independant way,
      such as in PIC code. The exact meaning is ABI specific }
   pic_offset_reg = R_EBX;
   {# Results are returned in this register (32-bit values) }
@@ -538,12 +538,12 @@ const
   fpuresultreg = R_ST;
   mmresultreg = R_MM0;
 
-  {# Registers which are defined as scratch and no need to save across 
+  {# Registers which are defined as scratch and no need to save across
      routine calls or in assembler blocks.
   }
   scratch_regs : array[1..1] of tregister = (R_EDI);
 
-  
+
 
 {*****************************************************************************
                        GCC /ABI linking information
@@ -552,20 +552,20 @@ const
   {# Registers which must be saved when calling a routine declared as
      cppdecl, cdecl, stdcall, safecall, palmossyscall. The registers
      saved should be the ones as defined in the target ABI and / or GCC.
-     
+
      This value can be deduced from the CALLED_USED_REGISTERS array in the
      GCC source.
   }
   std_saved_registers = [R_ESI,R_EDI,R_EBX];
   {# Required parameter alignment when calling a routine declared as
      stdcall and cdecl. The alignment value should be the one defined
-     by GCC or the target ABI. 
-     
-     The value of this constant is equal to the constant 
+     by GCC or the target ABI.
+
+     The value of this constant is equal to the constant
      PARM_BOUNDARY / BITS_PER_UNIT in the GCC source.
-  }     
+  }
   std_param_align = 4;
-  
+
 
 
 
@@ -593,11 +593,10 @@ const
 
 implementation
 
-  uses
 {$ifdef heaptrc}
-      ppheap,
+  uses
+      ppheap;
 {$endif heaptrc}
-      verbose;
 
 
 {*****************************************************************************
@@ -640,7 +639,24 @@ implementation
 end.
 {
   $Log$
-  Revision 1.18  2002-04-21 15:31:40  carl
+  Revision 1.19  2002-05-12 16:53:16  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.18  2002/04/21 15:31:40  carl
   - removed some other stuff to their units
 
   Revision 1.17  2002/04/20 21:37:07  carl

compiler/i386/cputarg.pas

@@ -69,7 +69,6 @@ implementation
 **************************************}
 
     {$ifndef NOAG386ATT}
-      ,aggas
       ,ag386att
     {$endif}
     {$ifndef NOAG386NSM}
@@ -86,7 +85,24 @@ implementation
 end.
 {
   $Log$
-  Revision 1.5  2002-04-14 17:00:49  carl
+  Revision 1.6  2002-05-12 16:53:16  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.5  2002/04/14 17:00:49  carl
   + att_reg2str -> gas_reg2str
 
   Revision 1.4  2002/04/04 18:31:37  carl

compiler/i386/daopt386.pas

@@ -226,7 +226,7 @@ Var
 Implementation
 
 Uses
-  globals, systems, verbose, cgbase, symconst, symsym, tainst, cginfo, cgobj, 
+  globals, systems, verbose, cgbase, symconst, symsym, tainst, cginfo, cgobj,
    rgobj;
 
 Type
@@ -776,9 +776,9 @@ var p: Taicpu;
 begin
   RegReadByInstruction := false;
   reg := reg32(reg);
-  p := Taicpu(hp);
   if hp.typ <> ait_instruction then
     exit;
+  p := Taicpu(hp);
   case p.opcode of
     A_IMUL:
       case p.ops of
@@ -844,9 +844,9 @@ var p: Taicpu;
 begin
   reg := reg32(reg);
   regInInstruction := false;
-  p := Taicpu(p1);
   if p1.typ <> ait_instruction then
     exit;
+  p := Taicpu(p1);
   case p.opcode of
     A_IMUL:
       case p.ops of
@@ -1112,10 +1112,14 @@ function regLoadedWithNewValue(reg: tregister; canDependOnPrevValue: boolean;
 { assumes reg is a 32bit register }
 var p: Taicpu;
 begin
+  if not assigned(hp) or
+     (hp.typ <> ait_instruction) then
+   begin
+     regLoadedWithNewValue := false;
+     exit;
+   end;
   p := Taicpu(hp);
   regLoadedWithNewValue :=
-    assigned(hp) and
-    (hp.typ = ait_instruction) and
     (((p.opcode = A_MOV) or
       (p.opcode = A_MOVZX) or
       (p.opcode = A_MOVSX) or
@@ -2587,7 +2591,24 @@ End.
 
 {
   $Log$
-  Revision 1.33  2002-04-21 15:32:59  carl
+  Revision 1.34  2002-05-12 16:53:16  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.33  2002/04/21 15:32:59  carl
   * changeregsize -> rg.makeregsize
 
   Revision 1.32  2002/04/20 21:37:07  carl

compiler/i386/n386add.pas

@@ -154,7 +154,7 @@ interface
               { maybe we can reuse a constant register when the
                 operation is a comparison that doesn't change the
                 value of the register }
-              location_force_reg(left.location,opsize_2_cgsize[opsize],(nodetype in [ltn,lten,gtn,gten,equaln,unequaln]));
+              location_force_reg(exprasmlist,left.location,opsize_2_cgsize[opsize],(nodetype in [ltn,lten,gtn,gten,equaln,unequaln]));
             end;
           end;
        end;
@@ -294,8 +294,8 @@ interface
                emitjmp(C_NB,hl4)
               else
                emitjmp(C_NO,hl4);
-              emitcall('FPC_OVERFLOW');
-              emitlab(hl4);
+              cg.a_call_name(exprasmlist,'FPC_OVERFLOW');
+              cg.a_label(exprasmlist,hl4);
             end;
          end;
       end;
@@ -380,17 +380,17 @@ interface
                         remove_non_regvars_from_loc(right.location,regstopush);
                         rg.saveusedregisters(exprasmlist,pushedregs,regstopush);
                         { push the maximum possible length of the result }
-                        emitpushreferenceaddr(left.location.reference);
+                        cg.a_paramaddr_ref(exprasmlist,left.location.reference,2);
                         { the optimizer can more easily put the          }
                         { deallocations in the right place if it happens }
                         { too early than when it happens too late (if    }
                         { the pushref needs a "lea (..),edi; push edi")  }
                         location_release(exprasmlist,right.location);
-                        emitpushreferenceaddr(right.location.reference);
+                        cg.a_paramaddr_ref(exprasmlist,right.location.reference,1);
                         rg.saveregvars(exprasmlist,regstopush);
-                        emitcall('FPC_SHORTSTR_CONCAT');
+                        cg.a_call_name(exprasmlist,'FPC_SHORTSTR_CONCAT');
                         tg.ungetiftemp(exprasmlist,right.location.reference);
-                        maybe_loadself;
+                        cg.g_maybe_loadself(exprasmlist);
                         rg.restoreusedregisters(exprasmlist,pushedregs);
                         location_copy(location,left.location);
                      end;
@@ -400,13 +400,13 @@ interface
                        rg.saveusedregisters(exprasmlist,pushedregs,all_registers);
                        secondpass(left);
                        location_release(exprasmlist,left.location);
-                       emitpushreferenceaddr(left.location.reference);
+                       cg.a_paramaddr_ref(exprasmlist,left.location.reference,2);
                        secondpass(right);
                        location_release(exprasmlist,right.location);
-                       emitpushreferenceaddr(right.location.reference);
+                       cg.a_paramaddr_ref(exprasmlist,right.location.reference,1);
                        rg.saveregvars(exprasmlist,all_registers);
-                       emitcall('FPC_SHORTSTR_COMPARE');
-                       maybe_loadself;
+                       cg.a_call_name(exprasmlist,'FPC_SHORTSTR_COMPARE');
+                       cg.g_maybe_loadself(exprasmlist);
                        rg.restoreusedregisters(exprasmlist,pushedregs);
                        location_freetemp(exprasmlist,left.location);
                        location_freetemp(exprasmlist,right.location);
@@ -463,7 +463,7 @@ interface
               end;
             secondpass(left);
             if left.location.loc in [LOC_FLAGS,LOC_JUMP] then
-             location_force_reg(left.location,opsize_2_cgsize[opsize],false);
+             location_force_reg(exprasmlist,left.location,opsize_2_cgsize[opsize],false);
             if isjump then
              begin
                truelabel:=otl;
@@ -483,7 +483,7 @@ interface
             if pushed then
              restore(left,false);
             if right.location.loc in [LOC_FLAGS,LOC_JUMP] then
-             location_force_reg(right.location,opsize_2_cgsize[opsize],false);
+             location_force_reg(exprasmlist,right.location,opsize_2_cgsize[opsize],false);
             if isjump then
              begin
                truelabel:=otl;
@@ -532,8 +532,8 @@ interface
                         otl:=truelabel;
                         getlabel(truelabel);
                         secondpass(left);
-                        maketojumpbool(left,lr_load_regvars);
-                        emitlab(truelabel);
+                        maketojumpbool(exprasmlist,left,lr_load_regvars);
+                        cg.a_label(exprasmlist,truelabel);
                         truelabel:=otl;
                      end;
                    orn :
@@ -541,15 +541,15 @@ interface
                         ofl:=falselabel;
                         getlabel(falselabel);
                         secondpass(left);
-                        maketojumpbool(left,lr_load_regvars);
-                        emitlab(falselabel);
+                        maketojumpbool(exprasmlist,left,lr_load_regvars);
+                        cg.a_label(exprasmlist,falselabel);
                         falselabel:=ofl;
                      end;
                    else
                      CGMessage(type_e_mismatch);
                  end;
                  secondpass(right);
-                 maketojumpbool(right,lr_load_regvars);
+                 maketojumpbool(exprasmlist,right,lr_load_regvars);
                end;
              else
                CGMessage(type_e_mismatch);
@@ -642,7 +642,7 @@ interface
           end;
         { to avoid the pentium bug
         if (op=FDIVP) and (opt_processors=pentium) then
-          emitcall('EMUL_FDIVP')
+          cg.a_call_name(exprasmlist,'EMUL_FDIVP')
         else
         }
         { the Intel assemblers want operands }
@@ -748,8 +748,8 @@ interface
                  if assigned(tsetelementnode(right).right) then
                   internalerror(43244);
                  { bts requires both elements to be registers }
-                 location_force_reg(left.location,opsize_2_cgsize[opsize],false);
-                 location_force_reg(right.location,opsize_2_cgsize[opsize],true);
+                 location_force_reg(exprasmlist,left.location,opsize_2_cgsize[opsize],false);
+                 location_force_reg(exprasmlist,right.location,opsize_2_cgsize[opsize],true);
                  op:=A_BTS;
                  noswap:=true;
                end
@@ -785,7 +785,7 @@ interface
                  ((nf_swaped in flags) and
                   (nodetype = gten)) then
                 swapleftright;
-              location_force_reg(left.location,opsize_2_cgsize[opsize],true);
+              location_force_reg(exprasmlist,left.location,opsize_2_cgsize[opsize],true);
               emit_op_right_left(A_AND,opsize);
               op:=A_CMP;
               cmpop:=true;
@@ -886,17 +886,17 @@ interface
                    { the comparisaion of the low dword have to be }
                    {  always unsigned!                            }
                    emitjmp(flags_to_cond(getresflags(true)),truelabel);
-                   emitjmp(C_None,falselabel);
+                   cg.a_jmp_always(exprasmlist,falselabel);
                 end;
               equaln:
                 begin
                    emitjmp(C_NE,falselabel);
-                   emitjmp(C_None,truelabel);
+                   cg.a_jmp_always(exprasmlist,truelabel);
                 end;
               unequaln:
                 begin
                    emitjmp(C_NE,truelabel);
-                   emitjmp(C_None,falselabel);
+                   cg.a_jmp_always(exprasmlist,falselabel);
                 end;
            end;
         end;
@@ -1045,7 +1045,7 @@ interface
                     firstjmp64bitcmp;
                     emit_ref_reg(A_CMP,S_L,right.location.reference,left.location.registerlow);
                     secondjmp64bitcmp;
-                    emitjmp(C_None,falselabel);
+                    cg.a_jmp_always(exprasmlist,falselabel);
                     location_freetemp(exprasmlist,right.location);
                     location_release(exprasmlist,right.location);
                   end;
@@ -1092,8 +1092,8 @@ interface
                emitjmp(C_NB,hl4)
               else
                emitjmp(C_NO,hl4);
-              emitcall('FPC_OVERFLOW');
-              emitlab(hl4);
+              cg.a_call_name(exprasmlist,'FPC_OVERFLOW');
+              cg.a_label(exprasmlist,hl4);
             end;
          end;
 
@@ -1457,8 +1457,8 @@ interface
                    { constant (JM)                             }
                    location_release(exprasmlist,right.location);
                    location.register:=rg.getregisterint(exprasmlist);
-                   emitloadord2reg(right.location,torddef(u32bittype.def),location.register,false);
-                   emit_const_reg(A_SHL,S_L,power,location.register)
+                   cg.a_load_loc_reg(exprasmlist,right.location,location.register);
+                   cg.a_op_const_reg(exprasmlist,OP_SHL,power,location.register);
                  End
                Else
                 Begin
@@ -1485,13 +1485,13 @@ interface
                   { left.location can be R_EAX !!! }
                   rg.getexplicitregisterint(exprasmlist,R_EDI);
                   { load the left value }
-                  emitloadord2reg(left.location,torddef(u32bittype.def),R_EDI,true);
+                  cg.a_load_loc_reg(exprasmlist,left.location,R_EDI);
                   location_release(exprasmlist,left.location);
                   { allocate EAX }
                   if R_EAX in rg.unusedregsint then
                     exprasmList.concat(Tairegalloc.Alloc(R_EAX));
                   { load he right value }
-                  emitloadord2reg(right.location,torddef(u32bittype.def),R_EAX,true);
+                  cg.a_load_loc_reg(exprasmlist,right.location,R_EAX);
                   location_release(exprasmlist,right.location);
                   { allocate EAX if it isn't yet allocated (JM) }
                   if (R_EAX in rg.unusedregsint) then
@@ -1522,9 +1522,9 @@ interface
 
             { Convert flags to register first }
             if (left.location.loc=LOC_FLAGS) then
-             location_force_reg(left.location,opsize_2_cgsize[opsize],false);
+             location_force_reg(exprasmlist,left.location,opsize_2_cgsize[opsize],false);
             if (right.location.loc=LOC_FLAGS) then
-             location_force_reg(right.location,opsize_2_cgsize[opsize],false);
+             location_force_reg(exprasmlist,right.location,opsize_2_cgsize[opsize],false);
 
             left_must_be_reg(opsize,false);
             emit_generic_code(op,opsize,unsigned,extra_not,mboverflow);
@@ -1574,7 +1574,24 @@ begin
 end.
 {
   $Log$
-  Revision 1.34  2002-04-25 20:16:40  peter
+  Revision 1.35  2002-05-12 16:53:17  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.34  2002/04/25 20:16:40  peter
     * moved more routines from cga/n386util
 
   Revision 1.33  2002/04/05 15:09:13  jonas

compiler/i386/n386cal.pas

@@ -89,6 +89,7 @@ implementation
          otlabel,oflabel : tasmlabel;
          { temporary variables: }
          tempdeftype : tdeftype;
+         tmpreg : tregister;
          href   : treference;
 
       begin
@@ -118,7 +119,7 @@ implementation
              if push_addr_param(left.resulttype.def) then
                begin
                  inc(pushedparasize,4);
-                 emitpushreferenceaddr(left.location.reference);
+                 cg.a_paramaddr_ref(exprasmlist,left.location.reference,-1);
                  location_release(exprasmlist,left.location);
                end
              else
@@ -136,22 +137,21 @@ implementation
               { allow passing of a constant to a const formaldef }
               if (defcoll.paratyp=vs_const) and
                  (left.location.loc=LOC_CONSTANT) then
-                location_force_mem(left.location);
+                location_force_mem(exprasmlist,left.location);
 
               { allow @var }
               inc(pushedparasize,4);
               if (left.nodetype=addrn) and
                  (not(nf_procvarload in left.flags)) then
                 begin
-                { always a register }
                   if inlined then
                     begin
                        reference_reset_base(href,procinfo^.framepointer,para_offset-pushedparasize);
-                       emit_reg_ref(A_MOV,S_L,left.location.register,href);
+                       cg.a_load_loc_ref(exprasmlist,left.location,href);
                     end
                   else
-                    emit_reg(A_PUSH,S_L,left.location.register);
-                  rg.ungetregisterint(exprasmlist,left.location.register);
+                    cg.a_param_loc(exprasmlist,left.location,-1);
+                  location_release(exprasmlist,left.location);
                 end
               else
                 begin
@@ -161,11 +161,11 @@ implementation
                      begin
                        if inlined then
                          begin
-                           rg.getexplicitregisterint(exprasmlist,R_EDI);
-                           emit_ref_reg(A_LEA,S_L,left.location.reference,R_EDI);
+                           tmpreg:=cg.get_scratch_reg(exprasmlist);
+                           cg.a_loadaddr_ref_reg(exprasmlist,left.location.reference,tmpreg);
                            reference_reset_base(href,procinfo^.framepointer,para_offset-pushedparasize);
-                           emit_reg_ref(A_MOV,S_L,R_EDI,href);
-                           rg.ungetregisterint(exprasmlist,R_EDI);
+                           cg.a_load_reg_ref(exprasmlist,OS_ADDR,tmpreg,href);
+                           cg.free_scratch_reg(exprasmlist,tmpreg);
                          end
                        else
                          cg.a_paramaddr_ref(exprasmlist,left.location.reference,-1);
@@ -202,11 +202,11 @@ implementation
               inc(pushedparasize,4);
               if inlined then
                 begin
-                   rg.getexplicitregisterint(exprasmlist,R_EDI);
-                   emit_ref_reg(A_LEA,S_L,left.location.reference,R_EDI);
+                   tmpreg:=cg.get_scratch_reg(exprasmlist);
+                   cg.a_loadaddr_ref_reg(exprasmlist,left.location.reference,tmpreg);
                    reference_reset_base(href,procinfo^.framepointer,para_offset-pushedparasize);
-                   emit_reg_ref(A_MOV,S_L,R_EDI,href);
-                   rg.ungetregisterint(exprasmlist,R_EDI);
+                   cg.a_load_reg_ref(exprasmlist,OS_ADDR,tmpreg,href);
+                   cg.free_scratch_reg(exprasmlist,tmpreg);
                 end
               else
                 cg.a_paramaddr_ref(exprasmlist,left.location.reference,-1);
@@ -249,11 +249,11 @@ implementation
                    inc(pushedparasize,4);
                    if inlined then
                      begin
-                        rg.getexplicitregisterint(exprasmlist,R_EDI);
-                        emit_ref_reg(A_LEA,S_L,left.location.reference,R_EDI);
+                        tmpreg:=cg.get_scratch_reg(exprasmlist);
+                        cg.a_loadaddr_ref_reg(exprasmlist,left.location.reference,tmpreg);
                         reference_reset_base(href,procinfo^.framepointer,para_offset-pushedparasize);
-                        emit_reg_ref(A_MOV,S_L,R_EDI,href);
-                        rg.ungetregisterint(exprasmlist,R_EDI);
+                        cg.a_load_reg_ref(exprasmlist,OS_ADDR,tmpreg,href);
+                        cg.free_scratch_reg(exprasmlist,tmpreg);
                      end
                    else
                      cg.a_paramaddr_ref(exprasmlist,left.location.reference,-1);
@@ -290,6 +290,7 @@ implementation
          unusedstate: pointer;
          pushed : tpushedsaved;
          funcretref,refcountedtemp : treference;
+         tmpreg : tregister;
          hregister : tregister;
          oldpushedparasize : longint;
          { true if ESI must be loaded again after the subroutine }
@@ -306,6 +307,7 @@ implementation
          i : longint;
          { help reference pointer }
          href : treference;
+         hrefvmt : treference;
          hp : tnode;
          pp : tbinarynode;
          params : tnode;
@@ -325,7 +327,7 @@ implementation
          push_size : longint;
 {$endif OPTALIGN}
          pop_allowed : boolean;
-         release_edi : boolean;
+         release_tmpreg : boolean;
          constructorfailed : tasmlabel;
 
       label
@@ -402,7 +404,7 @@ implementation
                  not(po_iocheck in aktprocdef.procoptions) then
                 begin
                    getaddrlabel(iolabel);
-                   emitlab(iolabel);
+                   cg.a_label(exprasmlist,iolabel);
                 end
               else
                 iolabel:=nil;
@@ -586,9 +588,9 @@ implementation
                    if ((not(nf_islocal in twithnode(twithsymtable(symtableproc).withnode).flags)) and
                        (not twithsymtable(symtableproc).direct_with)) or
                       is_class_or_interface(methodpointer.resulttype.def) then
-                     emit_ref_reg(A_MOV,S_L,href,R_ESI)
+                     cg.a_load_ref_reg(exprasmlist,OS_ADDR,href,self_pointer_reg)
                    else
-                     emit_ref_reg(A_LEA,S_L,href,R_ESI);
+                     cg.a_loadaddr_ref_reg(exprasmlist,href,self_pointer_reg);
                 end;
 
               { push self }
@@ -629,12 +631,11 @@ implementation
                                          { if no VMT just use $0 bug0214 PM }
                                          rg.getexplicitregisterint(exprasmlist,R_ESI);
                                          if not(oo_has_vmt in tobjectdef(methodpointer.resulttype.def).objectoptions) then
-                                           emit_const_reg(A_MOV,S_L,0,R_ESI)
+                                           cg.a_load_const_reg(exprasmlist,OS_ADDR,0,self_pointer_reg)
                                          else
                                            begin
-                                             emit_sym_ofs_reg(A_MOV,S_L,
-                                               newasmsymbol(tobjectdef(methodpointer.resulttype.def).vmt_mangledname),
-                                               0,R_ESI);
+                                             reference_reset_symbol(href,newasmsymbol(tobjectdef(methodpointer.resulttype.def).vmt_mangledname),0);
+                                             cg.a_loadaddr_ref_reg(exprasmlist,href,self_pointer_reg);
                                            end;
                                          { emit_reg(A_PUSH,S_L,R_ESI);
                                            this is done below !! }
@@ -647,15 +648,15 @@ implementation
                                     if is_class(tobjectdef(methodpointer.resulttype.def)) and
                                        (procdefinition.proctypeoption=potype_destructor) then
                                       begin
-                                        push_int(0);
-                                        emit_reg(A_PUSH,S_L,R_ESI);
+                                        cg.a_param_const(exprasmlist,OS_ADDR,0,2);
+                                        cg.a_param_reg(exprasmlist,OS_ADDR,self_pointer_reg,1);
                                       end;
 
                                     if not(is_con_or_destructor and
                                            is_class(methodpointer.resulttype.def) and
                                            (procdefinition.proctypeoption in [potype_constructor,potype_destructor])
                                           ) then
-                                      emit_reg(A_PUSH,S_L,R_ESI);
+                                      cg.a_param_reg(exprasmlist,OS_ADDR,self_pointer_reg,1);
                                     { if an inherited con- or destructor should be  }
                                     { called in a con- or destructor then a warning }
                                     { will be made                                  }
@@ -678,8 +679,8 @@ implementation
                                       begin
                                          { a constructor needs also a flag }
                                          if is_class(methodpointer.resulttype.def) then
-                                           push_int(0);
-                                         push_int(0);
+                                           cg.a_param_const(exprasmlist,OS_ADDR,0,2);
+                                         cg.a_param_const(exprasmlist,OS_ADDR,0,1);
                                       end;
                                  end;
                                hnewn:
@@ -687,11 +688,11 @@ implementation
                                     { extended syntax of new }
                                     { ESI must be zero }
                                     rg.getexplicitregisterint(exprasmlist,R_ESI);
-                                    emit_reg_reg(A_XOR,S_L,R_ESI,R_ESI);
-                                    emit_reg(A_PUSH,S_L,R_ESI);
+                                    cg.a_load_const_reg(exprasmlist,OS_ADDR,0,self_pointer_reg);
+                                    cg.a_param_reg(exprasmlist,OS_ADDR,self_pointer_reg,2);
                                     { insert the vmt }
-                                    emit_sym(A_PUSH,S_L,
-                                      newasmsymbol(tobjectdef(methodpointer.resulttype.def).vmt_mangledname));
+                                    reference_reset_symbol(href,newasmsymbol(tobjectdef(methodpointer.resulttype.def).vmt_mangledname),0);
+                                    cg.a_paramaddr_ref(exprasmlist,href,1);
                                     extended_new:=true;
                                  end;
                                hdisposen:
@@ -703,9 +704,9 @@ implementation
                                     rg.getexplicitregisterint(exprasmlist,R_ESI);
                                     emit_ref_reg(A_LEA,S_L,methodpointer.location.reference,R_ESI);
                                     reference_release(exprasmlist,methodpointer.location.reference);
-                                    emit_reg(A_PUSH,S_L,R_ESI);
-                                    emit_sym(A_PUSH,S_L,
-                                      newasmsymbol(tobjectdef(methodpointer.resulttype.def).vmt_mangledname));
+                                    cg.a_param_reg(exprasmlist,OS_ADDR,self_pointer_reg,2);
+                                    reference_reset_symbol(href,newasmsymbol(tobjectdef(methodpointer.resulttype.def).vmt_mangledname),0);
+                                    cg.a_paramaddr_ref(exprasmlist,href,1);
                                  end;
                                else
                                  begin
@@ -718,16 +719,16 @@ implementation
                                             LOC_CREGISTER,
                                             LOC_REGISTER:
                                               begin
-                                                 emit_reg_reg(A_MOV,S_L,methodpointer.location.register,R_ESI);
+                                                 cg.a_load_reg_reg(exprasmlist,OS_ADDR,methodpointer.location.register,R_ESI);
                                                  rg.ungetregisterint(exprasmlist,methodpointer.location.register);
                                               end;
                                             else
                                               begin
                                                  if (methodpointer.resulttype.def.deftype=classrefdef) or
                                                     is_class_or_interface(methodpointer.resulttype.def) then
-                                                   emit_ref_reg(A_MOV,S_L,methodpointer.location.reference,R_ESI)
+                                                   cg.a_load_ref_reg(exprasmlist,OS_ADDR,methodpointer.location.reference,R_ESI)
                                                  else
-                                                   emit_ref_reg(A_LEA,S_L,methodpointer.location.reference,R_ESI);
+                                                   cg.a_loadaddr_ref_reg(exprasmlist,methodpointer.location.reference,R_ESI);
                                                  reference_release(exprasmlist,methodpointer.location.reference);
                                               end;
                                          end;
@@ -742,20 +743,20 @@ implementation
                                              { class method needs current VMT }
                                              rg.getexplicitregisterint(exprasmlist,R_ESI);
                                              reference_reset_base(href,R_ESI,tprocdef(procdefinition)._class.vmt_offset);
-                                             emit_ref_reg(A_MOV,S_L,href,R_ESI);
+                                             cg.a_load_ref_reg(exprasmlist,OS_ADDR,href,self_pointer_reg);
                                           end;
 
                                         { direct call to destructor: remove data }
                                         if (procdefinition.proctypeoption=potype_destructor) and
                                            is_class(methodpointer.resulttype.def) then
-                                          emit_const(A_PUSH,S_L,1);
+                                          cg.a_param_const(exprasmlist,OS_INT,1,1);
 
                                         { direct call to class constructor, don't allocate memory }
                                         if (procdefinition.proctypeoption=potype_constructor) and
                                            is_class(methodpointer.resulttype.def) then
                                           begin
-                                             emit_const(A_PUSH,S_L,0);
-                                             emit_const(A_PUSH,S_L,0);
+                                             cg.a_param_const(exprasmlist,OS_INT,0,2);
+                                             cg.a_param_const(exprasmlist,OS_INT,0,1);
                                           end
                                         else
                                           begin
@@ -763,8 +764,8 @@ implementation
                                              if (procdefinition.proctypeoption=potype_constructor) and
                                                 (methodpointer.resulttype.def.deftype=classrefdef) and
                                                 is_class(tclassrefdef(methodpointer.resulttype.def).pointertype.def) then
-                                                emit_const(A_PUSH,S_L,1);
-                                             emit_reg(A_PUSH,S_L,R_ESI);
+                                               cg.a_param_const(exprasmlist,OS_INT,1,1);
+                                             cg.a_param_reg(exprasmlist,OS_ADDR,self_pointer_reg,1);
                                           end;
                                       end;
 
@@ -775,14 +776,15 @@ implementation
                                            begin
                                               if (procdefinition.proctypeoption=potype_constructor) then
                                                 begin
-                                                   { it's no bad idea, to insert the VMT }
-                                                   emit_sym(A_PUSH,S_L,newasmsymbol(
-                                                     tobjectdef(methodpointer.resulttype.def).vmt_mangledname));
+                                                  { it's no bad idea, to insert the VMT }
+                                                  reference_reset_symbol(href,newasmsymbol(
+                                                     tobjectdef(methodpointer.resulttype.def).vmt_mangledname),0);
+                                                  cg.a_paramaddr_ref(exprasmlist,href,1);
                                                 end
                                               { destructors haven't to dispose the instance, if this is }
                                               { a direct call                                           }
                                               else
-                                                push_int(0);
+                                                cg.a_param_const(exprasmlist,OS_INT,0,1);
                                            end;
                                       end;
                                  end;
@@ -800,7 +802,7 @@ implementation
                              { class method needs current VMT }
                              rg.getexplicitregisterint(exprasmlist,R_ESI);
                              reference_reset_base(href,R_ESI,tprocdef(procdefinition)._class.vmt_offset);
-                             emit_ref_reg(A_MOV,S_L,href,R_ESI);
+                             cg.a_load_ref_reg(exprasmlist,OS_ADDR,href,R_ESI);
                           end
                         else
                           begin
@@ -812,32 +814,32 @@ implementation
                           begin
                              if (procdefinition.proctypeoption=potype_destructor) then
                                begin
-                                  emit_const(A_PUSH,S_L,0);
-                                  emit_reg(A_PUSH,S_L,R_ESI);
+                                  cg.a_param_const(exprasmlist,OS_INT,0,2);
+                                  cg.a_param_reg(exprasmlist,OS_ADDR,R_ESI,1);
                                end
                              else if (procdefinition.proctypeoption=potype_constructor) then
                                begin
-                                  emit_const(A_PUSH,S_L,0);
-                                  emit_const(A_PUSH,S_L,0);
+                                  cg.a_param_const(exprasmlist,OS_INT,0,2);
+                                  cg.a_param_const(exprasmlist,OS_INT,0,1);
                                end
                              else
-                               emit_reg(A_PUSH,S_L,R_ESI);
+                               cg.a_param_reg(exprasmlist,OS_ADDR,R_ESI,1);
                           end
                         else if is_object(procinfo^._class) then
                           begin
-                             emit_reg(A_PUSH,S_L,R_ESI);
+                             cg.a_param_reg(exprasmlist,OS_ADDR,R_ESI,1);
                              if is_con_or_destructor 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(
-                                         procinfo^._class.vmt_mangledname));
+                                      { it's no bad idea, to insert the VMT }
+                                      reference_reset_symbol(href,newasmsymbol(procinfo^._class.vmt_mangledname),0);
+                                      cg.a_paramaddr_ref(exprasmlist,href,1);
                                     end
                                   { destructors haven't to dispose the instance, if this is }
                                   { a direct call                                           }
                                   else
-                                    push_int(0);
+                                    cg.a_param_const(exprasmlist,OS_INT,0,1);
                                end;
                           end
                         else
@@ -853,13 +855,13 @@ implementation
                    (inlined or
                    (right=nil)) then
                   begin
-                     emit_reg(A_PUSH,S_L,R_ESI);
-                     reference_reset_base(href,R_ESI,0);
-                     rg.getexplicitregisterint(exprasmlist,R_EDI);
-                     emit_ref_reg(A_MOV,S_L,href,R_EDI);
-                     reference_reset_base(href,R_EDI,72);
-                     emit_ref(A_CALL,S_NO,href);
-                     rg.ungetregisterint(exprasmlist,R_EDI);
+                     cg.a_param_reg(exprasmlist,OS_ADDR,self_pointer_reg,1);
+                     reference_reset_base(href,self_pointer_reg,0);
+                     tmpreg:=cg.get_scratch_reg(exprasmlist);
+                     cg.a_load_ref_reg(exprasmlist,OS_ADDR,href,tmpreg);
+                     reference_reset_base(href,tmpreg,72);
+                     cg.a_call_ref(exprasmlist,href);
+                     cg.free_scratch_reg(exprasmlist,tmpreg);
                   end;
 
               { push base pointer ?}
@@ -883,27 +885,27 @@ implementation
                      if lexlevel=(tprocdef(procdefinition).parast.symtablelevel) then
                        begin
                           reference_reset_base(href,procinfo^.framepointer,procinfo^.framepointer_offset);
-                          emit_ref(A_PUSH,S_L,href)
+                          cg.a_param_ref(exprasmlist,OS_ADDR,href,-1);
                        end
                        { this is only true if the difference is one !!
                          but it cannot be more !! }
                      else if (lexlevel=(tprocdef(procdefinition).parast.symtablelevel)-1) then
                        begin
-                          emit_reg(A_PUSH,S_L,procinfo^.framepointer)
+                          cg.a_param_reg(exprasmlist,OS_ADDR,procinfo^.framepointer,-1);
                        end
                      else if (lexlevel>(tprocdef(procdefinition).parast.symtablelevel)) then
                        begin
                           hregister:=rg.getregisterint(exprasmlist);
                           reference_reset_base(href,procinfo^.framepointer,procinfo^.framepointer_offset);
-                          emit_ref_reg(A_MOV,S_L,href,hregister);
+                          cg.a_load_ref_reg(exprasmlist,OS_ADDR,href,hregister);
                           for i:=(tprocdef(procdefinition).parast.symtablelevel) to lexlevel-1 do
                             begin
                                {we should get the correct frame_pointer_offset at each level
                                how can we do this !!! }
                                reference_reset_base(href,hregister,procinfo^.framepointer_offset);
-                               emit_ref_reg(A_MOV,S_L,href,hregister);
+                               cg.a_load_ref_reg(exprasmlist,OS_ADDR,href,hregister);
                             end;
-                          emit_reg(A_PUSH,S_L,hregister);
+                          cg.a_param_reg(exprasmlist,OS_ADDR,hregister,-1);
                           rg.ungetregisterint(exprasmlist,hregister);
                        end
                      else
@@ -919,7 +921,7 @@ implementation
                    { also class methods                       }
                    { Here it is quite tricky because it also depends }
                    { on the methodpointer                        PM }
-                   release_edi:=false;
+                   release_tmpreg:=false;
                    rg.getexplicitregisterint(exprasmlist,R_ESI);
                    if assigned(aktprocdef) then
                      begin
@@ -943,48 +945,39 @@ implementation
                          begin
                             { this is one point where we need vmt_offset (PM) }
                             reference_reset_base(href,R_ESI,tprocdef(procdefinition)._class.vmt_offset);
-                            rg.getexplicitregisterint(exprasmlist,R_EDI);
-                            emit_ref_reg(A_MOV,S_L,href,R_EDI);
-                            reference_reset_base(href,R_EDI,0);
-                            release_edi:=true;
+                            tmpreg:=cg.get_scratch_reg(exprasmlist);
+                            cg.a_load_ref_reg(exprasmlist,OS_ADDR,href,tmpreg);
+                            reference_reset_base(href,tmpreg,0);
+                            release_tmpreg:=true;
                          end;
                      end
                    else
                      { aktprocdef should be assigned, also in main program }
                      internalerror(12345);
-                   {
-                     begin
-                       new(r);
-                       reset_reference(r^);
-                       r^.base:=R_ESI;
-                       emit_ref_reg(A_MOV,S_L,r,R_EDI);
-                       new(r);
-                       reset_reference(r^);
-                       r^.base:=R_EDI;
-                     end;
-                   }
+
                    if tprocdef(procdefinition).extnumber=-1 then
                      internalerror(44584);
+
                    href.offset:=tprocdef(procdefinition)._class.vmtmethodoffset(tprocdef(procdefinition).extnumber);
                    if not(is_interface(tprocdef(procdefinition)._class)) and
-                     not(is_cppclass(tprocdef(procdefinition)._class)) then
+                      not(is_cppclass(tprocdef(procdefinition)._class)) then
                      begin
-                        if (cs_check_object_ext in aktlocalswitches) then
+                        if (cs_check_object in aktlocalswitches) then
                           begin
-                             emit_sym(A_PUSH,S_L,
-                               newasmsymbol(tprocdef(procdefinition)._class.vmt_mangledname));
-                             emit_reg(A_PUSH,S_L,href.base);
-                             emitcall('FPC_CHECK_OBJECT_EXT');
+                             reference_reset_symbol(hrefvmt,newasmsymbol(tprocdef(procdefinition)._class.vmt_mangledname),0);
+                             cg.a_paramaddr_ref(exprasmlist,hrefvmt,2);
+                             cg.a_param_reg(exprasmlist,OS_ADDR,href.base,1);
+                             cg.a_call_name(exprasmlist,'FPC_CHECK_OBJECT_EXT');
                           end
                         else if (cs_check_range in aktlocalswitches) then
                           begin
-                             emit_reg(A_PUSH,S_L,href.base);
-                             emitcall('FPC_CHECK_OBJECT');
+                             cg.a_param_reg(exprasmlist,OS_ADDR,href.base,1);
+                             cg.a_call_name(exprasmlist,'FPC_CHECK_OBJECT');
                           end;
                      end;
-                   emit_ref(A_CALL,S_NO,href);
-                   if release_edi then
-                     rg.ungetregisterint(exprasmlist,R_EDI);
+                   cg.a_call_ref(exprasmlist,href);
+                   if release_tmpreg then
+                     cg.free_scratch_reg(exprasmlist,tmpreg);
                 end
               else if not inlined then
                 begin
@@ -995,7 +988,7 @@ implementation
                         emit_none(A_PUSHF,S_L);
                         emit_reg(A_PUSH,S_L,R_CS);
                     end;
-                  emitcall(tprocdef(procdefinition).mangledname);
+                  cg.a_call_name(exprasmlist,tprocdef(procdefinition).mangledname);
                 end
               else { inlined proc }
                 { inlined code is in inlinecode }
@@ -1029,32 +1022,31 @@ implementation
                       (right.location.reference.index=R_ESI) then
                      begin
                         reference_release(exprasmlist,right.location.reference);
-                        rg.getexplicitregisterint(exprasmlist,R_EDI);
-                        emit_ref_reg(A_MOV,S_L,right.location.reference,R_EDI);
-                        hregister:=R_EDI;
+                        hregister:=cg.get_scratch_reg(exprasmlist);
+                        cg.a_load_ref_reg(exprasmlist,OS_ADDR,right.location.reference,hregister);
                      end;
 
                    { load self, but not if it's already explicitly pushed }
                    if not(po_containsself in procdefinition.procoptions) then
                      begin
                        { load ESI }
-                       inc(right.location.reference.offset,4);
+                       href:=right.location.reference;
+                       inc(href.offset,4);
                        rg.getexplicitregisterint(exprasmlist,R_ESI);
-                       emit_ref_reg(A_MOV,S_L,right.location.reference,R_ESI);
-                       dec(right.location.reference.offset,4);
+                       cg.a_load_ref_reg(exprasmlist,OS_ADDR,href,self_pointer_reg);
                        { push self pointer }
-                       emit_reg(A_PUSH,S_L,R_ESI);
+                       cg.a_param_reg(exprasmlist,OS_ADDR,self_pointer_reg,-1);
                      end;
 
                    rg.saveregvars(exprasmlist,ALL_REGISTERS);
-                   if hregister=R_NO then
-                     emit_ref(A_CALL,S_NO,right.location.reference)
+                   if hregister<>R_NO then
+                     reference_reset_base(href,hregister,0)
                    else
-                     begin
-                       emit_reg(A_CALL,S_NO,hregister);
-                       rg.ungetregisterint(exprasmlist,hregister);
-                     end;
+                     href:=right.location.reference;
+                   cg.a_call_ref(exprasmlist,href);
 
+                   if hregister<>R_NO then
+                     cg.free_scratch_reg(exprasmlist,hregister);
                    reference_release(exprasmlist,right.location.reference);
                 end
               else
@@ -1062,12 +1054,13 @@ implementation
                    rg.saveregvars(exprasmlist,ALL_REGISTERS);
                    case right.location.loc of
                       LOC_REGISTER,LOC_CREGISTER:
-                        emit_reg(A_CALL,S_NO,right.location.register);
+                        reference_reset_base(href,right.location.register,0);
                       LOC_REFERENCE,LOC_CREFERENCE :
-                        emit_ref(A_CALL,S_NO,right.location.reference);
+                        href:=right.location.reference;
                       else
                         internalerror(200203311);
                    end;
+                   cg.a_call_ref(exprasmlist,href);
                    location_release(exprasmlist,right.location);
                 end;
            end;
@@ -1138,16 +1131,16 @@ implementation
            begin
               getlabel(constructorfailed);
               emitjmp(C_Z,constructorfailed);
-              emit_reg(A_PUSH,S_L,R_ESI);
-              reference_reset_base(href,R_ESI,0);
-              rg.getexplicitregisterint(exprasmlist,R_EDI);
-              emit_ref_reg(A_MOV,S_L,href,R_EDI);
-              reference_reset_base(href,R_EDI,68);
-              emit_ref(A_CALL,S_NO,href);
-              rg.ungetregisterint(exprasmlist,R_EDI);
-              exprasmList.concat(Tairegalloc.Alloc(R_EAX));
-              emitlab(constructorfailed);
-              emit_reg_reg(A_MOV,S_L,R_ESI,R_EAX);
+              cg.a_param_reg(exprasmlist,OS_ADDR,self_pointer_reg,1);
+              reference_reset_base(href,self_pointer_reg,0);
+              tmpreg:=cg.get_scratch_reg(exprasmlist);
+              cg.a_load_ref_reg(exprasmlist,OS_ADDR,href,tmpreg);
+              reference_reset_base(href,tmpreg,68);
+              cg.a_call_ref(exprasmlist,href);
+              cg.free_scratch_reg(exprasmlist,tmpreg);
+              exprasmList.concat(Tairegalloc.Alloc(accumulator));
+              cg.a_label(exprasmlist,constructorfailed);
+              cg.a_load_reg_reg(exprasmlist,OS_ADDR,self_pointer_reg,accumulator);
            end;
 
          { handle function results }
@@ -1244,8 +1237,9 @@ implementation
          { perhaps i/o check ? }
          if iolabel<>nil then
            begin
-              emit_sym(A_PUSH,S_L,iolabel);
-              emitcall('FPC_IOCHECK');
+              reference_reset_symbol(href,iolabel,0);
+              cg.a_paramaddr_ref(exprasmlist,href,1);
+              cg.a_call_name(exprasmlist,'FPC_IOCHECK');
            end;
          if pop_size>0 then
            emit_const_reg(A_ADD,S_L,pop_size,R_ESP);
@@ -1255,15 +1249,14 @@ implementation
 
          { at last, restore instance pointer (SELF) }
          if loadesi then
-           maybe_loadself;
+           cg.g_maybe_loadself(exprasmlist);
          pp:=tbinarynode(params);
          while assigned(pp) do
            begin
               if assigned(pp.left) then
                 begin
-                  if (pp.left.location.loc in [LOC_REFERENCE,LOC_CREFERENCE]) then
-                    tg.ungetiftemp(exprasmlist,pp.left.location.reference);
-                { process also all nodes of an array of const }
+                  location_freetemp(exprasmlist,pp.left.location);
+                  { process also all nodes of an array of const }
                   if pp.left.nodetype=arrayconstructorn then
                     begin
                       if assigned(tarrayconstructornode(pp.left).left) then
@@ -1271,9 +1264,8 @@ implementation
                          hp:=pp.left;
                          while assigned(hp) do
                           begin
-                            if (tarrayconstructornode(tunarynode(hp).left).location.loc in [LOC_REFERENCE,LOC_CREFERENCE]) then
-                              tg.ungetiftemp(exprasmlist,tarrayconstructornode(hp).left.location.reference);
-                            hp:=tbinarynode(hp).right;
+                            location_freetemp(exprasmlist,tarrayconstructornode(hp).left.location);
+                            hp:=tarrayconstructornode(hp).right;
                           end;
                        end;
                     end;
@@ -1401,7 +1393,7 @@ implementation
             begin
               getaddrlabel(startlabel);
               getaddrlabel(endlabel);
-              emitlab(startlabel);
+              cg.a_label(exprasmlist,startlabel);
               inlineprocdef.localst.symtabletype:=inlinelocalsymtable;
               inlineprocdef.parast.symtabletype:=inlineparasymtable;
 
@@ -1457,7 +1449,7 @@ implementation
 {$ifdef GDB}
           if (cs_debuginfo in aktmoduleswitches) then
             begin
-              emitlab(endlabel);
+              cg.a_label(exprasmlist,endlabel);
               strpcopy(pp,'224,0,0,'+endlabel.name);
              if (target_info.use_function_relative_addresses) then
                begin
@@ -1492,7 +1484,24 @@ begin
 end.
 {
   $Log$
-  Revision 1.48  2002-04-25 20:16:40  peter
+  Revision 1.49  2002-05-12 16:53:17  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.48  2002/04/25 20:16:40  peter
     * moved more routines from cga/n386util
 
   Revision 1.47  2002/04/21 19:02:07  peter

compiler/i386/n386cnv.pas

@@ -65,7 +65,7 @@ implementation
       symconst,symdef,aasm,
       cginfo,cgbase,pass_2,
       ncon,ncal,ncnv,
-      cpubase,
+      cpubase,cpuasm,
       cgobj,cga,tgobj,rgobj,rgcpu,ncgutil;
 
 
@@ -76,63 +76,56 @@ implementation
     procedure ti386typeconvnode.second_int_to_real;
 
       var
-         r : treference;
+         href : treference;
          hregister : tregister;
          l1,l2 : tasmlabel;
+         freereg : boolean;
 
       begin
          location_reset(location,LOC_FPUREGISTER,def_cgsize(resulttype.def));
+         hregister:=R_NO;
+         freereg:=false;
+
          { for u32bit a solution is to push $0 and to load a comp }
          { does this first, it destroys maybe EDI }
-         hregister:=R_EDI;
          if torddef(left.resulttype.def).typ=u32bit then
-            push_int(0);
+          exprasmlist.concat(taicpu.op_const(A_PUSH,S_L,0));
 
          case left.location.loc of
            LOC_REGISTER,
            LOC_CREGISTER :
              begin
-                if not (torddef(left.resulttype.def).typ in [u32bit,s32bit,u64bit,s64bit]) then
-                  rg.getexplicitregisterint(exprasmlist,R_EDI);
-                case torddef(left.resulttype.def).typ of
-                   s8bit : emit_reg_reg(A_MOVSX,S_BL,left.location.register,R_EDI);
-                   u8bit : emit_reg_reg(A_MOVZX,S_BL,left.location.register,R_EDI);
-                   s16bit : emit_reg_reg(A_MOVSX,S_WL,left.location.register,R_EDI);
-                   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;
-              end;
-            LOC_REFERENCE,
-            LOC_CREFERENCE :
-              begin
-                r:=left.location.reference;
-                rg.getexplicitregisterint(exprasmlist,R_EDI);
-                case torddef(left.resulttype.def).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:=left.location.reference;
-                        emit_ref_reg(A_MOV,S_L,r,R_EDI);
-                     end;
-                end;
+               case left.location.size of
+                 OS_64,OS_S64 :
+                   begin
+                     exprasmlist.concat(taicpu.op_reg(A_PUSH,S_L,left.location.registerhigh));
+                     hregister:=left.location.registerlow;
+                   end;
+                 OS_32,OS_S32 :
+                   hregister:=left.location.register;
+                 else
+                   begin
+                     hregister:=cg.get_scratch_reg(exprasmlist);
+                     freereg:=true;
+                     cg.a_load_reg_reg(exprasmlist,left.location.size,left.location.register,hregister);
+                   end;
+               end;
+             end;
+           LOC_REFERENCE,
+           LOC_CREFERENCE :
+             begin
+               hregister:=cg.get_scratch_reg(exprasmlist);
+               freereg:=true;
+               if left.location.size in [OS_64,OS_S64] then
+                begin
+                  href:=left.location.reference;
+                  inc(href.offset,4);
+                  cg.a_load_ref_reg(exprasmlist,OS_32,href,hregister);
+                  exprasmlist.concat(taicpu.op_reg(A_PUSH,S_L,hregister));
+                  cg.a_load_ref_reg(exprasmlist,OS_32,left.location.reference,hregister);
+                end
+               else
+                cg.a_load_ref_reg(exprasmlist,left.location.size,left.location.reference,hregister);
              end;
            else
              internalerror(2002032218);
@@ -141,19 +134,19 @@ implementation
          location_freetemp(exprasmlist,left.location);
 
          { for 64 bit integers, the high dword is already pushed }
-         emit_reg(A_PUSH,S_L,hregister);
-         if hregister = R_EDI then
-           rg.ungetregisterint(exprasmlist,R_EDI);
-         reference_reset_base(r,R_ESP,0);
+         exprasmlist.concat(taicpu.op_reg(A_PUSH,S_L,hregister));
+         if freereg then
+           cg.free_scratch_reg(exprasmlist,hregister);
+         reference_reset_base(href,R_ESP,0);
          case torddef(left.resulttype.def).typ of
            u32bit:
              begin
-                emit_ref(A_FILD,S_IQ,r);
+                emit_ref(A_FILD,S_IQ,href);
                 emit_const_reg(A_ADD,S_L,8,R_ESP);
              end;
            s64bit:
              begin
-                emit_ref(A_FILD,S_IQ,r);
+                emit_ref(A_FILD,S_IQ,href);
                 emit_const_reg(A_ADD,S_L,8,R_ESP);
              end;
            u64bit:
@@ -162,15 +155,15 @@ implementation
                 { 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);
+                inc(href.offset,4);
                 rg.getexplicitregisterint(exprasmlist,R_EDI);
-                emit_ref_reg(A_MOV,S_L,r,R_EDI);
-                reference_reset_base(r,R_ESP,4);
-                emit_const_ref(A_AND,S_L,$7fffffff,r);
+                emit_ref_reg(A_MOV,S_L,href,R_EDI);
+                reference_reset_base(href,R_ESP,4);
+                emit_const_ref(A_AND,S_L,$7fffffff,href);
                 emit_const_reg(A_TEST,S_L,longint($80000000),R_EDI);
                 rg.ungetregisterint(exprasmlist,R_EDI);
-                reference_reset_base(r,R_ESP,0);
-                emit_ref(A_FILD,S_IQ,r);
+                reference_reset_base(href,R_ESP,0);
+                emit_ref(A_FILD,S_IQ,href);
                 getdatalabel(l1);
                 getlabel(l2);
                 emitjmp(C_Z,l2);
@@ -178,14 +171,14 @@ implementation
                 { I got this constant from a test progtram (FK) }
                 Consts.concat(Tai_const.Create_32bit(0));
                 Consts.concat(Tai_const.Create_32bit(1138753536));
-                reference_reset_symbol(r,l1,0);
-                emit_ref(A_FADD,S_FL,r);
-                emitlab(l2);
+                reference_reset_symbol(href,l1,0);
+                emit_ref(A_FADD,S_FL,href);
+                cg.a_label(exprasmlist,l2);
                 emit_const_reg(A_ADD,S_L,8,R_ESP);
              end
            else
              begin
-                emit_ref(A_FILD,S_IL,r);
+                emit_ref(A_FILD,S_IL,href);
                 rg.getexplicitregisterint(exprasmlist,R_EDI);
                 emit_reg(A_POP,S_L,R_EDI);
                 rg.ungetregisterint(exprasmlist,R_EDI);
@@ -239,7 +232,7 @@ implementation
                  end
                 else
                  begin
-                   location_force_reg(left.location,left.location.size,true);
+                   location_force_reg(exprasmlist,left.location,left.location.size,true);
                    cg.a_op_reg_reg(exprasmlist,OP_OR,left.location.size,left.location.register,left.location.register);
                  end;
               end;
@@ -372,7 +365,24 @@ begin
 end.
 {
   $Log$
-  Revision 1.37  2002-04-21 19:02:07  peter
+  Revision 1.38  2002-05-12 16:53:17  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.37  2002/04/21 19:02:07  peter
     * removed newn and disposen nodes, the code is now directly
       inlined from pexpr
     * -an option that will write the secondpass nodes to the .s file, this

compiler/i386/n386flw.pas

@@ -56,8 +56,8 @@ implementation
     uses
       verbose,systems,
       symsym,aasm,
-      cginfo,cgbase,pass_2,
-      cpubase,cpuasm,
+      cgbase,pass_2,
+      cpuinfo,cpubase,cpuasm,
       nld,ncon,
       tainst,cga,cgobj,tgobj,rgobj;
 
@@ -94,7 +94,7 @@ implementation
               else
                 begin
                    getaddrlabel(a);
-                   emitlab(a);
+                   cg.a_label(exprasmlist,a);
                    cg.a_param_reg(exprasmlist,OS_INT,R_EBP,2);
                    emit_sym(A_PUSH,S_L,a);
                 end;
@@ -103,12 +103,12 @@ implementation
               if codegenerror then
                 exit;
               cg.a_param_loc(exprasmlist,left.location,1);
-              emitcall('FPC_RAISEEXCEPTION');
+              cg.a_call_name(exprasmlist,'FPC_RAISEEXCEPTION');
            end
          else
            begin
-              emitcall('FPC_POPADDRSTACK');
-              emitcall('FPC_RERAISE');
+              cg.a_call_name(exprasmlist,'FPC_POPADDRSTACK');
+              cg.a_call_name(exprasmlist,'FPC_RERAISE');
            end;
        end;
 
@@ -125,12 +125,12 @@ implementation
     procedure cleanupobjectstack;
 
       begin
-         emitcall('FPC_POPOBJECTSTACK');
+         cg.a_call_name(exprasmlist,'FPC_POPOBJECTSTACK');
          exprasmList.concat(Tairegalloc.Alloc(R_EAX));
          emit_reg(A_PUSH,S_L,R_EAX);
-         emitcall('FPC_DESTROYEXCEPTION');
+         cg.a_call_name(exprasmlist,'FPC_DESTROYEXCEPTION');
          exprasmList.concat(Tairegalloc.DeAlloc(R_EAX));
-         maybe_loadself;
+         cg.g_maybe_loadself(exprasmlist);
       end;
 
     { pops one element from the exception address stack }
@@ -138,7 +138,7 @@ implementation
     procedure cleanupaddrstack;
 
       begin
-         emitcall('FPC_POPADDRSTACK');
+         cg.a_call_name(exprasmlist,'FPC_POPADDRSTACK');
          { allocate eax }
          exprasmList.concat(Tairegalloc.Alloc(R_EAX));
          emit_reg(A_POP,S_L,R_EAX);
@@ -205,15 +205,16 @@ implementation
 
          tg.gettempofsizereferencepersistant(exprasmlist,24,tempbuf);
          tg.gettempofsizereferencepersistant(exprasmlist,12,tempaddr);
-         emitpushreferenceaddr(tempaddr);
-         emitpushreferenceaddr(tempbuf);
-         push_int (1); { push type of exceptionframe }
-         emitcall('FPC_PUSHEXCEPTADDR');
+         cg.a_paramaddr_ref(exprasmlist,tempaddr,3);
+         cg.a_paramaddr_ref(exprasmlist,tempbuf,2);
+         { push type of exceptionframe }
+         cg.a_param_const(exprasmlist,OS_INT,1,1);
+         cg.a_call_name(exprasmlist,'FPC_PUSHEXCEPTADDR');
 
          { allocate eax }
          exprasmList.concat(Tairegalloc.Alloc(R_EAX));
          emit_reg(A_PUSH,S_L,R_EAX);
-         emitcall('FPC_SETJMP');
+         cg.a_call_name(exprasmlist,'FPC_SETJMP');
          emit_reg(A_PUSH,S_L,R_EAX);
          emit_reg_reg(A_TEST,S_L,R_EAX,R_EAX);
          { deallocate eax }
@@ -236,8 +237,8 @@ implementation
          if codegenerror then
            goto errorexit;
 
-         emitlab(exceptlabel);
-         emitcall('FPC_POPADDRSTACK');
+         cg.a_label(exprasmlist,exceptlabel);
+         cg.a_call_name(exprasmlist,'FPC_POPADDRSTACK');
          tg.ungetpersistanttempreference(exprasmlist,tempaddr);
          tg.ungetpersistanttempreference(exprasmlist,tempbuf);
 
@@ -247,7 +248,7 @@ implementation
          exprasmList.concat(Tairegalloc.DeAlloc(R_EAX));
 
          emitjmp(C_E,endexceptlabel);
-         emitlab(doexceptlabel);
+         cg.a_label(exprasmlist,doexceptlabel);
 
          { set control flow labels for the except block }
          { and the on statements                        }
@@ -264,46 +265,47 @@ implementation
          if assigned(right) then
            secondpass(right);
 
-         emitlab(lastonlabel);
+         cg.a_label(exprasmlist,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_loadself;
+              cg.a_param_const(exprasmlist,OS_INT,aword(-1),1);
+              cg.a_call_name(exprasmlist,'FPC_CATCHES');
+              cg.g_maybe_loadself(exprasmlist);
 
               { the destruction of the exception object must be also }
               { guarded by an exception frame                        }
               getlabel(doobjectdestroy);
               getlabel(doobjectdestroyandreraise);
 
-              tg.gettempofsizereferencepersistant(exprasmlist,12,tempaddr);
               tg.gettempofsizereferencepersistant(exprasmlist,24,tempbuf);
-              emitpushreferenceaddr(tempaddr);
-              emitpushreferenceaddr(tempbuf);
-              exprasmList.concat(Taicpu.Op_const(A_PUSH,S_L,1));
-              emitcall('FPC_PUSHEXCEPTADDR');
+              tg.gettempofsizereferencepersistant(exprasmlist,12,tempaddr);
+              cg.a_paramaddr_ref(exprasmlist,tempaddr,3);
+              cg.a_paramaddr_ref(exprasmlist,tempbuf,2);
+              { push type of exceptionframe }
+              cg.a_param_const(exprasmlist,OS_INT,1,1);
+              cg.a_call_name(exprasmlist,'FPC_PUSHEXCEPTADDR');
 
+              { allocate eax }
               exprasmList.concat(Tairegalloc.Alloc(R_EAX));
-              exprasmList.concat(Taicpu.op_reg(A_PUSH,S_L,R_EAX));
-              exprasmList.concat(Tairegalloc.DeAlloc(R_EAX));
-              emitcall('FPC_SETJMP');
-              exprasmList.concat(Tairegalloc.Alloc(R_EAX));
-              exprasmList.concat(Taicpu.op_reg(A_PUSH,S_L,R_EAX));
-              exprasmList.concat(Taicpu.op_reg_reg(A_TEST,S_L,R_EAX,R_EAX));
+              emit_reg(A_PUSH,S_L,R_EAX);
+              cg.a_call_name(exprasmlist,'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(Tairegalloc.DeAlloc(R_EAX));
-              emitjmp(C_NE,doobjectdestroyandreraise);
+              emitjmp(C_NE,exceptlabel);
 
               { here we don't have to reset flowcontrol           }
               { the default and on flowcontrols are handled equal }
               secondpass(t1);
               exceptflowcontrol:=flowcontrol;
 
-              emitlab(doobjectdestroyandreraise);
-              emitcall('FPC_POPADDRSTACK');
+              cg.a_label(exprasmlist,doobjectdestroyandreraise);
+              cg.a_call_name(exprasmlist,'FPC_POPADDRSTACK');
               tg.ungetpersistanttempreference(exprasmlist,tempaddr);
               tg.ungetpersistanttempreference(exprasmlist,tempbuf);
 
@@ -312,79 +314,79 @@ implementation
               exprasmList.concat(Taicpu.op_reg_reg(A_TEST,S_L,R_EAX,R_EAX));
               exprasmList.concat(Tairegalloc.DeAlloc(R_EAX));
               emitjmp(C_E,doobjectdestroy);
-              emitcall('FPC_POPSECONDOBJECTSTACK');
+              cg.a_call_name(exprasmlist,'FPC_POPSECONDOBJECTSTACK');
               exprasmList.concat(Tairegalloc.Alloc(R_EAX));
               emit_reg(A_PUSH,S_L,R_EAX);
-              emitcall('FPC_DESTROYEXCEPTION');
+              cg.a_call_name(exprasmlist,'FPC_DESTROYEXCEPTION');
               exprasmList.concat(Tairegalloc.DeAlloc(R_EAX));
               { we don't need to restore esi here because reraise never }
               { returns                                                 }
-              emitcall('FPC_RERAISE');
+              cg.a_call_name(exprasmlist,'FPC_RERAISE');
 
-              emitlab(doobjectdestroy);
+              cg.a_label(exprasmlist,doobjectdestroy);
               cleanupobjectstack;
-              emitjmp(C_None,endexceptlabel);
+              cg.a_jmp_always(exprasmlist,endexceptlabel);
            end
          else
            begin
-              emitcall('FPC_RERAISE');
+              cg.a_call_name(exprasmlist,'FPC_RERAISE');
               exceptflowcontrol:=flowcontrol;
            end;
 
          if fc_exit in exceptflowcontrol then
            begin
               { do some magic for exit in the try block }
-              emitlab(exitexceptlabel);
+              cg.a_label(exprasmlist,exitexceptlabel);
               { we must also destroy the address frame which guards }
               { exception object                                    }
               cleanupaddrstack;
               cleanupobjectstack;
-              emitjmp(C_None,oldaktexitlabel);
+              cg.a_jmp_always(exprasmlist,oldaktexitlabel);
            end;
 
          if fc_break in exceptflowcontrol then
            begin
-              emitlab(breakexceptlabel);
+              cg.a_label(exprasmlist,breakexceptlabel);
               { we must also destroy the address frame which guards }
               { exception object                                    }
               cleanupaddrstack;
               cleanupobjectstack;
-              emitjmp(C_None,oldaktbreaklabel);
+              cg.a_jmp_always(exprasmlist,oldaktbreaklabel);
            end;
 
          if fc_continue in exceptflowcontrol then
            begin
-              emitlab(continueexceptlabel);
+              cg.a_label(exprasmlist,continueexceptlabel);
               { we must also destroy the address frame which guards }
               { exception object                                    }
               cleanupaddrstack;
               cleanupobjectstack;
-              emitjmp(C_None,oldaktcontinuelabel);
+              cg.a_jmp_always(exprasmlist,oldaktcontinuelabel);
            end;
 
          if fc_exit in tryflowcontrol then
            begin
               { do some magic for exit in the try block }
-              emitlab(exittrylabel);
+              cg.a_label(exprasmlist,exittrylabel);
               cleanupaddrstack;
-              emitjmp(C_None,oldaktexitlabel);
+              cg.a_jmp_always(exprasmlist,oldaktexitlabel);
            end;
 
          if fc_break in tryflowcontrol then
            begin
-              emitlab(breaktrylabel);
+              cg.a_label(exprasmlist,breaktrylabel);
               cleanupaddrstack;
-              emitjmp(C_None,oldaktbreaklabel);
+              cg.a_jmp_always(exprasmlist,oldaktbreaklabel);
            end;
 
          if fc_continue in tryflowcontrol then
            begin
-              emitlab(continuetrylabel);
+              cg.a_label(exprasmlist,continuetrylabel);
               cleanupaddrstack;
-              emitjmp(C_None,oldaktcontinuelabel);
+              cg.a_jmp_always(exprasmlist,oldaktcontinuelabel);
            end;
 
-         emitlab(endexceptlabel);
+         cg.a_label(exprasmlist,endexceptlabel);
 
        errorexit:
          { restore all saved labels }
@@ -428,7 +430,7 @@ implementation
          { push the vmt }
          emit_sym(A_PUSH,S_L,
            newasmsymbol(excepttype.vmt_mangledname));
-         emitcall('FPC_CATCHES');
+         cg.a_call_name(exprasmlist,'FPC_CATCHES');
          { allocate eax }
          exprasmList.concat(Tairegalloc.Alloc(R_EAX));
          emit_reg_reg(A_TEST,S_L,R_EAX,R_EAX);
@@ -450,15 +452,15 @@ implementation
 
          tg.gettempofsizereferencepersistant(exprasmlist,12,tempaddr);
          tg.gettempofsizereferencepersistant(exprasmlist,24,tempbuf);
-         emitpushreferenceaddr(tempaddr);
-         emitpushreferenceaddr(tempbuf);
-         exprasmList.concat(Taicpu.Op_const(A_PUSH,S_L,1));
-         emitcall('FPC_PUSHEXCEPTADDR');
+         cg.a_paramaddr_ref(exprasmlist,tempaddr,3);
+         cg.a_paramaddr_ref(exprasmlist,tempbuf,2);
+         cg.a_param_const(exprasmlist,OS_INT,1,1);
+         cg.a_call_name(exprasmlist,'FPC_PUSHEXCEPTADDR');
 
          exprasmList.concat(Tairegalloc.Alloc(R_EAX));
          exprasmList.concat(Taicpu.op_reg(A_PUSH,S_L,R_EAX));
          exprasmList.concat(Tairegalloc.DeAlloc(R_EAX));
-         emitcall('FPC_SETJMP');
+         cg.a_call_name(exprasmlist,'FPC_SETJMP');
          exprasmList.concat(Tairegalloc.Alloc(R_EAX));
          exprasmList.concat(Taicpu.op_reg(A_PUSH,S_L,R_EAX));
          exprasmList.concat(Taicpu.op_reg_reg(A_TEST,S_L,R_EAX,R_EAX));
@@ -483,12 +485,12 @@ implementation
                end;
 
               { esi is destroyed by FPC_CATCHES }
-              maybe_loadself;
+              cg.g_maybe_loadself(exprasmlist);
               secondpass(right);
            end;
          getlabel(doobjectdestroy);
-         emitlab(doobjectdestroyandreraise);
-         emitcall('FPC_POPADDRSTACK');
+         cg.a_label(exprasmlist,doobjectdestroyandreraise);
+         cg.a_call_name(exprasmlist,'FPC_POPADDRSTACK');
          tg.ungetpersistanttempreference(exprasmlist,tempaddr);
          tg.ungetpersistanttempreference(exprasmlist,tempbuf);
 
@@ -497,20 +499,20 @@ implementation
          exprasmList.concat(Taicpu.op_reg_reg(A_TEST,S_L,R_EAX,R_EAX));
          exprasmList.concat(Tairegalloc.DeAlloc(R_EAX));
          emitjmp(C_E,doobjectdestroy);
-         emitcall('FPC_POPSECONDOBJECTSTACK');
+         cg.a_call_name(exprasmlist,'FPC_POPSECONDOBJECTSTACK');
          exprasmList.concat(Tairegalloc.Alloc(R_EAX));
          emit_reg(A_PUSH,S_L,R_EAX);
-         emitcall('FPC_DESTROYEXCEPTION');
+         cg.a_call_name(exprasmlist,'FPC_DESTROYEXCEPTION');
          exprasmList.concat(Tairegalloc.DeAlloc(R_EAX));
          { we don't need to restore esi here because reraise never }
          { returns                                                 }
-         emitcall('FPC_RERAISE');
+         cg.a_call_name(exprasmlist,'FPC_RERAISE');
 
-         emitlab(doobjectdestroy);
+         cg.a_label(exprasmlist,doobjectdestroy);
          cleanupobjectstack;
          { clear some stuff }
          tg.ungetiftemp(exprasmlist,ref);
-         emitjmp(C_None,endexceptlabel);
+         cg.a_jmp_always(exprasmlist,endexceptlabel);
 
          if assigned(right) then
            begin
@@ -518,22 +520,22 @@ implementation
               if fc_exit in flowcontrol then
                 begin
                    { the address and object pop does secondtryexcept }
-                   emitlab(exitonlabel);
-                   emitjmp(C_None,oldaktexitlabel);
+                   cg.a_label(exprasmlist,exitonlabel);
+                   cg.a_jmp_always(exprasmlist,oldaktexitlabel);
                 end;
 
               if fc_break in flowcontrol then
                 begin
                    { the address and object pop does secondtryexcept }
-                   emitlab(breakonlabel);
-                   emitjmp(C_None,oldaktbreaklabel);
+                   cg.a_label(exprasmlist,breakonlabel);
+                   cg.a_jmp_always(exprasmlist,oldaktbreaklabel);
                 end;
 
               if fc_continue in flowcontrol then
                 begin
                    { the address and object pop does secondtryexcept }
-                   emitlab(continueonlabel);
-                   emitjmp(C_None,oldaktcontinuelabel);
+                   cg.a_label(exprasmlist,continueonlabel);
+                   cg.a_jmp_always(exprasmlist,oldaktcontinuelabel);
                 end;
 
               aktexitlabel:=oldaktexitlabel;
@@ -545,7 +547,7 @@ implementation
                end;
            end;
 
-         emitlab(nextonlabel);
+         cg.a_label(exprasmlist,nextonlabel);
          flowcontrol:=oldflowcontrol+flowcontrol;
          { next on node }
          if assigned(left) then
@@ -604,15 +606,16 @@ implementation
 
          tg.gettempofsizereferencepersistant(exprasmlist,12,tempaddr);
          tg.gettempofsizereferencepersistant(exprasmlist,24,tempbuf);
-         emitpushreferenceaddr(tempaddr);
-         emitpushreferenceaddr(tempbuf);
-         push_int(1); { Type of stack-frame must be pushed}
-         emitcall('FPC_PUSHEXCEPTADDR');
+         cg.a_paramaddr_ref(exprasmlist,tempaddr,3);
+         cg.a_paramaddr_ref(exprasmlist,tempbuf,2);
+         { Type of stack-frame must be pushed}
+         cg.a_param_const(exprasmlist,OS_INT,1,1);
+         cg.a_call_name(exprasmlist,'FPC_PUSHEXCEPTADDR');
 
          { allocate eax }
          exprasmList.concat(Tairegalloc.Alloc(R_EAX));
          emit_reg(A_PUSH,S_L,R_EAX);
-         emitcall('FPC_SETJMP');
+         cg.a_call_name(exprasmlist,'FPC_SETJMP');
          emit_reg(A_PUSH,S_L,R_EAX);
          emit_reg_reg(A_TEST,S_L,R_EAX,R_EAX);
          { deallocate eax }
@@ -628,8 +631,8 @@ implementation
                 exit;
            end;
 
-         emitlab(finallylabel);
-         emitcall('FPC_POPADDRSTACK');
+         cg.a_label(exprasmlist,finallylabel);
+         cg.a_call_name(exprasmlist,'FPC_POPADDRSTACK');
          tg.ungetpersistanttempreference(exprasmlist,tempaddr);
          tg.ungetpersistanttempreference(exprasmlist,tempbuf);
 
@@ -670,41 +673,41 @@ implementation
            end;
          { deallocate eax }
          exprasmList.concat(Tairegalloc.DeAlloc(R_EAX));
-         emitlab(reraiselabel);
-         emitcall('FPC_RERAISE');
+         cg.a_label(exprasmlist,reraiselabel);
+         cg.a_call_name(exprasmlist,'FPC_RERAISE');
          { do some magic for exit,break,continue in the try block }
          if fc_exit in tryflowcontrol then
            begin
-              emitlab(exitfinallylabel);
+              cg.a_label(exprasmlist,exitfinallylabel);
               { allocate eax }
               exprasmList.concat(Tairegalloc.Alloc(R_EAX));
               emit_reg(A_POP,S_L,R_EAX);
               exprasmList.concat(Tairegalloc.Alloc(R_EAX));
               emit_const(A_PUSH,S_L,2);
-              emitjmp(C_NONE,finallylabel);
+              cg.a_jmp_always(exprasmlist,finallylabel);
            end;
          if fc_break in tryflowcontrol then
           begin
-             emitlab(breakfinallylabel);
+             cg.a_label(exprasmlist,breakfinallylabel);
              { allocate eax }
              exprasmList.concat(Tairegalloc.Alloc(R_EAX));
              emit_reg(A_POP,S_L,R_EAX);
              { deallocate eax }
              exprasmList.concat(Tairegalloc.DeAlloc(R_EAX));
              emit_const(A_PUSH,S_L,3);
-             emitjmp(C_NONE,finallylabel);
+             cg.a_jmp_always(exprasmlist,finallylabel);
            end;
          if fc_continue in tryflowcontrol then
            begin
-              emitlab(continuefinallylabel);
+              cg.a_label(exprasmlist,continuefinallylabel);
               exprasmList.concat(Tairegalloc.Alloc(R_EAX));
               emit_reg(A_POP,S_L,R_EAX);
               exprasmList.concat(Tairegalloc.Alloc(R_EAX));
               emit_const(A_PUSH,S_L,4);
-              emitjmp(C_NONE,finallylabel);
+              cg.a_jmp_always(exprasmlist,finallylabel);
            end;
 
-         emitlab(endfinallylabel);
+         cg.a_label(exprasmlist,endfinallylabel);
 
          aktexitlabel:=oldaktexitlabel;
          aktexit2label:=oldaktexit2label;
@@ -723,7 +726,7 @@ implementation
 
     procedure ti386failnode.pass_2;
       begin
-        emitjmp(C_None,faillabel);
+        cg.a_jmp_always(exprasmlist,faillabel);
       end;
 
 
@@ -736,7 +739,24 @@ begin
 end.
 {
   $Log$
-  Revision 1.22  2002-04-04 19:06:11  peter
+  Revision 1.23  2002-05-12 16:53:17  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.22  2002/04/04 19:06:11  peter
     * removed unused units
     * use tlocation.size in cg.a_*loc*() routines
 

compiler/i386/n386inl.pas

@@ -39,7 +39,7 @@ implementation
     uses
       globtype,systems,
       cutils,verbose,globals,fmodule,
-      symconst,symtype,symdef,aasm,types,
+      symconst,symdef,aasm,types,
       cginfo,cgbase,pass_1,pass_2,
       cpubase,
       nbas,ncon,ncal,ncnv,nld,
@@ -88,26 +88,26 @@ implementation
                  getlabel(truelabel);
                  getlabel(falselabel);
                  secondpass(tcallparanode(left).left);
-                 maketojumpbool(tcallparanode(left).left,lr_load_regvars);
-                 emitlab(falselabel);
+                 maketojumpbool(exprasmlist,tcallparanode(left).left,lr_load_regvars);
+                 cg.a_label(exprasmlist,falselabel);
                  { erroraddr }
-                 emit_reg(A_PUSH,S_L,R_EBP);
+                 cg.a_param_reg(exprasmlist,OS_ADDR,R_EBP,4);
                  { lineno }
-                 emit_const(A_PUSH,S_L,aktfilepos.line);
+                 cg.a_param_const(exprasmlist,OS_INT,aktfilepos.line,3);
                  { filename string }
                  hp2:=cstringconstnode.createstr(current_module.sourcefiles.get_file_name(aktfilepos.fileindex),st_shortstring);
                  firstpass(hp2);
                  secondpass(hp2);
                  if codegenerror then
                   exit;
-                 emitpushreferenceaddr(hp2.location.reference);
+                 cg.a_paramaddr_ref(exprasmlist,hp2.location.reference,2);
                  hp2.free;
                  { push msg }
                  secondpass(tcallparanode(tcallparanode(left).right).left);
-                 emitpushreferenceaddr(tcallparanode(tcallparanode(left).right).left.location.reference);
+                 cg.a_paramaddr_ref(exprasmlist,tcallparanode(tcallparanode(left).right).left.location.reference,1);
                  { call }
-                 emitcall('FPC_ASSERT');
-                 emitlab(truelabel);
+                 cg.a_call_name(exprasmlist,'FPC_ASSERT');
+                 cg.a_label(exprasmlist,truelabel);
                  truelabel:=otlabel;
                  falselabel:=oflabel;
               end;
@@ -118,27 +118,28 @@ implementation
                  { for both cases load vmt }
                  if left.nodetype=typen then
                    begin
-                      location.register:=rg.getregisterint(exprasmlist);
-                      emit_sym_ofs_reg(A_MOV,
-                        S_L,newasmsymbol(tobjectdef(left.resulttype.def).vmt_mangledname),0,
-                        location.register);
+                      hregister:=rg.getaddressregister(exprasmlist);
+                      reference_reset_symbol(href,newasmsymbol(tobjectdef(left.resulttype.def).vmt_mangledname),0);
+                      cg.a_loadaddr_ref_reg(exprasmlist,href,hregister);
                    end
                  else
                    begin
                       secondpass(left);
                       location_release(exprasmlist,left.location);
-                      location.register:=rg.getregisterint(exprasmlist);
+                      hregister:=rg.getaddressregister(exprasmlist);
                       { load VMT pointer }
-                      inc(left.location.reference.offset,
-                        tobjectdef(left.resulttype.def).vmt_offset);
-                      emit_ref_reg(A_MOV,S_L,left.location.reference,location.register);
+                      inc(left.location.reference.offset,tobjectdef(left.resulttype.def).vmt_offset);
+                      cg.a_load_ref_reg(exprasmlist,OS_ADDR,left.location.reference,hregister);
                    end;
                  { in sizeof load size }
                  if inlinenumber=in_sizeof_x then
                    begin
-                      reference_reset_base(href,location.register,0);
-                      emit_ref_reg(A_MOV,S_L,href,location.register);
+                      reference_reset_base(href,hregister,0);
+                      rg.ungetaddressregister(exprasmlist,hregister);
+                      hregister:=rg.getregisterint(exprasmlist);
+                      cg.a_load_ref_reg(exprasmlist,OS_INT,href,hregister);
                    end;
+                 location.register:=hregister;
               end;
             in_length_x :
               begin
@@ -155,12 +156,11 @@ implementation
                      end
                     else
                      hregister:=left.location.register;
-                    reference_reset_base(href,hregister,-8);
                     getlabel(lengthlab);
-                    emit_reg_reg(A_OR,S_L,hregister,hregister);
-                    emitjmp(C_Z,lengthlab);
-                    emit_ref_reg(A_MOV,S_L,href,hregister);
-                    emitlab(lengthlab);
+                    cg.a_cmp_const_reg_label(exprasmlist,OS_ADDR,OC_EQ,0,hregister,lengthlab);
+                    reference_reset_base(href,hregister,-8);
+                    cg.a_load_ref_reg(exprasmlist,OS_INT,href,hregister);
+                    cg.a_label(exprasmlist,lengthlab);
                     location_reset(location,LOC_REGISTER,OS_INT);
                     location.register:=hregister;
                   end
@@ -182,7 +182,7 @@ implementation
 
                  { we need a value in a register }
                  location_copy(location,left.location);
-                 location_force_reg(location,cgsize,false);
+                 location_force_reg(exprasmlist,location,cgsize,false);
 
                  if cgsize in [OS_64,OS_S64] then
                   tcg64f32(cg).a_op64_const_reg(exprasmlist,cgop,1,0,
@@ -229,7 +229,7 @@ implementation
                     addvalue:=addvalue*get_ordinal_value(tcallparanode(tcallparanode(left).right).left)
                    else
                     begin
-                      location_force_reg(tcallparanode(tcallparanode(left).right).left.location,cgsize,false);
+                      location_force_reg(exprasmlist,tcallparanode(tcallparanode(left).right).left.location,cgsize,false);
                       hregister:=tcallparanode(tcallparanode(left).right).left.location.register;
                       hregisterhi:=tcallparanode(tcallparanode(left).right).left.location.registerhigh;
                       { insert multiply with addvalue if its >1 }
@@ -411,7 +411,7 @@ implementation
                          emitjmp(C_NP,l1);
                          emit_reg(A_FSTP,S_NO,R_ST0);
                          emit_none(A_FLDZ,S_NO);
-                         emitlab(l1);
+                         cg.a_label(exprasmlist,l1);
                          }
                       end;
                     in_arctan_extended:
@@ -468,7 +468,24 @@ begin
 end.
 {
   $Log$
-  Revision 1.39  2002-04-23 19:16:35  peter
+  Revision 1.40  2002-05-12 16:53:17  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.39  2002/04/23 19:16:35  peter
     * add pinline unit that inserts compiler supported functions using
       one or more statements
     * moved finalize and setlength from ninl to pinline

compiler/i386/n386ld.pas

@@ -48,11 +48,11 @@ implementation
     uses
       systems,
       cutils,verbose,globals,
-      symconst,symtype,symdef,symsym,symtable,aasm,types,
+      symconst,symdef,symsym,symtable,aasm,types,
       cginfo,cgbase,pass_2,
       nmem,ncon,ncnv,
       cpubase,cpuasm,
-      cga,tgobj,n386util,ncgutil,regvars,cgobj,cg64f32,rgobj,rgcpu;
+      cga,tgobj,n386util,regvars,cgobj,cg64f32,rgobj,rgcpu;
 
 {*****************************************************************************
                              SecondLoad
@@ -127,7 +127,7 @@ implementation
                          emit_ref(A_PUSH,S_L,href);
                          { the called procedure isn't allowed to change }
                          { any register except EAX                    }
-                         emitcall('FPC_RELOCATE_THREADVAR');
+                         cg.a_call_name(exprasmlist,'FPC_RELOCATE_THREADVAR');
 
                          location.reference.base:=rg.getregisterint(exprasmlist);
                          emit_reg_reg(A_MOV,S_L,R_EAX,location.reference.base);
@@ -567,8 +567,8 @@ implementation
                     LOC_REFERENCE,
                     LOC_CREFERENCE :
                       begin
-                        concatcopy(right.location.reference,
-                                   left.location.reference,left.resulttype.def.size,true,false);
+                        cg.g_concatcopy(exprasmlist,right.location.reference,
+                                        left.location.reference,left.resulttype.def.size,true,false);
                         { right.location is already released by concatcopy }
                         releaseright:=false;
                       end;
@@ -619,7 +619,7 @@ implementation
                   getlabel(hlabel);
                   { generate the leftnode for the true case, and
                     release the location }
-                  emitlab(truelabel);
+                  cg.a_label(exprasmlist,truelabel);
                   pushed:=maybe_push(left.registers32,right,false);
                   secondpass(left);
                   if pushed then
@@ -628,9 +628,9 @@ implementation
                     exit;
                   cg.a_load_const_loc(exprasmlist,1,left.location);
                   location_release(exprasmlist,left.location);
-                  emitjmp(C_None,hlabel);
+                  cg.a_jmp_always(exprasmlist,hlabel);
                   { generate the leftnode for the false case }
-                  emitlab(falselabel);
+                  cg.a_label(exprasmlist,falselabel);
                   pushed:=maybe_push(left.registers32,right,false);
                   secondpass(left);
                   if pushed then
@@ -638,7 +638,7 @@ implementation
                   if codegenerror then
                     exit;
                   cg.a_load_const_loc(exprasmlist,0,left.location);
-                  emitlab(hlabel);
+                  cg.a_label(exprasmlist,hlabel);
                 end;
               LOC_FLAGS :
                 begin
@@ -723,7 +723,24 @@ begin
 end.
 {
   $Log$
-  Revision 1.40  2002-04-26 15:19:05  peter
+  Revision 1.41  2002-05-12 16:53:17  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.40  2002/04/26 15:19:05  peter
     * use saveregisters for incr routines, saves also problems with
       the optimizer
 

compiler/i386/n386mat.pas

@@ -90,7 +90,7 @@ implementation
          else
            begin
               { put numerator in register }
-              location_force_reg(left.location,OS_INT,false);
+              location_force_reg(exprasmlist,left.location,OS_INT,false);
               hreg1:=left.location.register;
 
               if (nodetype=divn) and
@@ -144,7 +144,7 @@ implementation
                             emit_reg(A_INC,S_L,hreg1)
                           else
                             emit_const_reg(A_ADD,S_L,tordconstnode(right).value-1,hreg1);
-                          emitlab(hl);
+                          cg.a_label(exprasmlist,hl);
                           emit_const_reg(A_SAR,S_L,power,hreg1);
                         end
                     End
@@ -294,7 +294,7 @@ implementation
               location_reset(location,LOC_REGISTER,OS_64);
 
               { load left operator in a register }
-              location_force_reg(left.location,OS_64,false);
+              location_force_reg(exprasmlist,left.location,OS_64,false);
               hregisterhigh:=left.location.registerhigh;
               hregisterlow:=left.location.registerlow;
 
@@ -404,8 +404,8 @@ implementation
                         emitjmp(C_L,l1);
                         emit_reg_reg(A_XOR,S_L,hregisterlow,hregisterlow);
                         emit_reg_reg(A_XOR,S_L,hregisterhigh,hregisterhigh);
-                        emitjmp(C_None,l3);
-                        emitlab(l1);
+                        cg.a_jmp_always(exprasmlist,l3);
+                        cg.a_label(exprasmlist,l1);
                         emit_const_reg(A_CMP,S_L,32,R_ECX);
                         emitjmp(C_L,l2);
                         emit_const_reg(A_SUB,S_L,32,R_ECX);
@@ -413,13 +413,13 @@ implementation
                           hregisterlow);
                         emit_reg_reg(A_MOV,S_L,hregisterlow,hregisterhigh);
                         emit_reg_reg(A_XOR,S_L,hregisterlow,hregisterlow);
-                        emitjmp(C_None,l3);
-                        emitlab(l2);
+                        cg.a_jmp_always(exprasmlist,l3);
+                        cg.a_label(exprasmlist,l2);
                         emit_reg_reg_reg(A_SHLD,S_L,R_CL,
                           hregisterlow,hregisterhigh);
                         emit_reg_reg(A_SHL,S_L,R_CL,
                           hregisterlow);
-                        emitlab(l3);
+                        cg.a_label(exprasmlist,l3);
                      end
                    else
                      begin
@@ -430,8 +430,8 @@ implementation
                         emitjmp(C_L,l1);
                         emit_reg_reg(A_XOR,S_L,hregisterlow,hregisterlow);
                         emit_reg_reg(A_XOR,S_L,hregisterhigh,hregisterhigh);
-                        emitjmp(C_None,l3);
-                        emitlab(l1);
+                        cg.a_jmp_always(exprasmlist,l3);
+                        cg.a_label(exprasmlist,l1);
                         emit_const_reg(A_CMP,S_L,32,R_ECX);
                         emitjmp(C_L,l2);
                         emit_const_reg(A_SUB,S_L,32,R_ECX);
@@ -439,13 +439,13 @@ implementation
                           hregisterhigh);
                         emit_reg_reg(A_MOV,S_L,hregisterhigh,hregisterlow);
                         emit_reg_reg(A_XOR,S_L,hregisterhigh,hregisterhigh);
-                        emitjmp(C_None,l3);
-                        emitlab(l2);
+                        cg.a_jmp_always(exprasmlist,l3);
+                        cg.a_label(exprasmlist,l2);
                         emit_reg_reg_reg(A_SHRD,S_L,R_CL,
                           hregisterhigh,hregisterlow);
                         emit_reg_reg(A_SHR,S_L,R_CL,
                           hregisterhigh);
-                        emitlab(l3);
+                        cg.a_label(exprasmlist,l3);
 
                      end;
 
@@ -463,7 +463,7 @@ implementation
            begin
               { load left operators in a register }
               location_copy(location,left.location);
-              location_force_reg(location,OS_INT,false);
+              location_force_reg(exprasmlist,location,OS_INT,false);
 
               { shifting by a constant directly coded: }
               if (right.nodetype=ordconstn) then
@@ -618,7 +618,7 @@ implementation
 
               { load left operator in a register }
               location_copy(location,left.location);
-              location_force_reg(location,OS_64,false);
+              location_force_reg(exprasmlist,location,OS_64,false);
 
               emit_reg(A_NOT,S_L,location.registerhigh);
               emit_reg(A_NEG,S_L,location.registerlow);
@@ -738,7 +738,7 @@ implementation
                   truelabel:=falselabel;
                   falselabel:=hl;
                   secondpass(left);
-                  maketojumpbool(left,lr_load_regvars);
+                  maketojumpbool(exprasmlist,left,lr_load_regvars);
                   hl:=truelabel;
                   truelabel:=falselabel;
                   falselabel:=hl;
@@ -755,7 +755,7 @@ implementation
               LOC_REFERENCE,
               LOC_CREFERENCE :
                 begin
-                  location_force_reg(left.location,def_cgsize(resulttype.def),true);
+                  location_force_reg(exprasmlist,left.location,def_cgsize(resulttype.def),true);
                   location_release(exprasmlist,left.location);
                   emit_reg_reg(A_TEST,opsize,left.location.register,left.location.register);
                   location_reset(location,LOC_FLAGS,OS_NO);
@@ -806,7 +806,7 @@ implementation
            begin
               secondpass(left);
               location_copy(location,left.location);
-              location_force_reg(location,OS_64,false);
+              location_force_reg(exprasmlist,location,OS_64,false);
 
               emit_reg(A_NOT,S_L,location.registerlow);
               emit_reg(A_NOT,S_L,location.registerhigh);
@@ -815,7 +815,7 @@ implementation
           begin
             secondpass(left);
             location_copy(location,left.location);
-            location_force_reg(location,def_cgsize(resulttype.def),false);
+            location_force_reg(exprasmlist,location,def_cgsize(resulttype.def),false);
 
             opsize:=def_opsize(resulttype.def);
             emit_reg(A_NOT,opsize,location.register);
@@ -831,7 +831,24 @@ begin
 end.
 {
   $Log$
-  Revision 1.26  2002-04-04 19:06:12  peter
+  Revision 1.27  2002-05-12 16:53:17  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.26  2002/04/04 19:06:12  peter
     * removed unused units
     * use tlocation.size in cg.a_*loc*() routines
 

compiler/i386/n386mem.pas

@@ -53,7 +53,7 @@ implementation
       symconst,symtype,symdef,symsym,symtable,aasm,types,
       cginfo,cgbase,pass_2,
       pass_1,nld,ncon,nadd,
-      cpuinfo,cpubase,
+      cpubase,
       cgobj,cga,tgobj,rgobj,ncgutil,n386util;
 
 {*****************************************************************************
@@ -75,18 +75,21 @@ implementation
 *****************************************************************************}
 
     procedure ti386derefnode.pass_2;
-
+      var
+        oldglobalswitches : tglobalswitches;
       begin
+         oldglobalswitches:=aktglobalswitches;
+         exclude(aktglobalswitches,cs_checkpointer);
          inherited pass_2;
+         aktglobalswitches:=oldglobalswitches;
          if tpointerdef(left.resulttype.def).is_far then
           location.reference.segment:=R_FS;
          if not tpointerdef(left.resulttype.def).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');
+            cg.a_param_reg(exprasmlist, OS_ADDR,location.reference.base,1);
+            cg.a_call_name(exprasmlist,'FPC_CHECKPOINTER');
           end;
       end;
 
@@ -162,13 +165,10 @@ implementation
                         exit;
                      end;
                    rg.saveusedregisters(exprasmlist,pushed,all_registers);
-                   emitpushreferenceaddr(left.location.reference);
+                   cg.a_paramaddr_ref(exprasmlist,left.location.reference,1);
                    rg.saveregvars(exprasmlist,all_registers);
-                   if is_ansistring(left.resulttype.def) then
-                     emitcall('FPC_ANSISTR_UNIQUE')
-                   else
-                     emitcall('FPC_WIDESTR_UNIQUE');
-                   maybe_loadself;
+                   cg.a_call_name(exprasmlist,'FPC_'+Upper(tstringdef(left.resulttype.def).stringtypname)+'_UNIQUE');
+                   cg.g_maybe_loadself(exprasmlist);
                    rg.restoreusedregisters(exprasmlist,pushed);
                 end;
 
@@ -181,8 +181,7 @@ implementation
                   begin
                     location_release(exprasmlist,left.location);
                     location.reference.base:=rg.getregisterint(exprasmlist);
-                    emit_ref_reg(A_MOV,S_L,
-                      left.location.reference,location.reference.base);
+                    cg.a_load_ref_reg(exprasmlist,OS_ADDR,left.location.reference,location.reference.base);
                   end;
                 else
                   internalerror(2002032218);
@@ -193,10 +192,10 @@ implementation
               if (cs_check_range in aktlocalswitches) then
                 begin
                    rg.saveusedregisters(exprasmlist,pushed,all_registers);
-                   emit_reg(A_PUSH,S_L,location.reference.base);
+                   cg.a_param_reg(exprasmlist,OS_ADDR,location.reference.base,1);
                    rg.saveregvars(exprasmlist,all_registers);
-                   emitcall('FPC_ANSISTR_CHECKZERO');
-                   maybe_loadself;
+                   cg.a_call_name(exprasmlist,'FPC_'+Upper(tstringdef(left.resulttype.def).stringtypname)+'_CHECKZERO');
+                   cg.g_maybe_loadself(exprasmlist);
                    rg.restoreusedregisters(exprasmlist,pushed);
                 end;
 
@@ -237,8 +236,8 @@ implementation
                    rg.saveusedregisters(exprasmlist,pushed,all_registers);
                    emit_reg(A_PUSH,S_L,location.reference.base);
                    rg.saveregvars(exprasmlist,all_registers);
-                   emitcall('FPC_ANSISTR_CHECKZERO');
-                   maybe_loadself;
+                   cg.a_call_name(exprasmlist,'FPC_ANSISTR_CHECKZERO');
+                   cg.g_maybe_loadself(exprasmlist);
                    rg.restoreusedregisters(exprasmlist,pushed);
                 end;
 
@@ -283,24 +282,26 @@ implementation
                 end
               else if (left.resulttype.def.deftype=stringdef) then
                 begin
-                   if (tordconstnode(right).value=0) and not(is_shortstring(left.resulttype.def)) then
+                   if (tordconstnode(right).value=0) and
+                      not(is_shortstring(left.resulttype.def)) then
                      CGMessage(cg_e_can_access_element_zero);
 
                    if (cs_check_range in aktlocalswitches) then
-                     case tstringdef(left.resulttype.def).string_typ of
+                    begin
+                      case tstringdef(left.resulttype.def).string_typ of
                         { it's the same for ansi- and wide strings }
                         st_widestring,
                         st_ansistring:
                           begin
                              rg.saveusedregisters(exprasmlist,pushed,all_registers);
-                             push_int(tordconstnode(right).value);
+                             cg.a_param_const(exprasmlist,OS_INT,tordconstnode(right).value,2);
                              href:=location.reference;
                              dec(href.offset,7);
-                             emit_ref(A_PUSH,S_L,href);
+                             cg.a_param_ref(exprasmlist,OS_INT,href,1);
                              rg.saveregvars(exprasmlist,all_registers);
-                             emitcall('FPC_ANSISTR_RANGECHECK');
+                             cg.a_call_name(exprasmlist,'FPC_'+Upper(tstringdef(left.resulttype.def).stringtypname)+'_RANGECHECK');
                              rg.restoreusedregisters(exprasmlist,pushed);
-                             maybe_loadself;
+                             cg.g_maybe_loadself(exprasmlist);
                           end;
 
                         st_shortstring:
@@ -312,30 +313,25 @@ implementation
                           begin
                              {!!!!!!!!!!!!!!!!!}
                           end;
-                     end;
+                      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.def;
-              disposetree(right);
-              _p:=left;
-              putnode(p);
-              p:=_p;
-              }
+
               location_copy(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.def.deftype=arraydef) then
+                 { 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.def.deftype=arraydef) then
                 begin
                    extraoffset:=0;
                    if (right.nodetype=addn) then
@@ -433,7 +429,7 @@ implementation
                    end;
                end;
 
-              location_force_reg(right.location,OS_32,false);
+              location_force_reg(exprasmlist,right.location,OS_32,false);
 
               if isjump then
                begin
@@ -456,14 +452,14 @@ implementation
                          st_ansistring:
                            begin
                               rg.saveusedregisters(exprasmlist,pushed,all_registers);
-                              emit_reg(A_PUSH,S_L,right.location.register);
+                              cg.a_param_reg(exprasmlist,OS_INT,right.location.register,1);
                               href:=location.reference;
                               dec(href.offset,7);
-                              emit_ref(A_PUSH,S_L,href);
+                              cg.a_param_ref(exprasmlist,OS_INT,href,1);
                               rg.saveregvars(exprasmlist,all_registers);
-                              emitcall('FPC_ANSISTR_RANGECHECK');
+                              cg.a_call_name(exprasmlist,'FPC_'+Upper(tstringdef(left.resulttype.def).stringtypname)+'_RANGECHECK');
                               rg.restoreusedregisters(exprasmlist,pushed);
-                              maybe_loadself;
+                              cg.g_maybe_loadself(exprasmlist);
                            end;
                          st_shortstring:
                            begin
@@ -525,7 +521,24 @@ begin
 end.
 {
   $Log$
-  Revision 1.28  2002-04-21 19:02:07  peter
+  Revision 1.29  2002-05-12 16:53:17  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.28  2002/04/21 19:02:07  peter
     * removed newn and disposen nodes, the code is now directly
       inlined from pexpr
     * -an option that will write the secondpass nodes to the .s file, this

compiler/i386/n386obj.pas

@@ -37,7 +37,7 @@ uses
   fmodule,
   nobj,
   cpubase,
-  cga,tgobj,rgobj;
+  cga,tgobj,rgobj,cgobj;
 
    type
      ti386classheader=class(tclassheader)
@@ -122,7 +122,7 @@ procedure ti386classheader.cgintfwrapper(asmlist: TAAsmoutput; procdef: tprocdef
   begin
     { mov offset(%esp),%eax }
     reference_reset_base(href,R_ESP,getselfoffsetfromsp(procdef));
-    emit_ref_reg(A_MOV,S_L,href,R_EAX);
+    cg.a_load_ref_reg(exprasmlist,OS_ADDR,href,R_EAX);
   end;
 
   procedure loadvmttoeax;
@@ -195,9 +195,7 @@ begin
           op_oneaxmethodaddr(A_CALL);
         end
       else { case 1 }
-        begin
-          emitcall(procdef.mangledname);
-        end;
+        cg.a_call_name(exprasmlist,procdef.mangledname);
       { restore param1 value self to interface }
       adjustselfvalue(-ioffset);
     end
@@ -239,7 +237,24 @@ initialization
 end.
 {
   $Log$
-  Revision 1.6  2002-04-02 17:11:36  peter
+  Revision 1.7  2002-05-12 16:53:17  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.6  2002/04/02 17:11:36  peter
     * tlocation,treference update
     * LOC_CONSTANT added for better constant handling
     * secondadd splitted in multiple routines

compiler/i386/n386opt.pas

@@ -41,8 +41,13 @@ type
 
 implementation
 
-uses pass_1, types, htypechk, cginfo, cgbase, cpubase, cga,
-     tgobj, aasm, ncnv, ncon, pass_2, symdef, rgobj, cgobj;
+uses
+  pass_1, types, htypechk,
+  symdef,
+  aasm,
+  ncnv, ncon, pass_2,
+  cginfo, cgbase, cpubase,
+  tgobj, rgobj, cgobj, n386util;
 
 
 {*****************************************************************************
@@ -86,6 +91,7 @@ var
   href,href2 :  treference;
   hreg, lengthreg: tregister;
   checklength: boolean;
+  len : integer;
 begin
   { first, we have to more or less replicate some code from }
   { ti386addnode.pass_2                                     }
@@ -118,15 +124,15 @@ begin
         reference_release(exprasmlist,right.location.reference);
         { get register for the char }
         hreg := rg.makeregsize(rg.getregisterint(exprasmlist),OS_8);
-        emit_ref_reg(A_MOV,S_B,right.location.reference,hreg);
-       { I don't think a temp char exists, but it won't hurt (JM) }
-       tg.ungetiftemp(exprasmlist,right.location.reference);
+        cg.a_load_ref_reg(exprasmlist,OS_8,right.location.reference,hreg);
+        { I don't think a temp char exists, but it won't hurt (JM) }
+        tg.ungetiftemp(exprasmlist,right.location.reference);
       end
     else hreg := right.location.register;
 
   { load the current string length }
   lengthreg := rg.getregisterint(exprasmlist);
-  emit_ref_reg(A_MOVZX,S_BL,left.location.reference,lengthreg);
+  cg.a_load_ref_reg(exprasmlist,OS_8,left.location.reference,lengthreg);
 
   { do we have to check the length ? }
   if tg.istemp(left.location.reference) then
@@ -138,10 +144,10 @@ begin
       { is it already maximal? }
       getlabel(l);
       if tg.istemp(left.location.reference) then
-        emit_const_reg(A_CMP,S_L,255,lengthreg)
+        len:=255
       else
-        emit_const_reg(A_CMP,S_L,tstringdef(left.resulttype.def).len,lengthreg);
-      emitjmp(C_E,l);
+        len:=tstringdef(left.resulttype.def).len;
+      cg.a_cmp_const_reg_label(exprasmlist,OS_INT,OC_EQ,len,lengthreg,l)
     end;
 
   { no, so increase the length and add the new character }
@@ -156,7 +162,7 @@ begin
       { they're not free, so add the base reg to       }
       { the string length (since the index can         }
       { have a scalefactor) and use lengthreg as base  }
-      emit_reg_reg(A_ADD,S_L,href2.base,lengthreg);
+      cg.a_op_reg_reg(exprasmlist,OP_ADD,OS_INT,href2.base,lengthreg);
       href2.base := lengthreg;
     end
   else
@@ -175,17 +181,17 @@ begin
     begin
       { no new_reference(href2) because it's only }
       { used once (JM)                            }
-      emit_reg_ref(A_MOV,S_B,hreg,href2);
+      cg.a_load_reg_ref(exprasmlist,OS_8,hreg,href2);
       rg.ungetregister(exprasmlist,hreg);
     end
   else
-    emit_const_ref(A_MOV,S_B,tordconstnode(right).value,href2);
+    cg.a_load_const_ref(exprasmlist,OS_8,tordconstnode(right).value,href2);
   { increase the string length }
-  emit_reg(A_INC,S_B,rg.makeregsize(lengthreg,OS_8));
-  emit_reg_ref(A_MOV,S_B,rg.makeregsize(lengthreg,OS_8),left.location.reference);
+  cg.a_op_const_reg(exprasmlist,OP_ADD,1,rg.makeregsize(lengthreg,OS_8));
+  cg.a_load_reg_ref(exprasmlist,OS_8,rg.makeregsize(lengthreg,OS_8),left.location.reference);
   rg.ungetregisterint(exprasmlist,lengthreg);
   if checklength then
-    emitlab(l);
+    cg.a_label(exprasmlist,l);
   location_copy(location,left.location);
 end;
 
@@ -220,17 +226,17 @@ begin
   remove_non_regvars_from_loc(right.location,regstopush);
   rg.saveusedregisters(exprasmlist,pushedregs,regstopush);
   { push the maximum possible length of the result }
-  emitpushreferenceaddr(left.location.reference);
+  cg.a_paramaddr_ref(exprasmlist,left.location.reference,2);
   { the optimizer can more easily put the          }
   { deallocations in the right place if it happens }
   { too early than when it happens too late (if    }
   { the pushref needs a "lea (..),edi; push edi")  }
   reference_release(exprasmlist,right.location.reference);
-  emitpushreferenceaddr(right.location.reference);
+  cg.a_paramaddr_ref(exprasmlist,right.location.reference,1);
   rg.saveregvars(exprasmlist,regstopush);
-  emitcall('FPC_SHORTSTR_CONCAT');
+  cg.a_call_name(exprasmlist,'FPC_SHORTSTR_CONCAT');
   tg.ungetiftemp(exprasmlist,right.location.reference);
-  maybe_loadself;
+  cg.g_maybe_loadself(exprasmlist);
   rg.restoreusedregisters(exprasmlist,pushedregs);
   location_copy(location,left.location);
 end;
@@ -242,7 +248,24 @@ end.
 
 {
   $Log$
-  Revision 1.12  2002-04-25 20:16:40  peter
+  Revision 1.13  2002-05-12 16:53:17  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.12  2002/04/25 20:16:40  peter
     * moved more routines from cga/n386util
 
   Revision 1.11  2002/04/21 15:36:40  carl

compiler/i386/n386set.pas

@@ -44,7 +44,7 @@ interface
 implementation
 
     uses
-      globtype,systems,cpuinfo,
+      globtype,systems,
       verbose,globals,
       symconst,symdef,aasm,types,
       cginfo,cgbase,pass_2,
@@ -66,7 +66,7 @@ implementation
        { load first value in 32bit register }
          secondpass(left);
          if left.location.loc in [LOC_REGISTER,LOC_CREGISTER] then
-           location_force_reg(left.location,OS_32,false);
+           location_force_reg(exprasmlist,left.location,OS_32,false);
 
        { also a second value ? }
          if assigned(right) then
@@ -78,7 +78,7 @@ implementation
              if pushed then
                restore(left,false);
              if right.location.loc in [LOC_REGISTER,LOC_CREGISTER] then
-              location_force_reg(right.location,OS_32,false);
+              location_force_reg(exprasmlist,right.location,OS_32,false);
            end;
 
          { we doesn't modify the left side, we check only the type }
@@ -313,7 +313,7 @@ implementation
                   { it's always true since "in" is only allowed for bytes }
                   begin
                     emit_none(A_STC,S_NO);
-                    emitjmp(C_NONE,l);
+                    cg.a_jmp_always(exprasmlist,l);
                   end;
               end
              else
@@ -335,7 +335,7 @@ implementation
              { To compensate for not doing a second pass }
              right.location.reference.symbol:=nil;
              { Now place the end label }
-             emitlab(l);
+             cg.a_label(exprasmlist,l);
              case left.location.loc of
                LOC_REGISTER,
                LOC_CREGISTER :
@@ -457,8 +457,8 @@ implementation
                           emitjmp(C_NA,l);
                         { reset carry flag }
                           emit_none(A_CLC,S_NO);
-                          emitjmp(C_NONE,l2);
-                          emitlab(l);
+                          cg.a_jmp_always(exprasmlist,l2);
+                          cg.a_label(exprasmlist,l);
                         { We have to load the value into a register because
                           btl does not accept values only refs or regs (PFV) }
                           hr2:=rg.getregisterint(exprasmlist);
@@ -483,8 +483,8 @@ implementation
                        emitjmp(C_NA,l);
                      { reset carry flag }
                        emit_none(A_CLC,S_NO);
-                       emitjmp(C_NONE,l2);
-                       emitlab(l);
+                       cg.a_jmp_always(exprasmlist,l2);
+                       cg.a_label(exprasmlist,l);
                        location_release(exprasmlist,left.location);
                        hr:=rg.getregisterint(exprasmlist);
                        emit_ref_reg(A_MOV,S_L,left.location.reference,hr);
@@ -497,7 +497,7 @@ implementation
                        rg.ungetregisterint(exprasmlist,hr2);
                     end;
                   end;
-                  emitlab(l2);
+                  cg.a_label(exprasmlist,l2);
                 end { of right.location.loc=LOC_CONSTANT }
                { do search in a normal set which could have >32 elementsm
                  but also used if the left side contains higher values > 32 }
@@ -555,7 +555,7 @@ implementation
            lesslabel,greaterlabel : tasmlabel;
 
        begin
-         emitlab(p^._at);
+         cg.a_label(exprasmlist,p^._at);
          { calculate labels for left and right }
          if (p^.less=nil) then
            lesslabel:=elselabel
@@ -577,7 +577,7 @@ implementation
                    emitjmp(jmp_le,lesslabel);
                    emitjmp(jmp_gt,greaterlabel);
                 end;
-              emitjmp(C_None,p^.statement);
+              cg.a_jmp_always(exprasmlist,p^.statement);
            end
          else
            begin
@@ -585,7 +585,7 @@ implementation
               emitjmp(jmp_le,lesslabel);
               emit_const_reg(A_CMP,opsize,p^._high,hregister);
               emitjmp(jmp_gt,greaterlabel);
-              emitjmp(C_None,p^.statement);
+              cg.a_jmp_always(exprasmlist,p^.statement);
            end;
           if assigned(p^.less) then
            gentreejmp(p^.less);
@@ -616,7 +616,7 @@ implementation
                        emitjmp(C_NZ,l1);
                        emit_const_reg(A_CMP,S_L,longint(lo(int64(t^._low))),hregister);
                        emitjmp(C_Z,t^.statement);
-                       emitlab(l1);
+                       cg.a_label(exprasmlist,l1);
                     end
                   else
                     begin
@@ -641,7 +641,7 @@ implementation
                             emit_const_reg(A_CMP,S_L,longint(lo(int64(t^._low))),hregister);
                             { the comparisation of the low dword must be always unsigned! }
                             emitjmp(C_B,elselabel);
-                            emitlab(l1);
+                            cg.a_label(exprasmlist,l1);
                          end
                        else
                          begin
@@ -659,7 +659,7 @@ implementation
                        emit_const_reg(A_CMP,S_L,longint(lo(int64(t^._high))),hregister);
                        { the comparisation of the low dword must be always unsigned! }
                        emitjmp(C_BE,t^.statement);
-                       emitlab(l1);
+                       cg.a_label(exprasmlist,l1);
                     end
                   else
                     begin
@@ -678,7 +678,7 @@ implementation
            last:=0;
            first:=true;
            genitem(hp);
-           emitjmp(C_None,elselabel);
+           cg.a_jmp_always(exprasmlist,elselabel);
         end;
 
       procedure genlinearlist(hp : pcaserecord);
@@ -725,7 +725,7 @@ implementation
                     begin
                        { have we to ajust the first value ? }
                        if (t^._low>get_min_value(left.resulttype.def)) then
-                         gensub(t^._low);
+                         gensub(longint(t^._low));
                     end
                   else
                     begin
@@ -756,7 +756,7 @@ implementation
                 last:=0;
                 first:=true;
                 genitem(hp);
-                emitjmp(C_None,elselabel);
+                cg.a_jmp_always(exprasmlist,elselabel);
              end;
         end;
 
@@ -881,7 +881,7 @@ implementation
          { determines the size of the operand }
          opsize:=bytes2Sxx[left.resulttype.def.size];
          { copy the case expression to a register }
-         location_force_reg(left.location,def_cgsize(left.resulttype.def),false);
+         location_force_reg(exprasmlist,left.location,def_cgsize(left.resulttype.def),false);
          if opsize=S_Q then
           begin
             hregister:=left.location.registerlow;
@@ -997,10 +997,10 @@ implementation
               { don't come back to case line }
               aktfilepos:=exprasmList.getlasttaifilepos^;
               load_all_regvars(exprasmlist);
-              emitjmp(C_None,endlabel);
+              cg.a_jmp_always(exprasmlist,endlabel);
               hp:=tbinarynode(hp).left;
            end;
-         emitlab(elselabel);
+         cg.a_label(exprasmlist,elselabel);
          { ...and the else block }
          if assigned(elseblock) then
            begin
@@ -1008,7 +1008,7 @@ implementation
               secondpass(elseblock);
               load_all_regvars(exprasmlist);
            end;
-         emitlab(endlabel);
+         cg.a_label(exprasmlist,endlabel);
       end;
 
 
@@ -1019,7 +1019,24 @@ begin
 end.
 {
   $Log$
-  Revision 1.26  2002-04-25 20:16:40  peter
+  Revision 1.27  2002-05-12 16:53:17  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.26  2002/04/25 20:16:40  peter
     * moved more routines from cga/n386util
 
   Revision 1.25  2002/04/21 19:02:07  peter

compiler/i386/n386util.pas

@@ -38,25 +38,26 @@ interface
 {$ifdef TEMPS_NOT_PUSH}
     procedure restorefromtemp(p : tnode;isint64 : boolean);
 {$endif TEMPS_NOT_PUSH}
+    procedure remove_non_regvars_from_loc(const t: tlocation; var regs: tregisterset);
     procedure push_value_para(p:tnode;inlined,is_cdecl:boolean;
                               para_offset:longint;alignment : longint);
 
     procedure emitoverflowcheck(p:tnode);
     procedure firstcomplex(p : tbinarynode);
 
+
 implementation
 
     uses
        globtype,globals,systems,verbose,
        cutils,
        aasm,cpuasm,
-       symconst,symdef,symsym,symtable,
+       symconst,symdef,
 {$ifdef GDB}
        gdb,
 {$endif GDB}
        types,
        ncgutil,ncon,nld,
-       pass_1,pass_2,
        cgbase,tgobj,
        cga,regvars,cgobj,cg64f32,rgobj,rgcpu,cgcpu;
 
@@ -142,7 +143,7 @@ implementation
            begin
              if p.location.loc = LOC_FPUREGISTER then
                begin
-                 location_force_mem(p.location);
+                 location_force_mem(exprasmlist,p.location);
                  maybe_pushfpu:=true;
                end
              else
@@ -295,6 +296,29 @@ implementation
       end;
 {$endif TEMPS_NOT_PUSH}
 
+    { only usefull in startup code }
+    procedure remove_non_regvars_from_loc(const t: tlocation; var regs: tregisterset);
+      begin
+        case t.loc of
+          LOC_REGISTER:
+            begin
+              { can't be a regvar, since it would be LOC_CREGISTER then }
+              exclude(regs,t.register);
+              if t.registerhigh <> R_NO then
+                exclude(regs,t.registerhigh);
+            end;
+          LOC_CREFERENCE,LOC_REFERENCE:
+            begin
+              if not(cs_regalloc in aktglobalswitches) or
+                 (t.reference.base in rg.usableregsint) then
+                exclude(regs,t.reference.base);
+              if not(cs_regalloc in aktglobalswitches) or
+                 (t.reference.index in rg.usableregsint) then
+              exclude(regs,t.reference.index);
+            end;
+        end;
+      end;
+
 
     procedure push_value_para(p:tnode;inlined,is_cdecl:boolean;
                                 para_offset:longint;alignment : longint);
@@ -308,7 +332,7 @@ implementation
       begin
         { Move flags and jump in register to make it less complex }
         if p.location.loc in [LOC_FLAGS,LOC_JUMP] then
-         location_force_reg(p.location,def_cgsize(p.resulttype.def),false);
+         location_force_reg(exprasmlist,p.location,def_cgsize(p.resulttype.def),false);
 
         { Handle Floating point types differently }
         if p.resulttype.def.deftype=floatdef then
@@ -483,8 +507,8 @@ implementation
            emitjmp(C_NO,hl)
          else
            emitjmp(C_NB,hl);
-         emitcall('FPC_OVERFLOW');
-         emitlab(hl);
+         cg.a_call_name(exprasmlist,'FPC_OVERFLOW');
+         cg.a_label(exprasmlist,hl);
       end;
 
    { DO NOT RELY on the fact that the tnode is not yet swaped
@@ -530,7 +554,24 @@ implementation
 end.
 {
   $Log$
-  Revision 1.35  2002-04-25 20:16:40  peter
+  Revision 1.36  2002-05-12 16:53:18  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.35  2002/04/25 20:16:40  peter
     * moved more routines from cga/n386util
 
   Revision 1.34  2002/04/21 15:39:41  carl

compiler/i386/optbase.pas

@@ -1,7 +1,7 @@
 {
     $Id$
     Copyright (c) 1998-2002 by the Free Pascal development team
-    
+
     This routine contains the basic tables and information
     for the generic optimizers and cpu specific optimizations.
 
@@ -23,7 +23,7 @@
 }
 {# This unit should define cpu specific information which is required
    for the optimizers.
-}   
+}
 unit optbase;
 
 interface
@@ -79,7 +79,24 @@ end.
 
 {
   $Log$
-  Revision 1.1  2002-04-20 21:50:14  carl
+  Revision 1.2  2002-05-12 16:53:18  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.1  2002/04/20 21:50:14  carl
   + optimization cpu specific information base file
 
-}  
+}

compiler/i386/popt386.pas

@@ -41,7 +41,7 @@ Uses
 {$ifdef finaldestdebug}
   cobjects,
 {$endif finaldestdebug}
-  tainst,cpubase,optbase,cpuasm,DAOpt386,cginfo,rgobj;
+  tainst,cpuinfo,cpubase,cpuasm,DAOpt386,cginfo,rgobj;
 
 Function RegUsedAfterInstruction(Reg: TRegister; p: Tai; Var UsedRegs: TRegSet): Boolean;
 Begin
@@ -102,7 +102,7 @@ end;
 Procedure PrePeepHoleOpts(AsmL: TAAsmOutput; BlockStart, BlockEnd: Tai);
 var
   p,hp1: Tai;
-  l: longint;
+  l: Aword;
   tmpRef: treference;
 Begin
   P := BlockStart;
@@ -344,7 +344,7 @@ Begin
                             Taicpu(hp1).opcode := A_AND;
                             l := (1 shl (Taicpu(hp1).oper[0].val)) - 1;
                             Case Taicpu(p).opsize Of
-                              S_L: Taicpu(hp1).LoadConst(0,l Xor longint(-1));
+                              S_L: Taicpu(hp1).LoadConst(0,l Xor aword($ffffffff));
                               S_B: Taicpu(hp1).LoadConst(0,l Xor $ff);
                               S_W: Taicpu(hp1).LoadConst(0,l Xor $ffff);
                             End;
@@ -361,7 +361,7 @@ Begin
                                 Taicpu(p).opcode := A_AND;
                                 l := (1 shl (Taicpu(p).oper[0].val))-1;
                                 Case Taicpu(p).opsize Of
-                                  S_L: Taicpu(p).LoadConst(0,l Xor longint($ffffffff));
+                                  S_L: Taicpu(p).LoadConst(0,l Xor aword($ffffffff));
                                   S_B: Taicpu(p).LoadConst(0,l Xor $ff);
                                   S_W: Taicpu(p).LoadConst(0,l Xor $ffff);
                                 End;
@@ -377,7 +377,7 @@ Begin
                                   Case Taicpu(p).opsize Of
                                     S_B: Taicpu(p).LoadConst(0,l Xor $ff);
                                     S_W: Taicpu(p).LoadConst(0,l Xor $ffff);
-                                    S_L: Taicpu(p).LoadConst(0,l Xor longint($ffffffff));
+                                    S_L: Taicpu(p).LoadConst(0,l Xor aword($ffffffff));
                                   End;
                                   asml.remove(hp1);
                                   hp1.free;
@@ -563,7 +563,7 @@ Var
               (Taicpu(hp1).oper[1].typ = top_reg) And
               (Taicpu(hp1).oper[1].reg = Taicpu(p).oper[1].reg) Then
              Begin
-               Taicpu(p).LoadConst(0,Taicpu(p).oper[0].val-Taicpu(hp1).oper[0].val);
+               Taicpu(p).LoadConst(0,AWord(int64(Taicpu(p).oper[0].val)-int64(Taicpu(hp1).oper[0].val)));
                asml.Remove(hp1);
                hp1.free;
                If (Taicpu(p).oper[0].val = 0) Then
@@ -870,21 +870,24 @@ Begin
                           if (Base = Taicpu(p).oper[1].reg) then
                             begin
                               l := offset+offsetfixup;
-                              case l of
-                                1,-1:
-                                  begin
-                                    if l = 1 then
-                                      Taicpu(p).opcode := A_INC
-                                    else Taicpu(p).opcode := A_DEC;
-                                    Taicpu(p).loadreg(0,Taicpu(p).oper[1].reg);
-                                    Taicpu(p).ops := 1;
-                                  end;
-                                else
-                                  begin
-                                    Taicpu(p).opcode := A_ADD;
-                                    Taicpu(p).loadconst(0,offset+offsetfixup);
-                                  end;
-                              end;
+                              if (l=1) then
+                               begin
+                                 Taicpu(p).opcode := A_INC;
+                                 Taicpu(p).loadreg(0,Taicpu(p).oper[1].reg);
+                                 Taicpu(p).ops := 1
+                               end
+                              else
+                               if (l=-1) then
+                                begin
+                                  Taicpu(p).opcode := A_DEC;
+                                  Taicpu(p).loadreg(0,Taicpu(p).oper[1].reg);
+                                  Taicpu(p).ops := 1;
+                                end
+                              else
+                               begin
+                                 Taicpu(p).opcode := A_ADD;
+                                 Taicpu(p).loadconst(0,aword(l));
+                               end;
                             end;
                 End;
               A_MOV:
@@ -1213,7 +1216,7 @@ Begin
                       Case Taicpu(p).opsize of
                         S_BW:
                           Begin
-                            If (Taicpu(p).oper[0].reg = rg.makeregsize(Taicpu(p).oper[1].reg,OS_8)) And
+                            If (rg.makeregsize(Taicpu(p).oper[0].reg,OS_16)=Taicpu(p).oper[1].reg) And
                                Not(CS_LittleSize In aktglobalswitches)
                               Then
                                 {Change "movzbw %al, %ax" to "andw $0x0ffh, %ax"}
@@ -1241,7 +1244,7 @@ Begin
                           End;
                         S_BL:
                           Begin
-                            If (Taicpu(p).oper[0].reg = rg.makeregsize(Taicpu(p).oper[1].reg,OS_8)) And
+                            If (rg.makeregsize(Taicpu(p).oper[0].reg,OS_32)=Taicpu(p).oper[1].reg) And
                                Not(CS_LittleSize in aktglobalswitches)
                               Then
                                 {Change "movzbl %al, %eax" to "andl $0x0ffh, %eax"}
@@ -1269,7 +1272,7 @@ Begin
                           End;
                         S_WL:
                           Begin
-                            If (Taicpu(p).oper[0].reg = rg.makeregsize(Taicpu(p).oper[1].reg,OS_16)) And
+                            If (rg.makeregsize(Taicpu(p).oper[0].reg,OS_32)=Taicpu(p).oper[1].reg) And
                                Not(CS_LittleSize In aktglobalswitches)
                               Then
                                {Change "movzwl %ax, %eax" to "andl $0x0ffffh, %eax"}
@@ -2040,7 +2043,24 @@ End.
 
 {
   $Log$
-  Revision 1.23  2002-04-21 15:40:49  carl
+  Revision 1.24  2002-05-12 16:53:18  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.23  2002/04/21 15:40:49  carl
   * changeregsize -> rg.makeregsize
 
   Revision 1.22  2002/04/20 21:37:07  carl

compiler/i386/ra386.pas

@@ -65,7 +65,7 @@ const
   AsmOverride : array[0..AsmOverrides-1] of TasmOP =(
     A_SEGCS,A_SEGES,A_SEGDS,A_SEGFS,A_SEGGS,A_SEGSS
   );
-  
+
   CondAsmOps=3;
   CondAsmOp:array[0..CondAsmOps-1] of TasmOp=(
     A_CMOVcc, A_Jcc, A_SETcc
@@ -668,7 +668,24 @@ end;
 end.
 {
   $Log$
-  Revision 1.17  2002-04-15 19:12:09  carl
+  Revision 1.18  2002-05-12 16:53:18  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.17  2002/04/15 19:12:09  carl
   + target_info.size_of_pointer -> pointer_size
   + some cleanup of unused types/variables
   * move several constants from cpubase to their specific units

compiler/i386/ra386dir.pas

@@ -40,7 +40,7 @@ interface
        globals,verbose,
        systems,
        { aasm }
-       cpubase,aasm,
+       aasm,
        { symtable }
        symconst,symbase,symtype,symsym,symtable,types,
        { pass 1 }
@@ -304,7 +304,24 @@ initialization
 end.
 {
   $Log$
-  Revision 1.14  2002-04-15 19:12:09  carl
+  Revision 1.15  2002-05-12 16:53:18  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.14  2002/04/15 19:12:09  carl
   + target_info.size_of_pointer -> pointer_size
   + some cleanup of unused types/variables
   * move several constants from cpubase to their specific units

compiler/i386/rgcpu.pas

@@ -47,10 +47,10 @@ unit rgcpu;
           procedure ungetregisterfpu(list: taasmoutput; r : tregister); override;
 
           procedure ungetreference(list: taasmoutput; const ref : treference); override;
-          
-          {# Returns a subset register of the register r with the specified size. 
+
+          {# Returns a subset register of the register r with the specified size.
              WARNING: There is no clearing of the upper parts of the register,
-             if a 8-bit / 16-bit register is converted to a 32-bit register. 
+             if a 8-bit / 16-bit register is converted to a 32-bit register.
              It is up to the code generator to correctly zero fill the register
           }
           function makeregsize(reg: tregister; size: tcgsize): tregister; override;
@@ -80,7 +80,7 @@ unit rgcpu;
     uses
        systems,
        globals,verbose,
-       tgobj,cga;
+       tgobj;
 
 {************************************************************************}
 {                         routine helpers                                }
@@ -399,7 +399,7 @@ unit rgcpu;
 
 
     function trgcpu.makeregsize(reg: tregister; size: tcgsize): tregister;
-  
+
       var
         _result : topsize;
       begin
@@ -430,7 +430,24 @@ end.
 
 {
   $Log$
-  Revision 1.5  2002-04-21 15:43:32  carl
+  Revision 1.6  2002-05-12 16:53:18  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.5  2002/04/21 15:43:32  carl
   * changeregsize -> rg.makeregsize
   * changeregsize moved from cpubase to here
 

compiler/i386/rropt386.pas

@@ -35,7 +35,7 @@ Implementation
 
 Uses
   {$ifdef replaceregdebug}cutils,{$endif}
-  verbose,globals,cpuinfo,cpubase,cpuasm,daopt386,csopt386,cginfo,rgobj;
+  verbose,globals,cpubase,cpuasm,daopt386,csopt386,cginfo,rgobj;
 
 function canBeFirstSwitch(p: Taicpu; reg: tregister): boolean;
 { checks whether an operation on reg can be switched to another reg without an }
@@ -350,7 +350,24 @@ End.
 
 {
   $Log$
-  Revision 1.13  2002-04-21 15:42:17  carl
+  Revision 1.14  2002-05-12 16:53:18  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.13  2002/04/21 15:42:17  carl
   * changeregsize -> rg.makeregsize
 
   Revision 1.12  2002/04/20 21:37:08  carl

compiler/msg/errore.msg

@@ -1110,6 +1110,9 @@ type_e_array_index_enums_with_assign_not_possible=04038_E_enums with assignments
 %   Tenum = (a,b,e:=5);
 % \end{verbatim}
 % you cannot use it as index of an array.
+type_e_classes_not_related=04039_E_Class types "$1" and "$2" are not related
+type_w_classes_not_related=04040_W_Class types "$1" and "$2" are not related
+type_e_class_or_interface_type_expected=04041_E_class or interface type expected, but got "$1"
 % \end{description}
 #
 # Symtable

compiler/msgidx.inc

@@ -300,6 +300,9 @@ const
   type_w_mixed_signed_unsigned2=04036;
   type_e_typecast_wrong_size_for_assignment=04037;
   type_e_array_index_enums_with_assign_not_possible=04038;
+  type_e_classes_not_related=04039;
+  type_w_classes_not_related=04040;
+  type_e_class_or_interface_type_expected=04041;
   sym_e_id_not_found=05000;
   sym_f_internal_error_in_symtablestack=05001;
   sym_e_duplicate_id=05002;
@@ -604,9 +607,9 @@ const
   option_info=11024;
   option_help_pages=11025;
 
-  MsgTxtSize = 33931;
+  MsgTxtSize = 34086;
 
   MsgIdxMax : array[1..20] of longint=(
-    17,62,184,39,41,41,98,17,35,42,
+    17,62,184,42,41,41,98,17,35,42,
     30,1,1,1,1,1,1,1,1,1
   );

compiler/msgtxt.inc

@@ -1,7 +1,7 @@
 {$ifdef Delphi}
-const msgtxt : array[0..000141] of string[240]=(
+const msgtxt : array[0..000142] of string[240]=(
 {$else Delphi}
-const msgtxt : array[0..000141,1..240] of char=(
+const msgtxt : array[0..000142,1..240] of char=(
 {$endif Delphi}
   '01000_T_Compiler: $1'#000+
   '01001_D_Compiler OS: $1'#000+
@@ -340,497 +340,499 @@ const msgtxt : array[0..000141,1..240] of char=(
   ' check error'#000+
   '04037_E_Typecast has different size ($1 -> $2) in assignment'#000+
   '04038_E_enums with assignments can'#039't be used as array index'#000+
-  '05000_E_Identifier no','t found "$1"'#000+
+  '04039_E_Class types "','$1" and "$2" are not related'#000+
+  '04040_W_Class types "$1" and "$2" are not related'#000+
+  '04041_E_class or interface type expected, but got "$1"'#000+
+  '05000_E_Identifier not found "$1"'#000+
   '05001_F_Internal Error in SymTableStack()'#000+
-  '05002_E_Duplicate identifier "$1"'#000+
+  '05002_E_Duplicate identifier "','$1"'#000+
   '05003_H_Identifier already defined in $1 at line $2'#000+
   '05004_E_Unknown identifier "$1"'#000+
   '05005_E_Forward declaration not solved "$1"'#000+
-  '05006_F_Identifier type',' already defined as type'#000+
+  '05006_F_Identifier type already defined as type'#000+
   '05007_E_Error in type definition'#000+
-  '05008_E_Type identifier not defined'#000+
+  '05008_E_Type identifier not',' defined'#000+
   '05009_E_Forward type not resolved "$1"'#000+
   '05010_E_Only static variables can be used in static methods or outside'+
   ' methods'#000+
-  '05011_E_Invalid call to tvar','sym.mangledname()'#000+
+  '05011_E_Invalid call to tvarsym.mangledname()'#000+
   '05012_F_record or class type expected'#000+
-  '05013_E_Instances of classes or objects with an abstract method are no'+
-  't allowed'#000+
+  '05013_E_Instances of classes ','or objects with an abstract method are '+
+  'not allowed'#000+
   '05014_W_Label not defined "$1"'#000+
   '05015_E_Label used but not defined "$1"'#000+
-  '05016_E_Illegal label declaration',#000+
+  '05016_E_Illegal label declaration'#000+
   '05017_E_GOTO and LABEL are not supported (use switch -Sg)'#000+
   '05018_E_Label not found'#000+
-  '05019_E_identifier isn'#039't a label'#000+
+  '05','019_E_identifier isn'#039't a label'#000+
   '05020_E_label already defined'#000+
   '05021_E_illegal type declaration of set elements'#000+
-  '05022_E_Forward class definition not resolved',' "$1"'#000+
+  '05022_E_Forward class definition not resolved "$1"'#000+
   '05023_H_Unit "$1" not used in $2'#000+
   '05024_H_Parameter "$1" not used'#000+
-  '05025_N_Local variable "$1" not used'#000+
+  '05025_N_Local ','variable "$1" not used'#000+
   '05026_H_Value parameter "$1" is assigned but never used'#000+
   '05027_N_Local variable "$1" is assigned but never used'#000+
-  '05028_H_Local $1 "$2"',' is not used'#000+
+  '05028_H_Local $1 "$2" is not used'#000+
   '05029_N_Private field "$1.$2" is never used'#000+
-  '05030_N_Private field "$1.$2" is assigned but never used'#000+
+  '05030_N_Private field "$1.$2','" is assigned but never used'#000+
   '05031_N_Private method "$1.$2" never used'#000+
   '05032_E_Set type expected'#000+
   '05033_W_Function result does not seem to be set'#000+
-  '05034_W_Ty','pe "$1" is not aligned correctly in current record for C'#000+
-  '05035_E_Unknown record field identifier "$1"'#000+
+  '05034_W_Type "$1" is not aligned correctly in current record for C'#000+
+  '05035_E_Unknown record field',' identifier "$1"'#000+
   '05036_W_Local variable "$1" does not seem to be initialized'#000+
   '05037_W_Variable "$1" does not seem to be initialized'#000+
-  '05038_E_identifier ident','s no member "$1"'#000+
+  '05038_E_identifier idents no member "$1"'#000+
   '05039_B_Found declaration: $1'#000+
-  '05040_E_Data segment too large (max. 2GB)'#000+
+  '05040_E_Data segment too large (max. 2','GB)'#000+
   '06000_E_BREAK not allowed'#000+
   '06001_E_CONTINUE not allowed'#000+
   '06002_E_Expression too complicated - FPU stack overflow'#000+
   '06003_E_Illegal expression'#000+
-  '06004_E_Inval','id integer expression'#000+
+  '06004_E_Invalid integer expression'#000+
   '06005_E_Illegal qualifier'#000+
-  '06006_E_High range limit < low range limit'#000+
+  '06006_E_High range limit < low range ','limit'#000+
   '06007_E_Illegal counter variable'#000+
   '06008_E_Can'#039't determine which overloaded function to call'#000+
   '06009_E_Parameter list size exceeds 65535 bytes'#000+
-  '06010_E_Il','legal type conversion'#000+
-  '06011_D_Conversion between ordinals and pointers is not portable acros'+
-  's platforms'#000+
+  '06010_E_Illegal type conversion'#000+
+  '06011_D_Conversion between ordinals and pointers is not portabl','e acr'+
+  'oss platforms'#000+
   '06012_E_File types must be var parameters'#000+
   '06013_E_The use of a far pointer isn'#039't allowed there'#000+
-  '06014_E_illegal call by reference paramet','ers'#000+
+  '06014_E_illegal call by reference parameters'#000+
   '06015_E_EXPORT declared functions can'#039't be called'#000+
-  '06016_W_Possible illegal call of constructor or destructor (doesn'#039't'+
-  ' match to this context)'#000+
+  '06016_W_Possible illegal call o','f constructor or destructor (doesn'#039+
+  't match to this context)'#000+
   '06017_N_Inefficient code'#000+
   '06018_W_unreachable code'#000+
-  '06019_E_procedure call with stackframe ESP/SP',#000+
+  '06019_E_procedure call with stackframe ESP/SP'#000+
   '06020_E_Abstract methods can'#039't be called directly'#000+
-  '06021_F_Internal Error in getfloatreg(), allocation failure'#000+
+  '06021_F_Internal Error in getfloat','reg(), allocation failure'#000+
   '06022_F_Unknown float type'#000+
   '06023_F_SecondVecn() base defined twice'#000+
   '06024_F_Extended cg68k not supported'#000+
-  '06025_F_32-bit unsigned n','ot supported in MC68000 mode'#000+
+  '06025_F_32-bit unsigned not supported in MC68000 mode'#000+
   '06026_F_Internal Error in secondinline()'#000+
-  '06027_D_Register $1 weight $2 $3'#000+
+  '06027_D_Registe','r $1 weight $2 $3'#000+
   '06028_E_Stack limit excedeed in local routine'#000+
   '06029_D_Stack frame is omitted'#000+
   '06031_E_Object or class methods can'#039't be inline.'#000+
-  '06032_E_Pro','cvar calls can'#039't be inline.'#000+
+  '06032_E_Procvar calls can'#039't be inline.'#000+
   '06033_E_No code for inline procedure stored'#000+
-  '06034_E_Direct call of interrupt procedure "$1" is not possible'#000+
+  '06034_E_Direc','t call of interrupt procedure "$1" is not possible'#000+
   '06035_E_Element zero of an ansi/wide- or longstring can'#039't be acces'+
   'sed, use (set)length instead'#000+
-  '06036_E_I','nclude and exclude not implemented in this case'#000+
-  '06037_E_Constructors or destructors can not be called inside a '#039'wi'+
-  'th'#039' clause'#000+
+  '06036_E_Include and exclude not implemented in this case'#000+
+  '06037_E_Constructors or destructors c','an not be called inside a '#039'w'+
+  'ith'#039' clause'#000+
   '06038_E_Cannot call message handler method directly'#000+
   '06039_E_Jump in or outside of an exception block'#000+
-  '06040_E_Contro','l flow statements aren'#039't allowed in a finally bloc'+
-  'k'#000+
-  '07000_D_Starting $1 styled assembler parsing'#000+
+  '06040_E_Control flow statements aren'#039't allowed in a finally block'#000+
+  '07000_D_Starting $1 styled assemb','ler parsing'#000+
   '07001_D_Finished $1 styled assembler parsing'#000+
   '07002_E_Non-label pattern contains @'#000+
   '07003_W_Override operator not supported'#000+
-  '07004_E_Error buildin','g record offset'#000+
+  '07004_E_Error building record offset'#000+
   '07005_E_OFFSET used without identifier'#000+
-  '07006_E_TYPE used without identifier'#000+
+  '07006_E_TYPE used without iden','tifier'#000+
   '07007_E_Cannot use local variable or parameters here'#000+
   '07008_E_need to use OFFSET here'#000+
   '07009_E_need to use $ here'#000+
-  '07010_E_Cannot use multiple relocata','ble symbols'#000+
+  '07010_E_Cannot use multiple relocatable symbols'#000+
   '07011_E_Relocatable symbol can only be added'#000+
-  '07012_E_Invalid constant expression'#000+
+  '07012_E_Invalid constant exp','ression'#000+
   '07013_E_Relocatable symbol is not allowed'#000+
   '07014_E_Invalid reference syntax'#000+
   '07015_E_You can not reach $1 from that code'#000+
-  '07016_E_Local symbols/labels',' aren'#039't allowed as references'#000+
+  '07016_E_Local symbols/labels aren'#039't allowed as references'#000+
   '07017_E_Invalid base and index register usage'#000+
-  '07018_W_Possible error in object field handling'#000+
+  '07018_W_P','ossible error in object field handling'#000+
   '07019_E_Wrong scale factor specified'#000+
   '07020_E_Multiple index register usage'#000+
   '07021_E_Invalid operand type'#000+
-  '07022_E_Inva','lid string as opcode operand: $1'#000+
+  '07022_E_Invalid string as opcode operand: $1'#000+
   '07023_W_@CODE and @DATA not supported'#000+
-  '07024_E_Null label references are not allowed'#000+
+  '07024_E_Null l','abel references are not allowed'#000+
   '07025_E_Divide by zero in asm evaluator'#000+
   '07026_E_Illegal expression'#000+
   '07027_E_escape sequence ignored: $1'#000+
-  '07028_E_Invalid symb','ol reference'#000+
+  '07028_E_Invalid symbol reference'#000+
   '07029_W_Fwait can cause emulation problems with emu387'#000+
-  '07030_W_$1 without operand translated into $1P'#000+
+  '07030_W_$1 withou','t operand translated into $1P'#000+
   '07031_W_ENTER instruction is not supported by Linux kernel'#000+
   '07032_W_Calling an overload function in assembler'#000+
-  '07033_E_Unsuppor','ted symbol type for operand'#000+
+  '07033_E_Unsupported symbol type for operand'#000+
   '07034_E_Constant value out of bounds'#000+
-  '07035_E_Error converting decimal $1'#000+
+  '07035_E_Error conver','ting decimal $1'#000+
   '07036_E_Error converting octal $1'#000+
   '07037_E_Error converting binary $1'#000+
   '07038_E_Error converting hexadecimal $1'#000+
   '07039_H_$1 translated to $2'#000+
-  '07','040_W_$1 is associated to an overloaded function'#000+
-  '07041_E_Cannot use SELF outside a method'#000+
+  '07040_W_$1 is associated to an overloaded function'#000+
+  '07041_E_Cannot use SELF outside a me','thod'#000+
   '07042_E_Cannot use OLDEBP outside a nested procedure'#000+
   '07043_W_Procedures can'#039't return any value in asm code'#000+
   '07044_E_SEG not supported'#000+
-  '07045_E_Size suff','ix and destination or source size do not match'#000+
-  '07046_W_Size suffix and destination or source size do not match'#000+
+  '07045_E_Size suffix and destination or source size do not match'#000+
+  '07046_W_Size suffix and destination or',' source size do not match'#000+
   '07047_E_Assembler syntax error'#000+
   '07048_E_Invalid combination of opcode and operands'#000+
   '07049_E_Assembler syntax error in operand'#000+
-  '07050','_E_Assembler syntax error in constant'#000+
+  '07050_E_Assembler syntax error in constant'#000+
   '07051_E_Invalid String expression'#000+
-  '07052_W_constant with symbol $1 for not 32bit address'#000+
+  '07052_W_const','ant with symbol $1 for not 32bit address'#000+
   '07053_E_Unrecognized opcode $1'#000+
   '07054_E_Invalid or missing opcode'#000+
-  '07055_E_Invalid combination of prefix and opcode:',' $1'#000+
+  '07055_E_Invalid combination of prefix and opcode: $1'#000+
   '07056_E_Invalid combination of override and opcode: $1'#000+
-  '07057_E_Too many operands on line'#000+
+  '07057_E_Too many operands ','on line'#000+
   '07058_W_NEAR ignored'#000+
   '07059_W_FAR ignored'#000+
   '07060_E_Duplicate local symbol $1'#000+
   '07061_E_Undefined local symbol $1'#000+
   '07062_E_Unknown label identifier $1'#000+
-  '07','063_E_Invalid register name'#000+
+  '07063_E_Invalid register name'#000+
   '07064_E_Invalid floating point register name'#000+
-  '07065_E_NOR not supported'#000+
+  '07065_E_NOR ','not supported'#000+
   '07066_W_Modulo not supported'#000+
   '07067_E_Invalid floating point constant $1'#000+
   '07068_E_Invalid floating point expression'#000+
   '07069_E_Wrong symbol type'#000+
-  '0','7070_E_Cannot index a local var or parameter with a register'#000+
-  '07071_E_Invalid segment override expression'#000+
+  '07070_E_Cannot index a local var or parameter with a register'#000+
+  '07071_E_Invalid segment ','override expression'#000+
   '07072_W_Identifier $1 supposed external'#000+
   '07073_E_Strings not allowed as constants'#000+
   '07074_No type of variable specified'#000+
-  '07075_E_assembler ','code not returned to text section'#000+
+  '07075_E_assembler code not returned to text section'#000+
   '07076_E_Not a directive or local symbol $1'#000+
-  '07077_E_Using a defined name as a local label'#000+
+  '07077_E_','Using a defined name as a local label'#000+
   '07078_E_Dollar token is used without an identifier'#000+
   '07079_W_32bit constant created for address'#000+
-  '07080_N_.align is targe','t specific, use .balign or .p2align'#000+
-  '07081_E_Can'#039't access fields directly for parameters'#000+
+  '07080_N_.align is target specific, use .balign or .p2align'#000+
+  '07081_E_Can'#039't access fields directly for paramete','rs'#000+
   '07082_E_Can'#039't access fields of objects/classes directly'#000+
   '07083_E_No size specified and unable to determine the size of the oper'+
   'ands'#000+
-  '07084_E_Cannot use RE','SULT in this function'#000+
+  '07084_E_Cannot use RESULT in this function'#000+
   '07085_H_RESULT is register $1'#000+
-  '07086_W_"$1" without operand translated into "$1 %st,%st(1)"'#000+
+  '07086_W_"$1" without operand tran','slated into "$1 %st,%st(1)"'#000+
   '07087_W_"$1 %st(n)" translated into "$1 %st,%st(n)"'#000+
   '07088_W_"$1 %st(n)" translated into "$1 %st(n),%st"'#000+
-  '07089_E_Char < not allo','wed here'#000+
+  '07089_E_Char < not allowed here'#000+
   '07090_E_Char > not allowed here'#000+
   '07091_W_XDEF not supported'#000+
-  '07092_E_Invalid XDEF syntax'#000+
+  '07092_E_Invalid X','DEF syntax'#000+
   '07093_W_ALIGN not supported'#000+
   '07094_E_Inc and Dec cannot be together'#000+
   '07095_E_Invalid reglist for movem'#000+
   '07096_E_Reglist invalid for opcode'#000+
-  '07097_E_','68020 mode required'#000+
+  '07097_E_68020 mode required'#000+
   '08000_F_Too many assembler files'#000+
-  '08001_F_Selected assembler output not supported'#000+
+  '08001_F_Selected assembler outpu','t not supported'#000+
   '08002_F_Comp not supported'#000+
   '08003_F_Direct not support for binary writers'#000+
   '08004_E_Allocating of data is only allowed in bss section'#000+
-  '08005_F_','No binary writer selected'#000+
+  '08005_F_No binary writer selected'#000+
   '08006_E_Asm: Opcode $1 not in table'#000+
-  '08007_E_Asm: $1 invalid combination of opcode and operands'#000+
+  '08007_E_Asm: $1 invalid',' combination of opcode and operands'#000+
   '08008_E_Asm: 16 Bit references not supported'#000+
   '08009_E_Asm: Invalid effective address'#000+
-  '08010_E_Asm: Immediate or reference',' expected'#000+
+  '08010_E_Asm: Immediate or reference expected'#000+
   '08011_E_Asm: $1 value exceeds bounds $2'#000+
-  '08012_E_Asm: Short jump is out of range $1'#000+
+  '08012_E_Asm: Short jump is out of r','ange $1'#000+
   '08013_E_Asm: Undefined label $1'#000+
   '08014_E_Asm: Comp type not supported for this target'#000+
   '08015_E_Asm: Extended type not supported for this target'#000+
-  '08016','_E_Asm: Duplicate label $1'#000+
+  '08016_E_Asm: Duplicate label $1'#000+
   '09000_W_Source operating system redefined'#000+
-  '09001_I_Assembling (pipe) $1'#000+
+  '09001_I_Assembli','ng (pipe) $1'#000+
   '09002_E_Can'#039't create assember file: $1'#000+
   '09003_E_Can'#039't create object file: $1'#000+
   '09004_E_Can'#039't create archive file: $1'#000+
-  '09005_E_Assembler $1 not fou','nd, switching to external assembling'#000+
+  '09005_E_Assembler $1 not found, switching to external assembling'#000+
   '09006_T_Using assembler: $1'#000+
-  '09007_E_Error while assembling exitcode $1'#000+
+  '09007_E_Error while ','assembling exitcode $1'#000+
   '09008_E_Can'#039't call the assembler, error $1 switching to external a'+
   'ssembling'#000+
   '09009_I_Assembling $1'#000+
   '09010_I_Assembling smartlink $1'#000+
-  '09','011_W_Object $1 not found, Linking may fail !'#000+
-  '09012_W_Library $1 not found, Linking may fail !'#000+
+  '09011_W_Object $1 not found, Linking may fail !'#000+
+  '09012_W_Library $1 not found, Linking m','ay fail !'#000+
   '09013_E_Error while linking'#000+
   '09014_E_Can'#039't call the linker, switching to external linking'#000+
   '09015_I_Linking $1'#000+
-  '09016_E_Util $1 not found, switching ','to external linking'#000+
+  '09016_E_Util $1 not found, switching to external linking'#000+
   '09017_T_Using util $1'#000+
-  '09018_E_Creation of Executables not supported'#000+
+  '09018_E_Creation of Executables not support','ed'#000+
   '09019_E_Creation of Dynamic/Shared Libraries not supported'#000+
   '09020_I_Closing script $1'#000+
   '09021_E_resource compiler not found, switching to external mode'#000+
-  '090','22_I_Compiling resource $1'#000+
-  '09023_T_unit $1 can'#039't be static linked, switching to smart linking'+
-  #000+
+  '09022_I_Compiling resource $1'#000+
+  '09023_T_unit $1 can'#039't be static linked, switching to smart',' linki'+
+  'ng'#000+
   '09024_T_unit $1 can'#039't be smart linked, switching to static linking'+
   #000+
   '09025_T_unit $1 can'#039't be shared linked, switching to static linkin'+
   'g'#000+
-  '09026_E_uni','t $1 can'#039't be smart or static linked'#000+
-  '09027_E_unit $1 can'#039't be shared or static linked'#000+
+  '09026_E_unit $1 can'#039't be smart or static linked'#000+
+  '09027_E_unit $1 can'#039't be shared or static linked',#000+
   '09028_F_Can'#039't post process executable $1'#000+
   '09029_F_Can'#039't open executable $1'#000+
   '09030_X_Size of Code: $1 bytes'#000+
   '09031_X_Size of initialized data: $1 bytes'#000+
-  '09032_','X_Size of uninitialized data: $1 bytes'#000+
+  '09032_X_Size of uninitialized data: $1 bytes'#000+
   '09033_X_Stack space reserved: $1 bytes'#000+
-  '09034_X_Stack space commited: $1 bytes'#000+
+  '09034_X','_Stack space commited: $1 bytes'#000+
   '10000_T_Unitsearch: $1'#000+
   '10001_T_PPU Loading $1'#000+
   '10002_U_PPU Name: $1'#000+
   '10003_U_PPU Flags: $1'#000+
   '10004_U_PPU Crc: $1'#000+
-  '10005_U_PPU Ti','me: $1'#000+
+  '10005_U_PPU Time: $1'#000+
   '10006_U_PPU File too short'#000+
   '10007_U_PPU Invalid Header (no PPU at the begin)'#000+
-  '10008_U_PPU Invalid Version $1'#000+
+  '10','008_U_PPU Invalid Version $1'#000+
   '10009_U_PPU is compiled for an other processor'#000+
   '10010_U_PPU is compiled for an other target'#000+
   '10011_U_PPU Source: $1'#000+
-  '10012_U_Writ','ing $1'#000+
+  '10012_U_Writing $1'#000+
   '10013_F_Can'#039't Write PPU-File'#000+
   '10014_F_Error reading PPU-File'#000+
-  '10015_F_unexpected end of PPU-File'#000+
+  '10015_F_unexpected',' end of PPU-File'#000+
   '10016_F_Invalid PPU-File entry: $1'#000+
   '10017_F_PPU Dbx count problem'#000+
   '10018_E_Illegal unit name: $1'#000+
   '10019_F_Too much units'#000+
-  '10020_F_Circular uni','t reference between $1 and $2'#000+
+  '10020_F_Circular unit reference between $1 and $2'#000+
   '10021_F_Can'#039't compile unit $1, no sources available'#000+
-  '10022_F_Can'#039't find unit $1'#000+
+  '100','22_F_Can'#039't find unit $1'#000+
   '10023_W_Unit $1 was not found but $2 exists'#000+
   '10024_F_Unit $1 searched but $2 found'#000+
-  '10025_W_Compiling the system unit requires the -U','s switch'#000+
+  '10025_W_Compiling the system unit requires the -Us switch'#000+
   '10026_F_There were $1 errors compiling module, stopping'#000+
-  '10027_U_Load from $1 ($2) unit $3'#000+
+  '10027_U_Load from $1',' ($2) unit $3'#000+
   '10028_U_Recompiling $1, checksum changed for $2'#000+
   '10029_U_Recompiling $1, source found only'#000+
-  '10030_U_Recompiling unit, static lib is older than ','ppufile'#000+
+  '10030_U_Recompiling unit, static lib is older than ppufile'#000+
   '10031_U_Recompiling unit, shared lib is older than ppufile'#000+
-  '10032_U_Recompiling unit, obj and asm are older than ppufile'#000+
+  '10032_U_Recompilin','g unit, obj and asm are older than ppufile'#000+
   '10033_U_Recompiling unit, obj is older than asm'#000+
   '10034_U_Parsing interface of $1'#000+
-  '10035_U_Parsing implementation o','f $1'#000+
+  '10035_U_Parsing implementation of $1'#000+
   '10036_U_Second load for unit $1'#000+
   '10037_U_PPU Check file $1 time $2'#000+
-  '10038_H_Conditional $1 was not set at startup in last compilation of $'+
-  '2'#000+
+  '10038_H_Condit','ional $1 was not set at startup in last compilation of'+
+  ' $2'#000+
   '10039_H_Conditional $1 was set at startup in last compilation of $2'#000+
-  '10040_W_Can'#039't recompile unit ','$1, but found modifed include files'+
-  #000+
-  '10041_H_File $1 is newer than Release PPU file $2'#000+
+  '10040_W_Can'#039't recompile unit $1, but found modifed include files'#000+
+  '10041_H_File $1 is newer than Release PPU file $2',#000+
   '11000_$1 [options] <inputfile> [options]'#000+
   '11001_W_Only one source file supported'#000+
   '11002_W_DEF file can be created only for OS/2'#000+
-  '11003_E_nested response file','s are not supported'#000+
+  '11003_E_nested response files are not supported'#000+
   '11004_F_No source file name in command line'#000+
-  '11005_N_No option inside $1 config file'#000+
+  '11005_N_No option ins','ide $1 config file'#000+
   '11006_E_Illegal parameter: $1'#000+
   '11007_H_-? writes help pages'#000+
   '11008_F_Too many config files nested'#000+
   '11009_F_Unable to open file $1'#000+
-  '11010_D_R','eading further options from $1'#000+
+  '11010_D_Reading further options from $1'#000+
   '11011_W_Target is already set to: $1'#000+
-  '11012_W_Shared libs not supported on DOS platform, reverting to static'+
-  #000+
+  '11012_W_Shared li','bs not supported on DOS platform, reverting to stat'+
+  'ic'#000+
   '11013_F_too many IF(N)DEFs'#000+
   '11014_F_too many ENDIFs'#000+
   '11015_F_open conditional at the end of the file'#000+
-  '11','016_W_Debug information generation is not supported by this execut'+
-  'able'#000+
-  '11017_H_Try recompiling with -dGDB'#000+
+  '11016_W_Debug information generation is not supported by this executab'+
+  'le'#000+
+  '11017_H_Try re','compiling with -dGDB'#000+
   '11018_E_You are using the obsolete switch $1'#000+
   '11019_E_You are using the obsolete switch $1, please use $2'#000+
-  '11020_N_Switching assembler t','o default source writing assembler'#000+
-  '11021_W_Assembler output selected "$1" is not compatible with "$2"'#000+
+  '11020_N_Switching assembler to default source writing assembler'#000+
+  '11021_W_Assembler output selected "$1" is not comp','atible with "$2"'#000+
   '11022_W_"$1" assembler use forced'#000+
   '11026_T_Reading options from file $1'#000+
   '11027_T_Reading options from environment $1'#000+
-  '11028_D_Handling option',' "$1"'#000+
+  '11028_D_Handling option "$1"'#000+
   '11029__*** press enter ***'#000+
-  '11023_Free Pascal Compiler version $FPCVER [$FPCDATE] for $FPCTARGET'#010+
+  '11023_Free Pascal Compiler version $FPCVER [$FPCDATE','] for $FPCTARGET'+
+  #010+
   'Copyright (c) 1993-2002 by Florian Klaempfl'#000+
   '11024_Free Pascal Compiler version $FPCVER'#010+
   #010+
   'Compiler Date  : $FPCDATE'#010+
-  'Compiler Target: $FPCTAR','GET'#010+
+  'Compiler Target: $FPCTARGET'#010+
   #010+
   'Supported targets:'#010+
   '  $OSTARGETS'#010+
   #010+
-  'This program comes under the GNU General Public Licence'#010+
+  'This program comes under the GNU General Public',' Licence'#010+
   'For more information read COPYING.FPC'#010+
   #010+
   'Report bugs,suggestions etc to:'#010+
   '                 [email protected]'#000+
-  '11025_**0*_put + after a boolean swi','tch option to enable it, - to di'+
-  'sable it'#010+
-  '**1a_the compiler doesn'#039't delete the generated assembler file'#010+
+  '11025_**0*_put + after a boolean switch option to enable it, - to disa'+
+  'ble it'#010+
+  '**1a_the compiler doesn'#039't delete the generat','ed assembler file'#010+
   '**2al_list sourcecode lines in assembler file'#010+
   '**2ar_list register allocation/release info in assembler file'#010+
-  '**2at_list temp allocation/re','lease info in assembler file'#010+
+  '**2at_list temp allocation/release info in assembler file'#010+
   '**1b_generate browser info'#010+
-  '**2bl_generate local symbol info'#010+
+  '**2bl_generate local symbol i','nfo'#010+
   '**1B_build all modules'#010+
   '**1C<x>_code generation options:'#010+
   '**2CD_create also dynamic library (not supported)'#010+
-  '**2Ch<n>_<n> bytes heap (between 1023 and 671','07840)'#010+
+  '**2Ch<n>_<n> bytes heap (between 1023 and 67107840)'#010+
   '**2Ci_IO-checking'#010+
   '**2Cn_omit linking stage'#010+
-  '**2Co_check overflow of integer operations'#010+
+  '**2Co_check overflow of integer ope','rations'#010+
   '**2Cr_range checking'#010+
   '**2CR_verify object method call validity'#010+
   '**2Cs<n>_set stack size to <n>'#010+
   '**2Ct_stack checking'#010+
-  '**2CX_create also smartlinked lib','rary'#010+
+  '**2CX_create also smartlinked library'#010+
   '**1d<x>_defines the symbol <x>'#010+
   '*O1D_generate a DEF file'#010+
-  '*O2Dd<x>_set description to <x>'#010+
+  '*O2Dd<x>_set description',' to <x>'#010+
   '*O2Dw_PM application'#010+
   '**1e<x>_set path to executable'#010+
   '**1E_same as -Cn'#010+
   '**1F<x>_set file names and paths:'#010+
-  '**2FD<x>_sets the directory where to search ','for compiler utilities'#010+
+  '**2FD<x>_sets the directory where to search for compiler utilities'#010+
   '**2Fe<x>_redirect error output to <x>'#010+
-  '**2FE<x>_set exe/unit output path to <x>'#010+
+  '**2FE<x>_set exe/unit ou','tput path to <x>'#010+
   '**2Fi<x>_adds <x> to include path'#010+
   '**2Fl<x>_adds <x> to library path'#010+
   '*L2FL<x>_uses <x> as dynamic linker'#010+
   '**2Fo<x>_adds <x> to object path'#010+
-  '*','*2Fr<x>_load error message file <x>'#010+
+  '**2Fr<x>_load error message file <x>'#010+
   '**2Fu<x>_adds <x> to unit path'#010+
-  '**2FU<x>_set unit output path to <x>, overrides -FE'#010+
+  '**2FU<x>_set unit ','output path to <x>, overrides -FE'#010+
   '*g1g_generate debugger information:'#010+
   '*g2gg_use gsym'#010+
   '*g2gd_use dbx'#010+
   '*g2gh_use heap trace unit (for memory leak debugging)'#010+
-  '*g','2gl_use line info unit to show more info for backtraces'#010+
-  '*g2gc_generate checks for pointers'#010+
+  '*g2gl_use line info unit to show more info for backtraces'#010+
+  '*g2gc_generate checks for poi','nters'#010+
   '**1i_information'#010+
   '**2iD_return compiler date'#010+
   '**2iV_return compiler version'#010+
   '**2iSO_return compiler OS'#010+
   '**2iSP_return compiler processor'#010+
-  '**2iTO_return ta','rget OS'#010+
+  '**2iTO_return target OS'#010+
   '**2iTP_return target processor'#010+
   '**1I<x>_adds <x> to include path'#010+
-  '**1k<x>_Pass <x> to the linker'#010+
+  '**1k<x>_Pass ','<x> to the linker'#010+
   '**1l_write logo'#010+
   '**1n_don'#039't read the default config file'#010+
   '**1o<x>_change the name of the executable produced to <x>'#010+
-  '**1pg_generate profile ','code for gprof (defines FPC_PROFILE)'#010+
-  '*L1P_use pipes instead of creating temporary assembler files'#010+
+  '**1pg_generate profile code for gprof (defines FPC_PROFILE)'#010+
+  '*L1P_use pipes instead of creating temporary ass','embler files'#010+
   '**1S<x>_syntax options:'#010+
   '**2S2_switch some Delphi 2 extensions on'#010+
   '**2Sc_supports operators like C (*=,+=,/= and -=)'#010+
-  '**2Sa_include assertion cod','e.'#010+
+  '**2Sa_include assertion code.'#010+
   '**2Sd_tries to be Delphi compatible'#010+
-  '**2Se<x>_compiler stops after the <x> errors (default is 1)'#010+
+  '**2Se<x>_compiler stops after the <x> errors (','default is 1)'#010+
   '**2Sg_allow LABEL and GOTO'#010+
   '**2Sh_Use ansistrings'#010+
   '**2Si_support C++ styled INLINE'#010+
   '**2Sm_support macros like C (global)'#010+
-  '**2So_tries to be TP/BP',' 7.0 compatible'#010+
+  '**2So_tries to be TP/BP 7.0 compatible'#010+
   '**2Sp_tries to be gpc compatible'#010+
-  '**2Ss_constructor name must be init (destructor must be done)'#010+
+  '**2Ss_constructor name must be init ','(destructor must be done)'#010+
   '**2St_allow static keyword in objects'#010+
   '**1s_don'#039't call assembler and linker (only with -a)'#010+
-  '**2st_Generate script to link on target',#010+
+  '**2st_Generate script to link on target'#010+
   '**2sh_Generate script to link on host'#010+
   '**1u<x>_undefines the symbol <x>'#010+
-  '**1U_unit options:'#010+
+  '**1U_unit opt','ions:'#010+
   '**2Un_don'#039't check the unit name'#010+
   '**2Ur_generate release unit files'#010+
   '**2Us_compile a system unit'#010+
-  '**1v<x>_Be verbose. <x> is a combination of the followi','ng letters:'#010+
+  '**1v<x>_Be verbose. <x> is a combination of the following letters:'#010+
   '**2*_e : Show errors (default)       d : Show debug info'#010+
-  '**2*_w : Show warnings               u : Show unit info'#010+
+  '**2*_w : Show wa','rnings               u : Show unit info'#010+
   '**2*_n : Show notes                  t : Show tried/used files'#010+
-  '**2*_h : Show hints                  m : Show define','d macros'#010+
+  '**2*_h : Show hints                  m : Show defined macros'#010+
   '**2*_i : Show general info           p : Show compiled procedures'#010+
-  '**2*_l : Show linenumbers            c : Show conditionals'#010+
+  '**2*_l : S','how linenumbers            c : Show conditionals'#010+
   '**2*_a : Show everything             0 : Show nothing (except errors)'#010+
-  '**2*_b : Show all procedure         ',' r : Rhide/GCC compatibility mod'+
-  'e'#010+
-  '**2*_    declarations if an error    x : Executable info (Win32 only)'#010+
+  '**2*_b : Show all procedure          r : Rhide/GCC compatibility mode'#010+
+  '**2*_    declarations if an error    x : Executable',' info (Win32 only'+
+  ')'#010+
   '**2*_    occurs'#010+
   '**1X_executable options:'#010+
   '*L2Xc_link with the c library'#010+
   '**2Xs_strip all symbols from executable'#010+
-  '**2XD_try to link dynamic','          (defines FPC_LINK_DYNAMIC)'#010+
-  '**2XS_try to link static (default) (defines FPC_LINK_STATIC)'#010+
+  '**2XD_try to link dynamic          (defines FPC_LINK_DYNAMIC)'#010+
+  '**2XS_try to link static (default) (defines FPC_','LINK_STATIC)'#010+
   '**2XX_try to link smart            (defines FPC_LINK_SMART)'#010+
   '**0*_Processor specific options:'#010+
   '3*1A<x>_output format:'#010+
-  '3*2Aas_assemble using GNU ','AS'#010+
+  '3*2Aas_assemble using GNU AS'#010+
   '3*2Aasaout_assemble using GNU AS for aout (Go32v1)'#010+
-  '3*2Anasmcoff_coff (Go32v2) file using Nasm'#010+
+  '3*2Anasmcoff_coff (Go32v2) file',' using Nasm'#010+
   '3*2Anasmelf_elf32 (Linux) file using Nasm'#010+
   '3*2Anasmobj_obj file using Nasm'#010+
   '3*2Amasm_obj file using Masm (Microsoft)'#010+
-  '3*2Atasm_obj file using Tasm',' (Borland)'#010+
+  '3*2Atasm_obj file using Tasm (Borland)'#010+
   '3*2Acoff_coff (Go32v2) using internal writer'#010+
-  '3*2Apecoff_pecoff (Win32) using internal writer'#010+
+  '3*2Apecoff_pecoff (Win32) usi','ng internal writer'#010+
   '3*1R<x>_assembler reading style:'#010+
   '3*2Ratt_read AT&T style assembler'#010+
   '3*2Rintel_read Intel style assembler'#010+
-  '3*2Rdirect_copy assembler text d','irectly to assembler file'#010+
+  '3*2Rdirect_copy assembler text directly to assembler file'#010+
   '3*1O<x>_optimizations:'#010+
   '3*2Og_generate smaller code'#010+
-  '3*2OG_generate faster code (default)'#010+
+  '3*2OG_ge','nerate faster code (default)'#010+
   '3*2Or_keep certain variables in registers'#010+
   '3*2Ou_enable uncertain optimizations (see docs)'#010+
-  '3*2O1_level 1 optimizations (quick o','ptimizations)'#010+
+  '3*2O1_level 1 optimizations (quick optimizations)'#010+
   '3*2O2_level 2 optimizations (-O1 + slower optimizations)'#010+
-  '3*2O3_level 3 optimizations (-O2 repeatedly, max 5 times)'#010+
+  '3*2O3_level 3 ','optimizations (-O2 repeatedly, max 5 times)'#010+
   '3*2Op<x>_target processor:'#010+
   '3*3Op1_set target processor to 386/486'#010+
-  '3*3Op2_set target processor to Pentium/Pentiu','mMMX (tm)'#010+
+  '3*3Op2_set target processor to Pentium/PentiumMMX (tm)'#010+
   '3*3Op3_set target processor to PPro/PII/c6x86/K6 (tm)'#010+
-  '3*1T<x>_Target operating system:'#010+
+  '3*1T<x>_Target operat','ing system:'#010+
   '3*2TGO32V2_version 2 of DJ Delorie DOS extender'#010+
   '3*2TWDOSX DOS 32 Bit Extender'#010+
   '3*2TLINUX_Linux'#010+
-  '3*2Tnetware_Novell Netware Module (experimental)'#010,
+  '3*2Tnetware_Novell Netware Module (experimental)'#010+
   '3*2TOS2_OS/2 2.x'#010+
   '3*2TSUNOS_SunOS/Solaris'#010+
   '3*2TWin32_Windows 32 Bit'#010+
-  '3*1W<x>_Win32 target options'#010+
+  '3*1W<x>_Win32 targe','t options'#010+
   '3*2WB<x>_Set Image base to Hexadecimal <x> value'#010+
   '3*2WC_Specify console type application'#010+
   '3*2WD_Use DEFFILE to export functions of DLL or EXE'#010+
-  '3*2WF','_Specify full-screen type application (OS/2 only)'#010+
-  '3*2WG_Specify graphic type application'#010+
+  '3*2WF_Specify full-screen type application (OS/2 only)'#010+
+  '3*2WG_Specify graphic type applicat','ion'#010+
   '3*2WN_Do not generate relocation code (necessary for debugging)'#010+
   '3*2WR_Generate relocation code'#010+
   '6*1A<x>_output format'#010+
   '6*2Aas_Unix o-file using GNU AS'#010+
-  '6*','2Agas_GNU Motorola assembler'#010+
+  '6*2Agas_GNU Motorola assembler'#010+
   '6*2Amit_MIT Syntax (old GAS)'#010+
-  '6*2Amot_Standard Motorola assembler'#010+
+  '6*2Amot_Standard Motorola a','ssembler'#010+
   '6*1O_optimizations:'#010+
   '6*2Oa_turn on the optimizer'#010+
   '6*2Og_generate smaller code'#010+
   '6*2OG_generate faster code (default)'#010+
-  '6*2Ox_optimize maximum (still BUG','GY!!!)'#010+
+  '6*2Ox_optimize maximum (still BUGGY!!!)'#010+
   '6*2O2_set target processor to a MC68020+'#010+
   '6*1R<x>_assembler reading style:'#010+
-  '6*2RMOT_read motorola style assembler'#010+
+  '6*2R','MOT_read motorola style assembler'#010+
   '6*1T<x>_Target operating system:'#010+
   '6*2TAMIGA_Commodore Amiga'#010+
   '6*2TATARI_Atari ST/STe/TT'#010+
   '6*2TMACOS_Macintosh m68k'#010+
-  '6*2TLINUX_L','inux-68k'#010+
+  '6*2TLINUX_Linux-68k'#010+
   '6*2TPALMOS_PalmOS'#010+
   '**1*_'#010+
   '**1?_shows this help'#010+
-  '**1h_shows this help without waiting'#000
+  '**1h_shows this help without wa','iting'#000
 );

compiler/nadd.pas

@@ -58,7 +58,6 @@ implementation
       globtype,systems,
       cutils,verbose,globals,widestr,
       symconst,symtype,symdef,symsym,symtable,types,
-      cpuinfo,
       cgbase,
       htypechk,pass_1,
       nmat,ncnv,nld,ncon,nset,nopt,ncal,ninl,
@@ -112,12 +111,12 @@ implementation
            possible for array constructors }
          if is_array_constructor(left.resulttype.def) then
           begin
-            arrayconstructor_to_set(tarrayconstructornode(left));
+            arrayconstructor_to_set(left);
             resulttypepass(left);
           end;
          if is_array_constructor(right.resulttype.def) then
           begin
-            arrayconstructor_to_set(tarrayconstructornode(right));
+            arrayconstructor_to_set(right);
             resulttypepass(right);
           end;
 
@@ -210,9 +209,12 @@ implementation
                 end
               else if (lt=ordconstn) and (rt=ordconstn) then
                 begin
-                  { make left const type the biggest, this type will be used
-                    for orn,andn,xorn }
-                  if rd.size>ld.size then
+                  { make left const type the biggest (u32bit is bigger than
+                    s32bit for or,and,xor) }
+                  if (rd.size>ld.size) or
+                     ((torddef(rd).typ=u32bit) and
+                      (torddef(ld).typ=s32bit) and
+                      (nodetype in [orn,andn,xorn])) then
                     inserttypeconv(left,right.resulttype);
                 end;
 
@@ -671,12 +673,19 @@ implementation
                    end
                  else
                    begin
-                     if is_signed(ld) and
-                        not(is_constintnode(left) and
-                            (tordconstnode(left).value >= 0)) and
-                        (cs_check_range in aktlocalswitches) then
-                       CGMessage(type_w_mixed_signed_unsigned2);
-                     inserttypeconv(left,u32bittype);
+                     { and,or,xor work on bit patterns and don't care
+                       about the sign }
+                     if nodetype in [andn,orn,xorn] then
+                      inserttypeconv_explicit(left,u32bittype)
+                     else
+                      begin
+                        if is_signed(ld) and
+                           not(is_constintnode(left) and
+                               (tordconstnode(left).value >= 0)) and
+                           (cs_check_range in aktlocalswitches) then
+                          CGMessage(type_w_mixed_signed_unsigned2);
+                        inserttypeconv(left,u32bittype);
+                      end;
 
                      if is_signed(rd) and
                         { then ld = u32bit }
@@ -693,12 +702,19 @@ implementation
                        end
                      else
                        begin
-                         if is_signed(rd) and
-                            not(is_constintnode(right) and
-                                (tordconstnode(right).value >= 0)) and
-                            (cs_check_range in aktlocalswitches) then
-                           CGMessage(type_w_mixed_signed_unsigned2);
-                         inserttypeconv(right,u32bittype);
+                         { and,or,xor work on bit patterns and don't care
+                           about the sign }
+                         if nodetype in [andn,orn,xorn] then
+                          inserttypeconv_explicit(left,u32bittype)
+                         else
+                          begin
+                            if is_signed(rd) and
+                               not(is_constintnode(right) and
+                                   (tordconstnode(right).value >= 0)) and
+                               (cs_check_range in aktlocalswitches) then
+                              CGMessage(type_w_mixed_signed_unsigned2);
+                            inserttypeconv(right,u32bittype);
+                          end;
                        end;
                    end;
                end
@@ -1601,7 +1617,24 @@ begin
 end.
 {
   $Log$
-  Revision 1.46  2002-04-23 19:16:34  peter
+  Revision 1.47  2002-05-12 16:53:06  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.46  2002/04/23 19:16:34  peter
     * add pinline unit that inserts compiler supported functions using
       one or more statements
     * moved finalize and setlength from ninl to pinline

compiler/ncal.pas

@@ -742,7 +742,7 @@ implementation
       var
          hp,procs,hp2 : pprocdefcoll;
          pd : pprocdeflist;
-         oldcallprocdef : tprocdef;
+         oldcallprocdef : tabstractprocdef;
          def_from,def_to,conv_to : tdef;
          hpt : tnode;
          pt : tcallparanode;
@@ -1543,7 +1543,7 @@ implementation
          { insert type conversions }
          if assigned(left) then
           begin
-            aktcallprocdef:=tprocdef(procdefinition);
+            aktcallprocdef:=procdefinition;
             tcallparanode(left).insert_typeconv(tparaitem(procdefinition.Para.first),true);
           end;
 
@@ -1725,7 +1725,12 @@ implementation
                      { but for R^.Assign, R must be valid !! }
                      if (procdefinition.proctypeoption=potype_constructor) or
                         ((methodpointer.nodetype=loadn) and
-                        (not(oo_has_virtual in tobjectdef(methodpointer.resulttype.def).objectoptions))) then
+                         ((methodpointer.resulttype.def.deftype=classrefdef) or
+                          ((methodpointer.resulttype.def.deftype=objectdef) and
+                           not(oo_has_virtual in tobjectdef(methodpointer.resulttype.def).objectoptions)
+                          )
+                         )
+                        ) then
                        method_must_be_valid:=false
                      else
                        method_must_be_valid:=true;
@@ -1865,7 +1870,24 @@ begin
 end.
 {
   $Log$
-  Revision 1.72  2002-04-25 20:16:38  peter
+  Revision 1.73  2002-05-12 16:53:06  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.72  2002/04/25 20:16:38  peter
     * moved more routines from cga/n386util
 
   Revision 1.71  2002/04/20 21:32:23  carl

compiler/ncgbas.pas

@@ -1,6 +1,6 @@
 {
     $Id$
-    Copyright (c) 2000-2002 by Florian Klaempfl
+    Copyright (c) 2000 by Florian Klaempfl
 
     This unit implements some basic nodes
 
@@ -22,7 +22,7 @@
 }
 unit ncgbas;
 
-{$i fpcdefs.inc}
+{$i defines.inc}
 
 interface
 
@@ -63,10 +63,10 @@ interface
     uses
       globtype,systems,
       cutils,verbose,globals,
-      aasmbase,aasmtai,aasmcpu,symsym,
-      cpubase,
+      aasm,symsym,
+      cpubase,cpuasm,
       nflw,pass_2,
-      cgbase,cginfo,cgobj,tgobj,rgobj
+      cgbase,cgobj,tgobj,rgobj
       ;
 
 {*****************************************************************************
@@ -75,8 +75,6 @@ interface
 
     procedure tcgnothingnode.pass_2;
       begin
-         location_reset(location,LOC_VOID,OS_NO);
-
          { avoid an abstract rte }
       end;
 
@@ -87,23 +85,19 @@ interface
 
     procedure tcgstatementnode.pass_2;
       var
-         hp : tstatementnode;
+         hp : tnode;
       begin
-         location_reset(location,LOC_VOID,OS_NO);
-
          hp:=self;
          while assigned(hp) do
           begin
-            if assigned(hp.left) then
+            if assigned(tstatementnode(hp).right) then
              begin
-             {$ifndef newra}
                rg.cleartempgen;
-             {$endif newra}
-               secondpass(hp.left);
+               secondpass(tstatementnode(hp).right);
                { Compiler inserted blocks can return values }
-               location_copy(hp.location,hp.left.location);
+               location_copy(location,tstatementnode(hp).right.location);
              end;
-            hp:=tstatementnode(hp.right);
+            hp:=tstatementnode(hp).left;
           end;
       end;
 
@@ -116,14 +110,21 @@ interface
 
       procedure ReLabel(var p:tasmsymbol);
         begin
-          { Only relabel local tasmlabels }
-          if (p.defbind = AB_LOCAL) and
-             (p is tasmlabel) then
+          if p.proclocal then
            begin
              if not assigned(p.altsymbol) then
-               objectlibrary.GenerateAltSymbol(p);
+              begin
+                { generatealtsymbol will also increase the refs }
+                p.GenerateAltSymbol;
+                UsedAsmSymbolListInsert(p);
+              end
+             else
+              begin
+                { increase the refs, they will be decreased when the
+                  asmnode is destroyed }
+                inc(p.refs);
+              end;
              p:=p.altsymbol;
-             p.increfs;
            end;
         end;
 
@@ -133,11 +134,9 @@ interface
         i : longint;
         skipnode : boolean;
       begin
-         location_reset(location,LOC_VOID,OS_NO);
-
          if inlining_procedure then
            begin
-             objectlibrary.CreateUsedAsmSymbolList;
+             CreateUsedAsmSymbolList;
              localfixup:=aktprocdef.localst.address_fixup;
              parafixup:=aktprocdef.parast.address_fixup;
              hp:=tai(p_asm.first);
@@ -160,11 +159,7 @@ interface
                      begin
                        { remove cached insentry, because the new code can
                          require an other less optimized instruction }
-{$ifdef i386}
-{$ifndef NOAG386BIN}
                        taicpu(hp2).ResetPass1;
-{$endif}
-{$endif}
                        { fixup the references }
                        for i:=1 to taicpu(hp2).ops do
                         begin
@@ -205,8 +200,8 @@ interface
                 hp:=tai(hp.next);
               end;
              { restore used symbols }
-             objectlibrary.UsedAsmSymbolListResetAltSym;
-             objectlibrary.DestroyUsedAsmSymbolList;
+             UsedAsmSymbolListResetAltSym;
+             DestroyUsedAsmSymbolList;
            end
          else
            begin
@@ -217,6 +212,8 @@ interface
              else
                exprasmList.concatlist(p_asm);
            end;
+         if not (nf_object_preserved in flags) then
+           cg.g_maybe_loadself(exprasmlist);
        end;
 
 
@@ -225,29 +222,13 @@ interface
 *****************************************************************************}
 
     procedure tcgblocknode.pass_2;
-      var
-        hp : tstatementnode;
       begin
-        location_reset(location,LOC_VOID,OS_NO);
-
         { do second pass on left node }
         if assigned(left) then
          begin
-           hp:=tstatementnode(left);
-           while assigned(hp) do
-            begin
-              if assigned(hp.left) then
-               begin
-               {$ifndef newra}
-                 if nf_releasetemps in flags then
-                   rg.cleartempgen;
-               {$endif newra}
-                 secondpass(hp.left);
-                 location_copy(hp.location,hp.left.location);
-               end;
-              location_copy(location,hp.location);
-              hp:=tstatementnode(hp.right);
-            end;
+           secondpass(left);
+           { Compiler inserted blocks can return values }
+           location_copy(location,left.location);
          end;
       end;
 
@@ -256,21 +237,16 @@ interface
 *****************************************************************************}
 
     procedure tcgtempcreatenode.pass_2;
-      var
-        temptype : ttemptype;
       begin
-        location_reset(location,LOC_VOID,OS_NO);
-
         { if we're secondpassing the same tcgtempcreatenode twice, we have a bug }
         if tempinfo^.valid then
           internalerror(200108222);
 
         { get a (persistent) temp }
         if persistent then
-          temptype:=tt_persistant
+          tg.gettempofsizereferencepersistant(exprasmlist,size,tempinfo^.ref)
         else
-          temptype:=tt_normal;
-        tg.GetTemp(exprasmlist,size,temptype,tempinfo^.ref);
+          tg.gettempofsizereference(exprasmlist,size,tempinfo^.ref);
         tempinfo^.valid := true;
       end;
 
@@ -296,12 +272,10 @@ interface
 
     procedure tcgtempdeletenode.pass_2;
       begin
-        location_reset(location,LOC_VOID,OS_NO);
-
         if release_to_normal then
-          tg.ChangeTempType(exprasmlist,tempinfo^.ref,tt_normal)
+          tg.persistanttemptonormal(tempinfo^.ref.offset)
         else
-          tg.UnGetTemp(exprasmlist,tempinfo^.ref);
+          tg.ungetpersistanttempreference(exprasmlist,tempinfo^.ref);
       end;
 
 
@@ -316,85 +290,7 @@ begin
 end.
 {
   $Log$
-  Revision 1.32  2002-04-25 20:15:39  florian
-    * block nodes within expressions shouldn't release the used registers,
-      fixed using a flag till the new rg is ready
-
-  Revision 1.31  2003/04/22 23:50:22  peter
-    * firstpass uses expectloc
-    * checks if there are differences between the expectloc and
-      location.loc from secondpass in EXTDEBUG
-
-  Revision 1.30  2003/04/17 07:50:24  daniel
-    * Some work on interference graph construction
-
-  Revision 1.29  2003/03/28 19:16:56  peter
-    * generic constructor working for i386
-    * remove fixed self register
-    * esi added as address register for i386
-
-  Revision 1.28  2002/11/27 15:33:19  peter
-    * fixed relabeling to relabel only tasmlabel (formerly proclocal)
-
-  Revision 1.27  2002/11/27 02:37:13  peter
-    * case statement inlining added
-    * fixed inlining of write()
-    * switched statementnode left and right parts so the statements are
-      processed in the correct order when getcopy is used. This is
-      required for tempnodes
-
-  Revision 1.26  2002/11/17 16:31:56  carl
-    * memory optimization (3-4%) : cleanup of tai fields,
-       cleanup of tdef and tsym fields.
-    * make it work for m68k
-
-  Revision 1.25  2002/11/15 16:29:30  peter
-    * made tasmsymbol.refs private (merged)
-
-  Revision 1.24  2002/11/15 01:58:51  peter
-    * merged changes from 1.0.7 up to 04-11
-      - -V option for generating bug report tracing
-      - more tracing for option parsing
-      - errors for cdecl and high()
-      - win32 import stabs
-      - win32 records<=8 are returned in eax:edx (turned off by default)
-      - heaptrc update
-      - more info for temp management in .s file with EXTDEBUG
-
-  Revision 1.23  2002/08/23 16:14:48  peter
-    * tempgen cleanup
-    * tt_noreuse temp type added that will be used in genentrycode
-
-  Revision 1.22  2002/08/11 14:32:26  peter
-    * renamed current_library to objectlibrary
-
-  Revision 1.21  2002/08/11 13:24:11  peter
-    * saving of asmsymbols in ppu supported
-    * asmsymbollist global is removed and moved into a new class
-      tasmlibrarydata that will hold the info of a .a file which
-      corresponds with a single module. Added librarydata to tmodule
-      to keep the library info stored for the module. In the future the
-      objectfiles will also be stored to the tasmlibrarydata class
-    * all getlabel/newasmsymbol and friends are moved to the new class
-
-  Revision 1.20  2002/07/01 18:46:22  peter
-    * internal linker
-    * reorganized aasm layer
-
-  Revision 1.19  2002/05/18 13:34:09  peter
-    * readded missing revisions
-
-  Revision 1.18  2002/05/16 19:46:37  carl
-  + defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
-  + try to fix temp allocation (still in ifdef)
-  + generic constructor calls
-  + start of tassembler / tmodulebase class cleanup
-
-  Revision 1.16  2002/05/13 19:54:37  peter
-    * removed n386ld and n386util units
-    * maybe_save/maybe_restore added instead of the old maybe_push
-
-  Revision 1.15  2002/05/12 16:53:07  peter
+  Revision 1.15  2002-05-12 16:53:07  peter
     * moved entry and exitcode to ncgutil and cgobj
     * foreach gets extra argument for passing local data to the
       iterator function
@@ -444,4 +340,52 @@ end.
     - list field removed of the tnode class because it's not used currently
       and can cause hard-to-find bugs
 
+  Revision 1.10  2001/12/31 16:54:14  peter
+    * fixed inline crash with assembler routines
+
+  Revision 1.9  2001/11/02 22:58:01  peter
+    * procsym definition rewrite
+
+  Revision 1.8  2001/10/25 21:22:35  peter
+    * calling convention rewrite
+
+  Revision 1.7  2001/08/26 13:36:39  florian
+    * some cg reorganisation
+    * some PPC updates
+
+  Revision 1.6  2001/08/24 13:47:27  jonas
+    * moved "reverseparameters" from ninl.pas to ncal.pas
+    + support for non-persistent temps in ttempcreatenode.create, for use
+      with typeconversion nodes
+
+  Revision 1.5  2001/08/23 14:28:35  jonas
+    + tempcreate/ref/delete nodes (allows the use of temps in the
+      resulttype and first pass)
+    * made handling of read(ln)/write(ln) processor independent
+    * moved processor independent handling for str and reset/rewrite-typed
+      from firstpass to resulttype pass
+    * changed names of helpers in text.inc to be generic for use as
+      compilerprocs + added "iocheck" directive for most of them
+    * reading of ordinals is done by procedures instead of functions
+      because otherwise FPC_IOCHECK overwrote the result before it could
+      be stored elsewhere (range checking still works)
+    * compilerprocs can now be used in the system unit before they are
+      implemented
+    * added note to errore.msg that booleans can't be read using read/readln
+
+  Revision 1.4  2001/06/02 19:22:15  peter
+    * refs count for relabeled asmsymbols fixed
+
+  Revision 1.3  2001/05/18 22:31:06  peter
+    * tasmnode.pass_2 is independent of cpu, moved to ncgbas
+    * include ncgbas for independent nodes
+
+  Revision 1.2  2001/04/13 01:22:08  peter
+    * symtable change to classes
+    * range check generation and errors fixed, make cycle DEBUG=1 works
+    * memory leaks fixed
+
+  Revision 1.1  2000/10/14 10:14:50  peter
+    * moehrendorf oct 2000 rewrite
+
 }

compiler/ncgcnv.pas

@@ -54,6 +54,10 @@ interface
          procedure pass_2;override;
        end;
 
+       tcgasnode = class(tasnode)
+         procedure pass_2;override;
+       end;
+
   implementation
 
     uses
@@ -63,7 +67,7 @@ interface
       cpubase,cpuinfo,
       pass_2,
       cginfo,cgbase,
-      cga,cgobj,cgcpu,
+      cgobj,cgcpu,
       ncgutil,
       tgobj,rgobj
       ;
@@ -84,7 +88,7 @@ interface
           begin
             { reuse the left location by default }
             location_copy(location,left.location);
-            location_force_reg(location,newsize,false);
+            location_force_reg(exprasmlist,location,newsize,false);
           end
         else
           begin
@@ -267,7 +271,7 @@ interface
 
       begin
         { method pointer ? }
-        if assigned(tcallnode(left).left) then
+        if assigned(tunarynode(left).left) then
           begin
              location_copy(location,left.location);
           end
@@ -296,7 +300,7 @@ interface
          if not((nf_explizit in flags) and
                 (left.resulttype.def.size=resulttype.def.size) and
                 (left.location.loc in [LOC_REFERENCE,LOC_CREFERENCE,LOC_CREGISTER])) then
-           location_force_reg(location,def_cgsize(resulttype.def),false);
+           location_force_reg(exprasmlist,location,def_cgsize(resulttype.def),false);
          truelabel:=oldtruelabel;
          falselabel:=oldfalselabel;
       end;
@@ -395,7 +399,7 @@ interface
           moving to memory before the new size is set }
         if (resulttype.def.deftype=floatdef) and
            (location.loc=LOC_CONSTANT) then
-         location_force_mem(location);
+         location_force_mem(exprasmlist,location);
 
         { but use the new size, but we don't know the size of all arrays }
         location.size:=def_cgsize(resulttype.def);
@@ -435,13 +439,53 @@ interface
 {$endif TESTOBJEXT2}
       end;
 
+
+    procedure tcgasnode.pass_2;
+      var
+        pushed : tpushedsaved;
+      begin
+        { instance to check }
+        secondpass(left);
+        rg.saveusedregisters(exprasmlist,pushed,all_registers);
+        cg.a_param_loc(exprasmlist,left.location,2);
+        { type information }
+        secondpass(right);
+        cg.a_param_loc(exprasmlist,right.location,1);
+        location_release(exprasmlist,right.location);
+        { call helper }
+        cg.a_call_name(exprasmlist,'FPC_DO_AS');
+        cg.g_maybe_loadself(exprasmlist);
+        rg.restoreusedregisters(exprasmlist,pushed);
+
+        location_copy(location,left.location);
+      end;
+
+
 begin
   ctypeconvnode := tcgtypeconvnode;
+  casnode := tcgasnode;
 end.
 
 {
   $Log$
-  Revision 1.11  2002-04-21 19:02:03  peter
+  Revision 1.12  2002-05-12 16:53:07  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.11  2002/04/21 19:02:03  peter
     * removed newn and disposen nodes, the code is now directly
       inlined from pexpr
     * -an option that will write the secondpass nodes to the .s file, this

compiler/ncgflw.pas

@@ -71,7 +71,7 @@ implementation
       cginfo,cgbase,pass_2,
       cpubase,cpuasm,cpuinfo,
       nld,ncon,
-      cga,tgobj,rgobj,
+      tgobj,rgobj,
       ncgutil,
       regvars,cgobj,cgcpu,cg64f32;
 
@@ -128,7 +128,7 @@ implementation
          rg.cleartempgen;
          secondpass(left);
 
-         maketojumpbool(left,lr_load_regvars);
+         maketojumpbool(exprasmlist,left,lr_load_regvars);
          cg.a_label(exprasmlist,lbreak);
          truelabel:=otlabel;
          falselabel:=oflabel;
@@ -171,7 +171,7 @@ implementation
              org_list := exprasmlist;
              exprasmlist := taasmoutput.create;
            end;
-         maketojumpbool(left,lr_dont_load_regvars);
+         maketojumpbool(exprasmlist,left,lr_dont_load_regvars);
 
          if cs_regalloc in aktglobalswitches then
            org_regvar_loaded := rg.regvar_loaded;
@@ -330,7 +330,7 @@ implementation
          { produce start assignment }
          rg.cleartempgen;
          secondpass(left);
-         count_var_is_signed:=is_signed(torddef(t2.resulttype.def));
+         count_var_is_signed:=is_signed(t2.resulttype.def);
 
          if nf_backward in flags then
            if count_var_is_signed then
@@ -611,7 +611,24 @@ begin
 end.
 {
   $Log$
-  Revision 1.13  2002-04-21 15:24:38  carl
+  Revision 1.14  2002-05-12 16:53:07  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.13  2002/04/21 15:24:38  carl
   + a_jmp_cond -> a_jmp_always (a_jmp_cond is NOT portable)
   + changeregsize -> rg.makeregsize
 

compiler/ncgld.pas

@@ -40,10 +40,10 @@ implementation
     uses
       systems,
       verbose,globals,
-      symconst,symtype,symdef,symsym,symtable,aasm,types,
+      symconst,symtype,symdef,aasm,types,
       cginfo,cgbase,pass_2,
-      cpubase,cpuasm,
-      cga,tgobj,ncgutil,regvars,cgobj,cg64f32,rgobj,rgcpu;
+      cpubase,
+      tgobj,ncgutil,cgobj,cg64f32,rgobj,rgcpu;
 
 {*****************************************************************************
                            SecondArrayConstruct
@@ -186,7 +186,7 @@ implementation
                   begin
                     if vaddr then
                      begin
-                       location_force_mem(hp.left.location);
+                       location_force_mem(exprasmlist,hp.left.location);
                        cg.a_paramaddr_ref(exprasmlist,hp.left.location.reference,-1);
                        location_release(exprasmlist,hp.left.location);
                        if freetemp then
@@ -202,7 +202,7 @@ implementation
                     inc(href.offset,4);
                     if vaddr then
                      begin
-                       location_force_mem(hp.left.location);
+                       location_force_mem(exprasmlist,hp.left.location);
                        tmpreg:=cg.get_scratch_reg(exprasmlist);
                        cg.a_loadaddr_ref_reg(exprasmlist,hp.left.location.reference,tmpreg);
                        cg.a_load_reg_ref(exprasmlist,cg.reg_cgsize(tmpreg),tmpreg,href);
@@ -260,7 +260,24 @@ begin
 end.
 {
   $Log$
-  Revision 1.2  2002-04-21 15:24:38  carl
+  Revision 1.3  2002-05-12 16:53:07  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.2  2002/04/21 15:24:38  carl
   + a_jmp_cond -> a_jmp_always (a_jmp_cond is NOT portable)
   + changeregsize -> rg.makeregsize
 

compiler/ncgmem.pas

@@ -73,7 +73,7 @@ implementation
       globtype,systems,
       cutils,verbose,globals,
       symconst,symdef,symsym,aasm,
-      cginfo,cgbase,pass_2,
+      cgbase,pass_2,
       nld,ncon,nadd,
       cpuinfo,cpubase,cgobj,cgcpu,
       tgobj,rgobj
@@ -83,7 +83,6 @@ implementation
   {$else}
       ,strings
   {$endif}
-      ,cga
       ,symbase
       ,gdb
 {$endif GDB}
@@ -239,10 +238,10 @@ implementation
          end;
          if (cs_gdb_heaptrc in aktglobalswitches) and
             (cs_checkpointer in aktglobalswitches) then
-              begin
-                 cg.a_param_reg(exprasmlist, OS_ADDR,location.reference.base,1);
-                 cg.a_call_name(exprasmlist,'FPC_CHECKPOINTER',0);
-              end;
+          begin
+            cg.a_param_reg(exprasmlist, OS_ADDR,location.reference.base,1);
+            cg.a_call_name(exprasmlist,'FPC_CHECKPOINTER');
+          end;
       end;
 
 
@@ -393,7 +392,7 @@ implementation
                       inc(withlevel);
                       getaddrlabel(withstartlabel);
                       getaddrlabel(withendlabel);
-                      emitlab(withstartlabel);
+                      cg.a_label(exprasmlist,withstartlabel);
                       withdebugList.concat(Tai_stabs.Create(strpnew(
                          '"with'+tostr(withlevel)+':'+tostr(symtablestack.getnewtypecount)+
                          '=*'+tstoreddef(left.resulttype.def).numberstring+'",'+
@@ -421,7 +420,7 @@ implementation
 {$ifdef GDB}
                    if (cs_debuginfo in aktmoduleswitches) then
                      begin
-                       emitlab(withendlabel);
+                       cg.a_label(exprasmlist,withendlabel);
                        strpcopy(pp,'224,0,0,'+withendlabel.name);
                       if (target_info.use_function_relative_addresses) then
                         begin
@@ -455,7 +454,24 @@ begin
 end.
 {
   $Log$
-  Revision 1.8  2002-04-20 21:32:23  carl
+  Revision 1.9  2002-05-12 16:53:07  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.8  2002/04/20 21:32:23  carl
   + generic FPC_CHECKPOINTER
   + first parameter offset in stack now portable
   * rename some constants

compiler/ncgutil.pas

@@ -28,23 +28,42 @@ interface
 
     uses
       node,
-      cginfo,
-      cpubase;
+      cginfo,cpubase,aasm;
 
     type
       tloadregvars = (lr_dont_load_regvars, lr_load_regvars);
 
-    procedure location_force_reg(var l:tlocation;dst_size:TCGSize;maybeconst:boolean);
-    procedure location_force_mem(var l:tlocation);
+    procedure location_force_reg(list: TAAsmoutput;var l:tlocation;dst_size:TCGSize;maybeconst:boolean);
+    procedure location_force_mem(list: TAAsmoutput;var l:tlocation);
+
+    procedure maketojumpbool(list:TAAsmoutput; p : tnode; loadregvars: tloadregvars);
+
+
+    procedure genentrycode(list : TAAsmoutput;
+                           make_global:boolean;
+                           stackframe:longint;
+                           var parasize:longint;var nostackframe:boolean;
+                           inlined : boolean);
+   procedure genexitcode(list : TAAsmoutput;parasize:longint;nostackframe,inlined:boolean);
+   procedure genimplicitunitinit(list : TAAsmoutput);
+   procedure genimplicitunitfinal(list : TAAsmoutput);
 
-    procedure maketojumpbool(p : tnode; loadregvars: tloadregvars);
 
 implementation
 
   uses
-    globals,systems,verbose,
-    types,
-    aasm,cgbase,regvars,
+{$ifdef Delphi}
+    Sysutils,
+{$else}
+    strings,
+{$endif}
+    cutils,cclasses,globtype,globals,systems,verbose,
+    symbase,symconst,symtype,symsym,symdef,symtable,types,
+    fmodule,
+    cgbase,regvars,tainst,cpuasm,
+{$ifdef GDB}
+    gdb,
+{$endif GDB}
     ncon,
     tgobj,cpuinfo,cgobj,cgcpu,rgobj,cg64f32;
 
@@ -54,7 +73,7 @@ implementation
 *****************************************************************************}
 
     { 32-bit version }
-    procedure location_force_reg32(var l:tlocation;dst_size:TCGSize;maybeconst:boolean);
+    procedure location_force_reg32(list: TAAsmoutput;var l:tlocation;dst_size:TCGSize;maybeconst:boolean);
       var
         hregister,
         hregisterhi : tregister;
@@ -69,44 +88,44 @@ implementation
               if l.loc=LOC_REGISTER then
                hregister:=rg.makeregsize(l.registerlow,OS_INT)
               else
-               hregister:=rg.getregisterint(exprasmlist);
+               hregister:=rg.getregisterint(list);
               { load value in low register }
               case l.loc of
                 LOC_FLAGS :
-                  cg.g_flags2reg(exprasmlist,l.resflags,hregister);
+                  cg.g_flags2reg(list,l.resflags,hregister);
                 LOC_JUMP :
                   begin
-                    cg.a_label(exprasmlist,truelabel);
-                    cg.a_load_const_reg(exprasmlist,OS_INT,1,hregister);
+                    cg.a_label(list,truelabel);
+                    cg.a_load_const_reg(list,OS_INT,1,hregister);
                     getlabel(hl);
-                    cg.a_jmp_always(exprasmlist,hl);
-                    cg.a_label(exprasmlist,falselabel);
-                    cg.a_load_const_reg(exprasmlist,OS_INT,0,hregister);
-                    cg.a_label(exprasmlist,hl);
+                    cg.a_jmp_always(list,hl);
+                    cg.a_label(list,falselabel);
+                    cg.a_load_const_reg(list,OS_INT,0,hregister);
+                    cg.a_label(list,hl);
                   end;
                 else
-                  cg.a_load_loc_reg(exprasmlist,l,hregister);
+                  cg.a_load_loc_reg(list,l,hregister);
               end;
               { reset hi part, take care of the signed bit of the current value }
-              hregisterhi:=rg.getregisterint(exprasmlist);
+              hregisterhi:=rg.getregisterint(list);
               if (dst_size=OS_S64) and
                  (l.size in [OS_S8,OS_S16,OS_S32]) then
                begin
                  if l.loc=LOC_CONSTANT then
                   begin
                     if (longint(l.value)<0) then
-                     cg.a_load_const_reg(exprasmlist,OS_32,$ffffffff,hregisterhi)
+                     cg.a_load_const_reg(list,OS_32,$ffffffff,hregisterhi)
                     else
-                     cg.a_load_const_reg(exprasmlist,OS_32,0,hregisterhi);
+                     cg.a_load_const_reg(list,OS_32,0,hregisterhi);
                   end
                  else
                   begin
-                    cg.a_load_reg_reg(exprasmlist,OS_32,hregister,hregisterhi);
-                    cg.a_op_const_reg(exprasmlist,OP_SAR,31,hregisterhi);
+                    cg.a_load_reg_reg(list,OS_32,hregister,hregisterhi);
+                    cg.a_op_const_reg(list,OP_SAR,31,hregisterhi);
                   end;
                end
               else
-               cg.a_load_const_reg(exprasmlist,OS_32,0,hregisterhi);
+               cg.a_load_const_reg(list,OS_32,0,hregisterhi);
               location_reset(l,LOC_REGISTER,dst_size);
               l.registerlow:=hregister;
               l.registerhigh:=hregisterhi;
@@ -122,11 +141,11 @@ implementation
                end
               else
                begin
-                 hregister:=rg.getregisterint(exprasmlist);
-                 hregisterhi:=rg.getregisterint(exprasmlist);
+                 hregister:=rg.getregisterint(list);
+                 hregisterhi:=rg.getregisterint(list);
                end;
               { load value in new register }
-              tcg64f32(cg).a_load64_loc_reg(exprasmlist,l,hregister,hregisterhi);
+              tcg64f32(cg).a_load64_loc_reg(list,l,hregister,hregisterhi);
               location_reset(l,LOC_REGISTER,dst_size);
               l.registerlow:=hregister;
               l.registerhigh:=hregisterhi;
@@ -140,7 +159,7 @@ implementation
               { if the previous was 64bit release the high register }
               if l.size in [OS_64,OS_S64] then
                begin
-                 rg.ungetregisterint(exprasmlist,l.registerhigh);
+                 rg.ungetregisterint(list,l.registerhigh);
                  l.registerhigh:=R_NO;
                end;
               hregister:=l.register;
@@ -153,22 +172,22 @@ implementation
                  (TCGSize2Size[dst_size]=TCGSize2Size[l.size]) then
                hregister:=l.register
               else
-               hregister:=rg.getregisterint(exprasmlist);
+               hregister:=rg.getregisterint(list);
             end;
            hregister:=rg.makeregsize(hregister,dst_size);
            { load value in new register }
            case l.loc of
              LOC_FLAGS :
-               cg.g_flags2reg(exprasmlist,l.resflags,hregister);
+               cg.g_flags2reg(list,l.resflags,hregister);
              LOC_JUMP :
                begin
-                 cg.a_label(exprasmlist,truelabel);
-                 cg.a_load_const_reg(exprasmlist,dst_size,1,hregister);
+                 cg.a_label(list,truelabel);
+                 cg.a_load_const_reg(list,dst_size,1,hregister);
                  getlabel(hl);
-                 cg.a_jmp_always(exprasmlist,hl);
-                 cg.a_label(exprasmlist,falselabel);
-                 cg.a_load_const_reg(exprasmlist,dst_size,0,hregister);
-                 cg.a_label(exprasmlist,hl);
+                 cg.a_jmp_always(list,hl);
+                 cg.a_label(list,falselabel);
+                 cg.a_load_const_reg(list,dst_size,0,hregister);
+                 cg.a_label(list,hl);
                end;
              else
                begin
@@ -181,7 +200,7 @@ implementation
                      l.register:=rg.makeregsize(l.register,dst_size);
                     l.size:=dst_size;
                   end;
-                 cg.a_load_loc_reg(exprasmlist,l,hregister);
+                 cg.a_load_loc_reg(list,l,hregister);
                end;
            end;
            location_reset(l,LOC_REGISTER,dst_size);
@@ -190,10 +209,9 @@ implementation
      end;
 
     { 64-bit version }
-    procedure location_force_reg64(var l:tlocation;dst_size:TCGSize;maybeconst:boolean);
+    procedure location_force_reg64(list: TAAsmoutput;var l:tlocation;dst_size:TCGSize;maybeconst:boolean);
       var
-        hregister,
-        hregisterhi : tregister;
+        hregister : tregister;
         hl : tasmlabel;
      begin
         { handle transformations to 64bit separate }
@@ -203,23 +221,23 @@ implementation
               if l.loc=LOC_REGISTER then
                hregister:=rg.makeregsize(l.register,OS_INT)
               else
-               hregister:=rg.getregisterint(exprasmlist);
+               hregister:=rg.getregisterint(list);
               { load value in low register }
               case l.loc of
                 LOC_FLAGS :
-                  cg.g_flags2reg(exprasmlist,l.resflags,hregister);
+                  cg.g_flags2reg(list,l.resflags,hregister);
                 LOC_JUMP :
                   begin
-                    cg.a_label(exprasmlist,truelabel);
-                    cg.a_load_const_reg(exprasmlist,OS_INT,1,hregister);
+                    cg.a_label(list,truelabel);
+                    cg.a_load_const_reg(list,OS_INT,1,hregister);
                     getlabel(hl);
-                    cg.a_jmp_always(exprasmlist,hl);
-                    cg.a_label(exprasmlist,falselabel);
-                    cg.a_load_const_reg(exprasmlist,OS_INT,0,hregister);
-                    cg.a_label(exprasmlist,hl);
+                    cg.a_jmp_always(list,hl);
+                    cg.a_label(list,falselabel);
+                    cg.a_load_const_reg(list,OS_INT,0,hregister);
+                    cg.a_label(list,hl);
                   end;
                 else
-                  cg.a_load_loc_reg(exprasmlist,l,hregister);
+                  cg.a_load_loc_reg(list,l,hregister);
               end;
               location_reset(l,LOC_REGISTER,dst_size);
               l.register:=hregister;
@@ -239,22 +257,22 @@ implementation
                  (TCGSize2Size[dst_size]=TCGSize2Size[l.size]) then
                hregister:=l.register
               else
-               hregister:=rg.getregisterint(exprasmlist);
+               hregister:=rg.getregisterint(list);
             end;
            hregister:=rg.makeregsize(hregister,dst_size);
            { load value in new register }
            case l.loc of
              LOC_FLAGS :
-               cg.g_flags2reg(exprasmlist,l.resflags,hregister);
+               cg.g_flags2reg(list,l.resflags,hregister);
              LOC_JUMP :
                begin
-                 cg.a_label(exprasmlist,truelabel);
-                 cg.a_load_const_reg(exprasmlist,dst_size,1,hregister);
+                 cg.a_label(list,truelabel);
+                 cg.a_load_const_reg(list,dst_size,1,hregister);
                  getlabel(hl);
-                 cg.a_jmp_always(exprasmlist,hl);
-                 cg.a_label(exprasmlist,falselabel);
-                 cg.a_load_const_reg(exprasmlist,dst_size,0,hregister);
-                 cg.a_label(exprasmlist,hl);
+                 cg.a_jmp_always(list,hl);
+                 cg.a_label(list,falselabel);
+                 cg.a_load_const_reg(list,dst_size,0,hregister);
+                 cg.a_label(list,hl);
                end;
              else
                begin
@@ -267,7 +285,7 @@ implementation
                      l.register:=rg.makeregsize(l.register,dst_size);
                     l.size:=dst_size;
                   end;
-                 cg.a_load_loc_reg(exprasmlist,l,hregister);
+                 cg.a_load_loc_reg(list,l,hregister);
                end;
            end;
            location_reset(l,LOC_REGISTER,dst_size);
@@ -275,22 +293,22 @@ implementation
          end;
      end;
 
-    procedure location_force_reg(var l:tlocation;dst_size:TCGSize;maybeconst:boolean);
+    procedure location_force_reg(list: TAAsmoutput;var l:tlocation;dst_size:TCGSize;maybeconst:boolean);
       begin
         { release previous location before demanding a new register }
         if (l.loc in [LOC_REFERENCE,LOC_CREFERENCE]) then
          begin
-           location_freetemp(exprasmlist,l);
-           location_release(exprasmlist,l);
+           location_freetemp(list,l);
+           location_release(list,l);
          end;
         if sizeof(aword) < 8 then
-          location_force_reg32(l, dst_size, maybeconst)
+          location_force_reg32(list, l, dst_size, maybeconst)
         else
-          location_force_reg64(l, dst_size, maybeconst);
+          location_force_reg64(list, l, dst_size, maybeconst);
       end;
 
 
-    procedure location_force_mem(var l:tlocation);
+    procedure location_force_mem(list: TAAsmoutput;var l:tlocation);
       var
         r : treference;
       begin
@@ -298,8 +316,8 @@ implementation
           LOC_FPUREGISTER,
           LOC_CFPUREGISTER :
             begin
-              tg.gettempofsizereference(exprasmlist,TCGSize2Size[l.size],r);
-              cg.a_loadfpu_reg_ref(exprasmlist,l.size,l.register,r);
+              tg.gettempofsizereference(list,TCGSize2Size[l.size],r);
+              cg.a_loadfpu_reg_ref(list,l.size,l.register,r);
               location_reset(l,LOC_REFERENCE,l.size);
               l.reference:=r;
             end;
@@ -307,11 +325,11 @@ implementation
           LOC_REGISTER,
           LOC_CREGISTER :
             begin
-              tg.gettempofsizereference(exprasmlist,TCGSize2Size[l.size],r);
+              tg.gettempofsizereference(list,TCGSize2Size[l.size],r);
               if l.size in [OS_64,OS_S64] then
-               tcg64f32(cg).a_load64_loc_ref(exprasmlist,l,r)
+               tcg64f32(cg).a_load64_loc_ref(list,l,r)
               else
-               cg.a_load_loc_ref(exprasmlist,l,r);
+               cg.a_load_loc_ref(list,l,r);
               location_reset(l,LOC_REFERENCE,l.size);
               l.reference:=r;
             end;
@@ -323,7 +341,7 @@ implementation
       end;
 
 
-    procedure maketojumpbool(p : tnode; loadregvars: tloadregvars);
+    procedure maketojumpbool(list:TAAsmoutput; p : tnode; loadregvars: tloadregvars);
     {
       produces jumps to true respectively false labels using boolean expressions
 
@@ -343,13 +361,13 @@ implementation
          if is_boolean(p.resulttype.def) then
            begin
               if loadregvars = lr_load_regvars then
-                load_all_regvars(exprasmlist);
+                load_all_regvars(list);
               if is_constboolnode(p) then
                 begin
                    if tordconstnode(p).value<>0 then
-                     cg.a_jmp_always(exprasmlist,truelabel)
+                     cg.a_jmp_always(list,truelabel)
                    else
-                     cg.a_jmp_always(exprasmlist,falselabel)
+                     cg.a_jmp_always(list,falselabel)
                 end
               else
                 begin
@@ -358,18 +376,18 @@ implementation
                      LOC_CREGISTER,LOC_REGISTER,LOC_CREFERENCE,LOC_REFERENCE :
                        begin
                          if (p.location.loc = LOC_CREGISTER) then
-                           load_regvar_reg(exprasmlist,p.location.register);
-                         cg.a_cmp_const_loc_label(exprasmlist,opsize,OC_NE,
+                           load_regvar_reg(list,p.location.register);
+                         cg.a_cmp_const_loc_label(list,opsize,OC_NE,
                            0,p.location,truelabel);
                          { !!! should happen right after cmp (JM) }
-                         location_release(exprasmlist,p.location);
-                         cg.a_jmp_always(exprasmlist,falselabel);
+                         location_release(list,p.location);
+                         cg.a_jmp_always(list,falselabel);
                        end;
                      LOC_FLAGS :
                        begin
-                         cg.a_jmp_flags(exprasmlist,p.location.resflags,
+                         cg.a_jmp_flags(list,p.location.resflags,
                            truelabel);
-                         cg.a_jmp_always(exprasmlist,falselabel);
+                         cg.a_jmp_always(list,falselabel);
                        end;
                    end;
                 end;
@@ -379,11 +397,875 @@ implementation
          aktfilepos:=storepos;
       end;
 
-end.
 
+{****************************************************************************
+                                 Entry/Exit Code
+****************************************************************************}
+
+    procedure copyvalueparas(p : tnamedindexitem;arg:pointer);
+      var
+        href1,href2 : treference;
+        list : taasmoutput;
+      begin
+        list:=taasmoutput(arg);
+        if (tsym(p).typ=varsym) and
+           (tvarsym(p).varspez=vs_value) and
+           (push_addr_param(tvarsym(p).vartype.def)) then
+         begin
+           reference_reset_base(href1,procinfo^.framepointer,tvarsym(p).address+procinfo^.para_offset);
+           if is_open_array(tvarsym(p).vartype.def) or
+              is_array_of_const(tvarsym(p).vartype.def) then
+             cg.g_copyvaluepara_openarray(list,href1,tarraydef(tvarsym(p).vartype.def).elesize)
+           else
+            begin
+              reference_reset_base(href2,procinfo^.framepointer,-tvarsym(p).localvarsym.address+tvarsym(p).localvarsym.owner.address_fixup);
+              if is_shortstring(tvarsym(p).vartype.def) then
+               cg.g_copyshortstring(list,href1,href2,tstringdef(tvarsym(p).vartype.def).len,false,true)
+              else
+               cg.g_concatcopy(list,href1,href2,tvarsym(p).vartype.def.size,true,true);
+            end;
+         end;
+      end;
+
+
+    procedure initialize_threadvar(p : tnamedindexitem;arg:pointer);
+      var
+        href : treference;
+        list : taasmoutput;
+      begin
+        list:=taasmoutput(arg);
+        if (tsym(p).typ=varsym) and
+           (vo_is_thread_var in tvarsym(p).varoptions) then
+         begin
+           cg.a_param_const(list,OS_INT,tvarsym(p).getsize,2);
+           reference_reset_symbol(href,newasmsymbol(tvarsym(p).mangledname),0);
+           cg.a_paramaddr_ref(list,href,2);
+           rg.saveregvars(list,all_registers);
+           cg.a_call_name(list,'FPC_INIT_THREADVAR');
+         end;
+     end;
+
+
+    { generates the code for initialisation of local data }
+    procedure initialize_data(p : tnamedindexitem;arg:pointer);
+      var
+        href : treference;
+        list : taasmoutput;
+      begin
+        list:=taasmoutput(arg);
+        if (tsym(p).typ=varsym) and
+           assigned(tvarsym(p).vartype.def) and
+           not(is_class(tvarsym(p).vartype.def)) and
+           tvarsym(p).vartype.def.needs_inittable then
+         begin
+           if assigned(procinfo) then
+            procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally;
+           if tsym(p).owner.symtabletype in [localsymtable,inlinelocalsymtable] then
+            reference_reset_base(href,procinfo^.framepointer,-tvarsym(p).address+tvarsym(p).owner.address_fixup)
+           else
+            reference_reset_symbol(href,newasmsymbol(tvarsym(p).mangledname),0);
+           cg.g_initialize(list,tvarsym(p).vartype.def,href,false);
+         end;
+      end;
+
+
+    { generates the code for finalisation of local data }
+    procedure finalize_data(p : tnamedindexitem;arg:pointer);
+      var
+        href : treference;
+        list : taasmoutput;
+      begin
+        list:=taasmoutput(arg);
+        if (tsym(p).typ=varsym) and
+           assigned(tvarsym(p).vartype.def) and
+           not(is_class(tvarsym(p).vartype.def)) and
+           tvarsym(p).vartype.def.needs_inittable then
+         begin
+           if tsym(p).owner.symtabletype in [localsymtable,inlinelocalsymtable] then
+            reference_reset_base(href,procinfo^.framepointer,-tvarsym(p).address+tvarsym(p).owner.address_fixup)
+           else
+            reference_reset_symbol(href,newasmsymbol(tvarsym(p).mangledname),0);
+           cg.g_finalize(list,tvarsym(p).vartype.def,href,false);
+         end;
+      end;
+
+
+    { generates the code for incrementing the reference count of parameters and
+      initialize out parameters }
+    procedure init_paras(p : tnamedindexitem;arg:pointer);
+      var
+        href : treference;
+        tmpreg : tregister;
+        list : taasmoutput;
+      begin
+        list:=taasmoutput(arg);
+        if (tsym(p).typ=varsym) and
+           not is_class(tvarsym(p).vartype.def) and
+           tvarsym(p).vartype.def.needs_inittable then
+         begin
+           case tvarsym(p).varspez of
+             vs_value :
+               begin
+                 procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally;
+                 if assigned(tvarsym(p).localvarsym) then
+                  reference_reset_base(href,procinfo^.framepointer,
+                      -tvarsym(p).localvarsym.address+tvarsym(p).localvarsym.owner.address_fixup)
+                 else
+                  reference_reset_base(href,procinfo^.framepointer,tvarsym(p).address+procinfo^.para_offset);
+                 cg.g_incrrefcount(list,tvarsym(p).vartype.def,href);
+               end;
+             vs_out :
+               begin
+                 reference_reset_base(href,procinfo^.framepointer,tvarsym(p).address+procinfo^.para_offset);
+                 tmpreg:=cg.get_scratch_reg(list);
+                 cg.a_load_ref_reg(list,OS_ADDR,href,tmpreg);
+                 reference_reset_base(href,tmpreg,0);
+                 cg.g_initialize(list,tvarsym(p).vartype.def,href,false);
+               end;
+           end;
+         end;
+      end;
+
+
+    { generates the code for decrementing the reference count of parameters }
+    procedure final_paras(p : tnamedindexitem;arg:pointer);
+      var
+        href : treference;
+        list : taasmoutput;
+      begin
+        list:=taasmoutput(arg);
+        if (tsym(p).typ=varsym) and
+           not is_class(tvarsym(p).vartype.def) and
+           tvarsym(p).vartype.def.needs_inittable then
+         begin
+           if (tvarsym(p).varspez=vs_value) then
+            begin
+              if assigned(tvarsym(p).localvarsym) then
+               reference_reset_base(href,procinfo^.framepointer,
+                   -tvarsym(p).localvarsym.address+tvarsym(p).localvarsym.owner.address_fixup)
+              else
+               reference_reset_base(href,procinfo^.framepointer,tvarsym(p).address+procinfo^.para_offset);
+              cg.g_decrrefcount(list,tvarsym(p).vartype.def,href);
+            end;
+         end;
+      end;
+
+
+    { Initialize temp ansi/widestrings,interfaces }
+    procedure inittempvariables(list:taasmoutput);
+      var
+        hp : ptemprecord;
+        href : treference;
+      begin
+        hp:=tg.templist;
+        while assigned(hp) do
+         begin
+           if hp^.temptype in [tt_ansistring,tt_freeansistring,
+                               tt_widestring,tt_freewidestring,
+                               tt_interfacecom] then
+            begin
+              procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally;
+              reference_reset_base(href,procinfo^.framepointer,hp^.pos);
+              cg.a_load_const_ref(list,OS_ADDR,0,href);
+            end;
+           hp:=hp^.next;
+         end;
+      end;
+
+
+    procedure finalizetempvariables(list:taasmoutput);
+      var
+        hp : ptemprecord;
+        href : treference;
+      begin
+        hp:=tg.templist;
+        while assigned(hp) do
+         begin
+           case hp^.temptype of
+             tt_ansistring,
+             tt_freeansistring :
+               begin
+                 reference_reset_base(href,procinfo^.framepointer,hp^.pos);
+                 cg.a_paramaddr_ref(list,href,1);
+                 cg.a_call_name(list,'FPC_ANSISTR_DECR_REF');
+               end;
+             tt_widestring,
+             tt_freewidestring :
+               begin
+                 reference_reset_base(href,procinfo^.framepointer,hp^.pos);
+                 cg.a_paramaddr_ref(list,href,1);
+                 cg.a_call_name(list,'FPC_WIDESTR_DECR_REF');
+               end;
+             tt_interfacecom :
+               begin
+                 reference_reset_base(href,procinfo^.framepointer,hp^.pos);
+                 cg.a_paramaddr_ref(list,href,1);
+                 cg.a_call_name(list,'FPC_INTF_DECR_REF');
+               end;
+           end;
+           hp:=hp^.next;
+         end;
+      end;
+
+
+    procedure handle_return_value(list:TAAsmoutput; inlined : boolean;var uses_acc,uses_acchi : boolean);
+      var
+        href : treference;
+        hreg : tregister;
+        cgsize : TCGSize;
+      begin
+        if not is_void(aktprocdef.rettype.def) then
+         begin
+           if (tfuncretsym(aktprocdef.funcretsym).funcretstate<>vs_assigned) and
+              (not inlined) then
+            CGMessage(sym_w_function_result_not_set);
+           reference_reset_base(href,procinfo^.framepointer,procinfo^.return_offset);
+           cgsize:=def_cgsize(aktprocdef.rettype.def);
+           case aktprocdef.rettype.def.deftype of
+             orddef,
+             enumdef :
+               begin
+                 uses_acc:=true;
+                 cg.a_reg_alloc(list,accumulator);
+                 if cgsize in [OS_64,OS_S64] then
+                  begin
+                    uses_acchi:=true;
+                    cg.a_reg_alloc(list,accumulatorhigh);
+                    tcg64f32(cg).a_load64_ref_reg(list,href,accumulator,accumulatorhigh);
+                  end
+                 else
+                  begin
+                    hreg:=rg.makeregsize(accumulator,cgsize);
+                    cg.a_load_ref_reg(list,cgsize,href,hreg);
+                  end;
+               end;
+             floatdef :
+               begin
+                 cg.a_loadfpu_ref_reg(list,cgsize,href,R_ST);
+               end;
+             else
+               begin
+                 if ret_in_acc(aktprocdef.rettype.def) then
+                  begin
+                    uses_acc:=true;
+                    cg.a_reg_alloc(list,accumulator);
+                    cg.a_load_ref_reg(list,cgsize,href,accumulator);
+                   end
+               end;
+           end;
+         end;
+      end;
+
+
+    procedure handle_fast_exit_return_value(list:TAAsmoutput);
+      var
+        href : treference;
+        hreg : tregister;
+        cgsize : TCGSize;
+      begin
+        if not is_void(aktprocdef.rettype.def) then
+         begin
+           reference_reset_base(href,procinfo^.framepointer,procinfo^.return_offset);
+           cgsize:=def_cgsize(aktprocdef.rettype.def);
+           case aktprocdef.rettype.def.deftype of
+             orddef,
+             enumdef :
+               begin
+                 if cgsize in [OS_64,OS_S64] then
+                  tcg64f32(cg).a_load64_reg_ref(list,accumulator,accumulatorhigh,href)
+                 else
+                  begin
+                    hreg:=rg.makeregsize(accumulator,cgsize);
+                    cg.a_load_reg_ref(list,cgsize,hreg,href);
+                  end;
+               end;
+             floatdef :
+               begin
+                 cg.a_loadfpu_reg_ref(list,cgsize,R_ST,href);
+               end;
+             else
+               begin
+                 if ret_in_acc(aktprocdef.rettype.def) then
+                  cg.a_load_reg_ref(list,cgsize,accumulator,href);
+               end;
+           end;
+         end;
+      end;
+
+
+    procedure genentrycode(list : TAAsmoutput;
+                           make_global:boolean;
+                           stackframe:longint;
+                           var parasize:longint;var nostackframe:boolean;
+                           inlined : boolean);
+      var
+        hs : string;
+        href : treference;
+        p : tsymtable;
+        tempbuf : treference;
+      begin
+        { Insert alignment and assembler names }
+        if not inlined then
+         begin
+           { Align, gprof uses 16 byte granularity }
+           if (cs_profile in aktmoduleswitches) then
+            list.concat(Tai_align.Create_op(16,$90))
+           else
+            list.concat(Tai_align.Create(aktalignment.procalign));
+
+           if (cs_profile in aktmoduleswitches) or
+              (aktprocdef.owner.symtabletype=globalsymtable) or
+              (assigned(procinfo^._class) and (procinfo^._class.owner.symtabletype=globalsymtable)) then
+            make_global:=true;
+
+           if make_global or ((procinfo^.flags and pi_is_global) <> 0) then
+            aktprocsym.is_global := True;
+
+{$ifdef GDB}
+           if (cs_debuginfo in aktmoduleswitches) then
+            begin
+              aktprocdef.concatstabto(list);
+              aktprocsym.isstabwritten:=true;
+            end;
+{$endif GDB}
+
+           repeat
+             hs:=aktprocdef.aliasnames.getfirst;
+             if hs='' then
+              break;
+{$ifdef GDB}
+             if (cs_debuginfo in aktmoduleswitches) and
+                target_info.use_function_relative_addresses then
+              list.concat(Tai_stab_function_name.Create(strpnew(hs)));
+{$endif GDB}
+             if make_global then
+              list.concat(Tai_symbol.Createname_global(hs,0))
+             else
+              list.concat(Tai_symbol.Createname(hs,0));
+           until false;
+
+           { omit stack frame ? }
+           if (procinfo^.framepointer=STACK_POINTER_REG) then
+            begin
+              CGMessage(cg_d_stackframe_omited);
+              nostackframe:=true;
+              if (aktprocdef.proctypeoption in [potype_unitinit,potype_proginit,potype_unitfinalize]) then
+                parasize:=0
+              else
+                parasize:=aktprocdef.parast.datasize+procinfo^.para_offset-4;
+              if stackframe<>0 then
+                cg.a_op_const_reg(list,OP_SUB,stackframe,procinfo^.framepointer);
+            end
+           else
+            begin
+              nostackframe:=false;
+              if (aktprocdef.proctypeoption in [potype_unitinit,potype_proginit,potype_unitfinalize]) then
+                parasize:=0
+              else
+                parasize:=aktprocdef.parast.datasize+procinfo^.para_offset-target_info.first_parm_offset;
+
+              if (po_interrupt in aktprocdef.procoptions) then
+                cg.g_interrupt_stackframe_entry(list);
+
+              cg.g_stackframe_entry(list,stackframe);
+
+              if (cs_check_stack in aktlocalswitches) then
+                cg.g_stackcheck(list,stackframe);
+            end;
+
+           if (cs_profile in aktmoduleswitches) and
+              not(po_assembler in aktprocdef.procoptions) then
+            cg.g_profilecode(list);
+         end;
+
+        { for the save all registers we can simply use a pusha,popa which
+          push edi,esi,ebp,esp(ignored),ebx,edx,ecx,eax }
+        if (po_saveregisters in aktprocdef.procoptions) then
+         cg.g_save_all_registers(list)
+        else
+         { should we save edi,esi,ebx like C ? }
+         if (po_savestdregs in aktprocdef.procoptions) then
+          cg.g_save_standard_registers(list);
+
+        { a constructor needs a help procedure }
+        if (aktprocdef.proctypeoption=potype_constructor) then
+          cg.g_call_constructor_helper(list);
+
+        { don't load ESI, does the caller }
+        { we must do it for local function }
+        { that can be called from a foreach_static }
+        { of another object than self !! PM }
+        if assigned(procinfo^._class) and  { !!!!! shouldn't we load ESI always? }
+           (lexlevel>normal_function_level) then
+         cg.g_maybe_loadself(list);
+
+        { When message method contains self as a parameter,
+          we must load it into ESI }
+        If (po_containsself in aktprocdef.procoptions) then
+          begin
+             list.concat(Tairegalloc.Alloc(self_pointer_reg));
+             reference_reset_base(href,procinfo^.framepointer,procinfo^.selfpointer_offset);
+             cg.a_load_ref_reg(list,OS_ADDR,href,self_pointer_reg);
+          end;
+
+        { initialize return value }
+        if (not is_void(aktprocdef.rettype.def)) and
+           (aktprocdef.rettype.def.needs_inittable) then
+          begin
+             procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally;
+             reference_reset_base(href,procinfo^.framepointer,procinfo^.return_offset);
+             cg.g_initialize(list,aktprocdef.rettype.def,href,ret_in_param(aktprocdef.rettype.def));
+          end;
+
+        { initialisize local data like ansistrings }
+        case aktprocdef.proctypeoption of
+           potype_unitinit:
+             begin
+                { using current_module.globalsymtable is hopefully      }
+                { more robust than symtablestack and symtablestack.next }
+                tsymtable(current_module.globalsymtable).foreach_static({$ifndef TP}@{$endif}initialize_data,list);
+                tsymtable(current_module.localsymtable).foreach_static({$ifndef TP}@{$endif}initialize_data,list);
+             end;
+           { units have seperate code for initilization and finalization }
+           potype_unitfinalize: ;
+           else
+             aktprocdef.localst.foreach_static({$ifndef TP}@{$endif}initialize_data,list);
+        end;
+
+        { initialisizes temp. ansi/wide string data }
+        inittempvariables(list);
+
+        { generate copies of call by value parameters }
+        if not(po_assembler in aktprocdef.procoptions) and
+           not(aktprocdef.proccalloption in [pocall_cdecl,pocall_cppdecl,pocall_palmossyscall,pocall_system]) then
+          aktprocdef.parast.foreach_static({$ifndef TP}@{$endif}copyvalueparas,list);
+
+        if assigned( aktprocdef.parast) then
+          aktprocdef.parast.foreach_static({$ifndef TP}@{$endif}init_paras,list);
+
+        if (not inlined) then
+         begin
+           { call startup helpers from main program }
+           if (aktprocdef.proctypeoption=potype_proginit) then
+            begin
+              { initialize profiling for win32 }
+              if (target_info.target in [target_I386_WIN32,target_I386_wdosx]) and
+                 (cs_profile in aktmoduleswitches) then
+                cg.a_call_name(list,'__monstartup');
+
+              { add local threadvars in units (only if needed because not all platforms
+                have threadvar support) }
+              if have_local_threadvars then
+                cg.a_call_name(list,'FPC_INITIALIZELOCALTHREADVARS');
+
+              { add global threadvars }
+              p:=symtablestack;
+              while assigned(p) do
+               begin
+                 p.foreach_static({$ifndef TP}@{$endif}initialize_threadvar,list);
+                 p:=p.next;
+               end;
+
+              { initialize units }
+              cg.a_call_name(list,'FPC_INITIALIZEUNITS');
+            end;
+
+           { do we need an exception frame because of ansi/widestrings/interfaces ? }
+           if ((procinfo^.flags and pi_needs_implicit_finally)<>0) and
+              { but it's useless in init/final code of units }
+              not(aktprocdef.proctypeoption in [potype_unitfinalize,potype_unitinit]) then
+            begin
+              include(rg.usedinproc,accumulator);
+
+              { allocate exception frame buffer }
+              list.concat(Taicpu.op_const_reg(A_SUB,S_L,36,R_ESP));
+              list.concat(Taicpu.op_reg_reg(A_MOV,S_L,R_ESP,R_EDI));
+              reference_reset_base(tempbuf,R_EDI,0);
+
+              cg.g_push_exception(list,tempbuf,1,aktexitlabel);
+
+              { probably we've to reload self here }
+              cg.g_maybe_loadself(list);
+            end;
+
+{$ifdef GDB}
+           if (cs_debuginfo in aktmoduleswitches) then
+            list.concat(Tai_force_line.Create);
+{$endif GDB}
+         end;
+
+        if inlined then
+         load_regvars(list,nil);
+      end;
+
+
+   procedure genexitcode(list : TAAsmoutput;parasize:longint;nostackframe,inlined:boolean);
+      var
+{$ifdef GDB}
+        stabsendlabel : tasmlabel;
+        mangled_length : longint;
+        p : pchar;
+        st : string[2];
+{$endif GDB}
+        okexitlabel,
+        noreraiselabel,nodestroycall : tasmlabel;
+        tmpreg : tregister;
+        href : treference;
+        usesacc,
+        usesacchi,
+        usesself : boolean;
+        pd : tprocdef;
+      begin
+        if aktexit2label.is_used and
+           ((procinfo^.flags and (pi_needs_implicit_finally or pi_uses_exceptions)) <> 0) then
+          begin
+            cg.a_jmp_always(list,aktexitlabel);
+            cg.a_label(list,aktexit2label);
+            handle_fast_exit_return_value(list);
+          end;
+
+        if aktexitlabel.is_used then
+          list.concat(Tai_label.Create(aktexitlabel));
+
+        cleanup_regvars(list);
+
+        { call the destructor help procedure }
+        if (aktprocdef.proctypeoption=potype_destructor) and
+           assigned(procinfo^._class) then
+         cg.g_call_destructor_helper(list);
+
+        { finalize temporary data }
+        finalizetempvariables(list);
+
+        { finalize local data like ansistrings}
+        case aktprocdef.proctypeoption of
+           potype_unitfinalize:
+             begin
+                { using current_module.globalsymtable is hopefully      }
+                { more robust than symtablestack and symtablestack.next }
+                tsymtable(current_module.globalsymtable).foreach_static({$ifndef TP}@{$endif}finalize_data,list);
+                tsymtable(current_module.localsymtable).foreach_static({$ifndef TP}@{$endif}finalize_data,list);
+             end;
+           { units have seperate code for initialization and finalization }
+           potype_unitinit: ;
+           else
+             aktprocdef.localst.foreach_static({$ifndef TP}@{$endif}finalize_data,list);
+        end;
+
+        { finalize paras data }
+        if assigned(aktprocdef.parast) then
+          aktprocdef.parast.foreach_static({$ifndef TP}@{$endif}final_paras,list);
+
+        { do we need to handle exceptions because of ansi/widestrings ? }
+        if not inlined and
+           ((procinfo^.flags and pi_needs_implicit_finally)<>0) and
+           { but it's useless in init/final code of units }
+           not(aktprocdef.proctypeoption in [potype_unitfinalize,potype_unitinit]) then
+          begin
+             { the exception helper routines modify all registers }
+             aktprocdef.usedregisters:=all_registers;
+             getlabel(noreraiselabel);
+             cg.g_pop_exception(list,noreraiselabel);
+
+             if (aktprocdef.proctypeoption=potype_constructor) then
+               begin
+                  if assigned(procinfo^._class) then
+                    begin
+                       pd:=procinfo^._class.searchdestructor;
+                       if assigned(pd) then
+                         begin
+                            getlabel(nodestroycall);
+                            reference_reset_base(href,procinfo^.framepointer,procinfo^.selfpointer_offset);
+                            cg.a_cmp_const_ref_label(list,OS_ADDR,OC_EQ,0,href,nodestroycall);
+                            if is_class(procinfo^._class) then
+                             begin
+                               cg.a_param_const(list,OS_INT,1,2);
+                               cg.a_param_reg(list,OS_ADDR,self_pointer_reg,1);
+                             end
+                            else if is_object(procinfo^._class) then
+                             begin
+                               cg.a_param_reg(list,OS_ADDR,self_pointer_reg,2);
+                               reference_reset_symbol(href,newasmsymbol(procinfo^._class.vmt_mangledname),0);
+                               cg.a_paramaddr_ref(list,href,1);
+                             end
+                            else
+                             Internalerror(200006164);
+                            if (po_virtualmethod in pd.procoptions) then
+                             begin
+                               reference_reset_base(href,self_pointer_reg,0);
+                               tmpreg:=cg.get_scratch_reg(list);
+                               cg.a_load_ref_reg(list,OS_ADDR,href,tmpreg);
+                               reference_reset_base(href,tmpreg,procinfo^._class.vmtmethodoffset(pd.extnumber));
+                               cg.free_scratch_reg(list,tmpreg);
+                               cg.a_call_ref(list,href);
+                             end
+                            else
+                             cg.a_call_name(list,pd.mangledname);
+                            { not necessary because the result is never assigned in the
+                              case of an exception (FK) }
+                            cg.a_label(list,nodestroycall);
+                         end;
+                    end
+               end
+             else
+              begin
+                { no constructor }
+                { must be the return value finalized before reraising the exception? }
+                if (not is_void(aktprocdef.rettype.def)) and
+                   (aktprocdef.rettype.def.needs_inittable) and
+                   ((aktprocdef.rettype.def.deftype<>objectdef) or
+                    not is_class(aktprocdef.rettype.def)) then
+                  begin
+                     reference_reset_base(href,procinfo^.framepointer,procinfo^.return_offset);
+                     cg.g_finalize(list,aktprocdef.rettype.def,href,ret_in_param(aktprocdef.rettype.def));
+                  end;
+              end;
+
+             cg.a_call_name(list,'FPC_RERAISE');
+             cg.a_label(list,noreraiselabel);
+          end;
+
+        { call __EXIT for main program }
+        if (not DLLsource) and
+           (not inlined) and
+           (aktprocdef.proctypeoption=potype_proginit) then
+         cg.a_call_name(list,'FPC_DO_EXIT');
+
+        { handle return value, this is not done for assembler routines when
+          they didn't reference the result variable }
+        usesacc:=false;
+        usesacchi:=false;
+        usesself:=false;
+        if not(po_assembler in aktprocdef.procoptions) or
+           (assigned(aktprocdef.funcretsym) and
+            (tfuncretsym(aktprocdef.funcretsym).refcount>1)) then
+          begin
+            if (aktprocdef.proctypeoption<>potype_constructor) then
+              handle_return_value(list,inlined,usesacc,usesacchi)
+            else
+              begin
+                { successful constructor deletes the zero flag }
+                { and returns self in eax                   }
+                { eax must be set to zero if the allocation failed !!! }
+                getlabel(okexitlabel);
+                cg.a_jmp_always(list,okexitlabel);
+                cg.a_label(list,faillabel);
+                cg.g_call_fail_helper(list);
+                cg.a_label(list,okexitlabel);
+
+                { for classes this is done after the call to }
+                { AfterConstruction                          }
+                if is_object(procinfo^._class) then
+                  begin
+                    cg.a_reg_alloc(list,accumulator);
+                    cg.a_load_reg_reg(list,OS_ADDR,self_pointer_reg,accumulator);
+                    usesacc:=true;
+                  end;
+{$ifdef i386}
+                list.concat(taicpu.op_reg_reg(A_TEST,S_L,R_ESI,R_ESI));
+{$else}
+{$warning constructor returns in flags for i386}
+{$endif i386}
+                usesself:=true;
+              end;
+          end;
+
+        if aktexit2label.is_used and not aktexit2label.is_set then
+          cg.a_label(list,aktexit2label);
+
+{$ifdef GDB}
+        if ((cs_debuginfo in aktmoduleswitches) and not inlined) then
+          begin
+            getlabel(stabsendlabel);
+            cg.a_label(list,stabsendlabel);
+          end;
+{$endif GDB}
+
+        { for the save all registers we can simply use a pusha,popa which
+          push edi,esi,ebp,esp(ignored),ebx,edx,ecx,eax }
+        if (po_saveregisters in aktprocdef.procoptions) then
+          cg.g_restore_all_registers(list,usesself,usesacc,usesacchi)
+        else
+         { should we restore edi ? }
+         if (po_savestdregs in aktprocdef.procoptions) then
+           cg.g_restore_standard_registers(list);
+
+        { remove stackframe }
+        if not inlined then
+         begin
+           if (not nostackframe) then
+            cg.g_restore_frame_pointer(list)
+           else
+            if (tg.gettempsize<>0) then
+             cg.a_op_const_reg(list,OP_ADD,tg.gettempsize,R_ESP);
+         end;
+
+        { at last, the return is generated }
+        if not inlined then
+         begin
+           if (po_interrupt in aktprocdef.procoptions) then
+            cg.g_interrupt_stackframe_exit(list,usesself,usesacc,usesacchi)
+           else
+            cg.g_return_from_proc(list,parasize);
+         end;
+
+        if not inlined then
+          list.concat(Tai_symbol_end.Createname(aktprocdef.mangledname));
+
+{$ifdef GDB}
+        if (cs_debuginfo in aktmoduleswitches) and not inlined  then
+          begin
+            if assigned(procinfo^._class) then
+              if (not assigned(procinfo^.parent) or
+                 not assigned(procinfo^.parent^._class)) then
+                begin
+                  if (po_classmethod in aktprocdef.procoptions) or
+                     ((po_virtualmethod in aktprocdef.procoptions) and
+                      (potype_constructor=aktprocdef.proctypeoption)) or
+                     (po_staticmethod in aktprocdef.procoptions) then
+                    begin
+                      list.concat(Tai_stabs.Create(strpnew(
+                       '"pvmt:p'+tstoreddef(pvmttype.def).numberstring+'",'+
+                       tostr(N_tsym)+',0,0,'+tostr(procinfo^.selfpointer_offset))));
+                    end
+                  else
+                    begin
+                      if not(is_class(procinfo^._class)) then
+                        st:='v'
+                      else
+                        st:='p';
+                      list.concat(Tai_stabs.Create(strpnew(
+                       '"$t:'+st+procinfo^._class.numberstring+'",'+
+                       tostr(N_tsym)+',0,0,'+tostr(procinfo^.selfpointer_offset))));
+                    end;
+                end
+              else
+                begin
+                  if not is_class(procinfo^._class) then
+                    st:='*'
+                  else
+                    st:='';
+                  list.concat(Tai_stabs.Create(strpnew(
+                   '"$t:r'+st+procinfo^._class.numberstring+'",'+
+                   tostr(N_RSYM)+',0,0,'+tostr(GDB_i386index[R_ESI]))));
+                end;
+
+            { define calling EBP as pseudo local var PM }
+            { this enables test if the function is a local one !! }
+            if  assigned(procinfo^.parent) and (lexlevel>normal_function_level) then
+              list.concat(Tai_stabs.Create(strpnew(
+               '"parent_ebp:'+tstoreddef(voidpointertype.def).numberstring+'",'+
+               tostr(N_LSYM)+',0,0,'+tostr(procinfo^.framepointer_offset))));
+
+            if (not is_void(aktprocdef.rettype.def)) then
+              begin
+                if ret_in_param(aktprocdef.rettype.def) then
+                  list.concat(Tai_stabs.Create(strpnew(
+                   '"'+aktprocsym.name+':X*'+tstoreddef(aktprocdef.rettype.def).numberstring+'",'+
+                   tostr(N_tsym)+',0,0,'+tostr(procinfo^.return_offset))))
+                else
+                  list.concat(Tai_stabs.Create(strpnew(
+                   '"'+aktprocsym.name+':X'+tstoreddef(aktprocdef.rettype.def).numberstring+'",'+
+                   tostr(N_tsym)+',0,0,'+tostr(procinfo^.return_offset))));
+                if (m_result in aktmodeswitches) then
+                  if ret_in_param(aktprocdef.rettype.def) then
+                    list.concat(Tai_stabs.Create(strpnew(
+                     '"RESULT:X*'+tstoreddef(aktprocdef.rettype.def).numberstring+'",'+
+                     tostr(N_tsym)+',0,0,'+tostr(procinfo^.return_offset))))
+                  else
+                    list.concat(Tai_stabs.Create(strpnew(
+                     '"RESULT:X'+tstoreddef(aktprocdef.rettype.def).numberstring+'",'+
+                     tostr(N_tsym)+',0,0,'+tostr(procinfo^.return_offset))));
+              end;
+            mangled_length:=length(aktprocdef.mangledname);
+            getmem(p,2*mangled_length+50);
+            strpcopy(p,'192,0,0,');
+            strpcopy(strend(p),aktprocdef.mangledname);
+            if (target_info.use_function_relative_addresses) then
+              begin
+                strpcopy(strend(p),'-');
+                strpcopy(strend(p),aktprocdef.mangledname);
+              end;
+            list.concat(Tai_stabn.Create(strnew(p)));
+            {List.concat(Tai_stabn.Create(strpnew('192,0,0,'
+             +aktprocdef.mangledname))));
+            p[0]:='2';p[1]:='2';p[2]:='4';
+            strpcopy(strend(p),'_end');}
+            strpcopy(p,'224,0,0,'+stabsendlabel.name);
+            if (target_info.use_function_relative_addresses) then
+              begin
+                strpcopy(strend(p),'-');
+                strpcopy(strend(p),aktprocdef.mangledname);
+              end;
+            list.concatlist(withdebuglist);
+            list.concat(Tai_stabn.Create(strnew(p)));
+             { strpnew('224,0,0,'
+             +aktprocdef.mangledname+'_end'))));}
+            freemem(p,2*mangled_length+50);
+          end;
+{$endif GDB}
+
+        if inlined then
+         cleanup_regvars(list);
+      end;
+
+
+    procedure genimplicitunitinit(list : TAAsmoutput);
+      begin
+         { using current_module.globalsymtable is hopefully      }
+         { more robust than symtablestack and symtablestack.next }
+         tsymtable(current_module.globalsymtable).foreach_static({$ifdef FPCPROCVAR}@{$endif}finalize_data,list);
+         tsymtable(current_module.localsymtable).foreach_static({$ifdef FPCPROCVAR}@{$endif}finalize_data,list);
+         list.insert(Tai_symbol.Createname_global('INIT$$'+current_module.modulename^,0));
+         list.insert(Tai_symbol.Createname_global(target_info.cprefix+current_module.modulename^+'_init',0));
+{$ifdef GDB}
+         if (cs_debuginfo in aktmoduleswitches) and
+            target_info.use_function_relative_addresses then
+           list.insert(Tai_stab_function_name.Create(strpnew('INIT$$'+current_module.modulename^)));
+{$endif GDB}
+         cg.g_return_from_proc(list,0);
+      end;
+
+
+    procedure genimplicitunitfinal(list : TAAsmoutput);
+      begin
+         { using current_module.globalsymtable is hopefully      }
+         { more robust than symtablestack and symtablestack.next }
+         tsymtable(current_module.globalsymtable).foreach_static({$ifdef FPCPROCVAR}@{$endif}finalize_data,list);
+         tsymtable(current_module.localsymtable).foreach_static({$ifdef FPCPROCVAR}@{$endif}finalize_data,list);
+         list.insert(Tai_symbol.Createname_global('FINALIZE$$'+current_module.modulename^,0));
+         list.insert(Tai_symbol.Createname_global(target_info.cprefix+current_module.modulename^+'_finalize',0));
+{$ifdef GDB}
+         if (cs_debuginfo in aktmoduleswitches) and
+            target_info.use_function_relative_addresses then
+           list.insert(Tai_stab_function_name.Create(strpnew('FINALIZE$$'+current_module.modulename^)));
+{$endif GDB}
+         cg.g_return_from_proc(list,0);
+      end;
+
+
+
+end.
 {
   $Log$
-  Revision 1.10  2002-04-21 19:02:03  peter
+  Revision 1.11  2002-05-12 16:53:07  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.10  2002/04/21 19:02:03  peter
     * removed newn and disposen nodes, the code is now directly
       inlined from pexpr
     * -an option that will write the secondpass nodes to the .s file, this

compiler/ncnv.pas

@@ -110,7 +110,6 @@ interface
           constructor create(l,r : tnode);virtual;
           function pass_1 : tnode;override;
           function det_resulttype:tnode;override;
-          procedure pass_2;override;
        end;
        tasnodeclass = class of tasnode;
 
@@ -128,7 +127,9 @@ interface
        cisnode : tisnodeclass;
 
     procedure inserttypeconv(var p:tnode;const t:ttype);
-    procedure arrayconstructor_to_set(var p : tarrayconstructornode);
+    procedure inserttypeconv_explicit(var p:tnode;const t:ttype);
+    procedure arrayconstructor_to_set(var p : tnode);
+
 
 implementation
 
@@ -171,11 +172,36 @@ implementation
       end;
 
 
+    procedure inserttypeconv_explicit(var p:tnode;const t:ttype);
+
+      begin
+        if not assigned(p.resulttype.def) then
+         begin
+           resulttypepass(p);
+           if codegenerror then
+            exit;
+         end;
+
+        { don't insert obsolete type conversions }
+        if is_equal(p.resulttype.def,t.def) and
+           not ((p.resulttype.def.deftype=setdef) and
+                (tsetdef(p.resulttype.def).settype <>
+                 tsetdef(t.def).settype)) then
+         begin
+           p.resulttype:=t;
+         end
+        else
+         begin
+           p:=ctypeconvnode.create_explicit(p,t);
+           resulttypepass(p);
+         end;
+      end;
+
 {*****************************************************************************
                     Array constructor to Set Conversion
 *****************************************************************************}
 
-    procedure arrayconstructor_to_set(var p : tarrayconstructornode);
+    procedure arrayconstructor_to_set(var p : tnode);
 
       var
         constp      : tsetconstnode;
@@ -234,8 +260,10 @@ implementation
       var
         l : Longint;
         lr,hr : TConstExprInt;
-
+        hp : tarrayconstructornode;
       begin
+        if p.nodetype<>arrayconstructorn then
+         internalerror(200205105);
         new(constset);
         FillChar(constset^,sizeof(constset^),0);
         htype.reset;
@@ -244,23 +272,24 @@ implementation
         constp:=csetconstnode.create(nil,htype);
         constp.value_set:=constset;
         buildp:=constp;
-        if assigned(p.left) then
+        hp:=tarrayconstructornode(p);
+        if assigned(hp.left) then
          begin
-           while assigned(p) do
+           while assigned(hp) do
             begin
               p4:=nil; { will contain the tree to create the set }
             {split a range into p2 and p3 }
-              if p.left.nodetype=arrayconstructorrangen then
+              if hp.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;
+                 p2:=tarrayconstructorrangenode(hp.left).left;
+                 p3:=tarrayconstructorrangenode(hp.left).right;
+                 tarrayconstructorrangenode(hp.left).left:=nil;
+                 tarrayconstructorrangenode(hp.left).right:=nil;
                end
               else
                begin
-                 p2:=p.left;
-                 p.left:=nil;
+                 p2:=hp.left;
+                 hp.left:=nil;
                  p3:=nil;
                end;
               resulttypepass(p2);
@@ -368,12 +397,12 @@ implementation
                     else
                       CGMessage(type_e_ordinal_expr_expected);
               end;
-            { insert the set creation tree }
+              { insert the set creation tree }
               if assigned(p4) then
                buildp:=caddnode.create(addn,buildp,p4);
-            { load next and dispose current node }
-              p2:=p;
-              p:=tarrayconstructornode(tarrayconstructornode(p2).right);
+              { load next and dispose current node }
+              p2:=hp;
+              hp:=tarrayconstructornode(tarrayconstructornode(p2).right);
               tarrayconstructornode(p2).right:=nil;
               p2.free;
             end;
@@ -382,15 +411,15 @@ implementation
          end
         else
          begin
-         { empty set [], only remove node }
+           { empty set [], only remove node }
            p.free;
          end;
-      { set the initial set type }
+        { set the initial set type }
         constp.resulttype.setdef(tsetdef.create(htype,constsethi));
-      { determine the resulttype for the tree }
+        { determine the resulttype for the tree }
         resulttypepass(buildp);
-      { set the new tree }
-        p:=tarrayconstructornode(buildp);
+        { set the new tree }
+        p:=buildp;
       end;
 
 
@@ -727,11 +756,11 @@ implementation
         result:=nil;
         if left.nodetype<>arrayconstructorn then
          internalerror(5546);
-      { remove typeconv node }
+        { remove typeconv node }
         hp:=left;
         left:=nil;
-      { create a set constructor tree }
-        arrayconstructor_to_set(tarrayconstructornode(hp));
+        { create a set constructor tree }
+        arrayconstructor_to_set(hp);
         result:=hp;
       end;
 
@@ -993,13 +1022,38 @@ implementation
 
               { constant pointer to ordinal }
               else if is_ordinal(resulttype.def) and
-                (left.nodetype=pointerconstn) then
+                      (left.nodetype=pointerconstn) then
                 begin
                    hp:=cordconstnode.create(tpointerconstnode(left).value,resulttype);
                    result:=hp;
                    exit;
                 end
 
+              { class to class or object to object, with checkobject support }
+              else if (resulttype.def.deftype=objectdef) and
+                      (left.resulttype.def.deftype=objectdef) then
+                begin
+                  if (cs_check_object in aktlocalswitches) then
+                   begin
+                     if is_class_or_interface(resulttype.def) then
+                      begin
+                        { we can translate the typeconvnode to 'as' when
+                          typecasting to a class or interface }
+                        hp:=casnode.create(left,cloadvmtnode.create(ctypenode.create(resulttype)));
+                        left:=nil;
+                        result:=hp;
+                        exit;
+                      end;
+                   end
+                  else
+                   begin
+                     { check if the types are related }
+                     if (not(tobjectdef(left.resulttype.def).is_related(tobjectdef(resulttype.def)))) and
+                        (not(tobjectdef(resulttype.def).is_related(tobjectdef(left.resulttype.def)))) then
+                       CGMessage2(type_w_classes_not_related,left.resulttype.def.typename,resulttype.def.typename);
+                   end;
+                end
+
               {Are we typecasting an ordconst to a char?}
               else
                 if is_char(resulttype.def) and
@@ -1216,7 +1270,6 @@ implementation
     function ttypeconvnode.first_nothing : tnode;
       begin
          first_nothing:=nil;
-         location.loc:=LOC_CREFERENCE;
       end;
 
 
@@ -1475,9 +1528,9 @@ implementation
         { load the value_str from the left part }
         registers32:=left.registers32;
         registersfpu:=left.registersfpu;
- {$ifdef SUPPORT_MMX}
+{$ifdef SUPPORT_MMX}
         registersmmx:=left.registersmmx;
- {$endif}
+{$endif}
         location.loc:=left.location.loc;
 
         if nf_explizit in flags then
@@ -1488,25 +1541,7 @@ implementation
             make_not_regable(left);
          end;
 
-        if convtype=tc_equal then
-         begin
-           { remove typeconv node if left is a const. For other nodes we can't
-             remove it because the secondpass can still depend on the old type (PFV)
-             Conversions to float should also be left in the tree, because a float
-             is not possible in LOC_CONSTANT. The second_nothing routine will take
-             care of the conversion to LOC_REFERENCE }
-           if is_constnode(left) and
-              (resulttype.def.deftype<>floatdef) then
-            begin
-              left.resulttype:=resulttype;
-              result:=left;
-              left:=nil;
-            end;
-         end
-        else
-         begin
-           result:=first_call_helper(convtype);
-         end;
+        result:=first_call_helper(convtype);
       end;
 
 
@@ -1553,10 +1588,11 @@ implementation
                   tobjectdef(tclassrefdef(right.resulttype.def).pointertype.def)))) and
                   (not(tobjectdef(tclassrefdef(right.resulttype.def).pointertype.def).is_related(
                   tobjectdef(left.resulttype.def)))) then
-                 CGMessage(type_e_mismatch);
+                 CGMessage2(type_e_classes_not_related,left.resulttype.def.typename,
+                            tclassrefdef(right.resulttype.def).pointertype.def.typename);
              end
             else
-             CGMessage(type_e_mismatch);
+             CGMessage1(type_e_class_type_expected,left.resulttype.def.typename);
 
             { call fpc_do_is helper }
             paras := ccallparanode.create(
@@ -1575,7 +1611,7 @@ implementation
                { the operands must be related }
                if not(assigned(tobjectdef(left.resulttype.def).implementedinterfaces) and
                       (tobjectdef(left.resulttype.def).implementedinterfaces.searchintf(right.resulttype.def)<>-1)) then
-                 CGMessage(type_e_mismatch);
+                 CGMessage2(type_e_classes_not_related,left.resulttype.def.typename,right.resulttype.def.typename);
              end
             { left is an interface }
             else if is_interface(left.resulttype.def) then
@@ -1586,7 +1622,7 @@ implementation
                  CGMessage(type_e_mismatch);
              end
             else
-             CGMessage(type_e_mismatch);
+             CGMessage1(type_e_class_type_expected,left.resulttype.def.typename);
 
             { call fpc_do_is helper }
             paras := ccallparanode.create(
@@ -1598,7 +1634,7 @@ implementation
             right := nil;
           end
          else
-          CGMessage(type_e_mismatch);
+          CGMessage1(type_e_class_or_interface_type_expected,right.resulttype.def.typename);
 
          resulttype:=booltype;
       end;
@@ -1629,8 +1665,6 @@ implementation
 
 
     function tasnode.det_resulttype:tnode;
-      var
-        paras : tcallparanode;
       begin
          result:=nil;
          resulttypepass(right);
@@ -1652,19 +1686,12 @@ implementation
                   tobjectdef(tclassrefdef(right.resulttype.def).pointertype.def)))) and
                   (not(tobjectdef(tclassrefdef(right.resulttype.def).pointertype.def).is_related(
                   tobjectdef(left.resulttype.def)))) then
-                 CGMessage(type_e_mismatch);
+                 CGMessage2(type_e_classes_not_related,left.resulttype.def.typename,
+                            tclassrefdef(right.resulttype.def).pointertype.def.typename);
              end
             else
-             CGMessage(type_e_mismatch);
-
-            { call fpc_do_as helper }
-            paras := ccallparanode.create(
-                         left,
-                     ccallparanode.create(
-                         right,nil));
-            result := ccallnode.createinternres('fpc_do_as',paras,tclassrefdef(right.resulttype.def).pointertype);
-            left := nil;
-            right := nil;
+             CGMessage1(type_e_class_type_expected,left.resulttype.def.typename);
+            resulttype:=tclassrefdef(right.resulttype.def).pointertype;
           end
          else if is_interface(right.resulttype.def) then
           begin
@@ -1674,7 +1701,7 @@ implementation
                { the operands must be related }
                if not(assigned(tobjectdef(left.resulttype.def).implementedinterfaces) and
                       (tobjectdef(left.resulttype.def).implementedinterfaces.searchintf(right.resulttype.def)<>-1)) then
-                 CGMessage(type_e_mismatch);
+                 CGMessage2(type_e_classes_not_related,left.resulttype.def.typename,right.resulttype.def.typename);
              end
             { left is an interface }
             else if is_interface(left.resulttype.def) then
@@ -1682,39 +1709,29 @@ implementation
                { the operands must be related }
                if (not(tobjectdef(left.resulttype.def).is_related(tobjectdef(right.resulttype.def)))) and
                   (not(tobjectdef(right.resulttype.def).is_related(tobjectdef(left.resulttype.def)))) then
-                 CGMessage(type_e_mismatch);
+                 CGMessage2(type_e_classes_not_related,left.resulttype.def.typename,right.resulttype.def.typename);
              end
             else
-             CGMessage(type_e_mismatch);
-
-            { call fpc_do_as helper }
-            paras := ccallparanode.create(
-                         left,
-                     ccallparanode.create(
-                         right,nil));
-            result := ccallnode.createinternres('fpc_do_as',paras,right.resulttype);
-            left := nil;
-            right := nil;
+             CGMessage1(type_e_class_type_expected,left.resulttype.def.typename);
+            resulttype:=right.resulttype;
           end
          else
-          CGMessage(type_e_mismatch);
+          CGMessage1(type_e_class_or_interface_type_expected,right.resulttype.def.typename);
       end;
 
 
     function tasnode.pass_1 : tnode;
       begin
-        internalerror(200204252);
+        firstpass(left);
+        firstpass(right);
+        if codegenerror then
+         exit;
+        left_right_max;
+        location.loc:=left.location.loc;
         result:=nil;
       end;
 
 
-    { dummy pass_2, it will never be called, but we need one since }
-    { you can't instantiate an abstract class                      }
-    procedure tasnode.pass_2;
-      begin
-      end;
-
-
 begin
    ctypeconvnode:=ttypeconvnode;
    casnode:=tasnode;
@@ -1722,7 +1739,24 @@ begin
 end.
 {
   $Log$
-  Revision 1.54  2002-04-25 20:16:38  peter
+  Revision 1.55  2002-05-12 16:53:07  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.54  2002/04/25 20:16:38  peter
     * moved more routines from cga/n386util
 
   Revision 1.53  2002/04/23 19:16:34  peter

compiler/ncon.pas

@@ -297,11 +297,8 @@ implementation
             p1:=cpointerconstnode.create(p.valueordptr,p.consttype);
           constnil :
             p1:=cnilnode.create;
-          constresourcestring:
-            begin
-              p1:=cloadnode.create(tvarsym(p),tvarsym(p).owner);
-              p1.resulttype:=cansistringtype;
-            end;
+          else
+            internalerror(200205103);
         end;
         genconstsymtree:=p1;
       end;
@@ -724,7 +721,24 @@ begin
 end.
 {
   $Log$
-  Revision 1.28  2002-04-07 13:25:20  carl
+  Revision 1.29  2002-05-12 16:53:07  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.28  2002/04/07 13:25:20  carl
   + change unit use
 
   Revision 1.27  2002/04/04 19:05:58  peter

compiler/nflw.pas

@@ -498,7 +498,7 @@ implementation
          while (hp.nodetype=subscriptn) or
                ((hp.nodetype=vecn) and
                 is_constintnode(tvecnode(hp).right)) do
-          hp:=tsubscriptnode(hp).left;
+          hp:=tunarynode(hp).left;
          { we need a simple loadn, but the load must be in a global symtable or
            in the same lexlevel }
          if (hp.nodetype=funcretn) or
@@ -1113,7 +1113,24 @@ begin
 end.
 {
   $Log$
-  Revision 1.28  2002-03-31 20:26:34  jonas
+  Revision 1.29  2002-05-12 16:53:07  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.28  2002/03/31 20:26:34  jonas
     + a_loadfpu_* and a_loadmm_* methods in tcg
     * register allocation is now handled by a class and is mostly processor
       independent (+rgobj.pas and i386/rgcpu.pas)

compiler/nld.pas

@@ -530,11 +530,10 @@ implementation
         { call helpers for interface }
         if is_interfacecom(left.resulttype.def) then
          begin
-           hp:=ccallparanode.create
-                   (right,
-               ccallparanode.create(caddrnode.create
-                   (left),nil));
-           hp:=ccallparanode.create(right,nil);
+           hp:=ccallparanode.create(ctypeconvnode.create_explicit
+                   (right,voidpointertype),
+               ccallparanode.create(ctypeconvnode.create_explicit
+                   (left,voidpointertype),nil));
            result:=ccallnode.createintern('fpc_intf_assign',hp);
            left:=nil;
            right:=nil;
@@ -956,7 +955,24 @@ begin
 end.
 {
   $Log$
-  Revision 1.38  2002-04-25 20:16:39  peter
+  Revision 1.39  2002-05-12 16:53:07  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.38  2002/04/25 20:16:39  peter
     * moved more routines from cga/n386util
 
   Revision 1.37  2002/04/23 19:16:34  peter

compiler/nmem.pas

@@ -94,8 +94,8 @@ interface
        tvecnodeclass = class of tvecnode;
 
        tselfnode = class(tnode)
-          classdef : tobjectdef;
-          constructor create(_class : tobjectdef);virtual;
+          classdef : tdef; { objectdef or classrefdef }
+          constructor create(_class : tdef);virtual;
           function pass_1 : tnode;override;
           function det_resulttype:tnode;override;
        end;
@@ -748,7 +748,7 @@ implementation
                                TSELFNODE
 *****************************************************************************}
 
-    constructor tselfnode.create(_class : tobjectdef);
+    constructor tselfnode.create(_class : tdef);
 
       begin
          inherited create(selfn);
@@ -789,6 +789,7 @@ implementation
 
     destructor twithnode.destroy;
       var
+        hsymt,
         symt : tsymtable;
         i    : longint;
       begin
@@ -797,10 +798,10 @@ implementation
          begin
            if assigned(symt) then
             begin
-              withsymtable:=twithsymtable(symt.next);
+              hsymt:=symt.next;
               symt.free;
+              symt:=hsymt;
             end;
-           symt:=withsymtable;
          end;
         inherited destroy;
       end;
@@ -821,7 +822,7 @@ implementation
 
     function twithnode.det_resulttype:tnode;
       var
-         symtable : twithsymtable;
+         symtable : tsymtable;
          i : longint;
       begin
          result:=nil;
@@ -839,9 +840,9 @@ implementation
              begin
                if (left.nodetype=loadn) and
                   (tloadnode(left).symtable=aktprocdef.localst) then
-                symtable.direct_with:=true;
-               symtable.withnode:=self;
-               symtable:=twithsymtable(symtable.next);
+                twithsymtable(symtable).direct_with:=true;
+               twithsymtable(symtable).withnode:=self;
+               symtable:=symtable.next;
              end;
 
             resulttypepass(right);
@@ -893,7 +894,24 @@ begin
 end.
 {
   $Log$
-  Revision 1.29  2002-04-21 19:02:04  peter
+  Revision 1.30  2002-05-12 16:53:07  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.29  2002/04/21 19:02:04  peter
     * removed newn and disposen nodes, the code is now directly
       inlined from pexpr
     * -an option that will write the secondpass nodes to the .s file, this

compiler/nobj.pas

@@ -61,8 +61,8 @@ interface
         { message tables }
         root : pprocdeftree;
         procedure disposeprocdeftree(p : pprocdeftree);
-        procedure insertmsgint(p : tnamedindexitem);
-        procedure insertmsgstr(p : tnamedindexitem);
+        procedure insertmsgint(p : tnamedindexitem;arg:pointer);
+        procedure insertmsgstr(p : tnamedindexitem;arg:pointer);
         procedure insertint(p : pprocdeftree;var at : pprocdeftree);
         procedure insertstr(p : pprocdeftree;var at : pprocdeftree);
         procedure writenames(p : pprocdeftree);
@@ -71,21 +71,21 @@ interface
 {$ifdef WITHDMT}
       private
         { dmt }
-        procedure insertdmtentry(p : tnamedindexitem);
+        procedure insertdmtentry(p : tnamedindexitem;arg:pointer);
         procedure writedmtindexentry(p : pprocdeftree);
         procedure writedmtaddressentry(p : pprocdeftree);
 {$endif}
       private
         { published methods }
-        procedure do_count(p : tnamedindexitem);
-        procedure genpubmethodtableentry(p : tnamedindexitem);
+        procedure do_count(p : tnamedindexitem;arg:pointer);
+        procedure genpubmethodtableentry(p : tnamedindexitem;arg:pointer);
       private
         { vmt }
         wurzel : psymcoll;
         nextvirtnumber : integer;
         has_constructor,
         has_virtual_method : boolean;
-        procedure eachsym(sym : tnamedindexitem);
+        procedure eachsym(sym : tnamedindexitem;arg:pointer);
         procedure disposevmttree;
         procedure writevirtualmethods(List:TAAsmoutput);
       private
@@ -136,11 +136,10 @@ implementation
 {$endif}
        globtype,globals,verbose,
        symtable,symconst,symtype,symsym,types,
-       fmodule,
 {$ifdef GDB}
        gdb,
 {$endif GDB}
-       cpuinfo,cpubase
+       cpuinfo
        ;
 
 
@@ -217,7 +216,7 @@ implementation
            end;
       end;
 
-    procedure tclassheader.insertmsgint(p : tnamedindexitem);
+    procedure tclassheader.insertmsgint(p : tnamedindexitem;arg:pointer);
 
       var
          hp : pprocdeflist;
@@ -241,7 +240,7 @@ implementation
            end;
       end;
 
-    procedure tclassheader.insertmsgstr(p : tnamedindexitem);
+    procedure tclassheader.insertmsgstr(p : tnamedindexitem;arg:pointer);
 
       var
          hp : pprocdeflist;
@@ -301,7 +300,7 @@ implementation
          root:=nil;
          count:=0;
          { insert all message handlers into a tree, sorted by name }
-         _class.symtable.foreach({$ifdef FPCPROCVAR}@{$endif}insertmsgstr);
+         _class.symtable.foreach({$ifdef FPCPROCVAR}@{$endif}insertmsgstr,nil);
 
          { write all names }
          if assigned(root) then
@@ -341,7 +340,7 @@ implementation
          root:=nil;
          count:=0;
          { insert all message handlers into a tree, sorted by name }
-         _class.symtable.foreach({$ifdef FPCPROCVAR}@{$endif}insertmsgint);
+         _class.symtable.foreach({$ifdef FPCPROCVAR}@{$endif}insertmsgint,nil);
 
          { now start writing of the message string table }
          getdatalabel(r);
@@ -361,7 +360,7 @@ implementation
               DMT
 **************************************}
 
-    procedure tclassheader.insertdmtentry(p : tnamedindexitem);
+    procedure tclassheader.insertdmtentry(p : tnamedindexitem;arg:pointer);
 
       var
          hp : tprocdef;
@@ -443,14 +442,14 @@ implementation
         Published Methods
 **************************************}
 
-    procedure tclassheader.do_count(p : tnamedindexitem);
+    procedure tclassheader.do_count(p : tnamedindexitem;arg:pointer);
 
       begin
          if (tsym(p).typ=procsym) and (sp_published in tsym(p).symoptions) then
            inc(count);
       end;
 
-    procedure tclassheader.genpubmethodtableentry(p : tnamedindexitem);
+    procedure tclassheader.genpubmethodtableentry(p : tnamedindexitem;arg:pointer);
 
       var
          hp : tprocdef;
@@ -480,13 +479,13 @@ implementation
 
       begin
          count:=0;
-         _class.symtable.foreach({$ifdef FPCPROCVAR}@{$endif}do_count);
+         _class.symtable.foreach({$ifdef FPCPROCVAR}@{$endif}do_count,nil);
          if count>0 then
            begin
               getdatalabel(l);
               dataSegment.concat(Tai_label.Create(l));
               dataSegment.concat(Tai_const.Create_32bit(count));
-              _class.symtable.foreach({$ifdef FPCPROCVAR}@{$endif}genpubmethodtableentry);
+              _class.symtable.foreach({$ifdef FPCPROCVAR}@{$endif}genpubmethodtableentry,nil);
               genpublishedmethodstable:=l;
            end
          else
@@ -498,7 +497,7 @@ implementation
                VMT
 **************************************}
 
-    procedure tclassheader.eachsym(sym : tnamedindexitem);
+    procedure tclassheader.eachsym(sym : tnamedindexitem;arg:pointer);
 
       var
          procdefcoll : pprocdefcoll;
@@ -746,7 +745,7 @@ implementation
              do_genvmt(p.childof);
 
            { walk through all public syms }
-           p.symtable.foreach({$ifdef FPCPROCVAR}@{$endif}eachsym);
+           p.symtable.foreach({$ifdef FPCPROCVAR}@{$endif}eachsym,nil);
         end;
 
       begin
@@ -1270,7 +1269,24 @@ initialization
 end.
 {
   $Log$
-  Revision 1.16  2002-04-20 21:32:24  carl
+  Revision 1.17  2002-05-12 16:53:08  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.16  2002/04/20 21:32:24  carl
   + generic FPC_CHECKPOINTER
   + first parameter offset in stack now portable
   * rename some constants

compiler/nset.pas

@@ -221,7 +221,7 @@ implementation
          { Convert array constructor first to set }
          if is_array_constructor(right.resulttype.def) then
           begin
-            arrayconstructor_to_set(tarrayconstructornode(right));
+            arrayconstructor_to_set(right);
             firstpass(right);
             if codegenerror then
              exit;
@@ -574,7 +574,24 @@ begin
 end.
 {
   $Log$
-  Revision 1.20  2002-04-07 13:27:50  carl
+  Revision 1.21  2002-05-12 16:53:08  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.20  2002/04/07 13:27:50  carl
   + change unit use
 
   Revision 1.19  2002/04/02 17:11:29  peter

compiler/ogelf.pas

@@ -425,17 +425,15 @@ implementation
     procedure telf32data.writestabs(section:tsection;offset:longint;p:pchar;nidx,nother,line:longint;reloc : boolean);
       var
         stab : telf32stab;
-        s : tsection;
       begin
-        s:=section;
         if reloc then
          begin
            if (offset=-1) then
             begin
-              if s=sec_none then
+              if section=sec_none then
                offset:=0
               else
-               offset:=sects[s].datasize;
+               offset:=sects[section].datasize;
             end;
          end;
         fillchar(stab,sizeof(telf32stab),0);
@@ -452,7 +450,7 @@ implementation
         { when the offset is not 0 then write a relocation, take also the
           hdrstab into account with the offset }
         if reloc then
-         sects[sec_stab].addsectionreloc(sects[sec_stab].datasize-4,s,relative_false);
+         sects[sec_stab].addsectionreloc(sects[sec_stab].datasize-4,section,relative_false);
       end;
 
 
@@ -461,16 +459,6 @@ implementation
       var
         stab : telf32stab;
       begin
-        if reloc then
-         begin
-           if (offset=-1) then
-            begin
-              if section=sec_none then
-               offset:=0
-              else
-               offset:=sects[section].datasize;
-            end;
-         end;
         fillchar(stab,sizeof(telf32stab),0);
         if assigned(p) and (p[0]<>#0) then
          begin
@@ -480,7 +468,7 @@ implementation
         stab.ntype:=nidx;
         stab.ndesc:=line;
         stab.nother:=nother;
-        stab.nvalue:=offset;
+        stab.nvalue:=0;
         sects[sec_stab].write(stab,sizeof(stab));
         { when the offset is not 0 then write a relocation, take also the
           hdrstab into account with the offset }
@@ -886,7 +874,24 @@ initialization
 end.
 {
   $Log$
-  Revision 1.11  2002-04-04 19:05:58  peter
+  Revision 1.12  2002-05-12 16:53:08  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.11  2002/04/04 19:05:58  peter
     * removed unused units
     * use tlocation.size in cg.a_*loc*() routines
 

compiler/options.pas

@@ -466,9 +466,15 @@ begin
                                 include(initlocalswitches,cs_check_range);
                             'R' :
                               If UnsetBool(More, j) then
-                                exclude(initlocalswitches,cs_check_object_ext)
+                                begin
+                                  exclude(initlocalswitches,cs_check_range);
+                                  exclude(initlocalswitches,cs_check_object);
+                                end
                               Else
-                                include(initlocalswitches,cs_check_object_ext);
+                                begin
+                                  include(initlocalswitches,cs_check_range);
+                                  include(initlocalswitches,cs_check_object);
+                                end;
                             's' :
                               begin
                                  val(copy(more,j+1,length(more)-j),stacksize,code);
@@ -1658,7 +1664,24 @@ finalization
 end.
 {
   $Log$
-  Revision 1.69  2002-04-21 19:02:04  peter
+  Revision 1.70  2002-05-12 16:53:08  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.69  2002/04/21 19:02:04  peter
     * removed newn and disposen nodes, the code is now directly
       inlined from pexpr
     * -an option that will write the secondpass nodes to the .s file, this

compiler/pass_2.pas

@@ -226,7 +226,7 @@ implementation
          do_secondpass:=codegenerror;
       end;
 
-    procedure clearrefs(p : tnamedindexitem);
+    procedure clearrefs(p : tnamedindexitem;arg:pointer);
 
       begin
          if (tsym(p).typ=varsym) then
@@ -247,8 +247,8 @@ implementation
          { clear register count }
          rg.clearregistercount;
          use_esp_stackframe:=false;
-         symtablestack.foreach_static({$ifdef FPCPROCVAR}@{$endif}clearrefs);
-         symtablestack.next.foreach_static({$ifdef FPCPROCVAR}@{$endif}clearrefs);
+         symtablestack.foreach_static({$ifdef FPCPROCVAR}@{$endif}clearrefs,nil);
+         symtablestack.next.foreach_static({$ifdef FPCPROCVAR}@{$endif}clearrefs,nil);
          { firstpass everything }
          do_firstpass(p);
          { only do secondpass if there are no errors }
@@ -321,7 +321,24 @@ implementation
 end.
 {
   $Log$
-  Revision 1.26  2002-04-21 19:02:04  peter
+  Revision 1.27  2002-05-12 16:53:08  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.26  2002/04/21 19:02:04  peter
     * removed newn and disposen nodes, the code is now directly
       inlined from pexpr
     * -an option that will write the secondpass nodes to the .s file, this

compiler/pdecl.pas

@@ -268,7 +268,7 @@ implementation
 
 
     { search in symtablestack used, but not defined type }
-    procedure resolve_type_forward(p : tnamedindexitem);
+    procedure resolve_type_forward(p : tnamedindexitem;arg:pointer);
       var
         hpd,pd : tdef;
         stpos  : tfileposinfo;
@@ -347,7 +347,7 @@ implementation
                   end;
                end;
              recorddef :
-               trecorddef(pd).symtable.foreach_static({$ifdef FPCPROCVAR}@{$endif}resolve_type_forward);
+               trecorddef(pd).symtable.foreach_static({$ifdef FPCPROCVAR}@{$endif}resolve_type_forward,nil);
              objectdef :
                begin
                  if not(m_fpc in aktmodeswitches) and
@@ -363,7 +363,7 @@ implementation
                       check objectdefs in objects/records, because these
                       can't exist (anonymous objects aren't allowed) }
                     if not(tsym(p).owner.symtabletype in [objectsymtable,recordsymtable]) then
-                     tobjectdef(pd).symtable.foreach_static({$ifdef FPCPROCVAR}@{$endif}resolve_type_forward);
+                     tobjectdef(pd).symtable.foreach_static({$ifdef FPCPROCVAR}@{$endif}resolve_type_forward,nil);
                   end;
                end;
           end;
@@ -524,7 +524,7 @@ implementation
             end;
          until token<>_ID;
          typecanbeforward:=false;
-         symtablestack.foreach_static({$ifdef FPCPROCVAR}@{$endif}resolve_type_forward);
+         symtablestack.foreach_static({$ifdef FPCPROCVAR}@{$endif}resolve_type_forward,nil);
          block_type:=old_block_type;
       end;
 
@@ -608,7 +608,24 @@ implementation
 end.
 {
   $Log$
-  Revision 1.42  2002-04-19 15:46:02  peter
+  Revision 1.43  2002-05-12 16:53:08  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.42  2002/04/19 15:46:02  peter
     * mangledname rewrite, tprocdef.mangledname is now created dynamicly
       in most cases and not written to the ppu
     * add mangeledname_prefix() routine to generate the prefix of

compiler/pdecobj.pas

@@ -516,7 +516,7 @@ implementation
                      if (p.proptype.def.deftype=setdef) and
                         (pt.nodetype=arrayconstructorn) then
                        begin
-                         arrayconstructor_to_set(tarrayconstructornode(pt));
+                         arrayconstructor_to_set(pt);
                          do_resulttypepass(pt);
                        end;
                      inserttypeconv(pt,p.proptype);
@@ -1111,7 +1111,24 @@ implementation
 end.
 {
   $Log$
-  Revision 1.41  2002-04-21 19:02:04  peter
+  Revision 1.42  2002-05-12 16:53:08  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.41  2002/04/21 19:02:04  peter
     * removed newn and disposen nodes, the code is now directly
       inlined from pexpr
     * -an option that will write the secondpass nodes to the .s file, this

compiler/pdecsub.pas

@@ -85,7 +85,7 @@ implementation
        ;
 
 
-    procedure resetvaluepara(p:tnamedindexitem);
+    procedure resetvaluepara(p:tnamedindexitem;arg:pointer);
       begin
         if tsym(p).typ=varsym then
          with tvarsym(p) do
@@ -1464,7 +1464,8 @@ const
     procedure handle_calling_convention(sym:tprocsym;def:tabstractprocdef);
       var
         st,parast : tsymtable;
-        lastps,ps : tsym;
+        lastps,
+        highps,ps : tsym;
       begin
       { set the default calling convention }
         if def.proccalloption=pocall_none then
@@ -1483,7 +1484,7 @@ const
                  if not assigned(tprocdef(def).parast) then
                   internalerror(200110234);
                  { do not copy on local !! }
-                 tprocdef(def).parast.foreach_static({$ifdef FPCPROCVAR}@{$endif}resetvaluepara);
+                 tprocdef(def).parast.foreach_static({$ifdef FPCPROCVAR}@{$endif}resetvaluepara,nil);
                  { Adjust positions of args for cdecl or stdcall }
                  tparasymtable(tprocdef(def).parast).set_alignment(std_param_align);
                end;
@@ -1503,7 +1504,7 @@ const
                  if not assigned(tprocdef(def).parast) then
                   internalerror(200110235);
                  { do not copy on local !! }
-                 tprocdef(def).parast.foreach_static({$ifdef FPCPROCVAR}@{$endif}resetvaluepara);
+                 tprocdef(def).parast.foreach_static({$ifdef FPCPROCVAR}@{$endif}resetvaluepara,nil);
                  { Adjust positions of args for cdecl or stdcall }
                  tparasymtable(tprocdef(def).parast).set_alignment(std_param_align);
                end;
@@ -1532,25 +1533,43 @@ const
           pocall_pascal :
             begin
               include(def.procoptions,po_leftright);
-              st:=tparasymtable.create;
               if def.deftype=procdef then
                begin
+                 st:=tparasymtable.create;
+                 st.symindex.noclear:=true;
                  parast:=tprocdef(def).parast;
+                 highps:=nil;
                  lastps:=nil;
                  while assigned(parast.symindex.first) and (lastps<>tsym(parast.symindex.first)) do
                   begin
                     ps:=tsym(parast.symindex.first);
                     while assigned(ps.indexnext) and (tsym(ps.indexnext)<>lastps) do
                       ps:=tsym(ps.indexnext);
-                    ps.owner:=st;
-                    { recalculate the corrected offset }
-                    { the really_insert_in_data procedure
-                      for parasymtable should only calculateoffset PM }
-                    tstoredsym(ps).insert_in_data;
-                    { reset the owner correctly }
-                    ps.owner:=parast;
+                    { Wait with inserting the high value, it needs to be inserted
+                      after the corresponding parameter }
+                    if Copy(ps.name,1,4)='high' then
+                     highps:=ps
+                    else
+                     begin
+                       { recalculate the corrected offset by inserting it into
+                         the new symtable and then reset the owner back }
+                       ps.owner:=st;
+                       tstoredsym(ps).insert_in_data;
+                       ps.owner:=parast;
+                       { add also the high tree if it was saved }
+                       if assigned(highps) then
+                        begin
+                          highps.owner:=st;
+                          tstoredsym(highps).insert_in_data;
+                          highps.owner:=parast;
+                          highps:=nil;
+                        end;
+                     end;
                     lastps:=ps;
                   end;
+                 st.free;
+                 if assigned(highps) then
+                  internalerror(200205111);
                end;
             end;
           pocall_register :
@@ -1581,7 +1600,7 @@ const
                  if not assigned(tprocdef(def).parast) then
                   internalerror(200110236);
                  { do not copy on local !! }
-                 tprocdef(def).parast.foreach_static({$ifdef FPCPROCVAR}@{$endif}resetvaluepara);
+                 tprocdef(def).parast.foreach_static({$ifdef FPCPROCVAR}@{$endif}resetvaluepara,nil);
                  { Adjust positions of args for cdecl or stdcall }
                  tparasymtable(tprocdef(def).parast).set_alignment(std_param_align);
                end;
@@ -1938,7 +1957,24 @@ const
 end.
 {
   $Log$
-  Revision 1.53  2002-04-21 19:02:04  peter
+  Revision 1.54  2002-05-12 16:53:08  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.53  2002/04/21 19:02:04  peter
     * removed newn and disposen nodes, the code is now directly
       inlined from pexpr
     * -an option that will write the secondpass nodes to the .s file, this

compiler/pexpr.pas

@@ -715,12 +715,12 @@ implementation
                      subscriptn. If no tree is found (with block), then
                      generate a loadn }
                    if assigned(p1) then
-                    p1:=csubscriptnode.create(tvarsym(plist^.sym),p1)
+                    p1:=csubscriptnode.create(plist^.sym,p1)
                    else
-                    p1:=cloadnode.create(tvarsym(plist^.sym),st);
+                    p1:=cloadnode.create(plist^.sym,st);
                  end;
                sl_subscript :
-                 p1:=csubscriptnode.create(tvarsym(plist^.sym),p1);
+                 p1:=csubscriptnode.create(plist^.sym,p1);
                sl_vec :
                  p1:=cvecnode.create(p1,cordconstnode.create(plist^.value,s32bittype));
                else
@@ -903,10 +903,10 @@ implementation
                            static_name:=lower(sym.owner.name^)+'_'+sym.name;
                            searchsym(static_name,sym,srsymtable);
                            p1.free;
-                           p1:=cloadnode.create(tvarsym(sym),srsymtable);
+                           p1:=cloadnode.create(sym,srsymtable);
                         end
                       else
-                        p1:=csubscriptnode.create(tvarsym(sym),p1);
+                        p1:=csubscriptnode.create(sym,p1);
                    end;
                  propertysym:
                    begin
@@ -948,17 +948,17 @@ implementation
                { is this an access to a function result? Accessing _RESULT is
                  always allowed and funcretn is generated }
                if assigned(p^.procdef.funcretsym) and
-                  ((tfuncretsym(sym)=p^.procdef.resultfuncretsym) or
-                   ((tfuncretsym(sym)=p^.procdef.funcretsym) or
-                    ((tvarsym(sym)=otsym) and ((p^.flags and pi_operator)<>0))) and
+                  ((sym=tsym(p^.procdef.resultfuncretsym)) or
+                   ((sym=tsym(p^.procdef.funcretsym)) or
+                    ((sym=tsym(otsym)) and ((p^.flags and pi_operator)<>0))) and
                    (not is_void(p^.procdef.rettype.def)) and
                    (token<>_LKLAMMER) and
                    (not (not(m_fpc in aktmodeswitches) and (afterassignment or in_args)))
                   ) then
                  begin
-                    if ((tvarsym(sym)=otsym) and
+                    if ((sym=tsym(otsym)) and
                        ((p^.flags and pi_operator)<>0)) then
-                       inc(otsym.refs);
+                      inc(otsym.refs);
                     p1:=cfuncretnode.create(p^.procdef.funcretsym);
                     is_func_ret:=true;
                     if tfuncretsym(p^.procdef.funcretsym).funcretstate=vs_declared then
@@ -1016,7 +1016,7 @@ implementation
               case srsym.typ of
                 absolutesym :
                   begin
-                    p1:=cloadnode.create(tvarsym(srsym),srsymtable);
+                    p1:=cloadnode.create(srsym,srsymtable);
                   end;
 
                 varsym :
@@ -1031,7 +1031,7 @@ implementation
                        static_name:=lower(srsym.owner.name^)+'_'+srsym.name;
                        searchsym(static_name,srsym,srsymtable);
                      end;
-                    p1:=cloadnode.create(tvarsym(srsym),srsymtable);
+                    p1:=cloadnode.create(srsym,srsymtable);
                     if tvarsym(srsym).varstate=vs_declared then
                      begin
                        include(p1.flags,nf_first);
@@ -1097,7 +1097,7 @@ implementation
                               p1:=ctypenode.create(htype);
                               { TP allows also @TMenu.Load if Load is only }
                               { defined in an anchestor class              }
-                              srsym:=tvarsym(search_class_member(tobjectdef(htype.def),pattern));
+                              srsym:=search_class_member(tobjectdef(htype.def),pattern);
                               if not assigned(srsym) then
                                Message1(sym_e_id_no_member,pattern)
                               else if not(getaddr) and not(sp_static in srsym.symoptions) then
@@ -1122,7 +1122,7 @@ implementation
                                 p1:=ctypenode.create(htype);
                                 { TP allows also @TMenu.Load if Load is only }
                                 { defined in an anchestor class              }
-                                srsym:=tvarsym(search_class_member(tobjectdef(htype.def),pattern));
+                                srsym:=search_class_member(tobjectdef(htype.def),pattern);
                                 if not assigned(srsym) then
                                  Message1(sym_e_id_no_member,pattern)
                                 else
@@ -1193,7 +1193,7 @@ implementation
                         p1:=cnilnode.create;
                       constresourcestring:
                         begin
-                          p1:=cloadnode.create(tvarsym(srsym),srsymtable);
+                          p1:=cloadnode.create(srsym,srsymtable);
                           do_resulttypepass(p1);
                           p1.resulttype:=cansistringtype;
                         end;
@@ -1499,7 +1499,7 @@ implementation
                             hsym:=tsym(trecorddef(p1.resulttype.def).symtable.search(pattern));
                             if assigned(hsym) and
                                (hsym.typ=varsym) then
-                              p1:=csubscriptnode.create(tvarsym(hsym),p1)
+                              p1:=csubscriptnode.create(hsym,p1)
                             else
                               begin
                                 Message1(sym_e_illegal_field,pattern);
@@ -1687,7 +1687,7 @@ implementation
                    begin
                      { self in class methods is a class reference type }
                      htype.setdef(procinfo^._class);
-                     p1:=cselfnode.create(tobjectdef(tclassrefdef.create(htype)));
+                     p1:=cselfnode.create(tclassrefdef.create(htype));
                    end
                   else
                    p1:=cselfnode.create(procinfo^._class);
@@ -2224,7 +2224,24 @@ implementation
 end.
 {
   $Log$
-  Revision 1.64  2002-04-23 19:16:34  peter
+  Revision 1.65  2002-05-12 16:53:09  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.64  2002/04/23 19:16:34  peter
     * add pinline unit that inserts compiler supported functions using
       one or more statements
     * moved finalize and setlength from ninl to pinline

compiler/pinline.pas

@@ -1,6 +1,6 @@
 {
     $Id$
-    Copyright (c) 1998-2002 by Florian Klaempfl
+    Copyright (c) 1998-2001 by Florian Klaempfl
 
     Generates nodes for routines that need compiler support
 
@@ -22,7 +22,7 @@
 }
 unit pinline;
 
-{$i fpcdefs.inc}
+{$i defines.inc}
 
 interface
 
@@ -37,7 +37,6 @@ interface
 
     function inline_setlength : tnode;
     function inline_finalize : tnode;
-    function inline_copy : tnode;
 
 
 implementation
@@ -52,7 +51,7 @@ implementation
        globtype,tokens,verbose,
        systems,
        { symtable }
-       symconst,symdef,symsym,symtable,defutil,
+       symconst,symdef,symsym,symtable,types,
        { pass 1 }
        pass_1,htypechk,
        nmat,nadd,ncal,nmem,nset,ncnv,ninl,ncon,nld,nflw,nbas,
@@ -170,15 +169,6 @@ implementation
                 { we need the real called method }
                 { rg.cleartempgen;}
                 do_resulttypepass(p2);
-
-                if p2.nodetype<>calln then
-                  begin
-                    if is_new then
-                      CGMessage(parser_e_expr_have_to_be_constructor_call)
-                    else
-                      CGMessage(parser_e_expr_have_to_be_destructor_call);
-                  end;
-
                 if not codegenerror then
                  begin
                    if is_new then
@@ -221,7 +211,7 @@ implementation
 
                   { create statements with call to getmem+initialize or
                     finalize+freemem }
-                  new_dispose_statement:=internalstatements(newstatement,true);
+                  new_dispose_statement:=internalstatements(newstatement);
 
                   if is_new then
                    begin
@@ -231,7 +221,7 @@ implementation
 
                      { create call to fpc_getmem }
                      para := ccallparanode.create(cordconstnode.create
-                         (tpointerdef(p.resulttype.def).pointertype.def.size,s32bittype,true),nil);
+                         (tpointerdef(p.resulttype.def).pointertype.def.size,s32bittype),nil);
                      addstatement(newstatement,cassignmentnode.create(
                          ctemprefnode.create(temp),
                          ccallnode.createintern('fpc_getmem',para)));
@@ -307,7 +297,7 @@ implementation
               Message(parser_w_use_extended_syntax_for_objects);
 
             { create statements with call to getmem+initialize }
-            newblock:=internalstatements(newstatement,true);
+            newblock:=internalstatements(newstatement);
 
             { create temp for result }
             temp := ctempcreatenode.create(p1.resulttype,p1.resulttype.def.size,true);
@@ -315,7 +305,7 @@ implementation
 
             { create call to fpc_getmem }
             para := ccallparanode.create(cordconstnode.create
-                (tpointerdef(p1.resulttype.def).pointertype.def.size,s32bittype,true),nil);
+                (tpointerdef(p1.resulttype.def).pointertype.def.size,s32bittype),nil);
             addstatement(newstatement,cassignmentnode.create(
                 ctemprefnode.create(temp),
                 ccallnode.createintern('fpc_getmem',para)));
@@ -465,7 +455,7 @@ implementation
          begin
             { create statements with call initialize the arguments and
               call fpc_dynarr_setlength }
-            newblock:=internalstatements(newstatement,true);
+            newblock:=internalstatements(newstatement);
 
             { get temp for array of lengths }
             temp := ctempcreatenode.create(s32bittype,counter*s32bittype.def.size,true);
@@ -490,7 +480,7 @@ implementation
             npara:=ccallparanode.create(caddrnode.create
                       (ctemprefnode.create(temp)),
                    ccallparanode.create(cordconstnode.create
-                      (counter,s32bittype,true),
+                      (counter,s32bittype),
                    ccallparanode.create(caddrnode.create
                       (crttinode.create(tstoreddef(destppn.resulttype.def),initrtti)),
                    ccallparanode.create(ctypeconvnode.create_explicit(destppn,voidpointertype),nil))));
@@ -546,7 +536,7 @@ implementation
             end;
            { create call to fpc_finalize_array }
            npara:=ccallparanode.create(cordconstnode.create
-                     (destppn.left.resulttype.def.size,s32bittype,true),
+                     (destppn.left.resulttype.def.size,s32bittype),
                   ccallparanode.create(ctypeconvnode.create
                      (ppn.left,s32bittype),
                   ccallparanode.create(caddrnode.create
@@ -572,151 +562,10 @@ implementation
         result:=newblock;
       end;
 
-
-    function inline_copy : tnode;
-      var
-        copynode,
-        lowppn,
-        highppn,
-        npara,
-        paras   : tnode;
-        temp    : ttempcreatenode;
-        ppn     : tcallparanode;
-        paradef : tdef;
-        counter : integer;
-        newstatement : tstatementnode;
-      begin
-        { for easy exiting if something goes wrong }
-        result := cerrornode.create;
-
-        consume(_LKLAMMER);
-        paras:=parse_paras(false,false);
-        consume(_RKLAMMER);
-        if not assigned(paras) then
-         begin
-           CGMessage(parser_e_wrong_parameter_size);
-           exit;
-         end;
-
-        { determine copy function to use based on the first argument,
-          also count the number of arguments in this loop }
-        counter:=1;
-        ppn:=tcallparanode(paras);
-        while assigned(ppn.right) do
-         begin
-           inc(counter);
-           ppn:=tcallparanode(ppn.right);
-         end;
-        paradef:=ppn.left.resulttype.def;
-        if is_ansistring(paradef) then
-          copynode:=ccallnode.createintern('fpc_ansistr_copy',paras)
-        else
-         if is_widestring(paradef) then
-           copynode:=ccallnode.createintern('fpc_widestr_copy',paras)
-        else
-         if is_char(paradef) then
-           copynode:=ccallnode.createintern('fpc_char_copy',paras)
-        else
-         if is_dynamic_array(paradef) then
-          begin
-            { Only allow 1 or 3 arguments }
-            if (counter<>1) and (counter<>3) then
-             begin
-               CGMessage(parser_e_wrong_parameter_size);
-               exit;
-             end;
-
-            { create statements with call }
-            copynode:=internalstatements(newstatement,true);
-
-            if (counter=3) then
-             begin
-               highppn:=tcallparanode(paras).left.getcopy;
-               lowppn:=tcallparanode(tcallparanode(paras).right).left.getcopy;
-             end
-            else
-             begin
-               { use special -1,-1 argument to copy the whole array }
-               highppn:=cordconstnode.create(-1,s32bittype,false);
-               lowppn:=cordconstnode.create(-1,s32bittype,false);
-             end;
-
-            { create temp for result, we've to use a temp because a dynarray
-              type is handled differently from a pointer so we can't
-              use createinternres() and a function }
-            temp := ctempcreatenode.create(voidpointertype,voidpointertype.def.size,true);
-            addstatement(newstatement,temp);
-
-            { create call to fpc_dynarray_copy }
-            npara:=ccallparanode.create(highppn,
-                   ccallparanode.create(lowppn,
-                   ccallparanode.create(caddrnode.create
-                      (crttinode.create(tstoreddef(ppn.left.resulttype.def),initrtti)),
-                   ccallparanode.create
-                      (ctypeconvnode.create_explicit(ppn.left,voidpointertype),
-                   ccallparanode.create
-                      (ctemprefnode.create(temp),nil)))));
-            addstatement(newstatement,ccallnode.createintern('fpc_dynarray_copy',npara));
-
-            { convert the temp to normal and return the reference to the
-              created temp, and convert the type of the temp to the dynarray type }
-            addstatement(newstatement,ctempdeletenode.create_normal_temp(temp));
-            addstatement(newstatement,ctypeconvnode.create_explicit(ctemprefnode.create(temp),ppn.left.resulttype));
-
-            ppn.left:=nil;
-            paras.free;
-          end
-        else
-         begin
-           { generic fallback that will give an error if a wrong
-             type is passed }
-           copynode:=ccallnode.createintern('fpc_shortstr_copy',paras)
-         end;
-
-        result.free;
-        result:=copynode;
-      end;
-
 end.
 {
   $Log$
-  Revision 1.12  2002-04-25 20:15:40  florian
-    * block nodes within expressions shouldn't release the used registers,
-      fixed using a flag till the new rg is ready
-
-  Revision 1.11  2002/11/26 22:59:09  peter
-    * fix Copy(array,x,y)
-
-  Revision 1.10  2002/11/25 17:43:22  peter
-    * splitted defbase in defutil,symutil,defcmp
-    * merged isconvertable and is_equal into compare_defs(_ext)
-    * made operator search faster by walking the list only once
-
-  Revision 1.9  2002/10/29 10:01:22  pierre
-   * fix crash report as webbug 2174
-
-  Revision 1.8  2002/10/02 18:20:52  peter
-    * Copy() is now internal syssym that calls compilerprocs
-
-  Revision 1.7  2002/09/07 12:16:03  carl
-    * second part bug report 1996 fix, testrange in cordconstnode
-      only called if option is set (also make parsing a tiny faster)
-
-  Revision 1.6  2002/07/20 11:57:56  florian
-    * types.pas renamed to defbase.pas because D6 contains a types
-      unit so this would conflicts if D6 programms are compiled
-    + Willamette/SSE2 instructions to assembler added
-
-  Revision 1.5  2002/05/18 13:34:12  peter
-    * readded missing revisions
-
-  Revision 1.4  2002/05/16 19:46:43  carl
-  + defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
-  + try to fix temp allocation (still in ifdef)
-  + generic constructor calls
-  + start of tassembler / tmodulebase class cleanup
-
-  Revision 1.2  2002/05/12 16:53:09  peter
+  Revision 1.2  2002-05-12 16:53:09  peter
     * moved entry and exitcode to ncgutil and cgobj
     * foreach gets extra argument for passing local data to the
       iterator function

compiler/pmodules.pas

@@ -38,9 +38,9 @@ implementation
        globtype,version,systems,tokens,
        cutils,cclasses,comphook,
        globals,verbose,fmodule,finput,fppu,
-       symconst,symbase,symdef,symsym,symtable,aasm,
+       symconst,symbase,symtype,symdef,symsym,symtable,aasm,
        cgbase,
-       cga,
+       ncgutil,
        link,assemble,import,export,gendef,ppu,comprsrc,
        cresstr,cpubase,cpuasm,
 {$ifdef GDB}
@@ -682,29 +682,18 @@ implementation
       end;
 
 
-
-    var ltvTable : taasmoutput;
-
-    procedure addToLocalThreadvarTab(p:tnamedindexitem);
+    procedure addToLocalThreadvarTab(p:tnamedindexitem;arg:pointer);
       var
-        asym : tasmsymbol;
+        ltvTable : taasmoutput;
       begin
-        with tvarsym(p) do
+        ltvTable:=taasmoutput(arg);
+        if (tsym(p).typ=varsym) and
+           (vo_is_thread_var in tvarsym(p).varoptions) then
          begin
-           if (typ=varsym) and (vo_is_thread_var IN varoptions) then
-           begin
-             if ltvTable = nil then
-             begin   { first threadvar }
-               ltvTable := TAAsmOutput.Create;
-               ltvTable.insert(tai_symbol.createdataname_global(current_module.modulename^+'_$LOCALTHREADVARLIST',0));
-             end;
-                 asym := getasmsymbol(mangledname);
-             if asym <> nil then
-             begin
-               ltvTable.concat(tai_const_symbol.create(asym));    { address of threadvar }
-               ltvTable.concat(tai_const.create_32bit(getsize));  { size of threadvar }
-             end;
-           end;
+           { address of threadvar }
+           ltvTable.concat(tai_const_symbol.create(newasmsymbol(tvarsym(p).mangledname)));
+           { size of threadvar }
+           ltvTable.concat(tai_const.create_32bit(tvarsym(p).getsize));
          end;
       end;
 
@@ -735,7 +724,7 @@ implementation
          store_crc,store_interface_crc : cardinal;
          s2  : ^string; {Saves stack space}
          force_init_final : boolean;
-
+         ltvTable : taasmoutput;
       begin
          consume(_UNIT);
          if compile_level=1 then
@@ -980,18 +969,20 @@ implementation
            end;
 
          { generate a list of local threadvars }
-         ltvTable := nil;
-         st.foreach_static (@addToLocalThreadvarTab);
-         if ltvTable <> nil then
-         begin
-           ltvTable.concat(tai_const.create_32bit(0));  { end of list marker }
-           ltvTable.concat(tai_symbol_end.createname(current_module.modulename^+'_$LOCALTHREADVARLIST'));
-           if (cs_create_smart in aktmoduleswitches) then
-            dataSegment.concat(Tai_cut.Create);
-           dataSegment.concatlist(ltvTable);
-           ltvTable.Free;
-           current_module.flags:=current_module.flags or uf_local_threadvars;
-         end;
+         ltvTable:=TAAsmoutput.create;
+         st.foreach_static({$ifdef FPCPROCVAR}@{$endif}addToLocalThreadvarTab,ltvTable);
+         if ltvTable.first<>nil then
+          begin
+            { add begin and end of the list }
+            ltvTable.insert(tai_symbol.createdataname_global(current_module.modulename^+'_$LOCALTHREADVARLIST',0));
+            ltvTable.concat(tai_const.create_32bit(0));  { end of list marker }
+            ltvTable.concat(tai_symbol_end.createname(current_module.modulename^+'_$LOCALTHREADVARLIST'));
+            if (cs_create_smart in aktmoduleswitches) then
+             dataSegment.concat(Tai_cut.Create);
+            dataSegment.concatlist(ltvTable);
+            current_module.flags:=current_module.flags or uf_local_threadvars;
+          end;
+         ltvTable.Free;
 
          { the last char should always be a point }
          consume(_POINT);
@@ -1236,7 +1227,7 @@ implementation
 
          {Insert the name of the main program into the symbol table.}
          if current_module.realmodulename^<>'' then
-           st.insert(tunitsym.create(current_module.realmodulename^,tglobalsymtable(st)));
+           st.insert(tunitsym.create(current_module.realmodulename^,st));
 
          { ...is also constsymtable, this is the symtable where }
          { the elements of enumeration types are inserted       }
@@ -1392,7 +1383,24 @@ implementation
 end.
 {
   $Log$
-  Revision 1.63  2002-05-06 19:54:50  carl
+  Revision 1.64  2002-05-12 16:53:09  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.63  2002/05/06 19:54:50  carl
   + added more patches from Mazen for SPARC port
 
   Revision 1.62  2002/04/20 21:32:24  carl

compiler/psub.pas

@@ -54,17 +54,17 @@ implementation
        { pass 1 }
        node,
        nbas,
+       pass_1,
        { pass 2 }
 {$ifndef NOPASS2}
-       pass_1,pass_2,
+       pass_2,
 {$endif}
        { parser }
        scanner,
        pbase,pstatmnt,pdecl,pdecsub,pexports,
        { codegen }
-       tgobj,cgbase,rgobj,
-       rgcpu,
-       cga
+       tgobj,cgbase,rgobj,rgcpu,
+       ncgutil
        {$ifndef NOOPT}
          {$ifdef i386}
            ,aopt386
@@ -328,11 +328,7 @@ implementation
                 { first generate entry code with the correct position and switches }
                 aktfilepos:=entrypos;
                 aktlocalswitches:=entryswitches;
-{$ifdef newcg}
-                cg^.g_entrycode(procinfo^.aktentrycode,proc_names,make_global,stackframe,parasize,nostackframe,false);
-{$else newcg}
                 genentrycode(procinfo^.aktentrycode,make_global,stackframe,parasize,nostackframe,false);
-{$endif newcg}
 
                 { FPC_POPADDRSTACK destroys all registers (JM) }
                 if (procinfo^.flags and (pi_needs_implicit_finally or pi_uses_exceptions)) <> 0 then
@@ -343,11 +339,7 @@ implementation
                 { now generate exit code with the correct position and switches }
                 aktfilepos:=exitpos;
                 aktlocalswitches:=exitswitches;
-{$ifdef newcg}
-                cg^.g_exitcode(procinfo^.aktexitcode,parasize,nostackframe,false);
-{$else newcg}
                 genexitcode(procinfo^.aktexitcode,parasize,nostackframe,false);
-{$endif newcg}
 
                 { now all the registers used are known }
                 aktprocdef.usedregisters:=rg.usedinproc;
@@ -462,11 +454,13 @@ implementation
                         PROCEDURE/FUNCTION PARSING
 ****************************************************************************}
 
-    procedure checkvaluepara(p:tnamedindexitem);
+    procedure checkvaluepara(p:tnamedindexitem;arg:pointer);
       var
         vs : tvarsym;
         s  : string;
       begin
+        if tsym(p).typ<>varsym then
+         exit;
         with tvarsym(p) do
          begin
            if copy(name,1,3)='val' then
@@ -648,7 +642,7 @@ implementation
            the parameter and insert a copy in the localst. This is not done
            for assembler procedures }
          if (not parse_only) and (not aktprocdef.forwarddef) then
-           aktprocdef.parast.foreach_static({$ifdef FPCPROCVAR}@{$endif}checkvaluepara);
+           aktprocdef.parast.foreach_static({$ifdef FPCPROCVAR}@{$endif}checkvaluepara,nil);
 
          { restore file pos }
          aktfilepos:=oldfilepos;
@@ -700,7 +694,7 @@ implementation
 ****************************************************************************}
 
     { search in symtablestack for not complete classes }
-    procedure check_forward_class(p : tnamedindexitem);
+    procedure check_forward_class(p : tnamedindexitem;arg:pointer);
       begin
         if (tsym(p).typ=typesym) and
            (ttypesym(p).restype.def.deftype=objectdef) and
@@ -772,7 +766,7 @@ implementation
          { check for incomplete class definitions, this is only required
            for fpc modes }
          if (m_fpc in aktmodeswitches) then
-          symtablestack.foreach_static({$ifdef FPCPROCVAR}@{$endif}check_forward_class);
+          symtablestack.foreach_static({$ifdef FPCPROCVAR}@{$endif}check_forward_class,nil);
       end;
 
 
@@ -805,13 +799,30 @@ implementation
          { check for incomplete class definitions, this is only required
            for fpc modes }
          if (m_fpc in aktmodeswitches) then
-          symtablestack.foreach_static({$ifdef FPCPROCVAR}@{$endif}check_forward_class);
+          symtablestack.foreach_static({$ifdef FPCPROCVAR}@{$endif}check_forward_class,nil);
       end;
 
 end.
 {
   $Log$
-  Revision 1.49  2002-04-20 21:32:24  carl
+  Revision 1.50  2002-05-12 16:53:09  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.49  2002/04/20 21:32:24  carl
   + generic FPC_CHECKPOINTER
   + first parameter offset in stack now portable
   * rename some constants

compiler/psystem.pas

@@ -40,8 +40,7 @@ implementation
 uses
   globals,
   symconst,symtype,symsym,symdef,symtable,
-  ninl,
-  cpuinfo;
+  ninl;
 
 procedure insertinternsyms(p : tsymtable);
 {
@@ -277,7 +276,24 @@ end;
 end.
 {
   $Log$
-  Revision 1.22  2002-01-24 12:33:53  jonas
+  Revision 1.23  2002-05-12 16:53:09  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.22  2002/01/24 12:33:53  jonas
     * adapted ranges of native types to int64 (e.g. high cardinal is no
       longer longint($ffffffff), but just $fffffff in psystem)
     * small additional fix in 64bit rangecheck code generation for 32 bit

compiler/ptconst.pas

@@ -43,7 +43,7 @@ implementation
 {$endif Delphi}
        globtype,systems,tokens,
        cutils,globals,widestr,scanner,
-       symconst,symbase,symdef,aasm,cpuasm,types,verbose,cpubase,
+       symconst,symbase,symdef,aasm,cpuasm,types,verbose,
        { pass 1 }
        node,
        nmat,nadd,ncal,nmem,nset,ncnv,ninl,ncon,nld,nflw,
@@ -347,7 +347,7 @@ implementation
                      hpstart:=taddrnode(p).left;
                     hp:=hpstart;
                     while assigned(hp) and (hp.nodetype in [subscriptn,vecn]) do
-                      hp:=tbinarynode(hp).left;
+                      hp:=tunarynode(hp).left;
                     if (hp.nodetype=loadn) then
                       begin
                         hp:=hpstart;
@@ -971,7 +971,24 @@ implementation
 end.
 {
   $Log$
-  Revision 1.45  2002-04-23 19:16:35  peter
+  Revision 1.46  2002-05-12 16:53:09  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.45  2002/04/23 19:16:35  peter
     * add pinline unit that inserts compiler supported functions using
       one or more statements
     * moved finalize and setlength from ninl to pinline

compiler/ptype.pas

@@ -55,7 +55,7 @@ implementation
 
     uses
        { common }
-       cutils,cpuinfo,
+       cutils,
        { global }
        globals,tokens,verbose,
        systems,
@@ -631,7 +631,24 @@ implementation
 end.
 {
   $Log$
-  Revision 1.37  2002-04-19 15:46:03  peter
+  Revision 1.38  2002-05-12 16:53:10  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.37  2002/04/19 15:46:03  peter
     * mangledname rewrite, tprocdef.mangledname is now created dynamicly
       in most cases and not written to the ppu
     * add mangeledname_prefix() routine to generate the prefix of

compiler/rautils.pas

@@ -1134,7 +1134,7 @@ end;
                              TLocalLabelList
 ***************************************************************************}
 
-procedure LocalLabelEmitted(p:tnamedindexitem);
+procedure LocalLabelEmitted(p:tnamedindexitem;arg:pointer);
 begin
   if not TLocalLabel(p).emitted  then
    Message1(asmr_e_unknown_label_identifier,p.name);
@@ -1142,7 +1142,7 @@ end;
 
 procedure TLocalLabelList.CheckEmitted;
 begin
-  ForEach_Static({$ifdef FPCPROCVAR}@{$endif}LocalLabelEmitted)
+  ForEach_Static({$ifdef FPCPROCVAR}@{$endif}LocalLabelEmitted,nil)
 end;
 
 
@@ -1585,7 +1585,24 @@ end;
 end.
 {
   $Log$
-  Revision 1.30  2002-04-20 21:32:24  carl
+  Revision 1.31  2002-05-12 16:53:10  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.30  2002/04/20 21:32:24  carl
   + generic FPC_CHECKPOINTER
   + first parameter offset in stack now portable
   * rename some constants

compiler/regvars.pas

@@ -49,16 +49,15 @@ implementation
       globtype,systems,comphook,
       cutils,cclasses,verbose,globals,
       symconst,symbase,symtype,symdef,types,
-      tainst,cgbase,cpuasm,cgobj, cgcpu,cga,rgcpu;
+      tainst,cgbase,cpuasm,cgobj,cgcpu,rgcpu;
 
-    var
-      parasym : boolean;
 
-
-    procedure searchregvars(p : tnamedindexitem);
+    procedure searchregvars(p : tnamedindexitem;arg:pointer);
       var
          i,j,k : longint;
+         parasym : boolean;
       begin
+         parasym:=pboolean(arg)^;
          if (tsym(p).typ=varsym) and (vo_regable in tvarsym(p).varoptions) then
            begin
               j:=tvarsym(p).refs;
@@ -94,10 +93,12 @@ implementation
       end;
 
 
-    procedure searchfpuregvars(p : tnamedindexitem);
+    procedure searchfpuregvars(p : tnamedindexitem;arg:pointer);
       var
          i,j,k : longint;
+         parasym : boolean;
       begin
+         parasym:=pboolean(arg)^;
          if (tsym(p).typ=varsym) and (vo_fpuregable in tvarsym(p).varoptions) then
            begin
               j:=tvarsym(p).refs;
@@ -137,6 +138,7 @@ implementation
     var
       regvarinfo: pregvarinfo;
       i: longint;
+      parasym : boolean;
     begin
       { max. optimizations     }
       { only if no asm is used }
@@ -150,10 +152,10 @@ implementation
           if (p.registers32<4) then
             begin
               parasym:=false;
-              symtablestack.foreach_static({$ifdef FPCPROCVAR}@{$endif}searchregvars);
+              symtablestack.foreach_static({$ifdef FPCPROCVAR}@{$endif}searchregvars,@parasym);
               { copy parameter into a register ? }
               parasym:=true;
-              symtablestack.next.foreach_static({$ifdef FPCPROCVAR}@{$endif}searchregvars);
+              symtablestack.next.foreach_static({$ifdef FPCPROCVAR}@{$endif}searchregvars,@parasym);
               { hold needed registers free }
               for i:=maxvarregs downto maxvarregs-p.registers32+1 do
                 begin
@@ -209,7 +211,7 @@ implementation
             if ((p.registersfpu+1)<maxfpuvarregs) then
               begin
                 parasym:=false;
-                symtablestack.foreach_static({$ifdef FPCPROCVAR}@{$endif}searchfpuregvars);
+                symtablestack.foreach_static({$ifdef FPCPROCVAR}@{$endif}searchfpuregvars,@parasym);
 {$ifdef dummy}
                 { copy parameter into a register ? }
                 parasym:=true;
@@ -462,7 +464,24 @@ end.
 
 {
   $Log$
-  Revision 1.29  2002-04-21 15:23:34  carl
+  Revision 1.30  2002-05-12 16:53:10  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.29  2002/04/21 15:23:34  carl
   + changeregsize -> makeregsize
 
   Revision 1.28  2002/04/19 15:46:03  peter

compiler/symbase.pas

@@ -113,8 +113,8 @@ interface
           destructor  destroy;override;
           procedure clear;virtual;
           function  rename(const olds,news : stringid):tsymentry;
-          procedure foreach(proc2call : tnamedindexcallback);
-          procedure foreach_static(proc2call : tnamedindexstaticcallback);
+          procedure foreach(proc2call : tnamedindexcallback;arg:pointer);
+          procedure foreach_static(proc2call : tnamedindexstaticcallback;arg:pointer);
           procedure insert(sym : tsymentry);virtual;
           function  search(const s : stringid) : tsymentry;
           function  speedsearch(const s : stringid;speedvalue : cardinal) : tsymentry;virtual;
@@ -208,15 +208,15 @@ implementation
       end;
 
 
-    procedure tsymtable.foreach(proc2call : tnamedindexcallback);
+    procedure tsymtable.foreach(proc2call : tnamedindexcallback;arg:pointer);
       begin
-        symindex.foreach(proc2call);
+        symindex.foreach(proc2call,arg);
       end;
 
 
-    procedure tsymtable.foreach_static(proc2call : tnamedindexstaticcallback);
+    procedure tsymtable.foreach_static(proc2call : tnamedindexstaticcallback;arg:pointer);
       begin
-        symindex.foreach_static(proc2call);
+        symindex.foreach_static(proc2call,arg);
       end;
 
 
@@ -311,7 +311,24 @@ implementation
 end.
 {
   $Log$
-  Revision 1.2  2001-04-13 01:22:15  peter
+  Revision 1.3  2002-05-12 16:53:10  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.2  2001/04/13 01:22:15  peter
     * symtable change to classes
     * range check generation and errors fixed, make cycle DEBUG=1 works
     * memory leaks fixed

compiler/symconst.pas

@@ -269,6 +269,10 @@ type
     vs_set_but_first_not_passed,vs_assigned,vs_used
   );
 
+  tvarspez = (vs_value,vs_const,vs_var,vs_out);
+
+  targconvtyp = (act_convertable,act_equal,act_exact);
+
   absolutetyp = (tovar,toasm,toaddr);
 
   tconsttyp = (constnone,
@@ -326,7 +330,24 @@ implementation
 end.
 {
   $Log$
-  Revision 1.28  2002-01-06 12:08:15  peter
+  Revision 1.29  2002-05-12 16:53:10  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.28  2002/01/06 12:08:15  peter
     * removed uauto from orddef, use new range_to_basetype generating
       the correct ordinal type for a range
 

compiler/symdef.pas

@@ -93,10 +93,6 @@ interface
           savesize  : longint;
        end;
 
-       targconvtyp = (act_convertable,act_equal,act_exact);
-
-       tvarspez = (vs_value,vs_const,vs_var,vs_out);
-
        tparaitem = class(tlinkedlistitem)
           paratype     : ttype;
           parasym      : tsym;
@@ -199,11 +195,11 @@ interface
           StabRecString : pchar;
           StabRecSize   : Integer;
           RecOffset     : Integer;
-          procedure addname(p : tnamedindexitem);
+          procedure addname(p : tnamedindexitem;arg:pointer);
 {$endif}
-          procedure count_field_rtti(sym : tnamedindexitem);
-          procedure write_field_rtti(sym : tnamedindexitem);
-          procedure generate_field_rtti(sym : tnamedindexitem);
+          procedure count_field_rtti(sym : tnamedindexitem;arg:pointer);
+          procedure write_field_rtti(sym : tnamedindexitem;arg:pointer);
+          procedure generate_field_rtti(sym : tnamedindexitem;arg:pointer);
        public
           symtable : tsymtable;
           function  getsymtable(t:tgetsymtable):tsymtable;override;
@@ -237,15 +233,15 @@ interface
        tobjectdef = class(tabstractrecorddef)
        private
           sd : tprocdef;
-          procedure _searchdestructor(sym : tnamedindexitem);
+          procedure _searchdestructor(sym : tnamedindexitem;arg:pointer);
 {$ifdef GDB}
-          procedure addprocname(p :tnamedindexitem);
+          procedure addprocname(p :tnamedindexitem;arg:pointer);
 {$endif GDB}
-          procedure count_published_properties(sym:tnamedindexitem);
-          procedure write_property_info(sym : tnamedindexitem);
-          procedure generate_published_child_rtti(sym : tnamedindexitem);
-          procedure count_published_fields(sym:tnamedindexitem);
-          procedure writefields(sym:tnamedindexitem);
+          procedure count_published_properties(sym:tnamedindexitem;arg:pointer);
+          procedure write_property_info(sym : tnamedindexitem;arg:pointer);
+          procedure generate_published_child_rtti(sym : tnamedindexitem;arg:pointer);
+          procedure count_published_fields(sym:tnamedindexitem;arg:pointer);
+          procedure writefields(sym:tnamedindexitem;arg:pointer);
        public
           childof  : tobjectdef;
           objname,
@@ -307,7 +303,8 @@ interface
           procedure addintf(def: tdef);
 
           procedure deref;
-          procedure addintfref(def: tdef);
+          { add interface reference loaded from ppu }
+          procedure addintfref(def: pointer);
 
           procedure clearmappings;
           procedure addmappings(intfindex: longint; const name, newname: string);
@@ -848,7 +845,7 @@ implementation
          fillchar(localrttilab,sizeof(localrttilab),0);
       { load }
          indexnr:=ppufile.getword;
-         typesym:=ttypesym(ppufile.getderef);
+         typesym:=ttypesym(pointer(ppufile.getderef));
          ppufile.getsmallset(defoptions);
          if df_has_rttitable in defoptions then
           rttitablesym:=tsym(ppufile.getderef);
@@ -911,9 +908,9 @@ implementation
 
     procedure tstoreddef.deref;
       begin
-        resolvesym(typesym);
-        resolvesym(rttitablesym);
-        resolvesym(inittablesym);
+        resolvesym(pointer(typesym));
+        resolvesym(pointer(rttitablesym));
+        resolvesym(pointer(inittablesym));
       end;
 
 
@@ -1323,8 +1320,8 @@ implementation
              end;
            st_widestring:
              begin
-               { an ansi string looks like a pchar easy !! }
-               stabstring:=strpnew('*'+typeglobalnumber('char'));
+               { an ansi string looks like a pwidechar easy !! }
+               stabstring:=strpnew('*'+typeglobalnumber('widechar'));
              end;
       end;
     end;
@@ -1481,7 +1478,7 @@ implementation
     procedure tenumdef.deref;
       begin
         inherited deref;
-        resolvedef(tdef(basedef));
+        resolvedef(pointer(basedef));
       end;
 
 
@@ -2810,7 +2807,7 @@ implementation
 
 
 {$ifdef GDB}
-    procedure tabstractrecorddef.addname(p : tnamedindexitem);
+    procedure tabstractrecorddef.addname(p : tnamedindexitem;arg:pointer);
       var
         news, newrec : pchar;
         spec : string[3];
@@ -2857,7 +2854,7 @@ implementation
 {$endif GDB}
 
 
-    procedure tabstractrecorddef.count_field_rtti(sym : tnamedindexitem);
+    procedure tabstractrecorddef.count_field_rtti(sym : tnamedindexitem;arg:pointer);
       begin
          if (FRTTIType=fullrtti) or
             ((tsym(sym).typ=varsym) and
@@ -2866,7 +2863,7 @@ implementation
       end;
 
 
-    procedure tabstractrecorddef.generate_field_rtti(sym:tnamedindexitem);
+    procedure tabstractrecorddef.generate_field_rtti(sym:tnamedindexitem;arg:pointer);
       begin
          if (FRTTIType=fullrtti) or
             ((tsym(sym).typ=varsym) and
@@ -2875,7 +2872,7 @@ implementation
       end;
 
 
-    procedure tabstractrecorddef.write_field_rtti(sym : tnamedindexitem);
+    procedure tabstractrecorddef.write_field_rtti(sym : tnamedindexitem;arg:pointer);
       begin
          if (FRTTIType=fullrtti) or
             ((tsym(sym).typ=varsym) and
@@ -3017,7 +3014,7 @@ implementation
         stabrecsize:=memsizeinc;
         strpcopy(stabRecString,'s'+tostr(size));
         RecOffset := 0;
-        symtable.foreach({$ifdef FPCPROCVAR}@{$endif}addname);
+        symtable.foreach({$ifdef FPCPROCVAR}@{$endif}addname,nil);
         strpcopy(strend(StabRecString),';');
         stabstring := strnew(StabRecString);
         Freemem(stabrecstring,stabrecsize);
@@ -3036,7 +3033,7 @@ implementation
     procedure trecorddef.write_child_rtti_data(rt:trttitype);
       begin
          FRTTIType:=rt;
-         symtable.foreach({$ifdef FPCPROCVAR}@{$endif}generate_field_rtti);
+         symtable.foreach({$ifdef FPCPROCVAR}@{$endif}generate_field_rtti,nil);
       end;
 
 
@@ -3047,9 +3044,9 @@ implementation
          rttiList.concat(Tai_const.Create_32bit(size));
          Count:=0;
          FRTTIType:=rt;
-         symtable.foreach({$ifdef FPCPROCVAR}@{$endif}count_field_rtti);
+         symtable.foreach({$ifdef FPCPROCVAR}@{$endif}count_field_rtti,nil);
          rttiList.concat(Tai_const.Create_32bit(Count));
-         symtable.foreach({$ifdef FPCPROCVAR}@{$endif}write_field_rtti);
+         symtable.foreach({$ifdef FPCPROCVAR}@{$endif}write_field_rtti,nil);
       end;
 
 
@@ -3128,8 +3125,8 @@ implementation
          while assigned(hp) do
           begin
             hp.paratype.resolve;
-            resolvesym(tsym(hp.defaultvalue));
-            resolvesym(tsym(hp.parasym));
+            resolvesym(pointer(hp.defaultvalue));
+            resolvesym(pointer(hp.parasym));
             hp:=TParaItem(hp.next);
           end;
       end;
@@ -3747,7 +3744,7 @@ implementation
         oldlocalsymtable : tsymtable;
       begin
          inherited deref;
-         resolvedef(tdef(_class));
+         resolvedef(pointer(_class));
          { parast }
          oldlocalsymtable:=aktlocalsymtable;
          aktlocalsymtable:=parast;
@@ -3755,7 +3752,7 @@ implementation
          aktlocalsymtable:=oldlocalsymtable;
          { procsym that originaly defined this definition, should be in the
            same symtable }
-         resolvesym(procsym);
+         resolvesym(pointer(procsym));
       end;
 
 
@@ -3774,7 +3771,7 @@ implementation
             tlocalsymtable(localst).derefimpl;
             aktlocalsymtable:=oldlocalsymtable;
             { funcretsym, this is always located in the localst }
-            resolvesym(funcretsym);
+            resolvesym(pointer(funcretsym));
           end
          else
           begin
@@ -4143,7 +4140,7 @@ implementation
              implintfcount:=ppufile.getlongint;
              for i:=1 to implintfcount do
                begin
-                  implementedinterfaces.addintfref(tdef(ppufile.getderef));
+                  implementedinterfaces.addintfref(ppufile.getderef);
                   implementedinterfaces.ioffsets(i)^:=ppufile.getlongint;
                end;
            end
@@ -4234,7 +4231,7 @@ implementation
          oldrecsyms : tsymtable;
       begin
          inherited deref;
-         resolvedef(tdef(childof));
+         resolvedef(pointer(childof));
          oldrecsyms:=aktrecordsymtable;
          aktrecordsymtable:=symtable;
          tstoredsymtable(symtable).deref;
@@ -4327,7 +4324,7 @@ implementation
      end;
 
 
-   procedure tobjectdef._searchdestructor(sym : tnamedindexitem);
+   procedure tobjectdef._searchdestructor(sym : tnamedindexitem;arg:pointer);
 
      var
         p : pprocdeflist;
@@ -4362,7 +4359,7 @@ implementation
         sd:=nil;
         while assigned(o) do
           begin
-             symtable.foreach({$ifdef FPCPROCVAR}@{$endif}_searchdestructor);
+             symtable.foreach({$ifdef FPCPROCVAR}@{$endif}_searchdestructor,nil);
              if assigned(sd) then
                begin
                   searchdestructor:=sd;
@@ -4420,7 +4417,7 @@ implementation
 
 
 {$ifdef GDB}
-    procedure tobjectdef.addprocname(p :tnamedindexitem);
+    procedure tobjectdef.addprocname(p :tnamedindexitem;arg:pointer);
       var virtualind,argnames : string;
           news, newrec : pchar;
           pd,ipd : tprocdef;
@@ -4538,7 +4535,7 @@ implementation
             {virtual table to implement yet}
             OldRecOffset:=RecOffset;
             RecOffset := 0;
-            symtable.foreach({$ifdef FPCPROCVAR}@{$endif}addname);
+            symtable.foreach({$ifdef FPCPROCVAR}@{$endif}addname,nil);
             RecOffset:=OldRecOffset;
             if (oo_has_vmt in objectoptions) then
               if not assigned(childof) or not(oo_has_vmt in childof.objectoptions) then
@@ -4546,7 +4543,7 @@ implementation
                     strpcopy(strend(stabrecstring),'$vf'+classnumberstring+':'+typeglobalnumber('vtblarray')
                       +','+tostr(vmt_offset*8)+';');
                  end;
-            symtable.foreach({$ifdef FPCPROCVAR}@{$endif}addprocname);
+            symtable.foreach({$ifdef FPCPROCVAR}@{$endif}addprocname,nil);
             if (oo_has_vmt in objectoptions) then
               begin
                  anc := self;
@@ -4680,7 +4677,7 @@ implementation
       end;
 
 
-    procedure tobjectdef.count_published_properties(sym:tnamedindexitem);
+    procedure tobjectdef.count_published_properties(sym:tnamedindexitem;arg:pointer);
       begin
          if needs_prop_entry(tsym(sym)) and
           (tsym(sym).typ<>varsym) then
@@ -4688,7 +4685,7 @@ implementation
       end;
 
 
-    procedure tobjectdef.write_property_info(sym : tnamedindexitem);
+    procedure tobjectdef.write_property_info(sym : tnamedindexitem;arg:pointer);
       var
          proctypesinfo : byte;
 
@@ -4792,7 +4789,7 @@ implementation
       end;
 
 
-    procedure tobjectdef.generate_published_child_rtti(sym : tnamedindexitem);
+    procedure tobjectdef.generate_published_child_rtti(sym : tnamedindexitem;arg:pointer);
       begin
          if needs_prop_entry(tsym(sym)) then
           begin
@@ -4813,9 +4810,9 @@ implementation
          FRTTIType:=rt;
          case rt of
            initrtti :
-             symtable.foreach({$ifdef FPCPROCVAR}@{$endif}generate_field_rtti);
+             symtable.foreach({$ifdef FPCPROCVAR}@{$endif}generate_field_rtti,nil);
            fullrtti :
-             symtable.foreach({$ifdef FPCPROCVAR}@{$endif}generate_published_child_rtti);
+             symtable.foreach({$ifdef FPCPROCVAR}@{$endif}generate_published_child_rtti,nil);
            else
              internalerror(200108301);
          end;
@@ -4851,7 +4848,7 @@ implementation
       end;
 
 
-    procedure tobjectdef.count_published_fields(sym:tnamedindexitem);
+    procedure tobjectdef.count_published_fields(sym:tnamedindexitem;arg:pointer);
       var
          hp : tclasslistitem;
       begin
@@ -4874,7 +4871,7 @@ implementation
       end;
 
 
-    procedure tobjectdef.writefields(sym:tnamedindexitem);
+    procedure tobjectdef.writefields(sym:tnamedindexitem;arg:pointer);
       var
          hp : tclasslistitem;
       begin
@@ -4904,13 +4901,13 @@ implementation
          getdatalabel(classtable);
          count:=0;
          tablecount:=0;
-         symtable.foreach({$ifdef FPC}@{$endif}count_published_fields);
+         symtable.foreach({$ifdef FPC}@{$endif}count_published_fields,nil);
          if (cs_create_smart in aktmoduleswitches) then
           rttiList.concat(Tai_cut.Create);
          rttiList.concat(Tai_label.Create(fieldtable));
          rttiList.concat(Tai_const.Create_16bit(count));
          rttiList.concat(Tai_const_symbol.Create(classtable));
-         symtable.foreach({$ifdef FPC}@{$endif}writefields);
+         symtable.foreach({$ifdef FPC}@{$endif}writefields,nil);
 
          { generate the class table }
          rttiList.concat(Tai_label.Create(classtable));
@@ -4936,7 +4933,7 @@ implementation
          else
            i:=0;
          count:=0;
-         symtable.foreach({$ifdef FPCPROCVAR}@{$endif}count_published_properties);
+         symtable.foreach({$ifdef FPCPROCVAR}@{$endif}count_published_properties,nil);
          next_free_name_index:=i+count;
       end;
 
@@ -4968,9 +4965,9 @@ implementation
                 begin
                   count:=0;
                   FRTTIType:=rt;
-                  symtable.foreach({$ifdef FPCPROCVAR}@{$endif}count_field_rtti);
+                  symtable.foreach({$ifdef FPCPROCVAR}@{$endif}count_field_rtti,nil);
                   rttiList.concat(Tai_const.Create_32bit(count));
-                  symtable.foreach({$ifdef FPCPROCVAR}@{$endif}write_field_rtti);
+                  symtable.foreach({$ifdef FPCPROCVAR}@{$endif}write_field_rtti,nil);
                 end;
              end;
            fullrtti :
@@ -4993,7 +4990,7 @@ implementation
                  count:=0;
 
                { write it }
-               symtable.foreach({$ifdef FPCPROCVAR}@{$endif}count_published_properties);
+               symtable.foreach({$ifdef FPCPROCVAR}@{$endif}count_published_properties,nil);
                rttiList.concat(Tai_const.Create_16bit(count));
 
                { write unit name }
@@ -5002,7 +4999,7 @@ implementation
 
                { write published properties count }
                count:=0;
-               symtable.foreach({$ifdef FPCPROCVAR}@{$endif}count_published_properties);
+               symtable.foreach({$ifdef FPCPROCVAR}@{$endif}count_published_properties,nil);
                rttiList.concat(Tai_const.Create_16bit(count));
 
                { count is used to write nameindex   }
@@ -5014,7 +5011,7 @@ implementation
                else
                  count:=0;
 
-               symtable.foreach({$ifdef FPCPROCVAR}@{$endif}write_property_info);
+               symtable.foreach({$ifdef FPCPROCVAR}@{$endif}write_property_info,nil);
              end;
          end;
       end;
@@ -5142,10 +5139,10 @@ implementation
       begin
         for i:=1 to count do
           with timplintfentry(finterfaces.search(i)) do
-            resolvedef(tdef(intf));
+            resolvedef(pointer(intf));
       end;
 
-    procedure timplementedinterfaces.addintfref(def: tdef);
+    procedure timplementedinterfaces.addintfref(def: pointer);
       begin
         finterfaces.insert(timplintfentry.create(tobjectdef(def)));
       end;
@@ -5479,7 +5476,24 @@ implementation
 end.
 {
   $Log$
-  Revision 1.75  2002-04-25 20:16:39  peter
+  Revision 1.76  2002-05-12 16:53:10  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.75  2002/04/25 20:16:39  peter
     * moved more routines from cga/n386util
 
   Revision 1.74  2002/04/23 19:16:35  peter

compiler/symppu.pas

@@ -35,7 +35,7 @@ interface
          procedure checkerror;
          procedure getguid(var g: tguid);
          procedure getposinfo(var p:tfileposinfo);
-         function  getderef : tsymtableentry;
+         function  getderef : pointer;
          function  getsymlist:tsymlist;
          procedure gettype(var t:ttype);
          procedure putguid(const g: tguid);
@@ -101,7 +101,7 @@ implementation
       end;
 
 
-    function tcompilerppufile.getderef : tsymtableentry;
+    function tcompilerppufile.getderef : pointer;
       var
         hp,p : tderef;
         b : tdereftype;
@@ -132,7 +132,7 @@ implementation
               end;
           end;
         until false;
-        getderef:=tsymtableentry(p);
+        getderef:=p;
       end;
 
 
@@ -388,7 +388,24 @@ implementation
 end.
 {
   $Log$
-  Revision 1.8  2002-04-19 15:40:40  peter
+  Revision 1.9  2002-05-12 16:53:15  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.8  2002/04/19 15:40:40  peter
     * optimize tfileposinfo writing, this reduces the ppu size with 20%
 
   Revision 1.7  2001/10/21 12:33:07  peter

compiler/symsym.pas

@@ -325,9 +325,9 @@ interface
                                      currently be parsed procedure }
        aktprocdef : tprocdef;
 
-       aktcallprocdef : tprocdef;  { pointer to the definition of the
-                                     currently called procedure,
-                                     only set/unset in ncal }
+       aktcallprocdef : tabstractprocdef;  { pointer to the definition of the
+                                             currently called procedure,
+                                             only set/unset in ncal }
 
        aktvarsym : tvarsym;     { pointer to the symbol for the
                                      currently read var, only used
@@ -686,9 +686,12 @@ implementation
          make_ref:=old_make_ref;
          typ:=unitsym;
          unitsymtable:=ref;
-         prevsym:=tglobalsymtable(ref).unitsym;
-         tglobalsymtable(ref).unitsym:=self;
-         refs:=0;
+         if assigned(ref) and
+            (ref.symtabletype=globalsymtable) then
+          begin
+            prevsym:=tglobalsymtable(ref).unitsym;
+            tglobalsymtable(ref).unitsym:=self;
+          end;
       end;
 
     constructor tunitsym.load(ppufile:tcompilerppufile);
@@ -706,7 +709,8 @@ implementation
     procedure tunitsym.restoreunitsym;
       var pus,ppus : tunitsym;
       begin
-         if assigned(unitsymtable) then
+         if assigned(unitsymtable) and
+            (unitsymtable.symtabletype=globalsymtable) then
            begin
              ppus:=nil;
              pus:=tglobalsymtable(unitsymtable).unitsym;
@@ -840,7 +844,7 @@ implementation
          p:=defs;
          while assigned(p) do
            begin
-             resolvedef(tdef(p^.def));
+             resolvedef(pointer(p^.def));
              p:=p^.next;
            end;
       end;
@@ -1018,7 +1022,7 @@ implementation
       begin
         if (ppo_is_override in propoptions) then
          begin
-           resolvesym(tsym(propoverriden));
+           resolvesym(pointer(propoverriden));
            dooverride(propoverriden);
          end
         else
@@ -2181,7 +2185,7 @@ implementation
 
     procedure tenumsym.deref;
       begin
-         resolvedef(tdef(definition));
+         resolvedef(pointer(definition));
          order;
       end;
 
@@ -2513,7 +2517,24 @@ implementation
 end.
 {
   $Log$
-  Revision 1.35  2002-04-19 15:46:03  peter
+  Revision 1.36  2002-05-12 16:53:15  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.35  2002/04/19 15:46:03  peter
     * mangledname rewrite, tprocdef.mangledname is now created dynamicly
       in most cases and not written to the ppu
     * add mangeledname_prefix() routine to generate the prefix of

compiler/symtable.pas

@@ -47,21 +47,20 @@ interface
        tstoredsymtable = class(tsymtable)
        private
           b_needs_init_final : boolean;
-          procedure _needs_init_final(p : tnamedindexitem);
-          procedure check_forward(sym : TNamedIndexItem);
-          procedure labeldefined(p : TNamedIndexItem);
-          procedure unitsymbolused(p : TNamedIndexItem);
-          procedure varsymbolused(p : TNamedIndexItem);
-          procedure TestPrivate(p : TNamedIndexItem);
-          procedure objectprivatesymbolused(p : TNamedIndexItem);
+          procedure _needs_init_final(p : tnamedindexitem;arg:pointer);
+          procedure check_forward(sym : TNamedIndexItem;arg:pointer);
+          procedure labeldefined(p : TNamedIndexItem;arg:pointer);
+          procedure unitsymbolused(p : TNamedIndexItem;arg:pointer);
+          procedure varsymbolused(p : TNamedIndexItem;arg:pointer);
+          procedure TestPrivate(p : TNamedIndexItem;arg:pointer);
+          procedure objectprivatesymbolused(p : TNamedIndexItem;arg:pointer);
 {$ifdef GDB}
        private
-          asmoutput : taasmoutput;
-          procedure concatstab(p : TNamedIndexItem);
-          procedure resetstab(p : TNamedIndexItem);
-          procedure concattypestab(p : TNamedIndexItem);
+          procedure concatstab(p : TNamedIndexItem;arg:pointer);
+          procedure resetstab(p : TNamedIndexItem;arg:pointer);
+          procedure concattypestab(p : TNamedIndexItem;arg:pointer);
 {$endif}
-          procedure unchain_overloads(p : TNamedIndexItem);
+          procedure unchain_overloads(p : TNamedIndexItem;arg:pointer);
           procedure loaddefs(ppufile:tcompilerppufile);
           procedure loadsyms(ppufile:tcompilerppufile);
           procedure writedefs(ppufile:tcompilerppufile);
@@ -88,7 +87,7 @@ interface
           procedure concatstabto(asmlist : taasmoutput);virtual;
           function  getnewtypecount : word; override;
 {$endif GDB}
-          procedure testfordefaultproperty(p : TNamedIndexItem);
+          procedure testfordefaultproperty(p : TNamedIndexItem;arg:pointer);
        end;
 
        tabstractrecordsymtable = class(tstoredsymtable)
@@ -451,14 +450,14 @@ implementation
              ibsymref :
                begin
                  sym:=tstoredsym(ppufile.getderef);
-                 resolvesym(tsym(sym));
+                 resolvesym(pointer(sym));
                  if assigned(sym) then
                    sym.load_references(ppufile,locals);
                end;
              ibdefref :
                begin
                  prdef:=tstoreddef(ppufile.getderef);
-                 resolvedef(tdef(prdef));
+                 resolvedef(pointer(prdef));
                  if assigned(prdef) then
                    begin
                      if prdef.deftype<>procdef then
@@ -669,7 +668,7 @@ implementation
              Callbacks
 **************************************}
 
-    procedure TStoredSymtable.check_forward(sym : TNamedIndexItem);
+    procedure TStoredSymtable.check_forward(sym : TNamedIndexItem;arg:pointer);
       begin
          if tsym(sym).typ=procsym then
            tprocsym(sym).check_forward
@@ -684,7 +683,7 @@ implementation
       end;
 
 
-    procedure TStoredSymtable.labeldefined(p : TNamedIndexItem);
+    procedure TStoredSymtable.labeldefined(p : TNamedIndexItem;arg:pointer);
       begin
         if (tsym(p).typ=labelsym) and
            not(tlabelsym(p).defined) then
@@ -697,18 +696,18 @@ implementation
       end;
 
 
-    procedure TStoredSymtable.unitsymbolused(p : TNamedIndexItem);
+    procedure TStoredSymtable.unitsymbolused(p : TNamedIndexItem;arg:pointer);
       begin
          if (tsym(p).typ=unitsym) and
             (tunitsym(p).refs=0) and
             { do not claim for unit name itself !! }
+            assigned(tunitsym(p).unitsymtable) and
             (tunitsym(p).unitsymtable.symtabletype=globalsymtable) then
-           MessagePos2(tsym(p).fileinfo,sym_n_unit_not_used,
-             p.name,current_module.modulename^);
+           MessagePos2(tsym(p).fileinfo,sym_n_unit_not_used,p.name,current_module.modulename^);
       end;
 
 
-    procedure TStoredSymtable.varsymbolused(p : TNamedIndexItem);
+    procedure TStoredSymtable.varsymbolused(p : TNamedIndexItem;arg:pointer);
       begin
          if (tsym(p).typ=varsym) and
             ((tsym(p).owner.symtabletype in
@@ -773,14 +772,14 @@ implementation
       end;
 
 
-    procedure TStoredSymtable.TestPrivate(p : TNamedIndexItem);
+    procedure TStoredSymtable.TestPrivate(p : TNamedIndexItem;arg:pointer);
       begin
         if sp_private in tsym(p).symoptions then
-          varsymbolused(p);
+          varsymbolused(p,arg);
       end;
 
 
-    procedure TStoredSymtable.objectprivatesymbolused(p : TNamedIndexItem);
+    procedure TStoredSymtable.objectprivatesymbolused(p : TNamedIndexItem;arg:pointer);
       begin
          {
            Don't test simple object aliases PM
@@ -788,11 +787,11 @@ implementation
          if (tsym(p).typ=typesym) and
             (ttypesym(p).restype.def.deftype=objectdef) and
             (ttypesym(p).restype.def.typesym=tsym(p)) then
-           tobjectdef(ttypesym(p).restype.def).symtable.foreach({$ifdef FPCPROCVAR}@{$endif}TestPrivate);
+           tobjectdef(ttypesym(p).restype.def).symtable.foreach({$ifdef FPCPROCVAR}@{$endif}TestPrivate,nil);
       end;
 
 
-    procedure tstoredsymtable.unchain_overloads(p : TNamedIndexItem);
+    procedure tstoredsymtable.unchain_overloads(p : TNamedIndexItem;arg:pointer);
       begin
          if tsym(p).typ=procsym then
            tprocsym(p).unchain_overload;
@@ -800,24 +799,24 @@ implementation
 
 {$ifdef GDB}
 
-    procedure TStoredSymtable.concatstab(p : TNamedIndexItem);
+    procedure TStoredSymtable.concatstab(p : TNamedIndexItem;arg:pointer);
       begin
         if tsym(p).typ <> procsym then
-          tstoredsym(p).concatstabto(asmoutput);
+          tstoredsym(p).concatstabto(TAAsmOutput(arg));
       end;
 
-    procedure TStoredSymtable.resetstab(p : TNamedIndexItem);
+    procedure TStoredSymtable.resetstab(p : TNamedIndexItem;arg:pointer);
       begin
         if tsym(p).typ <> procsym then
           tstoredsym(p).isstabwritten:=false;
       end;
 
-    procedure TStoredSymtable.concattypestab(p : TNamedIndexItem);
+    procedure TStoredSymtable.concattypestab(p : TNamedIndexItem;arg:pointer);
       begin
         if tsym(p).typ = typesym then
          begin
            tstoredsym(p).isstabwritten:=false;
-           tstoredsym(p).concatstabto(asmoutput);
+           tstoredsym(p).concatstabto(TAAsmOutput(arg));
          end;
       end;
 
@@ -894,48 +893,47 @@ implementation
     { checks, if all procsyms and methods are defined }
     procedure tstoredsymtable.check_forwards;
       begin
-         foreach({$ifdef FPCPROCVAR}@{$endif}check_forward);
+         foreach({$ifdef FPCPROCVAR}@{$endif}check_forward,nil);
       end;
 
 
     procedure tstoredsymtable.checklabels;
       begin
-         foreach({$ifdef FPCPROCVAR}@{$endif}labeldefined);
+         foreach({$ifdef FPCPROCVAR}@{$endif}labeldefined,nil);
       end;
 
 
     procedure tstoredsymtable.allunitsused;
       begin
-         foreach({$ifdef FPCPROCVAR}@{$endif}unitsymbolused);
+         foreach({$ifdef FPCPROCVAR}@{$endif}unitsymbolused,nil);
       end;
 
 
     procedure tstoredsymtable.allsymbolsused;
       begin
-         foreach({$ifdef FPCPROCVAR}@{$endif}varsymbolused);
+         foreach({$ifdef FPCPROCVAR}@{$endif}varsymbolused,nil);
       end;
 
 
     procedure tstoredsymtable.allprivatesused;
       begin
-         foreach({$ifdef FPCPROCVAR}@{$endif}objectprivatesymbolused);
+         foreach({$ifdef FPCPROCVAR}@{$endif}objectprivatesymbolused,nil);
       end;
 
 
     procedure tstoredsymtable.unchain_overloaded;
       begin
-         foreach({$ifdef FPCPROCVAR}@{$endif}unchain_overloads);
+         foreach({$ifdef FPCPROCVAR}@{$endif}unchain_overloads,nil);
       end;
 
 
 {$ifdef GDB}
     procedure tstoredsymtable.concatstabto(asmlist : taasmoutput);
       begin
-        asmoutput:=asmlist;
         if symtabletype in [inlineparasymtable,inlinelocalsymtable] then
-          foreach({$ifdef FPCPROCVAR}@{$endif}resetstab);
+          foreach({$ifdef FPCPROCVAR}@{$endif}resetstab,nil);
 
-        foreach({$ifdef FPCPROCVAR}@{$endif}concatstab);
+        foreach({$ifdef FPCPROCVAR}@{$endif}concatstab,asmlist);
       end;
 {$endif}
 
@@ -944,7 +942,7 @@ implementation
     function tstoredsymtable.needs_init_final : boolean;
       begin
          b_needs_init_final:=false;
-         foreach({$ifdef FPCPROCVAR}@{$endif}_needs_init_final);
+         foreach({$ifdef FPCPROCVAR}@{$endif}_needs_init_final,nil);
          needs_init_final:=b_needs_init_final;
       end;
 
@@ -1009,7 +1007,7 @@ implementation
       end;
 
 
-    procedure TStoredSymtable._needs_init_final(p : tnamedindexitem);
+    procedure TStoredSymtable._needs_init_final(p : tnamedindexitem;arg:pointer);
       begin
          if (not b_needs_init_final) and
             (tsym(p).typ=varsym) and
@@ -1363,8 +1361,7 @@ implementation
                     do_count_dbx:=assigned(dbx_counter);
                   end;
              end;
-           asmoutput:=asmlist;
-           foreach({$ifdef FPCPROCVAR}@{$endif}concattypestab);
+           foreach({$ifdef FPCPROCVAR}@{$endif}concattypestab,asmlist);
            if cs_gdb_dbx in aktglobalswitches then
              begin
                 if (current_module.globalsymtable<>self) then
@@ -1886,7 +1883,7 @@ implementation
    var
       _defaultprop : tpropertysym;
 
-   procedure tstoredsymtable.testfordefaultproperty(p : TNamedIndexItem);
+   procedure tstoredsymtable.testfordefaultproperty(p : TNamedIndexItem;arg:pointer);
      begin
         if (tsym(p).typ=propertysym) and
            (ppo_defaultproperty in tpropertysym(p).propoptions) then
@@ -1900,7 +1897,7 @@ implementation
         _defaultprop:=nil;
         while assigned(pd) do
           begin
-             pd.symtable.foreach({$ifdef FPCPROCVAR}@{$endif}tstoredsymtable(pd.symtable).testfordefaultproperty);
+             pd.symtable.foreach({$ifdef FPCPROCVAR}@{$endif}tstoredsymtable(pd.symtable).testfordefaultproperty,nil);
              if assigned(_defaultprop) then
                break;
              pd:=pd.childof;
@@ -2063,7 +2060,24 @@ implementation
 end.
 {
   $Log$
-  Revision 1.57  2002-04-04 19:06:05  peter
+  Revision 1.58  2002-05-12 16:53:15  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.57  2002/04/04 19:06:05  peter
     * removed unused units
     * use tlocation.size in cg.a_*loc*() routines
 

compiler/symtype.pas

@@ -137,8 +137,8 @@ interface
 
 
     { resolving }
-    procedure resolvesym(var sym:tsym);
-    procedure resolvedef(var def:tdef);
+    procedure resolvesym(var sym:pointer);
+    procedure resolvedef(var def:pointer);
 
 
 implementation
@@ -299,11 +299,11 @@ implementation
       begin
         if assigned(sym) then
          begin
-           resolvesym(sym);
+           resolvesym(pointer(sym));
            setsym(sym);
          end
         else
-         resolvedef(def);
+         resolvedef(pointer(def));
       end;
 
 {****************************************************************************
@@ -417,12 +417,12 @@ implementation
       var
         hp : psymlistitem;
       begin
-        resolvedef(def);
+        resolvedef(pointer(def));
         hp:=firstsym;
         while assigned(hp) do
          begin
            if assigned(hp^.sym) then
-            resolvesym(hp^.sym);
+            resolvesym(pointer(hp^.sym));
            hp:=hp^.next;
          end;
       end;
@@ -500,12 +500,12 @@ implementation
       end;
 
 
-    procedure resolvedef(var def:tdef);
+    procedure resolvedef(var def:pointer);
       var
         st   : tsymtable;
         idx  : word;
       begin
-        resolvederef(tderef(def),st,idx);
+        resolvederef(tderef(pointer(def)),st,idx);
         if assigned(st) then
          def:=tdef(st.getdefnr(idx))
         else
@@ -513,12 +513,12 @@ implementation
       end;
 
 
-    procedure resolvesym(var sym:tsym);
+    procedure resolvesym(var sym:pointer);
       var
         st   : tsymtable;
         idx  : word;
       begin
-        resolvederef(tderef(sym),st,idx);
+        resolvederef(tderef(pointer(sym)),st,idx);
         if assigned(st) then
          sym:=tsym(st.getsymnr(idx))
         else
@@ -528,7 +528,24 @@ implementation
 end.
 {
   $Log$
-  Revision 1.14  2002-04-19 15:46:04  peter
+  Revision 1.15  2002-05-12 16:53:15  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.14  2002/04/19 15:46:04  peter
     * mangledname rewrite, tprocdef.mangledname is now created dynamicly
       in most cases and not written to the ppu
     * add mangeledname_prefix() routine to generate the prefix of

compiler/targets/t_wdosx.pas

@@ -30,19 +30,8 @@ interface
 implementation
 
     uses
-{$ifdef Delphi}
-       dmisc,
-{$else Delphi}
-       dos,
-{$endif Delphi}
-       cutils,cclasses,
-       aasm,fmodule,globtype,globals,systems,verbose,
-       symconst,symsym,
-       script,gendef,
-       cpubase,cpuasm,
-{$ifdef GDB}
-       gdb,
-{$endif}
+       cutils,
+       fmodule,globals,systems,
        import,export,link,t_win32;
 
   type
@@ -176,7 +165,24 @@ end.
 
 {
   $Log$
-  Revision 1.4  2002-04-22 18:19:22  carl
+  Revision 1.5  2002-05-12 16:53:18  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.4  2002/04/22 18:19:22  carl
   - remove use_bound_instruction field
 
   Revision 1.3  2002/04/20 21:43:18  carl
@@ -190,4 +196,4 @@ end.
   Revision 1.1  2002/04/04 18:09:49  carl
   + added wdosx patch from Pavel
 
-}
+}

compiler/types.pas

@@ -271,7 +271,7 @@ interface
 implementation
 
     uses
-       globtype,cpubase,tokens,verbose,
+       globtype,tokens,verbose,
        symtable;
 
 
@@ -1970,7 +1970,24 @@ implementation
 end.
 {
   $Log$
-  Revision 1.69  2002-04-25 20:16:39  peter
+  Revision 1.70  2002-05-12 16:53:16  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.69  2002/04/25 20:16:39  peter
     * moved more routines from cga/n386util
 
   Revision 1.68  2002/04/15 19:08:22  carl

compiler/utils/ppudump.pp

@@ -234,7 +234,7 @@ var
 begin
   l1:=ppufile.getlongint;
   l2:=ppufile.getlongint;
-  getint64:=(int64(l2) shl 32) or l1;
+  getint64:=(int64(l2) shl 32) or qword(l1);
 end;
 
 Procedure ReadLinkContainer(const prefix:string);
@@ -1774,7 +1774,24 @@ begin
 end.
 {
   $Log$
-  Revision 1.21  2002-04-23 13:12:58  peter
+  Revision 1.22  2002-05-12 16:53:18  peter
+    * moved entry and exitcode to ncgutil and cgobj
+    * foreach gets extra argument for passing local data to the
+      iterator function
+    * -CR checks also class typecasts at runtime by changing them
+      into as
+    * fixed compiler to cycle with the -CR option
+    * fixed stabs with elf writer, finally the global variables can
+      be watched
+    * removed a lot of routines from cga unit and replaced them by
+      calls to cgobj
+    * u32bit-s32bit updates for and,or,xor nodes. When one element is
+      u32bit then the other is typecasted also to u32bit without giving
+      a rangecheck warning/error.
+    * fixed pascal calling method with reversing also the high tree in
+      the parast, detected by tcalcst3 test
+
+  Revision 1.21  2002/04/23 13:12:58  peter
     * updated for posinfo change
     * updated for mangledname change
     * include i386 registers, removed reference to cpubase unit that would