* smartlinking works for win32

  * some defines to exclude some compiler parts

compiler/aasm.pas

@@ -123,6 +123,7 @@ unit aasm;
        plabel = ^tlabel;
        tlabel = record
                   nb       : longint;
+                  is_data  : boolean;
                   is_used  : boolean;
                   is_set   : boolean;
                   refcount : word;
@@ -285,6 +286,8 @@ type
     function lab2str(l : plabel) : string;
     { make l as a new label }
     procedure getlabel(var l : plabel);
+    { make l as a new label and flag is_data }
+    procedure getdatalabel(var l : plabel);
     { frees the label if unused }
     procedure freelabel(var l : plabel);
     { make a new zero label }
@@ -585,18 +588,15 @@ uses
           typ:=ait_label;
           l:=_l;
           l^.is_set:=true;
-          { suggestion of JM:
-            inc(l^.refcount); }
        end;
 
     destructor tai_label.done;
 
       begin
-         { suggestion of JM:
-         dec(l^.refcount);  }
          if (l^.is_used) then
            l^.is_set:=false
-         else dispose(l);
+         else
+           dispose(l);
          inherited done;
       end;
 
@@ -751,15 +751,20 @@ uses
     function lab2str(l : plabel) : string;
       begin
          if (l=nil) or (l^.nb=0) then
+           begin
 {$ifdef EXTDEBUG}
-           lab2str:='ILLEGAL'
-         else
-           lab2str:=target_asm.labelprefix+tostr(l^.nb);
+             lab2str:='ILLEGAL'
 {$else EXTDEBUG}
-         internalerror(2000);
-         lab2str:=target_asm.labelprefix+tostr(l^.nb);
+             internalerror(2000);
 {$endif EXTDEBUG}
-         { was missed: }
+           end
+         else
+           begin
+             if (l^.is_data) and (cs_smartlink in aktswitches) then
+              lab2str:='_$'+current_module^.modulename^+'$_L'+tostr(l^.nb)
+             else
+              lab2str:=target_asm.labelprefix+tostr(l^.nb);
+           end;
          inc(l^.refcount);
          l^.is_used:=true;
       end;
@@ -771,6 +776,19 @@ uses
          l^.nb:=nextlabelnr;
          l^.is_used:=false;
          l^.is_set:=false;
+         l^.is_data:=false;
+         l^.refcount:=0;
+         inc(nextlabelnr);
+      end;
+
+
+    procedure getdatalabel(var l : plabel);
+      begin
+         new(l);
+         l^.nb:=nextlabelnr;
+         l^.is_used:=false;
+         l^.is_set:=false;
+         l^.is_data:=true;
          l^.refcount:=0;
          inc(nextlabelnr);
       end;
@@ -791,6 +809,7 @@ uses
            nb:=0;
            is_used:=false;
            is_set:=false;
+           is_data:=false;
            refcount:=0;
          end;
       end;
@@ -802,6 +821,7 @@ uses
          l^.nb:=0;
          l^.is_used:=false;
          l^.is_set:=false;
+         l^.is_data:=false;
          l^.refcount:=0;
       end;
 
