From 6b33f4d87d323bd9c655d32f4623db5f8e83be3e Mon Sep 17 00:00:00 2001 From: florian Date: Sun, 23 May 1999 18:41:55 +0000 Subject: [PATCH] * better error recovering in typed constants * some problems with arrays of const fixed, some problems due my previous - the location type of array constructor is now LOC_MEM - the pushing of high fixed - parameter copying fixed - zero temp. allocation removed * small problem in the assembler writers fixed: ref to nil wasn't written correctly --- compiler/ag386int.pas | 1951 ++++++++++++----------- compiler/ag386nsm.pas | 1829 ++++++++++----------- compiler/cg386cal.pas | 3091 ++++++++++++++++++------------------ compiler/cg386inl.pas | 3087 +++++++++++++++++------------------ compiler/cg386ld.pas | 2194 ++++++++++++------------- compiler/cg386mem.pas | 2038 ++++++++++++------------ compiler/msgtxt.inc | 2 +- compiler/ptconst.pas | 21 +- compiler/symdef.inc | 19 +- compiler/symdefh.inc | 14 +- compiler/symtable.pas | 15 +- compiler/tcadd.pas | 17 +- compiler/tccal.pas | 16 +- compiler/tcinl.pas | 16 +- compiler/tcld.pas | 15 +- compiler/types.pas | 16 +- compiler/utils/nasmconv.pp | 16 +- 17 files changed, 7284 insertions(+), 7073 deletions(-) diff --git a/compiler/ag386int.pas b/compiler/ag386int.pas index d8fb897d89..8548a5f1b5 100644 --- a/compiler/ag386int.pas +++ b/compiler/ag386int.pas @@ -1,969 +1,986 @@ -{ - $Id$ - Copyright (c) 1996,97 by Florian Klaempfl - - This unit implements an asmoutput class for Intel syntax with Intel i386+ - - 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} - {$N+,E+} -{$endif} -unit ag386int; - - interface - - uses aasm,assemble; - - type - pi386intasmlist=^ti386intasmlist; - ti386intasmlist = object(tasmlist) - procedure WriteTree(p:paasmoutput);virtual; - procedure WriteAsmList;virtual; - end; - - implementation - - uses - dos,strings, - globtype,globals,systems,cobjects, - files,verbose -{$ifndef OLDASM} - ,i386base,i386asm -{$else} - ,i386 -{$endif} -{$ifdef GDB} - ,gdb -{$endif GDB} - ; - - const - line_length = 70; - -{$ifndef NEWLAB} - extstr : array[EXT_NEAR..EXT_ABS] of String[8] = - ('NEAR','FAR','PROC','BYTE','WORD','DWORD', - 'CODEPTR','DATAPTR','FWORD','PWORD','QWORD','TBYTE','ABS'); -{$endif} - - function single2str(d : single) : string; - var - hs : string; - p : byte; - begin - str(d,hs); - { nasm expects a lowercase e } - p:=pos('E',hs); - if p>0 then - hs[p]:='e'; - p:=pos('+',hs); - if p>0 then - delete(hs,p,1); - single2str:=lower(hs); - end; - - function double2str(d : double) : string; - var - hs : string; - p : byte; - begin - str(d,hs); - { nasm expects a lowercase e } - p:=pos('E',hs); - if p>0 then - hs[p]:='e'; - p:=pos('+',hs); - if p>0 then - delete(hs,p,1); - double2str:=lower(hs); - end; - - function extended2str(e : extended) : string; - var - hs : string; - p : byte; - begin - str(e,hs); - { nasm expects a lowercase e } - p:=pos('E',hs); - if p>0 then - hs[p]:='e'; - p:=pos('+',hs); - if p>0 then - delete(hs,p,1); - extended2str:=lower(hs); - end; - - - function comp2str(d : bestreal) : string; - type - pdouble = ^double; - var - c : comp; - dd : pdouble; - begin -{$ifdef FPC} - c:=comp(d); -{$else} - c:=d; -{$endif} - dd:=pdouble(@c); { this makes a bitwise copy of c into a double } - comp2str:=double2str(dd^); - end; - - function getreferencestring(const ref : treference) : string; - var - s : string; - first : boolean; - begin - if ref.is_immediate then - begin - getreferencestring:=tostr(ref.offset); - exit; - end - else - with ref do - begin - first:=true; - if ref.segment<>R_NO then - s:=int_reg2str[segment]+':[' - else - s:='['; - if assigned(symbol) then - begin - s:=s+symbol^.name; - first:=false; - end; - if (base<>R_NO) then - begin - if not(first) then - s:=s+'+' - else - first:=false; - s:=s+int_reg2str[base]; - end; - if (index<>R_NO) then - begin - if not(first) then - s:=s+'+' - else - first:=false; - s:=s+int_reg2str[index]; - if scalefactor<>0 then - s:=s+'*'+tostr(scalefactor); - end; - if offset<0 then - s:=s+tostr(offset) - else if (offset>0) then - s:=s+'+'+tostr(offset); - s:=s+']'; - end; - getreferencestring:=s; - end; - -{$ifndef OLDASM} - - function getopstr(const o:toper;s : topsize; opcode: tasmop;dest : boolean) : string; - var - hs : string; - begin - case o.typ of - top_reg : - getopstr:=int_reg2str[o.reg]; - top_const : - getopstr:=tostr(o.val); - top_symbol : - begin - hs:='offset '+o.sym^.name; - if o.symofs>0 then - hs:=hs+'+'+tostr(o.symofs) - else - if o.symofs<0 then - hs:=hs+tostr(o.symofs); - getopstr:=hs; - end; - top_ref : - begin - hs:=getreferencestring(o.ref^); - if ((opcode <> A_LGS) and (opcode <> A_LSS) and - (opcode <> A_LFS) and (opcode <> A_LDS) and - (opcode <> A_LES)) then - Begin - case s of - S_B : hs:='byte ptr '+hs; - S_W : hs:='word ptr '+hs; - S_L : hs:='dword ptr '+hs; - S_IS : hs:='word ptr '+hs; - S_IL : hs:='dword ptr '+hs; - S_IQ : hs:='qword ptr '+hs; - S_FS : hs:='dword ptr '+hs; - S_FL : hs:='qword ptr '+hs; - S_FX : hs:='tbyte ptr '+hs; - S_BW : if dest then - hs:='word ptr '+hs - else - hs:='byte ptr '+hs; - S_BL : if dest then - hs:='dword ptr '+hs - else - hs:='byte ptr '+hs; - S_WL : if dest then - hs:='dword ptr '+hs - else - hs:='word ptr '+hs; - end; - end; - getopstr:=hs; - end; - else - internalerror(10001); - end; - end; - - function getopstr_jmp(const o:toper) : string; - var - hs : string; - begin - case o.typ of - top_reg : - getopstr_jmp:=int_reg2str[o.reg]; - top_const : - getopstr_jmp:=tostr(o.val); - top_symbol : - begin - hs:=o.sym^.name; - if o.symofs>0 then - hs:=hs+'+'+tostr(o.symofs) - else - if o.symofs<0 then - hs:=hs+tostr(o.symofs); - getopstr_jmp:=hs; - end; - top_ref : - getopstr_jmp:=getreferencestring(o.ref^); - else - internalerror(10001); - end; - end; - -{$else} - - function getopstr(t : byte;o : pointer;opofs:longint;s : topsize; _operator: tasmop;dest : boolean) : string; - var - hs : string; - begin - case t of - top_reg : getopstr:=int_reg2str[tregister(o)]; - top_const, - top_ref : begin - if t=top_const then - hs := tostr(longint(o)) - else - hs:=getreferencestring(preference(o)^); - { can possibly give a range check error under tp } - { if using in... } - if ((_operator <> A_LGS) and (_operator <> A_LSS) and - (_operator <> A_LFS) and (_operator <> A_LDS) and - (_operator <> A_LES)) then - Begin - case s of - S_B : hs:='byte ptr '+hs; - S_W : hs:='word ptr '+hs; - S_L : hs:='dword ptr '+hs; - S_IS : hs:='word ptr '+hs; - S_IL : hs:='dword ptr '+hs; - S_IQ : hs:='qword ptr '+hs; - S_FS : hs:='dword ptr '+hs; - S_FL : hs:='qword ptr '+hs; - S_FX : hs:='tbyte ptr '+hs; - S_BW : if dest then - hs:='word ptr '+hs - else - hs:='byte ptr '+hs; - S_BL : if dest then - hs:='dword ptr '+hs - else - hs:='byte ptr '+hs; - S_WL : if dest then - hs:='dword ptr '+hs - else - hs:='word ptr '+hs; - end; - end; - getopstr:=hs; - end; - top_symbol : begin - hs:='offset '+pasmsymbol(o)^.name; - if opofs>0 then - hs:=hs+'+'+tostr(opofs) - else - if opofs<0 then - hs:=hs+tostr(opofs); - getopstr:=hs; - end; - else - internalerror(10001); - end; - end; - - function getopstr_jmp(t : byte;o : pointer;opofs:longint) : string; - var - hs : string; - begin - case t of - top_reg : getopstr_jmp:=int_reg2str[tregister(o)]; - top_ref : getopstr_jmp:=getreferencestring(preference(o)^); - top_const : getopstr_jmp:=tostr(longint(o)); - top_symbol : begin - hs:=pasmsymbol(o)^.name; - if opofs>0 then - hs:=hs+'+'+tostr(opofs) - else - if opofs<0 then - hs:=hs+tostr(opofs); - getopstr_jmp:=hs; - end; - else - internalerror(10001); - end; - end; -{$endif} - - -{**************************************************************************** - TI386INTASMLIST - ****************************************************************************} - - var - LastSec : tsection; - - const - ait_const2str:array[ait_const_32bit..ait_const_8bit] of string[8]= - (#9'DD'#9,#9'DW'#9,#9'DB'#9); - - Function PadTabs(const p:string;addch:char):string; - var - s : string; - i : longint; - begin - i:=length(p); - if addch<>#0 then - begin - inc(i); - s:=p+addch; - end - else - s:=p; - if i<8 then - PadTabs:=s+#9#9 - else - PadTabs:=s+#9; - end; - - procedure ti386intasmlist.WriteTree(p:paasmoutput); - type - twowords=record - word1,word2:word; - end; - var - s, - prefix, - suffix : string; - hp : pai; - counter, - lines, - i,j,l : longint; - consttyp : tait; - found, - quoted : boolean; -{$ifndef OLDASM} - sep : char; -{$endif} - begin - if not assigned(p) then - exit; - hp:=pai(p^.first); - while assigned(hp) do - begin - case hp^.typ of - ait_comment : Begin - AsmWrite(target_asm.comment); - AsmWritePChar(pai_asm_comment(hp)^.str); - AsmLn; - End; - ait_regalloc, - ait_tempalloc : ; - ait_section : begin - if LastSec<>sec_none then - AsmWriteLn('_'+target_asm.secnames[LastSec]+#9#9'ENDS'); - if pai_section(hp)^.sec<>sec_none then - begin - AsmLn; - AsmWriteLn('_'+target_asm.secnames[pai_section(hp)^.sec]+#9#9+ - 'SEGMENT'#9'PARA PUBLIC USE32 '''+ - target_asm.secnames[pai_section(hp)^.sec]+''''); - end; - LastSec:=pai_section(hp)^.sec; - end; - ait_align : begin - { CAUSES PROBLEMS WITH THE SEGMENT DEFINITION } - { SEGMENT DEFINITION SHOULD MATCH TYPE OF ALIGN } - { HERE UNDER TASM! } - AsmWriteLn(#9'ALIGN '+tostr(pai_align(hp)^.aligntype)); - end; -{$ifndef NEWLAB} - ait_external : AsmWriteLn(#9'EXTRN'#9+pai_external(hp)^.sym^.name+ - ' :'+extstr[pai_external(hp)^.exttyp]); -{$endif} - ait_datablock : begin - if pai_datablock(hp)^.is_global then - AsmWriteLn(#9'PUBLIC'#9+pai_datablock(hp)^.sym^.name); - AsmWriteLn(PadTabs(pai_datablock(hp)^.sym^.name,#0)+'DB'#9+tostr(pai_datablock(hp)^.size)+' DUP(?)'); - end; - ait_const_32bit, - ait_const_8bit, - ait_const_16bit : begin - AsmWrite(ait_const2str[hp^.typ]+tostr(pai_const(hp)^.value)); - consttyp:=hp^.typ; - l:=0; - repeat - found:=(not (Pai(hp^.next)=nil)) and (Pai(hp^.next)^.typ=consttyp); - if found then - begin - hp:=Pai(hp^.next); - s:=','+tostr(pai_const(hp)^.value); - AsmWrite(s); - inc(l,length(s)); - end; - until (not found) or (l>line_length); - AsmLn; - end; - ait_const_symbol : begin - AsmWriteLn(#9#9'DD'#9'offset '+pai_const_symbol(hp)^.sym^.name); - if pai_const_symbol(hp)^.offset>0 then - AsmWrite('+'+tostr(pai_const_symbol(hp)^.offset)) - else if pai_const_symbol(hp)^.offset<0 then - AsmWrite(tostr(pai_const_symbol(hp)^.offset)); - AsmLn; - end; - ait_const_rva : begin - AsmWriteLn(#9#9'RVA'#9+pai_const_symbol(hp)^.sym^.name); - end; - ait_real_32bit : AsmWriteLn(#9#9'DD'#9+single2str(pai_real_32bit(hp)^.value)); - ait_real_64bit : AsmWriteLn(#9#9'DQ'#9+double2str(pai_real_64bit(hp)^.value)); - ait_real_80bit : AsmWriteLn(#9#9'DT'#9+extended2str(pai_real_80bit(hp)^.value)); - ait_comp_64bit : AsmWriteLn(#9#9'DQ'#9+comp2str(pai_real_80bit(hp)^.value)); - ait_string : begin - counter := 0; - lines := pai_string(hp)^.len div line_length; - { separate lines in different parts } - if pai_string(hp)^.len > 0 then - Begin - for j := 0 to lines-1 do - begin - AsmWrite(#9#9'DB'#9); - quoted:=false; - for i:=counter to counter+line_length do - begin - { it is an ascii character. } - if (ord(pai_string(hp)^.str[i])>31) and - (ord(pai_string(hp)^.str[i])<128) and - (pai_string(hp)^.str[i]<>'"') then - begin - if not(quoted) then - begin - if i>counter then - AsmWrite(','); - AsmWrite('"'); - end; - AsmWrite(pai_string(hp)^.str[i]); - quoted:=true; - end { if > 31 and < 128 and ord('"') } - else - begin - if quoted then - AsmWrite('"'); - if i>counter then - AsmWrite(','); - quoted:=false; - AsmWrite(tostr(ord(pai_string(hp)^.str[i]))); - end; - end; { end for i:=0 to... } - if quoted then AsmWrite('"'); - AsmWrite(target_os.newline); - counter := counter+line_length; - end; { end for j:=0 ... } - { do last line of lines } - AsmWrite(#9#9'DB'#9); - quoted:=false; - for i:=counter to pai_string(hp)^.len-1 do - begin - { it is an ascii character. } - if (ord(pai_string(hp)^.str[i])>31) and - (ord(pai_string(hp)^.str[i])<128) and - (pai_string(hp)^.str[i]<>'"') then - begin - if not(quoted) then - begin - if i>counter then - AsmWrite(','); - AsmWrite('"'); - end; - AsmWrite(pai_string(hp)^.str[i]); - quoted:=true; - end { if > 31 and < 128 and " } - else - begin - if quoted then - AsmWrite('"'); - if i>counter then - AsmWrite(','); - quoted:=false; - AsmWrite(tostr(ord(pai_string(hp)^.str[i]))); - end; - end; { end for i:=0 to... } - if quoted then - AsmWrite('"'); - end; - AsmLn; - end; -{$ifndef NEWLAB} - ait_label : begin - if pai_label(hp)^.l^.is_used then - begin - AsmWrite(lab2str(pai_label(hp)^.l)); - if assigned(hp^.next) and not(pai(hp^.next)^.typ in - [ait_const_32bit,ait_const_16bit,ait_const_8bit, - ait_const_symbol,ait_const_rva, - ait_real_32bit,ait_real_64bit,ait_real_80bit,ait_comp_64bit,ait_string]) then - AsmWriteLn(':'); - end; - end; -{$endif} - ait_direct : begin - AsmWritePChar(pai_direct(hp)^.str); - AsmLn; - end; -{$ifndef NEWLAB} -ait_labeled_instruction : - AsmWriteLn(#9#9+int_op2str[pai386_labeled(hp)^.opcode]+ - cond2str[pai386_labeled(hp)^.condition]+#9+lab2str(pai386_labeled(hp)^.lab)); -{$endif} - ait_symbol : begin - if pai_symbol(hp)^.is_global then - AsmWriteLn(#9'PUBLIC'#9+pai_symbol(hp)^.sym^.name); - AsmWrite(pai_symbol(hp)^.sym^.name); - if assigned(hp^.next) and not(pai(hp^.next)^.typ in - [ait_const_32bit,ait_const_16bit,ait_const_8bit, - ait_const_symbol,ait_const_rva, - ait_real_32bit,ait_real_64bit,ait_real_80bit,ait_comp_64bit,ait_string]) then - AsmWriteLn(':') - end; - ait_instruction : begin - suffix:=''; - prefix:= ''; - s:=''; -{$ifndef OLDASM} - { added prefix instructions, must be on same line as opcode } - if (pai386(hp)^.ops = 0) and - ((pai386(hp)^.opcode = A_REP) or - (pai386(hp)^.opcode = A_LOCK) or - (pai386(hp)^.opcode = A_REPE) or - (pai386(hp)^.opcode = A_REPNZ) or - (pai386(hp)^.opcode = A_REPZ) or - (pai386(hp)^.opcode = A_REPNE)) then - Begin - prefix:=int_op2str[pai386(hp)^.opcode]+#9; - hp:=Pai(hp^.next); - { this is theorically impossible... } - if hp=nil then - begin - s:=#9#9+prefix; - AsmWriteLn(s); - break; - end; - { nasm prefers prefix on a line alone } - AsmWriteln(#9#9+prefix); - prefix:=''; - end - else - prefix:= ''; - if pai386(hp)^.ops<>0 then - begin - if pai386(hp)^.opcode=A_CALL then - s:=#9+getopstr_jmp(pai386(hp)^.oper[0]) - else - begin - for i:=0to pai386(hp)^.ops-1 do - begin - if i=0 then - sep:=#9 - else - sep:=','; - s:=s+sep+getopstr(pai386(hp)^.oper[i],pai386(hp)^.opsize,pai386(hp)^.opcode,(i=1)); - end; - end; - end; - AsmWriteLn(#9#9+prefix+int_op2str[pai386(hp)^.opcode]+cond2str[pai386(hp)^.condition]+suffix+s); -{$else} - { added prefix instructions, must be on same line as opcode } - if (pai386(hp)^.op1t = top_none) and - ((pai386(hp)^.opcode = A_REP) or - (pai386(hp)^.opcode = A_LOCK) or - (pai386(hp)^.opcode = A_REPE) or - (pai386(hp)^.opcode = A_REPNE)) then - Begin - prefix:=int_op2str[pai386(hp)^.opcode]+#9; - hp:=Pai(hp^.next); - { this is theorically impossible... } - if hp=nil then - begin - s:=#9#9+prefix; - AsmWriteLn(s); - break; - end; - end - else - prefix:= ''; - if pai386(hp)^.op1t<>top_none then - begin - if pai386(hp)^.opcode=A_CALL then - begin - { with tasm call near ptr [edi+12] does not - work but call near [edi+12] works ?? (PM) - - It works with call dword ptr [], but you - need /m2 (2 passes) with tasm (PFV) - } -{ if pai386(hp)^.op1t=top_ref then - s:='near '+getopstr_jmp(pai386(hp)^.op1t,pai386(hp)^.op1) - else - s:='near ptr '+getopstr_jmp(pai386(hp)^.op1t,pai386(hp)^.op1);} - s:='dword ptr '+getopstr_jmp(pai386(hp)^.op1t,pai386(hp)^.op1,pai386(hp)^.op1ofs); - end - else - begin - s:=getopstr(pai386(hp)^.op1t,pai386(hp)^.op1,pai386(hp)^.op1ofs,pai386(hp)^.opsize, - pai386(hp)^.opcode,false); - if pai386(hp)^.op3t<>top_none then - begin - if pai386(hp)^.op2t<>top_none then -{$ifdef NO_OP3} - s:=getopstr(pai386(hp)^.op2t,pointer(longint(twowords(pai386(hp)^.op2).word1)),0, - pai386(hp)^.opsize,pai386(hp)^.opcode,true)+','+s; - s:=getopstr(pai386(hp)^.op3t,pointer(longint(twowords(pai386(hp)^.op2).word2)),0, - pai386(hp)^.opsize,pai386(hp)^.opcode,false)+','+s; -{$else NO_OP3} - s:=getopstr(pai386(hp)^.op2t,pai386(hp)^.op2,0, - pai386(hp)^.opsize,pai386(hp)^.opcode,true)+','+s; - s:=getopstr(pai386(hp)^.op3t,pai386(hp)^.op3,0, - pai386(hp)^.opsize,pai386(hp)^.opcode,false)+','+s; -{$endif NO_OP3} - end - else - if pai386(hp)^.op2t<>top_none then - s:=getopstr(pai386(hp)^.op2t,pai386(hp)^.op2,0,pai386(hp)^.opsize, - pai386(hp)^.opcode,true)+','+s; - end; - s:=#9+s; - end - else - begin - { check if string instruction } - { long form, otherwise may give range check errors } - { in turbo pascal... } - if ((pai386(hp)^.opcode = A_CMPS) or - (pai386(hp)^.opcode = A_INS) or - (pai386(hp)^.opcode = A_OUTS) or - (pai386(hp)^.opcode = A_SCAS) or - (pai386(hp)^.opcode = A_STOS) or - (pai386(hp)^.opcode = A_MOVS) or - (pai386(hp)^.opcode = A_LODS) or - (pai386(hp)^.opcode = A_XLAT)) then - Begin - case pai386(hp)^.opsize of - S_B: suffix:='b'; - S_W: suffix:='w'; - S_L: suffix:='d'; - else - Message(assem_f_invalid_suffix_intel); - end; - end; - s:=''; - end; - AsmWriteLn(#9#9+prefix+int_op2str[pai386(hp)^.opcode]+suffix+s); -{$endif OLDASM} - end; -{$ifdef GDB} - ait_stabn, - ait_stabs, - ait_force_line, -ait_stab_function_name : ; -{$endif GDB} - ait_cut : begin - { only reset buffer if nothing has changed } - if AsmSize=AsmStartSize then - AsmClear - else - begin - if LastSec<>sec_none then - AsmWriteLn('_'+target_asm.secnames[LastSec]+#9#9'ENDS'); - AsmLn; - AsmWriteLn(#9'END'); - AsmClose; - DoAssemble; - if pai_cut(hp)^.EndName then - IsEndFile:=true; - AsmCreate; - end; - { avoid empty files } - while assigned(hp^.next) and (pai(hp^.next)^.typ in [ait_cut,ait_section,ait_comment]) do - begin - if pai(hp^.next)^.typ=ait_section then - begin - lastsec:=pai_section(hp^.next)^.sec; - end; - hp:=pai(hp^.next); - end; - AsmWriteLn(#9'.386p'); - AsmWriteLn(#9'LOCALS '+target_asm.labelprefix); - if lastsec<>sec_none then - AsmWriteLn('_'+target_asm.secnames[lastsec]+#9#9+ - 'SEGMENT'#9'PARA PUBLIC USE32 '''+ - target_asm.secnames[lastsec]+''''); - AsmStartSize:=AsmSize; - end; - ait_marker: ; - else - internalerror(10000); - end; - hp:=pai(hp^.next); - end; - end; - - - procedure ti386intasmlist.WriteAsmList; - - begin -{$ifdef EXTDEBUG} - if assigned(current_module^.mainsource) then - comment(v_info,'Start writing intel-styled assembler output for '+current_module^.mainsource^); -{$endif} - LastSec:=sec_none; - AsmWriteLn(#9'.386p'); - AsmWriteLn(#9'LOCALS '+target_asm.labelprefix); - AsmWriteLn('DGROUP'#9'GROUP'#9'_BSS,_DATA'); - AsmWriteLn(#9'ASSUME'#9'CS:_CODE,ES:DGROUP,DS:DGROUP,SS:DGROUP'); - AsmLn; - - countlabelref:=false; - WriteTree(externals); - { INTEL ASM doesn't support stabs - WriteTree(debuglist);} - - WriteTree(codesegment); - WriteTree(datasegment); - WriteTree(consts); - WriteTree(rttilist); - WriteTree(bsssegment); - countlabelref:=true; - - AsmWriteLn(#9'END'); - AsmLn; - -{$ifdef EXTDEBUG} - if assigned(current_module^.mainsource) then - comment(v_info,'Done writing intel-styled assembler output for '+current_module^.mainsource^); -{$endif EXTDEBUG} - end; - -end. -{ +{ + $Id$ + Copyright (c) 1996,97 by Florian Klaempfl + + This unit implements an asmoutput class for Intel syntax with Intel i386+ + + 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} + {$N+,E+} +{$endif} +unit ag386int; + + interface + + uses aasm,assemble; + + type + pi386intasmlist=^ti386intasmlist; + ti386intasmlist = object(tasmlist) + procedure WriteTree(p:paasmoutput);virtual; + procedure WriteAsmList;virtual; + end; + + implementation + + uses + dos,strings, + globtype,globals,systems,cobjects, + files,verbose +{$ifndef OLDASM} + ,i386base,i386asm +{$else} + ,i386 +{$endif} +{$ifdef GDB} + ,gdb +{$endif GDB} + ; + + const + line_length = 70; + +{$ifndef NEWLAB} + extstr : array[EXT_NEAR..EXT_ABS] of String[8] = + ('NEAR','FAR','PROC','BYTE','WORD','DWORD', + 'CODEPTR','DATAPTR','FWORD','PWORD','QWORD','TBYTE','ABS'); +{$endif} + + function single2str(d : single) : string; + var + hs : string; + p : byte; + begin + str(d,hs); + { nasm expects a lowercase e } + p:=pos('E',hs); + if p>0 then + hs[p]:='e'; + p:=pos('+',hs); + if p>0 then + delete(hs,p,1); + single2str:=lower(hs); + end; + + function double2str(d : double) : string; + var + hs : string; + p : byte; + begin + str(d,hs); + { nasm expects a lowercase e } + p:=pos('E',hs); + if p>0 then + hs[p]:='e'; + p:=pos('+',hs); + if p>0 then + delete(hs,p,1); + double2str:=lower(hs); + end; + + function extended2str(e : extended) : string; + var + hs : string; + p : byte; + begin + str(e,hs); + { nasm expects a lowercase e } + p:=pos('E',hs); + if p>0 then + hs[p]:='e'; + p:=pos('+',hs); + if p>0 then + delete(hs,p,1); + extended2str:=lower(hs); + end; + + + function comp2str(d : bestreal) : string; + type + pdouble = ^double; + var + c : comp; + dd : pdouble; + begin +{$ifdef FPC} + c:=comp(d); +{$else} + c:=d; +{$endif} + dd:=pdouble(@c); { this makes a bitwise copy of c into a double } + comp2str:=double2str(dd^); + end; + + function getreferencestring(const ref : treference) : string; + var + s : string; + first : boolean; + begin + if ref.is_immediate then + begin + getreferencestring:=tostr(ref.offset); + exit; + end + else + with ref do + begin + first:=true; + if ref.segment<>R_NO then + s:=int_reg2str[segment]+':[' + else + s:='['; + if assigned(symbol) then + begin + s:=s+symbol^.name; + first:=false; + end; + if (base<>R_NO) then + begin + if not(first) then + s:=s+'+' + else + first:=false; + s:=s+int_reg2str[base]; + end; + if (index<>R_NO) then + begin + if not(first) then + s:=s+'+' + else + first:=false; + s:=s+int_reg2str[index]; + if scalefactor<>0 then + s:=s+'*'+tostr(scalefactor); + end; + if offset<0 then + s:=s+tostr(offset) + else if (offset>0) then + s:=s+'+'+tostr(offset); + s:=s+']'; + end; + getreferencestring:=s; + end; + +{$ifndef OLDASM} + + function getopstr(const o:toper;s : topsize; opcode: tasmop;dest : boolean) : string; + var + hs : string; + begin + case o.typ of + top_reg : + getopstr:=int_reg2str[o.reg]; + top_const : + getopstr:=tostr(o.val); + top_symbol : + begin + if assigned(o.sym) then + hs:='offset '+o.sym^.name + else + hs:='offset '; + if o.symofs>0 then + hs:=hs+'+'+tostr(o.symofs) + else + if o.symofs<0 then + hs:=hs+tostr(o.symofs) + else + if not(assigned(o.sym)) then + hs:=hs+'0'; + getopstr:=hs; + end; + top_ref : + begin + hs:=getreferencestring(o.ref^); + if ((opcode <> A_LGS) and (opcode <> A_LSS) and + (opcode <> A_LFS) and (opcode <> A_LDS) and + (opcode <> A_LES)) then + Begin + case s of + S_B : hs:='byte ptr '+hs; + S_W : hs:='word ptr '+hs; + S_L : hs:='dword ptr '+hs; + S_IS : hs:='word ptr '+hs; + S_IL : hs:='dword ptr '+hs; + S_IQ : hs:='qword ptr '+hs; + S_FS : hs:='dword ptr '+hs; + S_FL : hs:='qword ptr '+hs; + S_FX : hs:='tbyte ptr '+hs; + S_BW : if dest then + hs:='word ptr '+hs + else + hs:='byte ptr '+hs; + S_BL : if dest then + hs:='dword ptr '+hs + else + hs:='byte ptr '+hs; + S_WL : if dest then + hs:='dword ptr '+hs + else + hs:='word ptr '+hs; + end; + end; + getopstr:=hs; + end; + else + internalerror(10001); + end; + end; + + function getopstr_jmp(const o:toper) : string; + var + hs : string; + begin + case o.typ of + top_reg : + getopstr_jmp:=int_reg2str[o.reg]; + top_const : + getopstr_jmp:=tostr(o.val); + top_symbol : + begin + hs:=o.sym^.name; + if o.symofs>0 then + hs:=hs+'+'+tostr(o.symofs) + else + if o.symofs<0 then + hs:=hs+tostr(o.symofs); + getopstr_jmp:=hs; + end; + top_ref : + getopstr_jmp:=getreferencestring(o.ref^); + else + internalerror(10001); + end; + end; + +{$else} + + function getopstr(t : byte;o : pointer;opofs:longint;s : topsize; _operator: tasmop;dest : boolean) : string; + var + hs : string; + begin + case t of + top_reg : getopstr:=int_reg2str[tregister(o)]; + top_const, + top_ref : begin + if t=top_const then + hs := tostr(longint(o)) + else + hs:=getreferencestring(preference(o)^); + { can possibly give a range check error under tp } + { if using in... } + if ((_operator <> A_LGS) and (_operator <> A_LSS) and + (_operator <> A_LFS) and (_operator <> A_LDS) and + (_operator <> A_LES)) then + Begin + case s of + S_B : hs:='byte ptr '+hs; + S_W : hs:='word ptr '+hs; + S_L : hs:='dword ptr '+hs; + S_IS : hs:='word ptr '+hs; + S_IL : hs:='dword ptr '+hs; + S_IQ : hs:='qword ptr '+hs; + S_FS : hs:='dword ptr '+hs; + S_FL : hs:='qword ptr '+hs; + S_FX : hs:='tbyte ptr '+hs; + S_BW : if dest then + hs:='word ptr '+hs + else + hs:='byte ptr '+hs; + S_BL : if dest then + hs:='dword ptr '+hs + else + hs:='byte ptr '+hs; + S_WL : if dest then + hs:='dword ptr '+hs + else + hs:='word ptr '+hs; + end; + end; + getopstr:=hs; + end; + top_symbol : begin + hs:='offset '+pasmsymbol(o)^.name; + if opofs>0 then + hs:=hs+'+'+tostr(opofs) + else + if opofs<0 then + hs:=hs+tostr(opofs); + getopstr:=hs; + end; + else + internalerror(10001); + end; + end; + + function getopstr_jmp(t : byte;o : pointer;opofs:longint) : string; + var + hs : string; + begin + case t of + top_reg : getopstr_jmp:=int_reg2str[tregister(o)]; + top_ref : getopstr_jmp:=getreferencestring(preference(o)^); + top_const : getopstr_jmp:=tostr(longint(o)); + top_symbol : begin + hs:=pasmsymbol(o)^.name; + if opofs>0 then + hs:=hs+'+'+tostr(opofs) + else + if opofs<0 then + hs:=hs+tostr(opofs); + getopstr_jmp:=hs; + end; + else + internalerror(10001); + end; + end; +{$endif} + + +{**************************************************************************** + TI386INTASMLIST + ****************************************************************************} + + var + LastSec : tsection; + + const + ait_const2str:array[ait_const_32bit..ait_const_8bit] of string[8]= + (#9'DD'#9,#9'DW'#9,#9'DB'#9); + + Function PadTabs(const p:string;addch:char):string; + var + s : string; + i : longint; + begin + i:=length(p); + if addch<>#0 then + begin + inc(i); + s:=p+addch; + end + else + s:=p; + if i<8 then + PadTabs:=s+#9#9 + else + PadTabs:=s+#9; + end; + + procedure ti386intasmlist.WriteTree(p:paasmoutput); + type + twowords=record + word1,word2:word; + end; + var + s, + prefix, + suffix : string; + hp : pai; + counter, + lines, + i,j,l : longint; + consttyp : tait; + found, + quoted : boolean; +{$ifndef OLDASM} + sep : char; +{$endif} + begin + if not assigned(p) then + exit; + hp:=pai(p^.first); + while assigned(hp) do + begin + case hp^.typ of + ait_comment : Begin + AsmWrite(target_asm.comment); + AsmWritePChar(pai_asm_comment(hp)^.str); + AsmLn; + End; + ait_regalloc, + ait_tempalloc : ; + ait_section : begin + if LastSec<>sec_none then + AsmWriteLn('_'+target_asm.secnames[LastSec]+#9#9'ENDS'); + if pai_section(hp)^.sec<>sec_none then + begin + AsmLn; + AsmWriteLn('_'+target_asm.secnames[pai_section(hp)^.sec]+#9#9+ + 'SEGMENT'#9'PARA PUBLIC USE32 '''+ + target_asm.secnames[pai_section(hp)^.sec]+''''); + end; + LastSec:=pai_section(hp)^.sec; + end; + ait_align : begin + { CAUSES PROBLEMS WITH THE SEGMENT DEFINITION } + { SEGMENT DEFINITION SHOULD MATCH TYPE OF ALIGN } + { HERE UNDER TASM! } + AsmWriteLn(#9'ALIGN '+tostr(pai_align(hp)^.aligntype)); + end; +{$ifndef NEWLAB} + ait_external : AsmWriteLn(#9'EXTRN'#9+pai_external(hp)^.sym^.name+ + ' :'+extstr[pai_external(hp)^.exttyp]); +{$endif} + ait_datablock : begin + if pai_datablock(hp)^.is_global then + AsmWriteLn(#9'PUBLIC'#9+pai_datablock(hp)^.sym^.name); + AsmWriteLn(PadTabs(pai_datablock(hp)^.sym^.name,#0)+'DB'#9+tostr(pai_datablock(hp)^.size)+' DUP(?)'); + end; + ait_const_32bit, + ait_const_8bit, + ait_const_16bit : begin + AsmWrite(ait_const2str[hp^.typ]+tostr(pai_const(hp)^.value)); + consttyp:=hp^.typ; + l:=0; + repeat + found:=(not (Pai(hp^.next)=nil)) and (Pai(hp^.next)^.typ=consttyp); + if found then + begin + hp:=Pai(hp^.next); + s:=','+tostr(pai_const(hp)^.value); + AsmWrite(s); + inc(l,length(s)); + end; + until (not found) or (l>line_length); + AsmLn; + end; + ait_const_symbol : begin + AsmWriteLn(#9#9'DD'#9'offset '+pai_const_symbol(hp)^.sym^.name); + if pai_const_symbol(hp)^.offset>0 then + AsmWrite('+'+tostr(pai_const_symbol(hp)^.offset)) + else if pai_const_symbol(hp)^.offset<0 then + AsmWrite(tostr(pai_const_symbol(hp)^.offset)); + AsmLn; + end; + ait_const_rva : begin + AsmWriteLn(#9#9'RVA'#9+pai_const_symbol(hp)^.sym^.name); + end; + ait_real_32bit : AsmWriteLn(#9#9'DD'#9+single2str(pai_real_32bit(hp)^.value)); + ait_real_64bit : AsmWriteLn(#9#9'DQ'#9+double2str(pai_real_64bit(hp)^.value)); + ait_real_80bit : AsmWriteLn(#9#9'DT'#9+extended2str(pai_real_80bit(hp)^.value)); + ait_comp_64bit : AsmWriteLn(#9#9'DQ'#9+comp2str(pai_real_80bit(hp)^.value)); + ait_string : begin + counter := 0; + lines := pai_string(hp)^.len div line_length; + { separate lines in different parts } + if pai_string(hp)^.len > 0 then + Begin + for j := 0 to lines-1 do + begin + AsmWrite(#9#9'DB'#9); + quoted:=false; + for i:=counter to counter+line_length do + begin + { it is an ascii character. } + if (ord(pai_string(hp)^.str[i])>31) and + (ord(pai_string(hp)^.str[i])<128) and + (pai_string(hp)^.str[i]<>'"') then + begin + if not(quoted) then + begin + if i>counter then + AsmWrite(','); + AsmWrite('"'); + end; + AsmWrite(pai_string(hp)^.str[i]); + quoted:=true; + end { if > 31 and < 128 and ord('"') } + else + begin + if quoted then + AsmWrite('"'); + if i>counter then + AsmWrite(','); + quoted:=false; + AsmWrite(tostr(ord(pai_string(hp)^.str[i]))); + end; + end; { end for i:=0 to... } + if quoted then AsmWrite('"'); + AsmWrite(target_os.newline); + counter := counter+line_length; + end; { end for j:=0 ... } + { do last line of lines } + AsmWrite(#9#9'DB'#9); + quoted:=false; + for i:=counter to pai_string(hp)^.len-1 do + begin + { it is an ascii character. } + if (ord(pai_string(hp)^.str[i])>31) and + (ord(pai_string(hp)^.str[i])<128) and + (pai_string(hp)^.str[i]<>'"') then + begin + if not(quoted) then + begin + if i>counter then + AsmWrite(','); + AsmWrite('"'); + end; + AsmWrite(pai_string(hp)^.str[i]); + quoted:=true; + end { if > 31 and < 128 and " } + else + begin + if quoted then + AsmWrite('"'); + if i>counter then + AsmWrite(','); + quoted:=false; + AsmWrite(tostr(ord(pai_string(hp)^.str[i]))); + end; + end; { end for i:=0 to... } + if quoted then + AsmWrite('"'); + end; + AsmLn; + end; +{$ifndef NEWLAB} + ait_label : begin + if pai_label(hp)^.l^.is_used then + begin + AsmWrite(lab2str(pai_label(hp)^.l)); + if assigned(hp^.next) and not(pai(hp^.next)^.typ in + [ait_const_32bit,ait_const_16bit,ait_const_8bit, + ait_const_symbol,ait_const_rva, + ait_real_32bit,ait_real_64bit,ait_real_80bit,ait_comp_64bit,ait_string]) then + AsmWriteLn(':'); + end; + end; +{$endif} + ait_direct : begin + AsmWritePChar(pai_direct(hp)^.str); + AsmLn; + end; +{$ifndef NEWLAB} +ait_labeled_instruction : + AsmWriteLn(#9#9+int_op2str[pai386_labeled(hp)^.opcode]+ + cond2str[pai386_labeled(hp)^.condition]+#9+lab2str(pai386_labeled(hp)^.lab)); +{$endif} + ait_symbol : begin + if pai_symbol(hp)^.is_global then + AsmWriteLn(#9'PUBLIC'#9+pai_symbol(hp)^.sym^.name); + AsmWrite(pai_symbol(hp)^.sym^.name); + if assigned(hp^.next) and not(pai(hp^.next)^.typ in + [ait_const_32bit,ait_const_16bit,ait_const_8bit, + ait_const_symbol,ait_const_rva, + ait_real_32bit,ait_real_64bit,ait_real_80bit,ait_comp_64bit,ait_string]) then + AsmWriteLn(':') + end; + ait_instruction : begin + suffix:=''; + prefix:= ''; + s:=''; +{$ifndef OLDASM} + { added prefix instructions, must be on same line as opcode } + if (pai386(hp)^.ops = 0) and + ((pai386(hp)^.opcode = A_REP) or + (pai386(hp)^.opcode = A_LOCK) or + (pai386(hp)^.opcode = A_REPE) or + (pai386(hp)^.opcode = A_REPNZ) or + (pai386(hp)^.opcode = A_REPZ) or + (pai386(hp)^.opcode = A_REPNE)) then + Begin + prefix:=int_op2str[pai386(hp)^.opcode]+#9; + hp:=Pai(hp^.next); + { this is theorically impossible... } + if hp=nil then + begin + s:=#9#9+prefix; + AsmWriteLn(s); + break; + end; + { nasm prefers prefix on a line alone } + AsmWriteln(#9#9+prefix); + prefix:=''; + end + else + prefix:= ''; + if pai386(hp)^.ops<>0 then + begin + if pai386(hp)^.opcode=A_CALL then + s:=#9+getopstr_jmp(pai386(hp)^.oper[0]) + else + begin + for i:=0to pai386(hp)^.ops-1 do + begin + if i=0 then + sep:=#9 + else + sep:=','; + s:=s+sep+getopstr(pai386(hp)^.oper[i],pai386(hp)^.opsize,pai386(hp)^.opcode,(i=1)); + end; + end; + end; + AsmWriteLn(#9#9+prefix+int_op2str[pai386(hp)^.opcode]+cond2str[pai386(hp)^.condition]+suffix+s); +{$else} + { added prefix instructions, must be on same line as opcode } + if (pai386(hp)^.op1t = top_none) and + ((pai386(hp)^.opcode = A_REP) or + (pai386(hp)^.opcode = A_LOCK) or + (pai386(hp)^.opcode = A_REPE) or + (pai386(hp)^.opcode = A_REPNE)) then + Begin + prefix:=int_op2str[pai386(hp)^.opcode]+#9; + hp:=Pai(hp^.next); + { this is theorically impossible... } + if hp=nil then + begin + s:=#9#9+prefix; + AsmWriteLn(s); + break; + end; + end + else + prefix:= ''; + if pai386(hp)^.op1t<>top_none then + begin + if pai386(hp)^.opcode=A_CALL then + begin + { with tasm call near ptr [edi+12] does not + work but call near [edi+12] works ?? (PM) + + It works with call dword ptr [], but you + need /m2 (2 passes) with tasm (PFV) + } +{ if pai386(hp)^.op1t=top_ref then + s:='near '+getopstr_jmp(pai386(hp)^.op1t,pai386(hp)^.op1) + else + s:='near ptr '+getopstr_jmp(pai386(hp)^.op1t,pai386(hp)^.op1);} + s:='dword ptr '+getopstr_jmp(pai386(hp)^.op1t,pai386(hp)^.op1,pai386(hp)^.op1ofs); + end + else + begin + s:=getopstr(pai386(hp)^.op1t,pai386(hp)^.op1,pai386(hp)^.op1ofs,pai386(hp)^.opsize, + pai386(hp)^.opcode,false); + if pai386(hp)^.op3t<>top_none then + begin + if pai386(hp)^.op2t<>top_none then +{$ifdef NO_OP3} + s:=getopstr(pai386(hp)^.op2t,pointer(longint(twowords(pai386(hp)^.op2).word1)),0, + pai386(hp)^.opsize,pai386(hp)^.opcode,true)+','+s; + s:=getopstr(pai386(hp)^.op3t,pointer(longint(twowords(pai386(hp)^.op2).word2)),0, + pai386(hp)^.opsize,pai386(hp)^.opcode,false)+','+s; +{$else NO_OP3} + s:=getopstr(pai386(hp)^.op2t,pai386(hp)^.op2,0, + pai386(hp)^.opsize,pai386(hp)^.opcode,true)+','+s; + s:=getopstr(pai386(hp)^.op3t,pai386(hp)^.op3,0, + pai386(hp)^.opsize,pai386(hp)^.opcode,false)+','+s; +{$endif NO_OP3} + end + else + if pai386(hp)^.op2t<>top_none then + s:=getopstr(pai386(hp)^.op2t,pai386(hp)^.op2,0,pai386(hp)^.opsize, + pai386(hp)^.opcode,true)+','+s; + end; + s:=#9+s; + end + else + begin + { check if string instruction } + { long form, otherwise may give range check errors } + { in turbo pascal... } + if ((pai386(hp)^.opcode = A_CMPS) or + (pai386(hp)^.opcode = A_INS) or + (pai386(hp)^.opcode = A_OUTS) or + (pai386(hp)^.opcode = A_SCAS) or + (pai386(hp)^.opcode = A_STOS) or + (pai386(hp)^.opcode = A_MOVS) or + (pai386(hp)^.opcode = A_LODS) or + (pai386(hp)^.opcode = A_XLAT)) then + Begin + case pai386(hp)^.opsize of + S_B: suffix:='b'; + S_W: suffix:='w'; + S_L: suffix:='d'; + else + Message(assem_f_invalid_suffix_intel); + end; + end; + s:=''; + end; + AsmWriteLn(#9#9+prefix+int_op2str[pai386(hp)^.opcode]+suffix+s); +{$endif OLDASM} + end; +{$ifdef GDB} + ait_stabn, + ait_stabs, + ait_force_line, +ait_stab_function_name : ; +{$endif GDB} + ait_cut : begin + { only reset buffer if nothing has changed } + if AsmSize=AsmStartSize then + AsmClear + else + begin + if LastSec<>sec_none then + AsmWriteLn('_'+target_asm.secnames[LastSec]+#9#9'ENDS'); + AsmLn; + AsmWriteLn(#9'END'); + AsmClose; + DoAssemble; + if pai_cut(hp)^.EndName then + IsEndFile:=true; + AsmCreate; + end; + { avoid empty files } + while assigned(hp^.next) and (pai(hp^.next)^.typ in [ait_cut,ait_section,ait_comment]) do + begin + if pai(hp^.next)^.typ=ait_section then + begin + lastsec:=pai_section(hp^.next)^.sec; + end; + hp:=pai(hp^.next); + end; + AsmWriteLn(#9'.386p'); + AsmWriteLn(#9'LOCALS '+target_asm.labelprefix); + if lastsec<>sec_none then + AsmWriteLn('_'+target_asm.secnames[lastsec]+#9#9+ + 'SEGMENT'#9'PARA PUBLIC USE32 '''+ + target_asm.secnames[lastsec]+''''); + AsmStartSize:=AsmSize; + end; + ait_marker: ; + else + internalerror(10000); + end; + hp:=pai(hp^.next); + end; + end; + + + procedure ti386intasmlist.WriteAsmList; + + begin +{$ifdef EXTDEBUG} + if assigned(current_module^.mainsource) then + comment(v_info,'Start writing intel-styled assembler output for '+current_module^.mainsource^); +{$endif} + LastSec:=sec_none; + AsmWriteLn(#9'.386p'); + AsmWriteLn(#9'LOCALS '+target_asm.labelprefix); + AsmWriteLn('DGROUP'#9'GROUP'#9'_BSS,_DATA'); + AsmWriteLn(#9'ASSUME'#9'CS:_CODE,ES:DGROUP,DS:DGROUP,SS:DGROUP'); + AsmLn; + + countlabelref:=false; + WriteTree(externals); + { INTEL ASM doesn't support stabs + WriteTree(debuglist);} + + WriteTree(codesegment); + WriteTree(datasegment); + WriteTree(consts); + WriteTree(rttilist); + WriteTree(bsssegment); + countlabelref:=true; + + AsmWriteLn(#9'END'); + AsmLn; + +{$ifdef EXTDEBUG} + if assigned(current_module^.mainsource) then + comment(v_info,'Done writing intel-styled assembler output for '+current_module^.mainsource^); +{$endif EXTDEBUG} + end; + +end. +{ $Log$ - Revision 1.42 1999-05-21 13:54:42 peter + Revision 1.43 1999-05-23 18:41:55 florian + * better error recovering in typed constants + * some problems with arrays of const fixed, some problems + due my previous + - the location type of array constructor is now LOC_MEM + - the pushing of high fixed + - parameter copying fixed + - zero temp. allocation removed + * small problem in the assembler writers fixed: + ref to nil wasn't written correctly + + Revision 1.42 1999/05/21 13:54:42 peter * NEWLAB for label as symbol - - Revision 1.41 1999/05/12 00:19:38 peter - * removed R_DEFAULT_SEG - * uniform float names - - Revision 1.40 1999/05/10 15:18:14 peter - * fixed condition writing - - Revision 1.39 1999/05/08 19:52:33 peter - + MessagePos() which is enhanced Message() function but also gets the - position info - * Removed comp warnings - - Revision 1.38 1999/05/07 00:08:49 pierre - * AG386BIN cond -> OLDASM, only cosmetic - - Revision 1.37 1999/05/06 09:05:09 peter - * generic write_float and str_float - * fixed constant float conversions - - Revision 1.36 1999/05/04 21:44:31 florian - * changes to compile it with Delphi 4.0 - - Revision 1.35 1999/05/02 22:41:49 peter - * moved section names to systems - * fixed nasm,intel writer - - Revision 1.34 1999/05/01 13:23:58 peter - * merged nasm compiler - * old asm moved to oldasm/ - - Revision 1.33 1999/04/17 22:17:05 pierre - * ifdef USE_OP3 released (changed into ifndef NO_OP3) - * SHRD and SHLD first operand (ATT syntax) can only be CL reg or immediate const - - Revision 1.32 1999/04/16 11:49:39 peter - + tempalloc - + -at to show temp alloc info in .s file - - Revision 1.31 1999/04/16 10:00:55 pierre - + ifdef USE_OP3 code : - added all missing op_... constructors for tai386 needed - for SHRD,SHLD and IMUL code in assembler readers - (check in tests/tbs0123.pp) - - Revision 1.30 1999/03/29 16:05:43 peter - * optimizer working for ag386bin - - Revision 1.29 1999/03/02 02:56:10 peter - + stabs support for binary writers - * more fixes and missing updates from the previous commit :( - - Revision 1.28 1999/03/01 15:46:16 peter - * ag386bin finally make cycles correct - * prefixes are now also normal opcodes - - Revision 1.27 1999/02/26 00:48:13 peter - * assembler writers fixed for ag386bin - - Revision 1.26 1999/02/25 21:02:18 peter - * ag386bin updates - + coff writer - - Revision 1.25 1999/02/22 02:14:59 peter - * updates for ag386bin - - Revision 1.24 1998/12/20 16:21:22 peter - * smartlinking doesn't crash anymore - - Revision 1.23 1998/12/16 00:27:17 peter - * removed some obsolete version checks - - Revision 1.22 1998/12/01 11:19:38 peter - * fixed range problem with in [tasmop] - - Revision 1.21 1998/11/30 09:42:55 pierre - * some range check bugs fixed (still not working !) - + added DLL writing support for win32 (also accepts variables) - + TempAnsi for code that could be used for Temporary ansi strings - handling - - Revision 1.20 1998/11/17 00:26:09 peter - * fixed for $H+ - - Revision 1.19 1998/11/16 12:38:05 jonas - + readded ait_marker support - - Revision 1.18 1998/11/12 11:19:33 pierre - * fix for first line of function break - - Revision 1.17 1998/10/12 12:20:40 pierre - + added tai_const_symbol_offset - for r : pointer = @var.field; - * better message for different arg names on implementation - of function - - Revision 1.16 1998/10/06 17:16:33 pierre - * some memory leaks fixed (thanks to Peter for heaptrc !) - - Revision 1.15 1998/10/01 20:19:06 jonas - + ait_marker support - - Revision 1.14 1998/09/20 17:11:21 jonas - * released REGALLOC - - Revision 1.13 1998/08/10 15:49:38 peter - * small fixes for 0.99.5 - - Revision 1.12 1998/08/08 10:19:17 florian - * small fixes to write the extended type correct - - Revision 1.11 1998/06/05 17:46:02 peter - * tp doesn't like comp() typecast - - Revision 1.10 1998/05/25 17:11:36 pierre - * firstpasscount bug fixed - now all is already set correctly the first time - under EXTDEBUG try -gp to skip all other firstpasses - it works !! - * small bug fixes - - for smallsets with -dTESTSMALLSET - - some warnings removed (by correcting code !) - - Revision 1.9 1998/05/23 01:20:55 peter - + aktasmmode, aktoptprocessor, aktoutputformat - + smartlink per module $SMARTLINK-/+ (like MMX) and moved to aktswitches - + $LIBNAME to set the library name where the unit will be put in - * splitted cgi386 a bit (codeseg to large for bp7) - * nasm, tasm works again. nasm moved to ag386nsm.pas - - Revision 1.8 1998/05/06 18:36:53 peter - * tai_section extended with code,data,bss sections and enumerated type - * ident 'compiled by FPC' moved to pmodules - * small fix for smartlink - - Revision 1.7 1998/05/06 08:38:32 pierre - * better position info with UseTokenInfo - UseTokenInfo greatly simplified - + added check for changed tree after first time firstpass - (if we could remove all the cases were it happen - we could skip all firstpass if firstpasscount > 1) - Only with ExtDebug - - Revision 1.6 1998/05/04 17:54:24 peter - + smartlinking works (only case jumptable left todo) - * redesign of systems.pas to support assemblers and linkers - + Unitname is now also in the PPU-file, increased version to 14 - - Revision 1.5 1998/05/01 07:43:52 florian - + basics for rtti implemented - + switch $m (generate rtti for published sections) - - Revision 1.4 1998/04/29 10:33:41 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 16:58:01 pierre - * several bugfixes - ADD ADC and AND are also sign extended - nasm output OK (program still crashes at end - and creates wrong assembler files !!) - procsym types sym in tdef removed !! - - Revision 1.2 1998/04/08 11:34:17 peter - * nasm works (linux only tested) -} + + Revision 1.41 1999/05/12 00:19:38 peter + * removed R_DEFAULT_SEG + * uniform float names + + Revision 1.40 1999/05/10 15:18:14 peter + * fixed condition writing + + Revision 1.39 1999/05/08 19:52:33 peter + + MessagePos() which is enhanced Message() function but also gets the + position info + * Removed comp warnings + + Revision 1.38 1999/05/07 00:08:49 pierre + * AG386BIN cond -> OLDASM, only cosmetic + + Revision 1.37 1999/05/06 09:05:09 peter + * generic write_float and str_float + * fixed constant float conversions + + Revision 1.36 1999/05/04 21:44:31 florian + * changes to compile it with Delphi 4.0 + + Revision 1.35 1999/05/02 22:41:49 peter + * moved section names to systems + * fixed nasm,intel writer + + Revision 1.34 1999/05/01 13:23:58 peter + * merged nasm compiler + * old asm moved to oldasm/ + + Revision 1.33 1999/04/17 22:17:05 pierre + * ifdef USE_OP3 released (changed into ifndef NO_OP3) + * SHRD and SHLD first operand (ATT syntax) can only be CL reg or immediate const + + Revision 1.32 1999/04/16 11:49:39 peter + + tempalloc + + -at to show temp alloc info in .s file + + Revision 1.31 1999/04/16 10:00:55 pierre + + ifdef USE_OP3 code : + added all missing op_... constructors for tai386 needed + for SHRD,SHLD and IMUL code in assembler readers + (check in tests/tbs0123.pp) + + Revision 1.30 1999/03/29 16:05:43 peter + * optimizer working for ag386bin + + Revision 1.29 1999/03/02 02:56:10 peter + + stabs support for binary writers + * more fixes and missing updates from the previous commit :( + + Revision 1.28 1999/03/01 15:46:16 peter + * ag386bin finally make cycles correct + * prefixes are now also normal opcodes + + Revision 1.27 1999/02/26 00:48:13 peter + * assembler writers fixed for ag386bin + + Revision 1.26 1999/02/25 21:02:18 peter + * ag386bin updates + + coff writer + + Revision 1.25 1999/02/22 02:14:59 peter + * updates for ag386bin + + Revision 1.24 1998/12/20 16:21:22 peter + * smartlinking doesn't crash anymore + + Revision 1.23 1998/12/16 00:27:17 peter + * removed some obsolete version checks + + Revision 1.22 1998/12/01 11:19:38 peter + * fixed range problem with in [tasmop] + + Revision 1.21 1998/11/30 09:42:55 pierre + * some range check bugs fixed (still not working !) + + added DLL writing support for win32 (also accepts variables) + + TempAnsi for code that could be used for Temporary ansi strings + handling + + Revision 1.20 1998/11/17 00:26:09 peter + * fixed for $H+ + + Revision 1.19 1998/11/16 12:38:05 jonas + + readded ait_marker support + + Revision 1.18 1998/11/12 11:19:33 pierre + * fix for first line of function break + + Revision 1.17 1998/10/12 12:20:40 pierre + + added tai_const_symbol_offset + for r : pointer = @var.field; + * better message for different arg names on implementation + of function + + Revision 1.16 1998/10/06 17:16:33 pierre + * some memory leaks fixed (thanks to Peter for heaptrc !) + + Revision 1.15 1998/10/01 20:19:06 jonas + + ait_marker support + + Revision 1.14 1998/09/20 17:11:21 jonas + * released REGALLOC + + Revision 1.13 1998/08/10 15:49:38 peter + * small fixes for 0.99.5 + + Revision 1.12 1998/08/08 10:19:17 florian + * small fixes to write the extended type correct + + Revision 1.11 1998/06/05 17:46:02 peter + * tp doesn't like comp() typecast + + Revision 1.10 1998/05/25 17:11:36 pierre + * firstpasscount bug fixed + now all is already set correctly the first time + under EXTDEBUG try -gp to skip all other firstpasses + it works !! + * small bug fixes + - for smallsets with -dTESTSMALLSET + - some warnings removed (by correcting code !) + + Revision 1.9 1998/05/23 01:20:55 peter + + aktasmmode, aktoptprocessor, aktoutputformat + + smartlink per module $SMARTLINK-/+ (like MMX) and moved to aktswitches + + $LIBNAME to set the library name where the unit will be put in + * splitted cgi386 a bit (codeseg to large for bp7) + * nasm, tasm works again. nasm moved to ag386nsm.pas + + Revision 1.8 1998/05/06 18:36:53 peter + * tai_section extended with code,data,bss sections and enumerated type + * ident 'compiled by FPC' moved to pmodules + * small fix for smartlink + + Revision 1.7 1998/05/06 08:38:32 pierre + * better position info with UseTokenInfo + UseTokenInfo greatly simplified + + added check for changed tree after first time firstpass + (if we could remove all the cases were it happen + we could skip all firstpass if firstpasscount > 1) + Only with ExtDebug + + Revision 1.6 1998/05/04 17:54:24 peter + + smartlinking works (only case jumptable left todo) + * redesign of systems.pas to support assemblers and linkers + + Unitname is now also in the PPU-file, increased version to 14 + + Revision 1.5 1998/05/01 07:43:52 florian + + basics for rtti implemented + + switch $m (generate rtti for published sections) + + Revision 1.4 1998/04/29 10:33:41 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 16:58:01 pierre + * several bugfixes + ADD ADC and AND are also sign extended + nasm output OK (program still crashes at end + and creates wrong assembler files !!) + procsym types sym in tdef removed !! + + Revision 1.2 1998/04/08 11:34:17 peter + * nasm works (linux only tested) +} diff --git a/compiler/ag386nsm.pas b/compiler/ag386nsm.pas index c442db8d16..7502ac0c4f 100644 --- a/compiler/ag386nsm.pas +++ b/compiler/ag386nsm.pas @@ -1,908 +1,925 @@ -{ - $Id$ - Copyright (c) 1996,97 by Florian Klaempfl - - This unit implements an asmoutput class for the Nasm assembler with - Intel syntax for the i386+ - - 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} - {$N+,E+} -{$endif} -unit ag386nsm; - - interface - - uses aasm,assemble; - - type - pi386nasmasmlist=^ti386nasmasmlist; - ti386nasmasmlist = object(tasmlist) - procedure WriteTree(p:paasmoutput);virtual; - procedure WriteAsmList;virtual; - end; - - implementation - - uses - dos,strings, - globtype,globals,systems,cobjects, - files,verbose -{$ifndef OLDASM} - ,i386base,i386asm -{$else} - ,i386 -{$endif} -{$ifdef GDB} - ,gdb -{$endif GDB} - ; - - const - line_length = 70; - -{$ifndef NEWLAB} - extstr : array[EXT_NEAR..EXT_ABS] of String[8] = - ('NEAR','FAR','PROC','BYTE','WORD','DWORD', - 'CODEPTR','DATAPTR','FWORD','PWORD','QWORD','TBYTE','ABS'); -{$endif} - - function single2str(d : single) : string; - var - hs : string; - p : byte; - begin - str(d,hs); - { nasm expects a lowercase e } - p:=pos('E',hs); - if p>0 then - hs[p]:='e'; - p:=pos('+',hs); - if p>0 then - delete(hs,p,1); - single2str:=lower(hs); - end; - - function double2str(d : double) : string; - var - hs : string; - p : byte; - begin - str(d,hs); - { nasm expects a lowercase e } - p:=pos('E',hs); - if p>0 then - hs[p]:='e'; - p:=pos('+',hs); - if p>0 then - delete(hs,p,1); - double2str:=lower(hs); - end; - - function extended2str(e : extended) : string; - var - hs : string; - p : byte; - begin - str(e,hs); - { nasm expects a lowercase e } - p:=pos('E',hs); - if p>0 then - hs[p]:='e'; - p:=pos('+',hs); - if p>0 then - delete(hs,p,1); - extended2str:=lower(hs); - end; - - - function comp2str(d : bestreal) : string; - type - pdouble = ^double; - var - c : comp; - dd : pdouble; - begin -{$ifdef FPC} - c:=comp(d); -{$else} - c:=d; -{$endif} - dd:=pdouble(@c); { this makes a bitwise copy of c into a double } - comp2str:=double2str(dd^); - end; - - - function getreferencestring(const ref : treference) : string; - var - s : string; - first : boolean; - begin - if ref.is_immediate then - begin - getreferencestring:=tostr(ref.offset); - exit; - end - else - with ref do - begin - first:=true; - if ref.segment<>R_NO then - s:='['+int_reg2str[segment]+':' - else - s:='['; - if assigned(symbol) then - begin - s:=s+symbol^.name; - first:=false; - end; - if (base<>R_NO) then - begin - if not(first) then - s:=s+'+' - else - first:=false; - s:=s+int_reg2str[base]; - end; - if (index<>R_NO) then - begin - if not(first) then - s:=s+'+' - else - first:=false; - s:=s+int_reg2str[index]; - if scalefactor<>0 then - s:=s+'*'+tostr(scalefactor); - end; - if offset<0 then - s:=s+tostr(offset) - else if (offset>0) then - s:=s+'+'+tostr(offset); - s:=s+']'; - end; - getreferencestring:=s; - end; - -{$ifndef OLDASM} - - function getopstr(const o:toper;s : topsize; opcode: tasmop;dest : boolean) : string; - var - hs : string; - begin - case o.typ of - top_reg : - getopstr:=int_nasmreg2str[o.reg]; - top_const : - getopstr:=tostr(o.val); - top_symbol : - begin - hs:='dword '+o.sym^.name; - if o.symofs>0 then - hs:=hs+'+'+tostr(o.symofs) - else - if o.symofs<0 then - hs:=hs+tostr(o.symofs); - getopstr:=hs; - end; - top_ref : - begin - hs:=getreferencestring(o.ref^); - if not ((opcode = A_LEA) or (opcode = A_LGS) or - (opcode = A_LSS) or (opcode = A_LFS) or - (opcode = A_LES) or (opcode = A_LDS) or - (opcode = A_SHR) or (opcode = A_SHL) or - (opcode = A_SAR) or (opcode = A_SAL) or - (opcode = A_OUT) or (opcode = A_IN)) then - begin - case s of - S_B : hs:='byte '+hs; - S_W : hs:='word '+hs; - S_L : hs:='dword '+hs; - S_IS : hs:='word '+hs; - S_IL : hs:='dword '+hs; - S_IQ : hs:='qword '+hs; - S_FS : hs:='dword '+hs; - S_FL : hs:='qword '+hs; - S_FX : hs:='tword '+hs; - S_BW : if dest then - hs:='word '+hs - else - hs:='byte '+hs; - S_BL : if dest then - hs:='dword '+hs - else - hs:='byte '+hs; - S_WL : if dest then - hs:='dword '+hs - else - hs:='word '+hs; - end - end; - getopstr:=hs; - end; - else - internalerror(10001); - end; - end; - - function getopstr_jmp(const o:toper) : string; - var - hs : string; - begin - case o.typ of - top_reg : - getopstr_jmp:=int_nasmreg2str[o.reg]; - top_ref : - getopstr_jmp:=getreferencestring(o.ref^); - top_const : - getopstr_jmp:=tostr(o.val); - top_symbol : - begin - hs:=o.sym^.name; - if o.symofs>0 then - hs:=hs+'+'+tostr(o.symofs) - else - if o.symofs<0 then - hs:=hs+tostr(o.symofs); - getopstr_jmp:=hs; - end; - else - internalerror(10001); - end; - end; - -{$else} - - function getopstr(t : byte;o : pointer;opofs:longint;s : topsize; opcode: tasmop;dest : boolean) : string; - var - hs : string; - begin - case t of - top_reg : getopstr:=int_nasmreg2str[tregister(o)]; - top_const, - top_ref : begin - if t=top_const then - hs := tostr(longint(o)) - else - hs:=getreferencestring(preference(o)^); - if not ((opcode = A_LEA) or (opcode = A_LGS) or - (opcode = A_LSS) or (opcode = A_LFS) or - (opcode = A_LES) or (opcode = A_LDS) or - (opcode = A_SHR) or (opcode = A_SHL) or - (opcode = A_SAR) or (opcode = A_SAL) or - (opcode = A_OUT) or (opcode = A_IN)) then - begin - case s of - S_B : hs:='byte '+hs; - S_W : hs:='word '+hs; - S_L : hs:='dword '+hs; - S_IS : hs:='word '+hs; - S_IL : hs:='dword '+hs; - S_IQ : hs:='qword '+hs; - S_FS : hs:='dword '+hs; - S_FL : hs:='qword '+hs; - S_FX : hs:='tword '+hs; - S_BW : if dest then - hs:='word '+hs - else - hs:='byte '+hs; - S_BL : if dest then - hs:='dword '+hs - else - hs:='byte '+hs; - S_WL : if dest then - hs:='dword '+hs - else - hs:='word '+hs; - end - end; - getopstr:=hs; - end; - top_symbol : begin - hs:='dword '+pasmsymbol(o)^.name; - if opofs>0 then - hs:=hs+'+'+tostr(opofs) - else - if opofs<0 then - hs:=hs+tostr(opofs); - getopstr:=hs; - end; - else - internalerror(10001); - end; - end; - - function getopstr_jmp(t : byte;o : pointer;opofs:longint) : string; - var - hs : string; - begin - case t of - top_reg : getopstr_jmp:=int_reg2str[tregister(o)]; - top_ref : getopstr_jmp:=getreferencestring(preference(o)^); - top_const : getopstr_jmp:=tostr(longint(o)); - top_symbol : begin - hs:=pasmsymbol(o)^.name; - if opofs>0 then - hs:=hs+'+'+tostr(opofs) - else - if opofs<0 then - hs:=hs+tostr(opofs); - getopstr_jmp:=hs; - end; - else - internalerror(10001); - end; - end; - -{$endif} - - -{**************************************************************************** - Ti386nasmasmlist - ****************************************************************************} - - var - LastSec : tsection; - - const - ait_const2str:array[ait_const_32bit..ait_const_8bit] of string[8]= - (#9'DD'#9,#9'DW'#9,#9'DB'#9); - - Function PadTabs(const p:string;addch:char):string; - var - s : string; - i : longint; - begin - i:=length(p); - if addch<>#0 then - begin - inc(i); - s:=p+addch; - end - else - s:=p; - if i<8 then - PadTabs:=s+#9#9 - else - PadTabs:=s+#9; - end; - - - procedure ti386nasmasmlist.WriteTree(p:paasmoutput); - type - twowords=record - word1,word2:word; - end; - var - s, - prefix, - suffix : string; - hp : pai; - counter, - lines, - i,j,l : longint; - op : tasmop; - consttyp : tait; - found, - quoted : boolean; -{$ifndef OLDASM} - sep : char; -{$endif} - begin - if not assigned(p) then - exit; - hp:=pai(p^.first); - while assigned(hp) do - begin - case hp^.typ of - ait_comment : Begin - AsmWrite(target_asm.comment); - AsmWritePChar(pai_asm_comment(hp)^.str); - AsmLn; - End; - ait_regalloc, - ait_tempalloc : ; - ait_section : begin - if pai_section(hp)^.sec<>sec_none then - begin - AsmLn; - AsmWriteLn('SECTION '+target_asm.secnames[pai_section(hp)^.sec]); - end; - LastSec:=pai_section(hp)^.sec; - end; - ait_align : AsmWriteLn(#9'ALIGN '+tostr(pai_align(hp)^.aligntype)); -{$ifndef NEWLAB} - ait_external : AsmWriteLn('EXTERN '+pai_external(hp)^.sym^.name); -{$endif} - ait_datablock : begin - if pai_datablock(hp)^.is_global then - AsmWriteLn(#9'GLOBAL '+pai_datablock(hp)^.sym^.name); - AsmWriteLn(PadTabs(pai_datablock(hp)^.sym^.name,':')+'RESB'#9+tostr(pai_datablock(hp)^.size)); - end; - ait_const_32bit, - ait_const_8bit, - ait_const_16bit : begin - AsmWrite(ait_const2str[hp^.typ]+tostr(pai_const(hp)^.value)); - consttyp:=hp^.typ; - l:=0; - repeat - found:=(not (Pai(hp^.next)=nil)) and (Pai(hp^.next)^.typ=consttyp); - if found then - begin - hp:=Pai(hp^.next); - s:=','+tostr(pai_const(hp)^.value); - AsmWrite(s); - inc(l,length(s)); - end; - until (not found) or (l>line_length); - AsmLn; - end; - ait_const_symbol : begin - AsmWriteLn(#9#9'DD'#9+pai_const_symbol(hp)^.sym^.name); - if pai_const_symbol(hp)^.offset>0 then - AsmWrite('+'+tostr(pai_const_symbol(hp)^.offset)) - else if pai_const_symbol(hp)^.offset<0 then - AsmWrite(tostr(pai_const_symbol(hp)^.offset)); - AsmLn; - end; - ait_const_rva : begin - AsmWriteLn(#9#9'RVA'#9+pai_const_symbol(hp)^.sym^.name); - end; - ait_real_32bit : AsmWriteLn(#9#9'DD'#9+single2str(pai_real_32bit(hp)^.value)); - ait_real_64bit : AsmWriteLn(#9#9'DQ'#9+double2str(pai_real_64bit(hp)^.value)); - ait_real_80bit : AsmWriteLn(#9#9'DT'#9+extended2str(pai_real_80bit(hp)^.value)); - ait_comp_64bit : AsmWriteLn(#9#9'DQ'#9+comp2str(pai_real_80bit(hp)^.value)); - ait_string : begin - counter := 0; - lines := pai_string(hp)^.len div line_length; - { separate lines in different parts } - if pai_string(hp)^.len > 0 then - Begin - for j := 0 to lines-1 do - begin - AsmWrite(#9#9'DB'#9); - quoted:=false; - for i:=counter to counter+line_length do - begin - { it is an ascii character. } - if (ord(pai_string(hp)^.str[i])>31) and - (ord(pai_string(hp)^.str[i])<128) and - (pai_string(hp)^.str[i]<>'"') then - begin - if not(quoted) then - begin - if i>counter then - AsmWrite(','); - AsmWrite('"'); - end; - AsmWrite(pai_string(hp)^.str[i]); - quoted:=true; - end { if > 31 and < 128 and ord('"') } - else - begin - if quoted then - AsmWrite('"'); - if i>counter then - AsmWrite(','); - quoted:=false; - AsmWrite(tostr(ord(pai_string(hp)^.str[i]))); - end; - end; { end for i:=0 to... } - if quoted then AsmWrite('"'); - AsmWrite(target_os.newline); - counter := counter+line_length; - end; { end for j:=0 ... } - { do last line of lines } - AsmWrite(#9#9'DB'#9); - quoted:=false; - for i:=counter to pai_string(hp)^.len-1 do - begin - { it is an ascii character. } - if (ord(pai_string(hp)^.str[i])>31) and - (ord(pai_string(hp)^.str[i])<128) and - (pai_string(hp)^.str[i]<>'"') then - begin - if not(quoted) then - begin - if i>counter then - AsmWrite(','); - AsmWrite('"'); - end; - AsmWrite(pai_string(hp)^.str[i]); - quoted:=true; - end { if > 31 and < 128 and " } - else - begin - if quoted then - AsmWrite('"'); - if i>counter then - AsmWrite(','); - quoted:=false; - AsmWrite(tostr(ord(pai_string(hp)^.str[i]))); - end; - end; { end for i:=0 to... } - if quoted then - AsmWrite('"'); - end; - AsmLn; - end; -{$ifndef NEWLAB} - ait_label : begin - if pai_label(hp)^.l^.is_used then - AsmWriteLn(lab2str(pai_label(hp)^.l)+':'); - end; -{$endif} - ait_direct : begin - AsmWritePChar(pai_direct(hp)^.str); - AsmLn; - end; -{$ifndef NEWLAB} -ait_labeled_instruction : - begin - op:=pai386_labeled(hp)^.opcode; - if not((op=A_JMP) or (op=A_LOOP) or (op=A_LOOPZ) or - (op=A_LOOPE) or (op=A_LOOPNZ) or (op=A_LOOPNE) or - (op=A_JCXZ) or (op=A_JECXZ)) then - AsmWriteLn(#9#9+int_op2str[pai386_labeled(hp)^.opcode]+ - cond2str[pai386_labeled(hp)^.condition]+#9+'near '+lab2str(pai386_labeled(hp)^.lab)) - else - AsmWriteLn(#9#9+int_op2str[pai386_labeled(hp)^.opcode]+ - cond2str[pai386_labeled(hp)^.condition]+#9+lab2str(pai386_labeled(hp)^.lab)); - end; -{$endif} - ait_symbol : begin - if pai_symbol(hp)^.is_global then - AsmWriteLn(#9'GLOBAL '+pai_symbol(hp)^.sym^.name); - AsmWrite(pai_symbol(hp)^.sym^.name); - if assigned(hp^.next) and not(pai(hp^.next)^.typ in - [ait_const_32bit,ait_const_16bit,ait_const_8bit, - ait_const_symbol,ait_const_rva, - ait_real_32bit,ait_real_64bit,ait_real_80bit,ait_comp_64bit,ait_string]) then - AsmWriteLn(':') - end; - ait_instruction : begin - suffix:=''; - prefix:=''; - s:=''; -{$ifndef OLDASM} - if pai386(hp)^.ops<>0 then - begin - if pai386(hp)^.opcode=A_CALL then - s:=#9+getopstr_jmp(pai386(hp)^.oper[0]) - else - begin - for i:=0to pai386(hp)^.ops-1 do - begin - if i=0 then - sep:=#9 - else - sep:=','; - s:=s+sep+getopstr(pai386(hp)^.oper[i],pai386(hp)^.opsize,pai386(hp)^.opcode,(i=1)); - end; - end; - end; - if pai386(hp)^.opcode=A_FWAIT then - AsmWriteln(#9#9'DB'#9'09bh') - else - AsmWriteLn(#9#9+prefix+int_op2str[pai386(hp)^.opcode]+ - cond2str[pai386(hp)^.condition]+suffix+s); -{$else} - { added prefix instructions, must be on same line as opcode } - if (pai386(hp)^.op1t = top_none) and - ((pai386(hp)^.opcode = A_REP) or - (pai386(hp)^.opcode = A_LOCK) or - (pai386(hp)^.opcode = A_REPE) or - (pai386(hp)^.opcode = A_REPNE)) then - Begin - prefix:=int_op2str[pai386(hp)^.opcode]+#9; - hp:=Pai(hp^.next); - { this is theorically impossible... } - if hp=nil then - begin - s:=#9#9+prefix; - AsmWriteLn(s); - break; - end; - { nasm prefers prefix on a line alone } - AsmWriteln(#9#9+prefix); - prefix:=''; - end - else - prefix:= ''; - { A_FNSTS need the w as suffix at least for nasm} - if (pai386(hp)^.opcode = A_FNSTS) then - pai386(hp)^.opcode:=A_FNSTSW - else - if (pai386(hp)^.opcode = A_FSTS) then - pai386(hp)^.opcode:=A_FSTSW; - if pai386(hp)^.op1t<>top_none then - begin - if pai386(hp)^.opcode=A_CALL then - s:=getopstr_jmp(pai386(hp)^.op1t,pai386(hp)^.op1,pai386(hp)^.op1ofs) - else - begin - s:=getopstr(pai386(hp)^.op1t,pai386(hp)^.op1,pai386(hp)^.op1ofs, - pai386(hp)^.opsize,pai386(hp)^.opcode,false); - if pai386(hp)^.op3t<>top_none then - begin - if pai386(hp)^.op2t<>top_none then -{$ifdef NO_OP3} - s:=getopstr(pai386(hp)^.op2t,pointer(longint(twowords(pai386(hp)^.op2).word1)),0, - pai386(hp)^.opsize,pai386(hp)^.opcode,true)+','+s; - s:=getopstr(pai386(hp)^.op3t,pointer(longint(twowords(pai386(hp)^.op2).word2)),0, - pai386(hp)^.opsize,pai386(hp)^.opcode,false)+','+s; -{$else NO_OP3} - s:=getopstr(pai386(hp)^.op2t,pai386(hp)^.op2,0, - pai386(hp)^.opsize,pai386(hp)^.opcode,true)+','+s; - s:=getopstr(pai386(hp)^.op3t,pai386(hp)^.op3,0, - pai386(hp)^.opsize,pai386(hp)^.opcode,false)+','+s; -{$endif NO_OP3} - end - else - if pai386(hp)^.op2t<>top_none then - s:=getopstr(pai386(hp)^.op2t,pai386(hp)^.op2,0,pai386(hp)^.opsize, - pai386(hp)^.opcode,true)+','+s; - end; - s:=#9+s; - end - else - begin - { check if string instruction } - { long form, otherwise may give range check errors } - { in turbo pascal... } - if ((pai386(hp)^.opcode = A_CMPS) or - (pai386(hp)^.opcode = A_INS) or - (pai386(hp)^.opcode = A_OUTS) or - (pai386(hp)^.opcode = A_SCAS) or - (pai386(hp)^.opcode = A_STOS) or - (pai386(hp)^.opcode = A_MOVS) or - (pai386(hp)^.opcode = A_LODS) or - (pai386(hp)^.opcode = A_XLAT)) then - Begin - case pai386(hp)^.opsize of - S_B: suffix:='b'; - S_W: suffix:='w'; - S_L: suffix:='d'; - else - Message(assem_f_invalid_suffix_intel); - end; - end; - s:=''; - end; - if pai386(hp)^.opcode=A_FWAIT then - AsmWriteln(#9#9'DB'#9'09bh') - else - AsmWriteLn(#9#9+prefix+int_op2str[pai386(hp)^.opcode]+suffix+s); -{$endif OLDASM} - end; -{$ifdef GDB} - ait_stabn, - ait_stabs, - ait_force_line, -ait_stab_function_name : ; -{$endif GDB} - ait_cut : begin - { only reset buffer if nothing has changed } - if AsmSize=AsmStartSize then - AsmClear - else - begin - AsmClose; - DoAssemble; - if pai_cut(hp)^.EndName then - IsEndFile:=true; - AsmCreate; - end; - { avoid empty files } - while assigned(hp^.next) and (pai(hp^.next)^.typ in [ait_cut,ait_section,ait_comment]) do - begin - if pai(hp^.next)^.typ=ait_section then - lastsec:=pai_section(hp^.next)^.sec; - hp:=pai(hp^.next); - end; - if lastsec<>sec_none then - AsmWriteLn('SECTION '+target_asm.secnames[lastsec]); - AsmStartSize:=AsmSize; - end; - ait_marker : ; - else - internalerror(10000); - end; - hp:=pai(hp^.next); - end; - end; - - - procedure ti386nasmasmlist.WriteAsmList; - begin -{$ifdef EXTDEBUG} - if assigned(current_module^.mainsource) then - comment(v_info,'Start writing nasm-styled assembler output for '+current_module^.mainsource^); -{$endif} - LastSec:=sec_none; - AsmWriteLn('BITS 32'); - AsmLn; - - countlabelref:=false; - WriteTree(externals); - { Nasm doesn't support stabs - WriteTree(debuglist);} - - WriteTree(codesegment); - WriteTree(datasegment); - WriteTree(consts); - WriteTree(rttilist); - WriteTree(bsssegment); - countlabelref:=true; - - AsmLn; -{$ifdef EXTDEBUG} - if assigned(current_module^.mainsource) then - comment(v_info,'Done writing nasm-styled assembler output for '+current_module^.mainsource^); -{$endif EXTDEBUG} - end; - -end. -{ +{ + $Id$ + Copyright (c) 1996,97 by Florian Klaempfl + + This unit implements an asmoutput class for the Nasm assembler with + Intel syntax for the i386+ + + 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} + {$N+,E+} +{$endif} +unit ag386nsm; + + interface + + uses aasm,assemble; + + type + pi386nasmasmlist=^ti386nasmasmlist; + ti386nasmasmlist = object(tasmlist) + procedure WriteTree(p:paasmoutput);virtual; + procedure WriteAsmList;virtual; + end; + + implementation + + uses + dos,strings, + globtype,globals,systems,cobjects, + files,verbose +{$ifndef OLDASM} + ,i386base,i386asm +{$else} + ,i386 +{$endif} +{$ifdef GDB} + ,gdb +{$endif GDB} + ; + + const + line_length = 70; + +{$ifndef NEWLAB} + extstr : array[EXT_NEAR..EXT_ABS] of String[8] = + ('NEAR','FAR','PROC','BYTE','WORD','DWORD', + 'CODEPTR','DATAPTR','FWORD','PWORD','QWORD','TBYTE','ABS'); +{$endif} + + function single2str(d : single) : string; + var + hs : string; + p : byte; + begin + str(d,hs); + { nasm expects a lowercase e } + p:=pos('E',hs); + if p>0 then + hs[p]:='e'; + p:=pos('+',hs); + if p>0 then + delete(hs,p,1); + single2str:=lower(hs); + end; + + function double2str(d : double) : string; + var + hs : string; + p : byte; + begin + str(d,hs); + { nasm expects a lowercase e } + p:=pos('E',hs); + if p>0 then + hs[p]:='e'; + p:=pos('+',hs); + if p>0 then + delete(hs,p,1); + double2str:=lower(hs); + end; + + function extended2str(e : extended) : string; + var + hs : string; + p : byte; + begin + str(e,hs); + { nasm expects a lowercase e } + p:=pos('E',hs); + if p>0 then + hs[p]:='e'; + p:=pos('+',hs); + if p>0 then + delete(hs,p,1); + extended2str:=lower(hs); + end; + + + function comp2str(d : bestreal) : string; + type + pdouble = ^double; + var + c : comp; + dd : pdouble; + begin +{$ifdef FPC} + c:=comp(d); +{$else} + c:=d; +{$endif} + dd:=pdouble(@c); { this makes a bitwise copy of c into a double } + comp2str:=double2str(dd^); + end; + + + function getreferencestring(const ref : treference) : string; + var + s : string; + first : boolean; + begin + if ref.is_immediate then + begin + getreferencestring:=tostr(ref.offset); + exit; + end + else + with ref do + begin + first:=true; + if ref.segment<>R_NO then + s:='['+int_reg2str[segment]+':' + else + s:='['; + if assigned(symbol) then + begin + s:=s+symbol^.name; + first:=false; + end; + if (base<>R_NO) then + begin + if not(first) then + s:=s+'+' + else + first:=false; + s:=s+int_reg2str[base]; + end; + if (index<>R_NO) then + begin + if not(first) then + s:=s+'+' + else + first:=false; + s:=s+int_reg2str[index]; + if scalefactor<>0 then + s:=s+'*'+tostr(scalefactor); + end; + if offset<0 then + s:=s+tostr(offset) + else if (offset>0) then + s:=s+'+'+tostr(offset); + s:=s+']'; + end; + getreferencestring:=s; + end; + +{$ifndef OLDASM} + + function getopstr(const o:toper;s : topsize; opcode: tasmop;dest : boolean) : string; + var + hs : string; + begin + case o.typ of + top_reg : + getopstr:=int_nasmreg2str[o.reg]; + top_const : + getopstr:=tostr(o.val); + top_symbol : + begin + if assigned(o.sym) then + hs:='dword '+o.sym^.name + else + hs:='dword '; + if o.symofs>0 then + hs:=hs+'+'+tostr(o.symofs) + else + if o.symofs<0 then + hs:=hs+tostr(o.symofs) + else + if not(assigned(o.sym)) then + hs:=hs+'0'; + getopstr:=hs; + end; + top_ref : + begin + hs:=getreferencestring(o.ref^); + if not ((opcode = A_LEA) or (opcode = A_LGS) or + (opcode = A_LSS) or (opcode = A_LFS) or + (opcode = A_LES) or (opcode = A_LDS) or + (opcode = A_SHR) or (opcode = A_SHL) or + (opcode = A_SAR) or (opcode = A_SAL) or + (opcode = A_OUT) or (opcode = A_IN)) then + begin + case s of + S_B : hs:='byte '+hs; + S_W : hs:='word '+hs; + S_L : hs:='dword '+hs; + S_IS : hs:='word '+hs; + S_IL : hs:='dword '+hs; + S_IQ : hs:='qword '+hs; + S_FS : hs:='dword '+hs; + S_FL : hs:='qword '+hs; + S_FX : hs:='tword '+hs; + S_BW : if dest then + hs:='word '+hs + else + hs:='byte '+hs; + S_BL : if dest then + hs:='dword '+hs + else + hs:='byte '+hs; + S_WL : if dest then + hs:='dword '+hs + else + hs:='word '+hs; + end + end; + getopstr:=hs; + end; + else + internalerror(10001); + end; + end; + + function getopstr_jmp(const o:toper) : string; + var + hs : string; + begin + case o.typ of + top_reg : + getopstr_jmp:=int_nasmreg2str[o.reg]; + top_ref : + getopstr_jmp:=getreferencestring(o.ref^); + top_const : + getopstr_jmp:=tostr(o.val); + top_symbol : + begin + hs:=o.sym^.name; + if o.symofs>0 then + hs:=hs+'+'+tostr(o.symofs) + else + if o.symofs<0 then + hs:=hs+tostr(o.symofs); + getopstr_jmp:=hs; + end; + else + internalerror(10001); + end; + end; + +{$else} + + function getopstr(t : byte;o : pointer;opofs:longint;s : topsize; opcode: tasmop;dest : boolean) : string; + var + hs : string; + begin + case t of + top_reg : getopstr:=int_nasmreg2str[tregister(o)]; + top_const, + top_ref : begin + if t=top_const then + hs := tostr(longint(o)) + else + hs:=getreferencestring(preference(o)^); + if not ((opcode = A_LEA) or (opcode = A_LGS) or + (opcode = A_LSS) or (opcode = A_LFS) or + (opcode = A_LES) or (opcode = A_LDS) or + (opcode = A_SHR) or (opcode = A_SHL) or + (opcode = A_SAR) or (opcode = A_SAL) or + (opcode = A_OUT) or (opcode = A_IN)) then + begin + case s of + S_B : hs:='byte '+hs; + S_W : hs:='word '+hs; + S_L : hs:='dword '+hs; + S_IS : hs:='word '+hs; + S_IL : hs:='dword '+hs; + S_IQ : hs:='qword '+hs; + S_FS : hs:='dword '+hs; + S_FL : hs:='qword '+hs; + S_FX : hs:='tword '+hs; + S_BW : if dest then + hs:='word '+hs + else + hs:='byte '+hs; + S_BL : if dest then + hs:='dword '+hs + else + hs:='byte '+hs; + S_WL : if dest then + hs:='dword '+hs + else + hs:='word '+hs; + end + end; + getopstr:=hs; + end; + top_symbol : begin + hs:='dword '+pasmsymbol(o)^.name; + if opofs>0 then + hs:=hs+'+'+tostr(opofs) + else + if opofs<0 then + hs:=hs+tostr(opofs); + getopstr:=hs; + end; + else + internalerror(10001); + end; + end; + + function getopstr_jmp(t : byte;o : pointer;opofs:longint) : string; + var + hs : string; + begin + case t of + top_reg : getopstr_jmp:=int_reg2str[tregister(o)]; + top_ref : getopstr_jmp:=getreferencestring(preference(o)^); + top_const : getopstr_jmp:=tostr(longint(o)); + top_symbol : begin + hs:=pasmsymbol(o)^.name; + if opofs>0 then + hs:=hs+'+'+tostr(opofs) + else + if opofs<0 then + hs:=hs+tostr(opofs); + getopstr_jmp:=hs; + end; + else + internalerror(10001); + end; + end; + +{$endif} + + +{**************************************************************************** + Ti386nasmasmlist + ****************************************************************************} + + var + LastSec : tsection; + + const + ait_const2str:array[ait_const_32bit..ait_const_8bit] of string[8]= + (#9'DD'#9,#9'DW'#9,#9'DB'#9); + + Function PadTabs(const p:string;addch:char):string; + var + s : string; + i : longint; + begin + i:=length(p); + if addch<>#0 then + begin + inc(i); + s:=p+addch; + end + else + s:=p; + if i<8 then + PadTabs:=s+#9#9 + else + PadTabs:=s+#9; + end; + + + procedure ti386nasmasmlist.WriteTree(p:paasmoutput); + type + twowords=record + word1,word2:word; + end; + var + s, + prefix, + suffix : string; + hp : pai; + counter, + lines, + i,j,l : longint; + op : tasmop; + consttyp : tait; + found, + quoted : boolean; +{$ifndef OLDASM} + sep : char; +{$endif} + begin + if not assigned(p) then + exit; + hp:=pai(p^.first); + while assigned(hp) do + begin + case hp^.typ of + ait_comment : Begin + AsmWrite(target_asm.comment); + AsmWritePChar(pai_asm_comment(hp)^.str); + AsmLn; + End; + ait_regalloc, + ait_tempalloc : ; + ait_section : begin + if pai_section(hp)^.sec<>sec_none then + begin + AsmLn; + AsmWriteLn('SECTION '+target_asm.secnames[pai_section(hp)^.sec]); + end; + LastSec:=pai_section(hp)^.sec; + end; + ait_align : AsmWriteLn(#9'ALIGN '+tostr(pai_align(hp)^.aligntype)); +{$ifndef NEWLAB} + ait_external : AsmWriteLn('EXTERN '+pai_external(hp)^.sym^.name); +{$endif} + ait_datablock : begin + if pai_datablock(hp)^.is_global then + AsmWriteLn(#9'GLOBAL '+pai_datablock(hp)^.sym^.name); + AsmWriteLn(PadTabs(pai_datablock(hp)^.sym^.name,':')+'RESB'#9+tostr(pai_datablock(hp)^.size)); + end; + ait_const_32bit, + ait_const_8bit, + ait_const_16bit : begin + AsmWrite(ait_const2str[hp^.typ]+tostr(pai_const(hp)^.value)); + consttyp:=hp^.typ; + l:=0; + repeat + found:=(not (Pai(hp^.next)=nil)) and (Pai(hp^.next)^.typ=consttyp); + if found then + begin + hp:=Pai(hp^.next); + s:=','+tostr(pai_const(hp)^.value); + AsmWrite(s); + inc(l,length(s)); + end; + until (not found) or (l>line_length); + AsmLn; + end; + ait_const_symbol : begin + AsmWriteLn(#9#9'DD'#9+pai_const_symbol(hp)^.sym^.name); + if pai_const_symbol(hp)^.offset>0 then + AsmWrite('+'+tostr(pai_const_symbol(hp)^.offset)) + else if pai_const_symbol(hp)^.offset<0 then + AsmWrite(tostr(pai_const_symbol(hp)^.offset)); + AsmLn; + end; + ait_const_rva : begin + AsmWriteLn(#9#9'RVA'#9+pai_const_symbol(hp)^.sym^.name); + end; + ait_real_32bit : AsmWriteLn(#9#9'DD'#9+single2str(pai_real_32bit(hp)^.value)); + ait_real_64bit : AsmWriteLn(#9#9'DQ'#9+double2str(pai_real_64bit(hp)^.value)); + ait_real_80bit : AsmWriteLn(#9#9'DT'#9+extended2str(pai_real_80bit(hp)^.value)); + ait_comp_64bit : AsmWriteLn(#9#9'DQ'#9+comp2str(pai_real_80bit(hp)^.value)); + ait_string : begin + counter := 0; + lines := pai_string(hp)^.len div line_length; + { separate lines in different parts } + if pai_string(hp)^.len > 0 then + Begin + for j := 0 to lines-1 do + begin + AsmWrite(#9#9'DB'#9); + quoted:=false; + for i:=counter to counter+line_length do + begin + { it is an ascii character. } + if (ord(pai_string(hp)^.str[i])>31) and + (ord(pai_string(hp)^.str[i])<128) and + (pai_string(hp)^.str[i]<>'"') then + begin + if not(quoted) then + begin + if i>counter then + AsmWrite(','); + AsmWrite('"'); + end; + AsmWrite(pai_string(hp)^.str[i]); + quoted:=true; + end { if > 31 and < 128 and ord('"') } + else + begin + if quoted then + AsmWrite('"'); + if i>counter then + AsmWrite(','); + quoted:=false; + AsmWrite(tostr(ord(pai_string(hp)^.str[i]))); + end; + end; { end for i:=0 to... } + if quoted then AsmWrite('"'); + AsmWrite(target_os.newline); + counter := counter+line_length; + end; { end for j:=0 ... } + { do last line of lines } + AsmWrite(#9#9'DB'#9); + quoted:=false; + for i:=counter to pai_string(hp)^.len-1 do + begin + { it is an ascii character. } + if (ord(pai_string(hp)^.str[i])>31) and + (ord(pai_string(hp)^.str[i])<128) and + (pai_string(hp)^.str[i]<>'"') then + begin + if not(quoted) then + begin + if i>counter then + AsmWrite(','); + AsmWrite('"'); + end; + AsmWrite(pai_string(hp)^.str[i]); + quoted:=true; + end { if > 31 and < 128 and " } + else + begin + if quoted then + AsmWrite('"'); + if i>counter then + AsmWrite(','); + quoted:=false; + AsmWrite(tostr(ord(pai_string(hp)^.str[i]))); + end; + end; { end for i:=0 to... } + if quoted then + AsmWrite('"'); + end; + AsmLn; + end; +{$ifndef NEWLAB} + ait_label : begin + if pai_label(hp)^.l^.is_used then + AsmWriteLn(lab2str(pai_label(hp)^.l)+':'); + end; +{$endif} + ait_direct : begin + AsmWritePChar(pai_direct(hp)^.str); + AsmLn; + end; +{$ifndef NEWLAB} +ait_labeled_instruction : + begin + op:=pai386_labeled(hp)^.opcode; + if not((op=A_JMP) or (op=A_LOOP) or (op=A_LOOPZ) or + (op=A_LOOPE) or (op=A_LOOPNZ) or (op=A_LOOPNE) or + (op=A_JCXZ) or (op=A_JECXZ)) then + AsmWriteLn(#9#9+int_op2str[pai386_labeled(hp)^.opcode]+ + cond2str[pai386_labeled(hp)^.condition]+#9+'near '+lab2str(pai386_labeled(hp)^.lab)) + else + AsmWriteLn(#9#9+int_op2str[pai386_labeled(hp)^.opcode]+ + cond2str[pai386_labeled(hp)^.condition]+#9+lab2str(pai386_labeled(hp)^.lab)); + end; +{$endif} + ait_symbol : begin + if pai_symbol(hp)^.is_global then + AsmWriteLn(#9'GLOBAL '+pai_symbol(hp)^.sym^.name); + AsmWrite(pai_symbol(hp)^.sym^.name); + if assigned(hp^.next) and not(pai(hp^.next)^.typ in + [ait_const_32bit,ait_const_16bit,ait_const_8bit, + ait_const_symbol,ait_const_rva, + ait_real_32bit,ait_real_64bit,ait_real_80bit,ait_comp_64bit,ait_string]) then + AsmWriteLn(':') + end; + ait_instruction : begin + suffix:=''; + prefix:=''; + s:=''; +{$ifndef OLDASM} + if pai386(hp)^.ops<>0 then + begin + if pai386(hp)^.opcode=A_CALL then + s:=#9+getopstr_jmp(pai386(hp)^.oper[0]) + else + begin + for i:=0to pai386(hp)^.ops-1 do + begin + if i=0 then + sep:=#9 + else + sep:=','; + s:=s+sep+getopstr(pai386(hp)^.oper[i],pai386(hp)^.opsize,pai386(hp)^.opcode,(i=1)); + end; + end; + end; + if pai386(hp)^.opcode=A_FWAIT then + AsmWriteln(#9#9'DB'#9'09bh') + else + AsmWriteLn(#9#9+prefix+int_op2str[pai386(hp)^.opcode]+ + cond2str[pai386(hp)^.condition]+suffix+s); +{$else} + { added prefix instructions, must be on same line as opcode } + if (pai386(hp)^.op1t = top_none) and + ((pai386(hp)^.opcode = A_REP) or + (pai386(hp)^.opcode = A_LOCK) or + (pai386(hp)^.opcode = A_REPE) or + (pai386(hp)^.opcode = A_REPNE)) then + Begin + prefix:=int_op2str[pai386(hp)^.opcode]+#9; + hp:=Pai(hp^.next); + { this is theorically impossible... } + if hp=nil then + begin + s:=#9#9+prefix; + AsmWriteLn(s); + break; + end; + { nasm prefers prefix on a line alone } + AsmWriteln(#9#9+prefix); + prefix:=''; + end + else + prefix:= ''; + { A_FNSTS need the w as suffix at least for nasm} + if (pai386(hp)^.opcode = A_FNSTS) then + pai386(hp)^.opcode:=A_FNSTSW + else + if (pai386(hp)^.opcode = A_FSTS) then + pai386(hp)^.opcode:=A_FSTSW; + if pai386(hp)^.op1t<>top_none then + begin + if pai386(hp)^.opcode=A_CALL then + s:=getopstr_jmp(pai386(hp)^.op1t,pai386(hp)^.op1,pai386(hp)^.op1ofs) + else + begin + s:=getopstr(pai386(hp)^.op1t,pai386(hp)^.op1,pai386(hp)^.op1ofs, + pai386(hp)^.opsize,pai386(hp)^.opcode,false); + if pai386(hp)^.op3t<>top_none then + begin + if pai386(hp)^.op2t<>top_none then +{$ifdef NO_OP3} + s:=getopstr(pai386(hp)^.op2t,pointer(longint(twowords(pai386(hp)^.op2).word1)),0, + pai386(hp)^.opsize,pai386(hp)^.opcode,true)+','+s; + s:=getopstr(pai386(hp)^.op3t,pointer(longint(twowords(pai386(hp)^.op2).word2)),0, + pai386(hp)^.opsize,pai386(hp)^.opcode,false)+','+s; +{$else NO_OP3} + s:=getopstr(pai386(hp)^.op2t,pai386(hp)^.op2,0, + pai386(hp)^.opsize,pai386(hp)^.opcode,true)+','+s; + s:=getopstr(pai386(hp)^.op3t,pai386(hp)^.op3,0, + pai386(hp)^.opsize,pai386(hp)^.opcode,false)+','+s; +{$endif NO_OP3} + end + else + if pai386(hp)^.op2t<>top_none then + s:=getopstr(pai386(hp)^.op2t,pai386(hp)^.op2,0,pai386(hp)^.opsize, + pai386(hp)^.opcode,true)+','+s; + end; + s:=#9+s; + end + else + begin + { check if string instruction } + { long form, otherwise may give range check errors } + { in turbo pascal... } + if ((pai386(hp)^.opcode = A_CMPS) or + (pai386(hp)^.opcode = A_INS) or + (pai386(hp)^.opcode = A_OUTS) or + (pai386(hp)^.opcode = A_SCAS) or + (pai386(hp)^.opcode = A_STOS) or + (pai386(hp)^.opcode = A_MOVS) or + (pai386(hp)^.opcode = A_LODS) or + (pai386(hp)^.opcode = A_XLAT)) then + Begin + case pai386(hp)^.opsize of + S_B: suffix:='b'; + S_W: suffix:='w'; + S_L: suffix:='d'; + else + Message(assem_f_invalid_suffix_intel); + end; + end; + s:=''; + end; + if pai386(hp)^.opcode=A_FWAIT then + AsmWriteln(#9#9'DB'#9'09bh') + else + AsmWriteLn(#9#9+prefix+int_op2str[pai386(hp)^.opcode]+suffix+s); +{$endif OLDASM} + end; +{$ifdef GDB} + ait_stabn, + ait_stabs, + ait_force_line, +ait_stab_function_name : ; +{$endif GDB} + ait_cut : begin + { only reset buffer if nothing has changed } + if AsmSize=AsmStartSize then + AsmClear + else + begin + AsmClose; + DoAssemble; + if pai_cut(hp)^.EndName then + IsEndFile:=true; + AsmCreate; + end; + { avoid empty files } + while assigned(hp^.next) and (pai(hp^.next)^.typ in [ait_cut,ait_section,ait_comment]) do + begin + if pai(hp^.next)^.typ=ait_section then + lastsec:=pai_section(hp^.next)^.sec; + hp:=pai(hp^.next); + end; + if lastsec<>sec_none then + AsmWriteLn('SECTION '+target_asm.secnames[lastsec]); + AsmStartSize:=AsmSize; + end; + ait_marker : ; + else + internalerror(10000); + end; + hp:=pai(hp^.next); + end; + end; + + + procedure ti386nasmasmlist.WriteAsmList; + begin +{$ifdef EXTDEBUG} + if assigned(current_module^.mainsource) then + comment(v_info,'Start writing nasm-styled assembler output for '+current_module^.mainsource^); +{$endif} + LastSec:=sec_none; + AsmWriteLn('BITS 32'); + AsmLn; + + countlabelref:=false; + WriteTree(externals); + { Nasm doesn't support stabs + WriteTree(debuglist);} + + WriteTree(codesegment); + WriteTree(datasegment); + WriteTree(consts); + WriteTree(rttilist); + WriteTree(bsssegment); + countlabelref:=true; + + AsmLn; +{$ifdef EXTDEBUG} + if assigned(current_module^.mainsource) then + comment(v_info,'Done writing nasm-styled assembler output for '+current_module^.mainsource^); +{$endif EXTDEBUG} + end; + +end. +{ $Log$ - Revision 1.38 1999-05-21 13:54:43 peter + Revision 1.39 1999-05-23 18:41:57 florian + * better error recovering in typed constants + * some problems with arrays of const fixed, some problems + due my previous + - the location type of array constructor is now LOC_MEM + - the pushing of high fixed + - parameter copying fixed + - zero temp. allocation removed + * small problem in the assembler writers fixed: + ref to nil wasn't written correctly + + Revision 1.38 1999/05/21 13:54:43 peter * NEWLAB for label as symbol - - Revision 1.37 1999/05/12 00:19:39 peter - * removed R_DEFAULT_SEG - * uniform float names - - Revision 1.36 1999/05/11 16:28:16 peter - * long lines fixed - - Revision 1.35 1999/05/10 15:18:16 peter - * fixed condition writing - - Revision 1.34 1999/05/08 19:52:34 peter - + MessagePos() which is enhanced Message() function but also gets the - position info - * Removed comp warnings - - Revision 1.33 1999/05/07 00:08:48 pierre - * AG386BIN cond -> OLDASM, only cosmetic - - Revision 1.32 1999/05/06 09:05:11 peter - * generic write_float and str_float - * fixed constant float conversions - - Revision 1.31 1999/05/04 21:44:32 florian - * changes to compile it with Delphi 4.0 - - Revision 1.30 1999/05/02 22:41:50 peter - * moved section names to systems - * fixed nasm,intel writer - - Revision 1.29 1999/05/01 13:23:59 peter - * merged nasm compiler - * old asm moved to oldasm/ - - Revision 1.28 1999/04/17 22:17:06 pierre - * ifdef USE_OP3 released (changed into ifndef NO_OP3) - * SHRD and SHLD first operand (ATT syntax) can only be CL reg or immediate const - - Revision 1.27 1999/04/16 11:49:40 peter - + tempalloc - + -at to show temp alloc info in .s file - - Revision 1.26 1999/04/16 10:00:56 pierre - + ifdef USE_OP3 code : - added all missing op_... constructors for tai386 needed - for SHRD,SHLD and IMUL code in assembler readers - (check in tests/tbs0123.pp) - - Revision 1.25 1999/03/29 16:05:44 peter - * optimizer working for ag386bin - - Revision 1.24 1999/03/10 13:25:44 pierre - section order changed to get closer output from coff writer - - Revision 1.23 1999/03/04 13:55:39 pierre - * some m68k fixes (still not compilable !) - * new(tobj) does not give warning if tobj has no VMT ! - - Revision 1.22 1999/03/02 02:56:11 peter - + stabs support for binary writers - * more fixes and missing updates from the previous commit :( - - Revision 1.21 1999/03/01 15:46:17 peter - * ag386bin finally make cycles correct - * prefixes are now also normal opcodes - - Revision 1.20 1999/02/26 00:48:14 peter - * assembler writers fixed for ag386bin - - Revision 1.19 1999/02/25 21:02:19 peter - * ag386bin updates - + coff writer - - Revision 1.18 1999/02/22 02:15:00 peter - * updates for ag386bin - - Revision 1.17 1998/12/20 16:21:23 peter - * smartlinking doesn't crash anymore - - Revision 1.16 1998/12/16 00:27:18 peter - * removed some obsolete version checks - - Revision 1.15 1998/12/01 11:19:39 peter - * fixed range problem with in [tasmop] - - Revision 1.14 1998/11/30 09:42:56 pierre - * some range check bugs fixed (still not working !) - + added DLL writing support for win32 (also accepts variables) - + TempAnsi for code that could be used for Temporary ansi strings - handling - - Revision 1.13 1998/11/17 00:26:10 peter - * fixed for $H+ - - Revision 1.12 1998/11/12 11:19:34 pierre - * fix for first line of function break - - Revision 1.11 1998/10/12 12:20:42 pierre - + added tai_const_symbol_offset - for r : pointer = @var.field; - * better message for different arg names on implementation - of function - - Revision 1.10 1998/10/06 17:16:34 pierre - * some memory leaks fixed (thanks to Peter for heaptrc !) - - Revision 1.9 1998/10/01 20:19:07 jonas - + ait_marker support - - Revision 1.8 1998/09/20 17:11:22 jonas - * released REGALLOC - - Revision 1.7 1998/08/11 14:01:43 peter - * fixed fwait bug using direct opcode - - Revision 1.6 1998/08/10 15:49:39 peter - * small fixes for 0.99.5 - - Revision 1.5 1998/08/08 10:19:18 florian - * small fixes to write the extended type correct - - Revision 1.4 1998/06/05 17:46:03 peter - * tp doesn't like comp() typecast - - Revision 1.3 1998/05/28 17:24:27 peter - - $R- for tp to solve range errors with in[] - - Revision 1.2 1998/05/25 17:11:37 pierre - * firstpasscount bug fixed - now all is already set correctly the first time - under EXTDEBUG try -gp to skip all other firstpasses - it works !! - * small bug fixes - - for smallsets with -dTESTSMALLSET - - some warnings removed (by correcting code !) - - Revision 1.1 1998/05/23 01:20:56 peter - + aktasmmode, aktoptprocessor, aktoutputformat - + smartlink per module $SMARTLINK-/+ (like MMX) and moved to aktswitches - + $LIBNAME to set the library name where the unit will be put in - * splitted cgi386 a bit (codeseg to large for bp7) - * nasm, tasm works again. nasm moved to ag386nsm.pas - -} + + Revision 1.37 1999/05/12 00:19:39 peter + * removed R_DEFAULT_SEG + * uniform float names + + Revision 1.36 1999/05/11 16:28:16 peter + * long lines fixed + + Revision 1.35 1999/05/10 15:18:16 peter + * fixed condition writing + + Revision 1.34 1999/05/08 19:52:34 peter + + MessagePos() which is enhanced Message() function but also gets the + position info + * Removed comp warnings + + Revision 1.33 1999/05/07 00:08:48 pierre + * AG386BIN cond -> OLDASM, only cosmetic + + Revision 1.32 1999/05/06 09:05:11 peter + * generic write_float and str_float + * fixed constant float conversions + + Revision 1.31 1999/05/04 21:44:32 florian + * changes to compile it with Delphi 4.0 + + Revision 1.30 1999/05/02 22:41:50 peter + * moved section names to systems + * fixed nasm,intel writer + + Revision 1.29 1999/05/01 13:23:59 peter + * merged nasm compiler + * old asm moved to oldasm/ + + Revision 1.28 1999/04/17 22:17:06 pierre + * ifdef USE_OP3 released (changed into ifndef NO_OP3) + * SHRD and SHLD first operand (ATT syntax) can only be CL reg or immediate const + + Revision 1.27 1999/04/16 11:49:40 peter + + tempalloc + + -at to show temp alloc info in .s file + + Revision 1.26 1999/04/16 10:00:56 pierre + + ifdef USE_OP3 code : + added all missing op_... constructors for tai386 needed + for SHRD,SHLD and IMUL code in assembler readers + (check in tests/tbs0123.pp) + + Revision 1.25 1999/03/29 16:05:44 peter + * optimizer working for ag386bin + + Revision 1.24 1999/03/10 13:25:44 pierre + section order changed to get closer output from coff writer + + Revision 1.23 1999/03/04 13:55:39 pierre + * some m68k fixes (still not compilable !) + * new(tobj) does not give warning if tobj has no VMT ! + + Revision 1.22 1999/03/02 02:56:11 peter + + stabs support for binary writers + * more fixes and missing updates from the previous commit :( + + Revision 1.21 1999/03/01 15:46:17 peter + * ag386bin finally make cycles correct + * prefixes are now also normal opcodes + + Revision 1.20 1999/02/26 00:48:14 peter + * assembler writers fixed for ag386bin + + Revision 1.19 1999/02/25 21:02:19 peter + * ag386bin updates + + coff writer + + Revision 1.18 1999/02/22 02:15:00 peter + * updates for ag386bin + + Revision 1.17 1998/12/20 16:21:23 peter + * smartlinking doesn't crash anymore + + Revision 1.16 1998/12/16 00:27:18 peter + * removed some obsolete version checks + + Revision 1.15 1998/12/01 11:19:39 peter + * fixed range problem with in [tasmop] + + Revision 1.14 1998/11/30 09:42:56 pierre + * some range check bugs fixed (still not working !) + + added DLL writing support for win32 (also accepts variables) + + TempAnsi for code that could be used for Temporary ansi strings + handling + + Revision 1.13 1998/11/17 00:26:10 peter + * fixed for $H+ + + Revision 1.12 1998/11/12 11:19:34 pierre + * fix for first line of function break + + Revision 1.11 1998/10/12 12:20:42 pierre + + added tai_const_symbol_offset + for r : pointer = @var.field; + * better message for different arg names on implementation + of function + + Revision 1.10 1998/10/06 17:16:34 pierre + * some memory leaks fixed (thanks to Peter for heaptrc !) + + Revision 1.9 1998/10/01 20:19:07 jonas + + ait_marker support + + Revision 1.8 1998/09/20 17:11:22 jonas + * released REGALLOC + + Revision 1.7 1998/08/11 14:01:43 peter + * fixed fwait bug using direct opcode + + Revision 1.6 1998/08/10 15:49:39 peter + * small fixes for 0.99.5 + + Revision 1.5 1998/08/08 10:19:18 florian + * small fixes to write the extended type correct + + Revision 1.4 1998/06/05 17:46:03 peter + * tp doesn't like comp() typecast + + Revision 1.3 1998/05/28 17:24:27 peter + - $R- for tp to solve range errors with in[] + + Revision 1.2 1998/05/25 17:11:37 pierre + * firstpasscount bug fixed + now all is already set correctly the first time + under EXTDEBUG try -gp to skip all other firstpasses + it works !! + * small bug fixes + - for smallsets with -dTESTSMALLSET + - some warnings removed (by correcting code !) + + Revision 1.1 1998/05/23 01:20:56 peter + + aktasmmode, aktoptprocessor, aktoutputformat + + smartlink per module $SMARTLINK-/+ (like MMX) and moved to aktswitches + + $LIBNAME to set the library name where the unit will be put in + * splitted cgi386 a bit (codeseg to large for bp7) + * nasm, tasm works again. nasm moved to ag386nsm.pas + +} diff --git a/compiler/cg386cal.pas b/compiler/cg386cal.pas index cd73c4bdf1..a686885c73 100644 --- a/compiler/cg386cal.pas +++ b/compiler/cg386cal.pas @@ -1,1542 +1,1553 @@ -{ - $Id$ - Copyright (c) 1993-98 by Florian Klaempfl - - Generate i386 assembler for in call nodes - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - - **************************************************************************** -} -unit cg386cal; -interface - -{ $define AnsiStrRef} - - uses - symtable,tree; - - procedure secondcallparan(var p : ptree;defcoll : pdefcoll; - push_from_left_to_right,inlined,dword_align : boolean;para_offset : longint); - procedure secondcalln(var p : ptree); - procedure secondprocinline(var p : ptree); - - -implementation - - uses - globtype,systems, - cobjects,verbose,globals, - aasm,types, -{$ifdef GDB} - gdb, -{$endif GDB} - hcodegen,temp_gen,pass_2, -{$ifndef OLDASM} - i386base,i386asm, -{$else} - i386, -{$endif} - cgai386,tgeni386,cg386ld; - -{***************************************************************************** - SecondCallParaN -*****************************************************************************} - - procedure secondcallparan(var p : ptree;defcoll : pdefcoll; - push_from_left_to_right,inlined,dword_align : boolean;para_offset : longint); - - procedure maybe_push_high; - begin - { open array ? } - { defcoll^.data can be nil for read/write } - if assigned(defcoll^.data) and - push_high_param(defcoll^.data) then - begin - if assigned(p^.hightree) then - begin - secondpass(p^.hightree); - { this is a longint anyway ! } - push_value_para(p^.hightree,inlined,para_offset,4); - end - else - internalerror(432645); - end; - end; - - var - otlabel,oflabel : plabel; - align : longint; - { temporary variables: } - tempdeftype : tdeftype; - r : preference; - begin - { push from left to right if specified } - if push_from_left_to_right and assigned(p^.right) then - secondcallparan(p^.right,defcoll^.next,push_from_left_to_right, - inlined,dword_align,para_offset); - otlabel:=truelabel; - oflabel:=falselabel; - getlabel(truelabel); - getlabel(falselabel); - secondpass(p^.left); - { filter array constructor with c styled args } - if is_array_constructor(p^.left^.resulttype) and p^.left^.cargs then - begin - { nothing, everything is already pushed } - end - { in codegen.handleread.. defcoll^.data is set to nil } - else if assigned(defcoll^.data) and - (defcoll^.data^.deftype=formaldef) then - begin - { allow @var } - inc(pushedparasize,4); - if p^.left^.treetype=addrn then - begin - { always a register } - if inlined then - begin - r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); - exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L, - p^.left^.location.register,r))); - end - else - exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,p^.left^.location.register))); - ungetregister32(p^.left^.location.register); - end - else - begin - if not(p^.left^.location.loc in [LOC_MEM,LOC_REFERENCE]) then - CGMessage(type_e_mismatch) - else - begin - if inlined then - begin - exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L, - newreference(p^.left^.location.reference),R_EDI))); - r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); - exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L,R_EDI,r))); - end - else - emitpushreferenceaddr(exprasmlist,p^.left^.location.reference); - del_reference(p^.left^.location.reference); - end; - end; - end - { handle call by reference parameter } - else if (defcoll^.paratyp=vs_var) then - begin - if (p^.left^.location.loc<>LOC_REFERENCE) then - CGMessage(cg_e_var_must_be_reference); - maybe_push_high; - inc(pushedparasize,4); - if inlined then - begin - exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L, - newreference(p^.left^.location.reference),R_EDI))); - r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); - exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L,R_EDI,r))); - end - else - emitpushreferenceaddr(exprasmlist,p^.left^.location.reference); - del_reference(p^.left^.location.reference); - end - else - begin - tempdeftype:=p^.resulttype^.deftype; - if tempdeftype=filedef then - CGMessage(cg_e_file_must_call_by_reference); - if push_addr_param(p^.resulttype) then - begin - maybe_push_high; - inc(pushedparasize,4); - if inlined then - begin - exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L, - newreference(p^.left^.location.reference),R_EDI))); - r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); - exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L, - R_EDI,r))); - end - else - emitpushreferenceaddr(exprasmlist,p^.left^.location.reference); - del_reference(p^.left^.location.reference); - end - else - begin - align:=target_os.stackalignment; - if dword_align then - align:=4; - push_value_para(p^.left,inlined,para_offset,align); - end; - end; - freelabel(truelabel); - freelabel(falselabel); - truelabel:=otlabel; - falselabel:=oflabel; - { push from right to left } - if not push_from_left_to_right and assigned(p^.right) then - secondcallparan(p^.right,defcoll^.next,push_from_left_to_right, - inlined,dword_align,para_offset); - end; - - -{***************************************************************************** - SecondCallN -*****************************************************************************} - - procedure secondcalln(var p : ptree); - var - unusedregisters : tregisterset; - pushed : tpushed; - hr,funcretref : treference; - hregister,hregister2 : tregister; - oldpushedparasize : longint; - { true if ESI must be loaded again after the subroutine } - loadesi : boolean; - { true if a virtual method must be called directly } - no_virtual_call : boolean; - { true if we produce a con- or destrutor in a call } - is_con_or_destructor : boolean; - { true if a constructor is called again } - extended_new : boolean; - { adress returned from an I/O-error } - iolabel : plabel; - { lexlevel count } - i : longint; - { help reference pointer } - r : preference; - hp, - pp,params : ptree; - inlined : boolean; - inlinecode : ptree; - para_offset : longint; - { instruction for alignement correction } -{ corr : pai386;} - { we must pop this size also after !! } -{ must_pop : boolean; } - pop_size : longint; - - label - dont_call; - - begin - reset_reference(p^.location.reference); - extended_new:=false; - iolabel:=nil; - inlinecode:=nil; - inlined:=false; - loadesi:=true; - no_virtual_call:=false; - unusedregisters:=unused; - - if not assigned(p^.procdefinition) then - exit; - if (p^.procdefinition^.options and poinline)<>0 then - begin - inlined:=true; - inlinecode:=p^.right; - { set it to the same lexical level as the local symtable, becuase - the para's are stored there } - pprocdef(p^.procdefinition)^.parast^.symtablelevel:=aktprocsym^.definition^.localst^.symtablelevel; - if assigned(p^.left) then - inlinecode^.para_offset:=gettempofsizepersistant(inlinecode^.para_size); - pprocdef(p^.procdefinition)^.parast^.address_fixup:=inlinecode^.para_offset; -{$ifdef extdebug} - Comment(V_debug, - 'inlined parasymtable is at offset ' - +tostr(pprocdef(p^.procdefinition)^.parast^.address_fixup)); - exprasmlist^.concat(new(pai_asm_comment,init( - strpnew('inlined parasymtable is at offset ' - +tostr(pprocdef(p^.procdefinition)^.parast^.address_fixup))))); -{$endif extdebug} - p^.right:=nil; - { disable further inlining of the same proc - in the args } - p^.procdefinition^.options:=p^.procdefinition^.options and (not poinline); - end; - { only if no proc var } - if not(assigned(p^.right)) then - is_con_or_destructor:=((p^.procdefinition^.options and poconstructor)<>0) - or ((p^.procdefinition^.options and podestructor)<>0); - { proc variables destroy all registers } - if (p^.right=nil) and - { virtual methods too } - ((p^.procdefinition^.options and povirtualmethod)=0) then - begin - if ((p^.procdefinition^.options and poiocheck)<>0) and - ((aktprocsym^.definition^.options and poiocheck)=0) and - (cs_check_io in aktlocalswitches) then - begin - getlabel(iolabel); - emitlab(iolabel); - end - else - iolabel:=nil; - - { save all used registers } - pushusedregisters(exprasmlist,pushed,pprocdef(p^.procdefinition)^.usedregisters); - - { give used registers through } - usedinproc:=usedinproc or pprocdef(p^.procdefinition)^.usedregisters; - end - else - begin - pushusedregisters(exprasmlist,pushed,$ff); - usedinproc:=$ff; - { no IO check for methods and procedure variables } - iolabel:=nil; - end; - - { generate the code for the parameter and push them } - oldpushedparasize:=pushedparasize; - pushedparasize:=0; - pop_size:=0; - if (not inlined) then - begin - { Old pushedsize aligned on 4 ? } - i:=oldpushedparasize and 3; - if i>0 then - inc(pop_size,4-i); - { This parasize aligned on 4 ? } - i:=p^.procdefinition^.para_size and 3; - if i>0 then - inc(pop_size,4-i); - { insert the opcode and update pushedparasize } - if pop_size>0 then - begin - inc(pushedparasize,pop_size); - exprasmlist^.concat(new(pai386,op_const_reg(A_SUB,S_L,pop_size,R_ESP))); -{$ifdef GDB} - if (cs_debuginfo in aktmoduleswitches) and - (exprasmlist^.first=exprasmlist^.last) then - exprasmlist^.concat(new(pai_force_line,init)); -{$endif GDB} - end; - end; - - if (p^.resulttype<>pdef(voiddef)) and - ret_in_param(p^.resulttype) then - begin - funcretref.symbol:=nil; -{$ifdef test_dest_loc} - if dest_loc_known and (dest_loc_tree=p) and - (dest_loc.loc in [LOC_REFERENCE,LOC_MEM]) then - begin - funcretref:=dest_loc.reference; - if assigned(dest_loc.reference.symbol) then - funcretref.symbol:=stringdup(dest_loc.reference.symbol^); - in_dest_loc:=true; - end - else -{$endif test_dest_loc} - if inlined then - begin - reset_reference(funcretref); - funcretref.offset:=gettempofsizepersistant(p^.procdefinition^.retdef^.size); - funcretref.base:=procinfo.framepointer; - end - else - gettempofsizereference(p^.procdefinition^.retdef^.size,funcretref); - end; - if assigned(p^.left) then - begin - { be found elsewhere } - if inlined then - para_offset:=pprocdef(p^.procdefinition)^.parast^.address_fixup+ - pprocdef(p^.procdefinition)^.parast^.datasize - else - para_offset:=0; - if assigned(p^.right) then - secondcallparan(p^.left,pabstractprocdef(p^.right^.resulttype)^.para1, - (p^.procdefinition^.options and poleftright)<>0, - inlined,(p^.procdefinition^.options and (pocdecl or postdcall))<>0,para_offset) - else - secondcallparan(p^.left,p^.procdefinition^.para1, - (p^.procdefinition^.options and poleftright)<>0, - inlined,(p^.procdefinition^.options and (pocdecl or postdcall))<>0,para_offset); - end; - params:=p^.left; - p^.left:=nil; - if inlined then - inlinecode^.retoffset:=gettempofsizepersistant(4); - if ret_in_param(p^.resulttype) then - begin - inc(pushedparasize,4); - if inlined then - begin - exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L, - newreference(funcretref),R_EDI))); - r:=new_reference(procinfo.framepointer,inlinecode^.retoffset); - exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L, - R_EDI,r))); - end - else - emitpushreferenceaddr(exprasmlist,funcretref); - end; - { procedure variable ? } - if (p^.right=nil) then - begin - { overloaded operator have no symtable } - { push self } - if assigned(p^.symtable) and - (p^.symtable^.symtabletype=withsymtable) then - begin - { dirty trick to avoid the secondcall below } - p^.methodpointer:=genzeronode(callparan); - p^.methodpointer^.location.loc:=LOC_REGISTER; - p^.methodpointer^.location.register:=R_ESI; - { ARGHHH this is wrong !!! - if we can init from base class for a child - class that the wrong VMT will be - transfered to constructor !! } - p^.methodpointer^.resulttype:= - ptree(pwithsymtable(p^.symtable)^.withnode)^.left^.resulttype; - { change dispose type !! } - p^.disposetyp:=dt_mbleft_and_method; - { make a reference } - new(r); - reset_reference(r^); - { if assigned(ptree(pwithsymtable(p^.symtable)^.withnode)^.pref) then - begin - r^:=ptree(pwithsymtable(p^.symtable)^.withnode)^.pref^; - end - else - begin - r^.offset:=p^.symtable^.datasize; - r^.base:=procinfo.framepointer; - end; } - r^:=ptree(pwithsymtable(p^.symtable)^.withnode)^.withreference^; - if (not pwithsymtable(p^.symtable)^.direct_with) or - pobjectdef(p^.methodpointer^.resulttype)^.isclass then - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,R_ESI))) - else - exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L,r,R_ESI))); - end; - - { push self } - if assigned(p^.symtable) and - ((p^.symtable^.symtabletype=objectsymtable) or - (p^.symtable^.symtabletype=withsymtable)) then - begin - if assigned(p^.methodpointer) then - begin - { - if p^.methodpointer^.resulttype=classrefdef then - begin - two possibilities: - 1. constructor - 2. class method - - end - else } - begin - case p^.methodpointer^.treetype of - typen: - begin - { direct call to inherited method } - if (p^.procdefinition^.options and poabstractmethod)<>0 then - begin - CGMessage(cg_e_cant_call_abstract_method); - goto dont_call; - end; - { generate no virtual call } - no_virtual_call:=true; - - if (p^.symtableprocentry^.properties and sp_static)<>0 then - begin - { well lets put the VMT address directly into ESI } - { it is kind of dirty but that is the simplest } - { way to accept virtual static functions (PM) } - loadesi:=true; - { if no VMT just use $0 bug0214 PM } - if (pobjectdef(p^.methodpointer^.resulttype)^.options and oo_hasvmt)=0 then - exprasmlist^.concat(new(pai386,op_const_reg(A_MOV,S_L,0,R_ESI))) - else - begin - exprasmlist^.concat(new(pai386,op_sym_ofs_reg(A_MOV,S_L, - newasmsymbol(pobjectdef( - p^.methodpointer^.resulttype)^.vmt_mangledname),0,R_ESI))); -{$ifndef NEWLAB} - maybe_concat_external(pobjectdef(p^.methodpointer^.resulttype)^.owner, - pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname); -{$endif} - end; - { exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_ESI))); - this is done below !! } - end - else - { this is a member call, so ESI isn't modfied } - loadesi:=false; - - { a class destructor needs a flag } - if pobjectdef(p^.methodpointer^.resulttype)^.isclass and - assigned(aktprocsym) and - ((aktprocsym^.definition^.options and - (podestructor))<>0) then - begin - push_int(0); - exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_ESI))); - end; - - if not(is_con_or_destructor and - pobjectdef(p^.methodpointer^.resulttype)^.isclass and - assigned(aktprocsym) and - ((aktprocsym^.definition^.options and (poconstructor or podestructor))<>0) - ) then - exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_ESI))); - { if an inherited con- or destructor should be } - { called in a con- or destructor then a warning } - { will be made } - { con- and destructors need a pointer to the vmt } - if is_con_or_destructor and - not(pobjectdef(p^.methodpointer^.resulttype)^.isclass) and - assigned(aktprocsym) then - begin - if not ((aktprocsym^.definition^.options - and (poconstructor or podestructor))<>0) then - - CGMessage(cg_w_member_cd_call_from_method); - end; - { class destructors get there flag below } - if is_con_or_destructor and - not(pobjectdef(p^.methodpointer^.resulttype)^.isclass and - assigned(aktprocsym) and - ((aktprocsym^.definition^.options and - (podestructor))<>0)) then - push_int(0); - end; - hnewn: - begin - { extended syntax of new } - { ESI must be zero } - exprasmlist^.concat(new(pai386,op_reg_reg(A_XOR,S_L,R_ESI,R_ESI))); - exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_ESI))); - { insert the vmt } - exprasmlist^.concat(new(pai386,op_sym(A_PUSH,S_L, - newasmsymbol(pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname)))); -{$ifndef NEWLAB} - maybe_concat_external(pobjectdef(p^.methodpointer^.resulttype)^.owner, - pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname); -{$endif} - extended_new:=true; - end; - hdisposen: - begin - secondpass(p^.methodpointer); - - { destructor with extended syntax called from dispose } - { hdisposen always deliver LOC_REFERENCE } - exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L, - newreference(p^.methodpointer^.location.reference),R_ESI))); - del_reference(p^.methodpointer^.location.reference); - exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_ESI))); - exprasmlist^.concat(new(pai386,op_sym(A_PUSH,S_L, - newasmsymbol(pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname)))); -{$ifndef NEWLAB} - maybe_concat_external(pobjectdef(p^.methodpointer^.resulttype)^.owner, - pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname); -{$endif} - end; - else - begin - { call to an instance member } - if (p^.symtable^.symtabletype<>withsymtable) then - begin - secondpass(p^.methodpointer); - case p^.methodpointer^.location.loc of - LOC_CREGISTER, - LOC_REGISTER: - begin - emit_reg_reg(A_MOV,S_L,p^.methodpointer^.location.register,R_ESI); - ungetregister32(p^.methodpointer^.location.register); - end; - else - begin - if (p^.methodpointer^.resulttype^.deftype=classrefdef) or - ((p^.methodpointer^.resulttype^.deftype=objectdef) and - pobjectdef(p^.methodpointer^.resulttype)^.isclass) then - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, - newreference(p^.methodpointer^.location.reference),R_ESI))) - else - exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L, - newreference(p^.methodpointer^.location.reference),R_ESI))); - del_reference(p^.methodpointer^.location.reference); - end; - end; - end; - { when calling a class method, we have to load ESI with the VMT ! - But, not for a class method via self } - if ((p^.procdefinition^.options and pocontainsself)=0) then - begin - if ((p^.procdefinition^.options and poclassmethod)<>0) - and not(p^.methodpointer^.resulttype^.deftype=classrefdef) then - begin - { class method needs current VMT } - new(r); - reset_reference(r^); - r^.base:=R_ESI; - r^.offset:= pprocdef(p^.procdefinition)^._class^.vmt_offset; - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,R_ESI))); - end; - - { direct call to destructor: don't remove data! } - if ((p^.procdefinition^.options and podestructor)<>0) and - (p^.methodpointer^.resulttype^.deftype=objectdef) and - (pobjectdef(p^.methodpointer^.resulttype)^.isclass) then - exprasmlist^.concat(new(pai386,op_const(A_PUSH,S_L,1))); - - { direct call to class constructor, don't allocate memory } - if ((p^.procdefinition^.options and poconstructor)<>0) and - (p^.methodpointer^.resulttype^.deftype=objectdef) and - (pobjectdef(p^.methodpointer^.resulttype)^.isclass) then - exprasmlist^.concat(new(pai386,op_const(A_PUSH,S_L,0))) - else - exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_ESI))); - end; - - if is_con_or_destructor then - begin - { classes don't get a VMT pointer pushed } - if (p^.methodpointer^.resulttype^.deftype=objectdef) and - not(pobjectdef(p^.methodpointer^.resulttype)^.isclass) then - begin - if ((p^.procdefinition^.options and poconstructor)<>0) then - begin - { it's no bad idea, to insert the VMT } - exprasmlist^.concat(new(pai386,op_sym(A_PUSH,S_L,newasmsymbol( - pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname)))); -{$ifndef NEWLAB} - maybe_concat_external(pobjectdef(p^.methodpointer^.resulttype)^.owner, - pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname); -{$endif} - end - { destructors haven't to dispose the instance, if this is } - { a direct call } - else - push_int(0); - end; - end; - end; - end; - end; - end - else - begin - if ((p^.procdefinition^.options and poclassmethod)<>0) and - not( - assigned(aktprocsym) and - ((aktprocsym^.definition^.options and poclassmethod)<>0) - ) then - begin - { class method needs current VMT } - new(r); - reset_reference(r^); - r^.base:=R_ESI; - r^.offset:= pprocdef(p^.procdefinition)^._class^.vmt_offset; - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,R_ESI))); - end - else - begin - { member call, ESI isn't modified } - loadesi:=false; - end; - exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_ESI))); - { but a con- or destructor here would probably almost } - { always be placed wrong } - if is_con_or_destructor then - begin - CGMessage(cg_w_member_cd_call_from_method); - push_int(0); - end; - end; - end; - - { push base pointer ?} - if (lexlevel>=normal_function_level) and assigned(pprocdef(p^.procdefinition)^.parast) and - ((pprocdef(p^.procdefinition)^.parast^.symtablelevel)>normal_function_level) then - begin - { if we call a nested function in a method, we must } - { push also SELF! } - { THAT'S NOT TRUE, we have to load ESI via frame pointer } - { access } - { - begin - loadesi:=false; - exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_ESI))); - end; - } - if lexlevel=(pprocdef(p^.procdefinition)^.parast^.symtablelevel) then - begin - new(r); - reset_reference(r^); - r^.offset:=procinfo.framepointer_offset; - r^.base:=procinfo.framepointer; - exprasmlist^.concat(new(pai386,op_ref(A_PUSH,S_L,r))) - end - { this is only true if the difference is one !! - but it cannot be more !! } - else if (lexlevel=pprocdef(p^.procdefinition)^.parast^.symtablelevel-1) then - begin - exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,procinfo.framepointer))) - end - else if (lexlevel>pprocdef(p^.procdefinition)^.parast^.symtablelevel) then - begin - hregister:=getregister32; - new(r); - reset_reference(r^); - r^.offset:=procinfo.framepointer_offset; - r^.base:=procinfo.framepointer; - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,hregister))); - for i:=(pprocdef(p^.procdefinition)^.parast^.symtablelevel) to lexlevel-1 do - begin - new(r); - reset_reference(r^); - {we should get the correct frame_pointer_offset at each level - how can we do this !!! } - r^.offset:=procinfo.framepointer_offset; - r^.base:=hregister; - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,hregister))); - end; - exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,hregister))); - ungetregister32(hregister); - end - else - internalerror(25000); - end; - - if ((p^.procdefinition^.options and povirtualmethod)<>0) and - not(no_virtual_call) then - begin - { static functions contain the vmt_address in ESI } - { also class methods } - { Here it is quite tricky because it also depends } - { on the methodpointer PM } - if assigned(aktprocsym) then - begin - if ((((aktprocsym^.properties and sp_static)<>0) or - ((aktprocsym^.definition^.options and poclassmethod)<>0)) and - ((p^.methodpointer=nil) or (p^.methodpointer^.treetype=typen))) - or - ((p^.procdefinition^.options and postaticmethod)<>0) or - ((p^.procdefinition^.options and poconstructor)<>0) or - { ESI is loaded earlier } - ((p^.procdefinition^.options and poclassmethod)<>0)then - begin - new(r); - reset_reference(r^); - r^.base:=R_ESI; - end - else - begin - new(r); - reset_reference(r^); - r^.base:=R_ESI; - { this is one point where we need vmt_offset (PM) } - r^.offset:= pprocdef(p^.procdefinition)^._class^.vmt_offset; - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,R_EDI))); - new(r); - reset_reference(r^); - r^.base:=R_EDI; - end; - end - else - { aktprocsym should be assigned, also in main program } - internalerror(12345); - { - begin - new(r); - reset_reference(r^); - r^.base:=R_ESI; - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,R_EDI))); - new(r); - reset_reference(r^); - r^.base:=R_EDI; - end; - } - if pprocdef(p^.procdefinition)^.extnumber=-1 then - internalerror($Da); - r^.offset:=pprocdef(p^.procdefinition)^.extnumber*4+12; -{$ifndef TESTOBJEXT} - if (cs_check_range in aktlocalswitches) then - begin - exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,r^.base))); - emitcall('FPC_CHECK_OBJECT',true); - end; -{$else TESTOBJEXT} - if (cs_check_range in aktlocalswitches) then - begin - exprasmlist^.concat(new(pai386,op_sym(A_PUSH,S_L, - newasmsymbol(pprocdef(p^.procdefinition)^._class^.vmt_mangledname)))); - exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,r^.base))); - emitcall('FPC_CHECK_OBJECT_EXT',true); - end; -{$endif TESTOBJEXT} - exprasmlist^.concat(new(pai386,op_ref(A_CALL,S_NO,r))); - end - else if not inlined then - emitcall(pprocdef(p^.procdefinition)^.mangledname, - (p^.symtableproc^.symtabletype=unitsymtable) or - ((p^.symtableproc^.symtabletype=objectsymtable) and - (pobjectdef(p^.symtableproc^.defowner)^.owner^.symtabletype=unitsymtable))or - ((p^.symtableproc^.symtabletype=withsymtable) and - (pobjectdef(p^.symtableproc^.defowner)^.owner^.symtabletype=unitsymtable))) - else { inlined proc } - { inlined code is in inlinecode } - begin - { set poinline again } - p^.procdefinition^.options:=p^.procdefinition^.options or poinline; - { process the inlinecode } - secondpass(inlinecode); - { free the args } - ungetpersistanttemp(pprocdef(p^.procdefinition)^.parast^.address_fixup); - end; - end - else - { now procedure variable case } - begin - secondpass(p^.right); - { method pointer ? } - if (p^.procdefinition^.options and pomethodpointer)<>0 then - begin - { method pointer can't be in a register } - hregister:=R_NO; - - { do some hacking if we call a method pointer } - { which is a class member } - { else ESI is overwritten ! } - if (p^.right^.location.reference.base=R_ESI) or - (p^.right^.location.reference.index=R_ESI) then - begin - del_reference(p^.right^.location.reference); - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, - newreference(p^.right^.location.reference),R_EDI))); - hregister:=R_EDI; - end; - - - if ((p^.procdefinition^.options and pocontainsself)=0) then - begin - { load ESI } - inc(p^.right^.location.reference.offset,4); - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, - newreference(p^.right^.location.reference),R_ESI))); - dec(p^.right^.location.reference.offset,4); - { push self pointer } - exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_ESI))); - end; - - if hregister=R_NO then - exprasmlist^.concat(new(pai386,op_ref(A_CALL,S_NO,newreference(p^.right^.location.reference)))) - else - exprasmlist^.concat(new(pai386,op_reg(A_CALL,S_NO,hregister))); - - del_reference(p^.right^.location.reference); - end - else - begin - case p^.right^.location.loc of - LOC_REGISTER,LOC_CREGISTER: - begin - exprasmlist^.concat(new(pai386,op_reg(A_CALL,S_NO,p^.right^.location.register))); - ungetregister32(p^.right^.location.register); - end - else - exprasmlist^.concat(new(pai386,op_ref(A_CALL,S_NO,newreference(p^.right^.location.reference)))); - del_reference(p^.right^.location.reference); - end; - end; - end; - - { this was only for normal functions - displaced here so we also get - it to work for procvars PM } - if (not inlined) and ((p^.procdefinition^.options and poclearstack)<>0) then - begin - { consider the alignment with the rest (PM) } - inc(pushedparasize,pop_size); - pop_size:=0; - { better than an add on all processors } - if pushedparasize=4 then - exprasmlist^.concat(new(pai386,op_reg(A_POP,S_L,R_EDI))) - { the pentium has two pipes and pop reg is pairable } - { but the registers must be different! } - else if (pushedparasize=8) and - not(cs_littlesize in aktglobalswitches) and - (aktoptprocessor=ClassP5) and - (procinfo._class=nil) then - begin - exprasmlist^.concat(new(pai386,op_reg(A_POP,S_L,R_EDI))); - exprasmlist^.concat(new(pai386,op_reg(A_POP,S_L,R_ESI))); - end - else if pushedparasize<>0 then - exprasmlist^.concat(new(pai386,op_const_reg(A_ADD,S_L,pushedparasize,R_ESP))); - end; - dont_call: - pushedparasize:=oldpushedparasize; - unused:=unusedregisters; - - { handle function results } - { structured results are easy to handle.... } - { needed also when result_no_used !! } - if (p^.resulttype<>pdef(voiddef)) and ret_in_param(p^.resulttype) then - begin - p^.location.loc:=LOC_MEM; - p^.location.reference.symbol:=nil; - p^.location.reference:=funcretref; - end; - { we have only to handle the result if it is used, but } - { ansi/widestrings must be registered, so we can dispose them } - if (p^.resulttype<>pdef(voiddef)) and (p^.return_value_used or - is_ansistring(p^.resulttype) or is_widestring(p^.resulttype)) then - begin - { a contructor could be a function with boolean result } - if (p^.right=nil) and - ((p^.procdefinition^.options and poconstructor)<>0) and - { quick'n'dirty check if it is a class or an object } - (p^.resulttype^.deftype=orddef) then - begin - p^.location.loc:=LOC_FLAGS; - p^.location.resflags:=F_NE; - if extended_new then - begin -{$ifdef test_dest_loc} - if dest_loc_known and (dest_loc_tree=p) then - mov_reg_to_dest(p,S_L,R_EAX) - else -{$endif test_dest_loc} - begin - hregister:=getexplicitregister32(R_EAX); - emit_reg_reg(A_MOV,S_L,R_EAX,hregister); - p^.location.register:=hregister; - end; - end; - end - { structed results are easy to handle.... } - else if ret_in_param(p^.resulttype) then - begin - {p^.location.loc:=LOC_MEM; - stringdispose(p^.location.reference.symbol); - p^.location.reference:=funcretref; - already done above (PM) } - end - else - begin - if (p^.resulttype^.deftype=orddef) then - begin - p^.location.loc:=LOC_REGISTER; - case porddef(p^.resulttype)^.typ of - s32bit,u32bit,bool32bit : - begin -{$ifdef test_dest_loc} - if dest_loc_known and (dest_loc_tree=p) then - mov_reg_to_dest(p,S_L,R_EAX) - else -{$endif test_dest_loc} - begin - hregister:=getexplicitregister32(R_EAX); - emit_reg_reg(A_MOV,S_L,R_EAX,hregister); - p^.location.register:=hregister; - end; - end; - uchar,u8bit,bool8bit,s8bit: - begin -{$ifdef test_dest_loc} - if dest_loc_known and (dest_loc_tree=p) then - mov_reg_to_dest(p,S_B,R_AL) - else -{$endif test_dest_loc} - begin - hregister:=getexplicitregister32(R_EAX); - emit_reg_reg(A_MOV,S_B,R_AL,reg32toreg8(hregister)); - p^.location.register:=reg32toreg8(hregister); - end; - end; - s16bit,u16bit,bool16bit : - begin -{$ifdef test_dest_loc} - if dest_loc_known and (dest_loc_tree=p) then - mov_reg_to_dest(p,S_W,R_AX) - else -{$endif test_dest_loc} - begin - hregister:=getexplicitregister32(R_EAX); - emit_reg_reg(A_MOV,S_W,R_AX,reg32toreg16(hregister)); - p^.location.register:=reg32toreg16(hregister); - end; - end; - s64bitint,u64bit: - begin -{$ifdef test_dest_loc} -{$error Don't know what to do here} -{$endif test_dest_loc} - hregister:=getexplicitregister32(R_EAX); - hregister2:=getexplicitregister32(R_EDX); - emit_reg_reg(A_MOV,S_L,R_EAX,hregister); - emit_reg_reg(A_MOV,S_L,R_EDX,hregister2); - p^.location.registerlow:=hregister; - p^.location.registerhigh:=hregister2; - end; - else internalerror(7); - end - - end - else if (p^.resulttype^.deftype=floatdef) then - case pfloatdef(p^.resulttype)^.typ of - f32bit: - begin - p^.location.loc:=LOC_REGISTER; -{$ifdef test_dest_loc} - if dest_loc_known and (dest_loc_tree=p) then - mov_reg_to_dest(p,S_L,R_EAX) - else -{$endif test_dest_loc} - begin - hregister:=getexplicitregister32(R_EAX); - emit_reg_reg(A_MOV,S_L,R_EAX,hregister); - p^.location.register:=hregister; - end; - end; - else - p^.location.loc:=LOC_FPU; - end - else if is_ansistring(p^.resulttype) or - is_widestring(p^.resulttype) then - begin - gettempansistringreference(hr); - { cleanup the temp slot } - exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_EAX))); - decrstringref(exprasmlist,p^.resulttype,hr); - exprasmlist^.concat(new(pai386,op_reg(A_POP,S_L,R_EAX))); - - exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L,R_EAX, - newreference(hr)))); - p^.location.loc:=LOC_MEM; - p^.location.reference:=hr; - end - else - begin - p^.location.loc:=LOC_REGISTER; -{$ifdef test_dest_loc} - if dest_loc_known and (dest_loc_tree=p) then - mov_reg_to_dest(p,S_L,R_EAX) - else -{$endif test_dest_loc} - begin - hregister:=getexplicitregister32(R_EAX); - emit_reg_reg(A_MOV,S_L,R_EAX,hregister); - p^.location.register:=hregister; - end; - end; - end; - end; - - { perhaps i/o check ? } - if iolabel<>nil then - begin - exprasmlist^.concat(new(pai386,op_sym(A_PUSH,S_L,newasmsymbol(lab2str(iolabel))))); - emitcall('FPC_IOCHECK',true); - end; - if pop_size>0 then - exprasmlist^.concat(new(pai386,op_const_reg(A_ADD,S_L,pop_size,R_ESP))); - - { restore registers } - popusedregisters(exprasmlist,pushed); - - { at last, restore instance pointer (SELF) } - if loadesi then - maybe_loadesi; - pp:=params; - while assigned(pp) do - begin - if assigned(pp^.left) then - begin - if (pp^.left^.location.loc in [LOC_REFERENCE,LOC_MEM]) and - ungettempoftype(pp^.left^.resulttype) then - ungetiftemp(pp^.left^.location.reference); - { process also all nodes of an array of const } - if pp^.left^.treetype=arrayconstructn then - begin - if assigned(pp^.left^.left) then - begin - hp:=pp^.left; - while assigned(hp) do - begin - if (hp^.left^.location.loc in [LOC_REFERENCE,LOC_MEM]) and - ungettempoftype(hp^.left^.resulttype) then - ungetiftemp(hp^.left^.location.reference); - hp:=hp^.right; - end; - end; - end; - end; - pp:=pp^.right; - end; - if inlined then - ungetpersistanttemp(inlinecode^.retoffset); - disposetree(params); - - - { from now on the result can be freed normally } - if inlined and ret_in_param(p^.resulttype) then - persistanttemptonormal(funcretref.offset); - - { if return value is not used } - if (not p^.return_value_used) and (p^.resulttype<>pdef(voiddef)) then - begin - if p^.location.loc in [LOC_MEM,LOC_REFERENCE] then - begin - { data which must be finalized ? } - if (p^.resulttype^.needs_inittable) and - ( (p^.resulttype^.deftype<>objectdef) or - not(pobjectdef(p^.resulttype)^.isclass)) then - finalize(exprasmlist,p^.resulttype,p^.location.reference); - { release unused temp } - ungetiftemp(p^.location.reference) - end - else if p^.location.loc=LOC_FPU then - { release FPU stack } - exprasmlist^.concat(new(pai386,op_reg(A_FSTP,S_NO,R_ST0))); - end; - end; - - -{***************************************************************************** - SecondProcInlineN -*****************************************************************************} - - - procedure secondprocinline(var p : ptree); - var st : psymtable; - oldprocsym : pprocsym; - para_size : longint; - oldprocinfo : tprocinfo; - { just dummies for genentrycode } - nostackframe,make_global : boolean; - proc_names : tstringcontainer; - inlineentrycode,inlineexitcode : paasmoutput; - oldexitlabel,oldexit2label,oldquickexitlabel:Plabel; - begin - oldexitlabel:=aktexitlabel; - oldexit2label:=aktexit2label; - oldquickexitlabel:=quickexitlabel; - getlabel(aktexitlabel); - getlabel(aktexit2label); - oldprocsym:=aktprocsym; - oldprocinfo:=procinfo; - { set the return value } - aktprocsym:=p^.inlineprocsym; - procinfo.retdef:=aktprocsym^.definition^.retdef; - procinfo.retoffset:=p^.retoffset; - { arg space has been filled by the parent secondcall } - st:=aktprocsym^.definition^.localst; - { set it to the same lexical level } - st^.symtablelevel:=oldprocsym^.definition^.localst^.symtablelevel; - if st^.datasize>0 then - begin - st^.address_fixup:=gettempofsizepersistant(st^.datasize); -{$ifdef extdebug} - Comment(V_debug,'local symtable is at offset '+tostr(st^.address_fixup)); - exprasmlist^.concat(new(pai_asm_comment,init(strpnew( - 'local symtable is at offset '+tostr(st^.address_fixup))))); -{$endif extdebug} - end; -{$ifdef extdebug} - exprasmlist^.concat(new(pai_asm_comment,init('Start of inlined proc'))); -{$endif extdebug} - { takes care of local data initialization } - inlineentrycode:=new(paasmoutput,init); - inlineexitcode:=new(paasmoutput,init); - proc_names.init; - para_size:=p^.para_size; - make_global:=false; { to avoid warning } - genentrycode(inlineentrycode,proc_names,make_global,0,para_size,nostackframe,true); - exprasmlist^.concatlist(inlineentrycode); - secondpass(p^.inlinetree); - genexitcode(inlineexitcode,0,false,true); - exprasmlist^.concatlist(inlineexitcode); -{$ifdef extdebug} - exprasmlist^.concat(new(pai_asm_comment,init('End of inlined proc'))); -{$endif extdebug} - {we can free the local data now, reset also the fixup address } - if st^.datasize>0 then - begin - ungetpersistanttemp(st^.address_fixup); - st^.address_fixup:=0; - end; - aktprocsym:=oldprocsym; - freelabel(aktexitlabel); - freelabel(aktexit2label); - aktexitlabel:=oldexitlabel; - aktexit2label:=oldexit2label; - quickexitlabel:=oldquickexitlabel; - procinfo:=oldprocinfo; - end; - - - -end. -{ +{ + $Id$ + Copyright (c) 1993-98 by Florian Klaempfl + + Generate i386 assembler for in call nodes + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit cg386cal; +interface + +{ $define AnsiStrRef} + + uses + symtable,tree; + + procedure secondcallparan(var p : ptree;defcoll : pdefcoll; + push_from_left_to_right,inlined,dword_align : boolean;para_offset : longint); + procedure secondcalln(var p : ptree); + procedure secondprocinline(var p : ptree); + + +implementation + + uses + globtype,systems, + cobjects,verbose,globals, + aasm,types, +{$ifdef GDB} + gdb, +{$endif GDB} + hcodegen,temp_gen,pass_2, +{$ifndef OLDASM} + i386base,i386asm, +{$else} + i386, +{$endif} + cgai386,tgeni386,cg386ld; + +{***************************************************************************** + SecondCallParaN +*****************************************************************************} + + procedure secondcallparan(var p : ptree;defcoll : pdefcoll; + push_from_left_to_right,inlined,dword_align : boolean;para_offset : longint); + + procedure maybe_push_high; + begin + { open array ? } + { defcoll^.data can be nil for read/write } + if assigned(defcoll^.data) and + push_high_param(defcoll^.data) then + begin + if assigned(p^.hightree) then + begin + secondpass(p^.hightree); + { this is a longint anyway ! } + push_value_para(p^.hightree,inlined,para_offset,4); + end + else + internalerror(432645); + end; + end; + + var + otlabel,oflabel : plabel; + align : longint; + { temporary variables: } + tempdeftype : tdeftype; + r : preference; + begin + { push from left to right if specified } + if push_from_left_to_right and assigned(p^.right) then + secondcallparan(p^.right,defcoll^.next,push_from_left_to_right, + inlined,dword_align,para_offset); + otlabel:=truelabel; + oflabel:=falselabel; + getlabel(truelabel); + getlabel(falselabel); + secondpass(p^.left); + { filter array constructor with c styled args } + if is_array_constructor(p^.left^.resulttype) and p^.left^.cargs then + begin + { nothing, everything is already pushed } + end + { in codegen.handleread.. defcoll^.data is set to nil } + else if assigned(defcoll^.data) and + (defcoll^.data^.deftype=formaldef) then + begin + { allow @var } + inc(pushedparasize,4); + if p^.left^.treetype=addrn then + begin + { always a register } + if inlined then + begin + r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); + exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L, + p^.left^.location.register,r))); + end + else + exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,p^.left^.location.register))); + ungetregister32(p^.left^.location.register); + end + else + begin + if not(p^.left^.location.loc in [LOC_MEM,LOC_REFERENCE]) then + CGMessage(type_e_mismatch) + else + begin + if inlined then + begin + exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L, + newreference(p^.left^.location.reference),R_EDI))); + r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); + exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L,R_EDI,r))); + end + else + emitpushreferenceaddr(exprasmlist,p^.left^.location.reference); + del_reference(p^.left^.location.reference); + end; + end; + end + { handle call by reference parameter } + else if (defcoll^.paratyp=vs_var) then + begin + if (p^.left^.location.loc<>LOC_REFERENCE) then + CGMessage(cg_e_var_must_be_reference); + maybe_push_high; + inc(pushedparasize,4); + if inlined then + begin + exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L, + newreference(p^.left^.location.reference),R_EDI))); + r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); + exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L,R_EDI,r))); + end + else + emitpushreferenceaddr(exprasmlist,p^.left^.location.reference); + del_reference(p^.left^.location.reference); + end + else + begin + tempdeftype:=p^.resulttype^.deftype; + if tempdeftype=filedef then + CGMessage(cg_e_file_must_call_by_reference); + if push_addr_param(p^.resulttype) then + begin + maybe_push_high; + inc(pushedparasize,4); + if inlined then + begin + exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L, + newreference(p^.left^.location.reference),R_EDI))); + r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); + exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L, + R_EDI,r))); + end + else + emitpushreferenceaddr(exprasmlist,p^.left^.location.reference); + del_reference(p^.left^.location.reference); + end + else + begin + align:=target_os.stackalignment; + if dword_align then + align:=4; + push_value_para(p^.left,inlined,para_offset,align); + end; + end; + freelabel(truelabel); + freelabel(falselabel); + truelabel:=otlabel; + falselabel:=oflabel; + { push from right to left } + if not push_from_left_to_right and assigned(p^.right) then + secondcallparan(p^.right,defcoll^.next,push_from_left_to_right, + inlined,dword_align,para_offset); + end; + + +{***************************************************************************** + SecondCallN +*****************************************************************************} + + procedure secondcalln(var p : ptree); + var + unusedregisters : tregisterset; + pushed : tpushed; + hr,funcretref : treference; + hregister,hregister2 : tregister; + oldpushedparasize : longint; + { true if ESI must be loaded again after the subroutine } + loadesi : boolean; + { true if a virtual method must be called directly } + no_virtual_call : boolean; + { true if we produce a con- or destrutor in a call } + is_con_or_destructor : boolean; + { true if a constructor is called again } + extended_new : boolean; + { adress returned from an I/O-error } + iolabel : plabel; + { lexlevel count } + i : longint; + { help reference pointer } + r : preference; + hp, + pp,params : ptree; + inlined : boolean; + inlinecode : ptree; + para_offset : longint; + { instruction for alignement correction } +{ corr : pai386;} + { we must pop this size also after !! } +{ must_pop : boolean; } + pop_size : longint; + + label + dont_call; + + begin + reset_reference(p^.location.reference); + extended_new:=false; + iolabel:=nil; + inlinecode:=nil; + inlined:=false; + loadesi:=true; + no_virtual_call:=false; + unusedregisters:=unused; + + if not assigned(p^.procdefinition) then + exit; + if (p^.procdefinition^.options and poinline)<>0 then + begin + inlined:=true; + inlinecode:=p^.right; + { set it to the same lexical level as the local symtable, becuase + the para's are stored there } + pprocdef(p^.procdefinition)^.parast^.symtablelevel:=aktprocsym^.definition^.localst^.symtablelevel; + if assigned(p^.left) then + inlinecode^.para_offset:=gettempofsizepersistant(inlinecode^.para_size); + pprocdef(p^.procdefinition)^.parast^.address_fixup:=inlinecode^.para_offset; +{$ifdef extdebug} + Comment(V_debug, + 'inlined parasymtable is at offset ' + +tostr(pprocdef(p^.procdefinition)^.parast^.address_fixup)); + exprasmlist^.concat(new(pai_asm_comment,init( + strpnew('inlined parasymtable is at offset ' + +tostr(pprocdef(p^.procdefinition)^.parast^.address_fixup))))); +{$endif extdebug} + p^.right:=nil; + { disable further inlining of the same proc + in the args } + p^.procdefinition^.options:=p^.procdefinition^.options and (not poinline); + end; + { only if no proc var } + if not(assigned(p^.right)) then + is_con_or_destructor:=((p^.procdefinition^.options and poconstructor)<>0) + or ((p^.procdefinition^.options and podestructor)<>0); + { proc variables destroy all registers } + if (p^.right=nil) and + { virtual methods too } + ((p^.procdefinition^.options and povirtualmethod)=0) then + begin + if ((p^.procdefinition^.options and poiocheck)<>0) and + ((aktprocsym^.definition^.options and poiocheck)=0) and + (cs_check_io in aktlocalswitches) then + begin + getlabel(iolabel); + emitlab(iolabel); + end + else + iolabel:=nil; + + { save all used registers } + pushusedregisters(exprasmlist,pushed,pprocdef(p^.procdefinition)^.usedregisters); + + { give used registers through } + usedinproc:=usedinproc or pprocdef(p^.procdefinition)^.usedregisters; + end + else + begin + pushusedregisters(exprasmlist,pushed,$ff); + usedinproc:=$ff; + { no IO check for methods and procedure variables } + iolabel:=nil; + end; + + { generate the code for the parameter and push them } + oldpushedparasize:=pushedparasize; + pushedparasize:=0; + pop_size:=0; + if (not inlined) then + begin + { Old pushedsize aligned on 4 ? } + i:=oldpushedparasize and 3; + if i>0 then + inc(pop_size,4-i); + { This parasize aligned on 4 ? } + i:=p^.procdefinition^.para_size and 3; + if i>0 then + inc(pop_size,4-i); + { insert the opcode and update pushedparasize } + if pop_size>0 then + begin + inc(pushedparasize,pop_size); + exprasmlist^.concat(new(pai386,op_const_reg(A_SUB,S_L,pop_size,R_ESP))); +{$ifdef GDB} + if (cs_debuginfo in aktmoduleswitches) and + (exprasmlist^.first=exprasmlist^.last) then + exprasmlist^.concat(new(pai_force_line,init)); +{$endif GDB} + end; + end; + + if (p^.resulttype<>pdef(voiddef)) and + ret_in_param(p^.resulttype) then + begin + funcretref.symbol:=nil; +{$ifdef test_dest_loc} + if dest_loc_known and (dest_loc_tree=p) and + (dest_loc.loc in [LOC_REFERENCE,LOC_MEM]) then + begin + funcretref:=dest_loc.reference; + if assigned(dest_loc.reference.symbol) then + funcretref.symbol:=stringdup(dest_loc.reference.symbol^); + in_dest_loc:=true; + end + else +{$endif test_dest_loc} + if inlined then + begin + reset_reference(funcretref); + funcretref.offset:=gettempofsizepersistant(p^.procdefinition^.retdef^.size); + funcretref.base:=procinfo.framepointer; + end + else + gettempofsizereference(p^.procdefinition^.retdef^.size,funcretref); + end; + if assigned(p^.left) then + begin + { be found elsewhere } + if inlined then + para_offset:=pprocdef(p^.procdefinition)^.parast^.address_fixup+ + pprocdef(p^.procdefinition)^.parast^.datasize + else + para_offset:=0; + if assigned(p^.right) then + secondcallparan(p^.left,pabstractprocdef(p^.right^.resulttype)^.para1, + (p^.procdefinition^.options and poleftright)<>0, + inlined,(p^.procdefinition^.options and (pocdecl or postdcall))<>0,para_offset) + else + secondcallparan(p^.left,p^.procdefinition^.para1, + (p^.procdefinition^.options and poleftright)<>0, + inlined,(p^.procdefinition^.options and (pocdecl or postdcall))<>0,para_offset); + end; + params:=p^.left; + p^.left:=nil; + if inlined then + inlinecode^.retoffset:=gettempofsizepersistant(4); + if ret_in_param(p^.resulttype) then + begin + inc(pushedparasize,4); + if inlined then + begin + exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L, + newreference(funcretref),R_EDI))); + r:=new_reference(procinfo.framepointer,inlinecode^.retoffset); + exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L, + R_EDI,r))); + end + else + emitpushreferenceaddr(exprasmlist,funcretref); + end; + { procedure variable ? } + if (p^.right=nil) then + begin + { overloaded operator have no symtable } + { push self } + if assigned(p^.symtable) and + (p^.symtable^.symtabletype=withsymtable) then + begin + { dirty trick to avoid the secondcall below } + p^.methodpointer:=genzeronode(callparan); + p^.methodpointer^.location.loc:=LOC_REGISTER; + p^.methodpointer^.location.register:=R_ESI; + { ARGHHH this is wrong !!! + if we can init from base class for a child + class that the wrong VMT will be + transfered to constructor !! } + p^.methodpointer^.resulttype:= + ptree(pwithsymtable(p^.symtable)^.withnode)^.left^.resulttype; + { change dispose type !! } + p^.disposetyp:=dt_mbleft_and_method; + { make a reference } + new(r); + reset_reference(r^); + { if assigned(ptree(pwithsymtable(p^.symtable)^.withnode)^.pref) then + begin + r^:=ptree(pwithsymtable(p^.symtable)^.withnode)^.pref^; + end + else + begin + r^.offset:=p^.symtable^.datasize; + r^.base:=procinfo.framepointer; + end; } + r^:=ptree(pwithsymtable(p^.symtable)^.withnode)^.withreference^; + if (not pwithsymtable(p^.symtable)^.direct_with) or + pobjectdef(p^.methodpointer^.resulttype)^.isclass then + exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,R_ESI))) + else + exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L,r,R_ESI))); + end; + + { push self } + if assigned(p^.symtable) and + ((p^.symtable^.symtabletype=objectsymtable) or + (p^.symtable^.symtabletype=withsymtable)) then + begin + if assigned(p^.methodpointer) then + begin + { + if p^.methodpointer^.resulttype=classrefdef then + begin + two possibilities: + 1. constructor + 2. class method + + end + else } + begin + case p^.methodpointer^.treetype of + typen: + begin + { direct call to inherited method } + if (p^.procdefinition^.options and poabstractmethod)<>0 then + begin + CGMessage(cg_e_cant_call_abstract_method); + goto dont_call; + end; + { generate no virtual call } + no_virtual_call:=true; + + if (p^.symtableprocentry^.properties and sp_static)<>0 then + begin + { well lets put the VMT address directly into ESI } + { it is kind of dirty but that is the simplest } + { way to accept virtual static functions (PM) } + loadesi:=true; + { if no VMT just use $0 bug0214 PM } + if (pobjectdef(p^.methodpointer^.resulttype)^.options and oo_hasvmt)=0 then + exprasmlist^.concat(new(pai386,op_const_reg(A_MOV,S_L,0,R_ESI))) + else + begin + exprasmlist^.concat(new(pai386,op_sym_ofs_reg(A_MOV,S_L, + newasmsymbol(pobjectdef( + p^.methodpointer^.resulttype)^.vmt_mangledname),0,R_ESI))); +{$ifndef NEWLAB} + maybe_concat_external(pobjectdef(p^.methodpointer^.resulttype)^.owner, + pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname); +{$endif} + end; + { exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_ESI))); + this is done below !! } + end + else + { this is a member call, so ESI isn't modfied } + loadesi:=false; + + { a class destructor needs a flag } + if pobjectdef(p^.methodpointer^.resulttype)^.isclass and + assigned(aktprocsym) and + ((aktprocsym^.definition^.options and + (podestructor))<>0) then + begin + push_int(0); + exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_ESI))); + end; + + if not(is_con_or_destructor and + pobjectdef(p^.methodpointer^.resulttype)^.isclass and + assigned(aktprocsym) and + ((aktprocsym^.definition^.options and (poconstructor or podestructor))<>0) + ) then + exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_ESI))); + { if an inherited con- or destructor should be } + { called in a con- or destructor then a warning } + { will be made } + { con- and destructors need a pointer to the vmt } + if is_con_or_destructor and + not(pobjectdef(p^.methodpointer^.resulttype)^.isclass) and + assigned(aktprocsym) then + begin + if not ((aktprocsym^.definition^.options + and (poconstructor or podestructor))<>0) then + + CGMessage(cg_w_member_cd_call_from_method); + end; + { class destructors get there flag below } + if is_con_or_destructor and + not(pobjectdef(p^.methodpointer^.resulttype)^.isclass and + assigned(aktprocsym) and + ((aktprocsym^.definition^.options and + (podestructor))<>0)) then + push_int(0); + end; + hnewn: + begin + { extended syntax of new } + { ESI must be zero } + exprasmlist^.concat(new(pai386,op_reg_reg(A_XOR,S_L,R_ESI,R_ESI))); + exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_ESI))); + { insert the vmt } + exprasmlist^.concat(new(pai386,op_sym(A_PUSH,S_L, + newasmsymbol(pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname)))); +{$ifndef NEWLAB} + maybe_concat_external(pobjectdef(p^.methodpointer^.resulttype)^.owner, + pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname); +{$endif} + extended_new:=true; + end; + hdisposen: + begin + secondpass(p^.methodpointer); + + { destructor with extended syntax called from dispose } + { hdisposen always deliver LOC_REFERENCE } + exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L, + newreference(p^.methodpointer^.location.reference),R_ESI))); + del_reference(p^.methodpointer^.location.reference); + exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_ESI))); + exprasmlist^.concat(new(pai386,op_sym(A_PUSH,S_L, + newasmsymbol(pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname)))); +{$ifndef NEWLAB} + maybe_concat_external(pobjectdef(p^.methodpointer^.resulttype)^.owner, + pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname); +{$endif} + end; + else + begin + { call to an instance member } + if (p^.symtable^.symtabletype<>withsymtable) then + begin + secondpass(p^.methodpointer); + case p^.methodpointer^.location.loc of + LOC_CREGISTER, + LOC_REGISTER: + begin + emit_reg_reg(A_MOV,S_L,p^.methodpointer^.location.register,R_ESI); + ungetregister32(p^.methodpointer^.location.register); + end; + else + begin + if (p^.methodpointer^.resulttype^.deftype=classrefdef) or + ((p^.methodpointer^.resulttype^.deftype=objectdef) and + pobjectdef(p^.methodpointer^.resulttype)^.isclass) then + exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, + newreference(p^.methodpointer^.location.reference),R_ESI))) + else + exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L, + newreference(p^.methodpointer^.location.reference),R_ESI))); + del_reference(p^.methodpointer^.location.reference); + end; + end; + end; + { when calling a class method, we have to load ESI with the VMT ! + But, not for a class method via self } + if ((p^.procdefinition^.options and pocontainsself)=0) then + begin + if ((p^.procdefinition^.options and poclassmethod)<>0) + and not(p^.methodpointer^.resulttype^.deftype=classrefdef) then + begin + { class method needs current VMT } + new(r); + reset_reference(r^); + r^.base:=R_ESI; + r^.offset:= pprocdef(p^.procdefinition)^._class^.vmt_offset; + exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,R_ESI))); + end; + + { direct call to destructor: don't remove data! } + if ((p^.procdefinition^.options and podestructor)<>0) and + (p^.methodpointer^.resulttype^.deftype=objectdef) and + (pobjectdef(p^.methodpointer^.resulttype)^.isclass) then + exprasmlist^.concat(new(pai386,op_const(A_PUSH,S_L,1))); + + { direct call to class constructor, don't allocate memory } + if ((p^.procdefinition^.options and poconstructor)<>0) and + (p^.methodpointer^.resulttype^.deftype=objectdef) and + (pobjectdef(p^.methodpointer^.resulttype)^.isclass) then + exprasmlist^.concat(new(pai386,op_const(A_PUSH,S_L,0))) + else + exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_ESI))); + end; + + if is_con_or_destructor then + begin + { classes don't get a VMT pointer pushed } + if (p^.methodpointer^.resulttype^.deftype=objectdef) and + not(pobjectdef(p^.methodpointer^.resulttype)^.isclass) then + begin + if ((p^.procdefinition^.options and poconstructor)<>0) then + begin + { it's no bad idea, to insert the VMT } + exprasmlist^.concat(new(pai386,op_sym(A_PUSH,S_L,newasmsymbol( + pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname)))); +{$ifndef NEWLAB} + maybe_concat_external(pobjectdef(p^.methodpointer^.resulttype)^.owner, + pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname); +{$endif} + end + { destructors haven't to dispose the instance, if this is } + { a direct call } + else + push_int(0); + end; + end; + end; + end; + end; + end + else + begin + if ((p^.procdefinition^.options and poclassmethod)<>0) and + not( + assigned(aktprocsym) and + ((aktprocsym^.definition^.options and poclassmethod)<>0) + ) then + begin + { class method needs current VMT } + new(r); + reset_reference(r^); + r^.base:=R_ESI; + r^.offset:= pprocdef(p^.procdefinition)^._class^.vmt_offset; + exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,R_ESI))); + end + else + begin + { member call, ESI isn't modified } + loadesi:=false; + end; + exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_ESI))); + { but a con- or destructor here would probably almost } + { always be placed wrong } + if is_con_or_destructor then + begin + CGMessage(cg_w_member_cd_call_from_method); + push_int(0); + end; + end; + end; + + { push base pointer ?} + if (lexlevel>=normal_function_level) and assigned(pprocdef(p^.procdefinition)^.parast) and + ((pprocdef(p^.procdefinition)^.parast^.symtablelevel)>normal_function_level) then + begin + { if we call a nested function in a method, we must } + { push also SELF! } + { THAT'S NOT TRUE, we have to load ESI via frame pointer } + { access } + { + begin + loadesi:=false; + exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_ESI))); + end; + } + if lexlevel=(pprocdef(p^.procdefinition)^.parast^.symtablelevel) then + begin + new(r); + reset_reference(r^); + r^.offset:=procinfo.framepointer_offset; + r^.base:=procinfo.framepointer; + exprasmlist^.concat(new(pai386,op_ref(A_PUSH,S_L,r))) + end + { this is only true if the difference is one !! + but it cannot be more !! } + else if (lexlevel=pprocdef(p^.procdefinition)^.parast^.symtablelevel-1) then + begin + exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,procinfo.framepointer))) + end + else if (lexlevel>pprocdef(p^.procdefinition)^.parast^.symtablelevel) then + begin + hregister:=getregister32; + new(r); + reset_reference(r^); + r^.offset:=procinfo.framepointer_offset; + r^.base:=procinfo.framepointer; + exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,hregister))); + for i:=(pprocdef(p^.procdefinition)^.parast^.symtablelevel) to lexlevel-1 do + begin + new(r); + reset_reference(r^); + {we should get the correct frame_pointer_offset at each level + how can we do this !!! } + r^.offset:=procinfo.framepointer_offset; + r^.base:=hregister; + exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,hregister))); + end; + exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,hregister))); + ungetregister32(hregister); + end + else + internalerror(25000); + end; + + if ((p^.procdefinition^.options and povirtualmethod)<>0) and + not(no_virtual_call) then + begin + { static functions contain the vmt_address in ESI } + { also class methods } + { Here it is quite tricky because it also depends } + { on the methodpointer PM } + if assigned(aktprocsym) then + begin + if ((((aktprocsym^.properties and sp_static)<>0) or + ((aktprocsym^.definition^.options and poclassmethod)<>0)) and + ((p^.methodpointer=nil) or (p^.methodpointer^.treetype=typen))) + or + ((p^.procdefinition^.options and postaticmethod)<>0) or + ((p^.procdefinition^.options and poconstructor)<>0) or + { ESI is loaded earlier } + ((p^.procdefinition^.options and poclassmethod)<>0)then + begin + new(r); + reset_reference(r^); + r^.base:=R_ESI; + end + else + begin + new(r); + reset_reference(r^); + r^.base:=R_ESI; + { this is one point where we need vmt_offset (PM) } + r^.offset:= pprocdef(p^.procdefinition)^._class^.vmt_offset; + exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,R_EDI))); + new(r); + reset_reference(r^); + r^.base:=R_EDI; + end; + end + else + { aktprocsym should be assigned, also in main program } + internalerror(12345); + { + begin + new(r); + reset_reference(r^); + r^.base:=R_ESI; + exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,R_EDI))); + new(r); + reset_reference(r^); + r^.base:=R_EDI; + end; + } + if pprocdef(p^.procdefinition)^.extnumber=-1 then + internalerror($Da); + r^.offset:=pprocdef(p^.procdefinition)^.extnumber*4+12; +{$ifndef TESTOBJEXT} + if (cs_check_range in aktlocalswitches) then + begin + exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,r^.base))); + emitcall('FPC_CHECK_OBJECT',true); + end; +{$else TESTOBJEXT} + if (cs_check_range in aktlocalswitches) then + begin + exprasmlist^.concat(new(pai386,op_sym(A_PUSH,S_L, + newasmsymbol(pprocdef(p^.procdefinition)^._class^.vmt_mangledname)))); + exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,r^.base))); + emitcall('FPC_CHECK_OBJECT_EXT',true); + end; +{$endif TESTOBJEXT} + exprasmlist^.concat(new(pai386,op_ref(A_CALL,S_NO,r))); + end + else if not inlined then + emitcall(pprocdef(p^.procdefinition)^.mangledname, + (p^.symtableproc^.symtabletype=unitsymtable) or + ((p^.symtableproc^.symtabletype=objectsymtable) and + (pobjectdef(p^.symtableproc^.defowner)^.owner^.symtabletype=unitsymtable))or + ((p^.symtableproc^.symtabletype=withsymtable) and + (pobjectdef(p^.symtableproc^.defowner)^.owner^.symtabletype=unitsymtable))) + else { inlined proc } + { inlined code is in inlinecode } + begin + { set poinline again } + p^.procdefinition^.options:=p^.procdefinition^.options or poinline; + { process the inlinecode } + secondpass(inlinecode); + { free the args } + ungetpersistanttemp(pprocdef(p^.procdefinition)^.parast^.address_fixup); + end; + end + else + { now procedure variable case } + begin + secondpass(p^.right); + { method pointer ? } + if (p^.procdefinition^.options and pomethodpointer)<>0 then + begin + { method pointer can't be in a register } + hregister:=R_NO; + + { do some hacking if we call a method pointer } + { which is a class member } + { else ESI is overwritten ! } + if (p^.right^.location.reference.base=R_ESI) or + (p^.right^.location.reference.index=R_ESI) then + begin + del_reference(p^.right^.location.reference); + exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, + newreference(p^.right^.location.reference),R_EDI))); + hregister:=R_EDI; + end; + + + if ((p^.procdefinition^.options and pocontainsself)=0) then + begin + { load ESI } + inc(p^.right^.location.reference.offset,4); + exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, + newreference(p^.right^.location.reference),R_ESI))); + dec(p^.right^.location.reference.offset,4); + { push self pointer } + exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_ESI))); + end; + + if hregister=R_NO then + exprasmlist^.concat(new(pai386,op_ref(A_CALL,S_NO,newreference(p^.right^.location.reference)))) + else + exprasmlist^.concat(new(pai386,op_reg(A_CALL,S_NO,hregister))); + + del_reference(p^.right^.location.reference); + end + else + begin + case p^.right^.location.loc of + LOC_REGISTER,LOC_CREGISTER: + begin + exprasmlist^.concat(new(pai386,op_reg(A_CALL,S_NO,p^.right^.location.register))); + ungetregister32(p^.right^.location.register); + end + else + exprasmlist^.concat(new(pai386,op_ref(A_CALL,S_NO,newreference(p^.right^.location.reference)))); + del_reference(p^.right^.location.reference); + end; + end; + end; + + { this was only for normal functions + displaced here so we also get + it to work for procvars PM } + if (not inlined) and ((p^.procdefinition^.options and poclearstack)<>0) then + begin + { consider the alignment with the rest (PM) } + inc(pushedparasize,pop_size); + pop_size:=0; + { better than an add on all processors } + if pushedparasize=4 then + exprasmlist^.concat(new(pai386,op_reg(A_POP,S_L,R_EDI))) + { the pentium has two pipes and pop reg is pairable } + { but the registers must be different! } + else if (pushedparasize=8) and + not(cs_littlesize in aktglobalswitches) and + (aktoptprocessor=ClassP5) and + (procinfo._class=nil) then + begin + exprasmlist^.concat(new(pai386,op_reg(A_POP,S_L,R_EDI))); + exprasmlist^.concat(new(pai386,op_reg(A_POP,S_L,R_ESI))); + end + else if pushedparasize<>0 then + exprasmlist^.concat(new(pai386,op_const_reg(A_ADD,S_L,pushedparasize,R_ESP))); + end; + dont_call: + pushedparasize:=oldpushedparasize; + unused:=unusedregisters; + + { handle function results } + { structured results are easy to handle.... } + { needed also when result_no_used !! } + if (p^.resulttype<>pdef(voiddef)) and ret_in_param(p^.resulttype) then + begin + p^.location.loc:=LOC_MEM; + p^.location.reference.symbol:=nil; + p^.location.reference:=funcretref; + end; + { we have only to handle the result if it is used, but } + { ansi/widestrings must be registered, so we can dispose them } + if (p^.resulttype<>pdef(voiddef)) and (p^.return_value_used or + is_ansistring(p^.resulttype) or is_widestring(p^.resulttype)) then + begin + { a contructor could be a function with boolean result } + if (p^.right=nil) and + ((p^.procdefinition^.options and poconstructor)<>0) and + { quick'n'dirty check if it is a class or an object } + (p^.resulttype^.deftype=orddef) then + begin + p^.location.loc:=LOC_FLAGS; + p^.location.resflags:=F_NE; + if extended_new then + begin +{$ifdef test_dest_loc} + if dest_loc_known and (dest_loc_tree=p) then + mov_reg_to_dest(p,S_L,R_EAX) + else +{$endif test_dest_loc} + begin + hregister:=getexplicitregister32(R_EAX); + emit_reg_reg(A_MOV,S_L,R_EAX,hregister); + p^.location.register:=hregister; + end; + end; + end + { structed results are easy to handle.... } + else if ret_in_param(p^.resulttype) then + begin + {p^.location.loc:=LOC_MEM; + stringdispose(p^.location.reference.symbol); + p^.location.reference:=funcretref; + already done above (PM) } + end + else + begin + if (p^.resulttype^.deftype=orddef) then + begin + p^.location.loc:=LOC_REGISTER; + case porddef(p^.resulttype)^.typ of + s32bit,u32bit,bool32bit : + begin +{$ifdef test_dest_loc} + if dest_loc_known and (dest_loc_tree=p) then + mov_reg_to_dest(p,S_L,R_EAX) + else +{$endif test_dest_loc} + begin + hregister:=getexplicitregister32(R_EAX); + emit_reg_reg(A_MOV,S_L,R_EAX,hregister); + p^.location.register:=hregister; + end; + end; + uchar,u8bit,bool8bit,s8bit: + begin +{$ifdef test_dest_loc} + if dest_loc_known and (dest_loc_tree=p) then + mov_reg_to_dest(p,S_B,R_AL) + else +{$endif test_dest_loc} + begin + hregister:=getexplicitregister32(R_EAX); + emit_reg_reg(A_MOV,S_B,R_AL,reg32toreg8(hregister)); + p^.location.register:=reg32toreg8(hregister); + end; + end; + s16bit,u16bit,bool16bit : + begin +{$ifdef test_dest_loc} + if dest_loc_known and (dest_loc_tree=p) then + mov_reg_to_dest(p,S_W,R_AX) + else +{$endif test_dest_loc} + begin + hregister:=getexplicitregister32(R_EAX); + emit_reg_reg(A_MOV,S_W,R_AX,reg32toreg16(hregister)); + p^.location.register:=reg32toreg16(hregister); + end; + end; + s64bitint,u64bit: + begin +{$ifdef test_dest_loc} +{$error Don't know what to do here} +{$endif test_dest_loc} + hregister:=getexplicitregister32(R_EAX); + hregister2:=getexplicitregister32(R_EDX); + emit_reg_reg(A_MOV,S_L,R_EAX,hregister); + emit_reg_reg(A_MOV,S_L,R_EDX,hregister2); + p^.location.registerlow:=hregister; + p^.location.registerhigh:=hregister2; + end; + else internalerror(7); + end + + end + else if (p^.resulttype^.deftype=floatdef) then + case pfloatdef(p^.resulttype)^.typ of + f32bit: + begin + p^.location.loc:=LOC_REGISTER; +{$ifdef test_dest_loc} + if dest_loc_known and (dest_loc_tree=p) then + mov_reg_to_dest(p,S_L,R_EAX) + else +{$endif test_dest_loc} + begin + hregister:=getexplicitregister32(R_EAX); + emit_reg_reg(A_MOV,S_L,R_EAX,hregister); + p^.location.register:=hregister; + end; + end; + else + p^.location.loc:=LOC_FPU; + end + else if is_ansistring(p^.resulttype) or + is_widestring(p^.resulttype) then + begin + gettempansistringreference(hr); + { cleanup the temp slot } + exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_EAX))); + decrstringref(exprasmlist,p^.resulttype,hr); + exprasmlist^.concat(new(pai386,op_reg(A_POP,S_L,R_EAX))); + + exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L,R_EAX, + newreference(hr)))); + p^.location.loc:=LOC_MEM; + p^.location.reference:=hr; + end + else + begin + p^.location.loc:=LOC_REGISTER; +{$ifdef test_dest_loc} + if dest_loc_known and (dest_loc_tree=p) then + mov_reg_to_dest(p,S_L,R_EAX) + else +{$endif test_dest_loc} + begin + hregister:=getexplicitregister32(R_EAX); + emit_reg_reg(A_MOV,S_L,R_EAX,hregister); + p^.location.register:=hregister; + end; + end; + end; + end; + + { perhaps i/o check ? } + if iolabel<>nil then + begin + exprasmlist^.concat(new(pai386,op_sym(A_PUSH,S_L,newasmsymbol(lab2str(iolabel))))); + emitcall('FPC_IOCHECK',true); + end; + if pop_size>0 then + exprasmlist^.concat(new(pai386,op_const_reg(A_ADD,S_L,pop_size,R_ESP))); + + { restore registers } + popusedregisters(exprasmlist,pushed); + + { at last, restore instance pointer (SELF) } + if loadesi then + maybe_loadesi; + pp:=params; + while assigned(pp) do + begin + if assigned(pp^.left) then + begin + if (pp^.left^.location.loc in [LOC_REFERENCE,LOC_MEM]) and + ungettempoftype(pp^.left^.resulttype) then + ungetiftemp(pp^.left^.location.reference); + { process also all nodes of an array of const } + if pp^.left^.treetype=arrayconstructn then + begin + if assigned(pp^.left^.left) then + begin + hp:=pp^.left; + while assigned(hp) do + begin + if (hp^.left^.location.loc in [LOC_REFERENCE,LOC_MEM]) and + ungettempoftype(hp^.left^.resulttype) then + ungetiftemp(hp^.left^.location.reference); + hp:=hp^.right; + end; + end; + end; + end; + pp:=pp^.right; + end; + if inlined then + ungetpersistanttemp(inlinecode^.retoffset); + disposetree(params); + + + { from now on the result can be freed normally } + if inlined and ret_in_param(p^.resulttype) then + persistanttemptonormal(funcretref.offset); + + { if return value is not used } + if (not p^.return_value_used) and (p^.resulttype<>pdef(voiddef)) then + begin + if p^.location.loc in [LOC_MEM,LOC_REFERENCE] then + begin + { data which must be finalized ? } + if (p^.resulttype^.needs_inittable) and + ( (p^.resulttype^.deftype<>objectdef) or + not(pobjectdef(p^.resulttype)^.isclass)) then + finalize(exprasmlist,p^.resulttype,p^.location.reference); + { release unused temp } + ungetiftemp(p^.location.reference) + end + else if p^.location.loc=LOC_FPU then + { release FPU stack } + exprasmlist^.concat(new(pai386,op_reg(A_FSTP,S_NO,R_ST0))); + end; + end; + + +{***************************************************************************** + SecondProcInlineN +*****************************************************************************} + + + procedure secondprocinline(var p : ptree); + var st : psymtable; + oldprocsym : pprocsym; + para_size : longint; + oldprocinfo : tprocinfo; + { just dummies for genentrycode } + nostackframe,make_global : boolean; + proc_names : tstringcontainer; + inlineentrycode,inlineexitcode : paasmoutput; + oldexitlabel,oldexit2label,oldquickexitlabel:Plabel; + begin + oldexitlabel:=aktexitlabel; + oldexit2label:=aktexit2label; + oldquickexitlabel:=quickexitlabel; + getlabel(aktexitlabel); + getlabel(aktexit2label); + oldprocsym:=aktprocsym; + oldprocinfo:=procinfo; + { set the return value } + aktprocsym:=p^.inlineprocsym; + procinfo.retdef:=aktprocsym^.definition^.retdef; + procinfo.retoffset:=p^.retoffset; + { arg space has been filled by the parent secondcall } + st:=aktprocsym^.definition^.localst; + { set it to the same lexical level } + st^.symtablelevel:=oldprocsym^.definition^.localst^.symtablelevel; + if st^.datasize>0 then + begin + st^.address_fixup:=gettempofsizepersistant(st^.datasize); +{$ifdef extdebug} + Comment(V_debug,'local symtable is at offset '+tostr(st^.address_fixup)); + exprasmlist^.concat(new(pai_asm_comment,init(strpnew( + 'local symtable is at offset '+tostr(st^.address_fixup))))); +{$endif extdebug} + end; +{$ifdef extdebug} + exprasmlist^.concat(new(pai_asm_comment,init('Start of inlined proc'))); +{$endif extdebug} + { takes care of local data initialization } + inlineentrycode:=new(paasmoutput,init); + inlineexitcode:=new(paasmoutput,init); + proc_names.init; + para_size:=p^.para_size; + make_global:=false; { to avoid warning } + genentrycode(inlineentrycode,proc_names,make_global,0,para_size,nostackframe,true); + exprasmlist^.concatlist(inlineentrycode); + secondpass(p^.inlinetree); + genexitcode(inlineexitcode,0,false,true); + exprasmlist^.concatlist(inlineexitcode); +{$ifdef extdebug} + exprasmlist^.concat(new(pai_asm_comment,init('End of inlined proc'))); +{$endif extdebug} + {we can free the local data now, reset also the fixup address } + if st^.datasize>0 then + begin + ungetpersistanttemp(st^.address_fixup); + st^.address_fixup:=0; + end; + aktprocsym:=oldprocsym; + freelabel(aktexitlabel); + freelabel(aktexit2label); + aktexitlabel:=oldexitlabel; + aktexit2label:=oldexit2label; + quickexitlabel:=oldquickexitlabel; + procinfo:=oldprocinfo; + end; + + + +end. +{ $Log$ - Revision 1.85 1999-05-21 13:54:44 peter + Revision 1.86 1999-05-23 18:41:58 florian + * better error recovering in typed constants + * some problems with arrays of const fixed, some problems + due my previous + - the location type of array constructor is now LOC_MEM + - the pushing of high fixed + - parameter copying fixed + - zero temp. allocation removed + * small problem in the assembler writers fixed: + ref to nil wasn't written correctly + + Revision 1.85 1999/05/21 13:54:44 peter * NEWLAB for label as symbol - - Revision 1.84 1999/05/18 22:34:26 pierre - * extedebug problem solved - - Revision 1.83 1999/05/18 21:58:24 florian - * fixed some bugs related to temp. ansistrings and functions results - which return records/objects/arrays which need init/final. - - Revision 1.82 1999/05/18 14:15:23 peter - * containsself fixes - * checktypes() - - Revision 1.81 1999/05/18 09:52:17 peter - * procedure of object and addrn fixes - - Revision 1.80 1999/05/17 23:51:37 peter - * with temp vars now use a reference with a persistant temp instead - of setting datasize - - Revision 1.79 1999/05/17 21:56:59 florian - * new temporary ansistring handling - - Revision 1.78 1999/05/01 13:24:02 peter - * merged nasm compiler - * old asm moved to oldasm/ - - Revision 1.77 1999/04/29 22:12:21 pierre - * fix for ID 388 removing real from stack was wrong - - Revision 1.76 1999/04/25 22:33:19 pierre - * fix for TESTOBJEXT code - - Revision 1.75 1999/04/19 09:45:46 pierre - + cdecl or stdcall push all args with longint size - * tempansi stuff cleaned up - - Revision 1.74 1999/04/16 13:42:23 jonas - * more regalloc fixes (still not complete) - - Revision 1.73 1999/04/16 10:26:56 pierre - * no add $0,%esp for cdecl functions without parameters - - Revision 1.72 1999/04/09 08:41:48 peter - * define to get ansistring returns in ref instead of reg - - Revision 1.71 1999/03/31 13:55:04 peter - * assembler inlining working for ag386bin - - Revision 1.70 1999/03/24 23:16:46 peter - * fixed bugs 212,222,225,227,229,231,233 - - Revision 1.69 1999/02/25 21:02:21 peter - * ag386bin updates - + coff writer - - Revision 1.68 1999/02/22 02:15:04 peter - * updates for ag386bin - - Revision 1.67 1999/02/11 09:46:21 pierre - * fix for normal method calls inside static methods : - WARNING there were both parser and codegen errors !! - added static_call boolean to calln tree - - Revision 1.66 1999/02/09 15:45:46 florian - + complex results for assembler functions, fixes bug0155 - - Revision 1.65 1999/02/08 11:29:04 pierre - * fix for bug0214 - several problems where combined - search_class_member did not set srsymtable - => in do_member_read the call node got a wrong symtable - in cg386cal the vmt was pushed twice without chacking if it exists - now %esi is set to zero and pushed if not vmt - (not very efficient but should work !) - - Revision 1.64 1999/02/04 10:49:39 florian - + range checking for ansi- and widestrings - * made it compilable with TP - - Revision 1.63 1999/02/03 10:18:14 pierre - * conditionnal code for extended check of virtual methods - - Revision 1.62 1999/02/02 23:52:32 florian - * problem with calls to method pointers in methods fixed - - double ansistrings temp management removed - - Revision 1.61 1999/02/02 11:04:36 florian - * class destructors fixed, class instances weren't disposed correctly - - Revision 1.60 1999/01/28 23:56:44 florian - * the reference in the result location of a function call wasn't resetted => - problem with unallowed far pointer, is solved now - - Revision 1.59 1999/01/27 00:13:52 florian - * "procedure of object"-stuff fixed - - Revision 1.58 1999/01/21 22:10:35 peter - * fixed array of const - * generic platform independent high() support - - Revision 1.57 1999/01/21 16:40:51 pierre - * fix for constructor inside with statements - - Revision 1.56 1998/12/30 13:41:05 peter - * released valuepara - - Revision 1.55 1998/12/22 13:10:58 florian - * memory leaks for ansistring type casts fixed - - Revision 1.54 1998/12/19 00:23:41 florian - * ansistring memory leaks fixed - - Revision 1.53 1998/12/11 00:02:47 peter - + globtype,tokens,version unit splitted from globals - - Revision 1.52 1998/12/10 14:39:29 florian - * bug with p(const a : ansistring) fixed - * duplicate constant ansistrings were handled wrong, fixed - - Revision 1.51 1998/12/10 09:47:15 florian - + basic operations with int64/qord (compiler with -dint64) - + rtti of enumerations extended: names are now written - - Revision 1.50 1998/12/06 13:12:44 florian - * better code generation for classes which are passed as parameters to - subroutines - - Revision 1.49 1998/11/30 09:43:00 pierre - * some range check bugs fixed (still not working !) - + added DLL writing support for win32 (also accepts variables) - + TempAnsi for code that could be used for Temporary ansi strings - handling - - Revision 1.48 1998/11/27 14:50:30 peter - + open strings, $P switch support - - Revision 1.47 1998/11/26 21:30:03 peter - * fix for valuepara - - Revision 1.46 1998/11/26 14:39:10 peter - * ansistring -> pchar fixed - * ansistring constants fixed - * ansistring constants are now written once - - Revision 1.45 1998/11/18 15:44:07 peter - * VALUEPARA for tp7 compatible value parameters - - Revision 1.44 1998/11/16 15:35:36 peter - * rename laod/copystring -> load/copyshortstring - * fixed int-bool cnv bug - + char-ansistring conversion - - Revision 1.43 1998/11/15 16:32:33 florian - * some stuff of Pavel implement (win32 dll creation) - * bug with ansistring function results fixed - - Revision 1.42 1998/11/13 15:40:13 pierre - + added -Se in Makefile cvstest target - + lexlevel cleanup - normal_function_level main_program_level and unit_init_level defined - * tins_cache grown to A_EMMS (gave range check error in asm readers) - (test added in code !) - * -Un option was wrong - * _FAIL and _SELF only keyword inside - constructors and methods respectively - - Revision 1.41 1998/11/12 11:19:40 pierre - * fix for first line of function break - - Revision 1.40 1998/11/10 10:09:08 peter - * va_list -> array of const - - Revision 1.39 1998/11/09 11:44:33 peter - + va_list for printf support - - Revision 1.38 1998/10/21 15:12:49 pierre - * bug fix for IOCHECK inside a procedure with iocheck modifier - * removed the GPF for unexistant overloading - (firstcall was called with procedinition=nil !) - * changed typen to what Florian proposed - gentypenode(p : pdef) sets the typenodetype field - and resulttype is only set if inside bt_type block ! - - Revision 1.37 1998/10/21 08:39:57 florian - + ansistring operator + - + $h and string[n] for n>255 added - * small problem with TP fixed - - Revision 1.36 1998/10/20 08:06:39 pierre - * several memory corruptions due to double freemem solved - => never use p^.loc.location:=p^.left^.loc.location; - + finally I added now by default - that ra386dir translates global and unit symbols - + added a first field in tsymtable and - a nextsym field in tsym - (this allows to obtain ordered type info for - records and objects in gdb !) - - Revision 1.35 1998/10/16 08:51:45 peter - + target_os.stackalignment - + stack can be aligned at 2 or 4 byte boundaries - - Revision 1.34 1998/10/09 08:56:22 pierre - * several memory leaks fixed - - Revision 1.33 1998/10/06 17:16:39 pierre - * some memory leaks fixed (thanks to Peter for heaptrc !) - - Revision 1.32 1998/10/01 09:22:52 peter - * fixed value openarray - * ungettemp of arrayconstruct - - Revision 1.31 1998/09/28 16:57:15 pierre - * changed all length(p^.value_str^) into str_length(p) - to get it work with and without ansistrings - * changed sourcefiles field of tmodule to a pointer - - Revision 1.30 1998/09/26 15:03:02 florian - * small problems with DOM and excpetions fixed (code generation - of raise was wrong and self was sometimes destroyed :() - - Revision 1.29 1998/09/25 00:04:00 florian - * problems when calling class methods fixed - - Revision 1.28 1998/09/24 14:27:37 peter - * some better support for openarray - - Revision 1.27 1998/09/24 09:02:13 peter - * rewritten isconvertable to use case - * array of .. and single variable are compatible - - Revision 1.26 1998/09/21 08:45:06 pierre - + added vmt_offset in tobjectdef.write for fututre use - (first steps to have objects without vmt if no virtual !!) - + added fpu_used field for tabstractprocdef : - sets this level to 2 if the functions return with value in FPU - (is then set to correct value at parsing of implementation) - THIS MIGHT refuse some code with FPU expression too complex - that were accepted before and even in some cases - that don't overflow in fact - ( like if f : float; is a forward that finally in implementation - only uses one fpu register !!) - Nevertheless I think that it will improve security on - FPU operations !! - * most other changes only for UseBrowser code - (added symtable references for record and objects) - local switch for refs to args and local of each function - (static symtable still missing) - UseBrowser still not stable and probably broken by - the definition hash array !! - - Revision 1.25 1998/09/20 12:26:35 peter - * merged fixes - - Revision 1.24 1998/09/17 09:42:10 peter - + pass_2 for cg386 - * Message() -> CGMessage() for pass_1/pass_2 - - Revision 1.23 1998/09/14 10:43:45 peter - * all internal RTL functions start with FPC_ - - Revision 1.22.2.1 1998/09/20 12:20:06 peter - * Fixed stack not on 4 byte boundary when doing a call - - Revision 1.22 1998/09/04 08:41:37 peter - * updated some error CGMessages - - Revision 1.21 1998/09/01 12:47:57 peter - * use pdef^.size instead of orddef^.typ - - Revision 1.20 1998/08/31 12:22:15 peter - * secondinline moved to cg386inl - - Revision 1.19 1998/08/31 08:52:03 peter - * fixed error 10 with succ() and pref() - - Revision 1.18 1998/08/20 21:36:38 peter - * fixed 'with object do' bug - - Revision 1.17 1998/08/19 16:07:36 jonas - * changed optimizer switches + cleanup of DestroyRefs in daopt386.pas - - Revision 1.16 1998/08/18 09:24:36 pierre - * small warning position bug fixed - * support_mmx switches splitting was missing - * rhide error and warning output corrected - - Revision 1.15 1998/08/13 11:00:09 peter - * fixed procedure<>procedure construct - - Revision 1.14 1998/08/11 14:05:33 peter - * fixed sizeof(array of char) - - Revision 1.13 1998/08/10 14:49:45 peter - + localswitches, moduleswitches, globalswitches splitting - - Revision 1.12 1998/07/30 13:30:31 florian - * final implemenation of exception support, maybe it needs - some fixes :) - - Revision 1.11 1998/07/24 22:16:52 florian - * internal error 10 together with array access fixed. I hope - that's the final fix. - - Revision 1.10 1998/07/18 22:54:23 florian - * some ansi/wide/longstring support fixed: - o parameter passing - o returning as result from functions - - Revision 1.9 1998/07/07 17:40:37 peter - * packrecords 4 works - * word aligning of parameters - - Revision 1.8 1998/07/06 15:51:15 michael - Added length checking for string reading - - Revision 1.7 1998/07/06 14:19:51 michael - + Added calls for reading/writing ansistrings - - Revision 1.6 1998/07/01 15:28:48 peter - + better writeln/readln handling, now 100% like tp7 - - Revision 1.5 1998/06/25 14:04:17 peter - + internal inc/dec - - Revision 1.4 1998/06/25 08:48:06 florian - * first version of rtti support - - Revision 1.3 1998/06/09 16:01:33 pierre - + added procedure directive parsing for procvars - (accepted are popstack cdecl and pascal) - + added C vars with the following syntax - var C calias 'true_c_name';(can be followed by external) - reason is that you must add the Cprefix - - which is target dependent - - Revision 1.2 1998/06/08 13:13:29 pierre - + temporary variables now in temp_gen.pas unit - because it is processor independent - * mppc68k.bat modified to undefine i386 and support_mmx - (which are defaults for i386) - - Revision 1.1 1998/06/05 17:44:10 peter - * splitted cgi386 - -} - + + Revision 1.84 1999/05/18 22:34:26 pierre + * extedebug problem solved + + Revision 1.83 1999/05/18 21:58:24 florian + * fixed some bugs related to temp. ansistrings and functions results + which return records/objects/arrays which need init/final. + + Revision 1.82 1999/05/18 14:15:23 peter + * containsself fixes + * checktypes() + + Revision 1.81 1999/05/18 09:52:17 peter + * procedure of object and addrn fixes + + Revision 1.80 1999/05/17 23:51:37 peter + * with temp vars now use a reference with a persistant temp instead + of setting datasize + + Revision 1.79 1999/05/17 21:56:59 florian + * new temporary ansistring handling + + Revision 1.78 1999/05/01 13:24:02 peter + * merged nasm compiler + * old asm moved to oldasm/ + + Revision 1.77 1999/04/29 22:12:21 pierre + * fix for ID 388 removing real from stack was wrong + + Revision 1.76 1999/04/25 22:33:19 pierre + * fix for TESTOBJEXT code + + Revision 1.75 1999/04/19 09:45:46 pierre + + cdecl or stdcall push all args with longint size + * tempansi stuff cleaned up + + Revision 1.74 1999/04/16 13:42:23 jonas + * more regalloc fixes (still not complete) + + Revision 1.73 1999/04/16 10:26:56 pierre + * no add $0,%esp for cdecl functions without parameters + + Revision 1.72 1999/04/09 08:41:48 peter + * define to get ansistring returns in ref instead of reg + + Revision 1.71 1999/03/31 13:55:04 peter + * assembler inlining working for ag386bin + + Revision 1.70 1999/03/24 23:16:46 peter + * fixed bugs 212,222,225,227,229,231,233 + + Revision 1.69 1999/02/25 21:02:21 peter + * ag386bin updates + + coff writer + + Revision 1.68 1999/02/22 02:15:04 peter + * updates for ag386bin + + Revision 1.67 1999/02/11 09:46:21 pierre + * fix for normal method calls inside static methods : + WARNING there were both parser and codegen errors !! + added static_call boolean to calln tree + + Revision 1.66 1999/02/09 15:45:46 florian + + complex results for assembler functions, fixes bug0155 + + Revision 1.65 1999/02/08 11:29:04 pierre + * fix for bug0214 + several problems where combined + search_class_member did not set srsymtable + => in do_member_read the call node got a wrong symtable + in cg386cal the vmt was pushed twice without chacking if it exists + now %esi is set to zero and pushed if not vmt + (not very efficient but should work !) + + Revision 1.64 1999/02/04 10:49:39 florian + + range checking for ansi- and widestrings + * made it compilable with TP + + Revision 1.63 1999/02/03 10:18:14 pierre + * conditionnal code for extended check of virtual methods + + Revision 1.62 1999/02/02 23:52:32 florian + * problem with calls to method pointers in methods fixed + - double ansistrings temp management removed + + Revision 1.61 1999/02/02 11:04:36 florian + * class destructors fixed, class instances weren't disposed correctly + + Revision 1.60 1999/01/28 23:56:44 florian + * the reference in the result location of a function call wasn't resetted => + problem with unallowed far pointer, is solved now + + Revision 1.59 1999/01/27 00:13:52 florian + * "procedure of object"-stuff fixed + + Revision 1.58 1999/01/21 22:10:35 peter + * fixed array of const + * generic platform independent high() support + + Revision 1.57 1999/01/21 16:40:51 pierre + * fix for constructor inside with statements + + Revision 1.56 1998/12/30 13:41:05 peter + * released valuepara + + Revision 1.55 1998/12/22 13:10:58 florian + * memory leaks for ansistring type casts fixed + + Revision 1.54 1998/12/19 00:23:41 florian + * ansistring memory leaks fixed + + Revision 1.53 1998/12/11 00:02:47 peter + + globtype,tokens,version unit splitted from globals + + Revision 1.52 1998/12/10 14:39:29 florian + * bug with p(const a : ansistring) fixed + * duplicate constant ansistrings were handled wrong, fixed + + Revision 1.51 1998/12/10 09:47:15 florian + + basic operations with int64/qord (compiler with -dint64) + + rtti of enumerations extended: names are now written + + Revision 1.50 1998/12/06 13:12:44 florian + * better code generation for classes which are passed as parameters to + subroutines + + Revision 1.49 1998/11/30 09:43:00 pierre + * some range check bugs fixed (still not working !) + + added DLL writing support for win32 (also accepts variables) + + TempAnsi for code that could be used for Temporary ansi strings + handling + + Revision 1.48 1998/11/27 14:50:30 peter + + open strings, $P switch support + + Revision 1.47 1998/11/26 21:30:03 peter + * fix for valuepara + + Revision 1.46 1998/11/26 14:39:10 peter + * ansistring -> pchar fixed + * ansistring constants fixed + * ansistring constants are now written once + + Revision 1.45 1998/11/18 15:44:07 peter + * VALUEPARA for tp7 compatible value parameters + + Revision 1.44 1998/11/16 15:35:36 peter + * rename laod/copystring -> load/copyshortstring + * fixed int-bool cnv bug + + char-ansistring conversion + + Revision 1.43 1998/11/15 16:32:33 florian + * some stuff of Pavel implement (win32 dll creation) + * bug with ansistring function results fixed + + Revision 1.42 1998/11/13 15:40:13 pierre + + added -Se in Makefile cvstest target + + lexlevel cleanup + normal_function_level main_program_level and unit_init_level defined + * tins_cache grown to A_EMMS (gave range check error in asm readers) + (test added in code !) + * -Un option was wrong + * _FAIL and _SELF only keyword inside + constructors and methods respectively + + Revision 1.41 1998/11/12 11:19:40 pierre + * fix for first line of function break + + Revision 1.40 1998/11/10 10:09:08 peter + * va_list -> array of const + + Revision 1.39 1998/11/09 11:44:33 peter + + va_list for printf support + + Revision 1.38 1998/10/21 15:12:49 pierre + * bug fix for IOCHECK inside a procedure with iocheck modifier + * removed the GPF for unexistant overloading + (firstcall was called with procedinition=nil !) + * changed typen to what Florian proposed + gentypenode(p : pdef) sets the typenodetype field + and resulttype is only set if inside bt_type block ! + + Revision 1.37 1998/10/21 08:39:57 florian + + ansistring operator + + + $h and string[n] for n>255 added + * small problem with TP fixed + + Revision 1.36 1998/10/20 08:06:39 pierre + * several memory corruptions due to double freemem solved + => never use p^.loc.location:=p^.left^.loc.location; + + finally I added now by default + that ra386dir translates global and unit symbols + + added a first field in tsymtable and + a nextsym field in tsym + (this allows to obtain ordered type info for + records and objects in gdb !) + + Revision 1.35 1998/10/16 08:51:45 peter + + target_os.stackalignment + + stack can be aligned at 2 or 4 byte boundaries + + Revision 1.34 1998/10/09 08:56:22 pierre + * several memory leaks fixed + + Revision 1.33 1998/10/06 17:16:39 pierre + * some memory leaks fixed (thanks to Peter for heaptrc !) + + Revision 1.32 1998/10/01 09:22:52 peter + * fixed value openarray + * ungettemp of arrayconstruct + + Revision 1.31 1998/09/28 16:57:15 pierre + * changed all length(p^.value_str^) into str_length(p) + to get it work with and without ansistrings + * changed sourcefiles field of tmodule to a pointer + + Revision 1.30 1998/09/26 15:03:02 florian + * small problems with DOM and excpetions fixed (code generation + of raise was wrong and self was sometimes destroyed :() + + Revision 1.29 1998/09/25 00:04:00 florian + * problems when calling class methods fixed + + Revision 1.28 1998/09/24 14:27:37 peter + * some better support for openarray + + Revision 1.27 1998/09/24 09:02:13 peter + * rewritten isconvertable to use case + * array of .. and single variable are compatible + + Revision 1.26 1998/09/21 08:45:06 pierre + + added vmt_offset in tobjectdef.write for fututre use + (first steps to have objects without vmt if no virtual !!) + + added fpu_used field for tabstractprocdef : + sets this level to 2 if the functions return with value in FPU + (is then set to correct value at parsing of implementation) + THIS MIGHT refuse some code with FPU expression too complex + that were accepted before and even in some cases + that don't overflow in fact + ( like if f : float; is a forward that finally in implementation + only uses one fpu register !!) + Nevertheless I think that it will improve security on + FPU operations !! + * most other changes only for UseBrowser code + (added symtable references for record and objects) + local switch for refs to args and local of each function + (static symtable still missing) + UseBrowser still not stable and probably broken by + the definition hash array !! + + Revision 1.25 1998/09/20 12:26:35 peter + * merged fixes + + Revision 1.24 1998/09/17 09:42:10 peter + + pass_2 for cg386 + * Message() -> CGMessage() for pass_1/pass_2 + + Revision 1.23 1998/09/14 10:43:45 peter + * all internal RTL functions start with FPC_ + + Revision 1.22.2.1 1998/09/20 12:20:06 peter + * Fixed stack not on 4 byte boundary when doing a call + + Revision 1.22 1998/09/04 08:41:37 peter + * updated some error CGMessages + + Revision 1.21 1998/09/01 12:47:57 peter + * use pdef^.size instead of orddef^.typ + + Revision 1.20 1998/08/31 12:22:15 peter + * secondinline moved to cg386inl + + Revision 1.19 1998/08/31 08:52:03 peter + * fixed error 10 with succ() and pref() + + Revision 1.18 1998/08/20 21:36:38 peter + * fixed 'with object do' bug + + Revision 1.17 1998/08/19 16:07:36 jonas + * changed optimizer switches + cleanup of DestroyRefs in daopt386.pas + + Revision 1.16 1998/08/18 09:24:36 pierre + * small warning position bug fixed + * support_mmx switches splitting was missing + * rhide error and warning output corrected + + Revision 1.15 1998/08/13 11:00:09 peter + * fixed procedure<>procedure construct + + Revision 1.14 1998/08/11 14:05:33 peter + * fixed sizeof(array of char) + + Revision 1.13 1998/08/10 14:49:45 peter + + localswitches, moduleswitches, globalswitches splitting + + Revision 1.12 1998/07/30 13:30:31 florian + * final implemenation of exception support, maybe it needs + some fixes :) + + Revision 1.11 1998/07/24 22:16:52 florian + * internal error 10 together with array access fixed. I hope + that's the final fix. + + Revision 1.10 1998/07/18 22:54:23 florian + * some ansi/wide/longstring support fixed: + o parameter passing + o returning as result from functions + + Revision 1.9 1998/07/07 17:40:37 peter + * packrecords 4 works + * word aligning of parameters + + Revision 1.8 1998/07/06 15:51:15 michael + Added length checking for string reading + + Revision 1.7 1998/07/06 14:19:51 michael + + Added calls for reading/writing ansistrings + + Revision 1.6 1998/07/01 15:28:48 peter + + better writeln/readln handling, now 100% like tp7 + + Revision 1.5 1998/06/25 14:04:17 peter + + internal inc/dec + + Revision 1.4 1998/06/25 08:48:06 florian + * first version of rtti support + + Revision 1.3 1998/06/09 16:01:33 pierre + + added procedure directive parsing for procvars + (accepted are popstack cdecl and pascal) + + added C vars with the following syntax + var C calias 'true_c_name';(can be followed by external) + reason is that you must add the Cprefix + + which is target dependent + + Revision 1.2 1998/06/08 13:13:29 pierre + + temporary variables now in temp_gen.pas unit + because it is processor independent + * mppc68k.bat modified to undefine i386 and support_mmx + (which are defaults for i386) + + Revision 1.1 1998/06/05 17:44:10 peter + * splitted cgi386 + +} + diff --git a/compiler/cg386inl.pas b/compiler/cg386inl.pas index e6e2f96499..666f1a676f 100644 --- a/compiler/cg386inl.pas +++ b/compiler/cg386inl.pas @@ -1,1540 +1,1551 @@ -{ - $Id$ - Copyright (c) 1993-98 by Florian Klaempfl - - Generate i386 inline nodes - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - - **************************************************************************** -} -unit cg386inl; -interface - - uses - tree; - - procedure secondinline(var p : ptree); - - -implementation - - uses - globtype,systems, - cobjects,verbose,globals,files, - symtable,aasm,types, - hcodegen,temp_gen,pass_1,pass_2, -{$ifndef OLDASM} - i386base,i386asm, -{$else} - i386, -{$endif} - cgai386,tgeni386,cg386cal; - - -{***************************************************************************** - Helpers -*****************************************************************************} - - { reverts the parameter list } - var nb_para : integer; - - function reversparameter(p : ptree) : ptree; - - var - hp1,hp2 : ptree; - - begin - hp1:=nil; - nb_para := 0; - while assigned(p) do - begin - { pull out } - hp2:=p; - p:=p^.right; - inc(nb_para); - { pull in } - hp2^.right:=hp1; - hp1:=hp2; - end; - reversparameter:=hp1; - end; - - -{***************************************************************************** - SecondInLine -*****************************************************************************} - - procedure StoreDirectFuncResult(dest:ptree); - var - hp : ptree; - hdef : porddef; - hreg : tregister; - oldregisterdef : boolean; - begin - SecondPass(dest); - if Codegenerror then - exit; - Case dest^.resulttype^.deftype of - floatdef: - floatstore(PFloatDef(dest^.resulttype)^.typ,dest^.location.reference); - orddef: - begin - Case dest^.resulttype^.size of - 1 : hreg:=regtoreg8(accumulator); - 2 : hreg:=regtoreg16(accumulator); - 4 : hreg:=accumulator; - End; - emit_mov_reg_loc(hreg,dest^.location); - If (cs_check_range in aktlocalswitches) and - {no need to rangecheck longints or cardinals on 32bit processors} - not((porddef(dest^.resulttype)^.typ = s32bit) and - (porddef(dest^.resulttype)^.low = $80000000) and - (porddef(dest^.resulttype)^.high = $7fffffff)) and - not((porddef(dest^.resulttype)^.typ = u32bit) and - (porddef(dest^.resulttype)^.low = 0) and - (porddef(dest^.resulttype)^.high = $ffffffff)) then - Begin - {do not register this temporary def} - OldRegisterDef := RegisterDef; - RegisterDef := False; - hdef:=nil; - Case PordDef(dest^.resulttype)^.typ of - u8bit,u16bit,u32bit: - begin - new(hdef,init(u32bit,0,$ffffffff)); - hreg:=accumulator; - end; - s8bit,s16bit,s32bit: - begin - new(hdef,init(s32bit,$80000000,$7fffffff)); - hreg:=accumulator; - end; - end; - { create a fake node } - hp := genzeronode(nothingn); - hp^.location.loc := LOC_REGISTER; - hp^.location.register := hreg; - if assigned(hdef) then - hp^.resulttype:=hdef - else - hp^.resulttype:=dest^.resulttype; - { emit the range check } - emitrangecheck(hp,dest^.resulttype); - hp^.right := nil; - if assigned(hdef) then - Dispose(hdef, Done); - RegisterDef := OldRegisterDef; - disposetree(hp); - End; - End; - else - internalerror(66766766); - end; - end; - - - procedure secondinline(var p : ptree); - const - {tfloattype = (s32real,s64real,s80real,s64bit,f16bit,f32bit);} -{ float_name: array[tfloattype] of string[8]= - ('S32REAL','S64REAL','S80REAL','S64BIT','F16BIT','F32BIT'); } - incdecop:array[in_inc_x..in_dec_x] of tasmop=(A_INC,A_DEC); - addsubop:array[in_inc_x..in_dec_x] of tasmop=(A_ADD,A_SUB); - var - aktfile : treference; - ft : tfiletype; - opsize : topsize; - op, - asmop : tasmop; - pushed : tpushed; - {inc/dec} - addconstant : boolean; - addvalue : longint; - - - procedure handlereadwrite(doread,doln : boolean); - { produces code for READ(LN) and WRITE(LN) } - - procedure loadstream; - const - io:array[boolean] of string[7]=('_OUTPUT','_INPUT'); - var - r : preference; - begin - new(r); - reset_reference(r^); - r^.symbol:=newasmsymbol('U_'+upper(target_info.system_unit)+io[doread]); -{$ifndef NEWLAB} - concat_external(r^.symbol^.name,EXT_NEAR); -{$endif} - exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L,r,R_EDI))) - end; - - const - rdwrprefix:array[boolean] of string[15]=('FPC_WRITE_TEXT_','FPC_READ_TEXT_'); - var - destpara, - node,hp : ptree; - typedtyp, - pararesult : pdef; - orgfloattype : tfloattype; - has_length : boolean; - dummycoll : tdefcoll; - iolabel : plabel; - npara : longint; - begin - { I/O check } - if (cs_check_io in aktlocalswitches) and - ((aktprocsym^.definition^.options and poiocheck)=0) then - begin - getlabel(iolabel); - emitlab(iolabel); - end - else - iolabel:=nil; - { for write of real with the length specified } - has_length:=false; - hp:=nil; - { reserve temporary pointer to data variable } - aktfile.symbol:=nil; - gettempofsizereference(4,aktfile); - { first state text data } - ft:=ft_text; - { and state a parameter ? } - if p^.left=nil then - begin - { the following instructions are for "writeln;" } - loadstream; - { save @aktfile in temporary variable } - exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L,R_EDI,newreference(aktfile)))); - end - else - begin - { revers paramters } - node:=reversparameter(p^.left); - - p^.left := node; - npara := nb_para; - { calculate data variable } - { is first parameter a file type ? } - if node^.left^.resulttype^.deftype=filedef then - begin - ft:=pfiledef(node^.left^.resulttype)^.filetype; - if ft=ft_typed then - typedtyp:=pfiledef(node^.left^.resulttype)^.typed_as; - secondpass(node^.left); - if codegenerror then - exit; - - { save reference in temporary variables } - if node^.left^.location.loc<>LOC_REFERENCE then - begin - CGMessage(cg_e_illegal_expression); - exit; - end; - - exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L,newreference(node^.left^.location.reference),R_EDI))); - - { skip to the next parameter } - node:=node^.right; - end - else - begin - { load stdin/stdout stream } - loadstream; - end; - - { save @aktfile in temporary variable } - exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L,R_EDI,newreference(aktfile)))); - if doread then - { parameter by READ gives call by reference } - dummycoll.paratyp:=vs_var - { an WRITE Call by "Const" } - else - dummycoll.paratyp:=vs_const; - - { because of secondcallparan, which otherwise attaches } - if ft=ft_typed then - { this is to avoid copy of simple const parameters } - {dummycoll.data:=new(pformaldef,init)} - dummycoll.data:=cformaldef - else - { I think, this isn't a good solution (FK) } - dummycoll.data:=nil; - - while assigned(node) do - begin - pushusedregisters(exprasmlist,pushed,$ff); - hp:=node; - node:=node^.right; - hp^.right:=nil; - if hp^.is_colon_para then - CGMessage(parser_e_illegal_colon_qualifier); - { when float is written then we need bestreal to be pushed - convert here else we loose the old flaot type } - if (not doread) and - (ft<>ft_typed) and - (hp^.left^.resulttype^.deftype=floatdef) then - begin - orgfloattype:=pfloatdef(hp^.left^.resulttype)^.typ; - hp^.left:=gentypeconvnode(hp^.left,bestrealdef^); - firstpass(hp^.left); - end; - { when read ord,floats are functions, so they need this - parameter as their destination instead of being pushed } - if doread and - (ft<>ft_typed) and - (hp^.resulttype^.deftype in [orddef,floatdef]) then - destpara:=hp^.left - else - begin - if ft=ft_typed then - never_copy_const_param:=true; - { reset data type } - dummycoll.data:=nil; - { create temporary defs for high tree generation } - if doread and (is_shortstring(hp^.resulttype)) then - dummycoll.data:=openshortstringdef - else - if (is_chararray(hp^.resulttype)) then - dummycoll.data:=openchararraydef; - secondcallparan(hp,@dummycoll,false,false,false,0); - if ft=ft_typed then - never_copy_const_param:=false; - end; - hp^.right:=node; - if codegenerror then - exit; - - emit_push_mem(aktfile); - if (ft=ft_typed) then - begin - { OK let's try this } - { first we must only allow the right type } - { we have to call blockread or blockwrite } - { but the real problem is that } - { reset and rewrite should have set } - { the type size } - { as recordsize for that file !!!! } - { how can we make that } - { I think that is only possible by adding } - { reset and rewrite to the inline list a call } - { allways read only one record by element } - push_int(typedtyp^.size); - if doread then - emitcall('FPC_TYPED_READ',true) - else - emitcall('FPC_TYPED_WRITE',true); - end - else - begin - { save current position } - pararesult:=hp^.left^.resulttype; - { handle possible field width } - { of course only for write(ln) } - if not doread then - begin - { handle total width parameter } - if assigned(node) and node^.is_colon_para then - begin - hp:=node; - node:=node^.right; - hp^.right:=nil; - secondcallparan(hp,@dummycoll,false,false,false,0); - hp^.right:=node; - if codegenerror then - exit; - has_length:=true; - end - else - if pararesult^.deftype<>floatdef then - push_int(0) - else - push_int(-32767); - { a second colon para for a float ? } - if assigned(node) and node^.is_colon_para then - begin - hp:=node; - node:=node^.right; - hp^.right:=nil; - secondcallparan(hp,@dummycoll,false,false,false,0); - hp^.right:=node; - if pararesult^.deftype<>floatdef then - CGMessage(parser_e_illegal_colon_qualifier); - if codegenerror then - exit; - end - else - begin - if pararesult^.deftype=floatdef then - push_int(-1); - end; - { push also the real type for floats } - if pararesult^.deftype=floatdef then - push_int(ord(orgfloattype)); - end; - case pararesult^.deftype of - stringdef : - begin - emitcall(rdwrprefix[doread]+pstringdef(pararesult)^.stringtypname,true); - end; - pointerdef : - begin - if is_pchar(pararesult) then - emitcall(rdwrprefix[doread]+'PCHAR_AS_POINTER',true) - end; - arraydef : - begin - if is_chararray(pararesult) then - emitcall(rdwrprefix[doread]+'PCHAR_AS_ARRAY',true) - end; - floatdef : - begin - emitcall(rdwrprefix[doread]+'FLOAT',true); - if doread then - StoreDirectFuncResult(destpara); - end; - orddef : - begin - case porddef(pararesult)^.typ of - s8bit,s16bit,s32bit : - emitcall(rdwrprefix[doread]+'SINT',true); - u8bit,u16bit,u32bit : - emitcall(rdwrprefix[doread]+'UINT',true); - uchar : - emitcall(rdwrprefix[doread]+'CHAR',true); - s64bitint: - emitcall(rdwrprefix[doread]+'INT64',true); - u64bit : - emitcall(rdwrprefix[doread]+'QWORD',true); - bool8bit, - bool16bit, - bool32bit : - emitcall(rdwrprefix[doread]+'BOOLEAN',true); - end; - if doread then - StoreDirectFuncResult(destpara); - end; - end; - end; - { load ESI in methods again } - popusedregisters(exprasmlist,pushed); - maybe_loadesi; - end; - end; - { Insert end of writing for textfiles } - if ft=ft_text then - begin - pushusedregisters(exprasmlist,pushed,$ff); - emit_push_mem(aktfile); - if doread then - begin - if doln then - emitcall('FPC_READLN_END',true) - else - emitcall('FPC_READ_END',true); - end - else - begin - if doln then - emitcall('FPC_WRITELN_END',true) - else - emitcall('FPC_WRITE_END',true); - end; - popusedregisters(exprasmlist,pushed); - maybe_loadesi; - end; - { Insert IOCheck if set } - if assigned(iolabel) then - begin - { registers are saved in the procedure } - exprasmlist^.concat(new(pai386,op_sym(A_PUSH,S_L,newasmsymbol(lab2str(iolabel))))); - emitcall('FPC_IOCHECK',true); - end; - { Freeup all used temps } - ungetiftemp(aktfile); - if assigned(p^.left) then - begin - p^.left:=reversparameter(p^.left); - if npara<>nb_para then - CGMessage(cg_f_internal_error_in_secondinline); - hp:=p^.left; - while assigned(hp) do - begin - if assigned(hp^.left) then - if (hp^.left^.location.loc in [LOC_MEM,LOC_REFERENCE]) then - ungetiftemp(hp^.left^.location.reference); - hp:=hp^.right; - end; - end; - end; - - procedure handle_str; - - var - hp,node : ptree; - dummycoll : tdefcoll; - is_real,has_length : boolean; - realtype : tfloattype; - procedureprefix : string; - - begin - pushusedregisters(exprasmlist,pushed,$ff); - node:=p^.left; - is_real:=false; - has_length:=false; - while assigned(node^.right) do node:=node^.right; - { if a real parameter somewhere then call REALSTR } - if (node^.left^.resulttype^.deftype=floatdef) then - begin - is_real:=true; - realtype:=pfloatdef(node^.left^.resulttype)^.typ; - end; - - node:=p^.left; - { we have at least two args } - { with at max 2 colon_para in between } - - { string arg } - hp:=node; - node:=node^.right; - hp^.right:=nil; - dummycoll.paratyp:=vs_var; - if is_shortstring(hp^.resulttype) then - dummycoll.data:=openshortstringdef - else - dummycoll.data:=hp^.resulttype; - procedureprefix:='FPC_'+pstringdef(hp^.resulttype)^.stringtypname+'_'; - secondcallparan(hp,@dummycoll,false,false,false,0); - if codegenerror then - exit; - - dummycoll.paratyp:=vs_const; - disposetree(p^.left); - p^.left:=nil; - { second arg } - hp:=node; - node:=node^.right; - hp^.right:=nil; - - { if real push real type } - if is_real then - push_int(ord(realtype)); - - { frac para } - if hp^.is_colon_para and assigned(node) and - node^.is_colon_para then - begin - dummycoll.data:=hp^.resulttype; - secondcallparan(hp,@dummycoll,false - ,false,false,0 - ); - if codegenerror then - exit; - disposetree(hp); - hp:=node; - node:=node^.right; - hp^.right:=nil; - has_length:=true; - end - else - if is_real then - push_int(-1); - - { third arg, length only if is_real } - if hp^.is_colon_para then - begin - dummycoll.data:=hp^.resulttype; - secondcallparan(hp,@dummycoll,false - ,false,false,0 - ); - if codegenerror then - exit; - disposetree(hp); - hp:=node; - node:=node^.right; - hp^.right:=nil; - end - else - if is_real then - push_int(-32767) - else - push_int(-1); - - { Convert float to bestreal } - if is_real then - begin - hp^.left:=gentypeconvnode(hp^.left,bestrealdef^); - firstpass(hp^.left); - end; - - { last arg longint or real } - secondcallparan(hp,@dummycoll,false - ,false,false,0 - ); - if codegenerror then - exit; - - if is_real then - emitcall(procedureprefix+'FLOAT',true) - else - case porddef(hp^.resulttype)^.typ of - u32bit: - emitcall(procedureprefix+'CARDINAL',true); - - u64bit: - emitcall(procedureprefix+'QWORD',true); - - s64bitint: - emitcall(procedureprefix+'INT64',true); - - else - emitcall(procedureprefix+'LONGINT',true); - end; - disposetree(hp); - - popusedregisters(exprasmlist,pushed); - end; - -{$IfnDef OLDVAL} - - Procedure Handle_Val; - - var - hp,node, code_para, dest_para : ptree; - hreg: TRegister; - hdef: POrdDef; - procedureprefix : string; - hr, hr2: TReference; - dummycoll : tdefcoll; - has_code, has_32bit_code, oldregisterdef: boolean; - - begin - node:=p^.left; - hp:=node; - node:=node^.right; - hp^.right:=nil; - {if we have 3 parameters, we have a code parameter} - has_code := Assigned(node^.right); - has_32bit_code := false; - reset_reference(hr); - hreg := R_NO; - - If has_code then - Begin - {code is an orddef, that's checked in tcinl} - code_para := hp; - hp := node; - node := node^.right; - hp^.right := nil; - has_32bit_code := (porddef(code_para^.left^.resulttype)^.typ in [u32bit,s32bit]); - End; - - {hp = destination now, save for later use} - dest_para := hp; - - {if EAX is already in use, it's a register variable. Since we don't - need another register besides EAX, release the one we got} - If hreg <> R_EAX Then ungetregister32(hreg); - - {load and push the address of the destination} - dummycoll.paratyp:=vs_var; - dummycoll.data:=dest_para^.resulttype; - secondcallparan(dest_para,@dummycoll,false,false,false,0); - if codegenerror then - exit; - - {save the regvars} - pushusedregisters(exprasmlist,pushed,$ff); - - {now that we've already pushed the addres of dest_para^.left on the - stack, we can put the real parameters on the stack} - - If has_32bit_code Then - Begin - dummycoll.paratyp:=vs_var; - dummycoll.data:=code_para^.resulttype; - secondcallparan(code_para,@dummycoll,false,false,false,0); - if codegenerror then - exit; - Disposetree(code_para); - End - Else - Begin - {only 32bit code parameter is supported, so fake one} - GetTempOfSizeReference(4,hr); - emitpushreferenceaddr(exprasmlist,hr); - End; - - {node = first parameter = string} - dummycoll.paratyp:=vs_const; - dummycoll.data:=node^.resulttype; - secondcallparan(node,@dummycoll,false,false,false,0); - if codegenerror then - exit; - - Case dest_para^.resulttype^.deftype of - floatdef: - procedureprefix := 'FPC_VAL_REAL_'; - orddef: - if is_signed(dest_para^.resulttype) then - begin - {if we are converting to a signed number, we have to include the - size of the destination, so the Val function can extend the sign - of the result to allow proper range checking} - exprasmlist^.concat(new(pai386,op_const(A_PUSH,S_L,dest_para^.resulttype^.size))); - procedureprefix := 'FPC_VAL_SINT_' - end - else - procedureprefix := 'FPC_VAL_UINT_'; - End; - emitcall(procedureprefix+pstringdef(node^.resulttype)^.stringtypname,true); - { before disposing node we need to ungettemp !! PM } - if node^.left^.location.loc in [LOC_REFERENCE,LOC_MEM] then - ungetiftemp(node^.left^.location.reference); - disposetree(node); - p^.left := nil; - - {reload esi in case the dest_para/code_para is a class variable or so} - maybe_loadesi; - - If (dest_para^.resulttype^.deftype = orddef) Then - Begin - {store the result in a safe place, because EAX may be used by a - register variable} - hreg := getexplicitregister32(R_EAX); - emit_reg_reg(A_MOV,S_L,R_EAX,hreg); - {as of now, hreg now holds the location of the result, if it was - integer} - End; - - { restore the register vars} - - popusedregisters(exprasmlist,pushed); - - If has_code and Not(has_32bit_code) Then - {only 16bit code is possible} - Begin - {load the address of the code parameter} - secondpass(code_para^.left); - {move the code to its destination} - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,NewReference(hr),R_EDI))); - emit_mov_reg_loc(R_DI,code_para^.left^.location); - Disposetree(code_para); - End; - - {restore the address of the result} - exprasmlist^.concat(new(pai386,op_reg(A_POP,S_L,R_EDI))); - - {set up hr2 to a refernce with EDI as base register} - reset_reference(hr2); - hr2.base := R_EDI; - - {save the function result in the destination variable} - Case dest_para^.left^.resulttype^.deftype of - floatdef: - floatstore(PFloatDef(dest_para^.left^.resulttype)^.typ, hr2); - orddef: - Case PordDef(dest_para^.left^.resulttype)^.typ of - u8bit,s8bit: - exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV, S_B, - RegToReg8(hreg),newreference(hr2)))); - u16bit,s16bit: - exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV, S_W, - RegToReg16(hreg),newreference(hr2)))); - u32bit,s32bit: - exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV, S_L, - hreg,newreference(hr2)))); - {u64bit,s64bitint: ???} - End; - End; - If (cs_check_range in aktlocalswitches) and - (dest_para^.left^.resulttype^.deftype = orddef) and - {the following has to be changed to 64bit checking, once Val - returns 64 bit values (unless a special Val function is created - for that)} - {no need to rangecheck longints or cardinals on 32bit processors} - not((porddef(dest_para^.left^.resulttype)^.typ = s32bit) and - (porddef(dest_para^.left^.resulttype)^.low = $80000000) and - (porddef(dest_para^.left^.resulttype)^.high = $7fffffff)) and - not((porddef(dest_para^.left^.resulttype)^.typ = u32bit) and - (porddef(dest_para^.left^.resulttype)^.low = 0) and - (porddef(dest_para^.left^.resulttype)^.high = $ffffffff)) then - Begin - hp := getcopy(dest_para^.left); - hp^.location.loc := LOC_REGISTER; - hp^.location.register := hreg; - {do not register this temporary def} - OldRegisterDef := RegisterDef; - RegisterDef := False; - Case PordDef(dest_para^.left^.resulttype)^.typ of - u8bit,u16bit,u32bit: new(hdef,init(u32bit,0,$ffffffff)); - s8bit,s16bit,s32bit: new(hdef,init(s32bit,$80000000,$7fffffff)); - end; - hp^.resulttype := hdef; - emitrangecheck(hp,dest_para^.left^.resulttype); - hp^.right := nil; - Dispose(hp^.resulttype, Done); - RegisterDef := OldRegisterDef; - disposetree(hp); - End; - {dest_para^.right is already nil} - disposetree(dest_para); - UnGetIfTemp(hr); - end; -{$EndIf OLDVAL} - - var - r : preference; - hp : ptree; - l : longint; - ispushed : boolean; - hregister : tregister; - otlabel,oflabel : plabel; - oldpushedparasize : longint; - - begin - { save & reset pushedparasize } - oldpushedparasize:=pushedparasize; - pushedparasize:=0; - case p^.inlinenumber of - in_assert_x_y: - begin - otlabel:=truelabel; - oflabel:=falselabel; - getlabel(truelabel); - getlabel(falselabel); - secondpass(p^.left^.left); - if cs_do_assertion in aktlocalswitches then - begin - maketojumpbool(p^.left^.left); - emitlab(falselabel); - { erroraddr } - exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_EBP))); - { lineno } - exprasmlist^.concat(new(pai386,op_const(A_PUSH,S_L,aktfilepos.line))); - { filename string } - hp:=genstringconstnode(current_module^.sourcefiles^.get_file_name(aktfilepos.fileindex)); - secondpass(hp); - if codegenerror then - exit; - emitpushreferenceaddr(exprasmlist,hp^.location.reference); - disposetree(hp); - { push msg } - secondpass(p^.left^.right^.left); - emitpushreferenceaddr(exprasmlist,p^.left^.right^.left^.location.reference); - { call } - emitcall('FPC_ASSERT',true); - emitlab(truelabel); - end; - freelabel(truelabel); - freelabel(falselabel); - truelabel:=otlabel; - falselabel:=oflabel; - end; - in_lo_word, - in_hi_word : - begin - secondpass(p^.left); - p^.location.loc:=LOC_REGISTER; - if p^.left^.location.loc<>LOC_REGISTER then - begin - if p^.left^.location.loc=LOC_CREGISTER then - begin - p^.location.register:=reg32toreg16(getregister32); - emit_reg_reg(A_MOV,S_W,p^.left^.location.register, - p^.location.register); - end - else - begin - del_reference(p^.left^.location.reference); - p^.location.register:=reg32toreg16(getregister32); - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_W,newreference(p^.left^.location.reference), - p^.location.register))); - end; - end - else p^.location.register:=p^.left^.location.register; - if p^.inlinenumber=in_hi_word then - exprasmlist^.concat(new(pai386,op_const_reg(A_SHR,S_W,8,p^.location.register))); - p^.location.register:=reg16toreg8(p^.location.register); - end; - in_sizeof_x, - in_typeof_x : - begin - { for both cases load vmt } - if p^.left^.treetype=typen then - begin - p^.location.register:=getregister32; - exprasmlist^.concat(new(pai386,op_sym_ofs_reg(A_MOV, - S_L,newasmsymbol(pobjectdef(p^.left^.resulttype)^.vmt_mangledname),0, - p^.location.register))); - end - else - begin - secondpass(p^.left); - del_reference(p^.left^.location.reference); - p^.location.loc:=LOC_REGISTER; - p^.location.register:=getregister32; - { load VMT pointer } - inc(p^.left^.location.reference.offset, - pobjectdef(p^.left^.resulttype)^.vmt_offset); - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, - newreference(p^.left^.location.reference), - p^.location.register))); - end; - { in sizeof load size } - if p^.inlinenumber=in_sizeof_x then - begin - new(r); - reset_reference(r^); - r^.base:=p^.location.register; - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r, - p^.location.register))); - end; - end; - in_lo_long, - in_hi_long : - begin - secondpass(p^.left); - p^.location.loc:=LOC_REGISTER; - if p^.left^.location.loc<>LOC_REGISTER then - begin - if p^.left^.location.loc=LOC_CREGISTER then - begin - p^.location.register:=getregister32; - emit_reg_reg(A_MOV,S_L,p^.left^.location.register, - p^.location.register); - end - else - begin - del_reference(p^.left^.location.reference); - p^.location.register:=getregister32; - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.left^.location.reference), - p^.location.register))); - end; - end - else p^.location.register:=p^.left^.location.register; - if p^.inlinenumber=in_hi_long then - exprasmlist^.concat(new(pai386,op_const_reg(A_SHR,S_L,16,p^.location.register))); - p^.location.register:=reg32toreg16(p^.location.register); - end; - in_length_string : - begin - secondpass(p^.left); - set_location(p^.location,p^.left^.location); - { length in ansi strings is at offset -8 } - if is_ansistring(p^.left^.resulttype) then - dec(p^.location.reference.offset,8) - { char is always 1, so make it a constant value } - else if is_char(p^.left^.resulttype) then - begin - clear_location(p^.location); - p^.location.loc:=LOC_MEM; - p^.location.reference.is_immediate:=true; - p^.location.reference.offset:=1; - end; - end; - in_pred_x, - in_succ_x: - begin - secondpass(p^.left); - if not (cs_check_overflow in aktlocalswitches) then - if p^.inlinenumber=in_pred_x then - asmop:=A_DEC - else - asmop:=A_INC - else - if p^.inlinenumber=in_pred_x then - asmop:=A_SUB - else - asmop:=A_ADD; - case p^.resulttype^.size of - 4 : opsize:=S_L; - 2 : opsize:=S_W; - 1 : opsize:=S_B; - else - internalerror(10080); - end; - p^.location.loc:=LOC_REGISTER; - if p^.left^.location.loc<>LOC_REGISTER then - begin - p^.location.register:=getregister32; - if (p^.resulttype^.size=2) then - p^.location.register:=reg32toreg16(p^.location.register); - if (p^.resulttype^.size=1) then - p^.location.register:=reg32toreg8(p^.location.register); - if p^.left^.location.loc=LOC_CREGISTER then - emit_reg_reg(A_MOV,opsize,p^.left^.location.register, - p^.location.register) - else - if p^.left^.location.loc=LOC_FLAGS then - emit_flag2reg(p^.left^.location.resflags,p^.location.register) - else - begin - del_reference(p^.left^.location.reference); - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,opsize,newreference(p^.left^.location.reference), - p^.location.register))); - end; - end - else p^.location.register:=p^.left^.location.register; - - if not (cs_check_overflow in aktlocalswitches) then - exprasmlist^.concat(new(pai386,op_reg(asmop,opsize, - p^.location.register))) - else - exprasmlist^.concat(new(pai386,op_const_reg(asmop,opsize,1, - p^.location.register))); - emitoverflowcheck(p); - emitrangecheck(p,p^.resulttype); - end; - in_dec_x, - in_inc_x : - begin - { set defaults } - addvalue:=1; - addconstant:=true; - { load first parameter, must be a reference } - secondpass(p^.left^.left); - case p^.left^.left^.resulttype^.deftype of - orddef, - enumdef : begin - case p^.left^.left^.resulttype^.size of - 1 : opsize:=S_B; - 2 : opsize:=S_W; - 4 : opsize:=S_L; - end; - end; - pointerdef : begin - opsize:=S_L; - if porddef(ppointerdef(p^.left^.left^.resulttype)^.definition)=voiddef then - addvalue:=1 - else - addvalue:=ppointerdef(p^.left^.left^.resulttype)^.definition^.savesize; - end; - else - internalerror(10081); - end; - { second argument specified?, must be a s32bit in register } - if assigned(p^.left^.right) then - begin - secondpass(p^.left^.right^.left); - { when constant, just multiply the addvalue } - if is_constintnode(p^.left^.right^.left) then - addvalue:=addvalue*get_ordinal_value(p^.left^.right^.left) - else - begin - case p^.left^.right^.left^.location.loc of - LOC_REGISTER, - LOC_CREGISTER : hregister:=p^.left^.right^.left^.location.register; - LOC_MEM, - LOC_REFERENCE : begin - del_reference(p^.left^.right^.left^.location.reference); - hregister:=getregister32; - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, - newreference(p^.left^.right^.left^.location.reference),hregister))); - end; - else - internalerror(10082); - end; - { insert multiply with addvalue if its >1 } - if addvalue>1 then - exprasmlist^.concat(new(pai386,op_const_reg(A_IMUL,opsize, - addvalue,hregister))); - addconstant:=false; - end; - end; - { write the add instruction } - if addconstant then - begin - if (addvalue=1) and not(cs_check_overflow in aktlocalswitches) then - begin - if p^.left^.left^.location.loc=LOC_CREGISTER then - exprasmlist^.concat(new(pai386,op_reg(incdecop[p^.inlinenumber],opsize, - p^.left^.left^.location.register))) - else - exprasmlist^.concat(new(pai386,op_ref(incdecop[p^.inlinenumber],opsize, - newreference(p^.left^.left^.location.reference)))) - end - else - begin - if p^.left^.left^.location.loc=LOC_CREGISTER then - exprasmlist^.concat(new(pai386,op_const_reg(addsubop[p^.inlinenumber],opsize, - addvalue,p^.left^.left^.location.register))) - else - exprasmlist^.concat(new(pai386,op_const_ref(addsubop[p^.inlinenumber],opsize, - addvalue,newreference(p^.left^.left^.location.reference)))); - end - end - else - begin - { BUG HERE : detected with nasm : - hregister is allways 32 bit - it should be converted to 16 or 8 bit depending on op_size PM } - { still not perfect : - if hregister is already a 16 bit reg ?? PM } - case opsize of - S_B : hregister:=reg32toreg8(hregister); - S_W : hregister:=reg32toreg16(hregister); - end; - if p^.left^.left^.location.loc=LOC_CREGISTER then - exprasmlist^.concat(new(pai386,op_reg_reg(addsubop[p^.inlinenumber],opsize, - hregister,p^.left^.left^.location.register))) - else - exprasmlist^.concat(new(pai386,op_reg_ref(addsubop[p^.inlinenumber],opsize, - hregister,newreference(p^.left^.left^.location.reference)))); - case opsize of - S_B : hregister:=reg8toreg32(hregister); - S_W : hregister:=reg16toreg32(hregister); - end; - ungetregister32(hregister); - end; - emitoverflowcheck(p^.left^.left); - emitrangecheck(p^.left^.left,p^.left^.left^.resulttype); - end; - in_assigned_x : - begin - secondpass(p^.left^.left); - p^.location.loc:=LOC_FLAGS; - if (p^.left^.left^.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then - begin - exprasmlist^.concat(new(pai386,op_reg_reg(A_OR,S_L, - p^.left^.left^.location.register, - p^.left^.left^.location.register))); - ungetregister32(p^.left^.left^.location.register); - end - else - begin - exprasmlist^.concat(new(pai386,op_const_ref(A_CMP,S_L,0, - newreference(p^.left^.left^.location.reference)))); - del_reference(p^.left^.left^.location.reference); - end; - p^.location.resflags:=F_NE; - end; - in_reset_typedfile,in_rewrite_typedfile : - begin - pushusedregisters(exprasmlist,pushed,$ff); - exprasmlist^.concat(new(pai386,op_const(A_PUSH,S_L,pfiledef(p^.left^.resulttype)^.typed_as^.size))); - secondpass(p^.left); - emitpushreferenceaddr(exprasmlist,p^.left^.location.reference); - if p^.inlinenumber=in_reset_typedfile then - emitcall('FPC_RESET_TYPED',true) - else - emitcall('FPC_REWRITE_TYPED',true); - popusedregisters(exprasmlist,pushed); - end; - in_write_x : - handlereadwrite(false,false); - in_writeln_x : - handlereadwrite(false,true); - in_read_x : - handlereadwrite(true,false); - in_readln_x : - handlereadwrite(true,true); - in_str_x_string : - begin - handle_str; - maybe_loadesi; - end; -{$IfnDef OLDVAL} - in_val_x : - Begin - handle_val; - End; -{$EndIf OLDVAL} - in_include_x_y, - in_exclude_x_y: - begin - secondpass(p^.left^.left); - if p^.left^.right^.left^.treetype=ordconstn then - begin - { calculate bit position } - l:=1 shl (p^.left^.right^.left^.value mod 32); - - { determine operator } - if p^.inlinenumber=in_include_x_y then - asmop:=A_OR - else - begin - asmop:=A_AND; - l:=not(l); - end; - if (p^.left^.left^.location.loc=LOC_REFERENCE) then - begin - inc(p^.left^.left^.location.reference.offset,(p^.left^.right^.left^.value div 32)*4); - exprasmlist^.concat(new(pai386,op_const_ref(asmop,S_L, - l,newreference(p^.left^.left^.location.reference)))); - del_reference(p^.left^.left^.location.reference); - end - else - { LOC_CREGISTER } - exprasmlist^.concat(new(pai386,op_const_reg(asmop,S_L, - l,p^.left^.left^.location.register))); - end - else - begin - { generate code for the element to set } - ispushed:=maybe_push(p^.left^.right^.left^.registers32,p^.left^.left); - secondpass(p^.left^.right^.left); - if ispushed then - restore(p^.left^.left); - { determine asm operator } - if p^.inlinenumber=in_include_x_y then - asmop:=A_BTS - else - asmop:=A_BTR; - if psetdef(p^.left^.resulttype)^.settype=smallset then - begin - if p^.left^.right^.left^.location.loc in [LOC_CREGISTER,LOC_REGISTER] then - hregister:=p^.left^.right^.left^.location.register - else - begin - hregister:=R_EDI; - opsize:=def2def_opsize(p^.left^.right^.left^.resulttype,u32bitdef); - if opsize in [S_B,S_W,S_L] then - op:=A_MOV - else - op:=A_MOVZX; - exprasmlist^.concat(new(pai386,op_ref_reg(op,opsize, - newreference(p^.left^.right^.left^.location.reference),R_EDI))); - end; - if (p^.left^.left^.location.loc=LOC_REFERENCE) then - exprasmlist^.concat(new(pai386,op_reg_ref(asmop,S_L,hregister, - newreference(p^.left^.right^.left^.location.reference)))) - else - exprasmlist^.concat(new(pai386,op_reg_reg(asmop,S_L,hregister, - p^.left^.right^.left^.location.register))); - end - else - begin - pushsetelement(p^.left^.right^.left); - { normset is allways a ref } - emitpushreferenceaddr(exprasmlist, - p^.left^.left^.location.reference); - if p^.inlinenumber=in_include_x_y then - emitcall('FPC_SET_SET_BYTE',true) - else - emitcall('FPC_SET_UNSET_BYTE',true); - {CGMessage(cg_e_include_not_implemented);} - end; - end; - end; - else internalerror(9); - end; - { reset pushedparasize } - pushedparasize:=oldpushedparasize; - end; - -end. -{ +{ + $Id$ + Copyright (c) 1993-98 by Florian Klaempfl + + Generate i386 inline nodes + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit cg386inl; +interface + + uses + tree; + + procedure secondinline(var p : ptree); + + +implementation + + uses + globtype,systems, + cobjects,verbose,globals,files, + symtable,aasm,types, + hcodegen,temp_gen,pass_1,pass_2, +{$ifndef OLDASM} + i386base,i386asm, +{$else} + i386, +{$endif} + cgai386,tgeni386,cg386cal; + + +{***************************************************************************** + Helpers +*****************************************************************************} + + { reverts the parameter list } + var nb_para : integer; + + function reversparameter(p : ptree) : ptree; + + var + hp1,hp2 : ptree; + + begin + hp1:=nil; + nb_para := 0; + while assigned(p) do + begin + { pull out } + hp2:=p; + p:=p^.right; + inc(nb_para); + { pull in } + hp2^.right:=hp1; + hp1:=hp2; + end; + reversparameter:=hp1; + end; + + +{***************************************************************************** + SecondInLine +*****************************************************************************} + + procedure StoreDirectFuncResult(dest:ptree); + var + hp : ptree; + hdef : porddef; + hreg : tregister; + oldregisterdef : boolean; + begin + SecondPass(dest); + if Codegenerror then + exit; + Case dest^.resulttype^.deftype of + floatdef: + floatstore(PFloatDef(dest^.resulttype)^.typ,dest^.location.reference); + orddef: + begin + Case dest^.resulttype^.size of + 1 : hreg:=regtoreg8(accumulator); + 2 : hreg:=regtoreg16(accumulator); + 4 : hreg:=accumulator; + End; + emit_mov_reg_loc(hreg,dest^.location); + If (cs_check_range in aktlocalswitches) and + {no need to rangecheck longints or cardinals on 32bit processors} + not((porddef(dest^.resulttype)^.typ = s32bit) and + (porddef(dest^.resulttype)^.low = $80000000) and + (porddef(dest^.resulttype)^.high = $7fffffff)) and + not((porddef(dest^.resulttype)^.typ = u32bit) and + (porddef(dest^.resulttype)^.low = 0) and + (porddef(dest^.resulttype)^.high = $ffffffff)) then + Begin + {do not register this temporary def} + OldRegisterDef := RegisterDef; + RegisterDef := False; + hdef:=nil; + Case PordDef(dest^.resulttype)^.typ of + u8bit,u16bit,u32bit: + begin + new(hdef,init(u32bit,0,$ffffffff)); + hreg:=accumulator; + end; + s8bit,s16bit,s32bit: + begin + new(hdef,init(s32bit,$80000000,$7fffffff)); + hreg:=accumulator; + end; + end; + { create a fake node } + hp := genzeronode(nothingn); + hp^.location.loc := LOC_REGISTER; + hp^.location.register := hreg; + if assigned(hdef) then + hp^.resulttype:=hdef + else + hp^.resulttype:=dest^.resulttype; + { emit the range check } + emitrangecheck(hp,dest^.resulttype); + hp^.right := nil; + if assigned(hdef) then + Dispose(hdef, Done); + RegisterDef := OldRegisterDef; + disposetree(hp); + End; + End; + else + internalerror(66766766); + end; + end; + + + procedure secondinline(var p : ptree); + const + {tfloattype = (s32real,s64real,s80real,s64bit,f16bit,f32bit);} +{ float_name: array[tfloattype] of string[8]= + ('S32REAL','S64REAL','S80REAL','S64BIT','F16BIT','F32BIT'); } + incdecop:array[in_inc_x..in_dec_x] of tasmop=(A_INC,A_DEC); + addsubop:array[in_inc_x..in_dec_x] of tasmop=(A_ADD,A_SUB); + var + aktfile : treference; + ft : tfiletype; + opsize : topsize; + op, + asmop : tasmop; + pushed : tpushed; + {inc/dec} + addconstant : boolean; + addvalue : longint; + + + procedure handlereadwrite(doread,doln : boolean); + { produces code for READ(LN) and WRITE(LN) } + + procedure loadstream; + const + io:array[boolean] of string[7]=('_OUTPUT','_INPUT'); + var + r : preference; + begin + new(r); + reset_reference(r^); + r^.symbol:=newasmsymbol('U_'+upper(target_info.system_unit)+io[doread]); +{$ifndef NEWLAB} + concat_external(r^.symbol^.name,EXT_NEAR); +{$endif} + exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L,r,R_EDI))) + end; + + const + rdwrprefix:array[boolean] of string[15]=('FPC_WRITE_TEXT_','FPC_READ_TEXT_'); + var + destpara, + node,hp : ptree; + typedtyp, + pararesult : pdef; + orgfloattype : tfloattype; + has_length : boolean; + dummycoll : tdefcoll; + iolabel : plabel; + npara : longint; + begin + { I/O check } + if (cs_check_io in aktlocalswitches) and + ((aktprocsym^.definition^.options and poiocheck)=0) then + begin + getlabel(iolabel); + emitlab(iolabel); + end + else + iolabel:=nil; + { for write of real with the length specified } + has_length:=false; + hp:=nil; + { reserve temporary pointer to data variable } + aktfile.symbol:=nil; + gettempofsizereference(4,aktfile); + { first state text data } + ft:=ft_text; + { and state a parameter ? } + if p^.left=nil then + begin + { the following instructions are for "writeln;" } + loadstream; + { save @aktfile in temporary variable } + exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L,R_EDI,newreference(aktfile)))); + end + else + begin + { revers paramters } + node:=reversparameter(p^.left); + + p^.left := node; + npara := nb_para; + { calculate data variable } + { is first parameter a file type ? } + if node^.left^.resulttype^.deftype=filedef then + begin + ft:=pfiledef(node^.left^.resulttype)^.filetype; + if ft=ft_typed then + typedtyp:=pfiledef(node^.left^.resulttype)^.typed_as; + secondpass(node^.left); + if codegenerror then + exit; + + { save reference in temporary variables } + if node^.left^.location.loc<>LOC_REFERENCE then + begin + CGMessage(cg_e_illegal_expression); + exit; + end; + + exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L,newreference(node^.left^.location.reference),R_EDI))); + + { skip to the next parameter } + node:=node^.right; + end + else + begin + { load stdin/stdout stream } + loadstream; + end; + + { save @aktfile in temporary variable } + exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L,R_EDI,newreference(aktfile)))); + if doread then + { parameter by READ gives call by reference } + dummycoll.paratyp:=vs_var + { an WRITE Call by "Const" } + else + dummycoll.paratyp:=vs_const; + + { because of secondcallparan, which otherwise attaches } + if ft=ft_typed then + { this is to avoid copy of simple const parameters } + {dummycoll.data:=new(pformaldef,init)} + dummycoll.data:=cformaldef + else + { I think, this isn't a good solution (FK) } + dummycoll.data:=nil; + + while assigned(node) do + begin + pushusedregisters(exprasmlist,pushed,$ff); + hp:=node; + node:=node^.right; + hp^.right:=nil; + if hp^.is_colon_para then + CGMessage(parser_e_illegal_colon_qualifier); + { when float is written then we need bestreal to be pushed + convert here else we loose the old flaot type } + if (not doread) and + (ft<>ft_typed) and + (hp^.left^.resulttype^.deftype=floatdef) then + begin + orgfloattype:=pfloatdef(hp^.left^.resulttype)^.typ; + hp^.left:=gentypeconvnode(hp^.left,bestrealdef^); + firstpass(hp^.left); + end; + { when read ord,floats are functions, so they need this + parameter as their destination instead of being pushed } + if doread and + (ft<>ft_typed) and + (hp^.resulttype^.deftype in [orddef,floatdef]) then + destpara:=hp^.left + else + begin + if ft=ft_typed then + never_copy_const_param:=true; + { reset data type } + dummycoll.data:=nil; + { create temporary defs for high tree generation } + if doread and (is_shortstring(hp^.resulttype)) then + dummycoll.data:=openshortstringdef + else + if (is_chararray(hp^.resulttype)) then + dummycoll.data:=openchararraydef; + secondcallparan(hp,@dummycoll,false,false,false,0); + if ft=ft_typed then + never_copy_const_param:=false; + end; + hp^.right:=node; + if codegenerror then + exit; + + emit_push_mem(aktfile); + if (ft=ft_typed) then + begin + { OK let's try this } + { first we must only allow the right type } + { we have to call blockread or blockwrite } + { but the real problem is that } + { reset and rewrite should have set } + { the type size } + { as recordsize for that file !!!! } + { how can we make that } + { I think that is only possible by adding } + { reset and rewrite to the inline list a call } + { allways read only one record by element } + push_int(typedtyp^.size); + if doread then + emitcall('FPC_TYPED_READ',true) + else + emitcall('FPC_TYPED_WRITE',true); + end + else + begin + { save current position } + pararesult:=hp^.left^.resulttype; + { handle possible field width } + { of course only for write(ln) } + if not doread then + begin + { handle total width parameter } + if assigned(node) and node^.is_colon_para then + begin + hp:=node; + node:=node^.right; + hp^.right:=nil; + secondcallparan(hp,@dummycoll,false,false,false,0); + hp^.right:=node; + if codegenerror then + exit; + has_length:=true; + end + else + if pararesult^.deftype<>floatdef then + push_int(0) + else + push_int(-32767); + { a second colon para for a float ? } + if assigned(node) and node^.is_colon_para then + begin + hp:=node; + node:=node^.right; + hp^.right:=nil; + secondcallparan(hp,@dummycoll,false,false,false,0); + hp^.right:=node; + if pararesult^.deftype<>floatdef then + CGMessage(parser_e_illegal_colon_qualifier); + if codegenerror then + exit; + end + else + begin + if pararesult^.deftype=floatdef then + push_int(-1); + end; + { push also the real type for floats } + if pararesult^.deftype=floatdef then + push_int(ord(orgfloattype)); + end; + case pararesult^.deftype of + stringdef : + begin + emitcall(rdwrprefix[doread]+pstringdef(pararesult)^.stringtypname,true); + end; + pointerdef : + begin + if is_pchar(pararesult) then + emitcall(rdwrprefix[doread]+'PCHAR_AS_POINTER',true) + end; + arraydef : + begin + if is_chararray(pararesult) then + emitcall(rdwrprefix[doread]+'PCHAR_AS_ARRAY',true) + end; + floatdef : + begin + emitcall(rdwrprefix[doread]+'FLOAT',true); + if doread then + StoreDirectFuncResult(destpara); + end; + orddef : + begin + case porddef(pararesult)^.typ of + s8bit,s16bit,s32bit : + emitcall(rdwrprefix[doread]+'SINT',true); + u8bit,u16bit,u32bit : + emitcall(rdwrprefix[doread]+'UINT',true); + uchar : + emitcall(rdwrprefix[doread]+'CHAR',true); + s64bitint: + emitcall(rdwrprefix[doread]+'INT64',true); + u64bit : + emitcall(rdwrprefix[doread]+'QWORD',true); + bool8bit, + bool16bit, + bool32bit : + emitcall(rdwrprefix[doread]+'BOOLEAN',true); + end; + if doread then + StoreDirectFuncResult(destpara); + end; + end; + end; + { load ESI in methods again } + popusedregisters(exprasmlist,pushed); + maybe_loadesi; + end; + end; + { Insert end of writing for textfiles } + if ft=ft_text then + begin + pushusedregisters(exprasmlist,pushed,$ff); + emit_push_mem(aktfile); + if doread then + begin + if doln then + emitcall('FPC_READLN_END',true) + else + emitcall('FPC_READ_END',true); + end + else + begin + if doln then + emitcall('FPC_WRITELN_END',true) + else + emitcall('FPC_WRITE_END',true); + end; + popusedregisters(exprasmlist,pushed); + maybe_loadesi; + end; + { Insert IOCheck if set } + if assigned(iolabel) then + begin + { registers are saved in the procedure } + exprasmlist^.concat(new(pai386,op_sym(A_PUSH,S_L,newasmsymbol(lab2str(iolabel))))); + emitcall('FPC_IOCHECK',true); + end; + { Freeup all used temps } + ungetiftemp(aktfile); + if assigned(p^.left) then + begin + p^.left:=reversparameter(p^.left); + if npara<>nb_para then + CGMessage(cg_f_internal_error_in_secondinline); + hp:=p^.left; + while assigned(hp) do + begin + if assigned(hp^.left) then + if (hp^.left^.location.loc in [LOC_MEM,LOC_REFERENCE]) then + ungetiftemp(hp^.left^.location.reference); + hp:=hp^.right; + end; + end; + end; + + procedure handle_str; + + var + hp,node : ptree; + dummycoll : tdefcoll; + is_real,has_length : boolean; + realtype : tfloattype; + procedureprefix : string; + + begin + pushusedregisters(exprasmlist,pushed,$ff); + node:=p^.left; + is_real:=false; + has_length:=false; + while assigned(node^.right) do node:=node^.right; + { if a real parameter somewhere then call REALSTR } + if (node^.left^.resulttype^.deftype=floatdef) then + begin + is_real:=true; + realtype:=pfloatdef(node^.left^.resulttype)^.typ; + end; + + node:=p^.left; + { we have at least two args } + { with at max 2 colon_para in between } + + { string arg } + hp:=node; + node:=node^.right; + hp^.right:=nil; + dummycoll.paratyp:=vs_var; + if is_shortstring(hp^.resulttype) then + dummycoll.data:=openshortstringdef + else + dummycoll.data:=hp^.resulttype; + procedureprefix:='FPC_'+pstringdef(hp^.resulttype)^.stringtypname+'_'; + secondcallparan(hp,@dummycoll,false,false,false,0); + if codegenerror then + exit; + + dummycoll.paratyp:=vs_const; + disposetree(p^.left); + p^.left:=nil; + { second arg } + hp:=node; + node:=node^.right; + hp^.right:=nil; + + { if real push real type } + if is_real then + push_int(ord(realtype)); + + { frac para } + if hp^.is_colon_para and assigned(node) and + node^.is_colon_para then + begin + dummycoll.data:=hp^.resulttype; + secondcallparan(hp,@dummycoll,false + ,false,false,0 + ); + if codegenerror then + exit; + disposetree(hp); + hp:=node; + node:=node^.right; + hp^.right:=nil; + has_length:=true; + end + else + if is_real then + push_int(-1); + + { third arg, length only if is_real } + if hp^.is_colon_para then + begin + dummycoll.data:=hp^.resulttype; + secondcallparan(hp,@dummycoll,false + ,false,false,0 + ); + if codegenerror then + exit; + disposetree(hp); + hp:=node; + node:=node^.right; + hp^.right:=nil; + end + else + if is_real then + push_int(-32767) + else + push_int(-1); + + { Convert float to bestreal } + if is_real then + begin + hp^.left:=gentypeconvnode(hp^.left,bestrealdef^); + firstpass(hp^.left); + end; + + { last arg longint or real } + secondcallparan(hp,@dummycoll,false + ,false,false,0 + ); + if codegenerror then + exit; + + if is_real then + emitcall(procedureprefix+'FLOAT',true) + else + case porddef(hp^.resulttype)^.typ of + u32bit: + emitcall(procedureprefix+'CARDINAL',true); + + u64bit: + emitcall(procedureprefix+'QWORD',true); + + s64bitint: + emitcall(procedureprefix+'INT64',true); + + else + emitcall(procedureprefix+'LONGINT',true); + end; + disposetree(hp); + + popusedregisters(exprasmlist,pushed); + end; + +{$IfnDef OLDVAL} + + Procedure Handle_Val; + + var + hp,node, code_para, dest_para : ptree; + hreg: TRegister; + hdef: POrdDef; + procedureprefix : string; + hr, hr2: TReference; + dummycoll : tdefcoll; + has_code, has_32bit_code, oldregisterdef: boolean; + + begin + node:=p^.left; + hp:=node; + node:=node^.right; + hp^.right:=nil; + {if we have 3 parameters, we have a code parameter} + has_code := Assigned(node^.right); + has_32bit_code := false; + reset_reference(hr); + hreg := R_NO; + + If has_code then + Begin + {code is an orddef, that's checked in tcinl} + code_para := hp; + hp := node; + node := node^.right; + hp^.right := nil; + has_32bit_code := (porddef(code_para^.left^.resulttype)^.typ in [u32bit,s32bit]); + End; + + {hp = destination now, save for later use} + dest_para := hp; + + {if EAX is already in use, it's a register variable. Since we don't + need another register besides EAX, release the one we got} + If hreg <> R_EAX Then ungetregister32(hreg); + + {load and push the address of the destination} + dummycoll.paratyp:=vs_var; + dummycoll.data:=dest_para^.resulttype; + secondcallparan(dest_para,@dummycoll,false,false,false,0); + if codegenerror then + exit; + + {save the regvars} + pushusedregisters(exprasmlist,pushed,$ff); + + {now that we've already pushed the addres of dest_para^.left on the + stack, we can put the real parameters on the stack} + + If has_32bit_code Then + Begin + dummycoll.paratyp:=vs_var; + dummycoll.data:=code_para^.resulttype; + secondcallparan(code_para,@dummycoll,false,false,false,0); + if codegenerror then + exit; + Disposetree(code_para); + End + Else + Begin + {only 32bit code parameter is supported, so fake one} + GetTempOfSizeReference(4,hr); + emitpushreferenceaddr(exprasmlist,hr); + End; + + {node = first parameter = string} + dummycoll.paratyp:=vs_const; + dummycoll.data:=node^.resulttype; + secondcallparan(node,@dummycoll,false,false,false,0); + if codegenerror then + exit; + + Case dest_para^.resulttype^.deftype of + floatdef: + procedureprefix := 'FPC_VAL_REAL_'; + orddef: + if is_signed(dest_para^.resulttype) then + begin + {if we are converting to a signed number, we have to include the + size of the destination, so the Val function can extend the sign + of the result to allow proper range checking} + exprasmlist^.concat(new(pai386,op_const(A_PUSH,S_L,dest_para^.resulttype^.size))); + procedureprefix := 'FPC_VAL_SINT_' + end + else + procedureprefix := 'FPC_VAL_UINT_'; + End; + emitcall(procedureprefix+pstringdef(node^.resulttype)^.stringtypname,true); + { before disposing node we need to ungettemp !! PM } + if node^.left^.location.loc in [LOC_REFERENCE,LOC_MEM] then + ungetiftemp(node^.left^.location.reference); + disposetree(node); + p^.left := nil; + + {reload esi in case the dest_para/code_para is a class variable or so} + maybe_loadesi; + + If (dest_para^.resulttype^.deftype = orddef) Then + Begin + {store the result in a safe place, because EAX may be used by a + register variable} + hreg := getexplicitregister32(R_EAX); + emit_reg_reg(A_MOV,S_L,R_EAX,hreg); + {as of now, hreg now holds the location of the result, if it was + integer} + End; + + { restore the register vars} + + popusedregisters(exprasmlist,pushed); + + If has_code and Not(has_32bit_code) Then + {only 16bit code is possible} + Begin + {load the address of the code parameter} + secondpass(code_para^.left); + {move the code to its destination} + exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,NewReference(hr),R_EDI))); + emit_mov_reg_loc(R_DI,code_para^.left^.location); + Disposetree(code_para); + End; + + {restore the address of the result} + exprasmlist^.concat(new(pai386,op_reg(A_POP,S_L,R_EDI))); + + {set up hr2 to a refernce with EDI as base register} + reset_reference(hr2); + hr2.base := R_EDI; + + {save the function result in the destination variable} + Case dest_para^.left^.resulttype^.deftype of + floatdef: + floatstore(PFloatDef(dest_para^.left^.resulttype)^.typ, hr2); + orddef: + Case PordDef(dest_para^.left^.resulttype)^.typ of + u8bit,s8bit: + exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV, S_B, + RegToReg8(hreg),newreference(hr2)))); + u16bit,s16bit: + exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV, S_W, + RegToReg16(hreg),newreference(hr2)))); + u32bit,s32bit: + exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV, S_L, + hreg,newreference(hr2)))); + {u64bit,s64bitint: ???} + End; + End; + If (cs_check_range in aktlocalswitches) and + (dest_para^.left^.resulttype^.deftype = orddef) and + {the following has to be changed to 64bit checking, once Val + returns 64 bit values (unless a special Val function is created + for that)} + {no need to rangecheck longints or cardinals on 32bit processors} + not((porddef(dest_para^.left^.resulttype)^.typ = s32bit) and + (porddef(dest_para^.left^.resulttype)^.low = $80000000) and + (porddef(dest_para^.left^.resulttype)^.high = $7fffffff)) and + not((porddef(dest_para^.left^.resulttype)^.typ = u32bit) and + (porddef(dest_para^.left^.resulttype)^.low = 0) and + (porddef(dest_para^.left^.resulttype)^.high = $ffffffff)) then + Begin + hp := getcopy(dest_para^.left); + hp^.location.loc := LOC_REGISTER; + hp^.location.register := hreg; + {do not register this temporary def} + OldRegisterDef := RegisterDef; + RegisterDef := False; + Case PordDef(dest_para^.left^.resulttype)^.typ of + u8bit,u16bit,u32bit: new(hdef,init(u32bit,0,$ffffffff)); + s8bit,s16bit,s32bit: new(hdef,init(s32bit,$80000000,$7fffffff)); + end; + hp^.resulttype := hdef; + emitrangecheck(hp,dest_para^.left^.resulttype); + hp^.right := nil; + Dispose(hp^.resulttype, Done); + RegisterDef := OldRegisterDef; + disposetree(hp); + End; + {dest_para^.right is already nil} + disposetree(dest_para); + UnGetIfTemp(hr); + end; +{$EndIf OLDVAL} + + var + r : preference; + hp : ptree; + l : longint; + ispushed : boolean; + hregister : tregister; + otlabel,oflabel : plabel; + oldpushedparasize : longint; + + begin + { save & reset pushedparasize } + oldpushedparasize:=pushedparasize; + pushedparasize:=0; + case p^.inlinenumber of + in_assert_x_y: + begin + otlabel:=truelabel; + oflabel:=falselabel; + getlabel(truelabel); + getlabel(falselabel); + secondpass(p^.left^.left); + if cs_do_assertion in aktlocalswitches then + begin + maketojumpbool(p^.left^.left); + emitlab(falselabel); + { erroraddr } + exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_EBP))); + { lineno } + exprasmlist^.concat(new(pai386,op_const(A_PUSH,S_L,aktfilepos.line))); + { filename string } + hp:=genstringconstnode(current_module^.sourcefiles^.get_file_name(aktfilepos.fileindex)); + secondpass(hp); + if codegenerror then + exit; + emitpushreferenceaddr(exprasmlist,hp^.location.reference); + disposetree(hp); + { push msg } + secondpass(p^.left^.right^.left); + emitpushreferenceaddr(exprasmlist,p^.left^.right^.left^.location.reference); + { call } + emitcall('FPC_ASSERT',true); + emitlab(truelabel); + end; + freelabel(truelabel); + freelabel(falselabel); + truelabel:=otlabel; + falselabel:=oflabel; + end; + in_lo_word, + in_hi_word : + begin + secondpass(p^.left); + p^.location.loc:=LOC_REGISTER; + if p^.left^.location.loc<>LOC_REGISTER then + begin + if p^.left^.location.loc=LOC_CREGISTER then + begin + p^.location.register:=reg32toreg16(getregister32); + emit_reg_reg(A_MOV,S_W,p^.left^.location.register, + p^.location.register); + end + else + begin + del_reference(p^.left^.location.reference); + p^.location.register:=reg32toreg16(getregister32); + exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_W,newreference(p^.left^.location.reference), + p^.location.register))); + end; + end + else p^.location.register:=p^.left^.location.register; + if p^.inlinenumber=in_hi_word then + exprasmlist^.concat(new(pai386,op_const_reg(A_SHR,S_W,8,p^.location.register))); + p^.location.register:=reg16toreg8(p^.location.register); + end; + in_sizeof_x, + in_typeof_x : + begin + { for both cases load vmt } + if p^.left^.treetype=typen then + begin + p^.location.register:=getregister32; + exprasmlist^.concat(new(pai386,op_sym_ofs_reg(A_MOV, + S_L,newasmsymbol(pobjectdef(p^.left^.resulttype)^.vmt_mangledname),0, + p^.location.register))); + end + else + begin + secondpass(p^.left); + del_reference(p^.left^.location.reference); + p^.location.loc:=LOC_REGISTER; + p^.location.register:=getregister32; + { load VMT pointer } + inc(p^.left^.location.reference.offset, + pobjectdef(p^.left^.resulttype)^.vmt_offset); + exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, + newreference(p^.left^.location.reference), + p^.location.register))); + end; + { in sizeof load size } + if p^.inlinenumber=in_sizeof_x then + begin + new(r); + reset_reference(r^); + r^.base:=p^.location.register; + exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r, + p^.location.register))); + end; + end; + in_lo_long, + in_hi_long : + begin + secondpass(p^.left); + p^.location.loc:=LOC_REGISTER; + if p^.left^.location.loc<>LOC_REGISTER then + begin + if p^.left^.location.loc=LOC_CREGISTER then + begin + p^.location.register:=getregister32; + emit_reg_reg(A_MOV,S_L,p^.left^.location.register, + p^.location.register); + end + else + begin + del_reference(p^.left^.location.reference); + p^.location.register:=getregister32; + exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.left^.location.reference), + p^.location.register))); + end; + end + else p^.location.register:=p^.left^.location.register; + if p^.inlinenumber=in_hi_long then + exprasmlist^.concat(new(pai386,op_const_reg(A_SHR,S_L,16,p^.location.register))); + p^.location.register:=reg32toreg16(p^.location.register); + end; + in_length_string : + begin + secondpass(p^.left); + set_location(p^.location,p^.left^.location); + { length in ansi strings is at offset -8 } + if is_ansistring(p^.left^.resulttype) then + dec(p^.location.reference.offset,8) + { char is always 1, so make it a constant value } + else if is_char(p^.left^.resulttype) then + begin + clear_location(p^.location); + p^.location.loc:=LOC_MEM; + p^.location.reference.is_immediate:=true; + p^.location.reference.offset:=1; + end; + end; + in_pred_x, + in_succ_x: + begin + secondpass(p^.left); + if not (cs_check_overflow in aktlocalswitches) then + if p^.inlinenumber=in_pred_x then + asmop:=A_DEC + else + asmop:=A_INC + else + if p^.inlinenumber=in_pred_x then + asmop:=A_SUB + else + asmop:=A_ADD; + case p^.resulttype^.size of + 4 : opsize:=S_L; + 2 : opsize:=S_W; + 1 : opsize:=S_B; + else + internalerror(10080); + end; + p^.location.loc:=LOC_REGISTER; + if p^.left^.location.loc<>LOC_REGISTER then + begin + p^.location.register:=getregister32; + if (p^.resulttype^.size=2) then + p^.location.register:=reg32toreg16(p^.location.register); + if (p^.resulttype^.size=1) then + p^.location.register:=reg32toreg8(p^.location.register); + if p^.left^.location.loc=LOC_CREGISTER then + emit_reg_reg(A_MOV,opsize,p^.left^.location.register, + p^.location.register) + else + if p^.left^.location.loc=LOC_FLAGS then + emit_flag2reg(p^.left^.location.resflags,p^.location.register) + else + begin + del_reference(p^.left^.location.reference); + exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,opsize,newreference(p^.left^.location.reference), + p^.location.register))); + end; + end + else p^.location.register:=p^.left^.location.register; + + if not (cs_check_overflow in aktlocalswitches) then + exprasmlist^.concat(new(pai386,op_reg(asmop,opsize, + p^.location.register))) + else + exprasmlist^.concat(new(pai386,op_const_reg(asmop,opsize,1, + p^.location.register))); + emitoverflowcheck(p); + emitrangecheck(p,p^.resulttype); + end; + in_dec_x, + in_inc_x : + begin + { set defaults } + addvalue:=1; + addconstant:=true; + { load first parameter, must be a reference } + secondpass(p^.left^.left); + case p^.left^.left^.resulttype^.deftype of + orddef, + enumdef : begin + case p^.left^.left^.resulttype^.size of + 1 : opsize:=S_B; + 2 : opsize:=S_W; + 4 : opsize:=S_L; + end; + end; + pointerdef : begin + opsize:=S_L; + if porddef(ppointerdef(p^.left^.left^.resulttype)^.definition)=voiddef then + addvalue:=1 + else + addvalue:=ppointerdef(p^.left^.left^.resulttype)^.definition^.savesize; + end; + else + internalerror(10081); + end; + { second argument specified?, must be a s32bit in register } + if assigned(p^.left^.right) then + begin + secondpass(p^.left^.right^.left); + { when constant, just multiply the addvalue } + if is_constintnode(p^.left^.right^.left) then + addvalue:=addvalue*get_ordinal_value(p^.left^.right^.left) + else + begin + case p^.left^.right^.left^.location.loc of + LOC_REGISTER, + LOC_CREGISTER : hregister:=p^.left^.right^.left^.location.register; + LOC_MEM, + LOC_REFERENCE : begin + del_reference(p^.left^.right^.left^.location.reference); + hregister:=getregister32; + exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, + newreference(p^.left^.right^.left^.location.reference),hregister))); + end; + else + internalerror(10082); + end; + { insert multiply with addvalue if its >1 } + if addvalue>1 then + exprasmlist^.concat(new(pai386,op_const_reg(A_IMUL,opsize, + addvalue,hregister))); + addconstant:=false; + end; + end; + { write the add instruction } + if addconstant then + begin + if (addvalue=1) and not(cs_check_overflow in aktlocalswitches) then + begin + if p^.left^.left^.location.loc=LOC_CREGISTER then + exprasmlist^.concat(new(pai386,op_reg(incdecop[p^.inlinenumber],opsize, + p^.left^.left^.location.register))) + else + exprasmlist^.concat(new(pai386,op_ref(incdecop[p^.inlinenumber],opsize, + newreference(p^.left^.left^.location.reference)))) + end + else + begin + if p^.left^.left^.location.loc=LOC_CREGISTER then + exprasmlist^.concat(new(pai386,op_const_reg(addsubop[p^.inlinenumber],opsize, + addvalue,p^.left^.left^.location.register))) + else + exprasmlist^.concat(new(pai386,op_const_ref(addsubop[p^.inlinenumber],opsize, + addvalue,newreference(p^.left^.left^.location.reference)))); + end + end + else + begin + { BUG HERE : detected with nasm : + hregister is allways 32 bit + it should be converted to 16 or 8 bit depending on op_size PM } + { still not perfect : + if hregister is already a 16 bit reg ?? PM } + case opsize of + S_B : hregister:=reg32toreg8(hregister); + S_W : hregister:=reg32toreg16(hregister); + end; + if p^.left^.left^.location.loc=LOC_CREGISTER then + exprasmlist^.concat(new(pai386,op_reg_reg(addsubop[p^.inlinenumber],opsize, + hregister,p^.left^.left^.location.register))) + else + exprasmlist^.concat(new(pai386,op_reg_ref(addsubop[p^.inlinenumber],opsize, + hregister,newreference(p^.left^.left^.location.reference)))); + case opsize of + S_B : hregister:=reg8toreg32(hregister); + S_W : hregister:=reg16toreg32(hregister); + end; + ungetregister32(hregister); + end; + emitoverflowcheck(p^.left^.left); + emitrangecheck(p^.left^.left,p^.left^.left^.resulttype); + end; + in_assigned_x : + begin + secondpass(p^.left^.left); + p^.location.loc:=LOC_FLAGS; + if (p^.left^.left^.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then + begin + exprasmlist^.concat(new(pai386,op_reg_reg(A_OR,S_L, + p^.left^.left^.location.register, + p^.left^.left^.location.register))); + ungetregister32(p^.left^.left^.location.register); + end + else + begin + exprasmlist^.concat(new(pai386,op_const_ref(A_CMP,S_L,0, + newreference(p^.left^.left^.location.reference)))); + del_reference(p^.left^.left^.location.reference); + end; + p^.location.resflags:=F_NE; + end; + in_reset_typedfile,in_rewrite_typedfile : + begin + pushusedregisters(exprasmlist,pushed,$ff); + exprasmlist^.concat(new(pai386,op_const(A_PUSH,S_L,pfiledef(p^.left^.resulttype)^.typed_as^.size))); + secondpass(p^.left); + emitpushreferenceaddr(exprasmlist,p^.left^.location.reference); + if p^.inlinenumber=in_reset_typedfile then + emitcall('FPC_RESET_TYPED',true) + else + emitcall('FPC_REWRITE_TYPED',true); + popusedregisters(exprasmlist,pushed); + end; + in_write_x : + handlereadwrite(false,false); + in_writeln_x : + handlereadwrite(false,true); + in_read_x : + handlereadwrite(true,false); + in_readln_x : + handlereadwrite(true,true); + in_str_x_string : + begin + handle_str; + maybe_loadesi; + end; +{$IfnDef OLDVAL} + in_val_x : + Begin + handle_val; + End; +{$EndIf OLDVAL} + in_include_x_y, + in_exclude_x_y: + begin + secondpass(p^.left^.left); + if p^.left^.right^.left^.treetype=ordconstn then + begin + { calculate bit position } + l:=1 shl (p^.left^.right^.left^.value mod 32); + + { determine operator } + if p^.inlinenumber=in_include_x_y then + asmop:=A_OR + else + begin + asmop:=A_AND; + l:=not(l); + end; + if (p^.left^.left^.location.loc=LOC_REFERENCE) then + begin + inc(p^.left^.left^.location.reference.offset,(p^.left^.right^.left^.value div 32)*4); + exprasmlist^.concat(new(pai386,op_const_ref(asmop,S_L, + l,newreference(p^.left^.left^.location.reference)))); + del_reference(p^.left^.left^.location.reference); + end + else + { LOC_CREGISTER } + exprasmlist^.concat(new(pai386,op_const_reg(asmop,S_L, + l,p^.left^.left^.location.register))); + end + else + begin + { generate code for the element to set } + ispushed:=maybe_push(p^.left^.right^.left^.registers32,p^.left^.left); + secondpass(p^.left^.right^.left); + if ispushed then + restore(p^.left^.left); + { determine asm operator } + if p^.inlinenumber=in_include_x_y then + asmop:=A_BTS + else + asmop:=A_BTR; + if psetdef(p^.left^.resulttype)^.settype=smallset then + begin + if p^.left^.right^.left^.location.loc in [LOC_CREGISTER,LOC_REGISTER] then + hregister:=p^.left^.right^.left^.location.register + else + begin + hregister:=R_EDI; + opsize:=def2def_opsize(p^.left^.right^.left^.resulttype,u32bitdef); + if opsize in [S_B,S_W,S_L] then + op:=A_MOV + else + op:=A_MOVZX; + exprasmlist^.concat(new(pai386,op_ref_reg(op,opsize, + newreference(p^.left^.right^.left^.location.reference),R_EDI))); + end; + if (p^.left^.left^.location.loc=LOC_REFERENCE) then + exprasmlist^.concat(new(pai386,op_reg_ref(asmop,S_L,hregister, + newreference(p^.left^.right^.left^.location.reference)))) + else + exprasmlist^.concat(new(pai386,op_reg_reg(asmop,S_L,hregister, + p^.left^.right^.left^.location.register))); + end + else + begin + pushsetelement(p^.left^.right^.left); + { normset is allways a ref } + emitpushreferenceaddr(exprasmlist, + p^.left^.left^.location.reference); + if p^.inlinenumber=in_include_x_y then + emitcall('FPC_SET_SET_BYTE',true) + else + emitcall('FPC_SET_UNSET_BYTE',true); + {CGMessage(cg_e_include_not_implemented);} + end; + end; + end; + else internalerror(9); + end; + { reset pushedparasize } + pushedparasize:=oldpushedparasize; + end; + +end. +{ $Log$ - Revision 1.52 1999-05-21 13:54:50 peter + Revision 1.53 1999-05-23 18:42:01 florian + * better error recovering in typed constants + * some problems with arrays of const fixed, some problems + due my previous + - the location type of array constructor is now LOC_MEM + - the pushing of high fixed + - parameter copying fixed + - zero temp. allocation removed + * small problem in the assembler writers fixed: + ref to nil wasn't written correctly + + Revision 1.52 1999/05/21 13:54:50 peter * NEWLAB for label as symbol - - Revision 1.51 1999/05/18 21:58:27 florian - * fixed some bugs related to temp. ansistrings and functions results - which return records/objects/arrays which need init/final. - - Revision 1.50 1999/05/17 21:57:03 florian - * new temporary ansistring handling - - Revision 1.49 1999/05/12 15:46:26 pierre - * handle_str disposetree was badly placed - - Revision 1.48 1999/05/12 00:19:42 peter - * removed R_DEFAULT_SEG - * uniform float names - - Revision 1.47 1999/05/06 09:05:13 peter - * generic write_float and str_float - * fixed constant float conversions - - Revision 1.46 1999/05/05 16:18:20 jonas - * changes to handle_val so register vars are pushed/poped only once - - Revision 1.45 1999/05/01 13:24:08 peter - * merged nasm compiler - * old asm moved to oldasm/ - - Revision 1.44 1999/04/26 18:28:13 peter - * better read/write array - - Revision 1.43 1999/04/19 09:45:48 pierre - + cdecl or stdcall push all args with longint size - * tempansi stuff cleaned up - - Revision 1.42 1999/04/14 09:11:59 peter - * fixed include - - Revision 1.41 1999/04/08 23:59:49 pierre - * temp string for val code freed - - Revision 1.40 1999/04/08 15:57:46 peter - + subrange checking for readln() - - Revision 1.39 1999/04/07 15:31:16 pierre - * all formaldefs are now a sinlge definition - cformaldef (this was necessary for double_checksum) - + small part of double_checksum code - - Revision 1.38 1999/04/05 11:07:26 jonas - * fixed some typos in the constants of the range checking for Val - - Revision 1.37 1999/04/01 22:07:51 peter - * universal string names (ansistr instead of stransi) for val/str - - Revision 1.36 1999/04/01 06:21:04 jonas - * added initialization for has_32bit_code (caused problems with Val statement - without code parameter) - - Revision 1.35 1999/03/31 20:30:49 michael - * fixed typo: odlval to oldval - - Revision 1.34 1999/03/31 17:13:09 jonas - * bugfix for -Ox with internal val code - * internal val code now requires less free registers - * internal val code no longer needs a temp var for range checking - - Revision 1.33 1999/03/26 00:24:15 peter - * last para changed to long for easier pushing with 4 byte aligns - - Revision 1.32 1999/03/26 00:05:26 peter - * released valintern - + deffile is now removed when compiling is finished - * ^( compiles now correct - + static directive - * shrd fixed - - Revision 1.31 1999/03/24 23:16:49 peter - * fixed bugs 212,222,225,227,229,231,233 - - Revision 1.30 1999/03/16 17:52:56 jonas - * changes for internal Val code (do a "make cycle OPT=-dvalintern" to test) - * in cgi386inl: also range checking for subrange types (compile with "-dreadrangecheck") - * in cgai386: also small fixes to emitrangecheck - - Revision 1.29 1999/02/25 21:02:27 peter - * ag386bin updates - + coff writer - - Revision 1.28 1999/02/22 02:15:11 peter - * updates for ag386bin - - Revision 1.27 1999/02/17 14:21:40 pierre - * unused local removed - - Revision 1.26 1999/02/15 11:40:21 pierre - * pred/succ with overflow check must use ADD DEC !! - - Revision 1.25 1999/02/05 10:56:19 florian - * in some cases a writeln of temp. ansistrings cause a memory leak, fixed - - Revision 1.24 1999/01/21 22:10:39 peter - * fixed array of const - * generic platform independent high() support - - Revision 1.23 1999/01/06 12:23:29 florian - * str(...) for ansi/long and widestrings fixed - - Revision 1.22 1998/12/11 23:36:07 florian - + again more stuff for int64/qword: - - comparision operators - - code generation for: str, read(ln), write(ln) - - Revision 1.21 1998/12/11 00:02:50 peter - + globtype,tokens,version unit splitted from globals - - Revision 1.20 1998/11/27 14:50:32 peter - + open strings, $P switch support - - Revision 1.19 1998/11/26 13:10:40 peter - * new int - int conversion -dNEWCNV - * some function renamings - - Revision 1.18 1998/11/24 17:04:27 peter - * fixed length(char) when char is a variable - - Revision 1.17 1998/11/05 12:02:33 peter - * released useansistring - * removed -Sv, its now available in fpc modes - - Revision 1.16 1998/10/22 17:11:13 pierre - + terminated the include exclude implementation for i386 - * enums inside records fixed - - Revision 1.15 1998/10/21 15:12:50 pierre - * bug fix for IOCHECK inside a procedure with iocheck modifier - * removed the GPF for unexistant overloading - (firstcall was called with procedinition=nil !) - * changed typen to what Florian proposed - gentypenode(p : pdef) sets the typenodetype field - and resulttype is only set if inside bt_type block ! - - Revision 1.14 1998/10/20 08:06:40 pierre - * several memory corruptions due to double freemem solved - => never use p^.loc.location:=p^.left^.loc.location; - + finally I added now by default - that ra386dir translates global and unit symbols - + added a first field in tsymtable and - a nextsym field in tsym - (this allows to obtain ordered type info for - records and objects in gdb !) - - Revision 1.13 1998/10/13 16:50:02 pierre - * undid some changes of Peter that made the compiler wrong - for m68k (I had to reinsert some ifdefs) - * removed several memory leaks under m68k - * removed the meory leaks for assembler readers - * cross compiling shoud work again better - ( crosscompiling sysamiga works - but as68k still complain about some code !) - - Revision 1.12 1998/10/08 17:17:12 pierre - * current_module old scanner tagged as invalid if unit is recompiled - + added ppheap for better info on tracegetmem of heaptrc - (adds line column and file index) - * several memory leaks removed ith help of heaptrc !! - - Revision 1.11 1998/10/05 21:33:15 peter - * fixed 161,165,166,167,168 - - Revision 1.10 1998/10/05 12:32:44 peter - + assert() support - - Revision 1.8 1998/10/02 10:35:09 peter - * support for inc(pointer,value) which now increases with value instead - of 0*value :) - - Revision 1.7 1998/09/21 08:45:07 pierre - + added vmt_offset in tobjectdef.write for fututre use - (first steps to have objects without vmt if no virtual !!) - + added fpu_used field for tabstractprocdef : - sets this level to 2 if the functions return with value in FPU - (is then set to correct value at parsing of implementation) - THIS MIGHT refuse some code with FPU expression too complex - that were accepted before and even in some cases - that don't overflow in fact - ( like if f : float; is a forward that finally in implementation - only uses one fpu register !!) - Nevertheless I think that it will improve security on - FPU operations !! - * most other changes only for UseBrowser code - (added symtable references for record and objects) - local switch for refs to args and local of each function - (static symtable still missing) - UseBrowser still not stable and probably broken by - the definition hash array !! - - Revision 1.6 1998/09/20 12:26:37 peter - * merged fixes - - Revision 1.5 1998/09/17 09:42:15 peter - + pass_2 for cg386 - * Message() -> CGMessage() for pass_1/pass_2 - - Revision 1.4 1998/09/14 10:43:49 peter - * all internal RTL functions start with FPC_ - - Revision 1.3.2.1 1998/09/20 12:20:07 peter - * Fixed stack not on 4 byte boundary when doing a call - - Revision 1.3 1998/09/05 23:03:57 florian - * some fixes to get -Or work: - - inc/dec didn't take care of CREGISTER - - register calculcation of inc/dec was wrong - - var/const parameters get now assigned 32 bit register, but - const parameters only if they are passed by reference ! - - Revision 1.2 1998/09/04 08:41:40 peter - * updated some error CGMessages - - Revision 1.1 1998/08/31 12:22:14 peter - * secondinline moved to cg386inl - - Revision 1.19 1998/08/31 08:52:03 peter - * fixed error 10 with succ() and pref() - - Revision 1.18 1998/08/20 21:36:38 peter - * fixed 'with object do' bug - - Revision 1.17 1998/08/19 16:07:36 jonas - * changed optimizer switches + cleanup of DestroyRefs in daopt386.pas - - Revision 1.16 1998/08/18 09:24:36 pierre - * small warning position bug fixed - * support_mmx switches splitting was missing - * rhide error and warning output corrected - - Revision 1.15 1998/08/13 11:00:09 peter - * fixed procedure<>procedure construct - - Revision 1.14 1998/08/11 14:05:33 peter - * fixed sizeof(array of char) - - Revision 1.13 1998/08/10 14:49:45 peter - + localswitches, moduleswitches, globalswitches splitting - - Revision 1.12 1998/07/30 13:30:31 florian - * final implemenation of exception support, maybe it needs - some fixes :) - - Revision 1.11 1998/07/24 22:16:52 florian - * internal error 10 together with array access fixed. I hope - that's the final fix. - - Revision 1.10 1998/07/18 22:54:23 florian - * some ansi/wide/longstring support fixed: - o parameter passing - o returning as result from functions - - Revision 1.9 1998/07/07 17:40:37 peter - * packrecords 4 works - * word aligning of parameters - - Revision 1.8 1998/07/06 15:51:15 michael - Added length checking for string reading - - Revision 1.7 1998/07/06 14:19:51 michael - + Added calls for reading/writing ansistrings - - Revision 1.6 1998/07/01 15:28:48 peter - + better writeln/readln handling, now 100% like tp7 - - Revision 1.5 1998/06/25 14:04:17 peter - + internal inc/dec - - Revision 1.4 1998/06/25 08:48:06 florian - * first version of rtti support - - Revision 1.3 1998/06/09 16:01:33 pierre - + added procedure directive parsing for procvars - (accepted are popstack cdecl and pascal) - + added C vars with the following syntax - var C calias 'true_c_name';(can be followed by external) - reason is that you must add the Cprefix - - which is target dependent - - Revision 1.2 1998/06/08 13:13:29 pierre - + temporary variables now in temp_gen.pas unit - because it is processor independent - * mppc68k.bat modified to undefine i386 and support_mmx - (which are defaults for i386) - - Revision 1.1 1998/06/05 17:44:10 peter - * splitted cgi386 - -} - + + Revision 1.51 1999/05/18 21:58:27 florian + * fixed some bugs related to temp. ansistrings and functions results + which return records/objects/arrays which need init/final. + + Revision 1.50 1999/05/17 21:57:03 florian + * new temporary ansistring handling + + Revision 1.49 1999/05/12 15:46:26 pierre + * handle_str disposetree was badly placed + + Revision 1.48 1999/05/12 00:19:42 peter + * removed R_DEFAULT_SEG + * uniform float names + + Revision 1.47 1999/05/06 09:05:13 peter + * generic write_float and str_float + * fixed constant float conversions + + Revision 1.46 1999/05/05 16:18:20 jonas + * changes to handle_val so register vars are pushed/poped only once + + Revision 1.45 1999/05/01 13:24:08 peter + * merged nasm compiler + * old asm moved to oldasm/ + + Revision 1.44 1999/04/26 18:28:13 peter + * better read/write array + + Revision 1.43 1999/04/19 09:45:48 pierre + + cdecl or stdcall push all args with longint size + * tempansi stuff cleaned up + + Revision 1.42 1999/04/14 09:11:59 peter + * fixed include + + Revision 1.41 1999/04/08 23:59:49 pierre + * temp string for val code freed + + Revision 1.40 1999/04/08 15:57:46 peter + + subrange checking for readln() + + Revision 1.39 1999/04/07 15:31:16 pierre + * all formaldefs are now a sinlge definition + cformaldef (this was necessary for double_checksum) + + small part of double_checksum code + + Revision 1.38 1999/04/05 11:07:26 jonas + * fixed some typos in the constants of the range checking for Val + + Revision 1.37 1999/04/01 22:07:51 peter + * universal string names (ansistr instead of stransi) for val/str + + Revision 1.36 1999/04/01 06:21:04 jonas + * added initialization for has_32bit_code (caused problems with Val statement + without code parameter) + + Revision 1.35 1999/03/31 20:30:49 michael + * fixed typo: odlval to oldval + + Revision 1.34 1999/03/31 17:13:09 jonas + * bugfix for -Ox with internal val code + * internal val code now requires less free registers + * internal val code no longer needs a temp var for range checking + + Revision 1.33 1999/03/26 00:24:15 peter + * last para changed to long for easier pushing with 4 byte aligns + + Revision 1.32 1999/03/26 00:05:26 peter + * released valintern + + deffile is now removed when compiling is finished + * ^( compiles now correct + + static directive + * shrd fixed + + Revision 1.31 1999/03/24 23:16:49 peter + * fixed bugs 212,222,225,227,229,231,233 + + Revision 1.30 1999/03/16 17:52:56 jonas + * changes for internal Val code (do a "make cycle OPT=-dvalintern" to test) + * in cgi386inl: also range checking for subrange types (compile with "-dreadrangecheck") + * in cgai386: also small fixes to emitrangecheck + + Revision 1.29 1999/02/25 21:02:27 peter + * ag386bin updates + + coff writer + + Revision 1.28 1999/02/22 02:15:11 peter + * updates for ag386bin + + Revision 1.27 1999/02/17 14:21:40 pierre + * unused local removed + + Revision 1.26 1999/02/15 11:40:21 pierre + * pred/succ with overflow check must use ADD DEC !! + + Revision 1.25 1999/02/05 10:56:19 florian + * in some cases a writeln of temp. ansistrings cause a memory leak, fixed + + Revision 1.24 1999/01/21 22:10:39 peter + * fixed array of const + * generic platform independent high() support + + Revision 1.23 1999/01/06 12:23:29 florian + * str(...) for ansi/long and widestrings fixed + + Revision 1.22 1998/12/11 23:36:07 florian + + again more stuff for int64/qword: + - comparision operators + - code generation for: str, read(ln), write(ln) + + Revision 1.21 1998/12/11 00:02:50 peter + + globtype,tokens,version unit splitted from globals + + Revision 1.20 1998/11/27 14:50:32 peter + + open strings, $P switch support + + Revision 1.19 1998/11/26 13:10:40 peter + * new int - int conversion -dNEWCNV + * some function renamings + + Revision 1.18 1998/11/24 17:04:27 peter + * fixed length(char) when char is a variable + + Revision 1.17 1998/11/05 12:02:33 peter + * released useansistring + * removed -Sv, its now available in fpc modes + + Revision 1.16 1998/10/22 17:11:13 pierre + + terminated the include exclude implementation for i386 + * enums inside records fixed + + Revision 1.15 1998/10/21 15:12:50 pierre + * bug fix for IOCHECK inside a procedure with iocheck modifier + * removed the GPF for unexistant overloading + (firstcall was called with procedinition=nil !) + * changed typen to what Florian proposed + gentypenode(p : pdef) sets the typenodetype field + and resulttype is only set if inside bt_type block ! + + Revision 1.14 1998/10/20 08:06:40 pierre + * several memory corruptions due to double freemem solved + => never use p^.loc.location:=p^.left^.loc.location; + + finally I added now by default + that ra386dir translates global and unit symbols + + added a first field in tsymtable and + a nextsym field in tsym + (this allows to obtain ordered type info for + records and objects in gdb !) + + Revision 1.13 1998/10/13 16:50:02 pierre + * undid some changes of Peter that made the compiler wrong + for m68k (I had to reinsert some ifdefs) + * removed several memory leaks under m68k + * removed the meory leaks for assembler readers + * cross compiling shoud work again better + ( crosscompiling sysamiga works + but as68k still complain about some code !) + + Revision 1.12 1998/10/08 17:17:12 pierre + * current_module old scanner tagged as invalid if unit is recompiled + + added ppheap for better info on tracegetmem of heaptrc + (adds line column and file index) + * several memory leaks removed ith help of heaptrc !! + + Revision 1.11 1998/10/05 21:33:15 peter + * fixed 161,165,166,167,168 + + Revision 1.10 1998/10/05 12:32:44 peter + + assert() support + + Revision 1.8 1998/10/02 10:35:09 peter + * support for inc(pointer,value) which now increases with value instead + of 0*value :) + + Revision 1.7 1998/09/21 08:45:07 pierre + + added vmt_offset in tobjectdef.write for fututre use + (first steps to have objects without vmt if no virtual !!) + + added fpu_used field for tabstractprocdef : + sets this level to 2 if the functions return with value in FPU + (is then set to correct value at parsing of implementation) + THIS MIGHT refuse some code with FPU expression too complex + that were accepted before and even in some cases + that don't overflow in fact + ( like if f : float; is a forward that finally in implementation + only uses one fpu register !!) + Nevertheless I think that it will improve security on + FPU operations !! + * most other changes only for UseBrowser code + (added symtable references for record and objects) + local switch for refs to args and local of each function + (static symtable still missing) + UseBrowser still not stable and probably broken by + the definition hash array !! + + Revision 1.6 1998/09/20 12:26:37 peter + * merged fixes + + Revision 1.5 1998/09/17 09:42:15 peter + + pass_2 for cg386 + * Message() -> CGMessage() for pass_1/pass_2 + + Revision 1.4 1998/09/14 10:43:49 peter + * all internal RTL functions start with FPC_ + + Revision 1.3.2.1 1998/09/20 12:20:07 peter + * Fixed stack not on 4 byte boundary when doing a call + + Revision 1.3 1998/09/05 23:03:57 florian + * some fixes to get -Or work: + - inc/dec didn't take care of CREGISTER + - register calculcation of inc/dec was wrong + - var/const parameters get now assigned 32 bit register, but + const parameters only if they are passed by reference ! + + Revision 1.2 1998/09/04 08:41:40 peter + * updated some error CGMessages + + Revision 1.1 1998/08/31 12:22:14 peter + * secondinline moved to cg386inl + + Revision 1.19 1998/08/31 08:52:03 peter + * fixed error 10 with succ() and pref() + + Revision 1.18 1998/08/20 21:36:38 peter + * fixed 'with object do' bug + + Revision 1.17 1998/08/19 16:07:36 jonas + * changed optimizer switches + cleanup of DestroyRefs in daopt386.pas + + Revision 1.16 1998/08/18 09:24:36 pierre + * small warning position bug fixed + * support_mmx switches splitting was missing + * rhide error and warning output corrected + + Revision 1.15 1998/08/13 11:00:09 peter + * fixed procedure<>procedure construct + + Revision 1.14 1998/08/11 14:05:33 peter + * fixed sizeof(array of char) + + Revision 1.13 1998/08/10 14:49:45 peter + + localswitches, moduleswitches, globalswitches splitting + + Revision 1.12 1998/07/30 13:30:31 florian + * final implemenation of exception support, maybe it needs + some fixes :) + + Revision 1.11 1998/07/24 22:16:52 florian + * internal error 10 together with array access fixed. I hope + that's the final fix. + + Revision 1.10 1998/07/18 22:54:23 florian + * some ansi/wide/longstring support fixed: + o parameter passing + o returning as result from functions + + Revision 1.9 1998/07/07 17:40:37 peter + * packrecords 4 works + * word aligning of parameters + + Revision 1.8 1998/07/06 15:51:15 michael + Added length checking for string reading + + Revision 1.7 1998/07/06 14:19:51 michael + + Added calls for reading/writing ansistrings + + Revision 1.6 1998/07/01 15:28:48 peter + + better writeln/readln handling, now 100% like tp7 + + Revision 1.5 1998/06/25 14:04:17 peter + + internal inc/dec + + Revision 1.4 1998/06/25 08:48:06 florian + * first version of rtti support + + Revision 1.3 1998/06/09 16:01:33 pierre + + added procedure directive parsing for procvars + (accepted are popstack cdecl and pascal) + + added C vars with the following syntax + var C calias 'true_c_name';(can be followed by external) + reason is that you must add the Cprefix + + which is target dependent + + Revision 1.2 1998/06/08 13:13:29 pierre + + temporary variables now in temp_gen.pas unit + because it is processor independent + * mppc68k.bat modified to undefine i386 and support_mmx + (which are defaults for i386) + + Revision 1.1 1998/06/05 17:44:10 peter + * splitted cgi386 + +} + diff --git a/compiler/cg386ld.pas b/compiler/cg386ld.pas index 8595292aa6..a8cf216611 100644 --- a/compiler/cg386ld.pas +++ b/compiler/cg386ld.pas @@ -1,1091 +1,1107 @@ -{ - $Id$ - Copyright (c) 1993-98 by Florian Klaempfl - - Generate i386 assembler for load/assignment nodes - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - - **************************************************************************** -} -unit cg386ld; -interface - - uses - tree; - - procedure secondload(var p : ptree); - procedure secondassignment(var p : ptree); - procedure secondfuncret(var p : ptree); - procedure secondarrayconstruct(var p : ptree); - - -implementation - - uses - globtype,systems, - cobjects,verbose,globals, - symtable,aasm,types, - hcodegen,temp_gen,pass_2, -{$ifndef OLDASM} - i386base,i386asm, -{$else} - i386, -{$endif} - cgai386,tgeni386,cg386cnv; - -{***************************************************************************** - SecondLoad -*****************************************************************************} - - procedure secondload(var p : ptree); - var - hregister : tregister; - symtabletype : tsymtabletype; - i : longint; - hp : preference; - s : pasmsymbol; - popeax : boolean; - - begin - simple_loadn:=true; - reset_reference(p^.location.reference); - case p^.symtableentry^.typ of - { this is only for toasm and toaddr } - absolutesym : - begin - p^.location.reference.symbol:=nil; - if (pabsolutesym(p^.symtableentry)^.abstyp=toaddr) then - begin - if pabsolutesym(p^.symtableentry)^.absseg then - p^.location.reference.segment:=R_FS; - p^.location.reference.offset:=pabsolutesym(p^.symtableentry)^.address; - end - else - p^.location.reference.symbol:=newasmsymbol(p^.symtableentry^.mangledname); -{$ifndef NEWLAB} - maybe_concat_external(p^.symtableentry^.owner,p^.symtableentry^.mangledname); -{$endif} - end; - varsym : - begin - hregister:=R_NO; - { C variable } - if (pvarsym(p^.symtableentry)^.var_options and vo_is_C_var)<>0 then - begin - p^.location.reference.symbol:=newasmsymbol(p^.symtableentry^.mangledname); -{$ifndef NEWLAB} - if (pvarsym(p^.symtableentry)^.var_options and vo_is_external)<>0 then - concat_external(p^.symtableentry^.mangledname,EXT_NEAR); -{$endif} - end - { DLL variable } - else if (pvarsym(p^.symtableentry)^.var_options and vo_is_dll_var)<>0 then - begin - hregister:=getregister32; - p^.location.reference.symbol:=newasmsymbol(p^.symtableentry^.mangledname); - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.location.reference),hregister))); - p^.location.reference.symbol:=nil; - p^.location.reference.base:=hregister; - end - { external variable } - else if (pvarsym(p^.symtableentry)^.var_options and vo_is_external)<>0 then - begin - p^.location.reference.symbol:=newasmsymbol(p^.symtableentry^.mangledname); -{$ifndef NEWLAB} - concat_external(p^.symtableentry^.mangledname,EXT_NEAR); -{$endif} - end - { thread variable } - else if (pvarsym(p^.symtableentry)^.var_options and vo_is_thread_var)<>0 then - begin - popeax:=not(R_EAX in unused); - if popeax then - exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_EAX))); - p^.location.reference.symbol:=newasmsymbol(p^.symtableentry^.mangledname); -{$ifndef NEWLAB} - if p^.symtable^.symtabletype=unitsymtable then - concat_external(p^.symtableentry^.mangledname,EXT_NEAR); -{$endif} - exprasmlist^.concat(new(pai386,op_ref(A_PUSH,S_L,newreference(p^.location.reference)))); - { the called procedure isn't allowed to change } - { any register except EAX } - emitcall('FPC_RELOCATE_THREADVAR',true); - - reset_reference(p^.location.reference); - p^.location.reference.base:=getregister32; - emit_reg_reg(A_MOV,S_L,R_EAX,p^.location.reference.base); - if popeax then - exprasmlist^.concat(new(pai386,op_reg(A_POP,S_L,R_EAX))); - - end - { normal variable } - else - begin - symtabletype:=p^.symtable^.symtabletype; - { in case it is a register variable: } - if pvarsym(p^.symtableentry)^.reg<>R_NO then - begin - p^.location.loc:=LOC_CREGISTER; - p^.location.register:=pvarsym(p^.symtableentry)^.reg; - unused:=unused-[pvarsym(p^.symtableentry)^.reg]; - end - else - begin - { first handle local and temporary variables } - if (symtabletype in [parasymtable,inlinelocalsymtable, - inlineparasymtable,localsymtable]) then - begin - p^.location.reference.base:=procinfo.framepointer; - p^.location.reference.offset:=pvarsym(p^.symtableentry)^.address+p^.symtable^.address_fixup; - if (symtabletype in [localsymtable,inlinelocalsymtable]) then - p^.location.reference.offset:=-p^.location.reference.offset; - if (lexlevel>(p^.symtable^.symtablelevel)) then - begin - hregister:=getregister32; - - { make a reference } - hp:=new_reference(procinfo.framepointer, - procinfo.framepointer_offset); - - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,hp,hregister))); - - simple_loadn:=false; - i:=lexlevel-1; - while i>(p^.symtable^.symtablelevel) do - begin - { make a reference } - hp:=new_reference(hregister,8); - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,hp,hregister))); - dec(i); - end; - p^.location.reference.base:=hregister; - end; - end - else - case symtabletype of - unitsymtable,globalsymtable, - staticsymtable : - begin - p^.location.reference.symbol:=newasmsymbol(p^.symtableentry^.mangledname); -{$ifndef NEWLAB} - if symtabletype=unitsymtable then - concat_external(p^.symtableentry^.mangledname,EXT_NEAR); -{$endif} - end; - stt_exceptsymtable: - begin - p^.location.reference.base:=procinfo.framepointer; - p^.location.reference.offset:=pvarsym(p^.symtableentry)^.address; - end; - objectsymtable: - begin - if (pvarsym(p^.symtableentry)^.properties and sp_static)<>0 then - begin - p^.location.reference.symbol:=newasmsymbol(p^.symtableentry^.mangledname); -{$ifndef NEWLAB} - if p^.symtable^.defowner^.owner^.symtabletype=unitsymtable then - concat_external(p^.symtableentry^.mangledname,EXT_NEAR); -{$endif} - end - else - begin - p^.location.reference.base:=R_ESI; - p^.location.reference.offset:=pvarsym(p^.symtableentry)^.address; - end; - end; - withsymtable: - begin - { make a reference } - { symtable datasize field - contains the offset of the temp - stored } -{ hp:=new_reference(procinfo.framepointer, - p^.symtable^.datasize); - - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,hp,hregister)));} - - if ptree(pwithsymtable(p^.symtable)^.withnode)^.islocal then - begin - p^.location.reference:=ptree(pwithsymtable(p^.symtable)^.withnode)^.withreference^; - end - else - begin - hregister:=getregister32; - p^.location.reference.base:=hregister; - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, - newreference(ptree(pwithsymtable(p^.symtable)^.withnode)^.withreference^), - hregister))); - end; - inc(p^.location.reference.offset,pvarsym(p^.symtableentry)^.address); - end; - end; - end; - { in case call by reference, then calculate. Open array - is always an reference! } - if (pvarsym(p^.symtableentry)^.varspez=vs_var) or - is_open_array(pvarsym(p^.symtableentry)^.definition) or - ((pvarsym(p^.symtableentry)^.varspez=vs_const) and - push_addr_param(pvarsym(p^.symtableentry)^.definition)) then - begin - simple_loadn:=false; - if hregister=R_NO then - hregister:=getregister32; -{$ifdef OLDHIGH} - if is_open_array(pvarsym(p^.symtableentry)^.definition) or - is_open_string(pvarsym(p^.symtableentry)^.definition) then - begin - if (p^.location.reference.base=procinfo.framepointer) then - begin - highframepointer:=p^.location.reference.base; - highoffset:=p^.location.reference.offset; - end - else - begin - highframepointer:=R_EDI; - highoffset:=p^.location.reference.offset; - exprasmlist^.concat(new(pai386,op_reg_reg(A_MOV,S_L, - p^.location.reference.base,R_EDI))); - end; - end; -{$endif} - if p^.location.loc=LOC_CREGISTER then - begin - exprasmlist^.concat(new(pai386,op_reg_reg(A_MOV,S_L, - p^.location.register,hregister))); - p^.location.loc:=LOC_REFERENCE; - end - else - begin - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, - newreference(p^.location.reference), - hregister))); - end; - reset_reference(p^.location.reference); - p^.location.reference.base:=hregister; - end; - end; - end; - procsym: - begin - if assigned(p^.left) then - begin - secondpass(p^.left); - p^.location.loc:=LOC_MEM; - gettempofsizereference(8,p^.location.reference); - - { load class instance address } - case p^.left^.location.loc of - - LOC_CREGISTER, - LOC_REGISTER: - begin - hregister:=p^.left^.location.register; - ungetregister32(p^.left^.location.register); - { such code is allowed ! - CGMessage(cg_e_illegal_expression); } - end; - - LOC_MEM, - LOC_REFERENCE: - begin - hregister:=R_EDI; - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, - newreference(p^.left^.location.reference),R_EDI))); - del_reference(p^.left^.location.reference); - ungetiftemp(p^.left^.location.reference); - end; - else internalerror(26019); - end; - - { store the class instance address } - new(hp); - hp^:=p^.location.reference; - inc(hp^.offset,4); - exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L, - R_EDI,hp))); - - { virtual method ? } - if (pprocsym(p^.symtableentry)^.definition^.options and povirtualmethod)<>0 then - begin - new(hp); - reset_reference(hp^); - hp^.base:=hregister; - { load vmt pointer } - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, - hp,R_EDI))); -{$IfDef regallocfix} - del_reference(hp^); -{$EndIf regallocfix} - { load method address } - new(hp); - reset_reference(hp^); - hp^.base:=R_EDI; - hp^.offset:=pprocsym(p^.symtableentry)^.definition^.extnumber*4+12; - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, - hp,R_EDI))); - { ... and store it } - exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L, - R_EDI,newreference(p^.location.reference)))); - end - else - begin - s:=newasmsymbol(pprocsym(p^.symtableentry)^.definition^.mangledname); - exprasmlist^.concat(new(pai386,op_sym_ofs_ref(A_MOV,S_L,s,0, - newreference(p^.location.reference)))); -{$ifndef NEWLAB} - maybe_concat_external(p^.symtable,p^.symtableentry^.mangledname); -{$endif} - end; - end - else - begin - {!!!!! Be aware, work on virtual methods too } - p^.location.reference.symbol:=newasmsymbol(pprocsym(p^.symtableentry)^.definition^.mangledname); -{$ifndef NEWLAB} - maybe_concat_external(p^.symtable,p^.symtableentry^.mangledname); -{$endif} - end; - end; - typedconstsym : - begin - p^.location.reference.symbol:=newasmsymbol(p^.symtableentry^.mangledname); -{$ifndef NEWLAB} - maybe_concat_external(p^.symtable,p^.symtableentry^.mangledname); -{$endif} - end; - else internalerror(4); - end; - end; - - -{***************************************************************************** - SecondAssignment -*****************************************************************************} - - procedure secondassignment(var p : ptree); - var - opsize : topsize; - otlabel,hlabel,oflabel : plabel; - hregister : tregister; - loc : tloc; - r : preference; -{$ifndef OLDASM} - ai : pai386; -{$endif} - begin - otlabel:=truelabel; - oflabel:=falselabel; - getlabel(truelabel); - getlabel(falselabel); - { calculate left sides } - if not(p^.concat_string) then - secondpass(p^.left); - - if codegenerror then - exit; - - case p^.left^.location.loc of - LOC_REFERENCE : begin - { in case left operator uses to register } - { but to few are free then LEA } - if (p^.left^.location.reference.base<>R_NO) and - (p^.left^.location.reference.index<>R_NO) and - (usablereg32objectdef) or - not(pobjectdef(p^.right^.resulttype)^.isclass)) then - begin - { this would be a problem } - if not(p^.left^.resulttype^.needs_inittable) then - internalerror(3457); - - { increment source reference counter } - new(r); - reset_reference(r^); - r^.symbol:=newasmsymbol(lab2str(p^.right^.resulttype^.get_inittable_label)); - emitpushreferenceaddr(exprasmlist,r^); - - emitpushreferenceaddr(exprasmlist,p^.right^.location.reference); - exprasmlist^.concat(new(pai386, - op_sym(A_CALL,S_NO,newasmsymbol('FPC_ADDREF')))); -{$ifndef NEWLAB} - if not (cs_compilesystem in aktmoduleswitches) then - concat_external('FPC_ADDREF',EXT_NEAR); -{$endif} - { decrement destination reference counter } - new(r); - reset_reference(r^); - r^.symbol:=newasmsymbol(lab2str(p^.left^.resulttype^.get_inittable_label)); - emitpushreferenceaddr(exprasmlist,r^); - - emitpushreferenceaddr(exprasmlist,p^.left^.location.reference); - exprasmlist^.concat(new(pai386, - op_sym(A_CALL,S_NO,newasmsymbol('FPC_DECREF')))); -{$ifndef NEWLAB} - if not(cs_compilesystem in aktmoduleswitches) then - concat_external('FPC_DECREF',EXT_NEAR); -{$endif} - end; - -{$ifdef regallocfix} - concatcopy(p^.right^.location.reference, - p^.left^.location.reference,p^.left^.resulttype^.size,true,false); - ungetiftemp(p^.right^.location.reference); -{$Else regallocfix} - concatcopy(p^.right^.location.reference, - p^.left^.location.reference,p^.left^.resulttype^.size,false,false); - ungetiftemp(p^.right^.location.reference); -{$endif regallocfix} - end; - end; -{$ifdef SUPPORT_MMX} - LOC_CMMXREGISTER, - LOC_MMXREGISTER: - begin - if loc=LOC_CMMXREGISTER then - exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVQ,S_NO, - p^.right^.location.register,p^.left^.location.register))) - else - exprasmlist^.concat(new(pai386,op_reg_ref(A_MOVQ,S_NO, - p^.right^.location.register,newreference(p^.left^.location.reference)))); - end; -{$endif SUPPORT_MMX} - LOC_REGISTER, - LOC_CREGISTER : begin - case p^.right^.resulttype^.size of - 1 : opsize:=S_B; - 2 : opsize:=S_W; - 4 : opsize:=S_L; - 8 : opsize:=S_L; - end; - { simplified with op_reg_loc } - if loc=LOC_CREGISTER then - begin - exprasmlist^.concat(new(pai386,op_reg_reg(A_MOV,opsize, - p^.right^.location.register, - p^.left^.location.register))); -{$IfDef regallocfix} - ungetregister(p^.right^.location.register); -{$EndIf regallocfix} - end - else - Begin - exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,opsize, - p^.right^.location.register, - newreference(p^.left^.location.reference)))); -{$IfDef regallocfix} - ungetregister(p^.right^.location.register); - del_reference(p^.left^.location.reference); -{$EndIf regallocfix} - end; - if is_64bitint(p^.right^.resulttype) then - begin - { simplified with op_reg_loc } - if loc=LOC_CREGISTER then - exprasmlist^.concat(new(pai386,op_reg_reg(A_MOV,opsize, - p^.right^.location.registerhigh, - p^.left^.location.registerhigh))) - else - begin - r:=newreference(p^.left^.location.reference); - inc(r^.offset,4); - exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,opsize, - p^.right^.location.registerhigh,r))); - end; - end; - {exprasmlist^.concat(new(pai386,op_reg_loc(A_MOV,opsize, - p^.right^.location.register, - p^.left^.location))); } - - end; - LOC_FPU : begin - if loc<>LOC_REFERENCE then - internalerror(10010) - else - floatstore(pfloatdef(p^.left^.resulttype)^.typ, - p^.left^.location.reference); - end; - LOC_JUMP : begin - getlabel(hlabel); - emitlab(truelabel); - if loc=LOC_CREGISTER then - exprasmlist^.concat(new(pai386,op_const_reg(A_MOV,S_B, - 1,p^.left^.location.register))) - else - exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,S_B, - 1,newreference(p^.left^.location.reference)))); - {exprasmlist^.concat(new(pai386,op_const_loc(A_MOV,S_B, - 1,p^.left^.location)));} - emitjmp(C_None,hlabel); - emitlab(falselabel); - if loc=LOC_CREGISTER then - exprasmlist^.concat(new(pai386,op_reg_reg(A_XOR,S_B, - p^.left^.location.register, - p^.left^.location.register))) - else - begin - exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,S_B, - 0,newreference(p^.left^.location.reference)))); -{$IfDef regallocfix} - del_reference(p^.left^.location.reference); -{$EndIf regallocfix} - end; - emitlab(hlabel); - end; - LOC_FLAGS : begin - if loc=LOC_CREGISTER then - emit_flag2reg(p^.right^.location.resflags,p^.left^.location.register) - else -{$ifndef OLDASM} - begin - ai:=new(pai386,op_ref(A_Setcc,S_B,newreference(p^.left^.location.reference))); - ai^.SetCondition(flag_2_cond[p^.right^.location.resflags]); - exprasmlist^.concat(ai); - end; -{$else} - exprasmlist^.concat(new(pai386,op_ref(flag_2_set[p^.right^.location.resflags],S_B, - newreference(p^.left^.location.reference)))); -{$endif} -{$IfDef regallocfix} - del_reference(p^.left^.location.reference); -{$EndIf regallocfix} - end; - end; - freelabel(truelabel); - freelabel(falselabel); - truelabel:=otlabel; - falselabel:=oflabel; - end; - - -{***************************************************************************** - SecondFuncRet -*****************************************************************************} - - procedure secondfuncret(var p : ptree); - var - hr : tregister; - hp : preference; - pp : pprocinfo; - hr_valid : boolean; - begin - reset_reference(p^.location.reference); - hr_valid:=false; - if @procinfo<>pprocinfo(p^.funcretprocinfo) then - begin - hr:=getregister32; - hr_valid:=true; - hp:=new_reference(procinfo.framepointer, - procinfo.framepointer_offset); - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,hp,hr))); - pp:=procinfo.parent; - { walk up the stack frame } - while pp<>pprocinfo(p^.funcretprocinfo) do - begin - hp:=new_reference(hr, - pp^.framepointer_offset); - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,hp,hr))); - pp:=pp^.parent; - end; - p^.location.reference.base:=hr; - end - else - p^.location.reference.base:=procinfo.framepointer; - p^.location.reference.offset:=procinfo.retoffset; - if ret_in_param(p^.retdef) then - begin - if not hr_valid then - hr:=getregister32; - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.location.reference),hr))); - p^.location.reference.base:=hr; - p^.location.reference.offset:=0; - end; - end; - - -{***************************************************************************** - SecondArrayConstruct -*****************************************************************************} - - const - vtInteger = 0; - vtBoolean = 1; - vtChar = 2; - vtExtended = 3; - vtString = 4; - vtPointer = 5; - vtPChar = 6; - vtObject = 7; - vtClass = 8; - vtWideChar = 9; - vtPWideChar = 10; - vtAnsiString = 11; - vtCurrency = 12; - vtVariant = 13; - vtInterface = 14; - vtWideString = 15; - vtInt64 = 16; - - procedure secondarrayconstruct(var p : ptree); - var - hp : ptree; - href : treference; - lt : pdef; - vaddr : boolean; - vtype : longint; - begin - if not p^.cargs then - begin - reset_reference(p^.location.reference); - gettempofsizereference((parraydef(p^.resulttype)^.highrange+1)*8,p^.location.reference); - href:=p^.location.reference; - end; - hp:=p; - while assigned(hp) do - begin - secondpass(hp^.left); - if codegenerror then - exit; - { find the correct vtype value } - vtype:=$ff; - vaddr:=false; - lt:=hp^.left^.resulttype; - case lt^.deftype of - enumdef, - orddef : begin - if (lt^.deftype=enumdef) or - is_integer(lt) then - vtype:=vtInteger - else - if is_boolean(lt) then - vtype:=vtBoolean - else - if (lt^.deftype=orddef) and (porddef(lt)^.typ=uchar) then - vtype:=vtChar; - end; - floatdef : begin - vtype:=vtExtended; - vaddr:=true; - end; - procvardef, - pointerdef : begin - if is_pchar(lt) then - vtype:=vtPChar - else - vtype:=vtPointer; - end; - classrefdef : vtype:=vtClass; - objectdef : begin - vtype:=vtObject; - end; - stringdef : begin - if is_shortstring(lt) then - begin - vtype:=vtString; - vaddr:=true; - end - else - if is_ansistring(lt) then - vtype:=vtAnsiString; - end; - end; - if vtype=$ff then - internalerror(14357); - { write C style pushes or an pascal array } - if p^.cargs then - begin - if vaddr then - begin - emit_to_reference(hp^.left); - emit_push_lea_loc(hp^.left^.location); - end - else - emit_push_loc(hp^.left^.location); - end - else - begin - { update href to the vtype field and write it } - exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,S_L, - vtype,newreference(href)))); - inc(href.offset,4); - { write changing field update href to the next element } - if vaddr then - begin - emit_to_reference(hp^.left); - emit_lea_loc_ref(hp^.left^.location,href); - end - else - emit_mov_loc_ref(hp^.left^.location,href); - inc(href.offset,4); - end; - { load next entry } - hp:=hp^.right; - end; - end; - - -end. -{ +{ + $Id$ + Copyright (c) 1993-98 by Florian Klaempfl + + Generate i386 assembler for load/assignment nodes + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit cg386ld; +interface + + uses + tree; + + procedure secondload(var p : ptree); + procedure secondassignment(var p : ptree); + procedure secondfuncret(var p : ptree); + procedure secondarrayconstruct(var p : ptree); + + +implementation + + uses + globtype,systems, + cobjects,verbose,globals, + symtable,aasm,types, + hcodegen,temp_gen,pass_2, +{$ifndef OLDASM} + i386base,i386asm, +{$else} + i386, +{$endif} + cgai386,tgeni386,cg386cnv; + +{***************************************************************************** + SecondLoad +*****************************************************************************} + + procedure secondload(var p : ptree); + var + hregister : tregister; + symtabletype : tsymtabletype; + i : longint; + hp : preference; + s : pasmsymbol; + popeax : boolean; + + begin + simple_loadn:=true; + reset_reference(p^.location.reference); + case p^.symtableentry^.typ of + { this is only for toasm and toaddr } + absolutesym : + begin + p^.location.reference.symbol:=nil; + if (pabsolutesym(p^.symtableentry)^.abstyp=toaddr) then + begin + if pabsolutesym(p^.symtableentry)^.absseg then + p^.location.reference.segment:=R_FS; + p^.location.reference.offset:=pabsolutesym(p^.symtableentry)^.address; + end + else + p^.location.reference.symbol:=newasmsymbol(p^.symtableentry^.mangledname); +{$ifndef NEWLAB} + maybe_concat_external(p^.symtableentry^.owner,p^.symtableentry^.mangledname); +{$endif} + end; + varsym : + begin + hregister:=R_NO; + { C variable } + if (pvarsym(p^.symtableentry)^.var_options and vo_is_C_var)<>0 then + begin + p^.location.reference.symbol:=newasmsymbol(p^.symtableentry^.mangledname); +{$ifndef NEWLAB} + if (pvarsym(p^.symtableentry)^.var_options and vo_is_external)<>0 then + concat_external(p^.symtableentry^.mangledname,EXT_NEAR); +{$endif} + end + { DLL variable } + else if (pvarsym(p^.symtableentry)^.var_options and vo_is_dll_var)<>0 then + begin + hregister:=getregister32; + p^.location.reference.symbol:=newasmsymbol(p^.symtableentry^.mangledname); + exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.location.reference),hregister))); + p^.location.reference.symbol:=nil; + p^.location.reference.base:=hregister; + end + { external variable } + else if (pvarsym(p^.symtableentry)^.var_options and vo_is_external)<>0 then + begin + p^.location.reference.symbol:=newasmsymbol(p^.symtableentry^.mangledname); +{$ifndef NEWLAB} + concat_external(p^.symtableentry^.mangledname,EXT_NEAR); +{$endif} + end + { thread variable } + else if (pvarsym(p^.symtableentry)^.var_options and vo_is_thread_var)<>0 then + begin + popeax:=not(R_EAX in unused); + if popeax then + exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_EAX))); + p^.location.reference.symbol:=newasmsymbol(p^.symtableentry^.mangledname); +{$ifndef NEWLAB} + if p^.symtable^.symtabletype=unitsymtable then + concat_external(p^.symtableentry^.mangledname,EXT_NEAR); +{$endif} + exprasmlist^.concat(new(pai386,op_ref(A_PUSH,S_L,newreference(p^.location.reference)))); + { the called procedure isn't allowed to change } + { any register except EAX } + emitcall('FPC_RELOCATE_THREADVAR',true); + + reset_reference(p^.location.reference); + p^.location.reference.base:=getregister32; + emit_reg_reg(A_MOV,S_L,R_EAX,p^.location.reference.base); + if popeax then + exprasmlist^.concat(new(pai386,op_reg(A_POP,S_L,R_EAX))); + + end + { normal variable } + else + begin + symtabletype:=p^.symtable^.symtabletype; + { in case it is a register variable: } + if pvarsym(p^.symtableentry)^.reg<>R_NO then + begin + p^.location.loc:=LOC_CREGISTER; + p^.location.register:=pvarsym(p^.symtableentry)^.reg; + unused:=unused-[pvarsym(p^.symtableentry)^.reg]; + end + else + begin + { first handle local and temporary variables } + if (symtabletype in [parasymtable,inlinelocalsymtable, + inlineparasymtable,localsymtable]) then + begin + p^.location.reference.base:=procinfo.framepointer; + p^.location.reference.offset:=pvarsym(p^.symtableentry)^.address+p^.symtable^.address_fixup; + if (symtabletype in [localsymtable,inlinelocalsymtable]) then + p^.location.reference.offset:=-p^.location.reference.offset; + if (lexlevel>(p^.symtable^.symtablelevel)) then + begin + hregister:=getregister32; + + { make a reference } + hp:=new_reference(procinfo.framepointer, + procinfo.framepointer_offset); + + exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,hp,hregister))); + + simple_loadn:=false; + i:=lexlevel-1; + while i>(p^.symtable^.symtablelevel) do + begin + { make a reference } + hp:=new_reference(hregister,8); + exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,hp,hregister))); + dec(i); + end; + p^.location.reference.base:=hregister; + end; + end + else + case symtabletype of + unitsymtable,globalsymtable, + staticsymtable : + begin + p^.location.reference.symbol:=newasmsymbol(p^.symtableentry^.mangledname); +{$ifndef NEWLAB} + if symtabletype=unitsymtable then + concat_external(p^.symtableentry^.mangledname,EXT_NEAR); +{$endif} + end; + stt_exceptsymtable: + begin + p^.location.reference.base:=procinfo.framepointer; + p^.location.reference.offset:=pvarsym(p^.symtableentry)^.address; + end; + objectsymtable: + begin + if (pvarsym(p^.symtableentry)^.properties and sp_static)<>0 then + begin + p^.location.reference.symbol:=newasmsymbol(p^.symtableentry^.mangledname); +{$ifndef NEWLAB} + if p^.symtable^.defowner^.owner^.symtabletype=unitsymtable then + concat_external(p^.symtableentry^.mangledname,EXT_NEAR); +{$endif} + end + else + begin + p^.location.reference.base:=R_ESI; + p^.location.reference.offset:=pvarsym(p^.symtableentry)^.address; + end; + end; + withsymtable: + begin + { make a reference } + { symtable datasize field + contains the offset of the temp + stored } +{ hp:=new_reference(procinfo.framepointer, + p^.symtable^.datasize); + + exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,hp,hregister)));} + + if ptree(pwithsymtable(p^.symtable)^.withnode)^.islocal then + begin + p^.location.reference:=ptree(pwithsymtable(p^.symtable)^.withnode)^.withreference^; + end + else + begin + hregister:=getregister32; + p^.location.reference.base:=hregister; + exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, + newreference(ptree(pwithsymtable(p^.symtable)^.withnode)^.withreference^), + hregister))); + end; + inc(p^.location.reference.offset,pvarsym(p^.symtableentry)^.address); + end; + end; + end; + { in case call by reference, then calculate. Open array + is always an reference! } + if (pvarsym(p^.symtableentry)^.varspez=vs_var) or + is_open_array(pvarsym(p^.symtableentry)^.definition) or + is_array_of_const(pvarsym(p^.symtableentry)^.definition) or + ((pvarsym(p^.symtableentry)^.varspez=vs_const) and + push_addr_param(pvarsym(p^.symtableentry)^.definition)) then + begin + simple_loadn:=false; + if hregister=R_NO then + hregister:=getregister32; +{$ifdef OLDHIGH} + if is_open_array(pvarsym(p^.symtableentry)^.definition) or + is_open_string(pvarsym(p^.symtableentry)^.definition) then + begin + if (p^.location.reference.base=procinfo.framepointer) then + begin + highframepointer:=p^.location.reference.base; + highoffset:=p^.location.reference.offset; + end + else + begin + highframepointer:=R_EDI; + highoffset:=p^.location.reference.offset; + exprasmlist^.concat(new(pai386,op_reg_reg(A_MOV,S_L, + p^.location.reference.base,R_EDI))); + end; + end; +{$endif} + if p^.location.loc=LOC_CREGISTER then + begin + exprasmlist^.concat(new(pai386,op_reg_reg(A_MOV,S_L, + p^.location.register,hregister))); + p^.location.loc:=LOC_REFERENCE; + end + else + begin + exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, + newreference(p^.location.reference), + hregister))); + end; + reset_reference(p^.location.reference); + p^.location.reference.base:=hregister; + end; + end; + end; + procsym: + begin + if assigned(p^.left) then + begin + secondpass(p^.left); + p^.location.loc:=LOC_MEM; + gettempofsizereference(8,p^.location.reference); + + { load class instance address } + case p^.left^.location.loc of + + LOC_CREGISTER, + LOC_REGISTER: + begin + hregister:=p^.left^.location.register; + ungetregister32(p^.left^.location.register); + { such code is allowed ! + CGMessage(cg_e_illegal_expression); } + end; + + LOC_MEM, + LOC_REFERENCE: + begin + hregister:=R_EDI; + exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, + newreference(p^.left^.location.reference),R_EDI))); + del_reference(p^.left^.location.reference); + ungetiftemp(p^.left^.location.reference); + end; + else internalerror(26019); + end; + + { store the class instance address } + new(hp); + hp^:=p^.location.reference; + inc(hp^.offset,4); + exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L, + R_EDI,hp))); + + { virtual method ? } + if (pprocsym(p^.symtableentry)^.definition^.options and povirtualmethod)<>0 then + begin + new(hp); + reset_reference(hp^); + hp^.base:=hregister; + { load vmt pointer } + exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, + hp,R_EDI))); +{$IfDef regallocfix} + del_reference(hp^); +{$EndIf regallocfix} + { load method address } + new(hp); + reset_reference(hp^); + hp^.base:=R_EDI; + hp^.offset:=pprocsym(p^.symtableentry)^.definition^.extnumber*4+12; + exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, + hp,R_EDI))); + { ... and store it } + exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L, + R_EDI,newreference(p^.location.reference)))); + end + else + begin + s:=newasmsymbol(pprocsym(p^.symtableentry)^.definition^.mangledname); + exprasmlist^.concat(new(pai386,op_sym_ofs_ref(A_MOV,S_L,s,0, + newreference(p^.location.reference)))); +{$ifndef NEWLAB} + maybe_concat_external(p^.symtable,p^.symtableentry^.mangledname); +{$endif} + end; + end + else + begin + {!!!!! Be aware, work on virtual methods too } + p^.location.reference.symbol:=newasmsymbol(pprocsym(p^.symtableentry)^.definition^.mangledname); +{$ifndef NEWLAB} + maybe_concat_external(p^.symtable,p^.symtableentry^.mangledname); +{$endif} + end; + end; + typedconstsym : + begin + p^.location.reference.symbol:=newasmsymbol(p^.symtableentry^.mangledname); +{$ifndef NEWLAB} + maybe_concat_external(p^.symtable,p^.symtableentry^.mangledname); +{$endif} + end; + else internalerror(4); + end; + end; + + +{***************************************************************************** + SecondAssignment +*****************************************************************************} + + procedure secondassignment(var p : ptree); + var + opsize : topsize; + otlabel,hlabel,oflabel : plabel; + hregister : tregister; + loc : tloc; + r : preference; +{$ifndef OLDASM} + ai : pai386; +{$endif} + begin + otlabel:=truelabel; + oflabel:=falselabel; + getlabel(truelabel); + getlabel(falselabel); + { calculate left sides } + if not(p^.concat_string) then + secondpass(p^.left); + + if codegenerror then + exit; + + case p^.left^.location.loc of + LOC_REFERENCE : begin + { in case left operator uses to register } + { but to few are free then LEA } + if (p^.left^.location.reference.base<>R_NO) and + (p^.left^.location.reference.index<>R_NO) and + (usablereg32objectdef) or + not(pobjectdef(p^.right^.resulttype)^.isclass)) then + begin + { this would be a problem } + if not(p^.left^.resulttype^.needs_inittable) then + internalerror(3457); + + { increment source reference counter } + new(r); + reset_reference(r^); + r^.symbol:=newasmsymbol(lab2str(p^.right^.resulttype^.get_inittable_label)); + emitpushreferenceaddr(exprasmlist,r^); + + emitpushreferenceaddr(exprasmlist,p^.right^.location.reference); + exprasmlist^.concat(new(pai386, + op_sym(A_CALL,S_NO,newasmsymbol('FPC_ADDREF')))); +{$ifndef NEWLAB} + if not (cs_compilesystem in aktmoduleswitches) then + concat_external('FPC_ADDREF',EXT_NEAR); +{$endif} + { decrement destination reference counter } + new(r); + reset_reference(r^); + r^.symbol:=newasmsymbol(lab2str(p^.left^.resulttype^.get_inittable_label)); + emitpushreferenceaddr(exprasmlist,r^); + + emitpushreferenceaddr(exprasmlist,p^.left^.location.reference); + exprasmlist^.concat(new(pai386, + op_sym(A_CALL,S_NO,newasmsymbol('FPC_DECREF')))); +{$ifndef NEWLAB} + if not(cs_compilesystem in aktmoduleswitches) then + concat_external('FPC_DECREF',EXT_NEAR); +{$endif} + end; + +{$ifdef regallocfix} + concatcopy(p^.right^.location.reference, + p^.left^.location.reference,p^.left^.resulttype^.size,true,false); + ungetiftemp(p^.right^.location.reference); +{$Else regallocfix} + concatcopy(p^.right^.location.reference, + p^.left^.location.reference,p^.left^.resulttype^.size,false,false); + ungetiftemp(p^.right^.location.reference); +{$endif regallocfix} + end; + end; +{$ifdef SUPPORT_MMX} + LOC_CMMXREGISTER, + LOC_MMXREGISTER: + begin + if loc=LOC_CMMXREGISTER then + exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVQ,S_NO, + p^.right^.location.register,p^.left^.location.register))) + else + exprasmlist^.concat(new(pai386,op_reg_ref(A_MOVQ,S_NO, + p^.right^.location.register,newreference(p^.left^.location.reference)))); + end; +{$endif SUPPORT_MMX} + LOC_REGISTER, + LOC_CREGISTER : begin + case p^.right^.resulttype^.size of + 1 : opsize:=S_B; + 2 : opsize:=S_W; + 4 : opsize:=S_L; + 8 : opsize:=S_L; + end; + { simplified with op_reg_loc } + if loc=LOC_CREGISTER then + begin + exprasmlist^.concat(new(pai386,op_reg_reg(A_MOV,opsize, + p^.right^.location.register, + p^.left^.location.register))); +{$IfDef regallocfix} + ungetregister(p^.right^.location.register); +{$EndIf regallocfix} + end + else + Begin + exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,opsize, + p^.right^.location.register, + newreference(p^.left^.location.reference)))); +{$IfDef regallocfix} + ungetregister(p^.right^.location.register); + del_reference(p^.left^.location.reference); +{$EndIf regallocfix} + end; + if is_64bitint(p^.right^.resulttype) then + begin + { simplified with op_reg_loc } + if loc=LOC_CREGISTER then + exprasmlist^.concat(new(pai386,op_reg_reg(A_MOV,opsize, + p^.right^.location.registerhigh, + p^.left^.location.registerhigh))) + else + begin + r:=newreference(p^.left^.location.reference); + inc(r^.offset,4); + exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,opsize, + p^.right^.location.registerhigh,r))); + end; + end; + {exprasmlist^.concat(new(pai386,op_reg_loc(A_MOV,opsize, + p^.right^.location.register, + p^.left^.location))); } + + end; + LOC_FPU : begin + if loc<>LOC_REFERENCE then + internalerror(10010) + else + floatstore(pfloatdef(p^.left^.resulttype)^.typ, + p^.left^.location.reference); + end; + LOC_JUMP : begin + getlabel(hlabel); + emitlab(truelabel); + if loc=LOC_CREGISTER then + exprasmlist^.concat(new(pai386,op_const_reg(A_MOV,S_B, + 1,p^.left^.location.register))) + else + exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,S_B, + 1,newreference(p^.left^.location.reference)))); + {exprasmlist^.concat(new(pai386,op_const_loc(A_MOV,S_B, + 1,p^.left^.location)));} + emitjmp(C_None,hlabel); + emitlab(falselabel); + if loc=LOC_CREGISTER then + exprasmlist^.concat(new(pai386,op_reg_reg(A_XOR,S_B, + p^.left^.location.register, + p^.left^.location.register))) + else + begin + exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,S_B, + 0,newreference(p^.left^.location.reference)))); +{$IfDef regallocfix} + del_reference(p^.left^.location.reference); +{$EndIf regallocfix} + end; + emitlab(hlabel); + end; + LOC_FLAGS : begin + if loc=LOC_CREGISTER then + emit_flag2reg(p^.right^.location.resflags,p^.left^.location.register) + else +{$ifndef OLDASM} + begin + ai:=new(pai386,op_ref(A_Setcc,S_B,newreference(p^.left^.location.reference))); + ai^.SetCondition(flag_2_cond[p^.right^.location.resflags]); + exprasmlist^.concat(ai); + end; +{$else} + exprasmlist^.concat(new(pai386,op_ref(flag_2_set[p^.right^.location.resflags],S_B, + newreference(p^.left^.location.reference)))); +{$endif} +{$IfDef regallocfix} + del_reference(p^.left^.location.reference); +{$EndIf regallocfix} + end; + end; + freelabel(truelabel); + freelabel(falselabel); + truelabel:=otlabel; + falselabel:=oflabel; + end; + + +{***************************************************************************** + SecondFuncRet +*****************************************************************************} + + procedure secondfuncret(var p : ptree); + var + hr : tregister; + hp : preference; + pp : pprocinfo; + hr_valid : boolean; + begin + reset_reference(p^.location.reference); + hr_valid:=false; + if @procinfo<>pprocinfo(p^.funcretprocinfo) then + begin + hr:=getregister32; + hr_valid:=true; + hp:=new_reference(procinfo.framepointer, + procinfo.framepointer_offset); + exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,hp,hr))); + pp:=procinfo.parent; + { walk up the stack frame } + while pp<>pprocinfo(p^.funcretprocinfo) do + begin + hp:=new_reference(hr, + pp^.framepointer_offset); + exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,hp,hr))); + pp:=pp^.parent; + end; + p^.location.reference.base:=hr; + end + else + p^.location.reference.base:=procinfo.framepointer; + p^.location.reference.offset:=procinfo.retoffset; + if ret_in_param(p^.retdef) then + begin + if not hr_valid then + hr:=getregister32; + exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.location.reference),hr))); + p^.location.reference.base:=hr; + p^.location.reference.offset:=0; + end; + end; + + +{***************************************************************************** + SecondArrayConstruct +*****************************************************************************} + + const + vtInteger = 0; + vtBoolean = 1; + vtChar = 2; + vtExtended = 3; + vtString = 4; + vtPointer = 5; + vtPChar = 6; + vtObject = 7; + vtClass = 8; + vtWideChar = 9; + vtPWideChar = 10; + vtAnsiString = 11; + vtCurrency = 12; + vtVariant = 13; + vtInterface = 14; + vtWideString = 15; + vtInt64 = 16; + + procedure secondarrayconstruct(var p : ptree); + var + hp : ptree; + href : treference; + lt : pdef; + vaddr : boolean; + vtype : longint; + begin + if not p^.cargs then + begin + reset_reference(p^.location.reference); + if parraydef(p^.resulttype)^.highrange=-1 then + begin + end + else + gettempofsizereference((parraydef(p^.resulttype)^.highrange+1)*8,p^.location.reference); + href:=p^.location.reference; + end; + hp:=p; + while assigned(hp) do + begin + secondpass(hp^.left); + if codegenerror then + exit; + { find the correct vtype value } + vtype:=$ff; + vaddr:=false; + lt:=hp^.left^.resulttype; + case lt^.deftype of + enumdef, + orddef : begin + if (lt^.deftype=enumdef) or + is_integer(lt) then + vtype:=vtInteger + else + if is_boolean(lt) then + vtype:=vtBoolean + else + if (lt^.deftype=orddef) and (porddef(lt)^.typ=uchar) then + vtype:=vtChar; + end; + floatdef : begin + vtype:=vtExtended; + vaddr:=true; + end; + procvardef, + pointerdef : begin + if is_pchar(lt) then + vtype:=vtPChar + else + vtype:=vtPointer; + end; + classrefdef : vtype:=vtClass; + objectdef : begin + vtype:=vtObject; + end; + stringdef : begin + if is_shortstring(lt) then + begin + vtype:=vtString; + vaddr:=true; + end + else + if is_ansistring(lt) then + vtype:=vtAnsiString; + end; + end; + if vtype=$ff then + internalerror(14357); + { write C style pushes or an pascal array } + if p^.cargs then + begin + if vaddr then + begin + emit_to_reference(hp^.left); + emit_push_lea_loc(hp^.left^.location); + end + else + emit_push_loc(hp^.left^.location); + end + else + begin + { update href to the vtype field and write it } + exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,S_L, + vtype,newreference(href)))); + inc(href.offset,4); + { write changing field update href to the next element } + if vaddr then + begin + emit_to_reference(hp^.left); + emit_lea_loc_ref(hp^.left^.location,href); + end + else + emit_mov_loc_ref(hp^.left^.location,href); + inc(href.offset,4); + end; + { load next entry } + hp:=hp^.right; + end; + end; + + +end. +{ $Log$ - Revision 1.57 1999-05-21 13:54:51 peter + Revision 1.58 1999-05-23 18:42:02 florian + * better error recovering in typed constants + * some problems with arrays of const fixed, some problems + due my previous + - the location type of array constructor is now LOC_MEM + - the pushing of high fixed + - parameter copying fixed + - zero temp. allocation removed + * small problem in the assembler writers fixed: + ref to nil wasn't written correctly + + Revision 1.57 1999/05/21 13:54:51 peter * NEWLAB for label as symbol - - Revision 1.56 1999/05/17 23:51:38 peter - * with temp vars now use a reference with a persistant temp instead - of setting datasize - - Revision 1.55 1999/05/17 21:57:04 florian - * new temporary ansistring handling - - Revision 1.54 1999/05/12 00:19:43 peter - * removed R_DEFAULT_SEG - * uniform float names - - Revision 1.53 1999/05/06 09:05:16 peter - * generic write_float and str_float - * fixed constant float conversions - - Revision 1.52 1999/05/01 13:24:10 peter - * merged nasm compiler - * old asm moved to oldasm/ - - Revision 1.51 1999/04/28 06:01:55 florian - * changes of Bruessel: - + message handler can now take an explicit self - * typinfo fixed: sometimes the type names weren't written - * the type checking for pointer comparisations and subtraction - and are now more strict (was also buggy) - * small bug fix to link.pas to support compiling on another - drive - * probable bug in popt386 fixed: call/jmp => push/jmp - transformation didn't count correctly the jmp references - + threadvar support - * warning if ln/sqrt gets an invalid constant argument - - Revision 1.50 1999/04/16 13:42:26 jonas - * more regalloc fixes (still not complete) - - Revision 1.49 1999/04/13 18:57:48 florian - * classes which contain ansistring get unnecessary calls - to addref/decref when they are assigned, fixed - - Revision 1.48 1999/04/09 15:48:47 jonas - * added fix for missing register deallocation (-dregallocfix) - - Revision 1.47 1999/03/31 13:55:07 peter - * assembler inlining working for ag386bin - - Revision 1.46 1999/03/24 23:16:52 peter - * fixed bugs 212,222,225,227,229,231,233 - - Revision 1.45 1999/02/25 21:02:28 peter - * ag386bin updates - + coff writer - - Revision 1.44 1999/02/22 02:15:12 peter - * updates for ag386bin - - Revision 1.43 1999/01/27 00:13:54 florian - * "procedure of object"-stuff fixed - - Revision 1.42 1999/01/21 22:10:40 peter - * fixed array of const - * generic platform independent high() support - - Revision 1.41 1999/01/20 10:20:18 peter - * don't make localvar copies for assembler procedures - - Revision 1.40 1998/12/30 13:41:07 peter - * released valuepara - - Revision 1.39 1998/12/19 00:23:45 florian - * ansistring memory leaks fixed - - Revision 1.38 1998/12/11 00:02:51 peter - + globtype,tokens,version unit splitted from globals - - Revision 1.37 1998/12/10 09:47:17 florian - + basic operations with int64/qord (compiler with -dint64) - + rtti of enumerations extended: names are now written - - Revision 1.36 1998/12/04 10:18:06 florian - * some stuff for procedures of object added - * bug with overridden virtual constructors fixed (reported by Italo Gomes) - - Revision 1.35 1998/11/30 09:43:04 pierre - * some range check bugs fixed (still not working !) - + added DLL writing support for win32 (also accepts variables) - + TempAnsi for code that could be used for Temporary ansi strings - handling - - Revision 1.34 1998/11/28 16:20:48 peter - + support for dll variables - - Revision 1.33 1998/11/27 14:50:33 peter - + open strings, $P switch support - - Revision 1.32 1998/11/26 09:53:36 florian - * for classes no init/final. code is necessary, fixed - - Revision 1.31 1998/11/20 15:35:54 florian - * problems with rtti fixed, hope it works - - Revision 1.30 1998/11/18 17:45:24 peter - * fixes for VALUEPARA - - Revision 1.29 1998/11/18 15:44:11 peter - * VALUEPARA for tp7 compatible value parameters - - Revision 1.28 1998/11/17 11:32:44 peter - * optimize str:='' in H+ mode - + -! to test ansistrings - - Revision 1.27 1998/11/16 15:35:39 peter - * rename laod/copystring -> load/copyshortstring - * fixed int-bool cnv bug - + char-ansistring conversion - - Revision 1.26 1998/11/10 10:09:10 peter - * va_list -> array of const - - Revision 1.25 1998/11/05 12:02:35 peter - * released useansistring - * removed -Sv, its now available in fpc modes - - Revision 1.24 1998/10/14 08:47:14 pierre - * bugs in secondfuncret for result in subprocedures removed - - Revision 1.23 1998/10/06 17:16:44 pierre - * some memory leaks fixed (thanks to Peter for heaptrc !) - - Revision 1.22 1998/10/01 09:22:53 peter - * fixed value openarray - * ungettemp of arrayconstruct - - Revision 1.21 1998/09/28 11:07:39 peter - + floatdef support for array of const - - Revision 1.20 1998/09/24 14:26:03 peter - * updated for new tvarrec - - Revision 1.19 1998/09/23 17:49:59 peter - * high(arrayconstructor) is now correct - * procvardef support for variant record - - Revision 1.18 1998/09/23 09:58:48 peter - * first working array of const things - - Revision 1.17 1998/09/20 18:00:19 florian - * small compiling problems fixed - - Revision 1.16 1998/09/20 17:46:48 florian - * some things regarding ansistrings fixed - - Revision 1.15 1998/09/17 09:42:16 peter - + pass_2 for cg386 - * Message() -> CGMessage() for pass_1/pass_2 - - Revision 1.14 1998/09/14 10:43:50 peter - * all internal RTL functions start with FPC_ - - Revision 1.13 1998/09/04 12:24:24 florian - * bug0159 fixed - - Revision 1.12 1998/09/04 11:55:17 florian - * problem with -Or fixed - - Revision 1.11 1998/09/03 16:03:14 florian - + rtti generation - * init table generation changed - - Revision 1.10 1998/08/21 14:08:40 pierre - + TEST_FUNCRET now default (old code removed) - works also for m68k (at least compiles) - - Revision 1.9 1998/08/20 09:26:37 pierre - + funcret setting in underproc testing - compile with _dTEST_FUNCRET - - Revision 1.8 1998/08/10 14:49:48 peter - + localswitches, moduleswitches, globalswitches splitting - - Revision 1.7 1998/07/30 13:30:33 florian - * final implemenation of exception support, maybe it needs - some fixes :) - - Revision 1.6 1998/07/26 21:58:57 florian - + better support for switch $H - + index access to ansi strings added - + assigment of data (records/arrays) containing ansi strings - - Revision 1.5 1998/07/24 22:16:54 florian - * internal error 10 together with array access fixed. I hope - that's the final fix. - - Revision 1.4 1998/06/11 13:58:45 peter - * fixed too long line - - Revision 1.3 1998/06/09 16:01:35 pierre - + added procedure directive parsing for procvars - (accepted are popstack cdecl and pascal) - + added C vars with the following syntax - var C calias 'true_c_name';(can be followed by external) - reason is that you must add the Cprefix - - which is target dependent - - Revision 1.2 1998/06/08 13:13:34 pierre - + temporary variables now in temp_gen.pas unit - because it is processor independent - * mppc68k.bat modified to undefine i386 and support_mmx - (which are defaults for i386) - - Revision 1.1 1998/06/05 17:44:12 peter - * splitted cgi386 - -} - + + Revision 1.56 1999/05/17 23:51:38 peter + * with temp vars now use a reference with a persistant temp instead + of setting datasize + + Revision 1.55 1999/05/17 21:57:04 florian + * new temporary ansistring handling + + Revision 1.54 1999/05/12 00:19:43 peter + * removed R_DEFAULT_SEG + * uniform float names + + Revision 1.53 1999/05/06 09:05:16 peter + * generic write_float and str_float + * fixed constant float conversions + + Revision 1.52 1999/05/01 13:24:10 peter + * merged nasm compiler + * old asm moved to oldasm/ + + Revision 1.51 1999/04/28 06:01:55 florian + * changes of Bruessel: + + message handler can now take an explicit self + * typinfo fixed: sometimes the type names weren't written + * the type checking for pointer comparisations and subtraction + and are now more strict (was also buggy) + * small bug fix to link.pas to support compiling on another + drive + * probable bug in popt386 fixed: call/jmp => push/jmp + transformation didn't count correctly the jmp references + + threadvar support + * warning if ln/sqrt gets an invalid constant argument + + Revision 1.50 1999/04/16 13:42:26 jonas + * more regalloc fixes (still not complete) + + Revision 1.49 1999/04/13 18:57:48 florian + * classes which contain ansistring get unnecessary calls + to addref/decref when they are assigned, fixed + + Revision 1.48 1999/04/09 15:48:47 jonas + * added fix for missing register deallocation (-dregallocfix) + + Revision 1.47 1999/03/31 13:55:07 peter + * assembler inlining working for ag386bin + + Revision 1.46 1999/03/24 23:16:52 peter + * fixed bugs 212,222,225,227,229,231,233 + + Revision 1.45 1999/02/25 21:02:28 peter + * ag386bin updates + + coff writer + + Revision 1.44 1999/02/22 02:15:12 peter + * updates for ag386bin + + Revision 1.43 1999/01/27 00:13:54 florian + * "procedure of object"-stuff fixed + + Revision 1.42 1999/01/21 22:10:40 peter + * fixed array of const + * generic platform independent high() support + + Revision 1.41 1999/01/20 10:20:18 peter + * don't make localvar copies for assembler procedures + + Revision 1.40 1998/12/30 13:41:07 peter + * released valuepara + + Revision 1.39 1998/12/19 00:23:45 florian + * ansistring memory leaks fixed + + Revision 1.38 1998/12/11 00:02:51 peter + + globtype,tokens,version unit splitted from globals + + Revision 1.37 1998/12/10 09:47:17 florian + + basic operations with int64/qord (compiler with -dint64) + + rtti of enumerations extended: names are now written + + Revision 1.36 1998/12/04 10:18:06 florian + * some stuff for procedures of object added + * bug with overridden virtual constructors fixed (reported by Italo Gomes) + + Revision 1.35 1998/11/30 09:43:04 pierre + * some range check bugs fixed (still not working !) + + added DLL writing support for win32 (also accepts variables) + + TempAnsi for code that could be used for Temporary ansi strings + handling + + Revision 1.34 1998/11/28 16:20:48 peter + + support for dll variables + + Revision 1.33 1998/11/27 14:50:33 peter + + open strings, $P switch support + + Revision 1.32 1998/11/26 09:53:36 florian + * for classes no init/final. code is necessary, fixed + + Revision 1.31 1998/11/20 15:35:54 florian + * problems with rtti fixed, hope it works + + Revision 1.30 1998/11/18 17:45:24 peter + * fixes for VALUEPARA + + Revision 1.29 1998/11/18 15:44:11 peter + * VALUEPARA for tp7 compatible value parameters + + Revision 1.28 1998/11/17 11:32:44 peter + * optimize str:='' in H+ mode + + -! to test ansistrings + + Revision 1.27 1998/11/16 15:35:39 peter + * rename laod/copystring -> load/copyshortstring + * fixed int-bool cnv bug + + char-ansistring conversion + + Revision 1.26 1998/11/10 10:09:10 peter + * va_list -> array of const + + Revision 1.25 1998/11/05 12:02:35 peter + * released useansistring + * removed -Sv, its now available in fpc modes + + Revision 1.24 1998/10/14 08:47:14 pierre + * bugs in secondfuncret for result in subprocedures removed + + Revision 1.23 1998/10/06 17:16:44 pierre + * some memory leaks fixed (thanks to Peter for heaptrc !) + + Revision 1.22 1998/10/01 09:22:53 peter + * fixed value openarray + * ungettemp of arrayconstruct + + Revision 1.21 1998/09/28 11:07:39 peter + + floatdef support for array of const + + Revision 1.20 1998/09/24 14:26:03 peter + * updated for new tvarrec + + Revision 1.19 1998/09/23 17:49:59 peter + * high(arrayconstructor) is now correct + * procvardef support for variant record + + Revision 1.18 1998/09/23 09:58:48 peter + * first working array of const things + + Revision 1.17 1998/09/20 18:00:19 florian + * small compiling problems fixed + + Revision 1.16 1998/09/20 17:46:48 florian + * some things regarding ansistrings fixed + + Revision 1.15 1998/09/17 09:42:16 peter + + pass_2 for cg386 + * Message() -> CGMessage() for pass_1/pass_2 + + Revision 1.14 1998/09/14 10:43:50 peter + * all internal RTL functions start with FPC_ + + Revision 1.13 1998/09/04 12:24:24 florian + * bug0159 fixed + + Revision 1.12 1998/09/04 11:55:17 florian + * problem with -Or fixed + + Revision 1.11 1998/09/03 16:03:14 florian + + rtti generation + * init table generation changed + + Revision 1.10 1998/08/21 14:08:40 pierre + + TEST_FUNCRET now default (old code removed) + works also for m68k (at least compiles) + + Revision 1.9 1998/08/20 09:26:37 pierre + + funcret setting in underproc testing + compile with _dTEST_FUNCRET + + Revision 1.8 1998/08/10 14:49:48 peter + + localswitches, moduleswitches, globalswitches splitting + + Revision 1.7 1998/07/30 13:30:33 florian + * final implemenation of exception support, maybe it needs + some fixes :) + + Revision 1.6 1998/07/26 21:58:57 florian + + better support for switch $H + + index access to ansi strings added + + assigment of data (records/arrays) containing ansi strings + + Revision 1.5 1998/07/24 22:16:54 florian + * internal error 10 together with array access fixed. I hope + that's the final fix. + + Revision 1.4 1998/06/11 13:58:45 peter + * fixed too long line + + Revision 1.3 1998/06/09 16:01:35 pierre + + added procedure directive parsing for procvars + (accepted are popstack cdecl and pascal) + + added C vars with the following syntax + var C calias 'true_c_name';(can be followed by external) + reason is that you must add the Cprefix + + which is target dependent + + Revision 1.2 1998/06/08 13:13:34 pierre + + temporary variables now in temp_gen.pas unit + because it is processor independent + * mppc68k.bat modified to undefine i386 and support_mmx + (which are defaults for i386) + + Revision 1.1 1998/06/05 17:44:12 peter + * splitted cgi386 + +} + diff --git a/compiler/cg386mem.pas b/compiler/cg386mem.pas index b8160e2261..766078fe85 100644 --- a/compiler/cg386mem.pas +++ b/compiler/cg386mem.pas @@ -1,1015 +1,1027 @@ -{ - $Id$ - Copyright (c) 1993-98 by Florian Klaempfl - - Generate i386 assembler for in memory related nodes - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - - **************************************************************************** -} -unit cg386mem; -interface - - uses - tree; - - procedure secondloadvmt(var p : ptree); - procedure secondhnewn(var p : ptree); - procedure secondnewn(var p : ptree); - procedure secondhdisposen(var p : ptree); - procedure secondsimplenewdispose(var p : ptree); - procedure secondaddr(var p : ptree); - procedure seconddoubleaddr(var p : ptree); - procedure secondderef(var p : ptree); - procedure secondsubscriptn(var p : ptree); - procedure secondvecn(var p : ptree); - procedure secondselfn(var p : ptree); - procedure secondwith(var p : ptree); - - -implementation - - uses - globtype,systems, - cobjects,verbose,globals, - symtable,aasm,types, - hcodegen,temp_gen,pass_2,pass_1, -{$ifndef OLDASM} - i386base,i386asm, -{$else} - i386, -{$endif} - cgai386,tgeni386; - -{***************************************************************************** - SecondLoadVMT -*****************************************************************************} - - procedure secondloadvmt(var p : ptree); - begin - p^.location.register:=getregister32; - exprasmlist^.concat(new(pai386,op_sym_ofs_reg(A_MOV, - S_L,newasmsymbol(pobjectdef(pclassrefdef(p^.resulttype)^.definition)^.vmt_mangledname),0, - p^.location.register))); -{$ifndef NEWLAB} - maybe_concat_external(pobjectdef(pclassrefdef(p^.resulttype)^.definition)^.owner, - pobjectdef(pclassrefdef(p^.resulttype)^.definition)^.vmt_mangledname); -{$endif} - end; - - -{***************************************************************************** - SecondHNewN -*****************************************************************************} - - procedure secondhnewn(var p : ptree); - begin - end; - - -{***************************************************************************** - SecondNewN -*****************************************************************************} - - procedure secondnewn(var p : ptree); - var - pushed : tpushed; - r : preference; - begin - if assigned(p^.left) then - begin - secondpass(p^.left); - p^.location.register:=p^.left^.location.register; - end - else - begin - pushusedregisters(exprasmlist,pushed,$ff); - - { code copied from simplenewdispose PM } - { determines the size of the mem block } - push_int(ppointerdef(p^.resulttype)^.definition^.size); - - gettempofsizereference(target_os.size_of_pointer,p^.location.reference); - emitpushreferenceaddr(exprasmlist,p^.location.reference); - - emitcall('FPC_GETMEM',true); - if ppointerdef(p^.resulttype)^.definition^.needs_inittable then - begin - new(r); - reset_reference(r^); - r^.symbol:=newasmsymbol(lab2str(ppointerdef(p^.left^.resulttype)^.definition^.get_inittable_label)); - emitpushreferenceaddr(exprasmlist,r^); - { push pointer adress } - emitpushreferenceaddr(exprasmlist,p^.location.reference); - dispose(r); - emitcall('FPC_INITIALIZE',true); - end; - popusedregisters(exprasmlist,pushed); - { may be load ESI } - maybe_loadesi; - end; - if codegenerror then - exit; - end; - - -{***************************************************************************** - SecondDisposeN -*****************************************************************************} - - procedure secondhdisposen(var p : ptree); - begin - secondpass(p^.left); - if codegenerror then - exit; - reset_reference(p^.location.reference); - case p^.left^.location.loc of - LOC_REGISTER, - LOC_CREGISTER: - begin - p^.location.reference.index:=getregister32; - exprasmlist^.concat(new(pai386,op_reg_reg(A_MOV,S_L, - p^.left^.location.register, - p^.location.reference.index))); - end; - LOC_MEM,LOC_REFERENCE : - begin - del_reference(p^.left^.location.reference); - p^.location.reference.index:=getregister32; - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.left^.location.reference), - p^.location.reference.index))); - end; - end; - end; - - -{***************************************************************************** - SecondNewDispose -*****************************************************************************} - - procedure secondsimplenewdispose(var p : ptree); - - var - pushed : tpushed; - r : preference; - - begin - secondpass(p^.left); - if codegenerror then - exit; - - pushusedregisters(exprasmlist,pushed,$ff); - { determines the size of the mem block } - push_int(ppointerdef(p^.left^.resulttype)^.definition^.size); - - { push pointer adress } - case p^.left^.location.loc of - LOC_CREGISTER : exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L, - p^.left^.location.register))); - LOC_REFERENCE: - emitpushreferenceaddr(exprasmlist,p^.left^.location.reference); - end; - - { call the mem handling procedures } - case p^.treetype of - simpledisposen: - begin - if ppointerdef(p^.left^.resulttype)^.definition^.needs_inittable then - begin - new(r); - reset_reference(r^); - r^.symbol:=newasmsymbol(lab2str(ppointerdef(p^.left^.resulttype)^.definition^.get_inittable_label)); - emitpushreferenceaddr(exprasmlist,r^); - { push pointer adress } - case p^.left^.location.loc of - LOC_CREGISTER : exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L, - p^.left^.location.register))); - LOC_REFERENCE: - emitpushreferenceaddr(exprasmlist,p^.left^.location.reference); - end; - dispose(r); - emitcall('FPC_FINALIZE',true); - end; - emitcall('FPC_FREEMEM',true); - end; - simplenewn: - begin - emitcall('FPC_GETMEM',true); - if ppointerdef(p^.left^.resulttype)^.definition^.needs_inittable then - begin - new(r); - reset_reference(r^); - r^.symbol:=newasmsymbol(lab2str(ppointerdef(p^.left^.resulttype)^.definition^.get_inittable_label)); - emitpushreferenceaddr(exprasmlist,r^); - { push pointer adress } - case p^.left^.location.loc of - LOC_CREGISTER : exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L, - p^.left^.location.register))); - LOC_REFERENCE: - emitpushreferenceaddr(exprasmlist,p^.left^.location.reference); - end; - dispose(r); - emitcall('FPC_INITIALIZE',true); - end; - end; - end; - popusedregisters(exprasmlist,pushed); - { may be load ESI } - maybe_loadesi; - end; - - -{***************************************************************************** - SecondAddr -*****************************************************************************} - - procedure secondaddr(var p : ptree); - begin - secondpass(p^.left); - p^.location.loc:=LOC_REGISTER; - del_reference(p^.left^.location.reference); - p^.location.register:=getregister32; - {@ on a procvar means returning an address to the procedure that - is stored in it.} - { yes but p^.left^.symtableentry can be nil - for example on @self !! } - { symtableentry can be also invalid, if left is no tree node } - if (m_tp_procvar in aktmodeswitches) and - (p^.left^.treetype=loadn) and - assigned(p^.left^.symtableentry) and - (p^.left^.symtableentry^.typ=varsym) and - (pvarsym(p^.left^.symtableentry)^.definition^.deftype=procvardef) then - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, - newreference(p^.left^.location.reference), - p^.location.register))) - else - exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L, - newreference(p^.left^.location.reference), - p^.location.register))); - { for use of other segments } - if p^.left^.location.reference.segment<>R_NO then - p^.location.segment:=p^.left^.location.reference.segment; - end; - - -{***************************************************************************** - SecondDoubleAddr -*****************************************************************************} - - procedure seconddoubleaddr(var p : ptree); - begin - secondpass(p^.left); - p^.location.loc:=LOC_REGISTER; - del_reference(p^.left^.location.reference); - p^.location.register:=getregister32; - exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L, - newreference(p^.left^.location.reference), - p^.location.register))); - end; - - -{***************************************************************************** - SecondDeRef -*****************************************************************************} - - procedure secondderef(var p : ptree); - var - hr : tregister; - begin - secondpass(p^.left); - reset_reference(p^.location.reference); - case p^.left^.location.loc of - LOC_REGISTER: - p^.location.reference.base:=p^.left^.location.register; - LOC_CREGISTER: - begin - { ... and reserve one for the pointer } - hr:=getregister32; - emit_reg_reg(A_MOV,S_L,p^.left^.location.register,hr); - p^.location.reference.base:=hr; - end; - else - begin - { free register } - del_reference(p^.left^.location.reference); - - { ...and reserve one for the pointer } - hr:=getregister32; - exprasmlist^.concat(new(pai386,op_ref_reg( - A_MOV,S_L,newreference(p^.left^.location.reference), - hr))); - p^.location.reference.base:=hr; - end; - end; - if ppointerdef(p^.left^.resulttype)^.is_far then - p^.location.reference.segment:=R_FS; - if not ppointerdef(p^.left^.resulttype)^.is_far and - (cs_gdb_heaptrc in aktglobalswitches) and - (cs_checkpointer in aktglobalswitches) then - begin - exprasmlist^.concat(new(pai386,op_reg( - A_PUSH,S_L,p^.location.reference.base))); - emitcall('FPC_CHECKPOINTER',true); - end; - end; - - -{***************************************************************************** - SecondSubScriptN -*****************************************************************************} - - procedure secondsubscriptn(var p : ptree); - var - hr : tregister; - begin - secondpass(p^.left); - if codegenerror then - exit; - { classes must be dereferenced implicit } - if (p^.left^.resulttype^.deftype=objectdef) and - pobjectdef(p^.left^.resulttype)^.isclass then - begin - reset_reference(p^.location.reference); - case p^.left^.location.loc of - LOC_REGISTER: - p^.location.reference.base:=p^.left^.location.register; - LOC_CREGISTER: - begin - { ... and reserve one for the pointer } - hr:=getregister32; - emit_reg_reg(A_MOV,S_L,p^.left^.location.register,hr); - p^.location.reference.base:=hr; - end; - else - begin - { free register } - del_reference(p^.left^.location.reference); - - { ... and reserve one for the pointer } - hr:=getregister32; - exprasmlist^.concat(new(pai386,op_ref_reg( - A_MOV,S_L,newreference(p^.left^.location.reference), - hr))); - p^.location.reference.base:=hr; - end; - end; - end - else - set_location(p^.location,p^.left^.location); - - inc(p^.location.reference.offset,p^.vs^.address); - end; - - -{***************************************************************************** - SecondVecN -*****************************************************************************} - - procedure secondvecn(var p : ptree); - var - is_pushed : boolean; - ind,hr : tregister; - _p : ptree; - - function get_mul_size:longint; - begin - if p^.memindex then - get_mul_size:=1 - else - get_mul_size:=p^.resulttype^.size; - end; - - procedure calc_emit_mul; - var - l1,l2 : longint; - begin - l1:=get_mul_size; - case l1 of - 1,2,4,8 : p^.location.reference.scalefactor:=l1; - else - begin - if ispowerof2(l1,l2) then - exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L,l2,ind))) - else - exprasmlist^.concat(new(pai386,op_const_reg(A_IMUL,S_L,l1,ind))); - end; - end; - end; - - var - extraoffset : longint; - { rl stores the resulttype of the left node, this is necessary } - { to detect if it is an ansistring } - { because in constant nodes which constant index } - { the left tree is removed } - rl : pdef; - t : ptree; - hp : preference; - href : treference; - tai : Pai386; - pushed : tpushed; - hightree : ptree; - - begin - secondpass(p^.left); - rl:=p^.left^.resulttype; - { we load the array reference to p^.location } - - { an ansistring needs to be dereferenced } - if is_ansistring(p^.left^.resulttype) or - is_widestring(p^.left^.resulttype) then - begin - reset_reference(p^.location.reference); - if p^.callunique then - begin - if p^.left^.location.loc<>LOC_REFERENCE then - begin - CGMessage(cg_e_illegal_expression); - exit; - end; - pushusedregisters(exprasmlist,pushed,$ff); - emitpushreferenceaddr(exprasmlist,p^.left^.location.reference); - if is_ansistring(p^.left^.resulttype) then - emitcall('FPC_ANSISTR_UNIQUE',true) - else - emitcall('FPC_WIDESTR_UNIQUE',true); - maybe_loadesi; - popusedregisters(exprasmlist,pushed); - end; - - if p^.left^.location.loc in [LOC_REGISTER,LOC_CREGISTER] then - begin - p^.location.reference.base:=p^.left^.location.register; - end - else - begin - del_reference(p^.left^.location.reference); - p^.location.reference.base:=getregister32; - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, - newreference(p^.left^.location.reference), - p^.location.reference.base))); - end; - - { check for a zero length string, - we can use the ansistring routine here } - if (cs_check_range in aktlocalswitches) then - begin - pushusedregisters(exprasmlist,pushed,$ff); - exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,p^.location.reference.base))); - emitcall('FPC_ANSISTR_CHECKZERO',true); - maybe_loadesi; - popusedregisters(exprasmlist,pushed); - end; - - if is_ansistring(p^.left^.resulttype) then - { in ansistrings S[1] is pchar(S)[0] !! } - dec(p^.location.reference.offset) - else - begin - { in widestrings S[1] is pwchar(S)[0] !! } - dec(p^.location.reference.offset,2); - exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L, - 1,p^.location.reference.base))); - end; - - { we've also to keep left up-to-date, because it is used } - { if a constant array index occurs, subject to change (FK) } - set_location(p^.left^.location,p^.location); - end - else - set_location(p^.location,p^.left^.location); - - { offset can only differ from 0 if arraydef } - if p^.left^.resulttype^.deftype=arraydef then - dec(p^.location.reference.offset, - get_mul_size*parraydef(p^.left^.resulttype)^.lowrange); - if p^.right^.treetype=ordconstn then - begin - { offset can only differ from 0 if arraydef } - if (p^.left^.resulttype^.deftype=arraydef) then - begin - if not(is_open_array(p^.left^.resulttype)) then - begin - if (p^.right^.value>parraydef(p^.left^.resulttype)^.highrange) or - (p^.right^.valueLOC_REFERENCE) and - (p^.location.loc<>LOC_MEM) then - CGMessage(cg_e_illegal_expression); - is_pushed:=maybe_push(p^.right^.registers32,p); - secondpass(p^.right); - if is_pushed then - restore(p); - { here we change the location of p^.right - and the update was forgotten so it - led to wrong code in emitrangecheck later PM - so make range check before } - - if cs_check_range in aktlocalswitches then - begin - if p^.left^.resulttype^.deftype=arraydef then - begin - if is_open_array(p^.left^.resulttype) then - begin - reset_reference(href); - parraydef(p^.left^.resulttype)^.genrangecheck; - href.symbol:=newasmsymbol(parraydef(p^.left^.resulttype)^.getrangecheckstring); - href.offset:=4; - getsymonlyin(p^.left^.symtable,'high'+pvarsym(p^.left^.symtableentry)^.name); - hightree:=genloadnode(pvarsym(srsym),p^.left^.symtable); - firstpass(hightree); - secondpass(hightree); - emit_mov_loc_ref(hightree^.location,href); - disposetree(hightree); - end; - emitrangecheck(p^.right,p^.left^.resulttype); - end; - end; - - case p^.right^.location.loc of - LOC_REGISTER: - begin - ind:=p^.right^.location.register; - case p^.right^.resulttype^.size of - 1: - begin - hr:=reg8toreg32(ind); - emit_reg_reg(A_MOVZX,S_BL,ind,hr); - ind:=hr; - end; - 2: - begin - hr:=reg16toreg32(ind); - emit_reg_reg(A_MOVZX,S_WL,ind,hr); - ind:=hr; - end; - end; - end; - LOC_CREGISTER: - begin - ind:=getregister32; - case p^.right^.resulttype^.size of - 1: - emit_reg_reg(A_MOVZX,S_BL,p^.right^.location.register,ind); - 2: - emit_reg_reg(A_MOVZX,S_WL,p^.right^.location.register,ind); - 4: - emit_reg_reg(A_MOV,S_L,p^.right^.location.register,ind); - end; - end; - LOC_FLAGS: - begin - ind:=getregister32; - emit_flag2reg(p^.right^.location.resflags,reg32toreg8(ind)); - emit_reg_reg(A_MOVZX,S_BL,reg32toreg8(ind),ind); - end - else - begin - del_reference(p^.right^.location.reference); - ind:=getregister32; - { Booleans are stored in an 8 bit memory location, so - the use of MOVL is not correct } - case p^.right^.resulttype^.size of - 1 : tai:=new(pai386,op_ref_reg(A_MOVZX,S_BL,newreference(p^.right^.location.reference),ind)); - 2 : tai:=new(Pai386,op_ref_reg(A_MOVZX,S_WL,newreference(p^.right^.location.reference),ind)); - 4 : tai:=new(Pai386,op_ref_reg(A_MOV,S_L,newreference(p^.right^.location.reference),ind)); - end; - exprasmlist^.concat(tai); - end; - end; - - { produce possible range check code: } - if cs_check_range in aktlocalswitches then - begin - if p^.left^.resulttype^.deftype=arraydef then - begin - { done defore (PM) } - end - else if (p^.left^.resulttype^.deftype=stringdef) then - begin - case pstringdef(p^.left^.resulttype)^.string_typ of - { it's the same for ansi- and wide strings } - st_widestring, - st_ansistring: - begin - pushusedregisters(exprasmlist,pushed,$ff); - exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,ind))); - hp:=newreference(p^.location.reference); - dec(hp^.offset,7); - exprasmlist^.concat(new(pai386,op_ref(A_PUSH,S_L,hp))); - emitcall('FPC_ANSISTR_RANGECHECK',true); - popusedregisters(exprasmlist,pushed); - maybe_loadesi; - end; - st_shortstring: - begin - {!!!!!!!!!!!!!!!!!} - end; - st_longstring: - begin - {!!!!!!!!!!!!!!!!!} - end; - end; - end; - end; - - if p^.location.reference.index=R_NO then - begin - p^.location.reference.index:=ind; - calc_emit_mul; - end - else - begin - if p^.location.reference.base=R_NO then - begin - case p^.location.reference.scalefactor of - 2 : exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L,1,p^.location.reference.index))); - 4 : exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L,2,p^.location.reference.index))); - 8 : exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L,3,p^.location.reference.index))); - end; - calc_emit_mul; - p^.location.reference.base:=p^.location.reference.index; - p^.location.reference.index:=ind; - end - else - begin - exprasmlist^.concat(new(pai386,op_ref_reg( - A_LEA,S_L,newreference(p^.location.reference), - p^.location.reference.index))); - ungetregister32(p^.location.reference.base); - { the symbol offset is loaded, } - { so release the symbol name and set symbol } - { to nil } - p^.location.reference.symbol:=nil; - p^.location.reference.offset:=0; - calc_emit_mul; - p^.location.reference.base:=p^.location.reference.index; - p^.location.reference.index:=ind; - end; - end; - - if p^.memseg then - p^.location.reference.segment:=R_FS; - end; - end; - -{***************************************************************************** - SecondSelfN -*****************************************************************************} - - procedure secondselfn(var p : ptree); - begin - reset_reference(p^.location.reference); - if (p^.resulttype^.deftype=classrefdef) or - ((p^.resulttype^.deftype=objectdef) - and pobjectdef(p^.resulttype)^.isclass - ) then - p^.location.register:=R_ESI - else - p^.location.reference.base:=R_ESI; - end; - - -{***************************************************************************** - SecondWithN -*****************************************************************************} - - procedure secondwith(var p : ptree); - var - usetemp : boolean; - begin - if assigned(p^.left) then - begin - secondpass(p^.left); - if p^.left^.location.reference.segment<>R_NO then - message(parser_e_no_with_for_variable_in_other_segments); - - new(p^.withreference); - - usetemp:=false; - if (p^.left^.treetype=loadn) and - (p^.left^.symtable=aktprocsym^.definition^.localst) then - begin - { for locals use the local storage } - p^.withreference^:=p^.left^.location.reference; - p^.islocal:=true; - end - else - if (p^.left^.resulttype^.deftype=objectdef) and - pobjectdef(p^.left^.resulttype)^.isclass then - begin - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, - newreference(p^.left^.location.reference),R_EDI))); - usetemp:=true; - end - else - begin - exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L, - newreference(p^.left^.location.reference),R_EDI))); - usetemp:=true; - end; - - { if usetemp is set the value must be in %edi } - if usetemp then - begin - gettempofsizereference(4,p^.withreference^); - normaltemptopersistant(p^.withreference^.offset); - { move to temp reference } - exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L, - R_EDI,newreference(p^.withreference^)))); - del_reference(p^.left^.location.reference); - end; - - { p^.right can be optimize out !!! } - if assigned(p^.right) then - secondpass(p^.right); - - if usetemp then - ungetpersistanttemp(p^.withreference^.offset); - - dispose(p^.withreference); - p^.withreference:=nil; - end; - end; - - -end. -{ +{ + $Id$ + Copyright (c) 1993-98 by Florian Klaempfl + + Generate i386 assembler for in memory related nodes + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit cg386mem; +interface + + uses + tree; + + procedure secondloadvmt(var p : ptree); + procedure secondhnewn(var p : ptree); + procedure secondnewn(var p : ptree); + procedure secondhdisposen(var p : ptree); + procedure secondsimplenewdispose(var p : ptree); + procedure secondaddr(var p : ptree); + procedure seconddoubleaddr(var p : ptree); + procedure secondderef(var p : ptree); + procedure secondsubscriptn(var p : ptree); + procedure secondvecn(var p : ptree); + procedure secondselfn(var p : ptree); + procedure secondwith(var p : ptree); + + +implementation + + uses + globtype,systems, + cobjects,verbose,globals, + symtable,aasm,types, + hcodegen,temp_gen,pass_2,pass_1, +{$ifndef OLDASM} + i386base,i386asm, +{$else} + i386, +{$endif} + cgai386,tgeni386; + +{***************************************************************************** + SecondLoadVMT +*****************************************************************************} + + procedure secondloadvmt(var p : ptree); + begin + p^.location.register:=getregister32; + exprasmlist^.concat(new(pai386,op_sym_ofs_reg(A_MOV, + S_L,newasmsymbol(pobjectdef(pclassrefdef(p^.resulttype)^.definition)^.vmt_mangledname),0, + p^.location.register))); +{$ifndef NEWLAB} + maybe_concat_external(pobjectdef(pclassrefdef(p^.resulttype)^.definition)^.owner, + pobjectdef(pclassrefdef(p^.resulttype)^.definition)^.vmt_mangledname); +{$endif} + end; + + +{***************************************************************************** + SecondHNewN +*****************************************************************************} + + procedure secondhnewn(var p : ptree); + begin + end; + + +{***************************************************************************** + SecondNewN +*****************************************************************************} + + procedure secondnewn(var p : ptree); + var + pushed : tpushed; + r : preference; + begin + if assigned(p^.left) then + begin + secondpass(p^.left); + p^.location.register:=p^.left^.location.register; + end + else + begin + pushusedregisters(exprasmlist,pushed,$ff); + + { code copied from simplenewdispose PM } + { determines the size of the mem block } + push_int(ppointerdef(p^.resulttype)^.definition^.size); + + gettempofsizereference(target_os.size_of_pointer,p^.location.reference); + emitpushreferenceaddr(exprasmlist,p^.location.reference); + + emitcall('FPC_GETMEM',true); + if ppointerdef(p^.resulttype)^.definition^.needs_inittable then + begin + new(r); + reset_reference(r^); + r^.symbol:=newasmsymbol(lab2str(ppointerdef(p^.left^.resulttype)^.definition^.get_inittable_label)); + emitpushreferenceaddr(exprasmlist,r^); + { push pointer adress } + emitpushreferenceaddr(exprasmlist,p^.location.reference); + dispose(r); + emitcall('FPC_INITIALIZE',true); + end; + popusedregisters(exprasmlist,pushed); + { may be load ESI } + maybe_loadesi; + end; + if codegenerror then + exit; + end; + + +{***************************************************************************** + SecondDisposeN +*****************************************************************************} + + procedure secondhdisposen(var p : ptree); + begin + secondpass(p^.left); + if codegenerror then + exit; + reset_reference(p^.location.reference); + case p^.left^.location.loc of + LOC_REGISTER, + LOC_CREGISTER: + begin + p^.location.reference.index:=getregister32; + exprasmlist^.concat(new(pai386,op_reg_reg(A_MOV,S_L, + p^.left^.location.register, + p^.location.reference.index))); + end; + LOC_MEM,LOC_REFERENCE : + begin + del_reference(p^.left^.location.reference); + p^.location.reference.index:=getregister32; + exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.left^.location.reference), + p^.location.reference.index))); + end; + end; + end; + + +{***************************************************************************** + SecondNewDispose +*****************************************************************************} + + procedure secondsimplenewdispose(var p : ptree); + + var + pushed : tpushed; + r : preference; + + begin + secondpass(p^.left); + if codegenerror then + exit; + + pushusedregisters(exprasmlist,pushed,$ff); + { determines the size of the mem block } + push_int(ppointerdef(p^.left^.resulttype)^.definition^.size); + + { push pointer adress } + case p^.left^.location.loc of + LOC_CREGISTER : exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L, + p^.left^.location.register))); + LOC_REFERENCE: + emitpushreferenceaddr(exprasmlist,p^.left^.location.reference); + end; + + { call the mem handling procedures } + case p^.treetype of + simpledisposen: + begin + if ppointerdef(p^.left^.resulttype)^.definition^.needs_inittable then + begin + new(r); + reset_reference(r^); + r^.symbol:=newasmsymbol(lab2str(ppointerdef(p^.left^.resulttype)^.definition^.get_inittable_label)); + emitpushreferenceaddr(exprasmlist,r^); + { push pointer adress } + case p^.left^.location.loc of + LOC_CREGISTER : exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L, + p^.left^.location.register))); + LOC_REFERENCE: + emitpushreferenceaddr(exprasmlist,p^.left^.location.reference); + end; + dispose(r); + emitcall('FPC_FINALIZE',true); + end; + emitcall('FPC_FREEMEM',true); + end; + simplenewn: + begin + emitcall('FPC_GETMEM',true); + if ppointerdef(p^.left^.resulttype)^.definition^.needs_inittable then + begin + new(r); + reset_reference(r^); + r^.symbol:=newasmsymbol(lab2str(ppointerdef(p^.left^.resulttype)^.definition^.get_inittable_label)); + emitpushreferenceaddr(exprasmlist,r^); + { push pointer adress } + case p^.left^.location.loc of + LOC_CREGISTER : exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L, + p^.left^.location.register))); + LOC_REFERENCE: + emitpushreferenceaddr(exprasmlist,p^.left^.location.reference); + end; + dispose(r); + emitcall('FPC_INITIALIZE',true); + end; + end; + end; + popusedregisters(exprasmlist,pushed); + { may be load ESI } + maybe_loadesi; + end; + + +{***************************************************************************** + SecondAddr +*****************************************************************************} + + procedure secondaddr(var p : ptree); + begin + secondpass(p^.left); + p^.location.loc:=LOC_REGISTER; + del_reference(p^.left^.location.reference); + p^.location.register:=getregister32; + {@ on a procvar means returning an address to the procedure that + is stored in it.} + { yes but p^.left^.symtableentry can be nil + for example on @self !! } + { symtableentry can be also invalid, if left is no tree node } + if (m_tp_procvar in aktmodeswitches) and + (p^.left^.treetype=loadn) and + assigned(p^.left^.symtableentry) and + (p^.left^.symtableentry^.typ=varsym) and + (pvarsym(p^.left^.symtableentry)^.definition^.deftype=procvardef) then + exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, + newreference(p^.left^.location.reference), + p^.location.register))) + else + exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L, + newreference(p^.left^.location.reference), + p^.location.register))); + { for use of other segments } + if p^.left^.location.reference.segment<>R_NO then + p^.location.segment:=p^.left^.location.reference.segment; + end; + + +{***************************************************************************** + SecondDoubleAddr +*****************************************************************************} + + procedure seconddoubleaddr(var p : ptree); + begin + secondpass(p^.left); + p^.location.loc:=LOC_REGISTER; + del_reference(p^.left^.location.reference); + p^.location.register:=getregister32; + exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L, + newreference(p^.left^.location.reference), + p^.location.register))); + end; + + +{***************************************************************************** + SecondDeRef +*****************************************************************************} + + procedure secondderef(var p : ptree); + var + hr : tregister; + begin + secondpass(p^.left); + reset_reference(p^.location.reference); + case p^.left^.location.loc of + LOC_REGISTER: + p^.location.reference.base:=p^.left^.location.register; + LOC_CREGISTER: + begin + { ... and reserve one for the pointer } + hr:=getregister32; + emit_reg_reg(A_MOV,S_L,p^.left^.location.register,hr); + p^.location.reference.base:=hr; + end; + else + begin + { free register } + del_reference(p^.left^.location.reference); + + { ...and reserve one for the pointer } + hr:=getregister32; + exprasmlist^.concat(new(pai386,op_ref_reg( + A_MOV,S_L,newreference(p^.left^.location.reference), + hr))); + p^.location.reference.base:=hr; + end; + end; + if ppointerdef(p^.left^.resulttype)^.is_far then + p^.location.reference.segment:=R_FS; + if not ppointerdef(p^.left^.resulttype)^.is_far and + (cs_gdb_heaptrc in aktglobalswitches) and + (cs_checkpointer in aktglobalswitches) then + begin + exprasmlist^.concat(new(pai386,op_reg( + A_PUSH,S_L,p^.location.reference.base))); + emitcall('FPC_CHECKPOINTER',true); + end; + end; + + +{***************************************************************************** + SecondSubScriptN +*****************************************************************************} + + procedure secondsubscriptn(var p : ptree); + var + hr : tregister; + begin + secondpass(p^.left); + if codegenerror then + exit; + { classes must be dereferenced implicit } + if (p^.left^.resulttype^.deftype=objectdef) and + pobjectdef(p^.left^.resulttype)^.isclass then + begin + reset_reference(p^.location.reference); + case p^.left^.location.loc of + LOC_REGISTER: + p^.location.reference.base:=p^.left^.location.register; + LOC_CREGISTER: + begin + { ... and reserve one for the pointer } + hr:=getregister32; + emit_reg_reg(A_MOV,S_L,p^.left^.location.register,hr); + p^.location.reference.base:=hr; + end; + else + begin + { free register } + del_reference(p^.left^.location.reference); + + { ... and reserve one for the pointer } + hr:=getregister32; + exprasmlist^.concat(new(pai386,op_ref_reg( + A_MOV,S_L,newreference(p^.left^.location.reference), + hr))); + p^.location.reference.base:=hr; + end; + end; + end + else + set_location(p^.location,p^.left^.location); + + inc(p^.location.reference.offset,p^.vs^.address); + end; + + +{***************************************************************************** + SecondVecN +*****************************************************************************} + + procedure secondvecn(var p : ptree); + var + is_pushed : boolean; + ind,hr : tregister; + _p : ptree; + + function get_mul_size:longint; + begin + if p^.memindex then + get_mul_size:=1 + else + get_mul_size:=p^.resulttype^.size; + end; + + procedure calc_emit_mul; + var + l1,l2 : longint; + begin + l1:=get_mul_size; + case l1 of + 1,2,4,8 : p^.location.reference.scalefactor:=l1; + else + begin + if ispowerof2(l1,l2) then + exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L,l2,ind))) + else + exprasmlist^.concat(new(pai386,op_const_reg(A_IMUL,S_L,l1,ind))); + end; + end; + end; + + var + extraoffset : longint; + { rl stores the resulttype of the left node, this is necessary } + { to detect if it is an ansistring } + { because in constant nodes which constant index } + { the left tree is removed } + rl : pdef; + t : ptree; + hp : preference; + href : treference; + tai : Pai386; + pushed : tpushed; + hightree : ptree; + + begin + secondpass(p^.left); + rl:=p^.left^.resulttype; + { we load the array reference to p^.location } + + { an ansistring needs to be dereferenced } + if is_ansistring(p^.left^.resulttype) or + is_widestring(p^.left^.resulttype) then + begin + reset_reference(p^.location.reference); + if p^.callunique then + begin + if p^.left^.location.loc<>LOC_REFERENCE then + begin + CGMessage(cg_e_illegal_expression); + exit; + end; + pushusedregisters(exprasmlist,pushed,$ff); + emitpushreferenceaddr(exprasmlist,p^.left^.location.reference); + if is_ansistring(p^.left^.resulttype) then + emitcall('FPC_ANSISTR_UNIQUE',true) + else + emitcall('FPC_WIDESTR_UNIQUE',true); + maybe_loadesi; + popusedregisters(exprasmlist,pushed); + end; + + if p^.left^.location.loc in [LOC_REGISTER,LOC_CREGISTER] then + begin + p^.location.reference.base:=p^.left^.location.register; + end + else + begin + del_reference(p^.left^.location.reference); + p^.location.reference.base:=getregister32; + exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, + newreference(p^.left^.location.reference), + p^.location.reference.base))); + end; + + { check for a zero length string, + we can use the ansistring routine here } + if (cs_check_range in aktlocalswitches) then + begin + pushusedregisters(exprasmlist,pushed,$ff); + exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,p^.location.reference.base))); + emitcall('FPC_ANSISTR_CHECKZERO',true); + maybe_loadesi; + popusedregisters(exprasmlist,pushed); + end; + + if is_ansistring(p^.left^.resulttype) then + { in ansistrings S[1] is pchar(S)[0] !! } + dec(p^.location.reference.offset) + else + begin + { in widestrings S[1] is pwchar(S)[0] !! } + dec(p^.location.reference.offset,2); + exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L, + 1,p^.location.reference.base))); + end; + + { we've also to keep left up-to-date, because it is used } + { if a constant array index occurs, subject to change (FK) } + set_location(p^.left^.location,p^.location); + end + else + set_location(p^.location,p^.left^.location); + + { offset can only differ from 0 if arraydef } + if p^.left^.resulttype^.deftype=arraydef then + dec(p^.location.reference.offset, + get_mul_size*parraydef(p^.left^.resulttype)^.lowrange); + if p^.right^.treetype=ordconstn then + begin + { offset can only differ from 0 if arraydef } + if (p^.left^.resulttype^.deftype=arraydef) then + begin + if not(is_open_array(p^.left^.resulttype)) and + not(is_array_of_const(p^.left^.resulttype)) then + begin + if (p^.right^.value>parraydef(p^.left^.resulttype)^.highrange) or + (p^.right^.valueLOC_REFERENCE) and + (p^.location.loc<>LOC_MEM) then + CGMessage(cg_e_illegal_expression); + is_pushed:=maybe_push(p^.right^.registers32,p); + secondpass(p^.right); + if is_pushed then + restore(p); + { here we change the location of p^.right + and the update was forgotten so it + led to wrong code in emitrangecheck later PM + so make range check before } + + if cs_check_range in aktlocalswitches then + begin + if p^.left^.resulttype^.deftype=arraydef then + begin + if is_open_array(p^.left^.resulttype) then + begin + reset_reference(href); + parraydef(p^.left^.resulttype)^.genrangecheck; + href.symbol:=newasmsymbol(parraydef(p^.left^.resulttype)^.getrangecheckstring); + href.offset:=4; + getsymonlyin(p^.left^.symtable,'high'+pvarsym(p^.left^.symtableentry)^.name); + hightree:=genloadnode(pvarsym(srsym),p^.left^.symtable); + firstpass(hightree); + secondpass(hightree); + emit_mov_loc_ref(hightree^.location,href); + disposetree(hightree); + end; + emitrangecheck(p^.right,p^.left^.resulttype); + end; + end; + + case p^.right^.location.loc of + LOC_REGISTER: + begin + ind:=p^.right^.location.register; + case p^.right^.resulttype^.size of + 1: + begin + hr:=reg8toreg32(ind); + emit_reg_reg(A_MOVZX,S_BL,ind,hr); + ind:=hr; + end; + 2: + begin + hr:=reg16toreg32(ind); + emit_reg_reg(A_MOVZX,S_WL,ind,hr); + ind:=hr; + end; + end; + end; + LOC_CREGISTER: + begin + ind:=getregister32; + case p^.right^.resulttype^.size of + 1: + emit_reg_reg(A_MOVZX,S_BL,p^.right^.location.register,ind); + 2: + emit_reg_reg(A_MOVZX,S_WL,p^.right^.location.register,ind); + 4: + emit_reg_reg(A_MOV,S_L,p^.right^.location.register,ind); + end; + end; + LOC_FLAGS: + begin + ind:=getregister32; + emit_flag2reg(p^.right^.location.resflags,reg32toreg8(ind)); + emit_reg_reg(A_MOVZX,S_BL,reg32toreg8(ind),ind); + end + else + begin + del_reference(p^.right^.location.reference); + ind:=getregister32; + { Booleans are stored in an 8 bit memory location, so + the use of MOVL is not correct } + case p^.right^.resulttype^.size of + 1 : tai:=new(pai386,op_ref_reg(A_MOVZX,S_BL,newreference(p^.right^.location.reference),ind)); + 2 : tai:=new(Pai386,op_ref_reg(A_MOVZX,S_WL,newreference(p^.right^.location.reference),ind)); + 4 : tai:=new(Pai386,op_ref_reg(A_MOV,S_L,newreference(p^.right^.location.reference),ind)); + end; + exprasmlist^.concat(tai); + end; + end; + + { produce possible range check code: } + if cs_check_range in aktlocalswitches then + begin + if p^.left^.resulttype^.deftype=arraydef then + begin + { done defore (PM) } + end + else if (p^.left^.resulttype^.deftype=stringdef) then + begin + case pstringdef(p^.left^.resulttype)^.string_typ of + { it's the same for ansi- and wide strings } + st_widestring, + st_ansistring: + begin + pushusedregisters(exprasmlist,pushed,$ff); + exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,ind))); + hp:=newreference(p^.location.reference); + dec(hp^.offset,7); + exprasmlist^.concat(new(pai386,op_ref(A_PUSH,S_L,hp))); + emitcall('FPC_ANSISTR_RANGECHECK',true); + popusedregisters(exprasmlist,pushed); + maybe_loadesi; + end; + st_shortstring: + begin + {!!!!!!!!!!!!!!!!!} + end; + st_longstring: + begin + {!!!!!!!!!!!!!!!!!} + end; + end; + end; + end; + + if p^.location.reference.index=R_NO then + begin + p^.location.reference.index:=ind; + calc_emit_mul; + end + else + begin + if p^.location.reference.base=R_NO then + begin + case p^.location.reference.scalefactor of + 2 : exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L,1,p^.location.reference.index))); + 4 : exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L,2,p^.location.reference.index))); + 8 : exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L,3,p^.location.reference.index))); + end; + calc_emit_mul; + p^.location.reference.base:=p^.location.reference.index; + p^.location.reference.index:=ind; + end + else + begin + exprasmlist^.concat(new(pai386,op_ref_reg( + A_LEA,S_L,newreference(p^.location.reference), + p^.location.reference.index))); + ungetregister32(p^.location.reference.base); + { the symbol offset is loaded, } + { so release the symbol name and set symbol } + { to nil } + p^.location.reference.symbol:=nil; + p^.location.reference.offset:=0; + calc_emit_mul; + p^.location.reference.base:=p^.location.reference.index; + p^.location.reference.index:=ind; + end; + end; + + if p^.memseg then + p^.location.reference.segment:=R_FS; + end; + end; + +{***************************************************************************** + SecondSelfN +*****************************************************************************} + + procedure secondselfn(var p : ptree); + begin + reset_reference(p^.location.reference); + if (p^.resulttype^.deftype=classrefdef) or + ((p^.resulttype^.deftype=objectdef) + and pobjectdef(p^.resulttype)^.isclass + ) then + p^.location.register:=R_ESI + else + p^.location.reference.base:=R_ESI; + end; + + +{***************************************************************************** + SecondWithN +*****************************************************************************} + + procedure secondwith(var p : ptree); + var + usetemp : boolean; + begin + if assigned(p^.left) then + begin + secondpass(p^.left); + if p^.left^.location.reference.segment<>R_NO then + message(parser_e_no_with_for_variable_in_other_segments); + + new(p^.withreference); + + usetemp:=false; + if (p^.left^.treetype=loadn) and + (p^.left^.symtable=aktprocsym^.definition^.localst) then + begin + { for locals use the local storage } + p^.withreference^:=p^.left^.location.reference; + p^.islocal:=true; + end + else + if (p^.left^.resulttype^.deftype=objectdef) and + pobjectdef(p^.left^.resulttype)^.isclass then + begin + exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, + newreference(p^.left^.location.reference),R_EDI))); + usetemp:=true; + end + else + begin + exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L, + newreference(p^.left^.location.reference),R_EDI))); + usetemp:=true; + end; + + { if usetemp is set the value must be in %edi } + if usetemp then + begin + gettempofsizereference(4,p^.withreference^); + normaltemptopersistant(p^.withreference^.offset); + { move to temp reference } + exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L, + R_EDI,newreference(p^.withreference^)))); + del_reference(p^.left^.location.reference); + end; + + { p^.right can be optimize out !!! } + if assigned(p^.right) then + secondpass(p^.right); + + if usetemp then + ungetpersistanttemp(p^.withreference^.offset); + + dispose(p^.withreference); + p^.withreference:=nil; + end; + end; + + +end. +{ $Log$ - Revision 1.44 1999-05-21 13:54:53 peter + Revision 1.45 1999-05-23 18:42:04 florian + * better error recovering in typed constants + * some problems with arrays of const fixed, some problems + due my previous + - the location type of array constructor is now LOC_MEM + - the pushing of high fixed + - parameter copying fixed + - zero temp. allocation removed + * small problem in the assembler writers fixed: + ref to nil wasn't written correctly + + Revision 1.44 1999/05/21 13:54:53 peter * NEWLAB for label as symbol - - Revision 1.43 1999/05/19 16:48:21 florian - * tdef.typename: returns a now a proper type name for the most types - - Revision 1.42 1999/05/18 22:11:52 pierre - * checkpointer code was wrong! - - Revision 1.41 1999/05/18 21:58:29 florian - * fixed some bugs related to temp. ansistrings and functions results - which return records/objects/arrays which need init/final. - - Revision 1.40 1999/05/18 14:15:26 peter - * containsself fixes - * checktypes() - - Revision 1.39 1999/05/17 23:51:39 peter - * with temp vars now use a reference with a persistant temp instead - of setting datasize - - Revision 1.38 1999/05/17 21:57:05 florian - * new temporary ansistring handling - - Revision 1.37 1999/05/17 14:14:14 pierre - + -gc for check pointer with heaptrc - - Revision 1.36 1999/05/12 00:19:44 peter - * removed R_DEFAULT_SEG - * uniform float names - - Revision 1.35 1999/05/01 13:24:13 peter - * merged nasm compiler - * old asm moved to oldasm/ - - Revision 1.34 1999/04/26 18:29:54 peter - * farpointerdef moved into pointerdef.is_far - - Revision 1.33 1999/03/26 11:43:26 pierre - * bug0236 fixed - - Revision 1.32 1999/03/24 23:16:53 peter - * fixed bugs 212,222,225,227,229,231,233 - - Revision 1.31 1999/02/25 21:02:29 peter - * ag386bin updates - + coff writer - - Revision 1.30 1999/02/22 02:15:14 peter - * updates for ag386bin - - Revision 1.29 1999/02/07 22:53:07 florian - * potential bug in secondvecn fixed - - Revision 1.28 1999/02/04 17:16:51 peter - * fixed crash with temp ansistring indexing - - Revision 1.27 1999/02/04 11:44:46 florian - * fixed indexed access of ansistrings to temp. ansistring, i.e. - c:=(s1+s2)[i], the temp is now correctly remove and the generated - code is also fixed - - Revision 1.26 1999/02/04 10:49:41 florian - + range checking for ansi- and widestrings - * made it compilable with TP - - Revision 1.25 1999/01/21 16:40:52 pierre - * fix for constructor inside with statements - - Revision 1.24 1999/01/19 12:05:27 pierre - * bug with @procvar=procvar fiwed - - Revision 1.23 1998/12/30 22:15:45 peter - + farpointer type - * absolutesym now also stores if its far - - Revision 1.22 1998/12/11 00:02:55 peter - + globtype,tokens,version unit splitted from globals - - Revision 1.21 1998/12/10 09:47:18 florian - + basic operations with int64/qord (compiler with -dint64) - + rtti of enumerations extended: names are now written - - Revision 1.20 1998/11/25 19:12:54 pierre - * var:=new(pointer_type) support added - - Revision 1.19 1998/11/20 15:35:55 florian - * problems with rtti fixed, hope it works - - Revision 1.18 1998/11/17 00:36:40 peter - * more ansistring fixes - - Revision 1.17 1998/11/16 15:35:09 pierre - * added error for with if different segment - - Revision 1.16 1998/10/21 11:44:42 florian - + check for access to index 0 of long/wide/ansi strings added, - gives now an error - * problem with access to contant index of ansistrings fixed - - Revision 1.15 1998/10/12 09:49:53 florian - + support of := in delphi mode added - - Revision 1.14 1998/10/02 07:20:37 florian - * range checking in units doesn't work if the units are smartlinked, fixed - - Revision 1.13 1998/09/27 10:16:23 florian - * type casts pchar<->ansistring fixed - * ansistring[..] calls does now an unique call - - Revision 1.12 1998/09/23 15:46:36 florian - * problem with with and classes fixed - - Revision 1.11 1998/09/17 09:42:18 peter - + pass_2 for cg386 - * Message() -> CGMessage() for pass_1/pass_2 - - Revision 1.10 1998/09/14 10:43:52 peter - * all internal RTL functions start with FPC_ - - Revision 1.9 1998/09/03 16:03:15 florian - + rtti generation - * init table generation changed - - Revision 1.8 1998/08/23 21:04:34 florian - + rtti generation for classes added - + new/dispose do now also a call to INITIALIZE/FINALIZE, if necessaray - - Revision 1.7 1998/08/20 11:27:40 michael - * Applied Peters Fix - - Revision 1.6 1998/08/10 14:49:49 peter - + localswitches, moduleswitches, globalswitches splitting - - Revision 1.5 1998/07/26 21:58:58 florian - + better support for switch $H - + index access to ansi strings added - + assigment of data (records/arrays) containing ansi strings - - Revision 1.4 1998/07/24 22:16:55 florian - * internal error 10 together with array access fixed. I hope - that's the final fix. - - Revision 1.3 1998/06/25 08:48:09 florian - * first version of rtti support - - Revision 1.2 1998/06/08 13:13:35 pierre - + temporary variables now in temp_gen.pas unit - because it is processor independent - * mppc68k.bat modified to undefine i386 and support_mmx - (which are defaults for i386) - - Revision 1.1 1998/06/05 17:44:13 peter - * splitted cgi386 - -} - + + Revision 1.43 1999/05/19 16:48:21 florian + * tdef.typename: returns a now a proper type name for the most types + + Revision 1.42 1999/05/18 22:11:52 pierre + * checkpointer code was wrong! + + Revision 1.41 1999/05/18 21:58:29 florian + * fixed some bugs related to temp. ansistrings and functions results + which return records/objects/arrays which need init/final. + + Revision 1.40 1999/05/18 14:15:26 peter + * containsself fixes + * checktypes() + + Revision 1.39 1999/05/17 23:51:39 peter + * with temp vars now use a reference with a persistant temp instead + of setting datasize + + Revision 1.38 1999/05/17 21:57:05 florian + * new temporary ansistring handling + + Revision 1.37 1999/05/17 14:14:14 pierre + + -gc for check pointer with heaptrc + + Revision 1.36 1999/05/12 00:19:44 peter + * removed R_DEFAULT_SEG + * uniform float names + + Revision 1.35 1999/05/01 13:24:13 peter + * merged nasm compiler + * old asm moved to oldasm/ + + Revision 1.34 1999/04/26 18:29:54 peter + * farpointerdef moved into pointerdef.is_far + + Revision 1.33 1999/03/26 11:43:26 pierre + * bug0236 fixed + + Revision 1.32 1999/03/24 23:16:53 peter + * fixed bugs 212,222,225,227,229,231,233 + + Revision 1.31 1999/02/25 21:02:29 peter + * ag386bin updates + + coff writer + + Revision 1.30 1999/02/22 02:15:14 peter + * updates for ag386bin + + Revision 1.29 1999/02/07 22:53:07 florian + * potential bug in secondvecn fixed + + Revision 1.28 1999/02/04 17:16:51 peter + * fixed crash with temp ansistring indexing + + Revision 1.27 1999/02/04 11:44:46 florian + * fixed indexed access of ansistrings to temp. ansistring, i.e. + c:=(s1+s2)[i], the temp is now correctly remove and the generated + code is also fixed + + Revision 1.26 1999/02/04 10:49:41 florian + + range checking for ansi- and widestrings + * made it compilable with TP + + Revision 1.25 1999/01/21 16:40:52 pierre + * fix for constructor inside with statements + + Revision 1.24 1999/01/19 12:05:27 pierre + * bug with @procvar=procvar fiwed + + Revision 1.23 1998/12/30 22:15:45 peter + + farpointer type + * absolutesym now also stores if its far + + Revision 1.22 1998/12/11 00:02:55 peter + + globtype,tokens,version unit splitted from globals + + Revision 1.21 1998/12/10 09:47:18 florian + + basic operations with int64/qord (compiler with -dint64) + + rtti of enumerations extended: names are now written + + Revision 1.20 1998/11/25 19:12:54 pierre + * var:=new(pointer_type) support added + + Revision 1.19 1998/11/20 15:35:55 florian + * problems with rtti fixed, hope it works + + Revision 1.18 1998/11/17 00:36:40 peter + * more ansistring fixes + + Revision 1.17 1998/11/16 15:35:09 pierre + * added error for with if different segment + + Revision 1.16 1998/10/21 11:44:42 florian + + check for access to index 0 of long/wide/ansi strings added, + gives now an error + * problem with access to contant index of ansistrings fixed + + Revision 1.15 1998/10/12 09:49:53 florian + + support of := in delphi mode added + + Revision 1.14 1998/10/02 07:20:37 florian + * range checking in units doesn't work if the units are smartlinked, fixed + + Revision 1.13 1998/09/27 10:16:23 florian + * type casts pchar<->ansistring fixed + * ansistring[..] calls does now an unique call + + Revision 1.12 1998/09/23 15:46:36 florian + * problem with with and classes fixed + + Revision 1.11 1998/09/17 09:42:18 peter + + pass_2 for cg386 + * Message() -> CGMessage() for pass_1/pass_2 + + Revision 1.10 1998/09/14 10:43:52 peter + * all internal RTL functions start with FPC_ + + Revision 1.9 1998/09/03 16:03:15 florian + + rtti generation + * init table generation changed + + Revision 1.8 1998/08/23 21:04:34 florian + + rtti generation for classes added + + new/dispose do now also a call to INITIALIZE/FINALIZE, if necessaray + + Revision 1.7 1998/08/20 11:27:40 michael + * Applied Peters Fix + + Revision 1.6 1998/08/10 14:49:49 peter + + localswitches, moduleswitches, globalswitches splitting + + Revision 1.5 1998/07/26 21:58:58 florian + + better support for switch $H + + index access to ansi strings added + + assigment of data (records/arrays) containing ansi strings + + Revision 1.4 1998/07/24 22:16:55 florian + * internal error 10 together with array access fixed. I hope + that's the final fix. + + Revision 1.3 1998/06/25 08:48:09 florian + * first version of rtti support + + Revision 1.2 1998/06/08 13:13:35 pierre + + temporary variables now in temp_gen.pas unit + because it is processor independent + * mppc68k.bat modified to undefine i386 and support_mmx + (which are defaults for i386) + + Revision 1.1 1998/06/05 17:44:13 peter + * splitted cgi386 + +} + diff --git a/compiler/msgtxt.inc b/compiler/msgtxt.inc index 013d943fed..26427ff360 100644 --- a/compiler/msgtxt.inc +++ b/compiler/msgtxt.inc @@ -589,7 +589,7 @@ const msgtxt : array[0..000095,1..240] of char=( '3*2Anasmcoff_coff file using Nasm'#000+ '3*2Anasmelf_elf32 (Linux) file using Nasm'#000+ '3*2Anasmobj_ob','j file using Nasm'#000+ - '3*2Amasm_obj file using Masm (Mircosoft)'#000+ + '3*2Amasm_obj file using Masm (Microsoft)'#000+ '3*2Atasm_obj file using Tasm (Borland)'#000+ '3*1R_assembler reading style:'#000+ '3*2Ratt_read AT&T style assembler'#000+ diff --git a/compiler/ptconst.pas b/compiler/ptconst.pas index 94495a10c8..1a1967e7c9 100644 --- a/compiler/ptconst.pas +++ b/compiler/ptconst.pas @@ -714,6 +714,14 @@ unit ptconst; consume(RKLAMMER); end; end; + errordef: + begin + { try to consume something useful } + if token=LKLAMMER then + consume_all_until(RKLAMMER) + else + consume_all_until(SEMICOLON); + end; else Message(parser_e_type_const_not_possible); end; end; @@ -721,7 +729,18 @@ unit ptconst; end. { $Log$ - Revision 1.44 1999-05-21 13:55:11 peter + Revision 1.45 1999-05-23 18:42:13 florian + * better error recovering in typed constants + * some problems with arrays of const fixed, some problems + due my previous + - the location type of array constructor is now LOC_MEM + - the pushing of high fixed + - parameter copying fixed + - zero temp. allocation removed + * small problem in the assembler writers fixed: + ref to nil wasn't written correctly + + Revision 1.44 1999/05/21 13:55:11 peter * NEWLAB for label as symbol Revision 1.43 1999/05/12 00:19:54 peter diff --git a/compiler/symdef.inc b/compiler/symdef.inc index 7ab8c8638d..d04e32dbeb 100644 --- a/compiler/symdef.inc +++ b/compiler/symdef.inc @@ -3499,9 +3499,26 @@ Const local_symtable_index : longint = $8001; end; {$endif GDB} + function terrordef.gettypename:string; + + begin + gettypename:=''; + end; + { $Log$ - Revision 1.121 1999-05-21 13:55:19 peter + Revision 1.122 1999-05-23 18:42:14 florian + * better error recovering in typed constants + * some problems with arrays of const fixed, some problems + due my previous + - the location type of array constructor is now LOC_MEM + - the pushing of high fixed + - parameter copying fixed + - zero temp. allocation removed + * small problem in the assembler writers fixed: + ref to nil wasn't written correctly + + Revision 1.121 1999/05/21 13:55:19 peter * NEWLAB for label as symbol Revision 1.120 1999/05/20 22:22:43 pierre diff --git a/compiler/symdefh.inc b/compiler/symdefh.inc index 7281cb935f..493579783d 100644 --- a/compiler/symdefh.inc +++ b/compiler/symdefh.inc @@ -142,6 +142,7 @@ {$ifdef GDB} function stabstring : pchar;virtual; {$endif GDB} + function gettypename:string;virtual; end; { tpointerdef and tclassrefdef should get a common @@ -516,7 +517,18 @@ { $Log$ - Revision 1.28 1999-05-19 16:48:28 florian + Revision 1.29 1999-05-23 18:42:15 florian + * better error recovering in typed constants + * some problems with arrays of const fixed, some problems + due my previous + - the location type of array constructor is now LOC_MEM + - the pushing of high fixed + - parameter copying fixed + - zero temp. allocation removed + * small problem in the assembler writers fixed: + ref to nil wasn't written correctly + + Revision 1.28 1999/05/19 16:48:28 florian * tdef.typename: returns a now a proper type name for the most types Revision 1.27 1999/05/13 21:59:42 peter diff --git a/compiler/symtable.pas b/compiler/symtable.pas index e9f4d1c5c9..57afe9208c 100644 --- a/compiler/symtable.pas +++ b/compiler/symtable.pas @@ -284,7 +284,7 @@ unit symtable; s32bitdef : porddef; { Pointer to 32-Bit signed } cu64bitdef : porddef; { pointer to 64 bit unsigned def } - cs64bitdef : porddef; { pointer to 64 bit signed def, } + cs64bitintdef : porddef; { pointer to 64 bit signed def, } { calculated by the int unit on i386 } s32floatdef : pfloatdef; { pointer for realconstn } @@ -2345,7 +2345,18 @@ const localsymtablestack : psymtable = nil; end. { $Log$ - Revision 1.15 1999-05-17 23:51:41 peter + Revision 1.16 1999-05-23 18:42:16 florian + * better error recovering in typed constants + * some problems with arrays of const fixed, some problems + due my previous + - the location type of array constructor is now LOC_MEM + - the pushing of high fixed + - parameter copying fixed + - zero temp. allocation removed + * small problem in the assembler writers fixed: + ref to nil wasn't written correctly + + Revision 1.15 1999/05/17 23:51:41 peter * with temp vars now use a reference with a persistant temp instead of setting datasize diff --git a/compiler/tcadd.pas b/compiler/tcadd.pas index 03c92957a5..05783debe4 100644 --- a/compiler/tcadd.pas +++ b/compiler/tcadd.pas @@ -481,12 +481,12 @@ implementation begin if (porddef(ld)^.typ<>s64bitint) then begin - p^.left:=gentypeconvnode(p^.left,cs64bitdef); + p^.left:=gentypeconvnode(p^.left,cs64bitintdef); firstpass(p^.left); end; if (porddef(rd)^.typ<>s64bitint) then begin - p^.right:=gentypeconvnode(p^.right,cs64bitdef); + p^.right:=gentypeconvnode(p^.right,cs64bitintdef); firstpass(p^.right); end; calcregisters(p,2,0,0); @@ -1097,7 +1097,18 @@ implementation end. { $Log$ - Revision 1.31 1999-05-19 20:40:14 florian + Revision 1.32 1999-05-23 18:42:18 florian + * better error recovering in typed constants + * some problems with arrays of const fixed, some problems + due my previous + - the location type of array constructor is now LOC_MEM + - the pushing of high fixed + - parameter copying fixed + - zero temp. allocation removed + * small problem in the assembler writers fixed: + ref to nil wasn't written correctly + + Revision 1.31 1999/05/19 20:40:14 florian * fixed a couple of array related bugs: - var a : array[0..1] of char; p : pchar; p:=a+123; works now - open arrays with an odd size doesn't work: movsb wasn't generated diff --git a/compiler/tccal.pas b/compiler/tccal.pas index 565744d2f6..a58c795ab8 100644 --- a/compiler/tccal.pas +++ b/compiler/tccal.pas @@ -69,7 +69,8 @@ implementation case p^.left^.resulttype^.deftype of arraydef : begin - if is_open_array(p^.left^.resulttype) then + if is_open_array(p^.left^.resulttype) or + is_array_of_const(p^.left^.resulttype) then begin st:=p^.left^.symtable; getsymonlyin(st,'high'+pvarsym(p^.left^.symtableentry)^.name); @@ -1166,7 +1167,18 @@ implementation end. { $Log$ - Revision 1.46 1999-05-20 14:58:27 peter + Revision 1.47 1999-05-23 18:42:19 florian + * better error recovering in typed constants + * some problems with arrays of const fixed, some problems + due my previous + - the location type of array constructor is now LOC_MEM + - the pushing of high fixed + - parameter copying fixed + - zero temp. allocation removed + * small problem in the assembler writers fixed: + ref to nil wasn't written correctly + + Revision 1.46 1999/05/20 14:58:27 peter * fixed arrayconstruct->set conversion which didn't work for enum sets Revision 1.45 1999/05/19 10:31:54 florian diff --git a/compiler/tcinl.pas b/compiler/tcinl.pas index 0d052f9093..232708e611 100644 --- a/compiler/tcinl.pas +++ b/compiler/tcinl.pas @@ -1011,7 +1011,8 @@ implementation end else begin - if is_open_array(p^.left^.resulttype) then + if is_open_array(p^.left^.resulttype) or + is_array_of_const(p^.left^.resulttype) then begin getsymonlyin(p^.left^.symtable,'high'+pvarsym(p^.left^.symtableentry)^.name); hp:=genloadnode(pvarsym(srsym),p^.left^.symtable); @@ -1104,7 +1105,18 @@ implementation end. { $Log$ - Revision 1.33 1999-05-06 09:05:35 peter + Revision 1.34 1999-05-23 18:42:20 florian + * better error recovering in typed constants + * some problems with arrays of const fixed, some problems + due my previous + - the location type of array constructor is now LOC_MEM + - the pushing of high fixed + - parameter copying fixed + - zero temp. allocation removed + * small problem in the assembler writers fixed: + ref to nil wasn't written correctly + + Revision 1.33 1999/05/06 09:05:35 peter * generic write_float and str_float * fixed constant float conversions diff --git a/compiler/tcld.pas b/compiler/tcld.pas index c09c2a6991..9a6fe8ae9d 100644 --- a/compiler/tcld.pas +++ b/compiler/tcld.pas @@ -439,7 +439,7 @@ implementation parraydef(p^.resulttype)^.definition:=pd; parraydef(p^.resulttype)^.IsConstructor:=true; parraydef(p^.resulttype)^.IsVariant:=varia; - p^.location.loc:=LOC_REFERENCE; + p^.location.loc:=LOC_MEM; end; @@ -457,7 +457,18 @@ implementation end. { $Log$ - Revision 1.31 1999-05-19 15:26:41 florian + Revision 1.32 1999-05-23 18:42:22 florian + * better error recovering in typed constants + * some problems with arrays of const fixed, some problems + due my previous + - the location type of array constructor is now LOC_MEM + - the pushing of high fixed + - parameter copying fixed + - zero temp. allocation removed + * small problem in the assembler writers fixed: + ref to nil wasn't written correctly + + Revision 1.31 1999/05/19 15:26:41 florian * if a non local variables isn't initialized the compiler doesn't write any longer "local var. seems not to be ..." diff --git a/compiler/types.pas b/compiler/types.pas index 6de06c0e2e..1ddacc8ae1 100644 --- a/compiler/types.pas +++ b/compiler/types.pas @@ -446,7 +446,8 @@ implementation function push_high_param(def : pdef) : boolean; begin - push_high_param:=is_open_array(def) or is_open_string(def); + push_high_param:=is_open_array(def) or is_open_string(def) or + is_array_of_const(def); end; @@ -884,7 +885,18 @@ implementation end. { $Log$ - Revision 1.64 1999-05-19 20:55:08 florian + Revision 1.65 1999-05-23 18:42:23 florian + * better error recovering in typed constants + * some problems with arrays of const fixed, some problems + due my previous + - the location type of array constructor is now LOC_MEM + - the pushing of high fixed + - parameter copying fixed + - zero temp. allocation removed + * small problem in the assembler writers fixed: + ref to nil wasn't written correctly + + Revision 1.64 1999/05/19 20:55:08 florian * fix of my previous commit Revision 1.63 1999/05/19 20:40:15 florian diff --git a/compiler/utils/nasmconv.pp b/compiler/utils/nasmconv.pp index 6f6ca327fe..a71b8132dd 100644 --- a/compiler/utils/nasmconv.pp +++ b/compiler/utils/nasmconv.pp @@ -13,7 +13,6 @@ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. **********************************************************************} -program msg2inc; program nasmconv; var @@ -295,10 +294,21 @@ begin end. { $Log$ - Revision 1.1 1999-05-12 16:17:10 peter + Revision 1.2 1999-05-23 18:42:24 florian + * better error recovering in typed constants + * some problems with arrays of const fixed, some problems + due my previous + - the location type of array constructor is now LOC_MEM + - the pushing of high fixed + - parameter copying fixed + - zero temp. allocation removed + * small problem in the assembler writers fixed: + ref to nil wasn't written correctly + + Revision 1.1 1999/05/12 16:17:10 peter * init Revision 1.1 1999/05/12 16:08:27 peter + moved compiler utils -} \ No newline at end of file +}