From f98459e1fbd007a8c815da9f90550a76df2cf689 Mon Sep 17 00:00:00 2001 From: peter Date: Mon, 8 Jun 1998 22:59:41 +0000 Subject: [PATCH] * smartlinking works for win32 * some defines to exclude some compiler parts --- compiler/aasm.pas | 48 +- compiler/assemble.pas | 46 +- compiler/cgi3862.pas | 63 -- compiler/cgi386ad.inc | 1323 ----------------------------------------- compiler/link.pas | 16 +- compiler/parser.pas | 11 +- compiler/pmodules.pas | 60 +- compiler/pstatmnt.pas | 396 ++++++------ compiler/ptconst.pas | 164 ++--- compiler/symsym.inc | 14 +- compiler/systems.pas | 87 ++- compiler/win_targ.pas | 57 +- 12 files changed, 483 insertions(+), 1802 deletions(-) delete mode 100644 compiler/cgi3862.pas delete mode 100644 compiler/cgi386ad.inc diff --git a/compiler/aasm.pas b/compiler/aasm.pas index 25cb105194..7b3c964ec8 100644 --- a/compiler/aasm.pas +++ b/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 diff --git a/compiler/assemble.pas b/compiler/assemble.pas index 6ebe53a297..dac49b1aa7 100644 --- a/compiler/assemble.pas +++ b/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 diff --git a/compiler/cgi3862.pas b/compiler/cgi3862.pas deleted file mode 100644 index b434c1f292..0000000000 --- a/compiler/cgi3862.pas +++ /dev/null @@ -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 - -} diff --git a/compiler/cgi386ad.inc b/compiler/cgi386ad.inc deleted file mode 100644 index 4fa24dfdc5..0000000000 --- a/compiler/cgi386ad.inc +++ /dev/null @@ -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) -} diff --git a/compiler/link.pas b/compiler/link.pas index df053a856d..93fb1180df 100644 --- a/compiler/link.pas +++ b/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 diff --git a/compiler/parser.pas b/compiler/parser.pas index 484bbfba6e..1b498eeaf1 100644 --- a/compiler/parser.pas +++ b/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 diff --git a/compiler/pmodules.pas b/compiler/pmodules.pas index 627a6b8584..04fc0b9e5f 100644 --- a/compiler/pmodules.pas +++ b/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 diff --git a/compiler/pstatmnt.pas b/compiler/pstatmnt.pas index 4380f76782..e61a6759ae 100644 --- a/compiler/pstatmnt.pas +++ b/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 - 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); - 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; + { calc return type } + cleartempgen; + Store_valid := Must_be_valid; + Must_be_valid := False; + do_firstpass(p); + Must_be_valid := Store_valid; - 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); + {var o:Pobject; + begin + new(o,init); (*Also a valid new statement*) + end;} - { calc return type } - cleartempgen; - Store_valid := Must_be_valid; - Must_be_valid := False; - do_firstpass(p); - Must_be_valid := Store_valid; + 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 o:Pobject; + 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); - begin - new(o,init); (*Also a valid new statement*) - end;} + { we need the real called method } + cleartempgen; + do_firstpass(p2); - 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); + 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); - 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); + 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); - { we need the real called method } - cleartempgen; - do_firstpass(p2); + case ht of + _NEW : new_dispose_statement:=gensinglenode(simplenewn,p); + _DISPOSE : new_dispose_statement:=gensinglenode(simpledisposen,p); + end; + end; + end; + consume(RKLAMMER); + end; - 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 diff --git a/compiler/ptconst.pas b/compiler/ptconst.pas index 7b9c52cb2a..2db453e82c 100644 --- a/compiler/ptconst.pas +++ b/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 - } diff --git a/compiler/symsym.inc b/compiler/symsym.inc index ca96f0c579..8841f787b7 100644 --- a/compiler/symsym.inc +++ b/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) diff --git a/compiler/systems.pas b/compiler/systems.pas index eee9273e18..b3704d7392 100644 --- a/compiler/systems.pas +++ b/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 diff --git a/compiler/win_targ.pas b/compiler/win_targ.pas index 7e3314c3bd..d0efb74d11 100644 --- a/compiler/win_targ.pas +++ b/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