@@ -817,7 +837,11 @@ uses
 end.
 {
   $Log$
-  Revision 1.9  1998-06-04 23:51:26  peter
+  Revision 1.10  1998-06-08 22:59:41  peter
+    * smartlinking works for win32
+    * some defines to exclude some compiler parts
+
+  Revision 1.9  1998/06/04 23:51:26  peter
     * m68k compiles
     + .def file creation moved to gendef.pas so it could also be used
       for win32

compiler/assemble.pas

@@ -45,6 +45,7 @@ type
     srcfile,
     as_bin   : string;
   {outfile}
+    AsmSize,
     outcnt   : longint;
     outbuf   : array[0..AsmOutSize-1] of char;
     outfile  : file;
@@ -82,10 +83,26 @@ uses
 {$endif}
   ,strings
 {$ifdef i386}
-  ,ag386att,ag386int,ag386nsm
+  {$ifndef NoAg386Att}
+    ,ag386att
+  {$endif NoAg386Att}
+  {$ifndef NoAg386Nsm}
+    ,ag386nsm
+  {$endif NoAg386Nsm}
+  {$ifndef NoAg386Int}
+    ,ag386int
+  {$endif NoAg386Int}
 {$endif}
 {$ifdef m68k}
-  ,ag68kmot,ag68kgas,ag68kmit
+  {$ifndef NoAg68kGas}
+    ,ag68kgas
+  {$endif NoAg68kGas}
+  {$ifndef NoAg68kMot}
+    ,ag68kmot
+  {$endif NoAg68kMot}
+  {$ifndef NoAg68kMit}
+    ,ag68kmit
+  {$endif NoAg68kMit}
 {$endif}
   ;
 
@@ -231,6 +248,7 @@ begin
    AsmFlush;
   Move(s[1],OutBuf[OutCnt],length(s));
   inc(OutCnt,length(s));
+  inc(AsmSize,length(s));
 end;
 
 
@@ -254,6 +272,7 @@ begin
       AsmFlush;
      Move(p[0],OutBuf[OutCnt],i);
      inc(OutCnt,i);
+     inc(AsmSize,i);
      dec(j,i);
      p:=pchar(@p[i]);
    end;
@@ -266,10 +285,12 @@ begin
    AsmFlush;
   OutBuf[OutCnt]:=target_os.newline[1];
   inc(OutCnt);
+  inc(AsmSize);
   if length(target_os.newline)>1 then
    begin
      OutBuf[OutCnt]:=target_os.newline[2];
      inc(OutCnt);
+     inc(AsmSize);
    end;
 end;
 
@@ -295,6 +316,7 @@ begin
       Message1(exec_d_cant_create_asmfile,asmfile);
    end;
   outcnt:=0;
+  AsmSize:=0;
 end;
 
 
@@ -380,20 +402,32 @@ var
 begin
   case aktoutputformat of
 {$ifdef i386}
+  {$ifndef NoAg386Att}
         as_o : a:=new(pi386attasmlist,Init(fn));
+  {$endif NoAg386Att}
+  {$ifndef NoAg386Nsm}
  as_nasmcoff,
   as_nasmelf,
   as_nasmobj : a:=new(pi386nasmasmlist,Init(fn));
+  {$endif NoAg386Nsm}
+  {$ifndef NoAg386Int}
      as_tasm : a:=new(pi386intasmlist,Init(fn));
+  {$endif NoAg386Int}
 {$endif}
 {$ifdef m68k}
+  {$ifndef NoAg68kGas}
      as_o,
    as_gas : a:=new(pm68kgasasmlist,Init(fn));
+  {$endif NoAg86KGas}
+  {$ifndef NoAg68kMot}
    as_mot : a:=new(pm68kmotasmlist,Init(fn));
+  {$endif NoAg86kMot}
+  {$ifndef NoAg68kMit}
    as_mit : a:=new(pm68kmitasmlist,Init(fn));
+  {$endif NoAg86KMot}
 {$endif}
   else
-   internalerror(30000);
+   Comment(V_Fatal,'Selected assembler output not supported!');
   end;
   a^.AsmCreate;
   a^.WriteAsmList;
@@ -416,7 +450,11 @@ end;
 end.
 {
   $Log$
-  Revision 1.10  1998-06-04 23:51:33  peter
+  Revision 1.11  1998-06-08 22:59:43  peter
+    * smartlinking works for win32
+    * some defines to exclude some compiler parts
+
+  Revision 1.10  1998/06/04 23:51:33  peter
     * m68k compiles
     + .def file creation moved to gendef.pas so it could also be used
       for win32

compiler/cgi3862.pas

@@ -1,63 +0,0 @@
-{
-    $Id$
-    Copyright (c) 1993-98 by Florian Klaempfl
-
-    This unit generates i386 (or better) assembler from the parse tree
-
-    This program is free software; you can redistribute it and/or modify
-    it under the terms of the GNU General Public License as published by
-    the Free Software Foundation; either version 2 of the License, or
-    (at your option) any later version.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-    GNU General Public License for more details.
-
-    You should have received a copy of the GNU General Public License
-    along with this program; if not, write to the Free Software
-    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
- ****************************************************************************
-}
-{$ifdef tp}
-  {$E+,F+,N+,D+,L+,Y+}
-{$endif}
-unit cgi3862;
-
-  interface
-
-    uses
-       verbose,cobjects,systems,globals,tree,
-       symtable,types,strings,pass_1,hcodegen,
-       aasm,i386,tgeni386,files,cgai386;
-
-    procedure secondadd(var p : ptree);
-    procedure secondaddstring(var p : ptree);
-    procedure secondas(var p : ptree);
-    procedure secondis(var p : ptree);
-    procedure secondloadvmt(var p : ptree);
-
-  implementation
-
-    uses
-       cgi386;
-
-{$I cgi386ad.inc}
-
-end.
-{
-  $Log$
-  Revision 1.2  1998-04-21 10:16:47  peter
-    * patches from strasbourg
-    * objects is not used anymore in the fpc compiled version
-
-  Revision 1.1.1.1  1998/03/25 11:18:12  root
-  * Restored version
-
-  Revision 1.9  1998/03/10 01:17:18  peter
-    * all files have the same header
-    * messages are fully implemented, EXTDEBUG uses Comment()
-    + AG... files for the Assembler generation
-
-}

compiler/cgi386ad.inc

@@ -1,1323 +0,0 @@
-{
-    $Id$
-    Copyright (c) 1993-98 by Florian Klaempfl
-
-    This include file generates i386+ assembler from the parse tree
-
-    This program is free software; you can redistribute it and/or modify
-    it under the terms of the GNU General Public License as published by
-    the Free Software Foundation; either version 2 of the License, or
-    (at your option) any later version.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-    GNU General Public License for more details.
-
-    You should have received a copy of the GNU General Public License
-    along with this program; if not, write to the Free Software
-    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
- ****************************************************************************
-}
-
-    procedure secondas(var p : ptree);
-
-      var
-         pushed : tpushed;
-
-      begin
-         secondpass(p^.left);
-         { save all used registers }
-         pushusedregisters(pushed,$ff);
-
-         { push instance to check: }
-         case p^.left^.location.loc of
-            LOC_REGISTER,LOC_CREGISTER:
-              exprasmlist^.concat(new(pai386,op_reg(A_PUSH,
-                S_L,p^.left^.location.register)));
-            LOC_MEM,LOC_REFERENCE:
-              exprasmlist^.concat(new(pai386,op_ref(A_PUSH,
-                S_L,newreference(p^.left^.location.reference))));
-            else internalerror(100);
-         end;
-
-         { we doesn't modifiy the left side, we check only the type }
-         set_location(p^.location,p^.left^.location);
-
-         { generate type checking }
-         secondpass(p^.right);
-         case p^.right^.location.loc of
-            LOC_REGISTER,LOC_CREGISTER:
-              begin
-                 exprasmlist^.concat(new(pai386,op_reg(A_PUSH,
-                   S_L,p^.right^.location.register)));
-                 ungetregister32(p^.right^.location.register);
-              end;
-            LOC_MEM,LOC_REFERENCE:
-              begin
-                 exprasmlist^.concat(new(pai386,op_ref(A_PUSH,
-                   S_L,newreference(p^.right^.location.reference))));
-                 del_reference(p^.right^.location.reference);
-              end;
-            else internalerror(100);
-         end;
-         emitcall('DO_AS',true);
-         { restore register, this restores automatically the }
-         { result                                            }
-         popusedregisters(pushed);
-      end;
-
-    procedure secondloadvmt(var p : ptree);
-
-      begin
-         p^.location.register:=getregister32;
-         exprasmlist^.concat(new(pai386,op_csymbol_reg(A_MOV,
-            S_L,newcsymbol(pobjectdef(pclassrefdef(p^.resulttype)^.definition)^.vmt_mangledname,0),
-            p^.location.register)));
-      end;
-
-    procedure secondis(var p : ptree);
-
-      var
-         pushed : tpushed;
-
-      begin
-         { save all used registers }
-         pushusedregisters(pushed,$ff);
-         secondpass(p^.left);
-         p^.location.loc:=LOC_FLAGS;
-         p^.location.resflags:=F_NE;
-
-         { push instance to check: }
-         case p^.left^.location.loc of
-            LOC_REGISTER,LOC_CREGISTER:
-              begin
-                 exprasmlist^.concat(new(pai386,op_reg(A_PUSH,
-                   S_L,p^.left^.location.register)));
-                 ungetregister32(p^.left^.location.register);
-              end;
-            LOC_MEM,LOC_REFERENCE:
-              begin
-                 exprasmlist^.concat(new(pai386,op_ref(A_PUSH,
-                   S_L,newreference(p^.left^.location.reference))));
-                 del_reference(p^.left^.location.reference);
-              end;
-            else internalerror(100);
-         end;
-
-         { generate type checking }
-         secondpass(p^.right);
-         case p^.right^.location.loc of
-            LOC_REGISTER,LOC_CREGISTER:
-              begin
-                 exprasmlist^.concat(new(pai386,op_reg(A_PUSH,
-                   S_L,p^.right^.location.register)));
-                 ungetregister32(p^.right^.location.register);
-              end;
-            LOC_MEM,LOC_REFERENCE:
-              begin
-                 exprasmlist^.concat(new(pai386,op_ref(A_PUSH,
-                   S_L,newreference(p^.right^.location.reference))));
-                 del_reference(p^.right^.location.reference);
-              end;
-            else internalerror(100);
-         end;
-         emitcall('DO_IS',true);
-         exprasmlist^.concat(new(pai386,op_reg_reg(A_OR,S_B,R_AL,R_AL)));
-         popusedregisters(pushed);
-      end;
-
-    procedure setaddresult(cmpop,unsigned : boolean;var p :ptree);
-      var
-         flags : tresflags;
-      begin
-         if (p^.left^.resulttype^.deftype<>stringdef) and
-             ((p^.left^.resulttype^.deftype<>setdef) or
-              (psetdef(p^.left^.resulttype)^.settype=smallset)) then
-              if (p^.left^.location.loc=LOC_REFERENCE) or
-                 (p^.left^.location.loc=LOC_MEM) then
-                ungetiftemp(p^.left^.location.reference);
-         if (p^.right^.resulttype^.deftype<>stringdef) and
-             ((p^.right^.resulttype^.deftype<>setdef) or
-              (psetdef(p^.right^.resulttype)^.settype=smallset)) then
-              { this can be useful if for instance length(string) is called }
-              if (p^.right^.location.loc=LOC_REFERENCE) or
-                 (p^.right^.location.loc=LOC_MEM) then
-                ungetiftemp(p^.right^.location.reference);
-         { in case of comparison operation the put result in the flags }
-         if cmpop then
-           begin
-              if not(unsigned) then
-                begin
-                   if p^.swaped then
-                     case p^.treetype of
-                        equaln : flags:=F_E;
-                        unequaln : flags:=F_NE;
-                        ltn : flags:=F_G;
-                        lten : flags:=F_GE;
-                        gtn : flags:=F_L;
-                        gten : flags:=F_LE;
-                     end
-                   else
-                     case p^.treetype of
-                        equaln : flags:=F_E;
-                        unequaln : flags:=F_NE;
-                        ltn : flags:=F_L;
-                        lten : flags:=F_LE;
-                        gtn : flags:=F_G;
-                        gten : flags:=F_GE;
-                     end;
-                end
-              else
-                begin
-                   if p^.swaped then
-                     case p^.treetype of
-                        equaln : flags:=F_E;
-                        unequaln : flags:=F_NE;
-                        ltn : flags:=F_A;
-                        lten : flags:=F_AE;
-                        gtn : flags:=F_B;
-                        gten : flags:=F_BE;
-                     end
-                   else
-                     case p^.treetype of
-                        equaln : flags:=F_E;
-                        unequaln : flags:=F_NE;
-                        ltn : flags:=F_B;
-                        lten : flags:=F_BE;
-                        gtn : flags:=F_A;
-                        gten : flags:=F_AE;
-                     end;
-                end;
-              p^.location.loc:=LOC_FLAGS;
-              p^.location.resflags:=flags;
-           end;
-      end;
-
-
-  procedure secondaddstring(var p : ptree);
-
-    var
-       swapp : ptree;
-       pushedregs : tpushed;
-       href : treference;
-       pushed,cmpop : boolean;
-
-    begin
-       { string operations are not commutative }
-       if p^.swaped then
-         begin
-            swapp:=p^.left;
-            p^.left:=p^.right;
-            p^.right:=swapp;
-            { because of jump being produced at comparison below: }
-            p^.swaped:=not(p^.swaped);
-         end;
-{$ifdef UseAnsiString}
-              if is_ansistring(p^.left^.resulttype) then
-                begin
-                  case p^.treetype of
-                  addn :
-                    begin
-                       { we do not need destination anymore }
-                       del_reference(p^.left^.location.reference);
-                       del_reference(p^.right^.location.reference);
-                       { concatansistring(p); }
-                    end;
-                  ltn,lten,gtn,gten,
-                  equaln,unequaln :
-                    begin
-                       pushusedregisters(pushedregs,$ff);
-                       secondpass(p^.left);
-                       del_reference(p^.left^.location.reference);
-                       emitpushreferenceaddr(p^.left^.location.reference);
-                       secondpass(p^.right);
-                       del_reference(p^.right^.location.reference);
-                       emitpushreferenceaddr(p^.right^.location.reference);
-                       emitcall('ANSISTRCMP',true);
-                       maybe_loadesi;
-                       popusedregisters(pushedregs);
-                    end;
-                  end;
-                end
-              else
-{$endif UseAnsiString}
-       case p^.treetype of
-          addn :
-            begin
-               cmpop:=false;
-               secondpass(p^.left);
-               { if str_concat is set in expr
-                 s:=s+ ... no need to create a temp string (PM) }
-
-               if (p^.left^.treetype<>addn) and not (p^.use_strconcat) then
-                 begin
-
-                    { can only reference be }
-                    { string in register would be funny    }
-                    { therefore produce a temporary string }
-
-                    { release the registers }
-                    del_reference(p^.left^.location.reference);
-                    gettempofsizereference(256,href);
-                    copystring(href,p^.left^.location.reference,255);
-                    ungetiftemp(p^.left^.location.reference);
-
-                    { does not hurt: }
-                    p^.left^.location.loc:=LOC_MEM;
-                    p^.left^.location.reference:=href;
-                 end;
-
-               secondpass(p^.right);
-
-               { on the right we do not need the register anymore too }
-               del_reference(p^.right^.location.reference);
-{               if p^.right^.resulttype^.deftype=orddef then
-                begin
-                  pushusedregisters(pushedregs,$ff);
-                  exprasmlist^.concat(new(pai386,op_ref_reg(
-                     A_LEA,S_L,newreference(p^.left^.location.reference),R_EDI)));
-                  exprasmlist^.concat(new(pai386,op_reg_reg(
-                     A_XOR,S_L,R_EBX,R_EBX)));
-                  reset_reference(href);
-                  href.base:=R_EDI;
-                  exprasmlist^.concat(new(pai386,op_ref_reg(
-                     A_MOV,S_B,newreference(href),R_BL)));
-                  exprasmlist^.concat(new(pai386,op_reg(
-                     A_INC,S_L,R_EBX)));
-                  exprasmlist^.concat(new(pai386,op_reg_ref(
-                     A_MOV,S_B,R_BL,newreference(href))));
-                  href.index:=R_EBX;
-                  if p^.right^.treetype=ordconstn then
-                    exprasmlist^.concat(new(pai386,op_const_ref(
-                       A_MOV,S_L,p^.right^.value,newreference(href))))
-                  else
-                   begin
-                     if p^.right^.location.loc in [LOC_CREGISTER,LOC_REGISTER] then
-                      exprasmlist^.concat(new(pai386,op_reg_ref(
-                        A_MOV,S_B,p^.right^.location.register,newreference(href))))
-                     else
-                      begin
-                        exprasmlist^.concat(new(pai386,op_ref_reg(
-                          A_MOV,S_L,newreference(p^.right^.location.reference),R_EAX)));
-                        exprasmlist^.concat(new(pai386,op_reg_ref(
-                          A_MOV,S_B,R_AL,newreference(href))));
-                      end;
-                   end;
-                  popusedregisters(pushedregs);
-                end
-               else }
-                begin
-                  if p^.use_strconcat then
-                    pushusedregisters(pushedregs,pstringdef(p^.left^.resulttype)^.len)
-                  else
-                    pushusedregisters(pushedregs,$ff);
-                  emitpushreferenceaddr(p^.left^.location.reference);
-                  emitpushreferenceaddr(p^.right^.location.reference);
-                  emitcall('STRCONCAT',true);
-                  maybe_loadesi;
-                  popusedregisters(pushedregs);
-                end;
-
-               set_location(p^.location,p^.left^.location);
-               ungetiftemp(p^.right^.location.reference);
-            end;
-          ltn,lten,gtn,gten,
-          equaln,unequaln :
-            begin
-               cmpop:=true;
-             { generate better code for s='' and s<>'' }
-               if (p^.treetype in [equaln,unequaln]) and
-                  (((p^.left^.treetype=stringconstn) and (p^.left^.values^='')) or
-                   ((p^.right^.treetype=stringconstn) and (p^.right^.values^=''))) then
-                 begin
-                    secondpass(p^.left);
-                    { are too few registers free? }
-                    pushed:=maybe_push(p^.right^.registers32,p);
-                    secondpass(p^.right);
-                    if pushed then restore(p);
-                    del_reference(p^.right^.location.reference);
-                    del_reference(p^.left^.location.reference);
-                    { only one node can be stringconstn }
-                    { else pass 1 would have evaluted   }
-                    { this node                         }
-                    if p^.left^.treetype=stringconstn then
-                      exprasmlist^.concat(new(pai386,op_const_ref(
-                        A_CMP,S_B,0,newreference(p^.right^.location.reference))))
-                    else
-                      exprasmlist^.concat(new(pai386,op_const_ref(
-                        A_CMP,S_B,0,newreference(p^.left^.location.reference))));
-                 end
-               else
-                 begin
-                    pushusedregisters(pushedregs,$ff);
-                    secondpass(p^.left);
-                    del_reference(p^.left^.location.reference);
-                    emitpushreferenceaddr(p^.left^.location.reference);
-                    secondpass(p^.right);
-                    del_reference(p^.right^.location.reference);
-                    emitpushreferenceaddr(p^.right^.location.reference);
-                    emitcall('STRCMP',true);
-                    maybe_loadesi;
-                    popusedregisters(pushedregs);
-                 end;
-               ungetiftemp(p^.left^.location.reference);
-               ungetiftemp(p^.right^.location.reference);
-            end;
-            else Message(sym_e_type_mismatch);
-          end;
-       setaddresult(cmpop,true,p);
-    end;
-
-    procedure secondadd(var p : ptree);
-
-    { is also being used for xor, and "mul", "sub, or and comparative }
-    { operators                                                       }
-
-      label do_normal;
-
-      var
-         swapp : ptree;
-         hregister : tregister;
-         pushed,mboverflow,cmpop : boolean;
-         op : tasmop;
-         pushedregs : tpushed;
-         flags : tresflags;
-         otl,ofl : plabel;
-         power : longint;
-         href : treference;
-         opsize : topsize;
-         hl4: plabel;
-
-         { true, if unsigned types are compared }
-         unsigned : boolean;
-
-         { is_in_dest if the result is put directly into }
-         { the resulting refernce or varregister }
-         { true, if a small set is handled with the longint code }
-         is_set : boolean;
-         is_in_dest : boolean;
-         { true, if for sets subtractions the extra not should generated }
-         extra_not : boolean;
-
-{$ifdef SUPPORT_MMX}
-         mmxbase : tmmxtype;
-{$endif SUPPORT_MMX}
-
-      begin
-         if (p^.left^.resulttype^.deftype=stringdef) then
-           begin
-              secondaddstring(p);
-              exit;
-           end;
-         unsigned:=false;
-         is_in_dest:=false;
-         extra_not:=false;
-
-         opsize:=S_L;
-
-         { calculate the operator which is more difficult }
-         firstcomplex(p);
-         { handling boolean expressions extra: }
-         if ((p^.left^.resulttype^.deftype=orddef) and
-            (porddef(p^.left^.resulttype)^.typ in [bool8bit,bool16bit,bool32bit])) or
-            ((p^.right^.resulttype^.deftype=orddef) and
-            (porddef(p^.right^.resulttype)^.typ in [bool8bit,bool16bit,bool32bit])) then
-           begin
-             if (porddef(p^.left^.resulttype)^.typ=bool8bit) or
-                (porddef(p^.right^.resulttype)^.typ=bool8bit) then
-               opsize:=S_B
-             else
-               if (porddef(p^.left^.resulttype)^.typ=bool16bit) or
-                  (porddef(p^.right^.resulttype)^.typ=bool16bit) then
-                 opsize:=S_W
-             else
-               opsize:=S_L;
-             case p^.treetype of
-              andn,
-               orn : begin
-                       p^.location.loc:=LOC_JUMP;
-                       cmpop:=false;
-                       case p^.treetype of
-                        andn : begin
-                                  otl:=truelabel;
-                                  getlabel(truelabel);
-                                  secondpass(p^.left);
-                                  maketojumpbool(p^.left);
-                                  emitl(A_LABEL,truelabel);
-                                  truelabel:=otl;
-                               end;
-                        orn : begin
-                                 ofl:=falselabel;
-                                 getlabel(falselabel);
-                                 secondpass(p^.left);
-                                 maketojumpbool(p^.left);
-                                 emitl(A_LABEL,falselabel);
-                                 falselabel:=ofl;
-                              end;
-                       else
-                         Message(sym_e_type_mismatch);
-                       end;
-                       secondpass(p^.right);
-                       maketojumpbool(p^.right);
-                     end;
-          unequaln,
-       equaln,xorn : begin
-                       if p^.left^.treetype=ordconstn then
-                         begin
-                            swapp:=p^.right;
-                            p^.right:=p^.left;
-                            p^.left:=swapp;
-                            p^.swaped:=not(p^.swaped);
-                         end;
-                       secondpass(p^.left);
-                       p^.location:=p^.left^.location;
-                       { are enough registers free ? }
-                       pushed:=maybe_push(p^.right^.registers32,p);
-                       secondpass(p^.right);
-                       if pushed then restore(p);
-                       goto do_normal;
-                    end
-             else
-               Message(sym_e_type_mismatch);
-             end
-           end
-         else if (p^.left^.resulttype^.deftype=setdef) and
-                 not(psetdef(p^.left^.resulttype)^.settype=smallset) then
-           begin
-              mboverflow:=false;
-              secondpass(p^.left);
-              set_location(p^.location,p^.left^.location);
-              { are too few registers free? }
-              pushed:=maybe_push(p^.right^.registers32,p);
-              secondpass(p^.right);
-              if pushed then restore(p);
-              { not commutative }
-              if p^.swaped then
-                begin
-                   swapp:=p^.left;
-                   p^.left:=p^.right;
-                   p^.right:=swapp;
-                   { because of jump being produced by comparison }
-                   p^.swaped:=not(p^.swaped);
-                end;
-              case p^.treetype of
-                equaln,unequaln:
-                  begin
-                     cmpop:=true;
-                     del_reference(p^.left^.location.reference);
-                     del_reference(p^.right^.location.reference);
-                     pushusedregisters(pushedregs,$ff);
-                     emitpushreferenceaddr(p^.right^.location.reference);
-                     emitpushreferenceaddr(p^.left^.location.reference);
-                     emitcall('SET_COMP_SETS',true);
-                     maybe_loadesi;
-                     popusedregisters(pushedregs);
-                     ungetiftemp(p^.left^.location.reference);
-                     ungetiftemp(p^.right^.location.reference);
-                  end;
-                addn,symdifn,subn,muln:
-                  begin
-                     cmpop:=false;
-                     del_reference(p^.left^.location.reference);
-                     del_reference(p^.right^.location.reference);
-                     href.symbol:=nil;
-                     pushusedregisters(pushedregs,$ff);
-                     gettempofsizereference(32,href);
-                     emitpushreferenceaddr(href);
-                     { wrong place !! was hard to find out
-                     pushusedregisters(pushedregs,$ff);}
-                     emitpushreferenceaddr(p^.right^.location.reference);
-                     emitpushreferenceaddr(p^.left^.location.reference);
-                     case p^.treetype of
-                       subn:
-                         emitcall('SET_SUB_SETS',true);
-                       addn:
-                         emitcall('SET_ADD_SETS',true);
-                       symdifn:
-                         emitcall('SET_SYMDIF_SETS',true);
-                       muln:
-                         emitcall('SET_MUL_SETS',true);
-                     end;
-                     maybe_loadesi;
-                     popusedregisters(pushedregs);
-                     ungetiftemp(p^.left^.location.reference);
-                     ungetiftemp(p^.right^.location.reference);
-                     p^.location.loc:=LOC_MEM;
-                     stringdispose(p^.location.reference.symbol);
-                     p^.location.reference:=href;
-                  end;
-                else Message(sym_e_type_mismatch);
-              end;
-           end
-         else
-           begin
-              { in case of constant put it to the left }
-              if p^.left^.treetype=ordconstn then
-                begin
-                   swapp:=p^.right;
-                   p^.right:=p^.left;
-                   p^.left:=swapp;
-                   p^.swaped:=not(p^.swaped);
-                end;
-              secondpass(p^.left);
-              { this will be complicated as
-               a lot of code below assumes that
-               p^.location and p^.left^.location are the same }
-
-{$ifdef test_dest_loc}
-              if dest_loc_known and (dest_loc_tree=p) and
-                 ((dest_loc.loc=LOC_REGISTER) or (dest_loc.loc=LOC_CREGISTER)) then
-                begin
-                   set_location(p^.location,dest_loc);
-                   in_dest_loc:=true;
-                   is_in_dest:=true;
-                end
-              else
-{$endif test_dest_loc}
-                set_location(p^.location,p^.left^.location);
-              { are too few registers free? }
-              pushed:=maybe_push(p^.right^.registers32,p);
-              secondpass(p^.right);
-              if pushed then restore(p);
-              if (p^.left^.resulttype^.deftype=pointerdef) or
-
-                 (p^.right^.resulttype^.deftype=pointerdef) or
-
-                 ((p^.right^.resulttype^.deftype=objectdef) and
-                  pobjectdef(p^.right^.resulttype)^.isclass and
-                 (p^.left^.resulttype^.deftype=objectdef) and
-                  pobjectdef(p^.left^.resulttype)^.isclass
-                 ) or
-
-                 (p^.left^.resulttype^.deftype=classrefdef) or
-
-                 (p^.left^.resulttype^.deftype=procvardef) or
-
-                 (p^.left^.resulttype^.deftype=enumdef) or
-
-                 ((p^.left^.resulttype^.deftype=orddef) and
-                 (porddef(p^.left^.resulttype)^.typ=s32bit)) or
-                 ((p^.right^.resulttype^.deftype=orddef) and
-                 (porddef(p^.right^.resulttype)^.typ=s32bit)) or
-
-                ((p^.left^.resulttype^.deftype=orddef) and
-                 (porddef(p^.left^.resulttype)^.typ=u32bit)) or
-                 ((p^.right^.resulttype^.deftype=orddef) and
-                 (porddef(p^.right^.resulttype)^.typ=u32bit)) or
-
-                { as well as small sets }
-                ((p^.left^.resulttype^.deftype=setdef) and
-                 (psetdef(p^.left^.resulttype)^.settype=smallset)
-                ) then
-                begin
-           do_normal:
-                   mboverflow:=false;
-                   cmpop:=false;
-                   if (p^.left^.resulttype^.deftype=pointerdef) or
-                      (p^.right^.resulttype^.deftype=pointerdef) or
-                      ((p^.left^.resulttype^.deftype=orddef) and
-                      (porddef(p^.left^.resulttype)^.typ=u32bit)) or
-                      ((p^.right^.resulttype^.deftype=orddef) and
-                      (porddef(p^.right^.resulttype)^.typ=u32bit)) then
-                     unsigned:=true;
-                   is_set:=p^.resulttype^.deftype=setdef;
-
-                   case p^.treetype of
-                      addn : begin
-                                if is_set then
-                                  begin
-                                     op:=A_OR;
-                                     mboverflow:=false;
-                                     unsigned:=false;
-                                  end
-                                else
-                                  begin
-                                     op:=A_ADD;
-                                     mboverflow:=true;
-                                  end;
-                             end;
-                      symdifn : begin
-                                { the symetric diff is only for sets }
-                                if is_set then
-                                  begin
-                                     op:=A_XOR;
-                                     mboverflow:=false;
-                                     unsigned:=false;
-                                  end
-                                else
-                                  begin
-                                     Message(sym_e_type_mismatch);
-                                  end;
-                             end;
-                      muln : begin
-                                if is_set then
-                                  begin
-                                     op:=A_AND;
-                                     mboverflow:=false;
-                                     unsigned:=false;
-                                  end
-                                else
-                                  begin
-                                     if unsigned then
-                                       op:=A_MUL
-                                     else
-                                       op:=A_IMUL;
-                                     mboverflow:=true;
-                                  end;
-                             end;
-                      subn : begin
-                                if is_set then
-                                  begin
-                                     op:=A_AND;
-                                     mboverflow:=false;
-                                     unsigned:=false;
-                                     extra_not:=true;
-                                  end
-                                else
-                                  begin
-                                     op:=A_SUB;
-                                     mboverflow:=true;
-                                  end;
-                             end;
-                      ltn,lten,gtn,gten,
-                      equaln,unequaln :
-                             begin
-                                op:=A_CMP;
-                                cmpop:=true;
-                             end;
-                      xorn : op:=A_XOR;
-                      orn : op:=A_OR;
-                      andn : op:=A_AND;
-                      else Message(sym_e_type_mismatch);
-                   end;
-                   { left and right no register?  }
-                   { then one must be demanded    }
-                   if (p^.left^.location.loc<>LOC_REGISTER) and
-                     (p^.right^.location.loc<>LOC_REGISTER) then
-                     begin
-                        { register variable ? }
-                        if (p^.left^.location.loc=LOC_CREGISTER) then
-                          begin
-                             { it is OK if this is the destination }
-                             if is_in_dest then
-                               begin
-                                  hregister:=p^.location.register;
-                                  emit_reg_reg(A_MOV,opsize,p^.left^.location.register,
-                                    hregister);
-                               end
-                             else
-                             if cmpop then
-                               begin
-                                  { do not disturb the register }
-                                  hregister:=p^.location.register;
-                               end
-                             else
-                               begin
-                                  case opsize of
-                                     S_L : hregister:=getregister32;
-                                     S_B : hregister:=reg32toreg8(getregister32);
-                                  end;
-                                  emit_reg_reg(A_MOV,opsize,p^.left^.location.register,
-                                    hregister);
-                               end
-
-                          end
-                        else
-                          begin
-                             del_reference(p^.left^.location.reference);
-
-                             if is_in_dest then
-                               begin
-                                  hregister:=p^.location.register;
-                                  exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,opsize,
-                                  newreference(p^.left^.location.reference),hregister)));
-                               end
-                             else
-                               begin
-                                  { first give free, then demand new register }
-                                  case opsize of
-                                     S_L : hregister:=getregister32;
-                                     S_W : hregister:=reg32toreg16(getregister32);
-                                     S_B : hregister:=reg32toreg8(getregister32);
-                                  end;
-                                  exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,opsize,
-                                    newreference(p^.left^.location.reference),hregister)));
-                               end;
-                          end;
-
-                        p^.location.loc:=LOC_REGISTER;
-                        p^.location.register:=hregister;
-
-                     end
-                   else
-                     { if on the right the register then swap }
-                     if (p^.right^.location.loc=LOC_REGISTER) then
-                       begin
-                          swap_location(p^.location,p^.right^.location);
-
-                          { newly swapped also set swapped flag }
-                          p^.swaped:=not(p^.swaped);
-                       end;
-                   { at this point, p^.location.loc should be LOC_REGISTER }
-                   { and p^.location.register should be a valid register   }
-                   { containing the left result                            }
-                   if p^.right^.location.loc<>LOC_REGISTER then
-                     begin
-                        if (p^.treetype=subn) and p^.swaped then
-                          begin
-                             if p^.right^.location.loc=LOC_CREGISTER then
-                               begin
-                                  if extra_not then
-                                    exprasmlist^.concat(new(pai386,op_reg(A_NOT,opsize,p^.location.register)));
-
-                                  emit_reg_reg(A_MOV,opsize,p^.right^.location.register,R_EDI);
-                                  emit_reg_reg(op,opsize,p^.location.register,R_EDI);
-                                  emit_reg_reg(A_MOV,opsize,R_EDI,p^.location.register);
-                               end
-                             else
-                               begin
-                                  if extra_not then
-                                    exprasmlist^.concat(new(pai386,op_reg(A_NOT,opsize,p^.location.register)));
-
-                                  exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,opsize,
-                                    newreference(p^.right^.location.reference),R_EDI)));
-                                  exprasmlist^.concat(new(pai386,op_reg_reg(op,opsize,p^.location.register,R_EDI)));
-                                  exprasmlist^.concat(new(pai386,op_reg_reg(A_MOV,opsize,R_EDI,p^.location.register)));
-                                  del_reference(p^.right^.location.reference);
-                               end;
-                          end
-                        else
-                          begin
-                             if (p^.right^.treetype=ordconstn) and
-                                (op=A_CMP) and
-                                (p^.right^.value=0) then
-                               begin
-                                  exprasmlist^.concat(new(pai386,op_reg_reg(A_TEST,opsize,p^.location.register,
-                                    p^.location.register)));
-                               end
-                             else if (p^.right^.treetype=ordconstn) and
-                                (op=A_ADD) and
-                                (p^.right^.value=1) then
-                               begin
-                                  exprasmlist^.concat(new(pai386,op_reg(A_INC,opsize,
-                                    p^.location.register)));
-                               end
-                             else if (p^.right^.treetype=ordconstn) and
-                                (op=A_SUB) and
-                                (p^.right^.value=1) then
-                               begin
-                                  exprasmlist^.concat(new(pai386,op_reg(A_DEC,opsize,
-                                    p^.location.register)));
-                               end
-                             else if (p^.right^.treetype=ordconstn) and
-                                (op=A_IMUL) and
-                                (ispowerof2(p^.right^.value,power)) then
-                               begin
-                                  exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,opsize,power,
-                                    p^.location.register)));
-                               end
-                             else
-                               begin
-                                  if (p^.right^.location.loc=LOC_CREGISTER) then
-                                    begin
-                                       if extra_not then
-                                         begin
-                                            emit_reg_reg(A_MOV,S_L,p^.right^.location.register,R_EDI);
-                                            exprasmlist^.concat(new(pai386,op_reg(A_NOT,S_L,R_EDI)));
-                                            emit_reg_reg(A_AND,S_L,R_EDI,
-                                              p^.location.register);
-                                         end
-                                       else
-                                         begin
-                                            emit_reg_reg(op,opsize,p^.right^.location.register,
-                                              p^.location.register);
-                                         end;
-                                    end
-                                  else
-                                    begin
-                                       if extra_not then
-                                         begin
-                                            exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(
-                                              p^.right^.location.reference),R_EDI)));
-                                            exprasmlist^.concat(new(pai386,op_reg(A_NOT,S_L,R_EDI)));
-                                            emit_reg_reg(A_AND,S_L,R_EDI,
-                                              p^.location.register);
-                                         end
-                                       else
-                                         begin
-                                            exprasmlist^.concat(new(pai386,op_ref_reg(op,opsize,newreference(
-                                              p^.right^.location.reference),p^.location.register)));
-                                         end;
-                                       del_reference(p^.right^.location.reference);
-                                    end;
-                               end;
-                          end;
-                     end
-                   else
-                     begin
-                        { when swapped another result register }
-                        if (p^.treetype=subn) and p^.swaped then
-                          begin
-                             if extra_not then
-                               exprasmlist^.concat(new(pai386,op_reg(A_NOT,S_L,p^.location.register)));
-
-                             exprasmlist^.concat(new(pai386,op_reg_reg(op,opsize,
-                               p^.location.register,p^.right^.location.register)));
-                               swap_location(p^.location,p^.right^.location);
-                               { newly swapped also set swapped flag }
-                               { just to maintain ordering           }
-                               p^.swaped:=not(p^.swaped);
-                          end
-                        else
-                          begin
-                             if extra_not then
-                               exprasmlist^.concat(new(pai386,op_reg(A_NOT,S_L,p^.right^.location.register)));
-                             exprasmlist^.concat(new(pai386,op_reg_reg(op,opsize,
-                               p^.right^.location.register,
-                               p^.location.register)));
-                          end;
-                        case opsize of
-                           S_L : ungetregister32(p^.right^.location.register);
-                           S_B : ungetregister32(reg8toreg32(p^.right^.location.register));
-                        end;
-                     end;
-
-                   if cmpop then
-                     case opsize of
-                        S_L : ungetregister32(p^.location.register);
-                        S_B : ungetregister32(reg8toreg32(p^.location.register));
-                     end;
-
-                   { only in case of overflow operations }
-                   { produce overflow code }
-                   if mboverflow then
-                   { we must put it here directly, because sign of operation }
-                   { is in unsigned VAR!!                                    }
-                   begin
-                     if cs_check_overflow in aktswitches  then
-                     begin
-                       getlabel(hl4);
-                       if unsigned then
-                        emitl(A_JNB,hl4)
-                       else
-                        emitl(A_JNO,hl4);
-                       emitcall('RE_OVERFLOW',true);
-                       emitl(A_LABEL,hl4);
-                     end;
-                   end;
-                end
-              else if ((p^.left^.resulttype^.deftype=orddef) and
-                 (porddef(p^.left^.resulttype)^.typ=uchar)) then
-                begin
-                   case p^.treetype of
-                      ltn,lten,gtn,gten,
-                      equaln,unequaln :
-                                cmpop:=true;
-                      else Message(sym_e_type_mismatch);
-                   end;
-                   unsigned:=true;
-                   { left and right no register? }
-                   { the one must be demanded    }
-                   if (p^.location.loc<>LOC_REGISTER) and
-                     (p^.right^.location.loc<>LOC_REGISTER) then
-                     begin
-                        if p^.location.loc=LOC_CREGISTER then
-                          begin
-                             if cmpop then
-                               { do not disturb register }
-                               hregister:=p^.location.register
-                             else
-                               begin
-                                  hregister:=reg32toreg8(getregister32);
-                                  emit_reg_reg(A_MOV,S_B,p^.location.register,
-                                    hregister);
-                               end;
-                          end
-                        else
-                          begin
-                             del_reference(p^.location.reference);
-
-                             { first give free then demand new register }
-                             hregister:=reg32toreg8(getregister32);
-                             exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_B,newreference(p^.location.reference),
-                               hregister)));
-                          end;
-                        p^.location.loc:=LOC_REGISTER;
-                        p^.location.register:=hregister;
-                     end;
-
-                   { now p always a register }
-
-                   if (p^.right^.location.loc=LOC_REGISTER) and
-                      (p^.location.loc<>LOC_REGISTER) then
-                     begin
-                       swap_location(p^.location,p^.right^.location);
-
-                        { newly swapped also set swapped flag }
-                        p^.swaped:=not(p^.swaped);
-                     end;
-                   if p^.right^.location.loc<>LOC_REGISTER then
-                     begin
-                        if p^.right^.location.loc=LOC_CREGISTER then
-                          begin
-                             emit_reg_reg(A_CMP,S_B,
-                                p^.right^.location.register,p^.location.register);
-                          end
-                        else
-                          begin
-                             exprasmlist^.concat(new(pai386,op_ref_reg(A_CMP,S_B,newreference(
-                                p^.right^.location.reference),p^.location.register)));
-                             del_reference(p^.right^.location.reference);
-                          end;
-                     end
-                   else
-                     begin
-                        emit_reg_reg(A_CMP,S_B,p^.right^.location.register,
-                          p^.location.register);
-                        ungetregister32(reg8toreg32(p^.right^.location.register));
-                     end;
-                   ungetregister32(reg8toreg32(p^.location.register));
-                end
-              else if (p^.left^.resulttype^.deftype=floatdef) and
-                  (pfloatdef(p^.left^.resulttype)^.typ<>f32bit) then
-                 begin
-                    { real constants to the left }
-                    if p^.left^.treetype=realconstn then
-                      begin
-                         swapp:=p^.right;
-                         p^.right:=p^.left;
-                         p^.left:=swapp;
-                         p^.swaped:=not(p^.swaped);
-                      end;
-                    cmpop:=false;
-                    case p^.treetype of
-                       addn : op:=A_FADDP;
-                       muln : op:=A_FMULP;
-                       subn : op:=A_FSUBP;
-                       slashn : op:=A_FDIVP;
-                       ltn,lten,gtn,gten,
-                       equaln,unequaln : begin
-                                            op:=A_FCOMPP;
-                                            cmpop:=true;
-                                         end;
-                       else Message(sym_e_type_mismatch);
-                    end;
-
-                    if (p^.right^.location.loc<>LOC_FPU) then
-                      begin
-                         floatload(pfloatdef(p^.right^.resulttype)^.typ,p^.right^.location.reference);
-                         if (p^.left^.location.loc<>LOC_FPU) then
-                           floatload(pfloatdef(p^.left^.resulttype)^.typ,p^.left^.location.reference)
-                         { left was on the stack => swap }
-                         else
-                           p^.swaped:=not(p^.swaped);
-
-                         { releases the right reference }
-                         del_reference(p^.right^.location.reference);
-                      end
-                    { the nominator in st0 }
-                    else if (p^.left^.location.loc<>LOC_FPU) then
-                      floatload(pfloatdef(p^.left^.resulttype)^.typ,p^.left^.location.reference)
-                    { fpu operands are always in the wrong order on the stack }
-                    else
-                      p^.swaped:=not(p^.swaped);
-
-                    { releases the left reference }
-                    if (p^.left^.location.loc<>LOC_FPU) then
-                      del_reference(p^.left^.location.reference);
-
-                    { if we swaped the tree nodes, then use the reverse operator }
-                    if p^.swaped then
-                      begin
-                         if (p^.treetype=slashn) then
-                           op:=A_FDIVRP
-                         else if (p^.treetype=subn) then
-                           op:=A_FSUBRP;
-                      end;
-                    { to avoid the pentium bug
-                    if (op=FDIVP) and (opt_processors=pentium) then
-                      exprasmlist^.concat(new(pai386,op_CALL,S_NO,'EMUL_FDIVP')
-                    else
-                    }
-                    { the Intel assemblers want operands }
-                    if op<>A_FCOMPP then
-                       exprasmlist^.concat(new(pai386,op_reg_reg(op,S_NO,R_ST,R_ST1)))
-                    else
-                      exprasmlist^.concat(new(pai386,op_none(op,S_NO)));
-                    { on comparison load flags }
-                    if cmpop then
-                      begin
-                         if not(R_EAX in unused) then
-                           emit_reg_reg(A_MOV,S_L,R_EAX,R_EDI);
-                         exprasmlist^.concat(new(pai386,op_reg(A_FNSTSW,S_NO,R_AX)));
-                         exprasmlist^.concat(new(pai386,op_none(A_SAHF,S_NO)));
-                         if not(R_EAX in unused) then
-                           emit_reg_reg(A_MOV,S_L,R_EDI,R_EAX);
-                         if p^.swaped then
-                           case p^.treetype of
-                              equaln : flags:=F_E;
-                              unequaln : flags:=F_NE;
-                              ltn : flags:=F_A;
-                              lten : flags:=F_AE;
-                              gtn : flags:=F_B;
-                              gten : flags:=F_BE;
-                           end
-                         else
-                           case p^.treetype of
-                              equaln : flags:=F_E;
-                              unequaln : flags:=F_NE;
-                              ltn : flags:=F_B;
-                              lten : flags:=F_BE;
-                              gtn : flags:=F_A;
-                              gten : flags:=F_AE;
-                           end;
-                         p^.location.loc:=LOC_FLAGS;
-                         p^.location.resflags:=flags;
-                         cmpop:=false;
-                      end
-                    else
-                      p^.location.loc:=LOC_FPU;
-                 end
-{$ifdef SUPPORT_MMX}
-               else if is_mmx_able_array(p^.left^.resulttype) then
-                 begin
-                   cmpop:=false;
-                   mmxbase:=mmx_type(p^.left^.resulttype);
-                   case p^.treetype of
-                      addn : begin
-                                if (cs_mmx_saturation in aktswitches) then
-                                  begin
-                                     case mmxbase of
-                                        mmxs8bit:
-                                          op:=A_PADDSB;
-                                        mmxu8bit:
-                                          op:=A_PADDUSB;
-                                        mmxs16bit,mmxfixed16:
-                                          op:=A_PADDSB;
-                                        mmxu16bit:
-                                          op:=A_PADDUSW;
-                                     end;
-                                  end
-                                else
-                                  begin
-                                     case mmxbase of
-                                        mmxs8bit,mmxu8bit:
-                                          op:=A_PADDB;
-                                        mmxs16bit,mmxu16bit,mmxfixed16:
-                                          op:=A_PADDW;
-                                        mmxs32bit,mmxu32bit:
-                                          op:=A_PADDD;
-                                     end;
-                                  end;
-                             end;
-                      muln : begin
-                                case mmxbase of
-                                   mmxs16bit,mmxu16bit:
-                                     op:=A_PMULLW;
-                                   mmxfixed16:
-                                     op:=A_PMULHW;
-                                end;
-                             end;
-                      subn : begin
-                                if (cs_mmx_saturation in aktswitches) then
-                                  begin
-                                     case mmxbase of
-                                        mmxs8bit:
-                                          op:=A_PSUBSB;
-                                        mmxu8bit:
-                                          op:=A_PSUBUSB;
-                                        mmxs16bit,mmxfixed16:
-                                          op:=A_PSUBSB;
-                                        mmxu16bit:
-                                          op:=A_PSUBUSW;
-                                     end;
-                                  end
-                                else
-                                  begin
-                                     case mmxbase of
-                                        mmxs8bit,mmxu8bit:
-                                          op:=A_PSUBB;
-                                        mmxs16bit,mmxu16bit,mmxfixed16:
-                                          op:=A_PSUBW;
-                                        mmxs32bit,mmxu32bit:
-                                          op:=A_PSUBD;
-                                     end;
-                                  end;
-                             end;
-                      {
-                      ltn,lten,gtn,gten,
-                      equaln,unequaln :
-                             begin
-                                op:=A_CMP;
-                                cmpop:=true;
-                             end;
-                      }
-                      xorn:
-                        op:=A_PXOR;
-                      orn:
-                        op:=A_POR;
-                      andn:
-                        op:=A_PAND;
-                      else Message(sym_e_type_mismatch);
-                   end;
-                   { left and right no register?  }
-                   { then one must be demanded    }
-                   if (p^.left^.location.loc<>LOC_MMXREGISTER) and
-                     (p^.right^.location.loc<>LOC_MMXREGISTER) then
-                     begin
-                        { register variable ? }
-                        if (p^.left^.location.loc=LOC_CMMXREGISTER) then
-                          begin
-                             { it is OK if this is the destination }
-                             if is_in_dest then
-                               begin
-                                  hregister:=p^.location.register;
-                                  emit_reg_reg(A_MOVQ,S_NO,p^.left^.location.register,
-                                    hregister);
-                               end
-                             else
-                               begin
-                                  hregister:=getregistermmx;
-                                  emit_reg_reg(A_MOVQ,S_NO,p^.left^.location.register,
-                                    hregister);
-                               end
-
-                          end
-                        else
-                          begin
-                             del_reference(p^.left^.location.reference);
-
-                             if is_in_dest then
-                               begin
-                                  hregister:=p^.location.register;
-                                  exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVQ,S_NO,
-                                  newreference(p^.left^.location.reference),hregister)));
-                               end
-                             else
-                               begin
-                                  hregister:=getregistermmx;
-                                  exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVQ,S_NO,
-                                    newreference(p^.left^.location.reference),hregister)));
-                               end;
-                          end;
-
-                        p^.location.loc:=LOC_MMXREGISTER;
-                        p^.location.register:=hregister;
-
-                     end
-                   else
-                     { if on the right the register then swap }
-                     if (p^.right^.location.loc=LOC_MMXREGISTER) then
-                       begin
-                          swap_location(p^.location,p^.right^.location);
-
-                          { newly swapped also set swapped flag }
-                          p^.swaped:=not(p^.swaped);
-                       end;
-                   { at this point, p^.location.loc should be LOC_MMXREGISTER }
-                   { and p^.location.register should be a valid register      }
-                   { containing the left result                               }
-                   if p^.right^.location.loc<>LOC_MMXREGISTER then
-                     begin
-                        if (p^.treetype=subn) and p^.swaped then
-                          begin
-                             if p^.right^.location.loc=LOC_CMMXREGISTER then
-                               begin
-                                  emit_reg_reg(A_MOVQ,S_NO,p^.right^.location.register,R_MM7);
-                                  emit_reg_reg(op,S_NO,p^.location.register,R_EDI);
-                                  emit_reg_reg(A_MOVQ,S_NO,R_MM7,p^.location.register);
-                               end
-                             else
-                               begin
-
-                                  exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVQ,S_NO,
-                                    newreference(p^.right^.location.reference),R_MM7)));
-                                  exprasmlist^.concat(new(pai386,op_reg_reg(op,S_NO,p^.location.register,
-                                    R_MM7)));
-                                  exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVQ,S_NO,
-                                    R_MM7,p^.location.register)));
-                                  del_reference(p^.right^.location.reference);
-                               end;
-                          end
-                        else
-                          begin
-                             if (p^.right^.location.loc=LOC_CREGISTER) then
-                               begin
-                                  emit_reg_reg(op,S_NO,p^.right^.location.register,
-                                    p^.location.register);
-                               end
-                             else
-                               begin
-                                  exprasmlist^.concat(new(pai386,op_ref_reg(op,S_NO,newreference(
-                                    p^.right^.location.reference),p^.location.register)));
-                                  del_reference(p^.right^.location.reference);
-                               end;
-                          end;
-                     end
-                   else
-                     begin
-                        { when swapped another result register }
-                        if (p^.treetype=subn) and p^.swaped then
-                          begin
-                             exprasmlist^.concat(new(pai386,op_reg_reg(op,S_NO,
-                               p^.location.register,p^.right^.location.register)));
-                               swap_location(p^.location,p^.right^.location);
-                               { newly swapped also set swapped flag }
-                               { just to maintain ordering           }
-                               p^.swaped:=not(p^.swaped);
-                          end
-                        else
-                          begin
-                             exprasmlist^.concat(new(pai386,op_reg_reg(op,S_NO,
-                               p^.right^.location.register,
-                               p^.location.register)));
-                          end;
-                        ungetregistermmx(p^.right^.location.register);
-                     end;
-                end
-{$endif SUPPORT_MMX}
-              else Message(sym_e_type_mismatch);
-           end;
-       setaddresult(cmpop,unsigned,p);
-    end;
-
-{
-     $Log$
-     Revision 1.9  1998-06-03 22:48:53  peter
-       + wordbool,longbool
-       * rename bis,von -> high,low
-       * moved some systemunit loading/creating to psystem.pas
-
-     Revision 1.8  1998/05/11 13:07:53  peter
-       + $ifdef NEWPPU for the new ppuformat
-       + $define GDB not longer required
-       * removed all warnings and stripped some log comments
-       * no findfirst/findnext anymore to remove smartlink *.o files
-
-     Revision 1.7  1998/05/01 16:38:44  florian
-       * handling of private and protected fixed
-       + change_keywords_to_tp implemented to remove
-         keywords which aren't supported by tp
-       * break and continue are now symbols of the system unit
-       + widestring, longstring and ansistring type released
-
-     Revision 1.6  1998/04/30 15:59:40  pierre
-       * GDB works again better :
-         correct type info in one pass
-       + UseTokenInfo for better source position
-       * fixed one remaining bug in scanner for line counts
-       * several little fixes
-
-     Revision 1.5  1998/04/29 10:33:49  pierre
-       + added some code for ansistring (not complete nor working yet)
-       * corrected operator overloading
-       * corrected nasm output
-       + started inline procedures
-       + added starstarn : use ** for exponentiation (^ gave problems)
-       + started UseTokenInfo cond to get accurate positions
-
-     Revision 1.3  1998/04/08 11:34:22  peter
-       * nasm works (linux only tested)
-}

compiler/link.pas

@@ -304,7 +304,7 @@ begin
                        AddSharedLibrary('c');
                      end;
                   end;
-{$endif}                
+{$endif}
 
   end;
 
@@ -434,19 +434,23 @@ end;
 
 Procedure TLinker.MakeStaticLibrary(const path:string;filescnt:longint);
 var
+  s,
   arbin   : string;
   arfound : boolean;
   cnt     : longint;
   i       : word;
   f       : file;
 begin
-  arbin:=FindExe('ar',arfound);
+  arbin:=FindExe(target_ar.arbin,arfound);
   if (not arfound) and (not externlink) then
    begin
      Message(exec_w_ar_not_found);
      externlink:=true;
    end;
-  DoExec(arbin,'rs '+staticlibname+' '+FixPath(path)+'*'+target_info.objext,false,true);
+  s:=target_ar.arcmd;
+  Replace(s,'$LIB',staticlibname);
+  Replace(s,'$FILES',FixPath(path)+'*'+target_info.objext);
+  DoExec(arbin,s,false,true);
 { Clean up }
   if (not writeasmfile) and (not externlink) then
    begin
@@ -475,7 +479,11 @@ end;
 end.
 {
   $Log$
-  Revision 1.12  1998-06-04 23:51:44  peter
+  Revision 1.13  1998-06-08 22:59:46  peter
+    * smartlinking works for win32
+    * some defines to exclude some compiler parts
+
+  Revision 1.12  1998/06/04 23:51:44  peter
     * m68k compiles
     + .def file creation moved to gendef.pas so it could also be used
       for win32

compiler/parser.pas

@@ -34,7 +34,7 @@ unit parser;
 
     uses
       systems,cobjects,globals,verbose,
-      symtable,files,aasm,hcodegen,import,
+      symtable,files,aasm,hcodegen,
       assemble,link,script,gendef,
       scanner,pbase,pdecl,psystem,pmodules;
 
@@ -312,9 +312,6 @@ unit parser;
 
          if status.errorcount=0 then
            begin
-             if current_module^.uses_imports then
-              importlib^.generatelib;
-
              GenerateAsm(filename);
 
              if (cs_smartlink in aktswitches) then
@@ -442,7 +439,11 @@ done:
 end.
 {
   $Log$
-  Revision 1.22  1998-06-05 17:47:28  peter
+  Revision 1.23  1998-06-08 22:59:48  peter
+    * smartlinking works for win32
+    * some defines to exclude some compiler parts
+
+  Revision 1.22  1998/06/05 17:47:28  peter
     * some better uses clauses
 
   Revision 1.21  1998/06/04 23:51:49  peter

compiler/pmodules.pas

@@ -39,7 +39,7 @@ unit pmodules;
     uses
        cobjects,verbose,systems,globals,
        symtable,aasm,hcodegen,
-       link,assemble
+       link,assemble,import
 {$ifdef i386}
        ,i386
 {$endif}
@@ -63,6 +63,15 @@ unit pmodules;
       end;
 
     procedure insertsegment;
+
+        procedure fixseg(p:paasmoutput;sec:tsection);
+        begin
+          p^.insert(new(pai_section,init(sec)));
+          if (cs_smartlink in aktswitches) then
+           p^.insert(new(pai_cut,init));
+          p^.concat(new(pai_section,init(sec_none)));
+        end;
+
       begin
       {Insert Ident of the compiler}
         if (not (cs_smartlink in aktswitches))
@@ -75,15 +84,10 @@ unit pmodules;
            datasegment^.insert(new(pai_string,init('FPC '+version_string+' for '+target_string+' - '+target_info.short_name)));
          end;
       { Insert start and end of sections }
-        codesegment^.insert(new(pai_section,init(sec_code)));
-        codesegment^.concat(new(pai_section,init(sec_none)));
-        datasegment^.insert(new(pai_section,init(sec_data)));
-        datasegment^.concat(new(pai_section,init(sec_none)));
-        bsssegment^.insert(new(pai_section,init(sec_bss)));
-        bsssegment^.concat(new(pai_section,init(sec_none)));
-        consts^.insert(new(pai_asm_comment,init('Constants')));
-        consts^.insert(new(pai_section,init(sec_data)));
-        consts^.concat(new(pai_section,init(sec_none)));
+        fixseg(codesegment,sec_code);
+        fixseg(datasegment,sec_data);
+        fixseg(bsssegment,sec_bss);
+        fixseg(consts,sec_data);
       end;
 
     procedure insertheap;
@@ -101,14 +105,11 @@ unit pmodules;
           not output a pointer }
          case target_info.target of
 {$ifdef i386}
-
           target_OS2 : ;
 {$endif i386}
 {$ifdef m68k}
-
        target_Mac68K : bsssegment^.concat(new(pai_datablock,init_global('HEAP',4)));
 {$endif m68k}
-
          else
            bsssegment^.concat(new(pai_datablock,init_global('HEAP',heapsize)));
          end;
@@ -122,7 +123,6 @@ unit pmodules;
         i : longint;
       begin
 {$ifdef i386}
-
         case target_info.target of
        target_GO32V2 : begin
                        { stacksize can be specified }
@@ -130,14 +130,17 @@ unit pmodules;
                          datasegment^.concat(new(pai_const,init_32bit(stacksize)));
                        end;
         target_WIN32 : begin
-                       { generate the last entry for the imports directory }
-                         if not(assigned(importssection)) then
+                       { Generate an external entry to be sure that _mainCRTStarup will be
+                         linked, can't use concat_external because those aren't written for
+                         asw (PFV) }
+                         datasegment^.concat(new(pai_const,init_symbol('_mainCRTStartup')));
+                       { generate the last entry for the imports directory, is done
+                         in the ld script }
+                       {  if not(assigned(importssection)) then
                            importssection:=new(paasmoutput,init);
-                       { $3 ensure that it is the last entry, all other entries }
-                       { are written to $2                                      }
                          importssection^.concat(new(pai_section,init_idata(3)));
                          for i:=1 to 5 do
-                           importssection^.concat(new(pai_const,init_32bit(0)));
+                           importssection^.concat(new(pai_const,init_32bit(0))); }
                        end;
         end;
 {$endif i386}
@@ -845,6 +848,11 @@ unit pmodules;
               pu:=pused_unit(pu^.next);
            end;
          inc(datasize,symtablestack^.datasize);
+
+         { generate imports }
+         if current_module^.uses_imports then
+          importlib^.generatelib;
+
          { finish asmlist by adding segment starts }
          insertsegment;
       end;
@@ -967,7 +975,13 @@ unit pmodules;
          else
           current_module^.linkofiles.insert(current_module^.objfilename^);
 
+         { insert heap }
          insertheap;
+
+         { generate imports }
+         if current_module^.uses_imports then
+          importlib^.generatelib;
+
          inserttargetspecific;
 
          datasize:=symtablestack^.datasize;
@@ -979,7 +993,11 @@ unit pmodules;
 end.
 {
   $Log$
-  Revision 1.24  1998-06-08 13:13:44  pierre
+  Revision 1.25  1998-06-08 22:59:49  peter
+    * smartlinking works for win32
+    * some defines to exclude some compiler parts
+
+  Revision 1.24  1998/06/08 13:13:44  pierre
     + temporary variables now in temp_gen.pas unit
       because it is processor independent
     * mppc68k.bat modified to undefine i386 and support_mmx
@@ -1000,8 +1018,6 @@ end.
   Revision 1.20  1998/06/04 09:55:42  pierre
     * demangled name of procsym reworked to become independant of the mangling scheme
 
-  Come test_funcret improvements (not yet working)S: ----------------------------------------------------------------------
-
   Revision 1.19  1998/06/03 23:40:38  peter
     + unlimited file support, release tempclose
 

compiler/pstatmnt.pas

@@ -39,42 +39,42 @@ unit pstatmnt;
   implementation
 
     uses
-       cobjects,scanner,globals,symtable,aasm,pass_1,
-       types,hcodegen,files,verbose,systems
+       cobjects,globals,files,verbose,systems,
+       symtable,aasm,pass_1,types,scanner,hcodegen
 {$ifdef NEWPPU}
        ,ppu
 {$endif}
-       { processor specific stuff }
+       ,pbase,pexpr,pdecl
 {$ifdef i386}
-       ,i386
+       ,i386,tgeni386
+  {$ifndef NoRa386Int}
        ,rai386
+  {$endif NoRa386Int}
+  {$ifndef NoRa386Att}
        ,ratti386
+  {$endif NoRa386Att}
+  {$ifndef NoRa386Dir}
        ,radi386
-       ,tgeni386
-{$endif}
+  {$endif NoRa386Dir}
+{$endif i386}
 {$ifdef m68k}
-       ,m68k
-       ,tgen68k
-       ,ag68kmit
+       ,m68k,tgen68k
+  {$ifndef NoRa68kMot}
        ,ra68k
-       ,ag68kgas
-       ,ag68kmot
-{$endif}
-       { parser specific stuff, be careful consume is also defined to }
-       { read assembler tokens                                        }
-       ,pbase,pexpr,pdecl;
+  {$endif NoRa68kMot}
+{$endif m68k}
+       ;
 
-    const
 
+    const
       statement_level : longint = 0;
 
     function statement : ptree;forward;
 
-    function if_statement : ptree;
 
+    function if_statement : ptree;
       var
          ex,if_a,else_a : ptree;
-
       begin
          consume(_IF);
          ex:=comp_expr(true);
@@ -257,6 +257,7 @@ unit pstatmnt;
          case_statement:=code;
       end;
 
+
     function repeat_statement : ptree;
 
       var
@@ -293,6 +294,7 @@ unit pstatmnt;
          repeat_statement:=genloopnode(repeatn,p_e,first,nil,false);
       end;
 
+
     function while_statement : ptree;
 
       var
@@ -306,6 +308,7 @@ unit pstatmnt;
          while_statement:=genloopnode(whilen,p_e,p_a,nil,false);
       end;
 
+
     function for_statement : ptree;
 
       var
@@ -334,6 +337,7 @@ unit pstatmnt;
          for_statement:=genloopnode(forn,p_e,tovalue,p_a,backward);
       end;
 
+
     function _with_statement : ptree;
 
       var
@@ -434,6 +438,7 @@ unit pstatmnt;
          _with_statement:=genwithnode(withsymtable,p,right,levelcount);
       end;
 
+
     function with_statement : ptree;
 
       begin
@@ -441,6 +446,7 @@ unit pstatmnt;
          with_statement:=_with_statement;
       end;
 
+
     function raise_statement : ptree;
 
       var
@@ -467,6 +473,7 @@ unit pstatmnt;
          raise_statement:=gennode(raisen,p1,p2);
       end;
 
+
     function try_statement : ptree;
 
       var
@@ -558,6 +565,7 @@ unit pstatmnt;
            end;
       end;
 
+
     function exit_statement : ptree;
 
       var
@@ -581,11 +589,9 @@ unit pstatmnt;
       end;
 
 
-{$ifdef i386}
     function _asm_statement : ptree;
-
-      var asm_stat : ptree;
-      
+      var
+        asmstat : ptree;
       begin
          if (aktprocsym^.definition^.options and poinline)<>0 then
            Begin
@@ -594,25 +600,38 @@ unit pstatmnt;
               aktprocsym^.definition^.options:= aktprocsym^.definition^.options and not poinline;
            End;
          case aktasmmode of
-            I386_ATT : asm_stat:=ratti386.assemble;
-            I386_INTEL : asm_stat:=rai386.assemble;
-            I386_DIRECT : asm_stat:=radi386.assemble;
-            else internalerror(30004);
+{$ifdef i386}
+  {$ifndef NoRA386Att}
+            I386_ATT : asmstat:=ratti386.assemble;
+  {$endif NoRA386Att}
+  {$ifndef NoRA386Int}
+          I386_INTEL : asmstat:=rai386.assemble;
+  {$endif NoRA386Int}
+  {$ifndef NoRA386Dir}
+         I386_DIRECT : asmstat:=radi386.assemble;
+  {$endif NoRA386Dir}
+{$endif}
+{$ifdef m68k}
+  {$ifndef NoRA68kMot}
+            M68K_MOT : asmstat:=ra68k.assemble;
+  {$endif NoRA68kMot}
+{$endif}
+         else
+           Comment(V_Fatal,'Selected assembler reader not supported');
          end;
 
-         { Erst am Ende _ASM konsumieren, da der Scanner sonst die }
-         { erste Assemblerstatement zu lesen versucht! }
+         { Read first the _ASM statement }
          consume(_ASM);
 
-         { (END is read) }
+         { END is read }
          if token=LECKKLAMMER then
            begin
               { it's possible to specify the modified registers }
               consume(LECKKLAMMER);
-              asm_stat^.object_preserved:=true;
+              asmstat^.object_preserved:=true;
               if token<>RECKKLAMMER then
                 repeat
-                  pattern:=upper(pattern);
+{$ifdef i386}
                   if pattern='EAX' then
                     usedinproc:=usedinproc or ($80 shr byte(R_EAX))
                   else if pattern='EBX' then
@@ -624,41 +643,12 @@ unit pstatmnt;
                   else if pattern='ESI' then
                     begin
                        usedinproc:=usedinproc or ($80 shr byte(R_ESI));
-                       asm_stat^.object_preserved:=false;
+                       asmstat^.object_preserved:=false;
                     end
                   else if pattern='EDI' then
                     usedinproc:=usedinproc or ($80 shr byte(R_EDI))
-                  else consume(RECKKLAMMER);
-                  consume(CSTRING);
-                  if token=COMMA then consume(COMMA)
-                    else break;
-                until false;
-              consume(RECKKLAMMER);
-           end
-         else usedinproc:=$ff;
-         _asm_statement:=asm_stat;
-      end;
-{$endif}
-
+{$endif i386}
 {$ifdef m68k}
-    function _asm_statement : ptree;
-    begin
-         _asm_statement:= ra68k.assemble;
-         { Erst am Ende _ASM konsumieren, da der Scanner sonst die }
-         { erste Assemblerstatement zu lesen versucht! }
-         consume(_ASM);
-
-         { (END is read) }
-         if token=LECKKLAMMER then
-           begin
-              { it's possible to specify the modified registers }
-              { we only check the registers which are not reserved }
-              { and which can be used. This is done for future     }
-              { optimizations.                                     }
-              consume(LECKKLAMMER);
-              if token<>RECKKLAMMER then
-                repeat
-                  pattern:=upper(pattern);
                   if pattern='D0' then
                     usedinproc:=usedinproc or ($800 shr word(R_D0))
                   else if pattern='D1' then
@@ -669,6 +659,7 @@ unit pstatmnt;
                     usedinproc:=usedinproc or ($800 shr word(R_A0))
                   else if pattern='A1' then
                     usedinproc:=usedinproc or ($800 shr word(R_A1))
+{$endif m68k}
                   else consume(RECKKLAMMER);
                   consume(CSTRING);
                   if token=COMMA then consume(COMMA)
@@ -676,155 +667,153 @@ unit pstatmnt;
                 until false;
               consume(RECKKLAMMER);
            end
-         else usedinproc:=$ffff;
-    end;
-{$endif}
+         else usedinproc:=$ff;
+         _asm_statement:=asmstat;
+      end;
 
 
         function new_dispose_statement : ptree;
+        var
+          p,p2 : ptree;
+          ht : ttoken;
+          again : boolean; { dummy for do_proc_call }
+          destrukname : stringid;
+          sym : psym;
+          classh : pobjectdef;
+          pd,pd2 : pdef;
+          store_valid : boolean;
+          tt : ttreetyp;
+        begin
+          ht:=token;
+          if token=_NEW then consume(_NEW)
+            else consume(_DISPOSE);
+          if ht=_NEW then
+            tt:=hnewn
+          else
+            tt:=hdisposen;
+          consume(LKLAMMER);
+          p:=comp_expr(true);
+
+          { calc return type }
+          cleartempgen;
+          Store_valid := Must_be_valid;
+          Must_be_valid := False;
+          do_firstpass(p);
+          Must_be_valid := Store_valid;
+
+  {var o:Pobject;
+           begin
+               new(o,init);        (*Also a valid new statement*)
+           end;}
+
+          if token=COMMA then
+            begin
+                   { extended syntax of new and dispose }
+                   { function styled new is handled in factor }
+                   consume(COMMA);
+                   { destructors have no parameters }
+                   destrukname:=pattern;
+                   consume(ID);
 
-          var
-                 p,p2 : ptree;
-                 ht : ttoken;
-         again : boolean; { dummy for do_proc_call }
-                 destrukname : stringid;
-                 sym : psym;
-                 classh : pobjectdef;
-                 pd,pd2 : pdef;
-                 store_valid : boolean;
-                 tt : ttreetyp;
-
-          begin
-                 ht:=token;
-                 if token=_NEW then consume(_NEW)
-                   else consume(_DISPOSE);
-                 if ht=_NEW then
-                   tt:=hnewn
-                 else
-                   tt:=hdisposen;
-                 consume(LKLAMMER);
-                 p:=comp_expr(true);
-
-                 { calc return type }
-                 cleartempgen;
-                 Store_valid := Must_be_valid;
-                 Must_be_valid := False;
-                 do_firstpass(p);
-                 Must_be_valid := Store_valid;
-
-         {var o:Pobject;
-
-                  begin
-                      new(o,init);        (*Also a valid new statement*)
-                  end;}
+                   pd:=p^.resulttype;
+                   pd2:=pd;
+                   if (p^.resulttype = nil) or (pd^.deftype<>pointerdef) then
+                     begin
+                        Message(parser_e_pointer_type_expected);
+                        p:=factor(false);
+                        consume(RKLAMMER);
+                        new_dispose_statement:=genzeronode(errorn);
+                        exit;
+                     end;
+                   { first parameter must be an object or class }
+                   if ppointerdef(pd)^.definition^.deftype<>objectdef then
+                     begin
+                        Message(parser_e_pointer_to_class_expected);
+                        new_dispose_statement:=factor(false);
+                        consume_all_until(RKLAMMER);
+                        consume(RKLAMMER);
+                        exit;
+                     end;
+                   { check, if the first parameter is a pointer to a _class_ }
+                   classh:=pobjectdef(ppointerdef(pd)^.definition);
+                   if (classh^.options and oois_class)<>0 then
+                         begin
+                            Message(parser_e_no_new_or_dispose_for_classes);
+                            new_dispose_statement:=factor(false);
+                            { while token<>RKLAMMER do
+                                  consume(token); }
+                            consume_all_until(RKLAMMER);
+                            consume(RKLAMMER);
+                            exit;
+                         end;
+                   { search cons-/destructor, also in parent classes }
+                   sym:=nil;
+                   while assigned(classh) do
+                         begin
+                            sym:=classh^.publicsyms^.search(pattern);
+                            srsymtable:=classh^.publicsyms;
+                            if assigned(sym) then
+                                  break;
+                            classh:=classh^.childof;
+                         end;
+                   { the second parameter of new/dispose must be a call }
+                   { to a cons-/destructor                                }
+                   if (sym^.typ<>procsym) then
+                         begin
+                            Message(parser_e_expr_have_to_be_destructor_call);
+                            new_dispose_statement:=genzeronode(errorn);
+                         end
+                   else
+                         begin
+                           p2:=gensinglenode(tt,p);
+                           if ht=_NEW then
+                                 begin
+                                    { Constructors can take parameters.}
+                                    p2^.resulttype:=ppointerdef(pd)^.definition;
+                                    do_member_read(sym,p2,pd,again);
+                                 end
+                           else
+                             { destructors can't.}
+                             p2:=genmethodcallnode(pprocsym(sym),srsymtable,p2);
+
+                           { we need the real called method }
+                           cleartempgen;
+                           do_firstpass(p2);
+
+                           if (ht=_NEW) and ((p2^.procdefinition^.options and poconstructor)=0) then
+                                  Message(parser_e_expr_have_to_be_constructor_call);
+                           if (ht=_DISPOSE) and ((p2^.procdefinition^.options and podestructor)=0) then
+                                  Message(parser_e_expr_have_to_be_destructor_call);
+
+                           if ht=_NEW then
+                                 begin
+                                         p2:=gennode(assignn,getcopy(p),gensinglenode(newn,p2));
+                                         p2^.right^.resulttype:=pd2;
+                                 end;
+                           new_dispose_statement:=p2;
+                         end;
+            end
+          else
+            begin
+               if (p^.resulttype=nil) or (p^.resulttype^.deftype<>pointerdef) then
+                 Begin
+                    Message(parser_e_pointer_type_expected);
+                    new_dispose_statement:=genzeronode(errorn);
+                 end
+               else
+                 begin
+                    if (ppointerdef(p^.resulttype)^.definition^.deftype=objectdef) then
+                     Message(parser_w_use_extended_syntax_for_objects);
+
+                     case ht of
+                        _NEW : new_dispose_statement:=gensinglenode(simplenewn,p);
+                        _DISPOSE : new_dispose_statement:=gensinglenode(simpledisposen,p);
+                     end;
+                 end;
+            end;
+          consume(RKLAMMER);
+      end;
 
-                 if token=COMMA then
-                   begin
-                          { extended syntax of new and dispose }
-                          { function styled new is handled in factor }
-                          consume(COMMA);
-                          { destructors have no parameters }
-                          destrukname:=pattern;
-                          consume(ID);
-
-                          pd:=p^.resulttype;
-                          pd2:=pd;
-                          if (p^.resulttype = nil) or (pd^.deftype<>pointerdef) then
-                            begin
-                               Message(parser_e_pointer_type_expected);
-                               p:=factor(false);
-                               consume(RKLAMMER);
-                               new_dispose_statement:=genzeronode(errorn);
-                               exit;
-                            end;
-                          { first parameter must be an object or class }
-                          if ppointerdef(pd)^.definition^.deftype<>objectdef then
-                            begin
-                               Message(parser_e_pointer_to_class_expected);
-                               new_dispose_statement:=factor(false);
-                               consume_all_until(RKLAMMER);
-                               consume(RKLAMMER);
-                               exit;
-                            end;
-                          { check, if the first parameter is a pointer to a _class_ }
-                          classh:=pobjectdef(ppointerdef(pd)^.definition);
-                          if (classh^.options and oois_class)<>0 then
-                                begin
-                                   Message(parser_e_no_new_or_dispose_for_classes);
-                                   new_dispose_statement:=factor(false);
-                                   { while token<>RKLAMMER do
-                                         consume(token); }
-                                   consume_all_until(RKLAMMER);
-                                   consume(RKLAMMER);
-                                   exit;
-                                end;
-                          { search cons-/destructor, also in parent classes }
-                          sym:=nil;
-                          while assigned(classh) do
-                                begin
-                                   sym:=classh^.publicsyms^.search(pattern);
-                                   srsymtable:=classh^.publicsyms;
-                                   if assigned(sym) then
-                                         break;
-                                   classh:=classh^.childof;
-                                end;
-                          { the second parameter of new/dispose must be a call }
-                          { to a cons-/destructor                                }
-                          if (sym^.typ<>procsym) then
-                                begin
-                                   Message(parser_e_expr_have_to_be_destructor_call);
-                                   new_dispose_statement:=genzeronode(errorn);
-                                end
-                          else
-                                begin
-                                  p2:=gensinglenode(tt,p);
-                                  if ht=_NEW then
-                                        begin
-                                           { Constructors can take parameters.}
-                                           p2^.resulttype:=ppointerdef(pd)^.definition;
-                                           do_member_read(sym,p2,pd,again);
-                                        end
-                                  else
-                                    { destructors can't.}
-                                    p2:=genmethodcallnode(pprocsym(sym),srsymtable,p2);
-
-                                  { we need the real called method }
-                                  cleartempgen;
-                                  do_firstpass(p2);
-
-                                  if (ht=_NEW) and ((p2^.procdefinition^.options and poconstructor)=0) then
-                                         Message(parser_e_expr_have_to_be_constructor_call);
-                                  if (ht=_DISPOSE) and ((p2^.procdefinition^.options and podestructor)=0) then
-                                         Message(parser_e_expr_have_to_be_destructor_call);
-
-                                  if ht=_NEW then
-                                        begin
-                                                p2:=gennode(assignn,getcopy(p),gensinglenode(newn,p2));
-                                                p2^.right^.resulttype:=pd2;
-                                        end;
-                                  new_dispose_statement:=p2;
-                                end;
-                   end
-                 else
-                   begin
-                      if (p^.resulttype=nil) or (p^.resulttype^.deftype<>pointerdef) then
-                        Begin
-                           Message(parser_e_pointer_type_expected);
-                           new_dispose_statement:=genzeronode(errorn);
-                        end
-                      else
-                        begin
-                           if (ppointerdef(p^.resulttype)^.definition^.deftype=objectdef) then
-                            Message(parser_w_use_extended_syntax_for_objects);
-
-                            case ht of
-                               _NEW : new_dispose_statement:=gensinglenode(simplenewn,p);
-                               _DISPOSE : new_dispose_statement:=gensinglenode(simpledisposen,p);
-                            end;
-                        end;
-                   end;
-                 consume(RKLAMMER);
-          end;
 
     function statement_block : ptree;
 
@@ -874,6 +863,7 @@ unit pstatmnt;
          statement_block:=last;
       end;
 
+
     function statement : ptree;
 
       var
@@ -1146,15 +1136,17 @@ unit pstatmnt;
 end.
 {
   $Log$
-  Revision 1.18  1998-06-05 14:37:35  pierre
+  Revision 1.19  1998-06-08 22:59:50  peter
+    * smartlinking works for win32
+    * some defines to exclude some compiler parts
+
+  Revision 1.18  1998/06/05 14:37:35  pierre
     * fixes for inline for operators
     * inline procedure more correctly restricted
 
   Revision 1.17  1998/06/04 09:55:43  pierre
     * demangled name of procsym reworked to become independant of the mangling scheme
 
-  Come test_funcret improvements (not yet working)S: ----------------------------------------------------------------------
-
   Revision 1.16  1998/06/02 17:03:04  pierre
     *  with node corrected for objects
     * small bugs for SUPPORT_MMX fixed

compiler/ptconst.pas

@@ -156,52 +156,56 @@ unit ptconst;
               if p^.treetype=niln then
                 datasegment^.concat(new(pai_const,init_32bit(0)))
               { maybe pchar ? }
-              else if (ppointerdef(def)^.definition^.deftype=orddef) and
+              else
+                if (ppointerdef(def)^.definition^.deftype=orddef) and
                    (porddef(ppointerdef(def)^.definition)^.typ=uchar) then
-                begin
-                   getlabel(ll);
-                   { insert string at the begin }
-                   if p^.treetype=stringconstn then
-                     generate_ascii_insert((p^.values^)+#0)
-                   else if is_constcharnode(p) then
-                     datasegment^.insert(new(pai_string,init(char(byte(p^.value))+#0)))
-                   else Message(cg_e_illegal_expression);
-                   datasegment^.insert(new(pai_label,init(ll)));
-                   { insert label }
-                   datasegment^.concat(new(pai_const,init_symbol(strpnew(lab2str(ll)))));
+                  begin
+                    getlabel(ll);
+                    datasegment^.concat(new(pai_const,init_symbol(strpnew(lab2str(ll)))));
+                    datasegment^.concat(new(pai_label,init(ll)));
+                    { insert string at the begin }
+                    if p^.treetype=stringconstn then
+                      datasegment^.concat(new(pai_string,init(p^.values^+#0)))
+                    else
+                      if is_constcharnode(p) then
+                        datasegment^.concat(new(pai_string,init(char(byte(p^.value))+#0)))
+                    else
+                      Message(cg_e_illegal_expression);
+                    { insert label }
                 end
-              else if p^.treetype=addrn then
-                begin
-                   if (is_equal(ppointerdef(p^.resulttype)^.definition,ppointerdef(def)^.definition) or
-                      (is_equal(ppointerdef(p^.resulttype)^.definition,voiddef)) or
-                      (is_equal(ppointerdef(def)^.definition,voiddef))) and
-                      (p^.left^.treetype = loadn) then
-                     begin
+              else
+                if p^.treetype=addrn then
+                  begin
+                    if (is_equal(ppointerdef(p^.resulttype)^.definition,ppointerdef(def)^.definition) or
+                       (is_equal(ppointerdef(p^.resulttype)^.definition,voiddef)) or
+                       (is_equal(ppointerdef(def)^.definition,voiddef))) and
+                       (p^.left^.treetype = loadn) then
+                      begin
                         datasegment^.concat(new(pai_const,init_symbol(
                           strpnew(p^.left^.symtableentry^.mangledname))));
                         maybe_concat_external(p^.left^.symtableentry^.owner,
                           p^.left^.symtableentry^.mangledname);
-                     end
-                   else
-                     Message(cg_e_illegal_expression);
-                end
+                      end
+                    else
+                      Message(cg_e_illegal_expression);
+                  end
               else
               { allow typeof(Object type)}
                 if (p^.treetype=inlinen) and
                    (p^.inlinenumber=in_typeof_x) then
-                  if (p^.left^.treetype=typen) then
-                    begin
-                       datasegment^.concat(new(pai_const,init_symbol(
-                         strpnew(pobjectdef(p^.left^.resulttype)^.vmt_mangledname))));
-                       if pobjectdef(p^.left^.resulttype)^.owner^.symtabletype=unitsymtable then
+                  begin
+                    if (p^.left^.treetype=typen) then
+                      begin
+                        datasegment^.concat(new(pai_const,init_symbol(
+                          strpnew(pobjectdef(p^.left^.resulttype)^.vmt_mangledname))));
+                        if pobjectdef(p^.left^.resulttype)^.owner^.symtabletype=unitsymtable then
                           concat_external(pobjectdef(p^.left^.resulttype)^.vmt_mangledname,EXT_NEAR);
-                    end
-                  else
-                    begin
-                       Message(cg_e_illegal_expression);
-                    end
-                else
-                  Message(cg_e_illegal_expression);
+                      end
+                    else
+                      Message(cg_e_illegal_expression);
+                  end
+              else
+                Message(cg_e_illegal_expression);
               disposetree(p);
            end;
          setdef:
@@ -215,9 +219,8 @@ unit ptconst;
                      Message(cg_e_illegal_expression)
                    else
                      begin
-                        for l:=0 to def^.savesize-1 do
-                          datasegment^.concat(
-                        new(pai_const,init_8bit(p^.constset^[l])));
+                       for l:=0 to def^.savesize-1 do
+                         datasegment^.concat(new(pai_const,init_8bit(p^.constset^[l])));
                      end;
                 end
               else
@@ -225,15 +228,13 @@ unit ptconst;
               disposetree(p);
            end;
          enumdef:
-       begin
+           begin
               p:=comp_expr(true);
               do_firstpass(p);
               if p^.treetype=ordconstn then
                 begin
                    if is_equal(p^.resulttype,def) then
-                     begin
-                        datasegment^.concat(new(pai_const,init_32bit(p^.value)));
-                     end
+                     datasegment^.concat(new(pai_const,init_32bit(p^.value)))
                    else
                      Message(cg_e_illegal_expression);
                 end
@@ -450,7 +451,11 @@ unit ptconst;
 end.
 {
   $Log$
-  Revision 1.5  1998-06-03 22:49:01  peter
+  Revision 1.6  1998-06-08 22:59:52  peter
+    * smartlinking works for win32
+    * some defines to exclude some compiler parts
+
+  Revision 1.5  1998/06/03 22:49:01  peter
     + wordbool,longbool
     * rename bis,von -> high,low
     * moved some systemunit loading/creating to psystem.pas
@@ -467,77 +472,4 @@ end.
     + started inline procedures
     + added starstarn : use ** for exponentiation (^ gave problems)
     + started UseTokenInfo cond to get accurate positions
-
-  Revision 1.2  1998/04/07 13:19:48  pierre
-    * bugfixes for reset_gdb_info
-      in MEM parsing for go32v2
-      better external symbol creation
-      support for rhgdb.exe (lowercase file names)
-
-  Revision 1.1.1.1  1998/03/25 11:18:15  root
-  * Restored version
-
-  Revision 1.13  1998/03/20 23:31:35  florian
-    * bug0113 fixed
-    * problem with interdepened units fixed ("options.pas problem")
-    * two small extensions for future AMD 3D support
-
-  Revision 1.12  1998/03/18 22:50:11  florian
-    + fstp/fld optimization
-    * routines which contains asm aren't longer optimzed
-    * wrong ifdef TEST_FUNCRET corrected
-    * wrong data generation for array[0..n] of char = '01234'; fixed
-    * bug0097 is fixed partial
-    * bug0116 fixed (-Og doesn't use enter of the stack frame is greater than
-      65535)
-
-  Revision 1.11  1998/03/13 22:45:59  florian
-    * small bug fixes applied
-
-  Revision 1.10  1998/03/11 11:23:57  florian
-    * bug0081 and bug0109 fixed
-
-  Revision 1.9  1998/03/10 01:17:25  peter
-    * all files have the same header
-    * messages are fully implemented, EXTDEBUG uses Comment()
-    + AG... files for the Assembler generation
-
-  Revision 1.8  1998/03/06 00:52:50  peter
-    * replaced all old messages from errore.msg, only ExtDebug and some
-      Comment() calls are left
-    * fixed options.pas
-
-  Revision 1.7  1998/03/02 01:49:10  peter
-    * renamed target_DOS to target_GO32V1
-    + new verbose system, merged old errors and verbose units into one new
-      verbose.pas, so errors.pas is obsolete
-
-  Revision 1.6  1998/02/13 10:35:33  daniel
-  * Made Motorola version compilable.
-  * Fixed optimizer
-
-  Revision 1.5  1998/02/12 11:50:32  daniel
-  Yes! Finally! After three retries, my patch!
-
-  Changes:
-
-  Complete rewrite of psub.pas.
-  Added support for DLL's.
-  Compiler requires less memory.
-  Platform units for each platform.
-
-  Revision 1.4  1998/01/24 23:08:19  carl
-    + compile time range checking should logically always be on!
-
-  Revision 1.3  1998/01/23 17:12:20  pierre
-    * added some improvements for as and ld :
-      - doserror and dosexitcode treated separately
-      - PATH searched if doserror=2
-    + start of long and ansi string (far from complete)
-      in conditionnal UseLongString and UseAnsiString
-    * options.pas cleaned (some variables shifted to globals)gl
-
-  Revision 1.2  1998/01/09 09:10:03  michael
-  + Initial implementation, second try
-
 }

compiler/symsym.inc

@@ -1269,10 +1269,10 @@
 
       procedure ttypedconstsym.really_insert_in_data;
         begin
-           if (cs_smartlink in aktswitches) then
-             datasegment^.concat(new(pai_cut,init));
            if owner^.symtabletype=globalsymtable then
              begin
+                if (cs_smartlink in aktswitches) then
+                  datasegment^.concat(new(pai_cut,init));
 {$ifdef GDB}
                 if cs_debuginfo in aktswitches then
                   concatstabto(datasegment);
@@ -1282,6 +1282,8 @@
            else
              if owner^.symtabletype<>unitsymtable then
                begin
+                 if (cs_smartlink in aktswitches) then
+                   datasegment^.concat(new(pai_cut,init));
 {$ifdef GDB}
                  if cs_debuginfo in aktswitches then
                    concatstabto(datasegment);
@@ -1692,7 +1694,11 @@
 
 {
   $Log$
-  Revision 1.5  1998-06-04 23:52:02  peter
+  Revision 1.6  1998-06-08 22:59:53  peter
+    * smartlinking works for win32
+    * some defines to exclude some compiler parts
+
+  Revision 1.5  1998/06/04 23:52:02  peter
     * m68k compiles
     + .def file creation moved to gendef.pas so it could also be used
       for win32
@@ -1700,8 +1706,6 @@
   Revision 1.4  1998/06/04 09:55:46  pierre
     * demangled name of procsym reworked to become independant of the mangling scheme
 
-  Come test_funcret improvements (not yet working)S: ----------------------------------------------------------------------
-
   Revision 1.3  1998/06/03 22:14:20  florian
     * problem with sizes of classes fixed (if the anchestor was declared
       forward, the compiler doesn't update the child classes size)

compiler/systems.pas

@@ -76,6 +76,15 @@ unit systems;
        {$endif}
        );
 
+       tar = (
+       {$ifdef i386}
+              ar_ar,ar_arw
+       {$endif}
+       {$ifdef m68k}
+              ar_ar
+       {$endif}
+       );
+
 
        tos = (
        {$ifdef i386}
@@ -127,6 +136,11 @@ unit systems;
           libprefix     : string[2];
        end;
 
+       tarinfo = record
+          arbin   : string[8];
+          arcmd   : string[50];
+       end;
+
        ttargetinfo = record
           target      : ttarget;
           short_name  : string[8];
@@ -141,6 +155,7 @@ unit systems;
           os          : tos;
           link        : tlink;
           assem       : tasm;
+          ar          : tar;
        end;
 
        tasmmodeinfo=record
@@ -153,6 +168,7 @@ unit systems;
        target_os   : tosinfo;
        target_asm  : tasminfo;
        target_link : tlinkinfo;
+       target_ar   : tarinfo;
        source_os   : tosinfo;
 
     function set_string_target(const s : string) : boolean;
@@ -168,7 +184,6 @@ implementation
 ****************************************************************************}
        os_infos : array[tos] of tosinfo = (
 {$ifdef i386}
-
           (
             name         : 'GO32 V1 DOS extender';
             sharedlibext : '.DLL';
@@ -234,8 +249,7 @@ implementation
             endian       : endian_little;
             use_function_relative_addresses : true
           )
-{$endif i386}   
-
+{$endif i386}
 {$ifdef m68k}
           (
             name         : 'Commodore Amiga';
@@ -291,7 +305,7 @@ implementation
           )
 {$endif m68k}
           );
-        
+
 
 {****************************************************************************
                              Assembler Info
@@ -493,8 +507,29 @@ implementation
             inputend   : ')';
             libprefix  : '-l'
           )
-{$endif m68k}   
+{$endif m68k}
+          );
 
+{****************************************************************************
+                                 Ar Info
+****************************************************************************}
+       ar_infos : array[tar] of tarinfo = (
+{$ifdef i386}
+          (
+            arbin : 'ar';
+            arcmd : 'rs $LIB $FILES'
+          ),
+          (
+            arbin : 'arw';
+            arcmd : 'rs $LIB $FILES'
+          )
+{$endif i386}
+{$ifdef m68k}
+          (
+            arbin : 'ar';
+            arcmd : 'rs $LIB $FILES'
+          )
+{$endif m68k}
           );
 
 {****************************************************************************
@@ -502,7 +537,6 @@ implementation
 ****************************************************************************}
        target_infos : array[ttarget] of ttargetinfo = (
 {$ifdef i386}
-
           (
             target      : target_GO32V1;
             short_name  : 'GO32V1';
@@ -516,7 +550,8 @@ implementation
             exeext      : ''; { The linker procedures a.out }
             os          : os_GO32V1;
             link        : link_ldgo32v1;
-            assem       : as_o
+            assem       : as_o;
+            ar          : ar_ar
           ),
           (
             target      : target_GO32V2;
@@ -540,7 +575,8 @@ implementation
       {$endif UseAnsiString}
             os          : os_GO32V2;
             link        : link_ldgo32v2;
-            assem       : as_o
+            assem       : as_o;
+            ar          : ar_ar
           ),
           (
             target      : target_LINUX;
@@ -555,7 +591,8 @@ implementation
             exeext      : '';
             os          : os_Linux;
             link        : link_ld;
-            assem       : as_o
+            assem       : as_o;
+            ar          : ar_ar
           ),
           (
             target      : target_OS2;
@@ -570,7 +607,8 @@ implementation
             exeext      : ''; { The linker procedures a.out }
             os          : os_OS2;
             link        : link_ldos2;
-            assem       : as_o
+            assem       : as_o;
+            ar          : ar_ar
           ),
           (
             target      : target_WIN32;
@@ -585,10 +623,10 @@ implementation
             exeext      : '.exe';
             os          : os_Win32;
             link        : link_ldw;
-            assem       : as_asw
+            assem       : as_asw;
+            ar          : ar_arw
           )
 {$endif i386}
-
 {$ifdef m68k}
           (
             target      : target_Amiga;
@@ -603,7 +641,8 @@ implementation
             exeext      : '';
             os          : os_Amiga;
             link        : link_ld;
-            assem       : as_o
+            assem       : as_o;
+            ar          : ar_ar
           ),
           (
             target      : target_Atari;
@@ -618,7 +657,8 @@ implementation
             exeext      : '';
             os          : os_Atari;
             link        : link_ld;
-            assem       : as_o
+            assem       : as_o;
+            ar          : ar_ar
           ),
           (
             target      : target_Mac68k;
@@ -633,7 +673,8 @@ implementation
             exeext      : '';
             os          : os_Mac68k;
             link        : link_ld;
-            assem       : as_o
+            assem       : as_o;
+            ar          : ar_ar
           ),
           (
             target      : target_Linux;
@@ -648,7 +689,8 @@ implementation
             exeext      : '';
             os          : os_Linux;
             link        : link_ld;
-            assem       : as_o
+            assem       : as_o;
+            ar          : ar_ar
           )
 {$endif m68k}
           );
@@ -689,6 +731,7 @@ begin
   target_os:=os_infos[target_info.os];
   target_asm:=as_infos[target_info.assem];
   target_link:=link_infos[target_info.link];
+  target_ar:=ar_infos[target_info.ar];
 end;
 
 
@@ -757,19 +800,15 @@ begin
     {$ifdef GO32V2}
       default_os(target_GO32V2);
     {$else}
-
       {$ifdef OS2}
         default_os(target_OS2);
       {$else}
-
         {$ifdef LINUX}
           default_os(target_LINUX);
         {$else}
-
            {$ifdef WIN32}
              default_os(target_WIN32);
            {$else}
-
               default_os(target_GO32V2);
            {$endif win32}
         {$endif linux}
@@ -781,14 +820,12 @@ begin
   {$ifdef AMIGA}
     default_os(target_Amiga);
   {$else}
-
     {$ifdef ATARI}
       default_os(target_Atari);
     {$else}
       {$ifdef MACOS}
         default_os(target_MAC68k);
       {$else}
-
         default_os(target_Amiga);
       {$endif macos}
     {$endif atari}
@@ -797,7 +834,11 @@ begin
 end.
 {
   $Log$
-  Revision 1.17  1998-06-04 23:52:04  peter
+  Revision 1.18  1998-06-08 22:59:54  peter
+    * smartlinking works for win32
+    * some defines to exclude some compiler parts
+
+  Revision 1.17  1998/06/04 23:52:04  peter
     * m68k compiles
     + .def file creation moved to gendef.pas so it could also be used
       for win32

compiler/win_targ.pas

@@ -39,6 +39,9 @@ unit win_targ;
 
     uses
        aasm,files,strings,globals,cobjects
+{$ifdef GDB}
+       ,gdb
+{$endif}
 {$ifdef i386}
        ,i386
 {$endif}
@@ -83,42 +86,48 @@ unit win_targ;
          hp2 : pimported_procedure;
          l1,l2,l3,l4 : plabel;
          r : preference;
-
       begin
          hp1:=pimportlist(current_module^.imports^.first);
          while assigned(hp1) do
            begin
+              { Insert cuts for smartlinking }
+              if (cs_smartlink in aktswitches) then
+                begin
+                  importssection^.concat(new(pai_cut,init));
+                  codesegment^.concat(new(pai_cut,init));
+                end;
+{$IfDef GDB}
+              if (cs_debuginfo in aktswitches) then
+                codesegment^.concat(new(pai_stab_function_name,init(nil)));
+{$EndIf GDB}
+
+              { Get labels for the sections }
               getlabel(l1);
               getlabel(l2);
               getlabel(l3);
-              { create import directory entry }
               importssection^.concat(new(pai_section,init_idata(2)));
               { pointer to procedure names }
-              importssection^.concat(new(pai_const,init_rva(strpnew(lab2str
-                (l2)))));
+              importssection^.concat(new(pai_const,init_rva(strpnew(lab2str(l2)))));
               { two empty entries follow }
               importssection^.concat(new(pai_const,init_32bit(0)));
               importssection^.concat(new(pai_const,init_32bit(0)));
               { pointer to dll name }
-              importssection^.concat(new(pai_const,init_rva(strpnew(lab2str
-                (l1)))));
+              importssection^.concat(new(pai_const,init_rva(strpnew(lab2str(l1)))));
               { pointer to fixups }
-              importssection^.concat(new(pai_const,init_rva(strpnew(lab2str
-                (l3)))));
+              importssection^.concat(new(pai_const,init_rva(strpnew(lab2str(l3)))));
 
-              { now walk through all imported procedures }
-              { we could that do in one while loop, but  }
-              { this would give too much idata* entries  }
+              { only create one section for each else it will
+                create a lot of idata* }
 
               { first write the name references }
               importssection^.concat(new(pai_section,init_idata(4)));
               importssection^.concat(new(pai_label,init(l2)));
+
               hp2:=pimported_procedure(hp1^.imported_procedures^.first);
               while assigned(hp2) do
                 begin
                    getlabel(plabel(hp2^.lab));
-                   importssection^.concat(new(pai_const,init_rva(strpnew(lab2str
-                     (hp2^.lab)))));
+                   importssection^.concat(new(pai_const,init_rva(strpnew(lab2str(hp2^.lab)))));
                    hp2:=pimported_procedure(hp2^.next);
                 end;
               { finalize the names ... }
@@ -130,20 +139,18 @@ unit win_targ;
               hp2:=pimported_procedure(hp1^.imported_procedures^.first);
               while assigned(hp2) do
                 begin
-                   getlabel(l4);
-                   { text segment should be aligned }
-                   codesegment^.concat(new(pai_align,init_op(4,$90)));
-                   codesegment^.concat(new(pai_symbol,init_global(hp2^.func^)));
-                   { the indirect jump }
+                   getdatalabel(l4);
+                   { create indirect jump }
                    new(r);
                    reset_reference(r^);
                    r^.symbol:=stringdup(lab2str(l4));
-{$ifdef i386}
+                   { place jump in codesegment }
+                   codesegment^.concat(new(pai_align,init_op(4,$90)));
+                   codesegment^.concat(new(pai_symbol,init_global(hp2^.func^)));
                    codesegment^.concat(new(pai386,op_ref(A_JMP,S_NO,r)));
-{$endif}
+                   { add jump field to importsection }
                    importssection^.concat(new(pai_label,init(l4)));
-                   importssection^.concat(new(pai_const,init_rva(strpnew(lab2str
-                      (hp2^.lab)))));
+                   importssection^.concat(new(pai_const,init_rva(strpnew(lab2str(hp2^.lab)))));
                    hp2:=pimported_procedure(hp2^.next);
                 end;
               { finalize the addresses }
@@ -172,7 +179,11 @@ unit win_targ;
 end.
 {
   $Log$
-  Revision 1.3  1998-06-04 23:52:06  peter
+  Revision 1.4  1998-06-08 22:59:56  peter
+    * smartlinking works for win32
+    * some defines to exclude some compiler parts
+
+  Revision 1.3  1998/06/04 23:52:06  peter
     * m68k compiles
     + .def file creation moved to gendef.pas so it could also be used
       for win32