{ $Id$ Copyright (c) 1993,98 by Florian Klaempfl, Carl Eric Codere This unit generates 68000 (or better) assembler from the parse tree This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ****************************************************************************} {$ifdef tp} {$E+,F+,N+,D+,L+,Y+} {$endif} {---------------------------------------------------------------------------} { LEFT TO DO IN CG68k AND CG68k2 } {---------------------------------------------------------------------------} { o Test and correct problems with extended support. } { o Optimize secondmoddiv when doing a constant modulo. } { o Add emulation support for Cardinal under MC68000. } {---------------------------------------------------------------------------} unit cg68k; {***************************************************************************} interface {***************************************************************************} uses objects,verbose,cobjects,systems,globals,tree, symtable,types,strings,pass_1,hcodegen,temp_gen, aasm,m68k,tgen68k,files,cga68k,cg68k2,link {$ifdef GDB} ,gdb {$endif} ; { produces assembler for the expression in variable p } { and produces an assembler node at the end } procedure generatecode(var p : ptree); { produces the actual code } function do_secondpass(var p : ptree) : boolean; procedure secondpass(var p : ptree); {$ifdef test_dest_loc} const { used to avoid temporary assignments } dest_loc_known : boolean = false; in_dest_loc : boolean = false; dest_loc_tree : ptree = nil; var dest_loc : tlocation; procedure mov_reg_to_dest(p : ptree; s : topsize; reg : tregister); {$endif test_dest_loc} {***************************************************************************} implementation {***************************************************************************} uses scanner; const never_copy_const_param : boolean = false; bytes2Sxx:array[1..4] of Topsize=(S_B,S_W,S_NO,S_L); { used to avoid temporary assignments } dest_loc_known : boolean = false; in_dest_loc : boolean = false; dest_loc_tree : ptree = nil; var { this is for open arrays and strings } { but be careful, this data is in the } { generated code destroyed quick, and also } { the next call of secondload destroys this } { data } { So be careful using the informations } { provided by this variables } highframepointer : tregister; highoffset : longint; dest_loc : tlocation; procedure mov_reg_to_dest(p : ptree; s : topsize; reg : tregister); begin if (dest_loc.loc=LOC_CREGISTER) or (dest_loc.loc=LOC_REGISTER) then begin emit_reg_reg(A_MOVE,s,reg,dest_loc.register); p^.location:=dest_loc; in_dest_loc:=true; end else if (dest_loc.loc=LOC_REFERENCE) or (dest_loc.loc=LOC_MEM) then begin exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,s,reg,newreference(dest_loc.reference)))); p^.location:=dest_loc; in_dest_loc:=true; end else internalerror(20080); end; procedure error(const t : tmsgconst); begin if not(codegenerror) then verbose.Message(t); codegenerror:=true; end; type secondpassproc = procedure(var p : ptree); procedure seconderror(var p : ptree); begin p^.error:=true; codegenerror:=true; end; procedure secondstatement(var p : ptree); var hp : ptree; begin hp:=p; while assigned(hp) do begin { assignments could be distance optimized } if assigned(hp^.right) then begin cleartempgen; secondpass(hp^.right); end; hp:=hp^.left; end; end; procedure secondload(var p : ptree); var hregister : tregister; i : longint; symtabletype: tsymtabletype; hp : preference; begin simple_loadn:=true; reset_reference(p^.location.reference); case p^.symtableentry^.typ of { this is only for toasm and toaddr } absolutesym : begin stringdispose(p^.location.reference.symbol); p^.location.reference.symbol:=stringdup(p^.symtableentry^.mangledname); if p^.symtableentry^.owner^.symtabletype=unitsymtable then concat_external(p^.symtableentry^.mangledname,EXT_NEAR); end; varsym : begin hregister:=R_NO; symtabletype:=p^.symtable^.symtabletype; { in case it is a register variable: } { we simply set the location to the } { correct register. } 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 { --------------------- LOCAL AND TEMP VARIABLES ------------- } if (symtabletype=parasymtable) or (symtabletype=localsymtable) then begin p^.location.reference.base:=procinfo.framepointer; p^.location.reference.offset:=pvarsym(p^.symtableentry)^.address; if (symtabletype=localsymtable) then p^.location.reference.offset:=-p^.location.reference.offset; if (symtabletype=parasymtable) then inc(p^.location.reference.offset,p^.symtable^.call_offset); if (lexlevel>(p^.symtable^.symtablelevel)) then begin hregister:=getaddressreg; { make a reference } new(hp); reset_reference(hp^); hp^.offset:=procinfo.framepointer_offset; hp^.base:=procinfo.framepointer; exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,hp,hregister))); simple_loadn:=false; i:=lexlevel-1; while i>(p^.symtable^.symtablelevel) do begin { make a reference } new(hp); reset_reference(hp^); hp^.offset:=8; hp^.base:=hregister; exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,hp,hregister))); dec(i); end; p^.location.reference.base:=hregister; end; end { --------------------- END OF LOCAL AND TEMP VARS ---------------- } else case symtabletype of unitsymtable,globalsymtable, staticsymtable : begin stringdispose(p^.location.reference.symbol); p^.location.reference.symbol:=stringdup(p^.symtableentry^.mangledname); if symtabletype=unitsymtable then concat_external(p^.symtableentry^.mangledname,EXT_NEAR); end; objectsymtable : begin if (pvarsym(p^.symtableentry)^.properties and sp_static)<>0 then begin stringdispose(p^.location.reference.symbol); p^.location.reference.symbol:=stringdup(p^.symtableentry^.mangledname); if p^.symtable^.defowner^.owner^.symtabletype=unitsymtable then concat_external(p^.symtableentry^.mangledname,EXT_NEAR); end else begin p^.location.reference.base:=R_A5; p^.location.reference.offset:=pvarsym(p^.symtableentry)^.address; end; end; withsymtable : begin hregister:=getaddressreg; p^.location.reference.base:=hregister; { make a reference } new(hp); reset_reference(hp^); hp^.offset:=p^.symtable^.datasize; hp^.base:=procinfo.framepointer; exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,hp,hregister))); p^.location.reference.offset:= pvarsym(p^.symtableentry)^.address; end; end; { in case call by reference, then calculate: } if (pvarsym(p^.symtableentry)^.varspez=vs_var) or ((pvarsym(p^.symtableentry)^.varspez=vs_const) and dont_copy_const_param(pvarsym(p^.symtableentry)^.definition)) then begin simple_loadn:=false; if hregister=R_NO then hregister:=getaddressreg; { ADDED FOR OPEN ARRAY SUPPORT. } if (p^.location.reference.base=procinfo.framepointer) then begin highframepointer:=p^.location.reference.base; highoffset:=p^.location.reference.offset; end else begin highframepointer:=R_A1; highoffset:=p^.location.reference.offset; exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L, p^.location.reference.base,R_A1))); end; exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(p^.location.reference), hregister))); { END ADDITION } clear_reference(p^.location.reference); p^.location.reference.base:=hregister; end; { should be dereferenced later (FK) if (pvarsym(p^.symtableentry)^.definition^.deftype=objectdef) and ((pobjectdef(pvarsym(p^.symtableentry)^.definition)^.options and oois_class)<>0) then begin simple_loadn:=false; if hregister=R_NO then hregister:=getaddressreg; exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(p^.location.reference), hregister))); clear_reference(p^.location.reference); p^.location.reference.base:=hregister; end; } end; end; procsym: begin {!!!!! Be aware, work on virtual methods too } stringdispose(p^.location.reference.symbol); p^.location.reference.symbol:= stringdup(pprocsym(p^.symtableentry)^.definition^.mangledname); if p^.symtable^.symtabletype=unitsymtable then concat_external(p^.symtableentry^.mangledname,EXT_NEAR); end; typedconstsym : begin stringdispose(p^.location.reference.symbol); p^.location.reference.symbol:=stringdup(p^.symtableentry^.mangledname); if p^.symtable^.symtabletype=unitsymtable then concat_external(p^.symtableentry^.mangledname,EXT_NEAR); end; else internalerror(4); end; end; { D0 and D1 used as temp (ok) } procedure secondmoddiv(var p : ptree); var hreg1 : tregister; power : longint; hl : plabel; reg: tregister; pushed: boolean; hl1: plabel; begin secondpass(p^.left); set_location(p^.location,p^.left^.location); pushed:=maybe_push(p^.right^.registers32,p); secondpass(p^.right); if pushed then restore(p); { put numerator in register } if p^.left^.location.loc<>LOC_REGISTER then begin if p^.left^.location.loc=LOC_CREGISTER then begin hreg1:=getregister32; emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,hreg1); end else begin del_reference(p^.left^.location.reference); hreg1:=getregister32; exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(p^.left^.location.reference), hreg1))); end; p^.left^.location.loc:=LOC_REGISTER; p^.left^.location.register:=hreg1; end else hreg1:=p^.left^.location.register; if (p^.treetype=divn) and (p^.right^.treetype=ordconstn) and ispowerof2(p^.right^.value,power) then begin exprasmlist^.concat(new(pai68k, op_reg(A_TST, S_L, hreg1))); getlabel(hl); emitl(A_BPL,hl); if (power = 1) then exprasmlist^.concat(new(pai68k, op_const_reg(A_ADDQ, S_L,1, hreg1))) else Begin { optimize using ADDQ if possible! } if (p^.right^.value-1) < 9 then exprasmlist^.concat(new(pai68k, op_const_reg(A_ADDQ, S_L,p^.right^.value-1, hreg1))) else exprasmlist^.concat(new(pai68k, op_const_reg(A_ADD, S_L,p^.right^.value-1, hreg1))); end; emitl(A_LABEL, hl); if (power > 0) and (power < 9) then exprasmlist^.concat(new(pai68k, op_const_reg(A_ASR, S_L,power, hreg1))) else begin exprasmlist^.concat(new(pai68k, op_const_reg(A_MOVE,S_L,power, R_D0))); exprasmlist^.concat(new(pai68k, op_reg_reg(A_ASR,S_L,R_D0, hreg1))); end; end else begin { bring denominator to D1 } { D1 is always free, it's } { only used for temporary } { purposes } if (p^.right^.location.loc<>LOC_REGISTER) and (p^.right^.location.loc<>LOC_CREGISTER) then begin del_reference(p^.right^.location.reference); p^.left^.location.loc:=LOC_REGISTER; exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(p^.right^.location.reference),R_D1))); end else begin ungetregister32(p^.right^.location.register); emit_reg_reg(A_MOVE,S_L,p^.right^.location.register,R_D1); end; { on entering this section D1 should contain the divisor } if (aktoptprocessor = MC68020) then begin { Check if divisor is ZERO - if so call HALT_ERROR } { with d0 = 200 (Division by zero!) } getlabel(hl1); exprasmlist^.concat(new(pai68k,op_reg(A_TST,S_L,R_D1))); { if not zero then simply continue on } emitl(A_BNE,hl1); exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_L,200,R_D0))); emitcall('HALT_ERROR',true); emitl(A_LABEL,hl1); if (p^.treetype = modn) then Begin reg := getregister32; exprasmlist^.concat(new(pai68k,op_reg(A_CLR,S_L,reg))); getlabel(hl); { here what we do is prepare the high register with the } { correct sign. i.e we clear it, check if the low dword reg } { which will participate in the division is signed, if so we} { we extend the sign to the high doword register by inverting } { all the bits. } exprasmlist^.concat(new(pai68k,op_reg(A_TST,S_L,hreg1))); emitl(A_BPL,hl); exprasmlist^.concat(new(pai68k,op_reg(A_NOT,S_L,reg))); emitl(A_LABEL,hl); { reg:hreg1 / d1 } exprasmlist^.concat(new(pai68k,op_reg_reg_reg(A_DIVSL,S_L,R_D1,reg,hreg1))); { hreg1 already contains quotient } { looking for remainder } exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,reg,hreg1))); ungetregister32(reg); end else { simple division... } Begin { reg:hreg1 / d1 } exprasmlist^.concat(new(pai68k,op_reg_reg(A_DIVS,S_L,R_D1,hreg1))); end; end else { MC68000 operations } begin { put numerator in d0 } emit_reg_reg(A_MOVE,S_L,hreg1,R_D0); { operation to perform on entry to both } { routines... d0/d1 } { return result in d0 } if p^.treetype = divn then emitcall('LONGDIV',true) else emitcall('LONGMOD',true); emit_reg_reg(A_MOVE,S_L,R_D0,hreg1); end; { endif } end; { this registers are always used when div/mod are present } usedinproc:=usedinproc or ($800 shr word(R_D1)); usedinproc:=usedinproc or ($800 shr word(R_D0)); p^.location.loc:=LOC_REGISTER; p^.location.register:=hreg1; end; { D6 used as scratch (ok) } procedure secondshlshr(var p : ptree); var hregister1,hregister2,hregister3 : tregister; op : tasmop; pushed : boolean; begin secondpass(p^.left); pushed:=maybe_push(p^.right^.registers32,p); secondpass(p^.right); if pushed then restore(p); { load left operators in a register } if p^.left^.location.loc<>LOC_REGISTER then begin if p^.left^.location.loc=LOC_CREGISTER then begin hregister1:=getregister32; emit_reg_reg(A_MOVE,S_L,p^.left^.location.register, hregister1); end else begin del_reference(p^.left^.location.reference); hregister1:=getregister32; exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(p^.left^.location.reference), hregister1))); end; end else hregister1:=p^.left^.location.register; { determine operator } if p^.treetype=shln then op:=A_LSL else op:=A_LSR; { shifting by a constant directly decode: } if (p^.right^.treetype=ordconstn) then begin if (p^.right^.location.reference.offset and 31 > 0) and (p^.right^.location.reference.offset and 31 < 9) then exprasmlist^.concat(new(pai68k,op_const_reg(op,S_L,p^.right^.location.reference.offset and 31, hregister1))) else begin exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_L,p^.right^.location.reference.offset and 31, R_D6))); exprasmlist^.concat(new(pai68k,op_reg_reg(op,S_L,R_D6,hregister1))); end; p^.location.loc:=LOC_REGISTER; p^.location.register:=hregister1; end else begin { load right operators in a register } if p^.right^.location.loc<>LOC_REGISTER then begin if p^.right^.location.loc=LOC_CREGISTER then begin hregister2:=getregister32; emit_reg_reg(A_MOVE,S_L,p^.right^.location.register, hregister2); end else begin del_reference(p^.right^.location.reference); hregister2:=getregister32; exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(p^.right^.location.reference), hregister2))); end; end else hregister2:=p^.right^.location.register; emit_reg_reg(op,S_L,hregister2,hregister1); p^.location.register:=hregister1; end; { this register is always used when shl/shr are present } usedinproc:=usedinproc or ($800 shr byte(R_D6)); end; procedure secondrealconst(var p : ptree); var hp1 : pai; lastlabel : plabel; found : boolean; begin clear_reference(p^.location.reference); lastlabel:=nil; found:=false; { const already used ? } if p^.labnumber=-1 then begin { tries to found an old entry } hp1:=pai(consts^.first); while assigned(hp1) do begin if hp1^.typ=ait_label then lastlabel:=pai_label(hp1)^.l else begin if (hp1^.typ=p^.realtyp) and (lastlabel<>nil) then begin { Florian this caused a internalerror(10)=> no free reg !! } {if ((p^.realtyp=ait_real_64bit) and (pai_double(hp1)^.value=p^.valued)) or ((p^.realtyp=ait_real_80bit) and (pai_extended(hp1)^.value=p^.valued)) or ((p^.realtyp=ait_real_32bit) and (pai_single(hp1)^.value=p^.valued)) then } if ((p^.realtyp=ait_real_64bit) and (pai_double(hp1)^.value=p^.valued)) then found:=true; if ((p^.realtyp=ait_real_32bit) and (pai_single(hp1)^.value=p^.valued)) then found:=true; if ((p^.realtyp=ait_real_extended) and (pai_extended(hp1)^.value=p^.valued)) then found:=true; if found then begin { found! } p^.labnumber:=lastlabel^.nb; break; end; end; lastlabel:=nil; end; hp1:=pai(hp1^.next); end; { :-(, we must generate a new entry } if p^.labnumber=-1 then begin getlabel(lastlabel); p^.labnumber:=lastlabel^.nb; case p^.realtyp of ait_real_64bit : consts^.insert(new(pai_double,init(p^.valued))); ait_real_32bit : consts^.insert(new(pai_single,init(p^.valued))); ait_real_extended : consts^.insert(new(pai_extended,init(p^.valued))); else internalerror(10120); end; consts^.insert(new(pai_label,init(lastlabel))); end; end; stringdispose(p^.location.reference.symbol); p^.location.reference.symbol:=stringdup(lab2str(lastlabel)); end; procedure secondfixconst(var p : ptree); begin { an fix comma const. behaves as a memory reference } p^.location.loc:=LOC_MEM; p^.location.reference.isintvalue:=true; p^.location.reference.offset:=p^.valuef; end; procedure secondordconst(var p : ptree); begin { an integer const. behaves as a memory reference } p^.location.loc:=LOC_MEM; p^.location.reference.isintvalue:=true; p^.location.reference.offset:=p^.value; end; procedure secondniln(var p : ptree); begin p^.location.loc:=LOC_MEM; p^.location.reference.isintvalue:=true; p^.location.reference.offset:=0; end; procedure secondstringconst(var p : ptree); var hp1 : pai; lastlabel : plabel; pc : pchar; same_string : boolean; i : word; begin clear_reference(p^.location.reference); lastlabel:=nil; { const already used ? } if p^.labstrnumber=-1 then begin { tries to found an old entry } hp1:=pai(consts^.first); while assigned(hp1) do begin if hp1^.typ=ait_label then lastlabel:=pai_label(hp1)^.l else begin if (hp1^.typ=ait_string) and (lastlabel<>nil) and (pai_string(hp1)^.len=length(p^.values^)+2) then begin same_string:=true; for i:=1 to length(p^.values^) do if pai_string(hp1)^.str[i]<>p^.values^[i] then begin same_string:=false; break; end; if same_string then begin { found! } p^.labstrnumber:=lastlabel^.nb; break; end; end; lastlabel:=nil; end; hp1:=pai(hp1^.next); end; { :-(, we must generate a new entry } if p^.labstrnumber=-1 then begin getlabel(lastlabel); p^.labstrnumber:=lastlabel^.nb; getmem(pc,length(p^.values^)+3); move(p^.values^,pc^,length(p^.values^)+1); pc[length(p^.values^)+1]:=#0; { we still will have a problem if there is a #0 inside the pchar } consts^.insert(new(pai_string,init_pchar(pc))); { to overcome this problem we set the length explicitly } { with the ending null char } pai_string(consts^.first)^.len:=length(p^.values^)+2; consts^.insert(new(pai_label,init(lastlabel))); end; end; stringdispose(p^.location.reference.symbol); p^.location.reference.symbol:=stringdup(lab2str(lastlabel)); p^.location.loc := LOC_MEM; end; procedure secondumminus(var p : ptree); begin secondpass(p^.left); p^.location.loc:=LOC_REGISTER; case p^.left^.location.loc of LOC_REGISTER : begin p^.location.register:=p^.left^.location.register; exprasmlist^.concat(new(pai68k,op_reg(A_NEG,S_L,p^.location.register))); end; LOC_CREGISTER : begin p^.location.register:=getregister32; emit_reg_reg(A_MOVE,S_L,p^.location.register, p^.location.register); exprasmlist^.concat(new(pai68k,op_reg(A_NEG,S_L,p^.location.register))); end; LOC_REFERENCE,LOC_MEM : begin del_reference(p^.left^.location.reference); { change sign of a floating point } { in the case of emulation, get } { a free register, and change sign } { manually. } { otherwise simply load into an FPU} { register. } if (p^.left^.resulttype^.deftype=floatdef) and (pfloatdef(p^.left^.resulttype)^.typ<>f32bit) then begin { move to FPU } floatload(pfloatdef(p^.left^.resulttype)^.typ, p^.left^.location.reference,p^.location); if (cs_fp_emulation) in aktswitches then { if in emulation mode change sign manually } exprasmlist^.concat(new(pai68k,op_const_reg(A_BCHG,S_L,31, p^.location.fpureg))) else exprasmlist^.concat(new(pai68k,op_reg(A_FNEG,S_FX, p^.location.fpureg))); end else begin p^.location.register:=getregister32; exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L, newreference(p^.left^.location.reference), p^.location.register))); exprasmlist^.concat(new(pai68k,op_reg(A_NEG,S_L,p^.location.register))); end; end; LOC_FPU : begin p^.location.loc:=LOC_FPU; p^.location.fpureg := p^.left^.location.fpureg; if (cs_fp_emulation) in aktswitches then exprasmlist^.concat(new(pai68k,op_const_reg(A_BCHG,S_L,31,p^.location.fpureg))) else exprasmlist^.concat(new(pai68k,op_reg(A_FNEG,S_FX,p^.location.fpureg))); end; end; { emitoverflowcheck;} end; { use of A6 is required only temp (ok) } procedure secondaddr(var p : ptree); begin secondpass(p^.left); p^.location.loc:=LOC_REGISTER; 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 (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(pai68k,op_ref_reg(A_MOVE,S_L, newreference(p^.left^.location.reference), p^.location.register))) else begin exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L, newreference(p^.left^.location.reference),R_A0))); exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L, R_A0,p^.location.register))); end; { for use of other segments } { if p^.left^.location.reference.segment<>R_DEFAULT_SEG then p^.location.segment:=p^.left^.location.reference.segment; } del_reference(p^.left^.location.reference); end; { register a6 used as scratch } 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(pai68k,op_ref_reg(A_LEA,S_L, newreference(p^.left^.location.reference),R_A0))); exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L, R_A0,p^.location.register))); end; procedure secondnot(var p : ptree); const flagsinvers : array[F_E..F_BE] of tresflags = (F_NE,F_E,F_LE,F_GE,F_L,F_G,F_NC,F_C, F_A,F_AE,F_B,F_BE); var hl : plabel; begin if (p^.resulttype^.deftype=orddef) and (porddef(p^.resulttype)^.typ=bool8bit) then begin case p^.location.loc of LOC_JUMP : begin hl:=truelabel; truelabel:=falselabel; falselabel:=hl; secondpass(p^.left); maketojumpbool(p^.left); hl:=truelabel; truelabel:=falselabel; falselabel:=hl; end; LOC_FLAGS : begin secondpass(p^.left); p^.location.resflags:=flagsinvers[p^.left^.location.resflags]; end; LOC_REGISTER : begin secondpass(p^.left); p^.location.register:=p^.left^.location.register; exprasmlist^.concat(new(pai68k,op_const_reg(A_EOR,S_B,1,p^.location.register))); end; LOC_CREGISTER : begin secondpass(p^.left); p^.location.loc:=LOC_REGISTER; p^.location.register:=getregister32; emit_reg_reg(A_MOVE,S_B,p^.left^.location.register, p^.location.register); exprasmlist^.concat(new(pai68k,op_const_reg(A_EOR,S_B,1,p^.location.register))); end; LOC_REFERENCE,LOC_MEM : begin secondpass(p^.left); del_reference(p^.left^.location.reference); p^.location.loc:=LOC_REGISTER; p^.location.register:=getregister32; if p^.left^.location.loc=LOC_CREGISTER then emit_reg_reg(A_MOVE,S_B,p^.left^.location.register, p^.location.register) else exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_B, newreference(p^.left^.location.reference), p^.location.register))); exprasmlist^.concat(new(pai68k,op_const_reg(A_EOR,S_B,1,p^.location.register))); end; end; end else begin secondpass(p^.left); p^.location.loc:=LOC_REGISTER; case p^.left^.location.loc of LOC_REGISTER : begin p^.location.register:=p^.left^.location.register; exprasmlist^.concat(new(pai68k,op_reg(A_NOT,S_L,p^.location.register))); end; LOC_CREGISTER : begin p^.location.register:=getregister32; emit_reg_reg(A_MOVE,S_L,p^.left^.location.register, p^.location.register); exprasmlist^.concat(new(pai68k,op_reg(A_NOT,S_L,p^.location.register))); end; LOC_REFERENCE,LOC_MEM : begin del_reference(p^.left^.location.reference); p^.location.register:=getregister32; exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L, newreference(p^.left^.location.reference), p^.location.register))); exprasmlist^.concat(new(pai68k,op_reg(A_NOT,S_L,p^.location.register))); end; end; {if p^.left^.location.loc=loc_register then p^.location.register:=p^.left^.location.register else begin del_locref(p^.left^.location); p^.location.register:=getregister32; exprasmlist^.concat(new(pai68k,op_loc_reg(A_MOV,S_L, p^.left^.location, p^.location.register))); end; exprasmlist^.concat(new(pai68k,op_reg(A_NOT,S_L,p^.location.register)));} end; end; procedure secondnothing(var p : ptree); begin end; procedure secondassignment(var p : ptree); var opsize : topsize; withresult : boolean; otlabel,hlabel,oflabel : plabel; hregister : tregister; loc : tloc; begin otlabel:=truelabel; oflabel:=falselabel; getlabel(truelabel); getlabel(falselabel); withresult:=false; { calculate left sides } secondpass(p^.left); case p^.left^.location.loc of LOC_REFERENCE : begin { in case left operator uses too many registers } { but to few are free then LEA } if (p^.left^.location.reference.base<>R_NO) and (p^.left^.location.reference.index<>R_NO) and (usablereg32LOC_REFERENCE then internalerror(10010) else floatstore(pfloatdef(p^.left^.resulttype)^.typ, p^.right^.location,p^.left^.location.reference); end; LOC_JUMP : begin getlabel(hlabel); emitl(A_LABEL,truelabel); if loc=LOC_CREGISTER then exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_B, 1,p^.left^.location.register))) else exprasmlist^.concat(new(pai68k,op_const_ref(A_MOVE,S_B, 1,newreference(p^.left^.location.reference)))); {exprasmlist^.concat(new(pai68k,op_const_loc(A_MOV,S_B, 1,p^.left^.location)));} emitl(A_JMP,hlabel); emitl(A_LABEL,falselabel); if loc=LOC_CREGISTER then exprasmlist^.concat(new(pai68k,op_reg(A_CLR,S_B, p^.left^.location.register))) else exprasmlist^.concat(new(pai68k,op_const_ref(A_MOVE,S_B, 0,newreference(p^.left^.location.reference)))); emitl(A_LABEL,hlabel); end; LOC_FLAGS : begin if loc=LOC_CREGISTER then begin exprasmlist^.concat(new(pai68k,op_reg(flag_2_set[p^.right^.location.resflags],S_B, p^.left^.location.register))); exprasmlist^.concat(new(pai68k,op_reg(A_NEG,S_B,p^.left^.location.register))); end else begin exprasmlist^.concat(new(pai68k,op_ref(flag_2_set[p^.right^.location.resflags],S_B, newreference(p^.left^.location.reference)))); exprasmlist^.concat(new(pai68k,op_ref(A_NEG,S_B,newreference(p^.left^.location.reference)))); end; end; end; truelabel:=otlabel; falselabel:=oflabel; end; procedure secondderef(var p : ptree); var hr : tregister; begin secondpass(p^.left); clear_reference(p^.location.reference); case p^.left^.location.loc of LOC_REGISTER : Begin hr := getaddressreg; emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,hr); p^.location.reference.base:=hr; ungetregister(p^.left^.location.register); end; LOC_CREGISTER : begin { ... and reserve one for the pointer } hr:=getaddressreg; emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,hr); p^.location.reference.base:=hr; { LOC_REGISTER indicates that this is a variable register which should not be freed. } { ungetregister(p^.left^.location.register); } end; else begin { free register } del_reference(p^.left^.location.reference); { ...and reserve one for the pointer } hr:=getaddressreg; exprasmlist^.concat(new(pai68k,op_ref_reg( A_MOVE,S_L,newreference(p^.left^.location.reference), hr))); p^.location.reference.base:=hr; end; end; end; { used D0, D1 as scratch (ok) } { arrays ... } { Sets up the array and string } { references . } procedure secondvecn(var p : ptree); var pushed : boolean; ind : tregister; _p : ptree; procedure calc_emit_mul; var l1,l2 : longint; begin l1:=p^.resulttype^.size; case l1 of 1 : p^.location.reference.scalefactor:=l1; 2 : exprasmlist^.concat(new(pai68k,op_const_reg(A_LSL,S_L,1,ind))); 4 : exprasmlist^.concat(new(pai68k,op_const_reg(A_LSL,S_L,2,ind))); 8 : exprasmlist^.concat(new(pai68k,op_const_reg(A_LSL,S_L,3,ind))); else begin if ispowerof2(l1,l2) then exprasmlist^.concat(new(pai68k,op_const_reg(A_LSL,S_L,l2,ind))) else begin { use normal MC68000 signed multiply } if (l1 >= -32768) and (l1 <= 32767) then exprasmlist^.concat(new(pai68k,op_const_reg(A_MULS,S_W,l1,ind))) else { use long MC68020 long multiply } if (aktoptprocessor = MC68020) then exprasmlist^.concat(new(pai68k,op_const_reg(A_MULS,S_L,l1,ind))) else { MC68000 long multiply } begin exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_L,l1,R_D0))); exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,ind,R_D1))); emitcall('LONGMUL',true); exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_D0,ind))); end; end; end; { else case } end; { end case } end; { calc_emit_mul } var extraoffset : longint; t : ptree; hp : preference; tai:pai68k; reg: tregister; begin secondpass(p^.left); { RESULT IS IN p^.location.reference } 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, p^.resulttype^.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 Message(cg_e_illegal_expression); pushed:=maybe_push(p^.right^.registers32,p); secondpass(p^.right); if pushed then restore(p); case p^.right^.location.loc of LOC_REGISTER : begin ind:=p^.right^.location.register; case p^.right^.resulttype^.size of 1: exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L, $ff,ind))); 2: exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L, $ffff,ind))); end; end; LOC_CREGISTER : begin ind:=getregister32; emit_reg_reg(A_MOVE,S_L,p^.right^.location.register,ind); case p^.right^.resulttype^.size of 1: exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L, $ff,ind))); 2: exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L, $ffff,ind))); end; end; LOC_FLAGS: begin ind:=getregister32; exprasmlist^.concat(new(pai68k,op_reg(flag_2_set[p^.right^.location.resflags],S_B,ind))); exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L,$ff,ind))); end else { else outer case } begin del_reference(p^.right^.location.reference); ind:=getregister32; exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L, newreference(p^.right^.location.reference),ind))); {Booleans are stored in an 8 bit memory location, so the use of MOVL is not correct.} case p^.right^.resulttype^.size of 1: exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L, $ff,ind))); 2: exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L, $ffff,ind))); end; { end case } end; { end else begin } end; { produce possible range check code: } if cs_rangechecking in aktswitches then begin if p^.left^.resulttype^.deftype=arraydef then begin new(hp); reset_reference(hp^); parraydef(p^.left^.resulttype)^.genrangecheck; hp^.symbol:=stringdup('R_'+tostr(parraydef(p^.left^.resulttype)^.rangenr)); emit_bounds_check(hp^,ind); end; end; { ------------------------ HANDLE INDEXING ----------------------- } { In Motorola 680x0 mode, displacement can only be of 64K max. } { Therefore instead of doing a direct displacement, we must first } { load the new address into an address register. Therefore the } { symbol is not used. } if assigned(p^.location.reference.symbol) then begin if p^.location.reference.base <> R_NO then Message(cg_f_secondvecn_base_defined_twice); p^.location.reference.base:=getaddressreg; exprasmlist^.concat(new(pai68k,op_csymbol_reg(A_LEA,S_L,newcsymbol(p^.location.reference.symbol^,0), p^.location.reference.base))); stringdispose(p^.location.reference.symbol); end; if (p^.location.reference.index=R_NO) then begin p^.location.reference.index:=ind; calc_emit_mul; { here we must check for the offset } { and if out of bounds for the motorola } { eg: out of signed d8 then reload index } { with correct value. } if p^.location.reference.offset > 127 then begin exprasmlist^.concat(new(pai68k,op_const_reg(A_ADD,S_L,p^.location.reference.offset,ind))); p^.location.reference.offset := 0; end else if p^.location.reference.offset < -128 then begin exprasmlist^.concat(new(pai68k,op_const_reg(A_SUB,S_L,-p^.location.reference.offset,ind))); p^.location.reference.offset := 0; end; end else begin if p^.location.reference.base=R_NO then begin case p^.location.reference.scalefactor of 2 : exprasmlist^.concat(new(pai68k,op_const_reg(A_LSL,S_L,1,p^.location.reference.index))); 4 : exprasmlist^.concat(new(pai68k,op_const_reg(A_LSL,S_L,2,p^.location.reference.index))); 8 : exprasmlist^.concat(new(pai68k,op_const_reg(A_LSL,S_L,3,p^.location.reference.index))); end; calc_emit_mul; { we must use address register to put index in base } { compare with cgi386.pas } reg := getaddressreg; p^.location.reference.base := reg; emit_reg_reg(A_MOVE,S_L,p^.location.reference.index,reg); ungetregister(p^.location.reference.index); p^.location.reference.index:=ind; end else begin reg := getaddressreg; exprasmlist^.concat(new(pai68k,op_ref_reg( A_LEA,S_L,newreference(p^.location.reference), reg))); ungetregister(p^.location.reference.base); { the symbol offset is loaded, } { so release the symbol name and set symbol } { to nil } stringdispose(p^.location.reference.symbol); p^.location.reference.offset:=0; calc_emit_mul; p^.location.reference.base:=reg; ungetregister32(p^.location.reference.index); p^.location.reference.index:=ind; end; end; end; end; { *************** Converting Types **************** } { produces if necessary rangecheckcode } procedure maybe_rangechecking(p : ptree;p2,p1 : pdef); var hp : preference; hregister : tregister; neglabel,poslabel : plabel; begin { convert from p2 to p1 } { range check from enums is not made yet !!} { and its probably not easy } if (p1^.deftype<>orddef) or (p2^.deftype<>orddef) then exit; { range checking is different for u32bit } { lets try to generate it allways } if (cs_rangechecking in aktswitches) and { with $R+ explicit type conversations in TP aren't range checked! } (not(p^.explizit) or not(cs_tp_compatible in aktswitches)) and ((porddef(p1)^.low>porddef(p2)^.low) or (porddef(p1)^.highporddef(p1)^.high then begin getlabel(neglabel); getlabel(poslabel); exprasmlist^.concat(new(pai68k,op_reg(A_TST,S_L,hregister))); emitl(A_BLT,neglabel); end; emit_bounds_check(hp^,hregister); if porddef(p1)^.low>porddef(p1)^.high then begin new(hp); reset_reference(hp^); hp^.symbol:=stringdup('R_'+tostr(porddef(p1)^.rangenr+1)); emitl(A_JMP,poslabel); emitl(A_LABEL,neglabel); emit_bounds_check(hp^,hregister); emitl(A_LABEL,poslabel); end; end; end; type tsecondconvproc = procedure(p,hp : ptree;convtyp : tconverttype); procedure second_nothing(p,hp : ptree;convtyp : tconverttype); begin end; procedure second_only_rangecheck(p,hp : ptree;convtyp : tconverttype); begin maybe_rangechecking(p,hp^.resulttype,p^.resulttype); end; procedure second_bigger(p,hp : ptree;convtyp : tconverttype); var hregister : tregister; opsize : topsize; op : tasmop; is_register : boolean; begin is_register:=p^.left^.location.loc=LOC_REGISTER; if not(is_register) and (p^.left^.location.loc<>LOC_CREGISTER) then begin del_reference(p^.left^.location.reference); { we can do this here as we need no temp inside second_bigger } ungetiftemp(p^.left^.location.reference); end; { this is wrong !!! gives me movl (%eax),%eax for the length(string !!! use only for constant values } {Constanst cannot be loaded into registers using MOVZX!} if (p^.left^.location.loc<>LOC_MEM) or (not p^.left^.location.reference.isintvalue) then case convtyp of tc_u8bit_2_s32bit, tc_u8bit_2_u32bit, tc_s8bit_2_u32bit, tc_s8bit_2_s16bit, tc_s8bit_2_s32bit, tc_u8bit_2_u16bit, tc_s8bit_2_u16bit, tc_u8bit_2_s16bit: begin if is_register then hregister := p^.left^.location.register else hregister := getregister32; if is_register then emit_reg_reg(A_MOVE,S_B,p^.left^.location.register, hregister) else begin if p^.left^.location.loc = LOC_CREGISTER then emit_reg_reg(A_MOVE,S_B,p^.left^.location.register,hregister) else exprasmlist^.concat(new(pai68k, op_ref_reg(A_MOVE,S_B, newreference(P^.left^.location.reference), hregister))); end; case convtyp of tc_u8bit_2_s32bit, tc_u8bit_2_u32bit: exprasmlist^.concat(new(pai68k, op_const_reg( A_AND,S_L,$FF,hregister))); tc_s8bit_2_u32bit, tc_s8bit_2_s32bit: begin if aktoptprocessor = MC68020 then exprasmlist^.concat(new(pai68k,op_reg (A_EXTB,S_L,hregister))) else { else if aktoptprocessor } begin { byte to word } exprasmlist^.concat(new(pai68k,op_reg (A_EXT,S_W,hregister))); { word to long } exprasmlist^.concat(new(pai68k,op_reg (A_EXT,S_L,hregister))); end; end; tc_s8bit_2_u16bit, tc_u8bit_2_s16bit, tc_u8bit_2_u16bit: exprasmlist^.concat(new(pai68k, op_const_reg( A_AND,S_W,$FF,hregister))); tc_s8bit_2_s16bit: exprasmlist^.concat(new(pai68k, op_reg( A_EXT, S_W, hregister))); end; { inner case } end; tc_u16bit_2_u32bit, tc_u16bit_2_s32bit, tc_s16bit_2_u32bit, tc_s16bit_2_s32bit: begin if is_register then hregister := p^.left^.location.register else hregister := getregister32; if is_register then emit_reg_reg(A_MOVE,S_W,p^.left^.location.register, hregister) else begin if p^.left^.location.loc = LOC_CREGISTER then emit_reg_reg(A_MOVE,S_W,p^.left^.location.register,hregister) else exprasmlist^.concat(new(pai68k, op_ref_reg(A_MOVE,S_W, newreference(P^.left^.location.reference), hregister))); end; if (convtyp = tc_u16bit_2_s32bit) or (convtyp = tc_u16bit_2_u32bit) then exprasmlist^.concat(new(pai68k, op_const_reg( A_AND, S_L, $ffff, hregister))) else { tc_s16bit_2_s32bit } { tc_s16bit_2_u32bit } exprasmlist^.concat(new(pai68k, op_reg(A_EXT,S_L, hregister))); end; end { end case } else begin case convtyp of tc_u8bit_2_s32bit, tc_s8bit_2_s32bit, tc_u16bit_2_s32bit, tc_s16bit_2_s32bit, tc_u8bit_2_u32bit, tc_s8bit_2_u32bit, tc_u16bit_2_u32bit, tc_s16bit_2_u32bit: begin hregister:=getregister32; op:=A_MOVE; opsize:=S_L; end; tc_s8bit_2_u16bit, tc_s8bit_2_s16bit, tc_u8bit_2_s16bit, tc_u8bit_2_u16bit: begin hregister:=getregister32; op:=A_MOVE; opsize:=S_W; end; end; if is_register then begin emit_reg_reg(op,opsize,p^.left^.location.register,hregister); end else begin if p^.left^.location.loc=LOC_CREGISTER then emit_reg_reg(op,opsize,p^.left^.location.register,hregister) else exprasmlist^.concat(new(pai68k,op_ref_reg(op,opsize, newreference(p^.left^.location.reference),hregister))); end; end; { end elseif } p^.location.loc:=LOC_REGISTER; p^.location.register:=hregister; maybe_rangechecking(p,p^.left^.resulttype,p^.resulttype); end; procedure second_string_string(p,hp : ptree;convtyp : tconverttype); var pushedregs : tpushed; begin stringdispose(p^.location.reference.symbol); gettempofsizereference(p^.resulttype^.size,p^.location.reference); del_reference(p^.left^.location.reference); copystring(p^.location.reference,p^.left^.location.reference,pstringdef(p^.resulttype)^.len); ungetiftemp(p^.left^.location.reference); end; procedure second_cstring_charpointer(p,hp : ptree;convtyp : tconverttype); begin p^.location.loc:=LOC_REGISTER; p^.location.register:=getregister32; inc(p^.left^.location.reference.offset); exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,newreference(p^.left^.location.reference), R_A0))); emit_reg_reg(A_MOVE, S_L, R_A0, p^.location.register); end; procedure second_cchar_charpointer(p,hp : ptree;convtyp : tconverttype); begin {!!!!} p^.location.loc:=LOC_REGISTER; p^.location.register:=getregister32; inc(p^.left^.location.reference.offset); exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,newreference(p^.left^.location.reference), R_A0))); emit_reg_reg(A_MOVE, S_L, R_A0, p^.location.register); end; procedure second_string_chararray(p,hp : ptree;convtyp : tconverttype); begin inc(p^.location.reference.offset); end; procedure second_array_to_pointer(p,hp : ptree;convtyp : tconverttype); begin del_reference(p^.left^.location.reference); p^.location.loc:=LOC_REGISTER; p^.location.register:=getregister32; exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,newreference(p^.left^.location.reference), R_A0))); emit_reg_reg(A_MOVE,S_L,R_A0, P^.location.register); end; procedure second_pointer_to_array(p,hp : ptree;convtyp : tconverttype); var reg: tregister; begin p^.location.loc:=LOC_REFERENCE; clear_reference(p^.location.reference); { here, after doing some arithmetic on the pointer } { we put it back in an address register } if p^.left^.location.loc=LOC_REGISTER then begin reg := getaddressreg; { move the pointer in a data register back into } { an address register. } emit_reg_reg(A_MOVE, S_L, p^.left^.location.register,reg); p^.location.reference.base:=reg; ungetregister32(p^.left^.location.register); end else begin if p^.left^.location.loc=LOC_CREGISTER then begin p^.location.reference.base:=getaddressreg; emit_reg_reg(A_MOVE,S_L,p^.left^.location.register, p^.location.reference.base); end else begin del_reference(p^.left^.location.reference); p^.location.reference.base:=getaddressreg; exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(p^.left^.location.reference), p^.location.reference.base))); end; end; end; { generates the code for the type conversion from an array of char } { to a string } procedure second_chararray_to_string(p,hp : ptree;convtyp : tconverttype); var l : longint; begin { this is a type conversion which copies the data, so we can't } { return a reference } p^.location.loc:=LOC_MEM; { first get the memory for the string } stringdispose(p^.location.reference.symbol); gettempofsizereference(256,p^.location.reference); { calc the length of the array } l:=parraydef(p^.left^.resulttype)^.highrange- parraydef(p^.left^.resulttype)^.lowrange+1; if l>255 then Message(sym_e_type_mismatch); { write the length } exprasmlist^.concat(new(pai68k,op_const_ref(A_MOVE,S_B,l, newreference(p^.location.reference)))); { copy to first char of string } inc(p^.location.reference.offset); { generates the copy code } { and we need the source never } concatcopy(p^.left^.location.reference,p^.location.reference,l,true); { correct the string location } dec(p^.location.reference.offset); end; (* procedure second_char_to_string(p,hp : ptree;convtyp : tconverttype); begin stringdispose(p^.location.reference.symbol); gettempofsizereference(256,p^.location.reference); { is it a char const ? } if p^.left^.treetype=ordconstn then exprasmlist^.concat(new(pai68k,op_const_ref(A_MOVE,S_W,p^.left^.value*256+1,newreference(p^.location.reference)))) else begin { not so elegant (goes better with extra register } { Here the conversion is done in one shot } { i.e we convert to a string with a single word which } { will be stored, the length followed by the char } { This is of course, endian specific. } if (p^.left^.location.loc=LOC_REGISTER) or (p^.left^.location.loc=LOC_CREGISTER) then begin exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_B,p^.left^.location.register,R_D6))); exprasmlist^.concat(new(pai68k, op_const_reg(A_AND, S_W, $FF, R_D6))); ungetregister32(p^.left^.location.register); end else begin exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_B,newreference(p^.left^.location.reference),R_D6))); exprasmlist^.concat(new(pai68k, op_const_reg(A_AND, S_W, $FF, R_D6))); del_reference(p^.left^.location.reference); end; if (aktoptprocessor = MC68020) then { alignment is not a problem on the 68020 and higher processors } Begin { add length of string to word } exprasmlist^.concat(new(pai68k,op_const_reg(A_OR,S_W,$0100,R_D6))); { put back into mem ... } exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,S_W,R_D6,newreference(p^.location.reference)))); end else Begin { alignment can cause problems } { add length of string to ref } exprasmlist^.concat(new(pai68k,op_const_ref(A_MOVE,S_B,1,newreference(p^.location.reference)))); if abs(p^.location.reference.offset) >= 1 then Begin { temporarily decrease offset } Inc(p^.location.reference.offset); exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,S_B,R_D6,newreference(p^.location.reference)))); Dec(p^.location.reference.offset); { restore offset } end else Begin Comment(V_Debug,'SecondChar2String() internal error.'); internalerror(34); end; end; end; end;*) procedure second_char_to_string(p,hp : ptree;convtyp : tconverttype); begin stringdispose(p^.location.reference.symbol); gettempofsizereference(256,p^.location.reference); { call loadstring with correct left and right } p^.right:=p^.left; p^.left:=p; loadstring(p); p^.left:=nil; { reset left tree, which is empty } end; procedure second_int_real(p,hp : ptree;convtyp : tconverttype); var r : preference; reg:tregister; begin emitloadord2reg(p^.left^.location, porddef(p^.left^.resulttype), R_D6, true); ungetiftemp(p^.left^.location.reference); if porddef(p^.left^.resulttype)^.typ=u32bit then push_int(0); emit_reg_reg(A_MOVE, S_L, R_D6, R_SPPUSH); new(r); reset_reference(r^); r^.base := R_SP; { no emulation } { for u32bit a solution would be to push $0 and to load a + comp + if porddef(p^.left^.resulttype)^.typ=u32bit then + exprasmlist^.concat(new(pai386,op_ref(A_FILD,S_IQ,r))) + else} p^.location.loc := LOC_FPU; { get floating point register. } if (cs_fp_emulation in aktswitches) then begin p^.location.fpureg := getregister32; exprasmlist^.concat(new(pai68k, op_ref_reg(A_MOVE, S_L, r, R_D0))); emitcall('LONG2SINGLE',true); emit_reg_reg(A_MOVE,S_L,R_D0,p^.location.fpureg); end else begin p^.location.fpureg := getfloatreg; exprasmlist^.concat(new(pai68k, op_ref_reg(A_FMOVE, S_L, r, p^.location.fpureg))) end; if porddef(p^.left^.resulttype)^.typ=u32bit then exprasmlist^.concat(new(pai68k,op_const_reg(A_ADD,S_L,8,R_SP))) else { restore the stack to the previous address } exprasmlist^.concat(new(pai68k, op_const_reg(A_ADDQ, S_L, 4, R_SP))); end; procedure second_real_fix(p,hp : ptree;convtyp : tconverttype); var {hs : string;} rreg : tregister; ref : treference; begin rreg:=getregister32; { Are we in a LOC_FPU, if not then use scratch registers } { instead of allocating reserved registers. } if (p^.left^.location.loc<>LOC_FPU) then begin if (cs_fp_emulation in aktswitches) then begin exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(p^.left^.location.reference),R_D0))); exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_L,65536,R_D1))); emitcall('LONGMUL',true); emit_reg_reg(A_MOVE,S_L,R_D0,rreg); end else begin exprasmlist^.concat(new(pai68k,op_ref_reg(A_FMOVE,S_L,newreference(p^.left^.location.reference),R_FP0))); exprasmlist^.concat(new(pai68k,op_const_reg(A_FMUL,S_L,65536,R_FP0))); exprasmlist^.concat(new(pai68k,op_reg_reg(A_FMOVE,S_L,R_FP0,rreg))); end; end else begin if (cs_fp_emulation in aktswitches) then begin exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,p^.left^.location.fpureg,R_D0))); exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_L,65536,R_D1))); emitcall('LONGMUL',true); emit_reg_reg(A_MOVE,S_L,R_D0,rreg); end else begin exprasmlist^.concat(new(pai68k,op_const_reg(A_FMUL,S_L,65536,p^.left^.location.fpureg))); exprasmlist^.concat(new(pai68k,op_reg_reg(A_FMOVE,S_L,p^.left^.location.fpureg,rreg))); end; end; p^.location.loc:=LOC_REGISTER; p^.location.register:=rreg; end; procedure second_float_float(p,hp : ptree;convtyp : tconverttype); begin case p^.left^.location.loc of LOC_FPU : begin { reload } p^.location.loc := LOC_FPU; p^.location.fpureg := p^.left^.location.fpureg; end; LOC_MEM, LOC_REFERENCE : floatload(pfloatdef(p^.left^.resulttype)^.typ, p^.left^.location.reference,p^.location); end; { ALREADY HANDLED BY FLOATLOAD } { p^.location.loc:=LOC_FPU; } end; procedure second_fix_real(p,hp : ptree;convtyp : tconverttype); var startreg : tregister; hl : plabel; r : treference; reg1: tregister; hl1,hl2,hl3,hl4,hl5,hl6,hl7,hl8,hl9: plabel; begin if (p^.left^.location.loc=LOC_REGISTER) or (p^.left^.location.loc=LOC_CREGISTER) then begin startreg:=p^.left^.location.register; ungetregister(startreg); { move d0,d0 is removed by emit_reg_reg } emit_reg_reg(A_MOVE,S_L,startreg,R_D0); end else begin exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference( p^.left^.location.reference),R_D0))); del_reference(p^.left^.location.reference); startreg:=R_NO; end; reg1 := getregister32; { Motorola 68000 equivalent of CDQ } { we choose d1:d0 pair for quad word } exprasmlist^.concat(new(pai68k,op_reg(A_TST,S_L,R_D0))); getlabel(hl1); emitl(A_BPL,hl1); { we copy all bits (-ve number) } exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_L,$ffffffff,R_D1))); getlabel(hl2); emitl(A_BRA,hl2); emitl(A_LABEL,hl1); exprasmlist^.concat(new(pai68k,op_reg(A_CLR,S_L,R_D0))); emitl(A_LABEL,hl2); { end CDQ } exprasmlist^.concat(new(pai68k,op_reg_reg(A_EOR,S_L,R_D1,R_D0))); exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_D0,reg1))); getlabel(hl3); emitl(A_BEQ,hl3); { Motorola 68000 equivalent of RCL } getlabel(hl4); emitl(A_BCC,hl4); exprasmlist^.concat(new(pai68k,op_const_reg(A_LSL,S_L,1,reg1))); exprasmlist^.concat(new(pai68k,op_const_reg(A_OR,S_L,1,reg1))); getlabel(hl5); emitl(A_BRA,hl5); emitl(A_LABEL,hl4); exprasmlist^.concat(new(pai68k,op_const_reg(A_LSL,S_L,1,reg1))); emitl(A_LABEL,hl5); { end RCL } { Motorola 68000 equivalent of BSR } { save register } exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_D0,R_D6))); exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_B,31,R_D0))); getlabel(hl6); emitl(A_LABEL,hl6); exprasmlist^.concat(new(pai68k,op_reg_reg(A_BTST,S_L,R_D0,R_D1))); getlabel(hl7); emitl(A_BNE,hl7); exprasmlist^.concat(new(pai68k,op_const_reg(A_SUBQ,S_B,1,R_D0))); emitl(A_BPL,hl6); { restore register } exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_D6,R_D0))); emitl(A_LABEL,hl7); { end BSR } exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_B,32,R_D6))); exprasmlist^.concat(new(pai68k,op_reg_reg(A_SUB,S_B,R_D1,R_D6))); exprasmlist^.concat(new(pai68k,op_reg_reg(A_LSL,S_L,R_D6,R_D0))); exprasmlist^.concat(new(pai68k,op_const_reg(A_ADD,S_W,1007,R_D1))); exprasmlist^.concat(new(pai68k,op_const_reg(A_LSL,S_L,5,R_D1))); { Motorola 68000 equivalent of SHLD } exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_W,11,R_D6))); { save register } exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_D1,R_A0))); getlabel(hl8); emitl(A_LABEL,hl8); exprasmlist^.concat(new(pai68k,op_const_reg(A_ROXL,S_W,1,R_D1))); exprasmlist^.concat(new(pai68k,op_const_reg(A_ROXL,S_W,1,reg1))); exprasmlist^.concat(new(pai68k,op_const_reg(A_SUBQ,S_B,1,R_D6))); emitl(A_BNE,hl8); { restore register } exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_A0,R_D1))); { end Motorola equivalent of SHLD } { Motorola 68000 equivalent of SHLD } exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_W,20,R_D6))); { save register } exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_D0,R_A0))); getlabel(hl9); emitl(A_LABEL,hl9); exprasmlist^.concat(new(pai68k,op_const_reg(A_ROXL,S_W,1,R_D0))); exprasmlist^.concat(new(pai68k,op_const_reg(A_ROXL,S_W,1,reg1))); exprasmlist^.concat(new(pai68k,op_const_reg(A_SUBQ,S_B,1,R_D6))); emitl(A_BNE,hl9); { restore register } exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_A0,R_D0))); { end Motorola equivalent of SHLD } exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_B,20,R_D6))); exprasmlist^.concat(new(pai68k,op_reg_reg(A_SUB,S_L,R_D6,R_D0))); emitl(A_LABEL, hl3); { create temp values and put on stack } exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,reg1,R_SPPUSH))); exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_D0,R_SPPUSH))); reset_reference(r); r.base:=R_SP; if (cs_fp_emulation in aktswitches) then begin p^.location.loc:=LOC_FPU; p^.location.fpureg := getregister32; exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(r), p^.left^.location.fpureg))) end else begin p^.location.loc:=LOC_FPU; p^.location.fpureg := getfloatreg; exprasmlist^.concat(new(pai68k,op_ref_reg(A_FMOVE,S_L,newreference(r), p^.left^.location.fpureg))) end; { clear temporary space } exprasmlist^.concat(new(pai68k,op_const_reg(A_ADDQ,S_L,8,R_SP))); ungetregister32(reg1); { Alreadu handled above... } { p^.location.loc:=LOC_FPU; } end; procedure second_int_fix(p,hp : ptree;convtyp : tconverttype); var {hs : string;} hregister : tregister; begin if (p^.left^.location.loc=LOC_REGISTER) then hregister:=p^.left^.location.register else if (p^.left^.location.loc=LOC_CREGISTER) then hregister:=getregister32 else begin del_reference(p^.left^.location.reference); hregister:=getregister32; case porddef(p^.left^.resulttype)^.typ of s8bit : begin exprasmlist^.concat(new(pai68k, op_ref_reg(A_MOVE,S_B, newreference(p^.left^.location.reference),hregister))); if aktoptprocessor = MC68020 then exprasmlist^.concat(new(pai68k, op_reg(A_EXTB,S_L,hregister))) else begin exprasmlist^.concat(new(pai68k, op_reg(A_EXT,S_W,hregister))); exprasmlist^.concat(new(pai68k, op_reg(A_EXT,S_L,hregister))); end; end; u8bit : begin exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_B,newreference(p^.left^.location.reference), hregister))); exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L,$ff,hregister))); end; s16bit :begin exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_W,newreference(p^.left^.location.reference), hregister))); exprasmlist^.concat(new(pai68k,op_reg(A_EXT,S_L,hregister))); end; u16bit : begin exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_W,newreference(p^.left^.location.reference), hregister))); exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L,$ffff,hregister))); end; s32bit,u32bit : exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(p^.left^.location.reference), hregister))); {!!!! u32bit } end; end; exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVEQ,S_L,16,R_D1))); exprasmlist^.concat(new(pai68k,op_reg_reg(A_LSL,S_L,R_D1,hregister))); p^.location.loc:=LOC_REGISTER; p^.location.register:=hregister; end; procedure second_smaller(p,hp : ptree;convtyp : tconverttype); var hregister,destregister : tregister; {opsize : topsize;} ref : boolean; hpp : preference; begin { !!!!!!!! Rangechecking } ref:=false; { problems with enums !! } { with $R+ explicit type conversations in TP aren't range checked! } if (p^.resulttype^.deftype=orddef) and (hp^.resulttype^.deftype=orddef) and ((porddef(p^.resulttype)^.low>porddef(hp^.resulttype)^.low) or (porddef(p^.resulttype)^.hightc_bool_2_int then begin secondpass(p^.left); set_location(p^.location,p^.left^.location); end; if (p^.convtyp<>tc_equal) and (p^.convtyp<>tc_not_possible) then {the second argument only is for maybe_range_checking !} secondconvert[p^.convtyp](p,p^.left,p^.convtyp) end; { save the size of pushed parameter } var pushedparasize : longint; procedure secondcallparan(var p : ptree;defcoll : pdefcoll; push_from_left_to_right : boolean); var size : longint; stackref : treference; otlabel,hlabel,oflabel : plabel; { temporary variables: } tempdeftype : tdeftype; tempreference : treference; r : preference; s : topsize; op : tasmop; reg: tregister; 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); otlabel:=truelabel; oflabel:=falselabel; getlabel(truelabel); getlabel(falselabel); secondpass(p^.left); { in codegen.handleread.. defcoll^.data is set to nil } if assigned(defcoll^.data) and (defcoll^.data^.deftype=formaldef) then begin { allow @var } if p^.left^.treetype=addrn then begin { allways a register } exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,p^.left^.location.register,R_SPPUSH))); ungetregister32(p^.left^.location.register); end else begin if (p^.left^.location.loc<>LOC_REFERENCE) and (p^.left^.location.loc<>LOC_MEM) then Message(sym_e_type_mismatch) else begin emitpushreferenceaddr(p^.left^.location.reference); del_reference(p^.left^.location.reference); end; end; inc(pushedparasize,4); end { handle call by reference parameter } else if (defcoll^.paratyp=vs_var) then begin if (p^.left^.location.loc<>LOC_REFERENCE) then Message(cg_e_var_must_be_reference); { open array ? } { defcoll^.data can be nil for read/write } if assigned(defcoll^.data) and is_open_array(defcoll^.data) then begin { push high } if is_open_array(p^.left^.resulttype) then begin new(r); reset_reference(r^); r^.base:=highframepointer; r^.offset:=highoffset+4; exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,r,R_SPPUSH))); end else push_int(parraydef(p^.left^.resulttype)^.highrange- parraydef(p^.left^.resulttype)^.lowrange); inc(pushedparasize,4); end; emitpushreferenceaddr(p^.left^.location.reference); del_reference(p^.left^.location.reference); inc(pushedparasize,4); end else begin tempdeftype:=p^.resulttype^.deftype; if tempdeftype=filedef then Message(cg_e_file_must_call_by_reference); if (defcoll^.paratyp=vs_const) and dont_copy_const_param(p^.resulttype) then begin emitpushreferenceaddr(p^.left^.location.reference); del_reference(p^.left^.location.reference); inc(pushedparasize,4); end else case p^.left^.location.loc of LOC_REGISTER, LOC_CREGISTER : begin { HERE IS A BIG PROBLEM } { --> We *MUST* know the data size to push } { for the moment, we can say that the savesize } { indicates the parameter size to push, but } { that is CERTAINLY NOT TRUE! } { CAN WE USE LIKE LOC_MEM OR LOC_REFERENCE?? } case integer(p^.left^.resulttype^.savesize) of 1 : Begin { A byte sized value normally increments } { the SP by 2, BUT because how memory has } { been setup OR because of GAS, a byte sized } { push CRASHES the Amiga, therefore, we do it } { by hand instead. } { PUSH A WORD SHIFTED LEFT 8 } reg := getregister32; emit_reg_reg(A_MOVE, S_B, p^.left^.location.register, reg); exprasmlist^.concat(new(pai68k,op_const_reg(A_LSL,S_W, 8, reg))); exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_W, reg,R_SPPUSH))); { offset will be TWO greater } inc(pushedparasize,2); ungetregister32(reg); ungetregister32(p^.left^.location.register); end; 2 : Begin exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_W, p^.left^.location.register,R_SPPUSH))); inc(pushedparasize,2); ungetregister32(p^.left^.location.register); end; 4 : Begin exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L, p^.left^.location.register,R_SPPUSH))); inc(pushedparasize,4); ungetregister32(p^.left^.location.register); end; else Begin exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L, p^.left^.location.register,R_SPPUSH))); inc(pushedparasize,4); ungetregister32(p^.left^.location.register); end; end; { end case } end; LOC_FPU : begin size:=pfloatdef(p^.left^.resulttype)^.size; inc(pushedparasize,size); exprasmlist^.concat(new(pai68k,op_const_reg(A_SUBQ,S_L,size,R_SP))); new(r); reset_reference(r^); r^.base:=R_SP; s:=getfloatsize(pfloatdef(p^.left^.resulttype)^.typ); if (cs_fp_emulation in aktswitches) or (s=S_FS) then begin { when in emulation mode... } { only single supported!!! } exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,S_L, p^.left^.location.fpureg,r))); end else { convert back from extended to normal type } exprasmlist^.concat(new(pai68k,op_reg_ref(A_FMOVE,s, p^.left^.location.fpureg,r))); end; LOC_REFERENCE,LOC_MEM : begin tempreference:=p^.left^.location.reference; del_reference(p^.left^.location.reference); case p^.resulttype^.deftype of orddef : begin case porddef(p^.resulttype)^.typ of s32bit,u32bit : begin emit_push_mem(tempreference); inc(pushedparasize,4); end; s8bit,u8bit,uchar,bool8bit: Begin { We push a BUT, the SP is incremented by 2 } { as specified in the Motorola Prog's Ref Manual } { Therefore offet increments BY 2!!! } { BUG??? ... } { SWAP OPERANDS: } if tempreference.isintvalue then Begin exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_W, tempreference.offset shl 8,R_SPPUSH))); end else Begin { A byte sized value normally increments } { the SP by 2, BUT because how memory has } { been setup OR because of GAS, a byte sized } { push CRASHES the Amiga, therefore, we do it } { by hand instead. } { PUSH A WORD SHIFTED LEFT 8 } reg:=getregister32; exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_B, newreference(tempreference),reg))); exprasmlist^.concat(new(pai68k,op_const_reg(A_LSL,S_W, 8, reg))); exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_W, reg,R_SPPUSH))); ungetregister32(reg); { exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_W, newreference(tempreference),R_SPPUSH))); } end; inc(pushedparasize,2); end; s16bit,u16bit : begin exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_W, newreference(tempreference),R_SPPUSH))); inc(pushedparasize,2); end; end; end; floatdef : begin case pfloatdef(p^.resulttype)^.typ of f32bit, s32real : begin emit_push_mem(tempreference); inc(pushedparasize,4); end; s64real: {s64bit } begin inc(tempreference.offset,4); emit_push_mem(tempreference); dec(tempreference.offset,4); emit_push_mem(tempreference); inc(pushedparasize,8); end; {$ifdef use48} s48real : begin end; {$endif} s80real : begin Message(cg_f_extended_cg68k_not_supported); { inc(tempreference.offset,6); emit_push_mem(tempreference); dec(tempreference.offset,4); emit_push_mem(tempreference); dec(tempreference.offset,2); exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_W, newreference(tempreference),R_SPPUSH))); inc(pushedparasize,extended_size);} end; end; end; pointerdef,procvardef, enumdef,classrefdef: begin emit_push_mem(tempreference); inc(pushedparasize,4); end; arraydef,recorddef,stringdef,setdef,objectdef : begin if ((p^.resulttype^.deftype=setdef) and (psetdef(p^.resulttype)^.settype=smallset)) then begin emit_push_mem(tempreference); inc(pushedparasize,4); end else begin size:=p^.resulttype^.size; { Alignment } { if (size>=4) and ((size and 3)<>0) then inc(size,4-(size and 3)) else if (size>=2) and ((size and 1)<>0) then inc(size,2-(size and 1)) else if size=1 then size:=2; } { create stack space } if (size > 0) and (size < 9) then exprasmlist^.concat(new(pai68k,op_const_reg(A_SUBQ,S_L,size,R_SP))) else exprasmlist^.concat(new(pai68k,op_const_reg(A_SUBA, S_L,size,R_SP))); inc(pushedparasize,size); { create stack reference } stackref.symbol := nil; clear_reference(stackref); stackref.base:=R_SP; { produce copy } if p^.resulttype^.deftype=stringdef then begin copystring(stackref,p^.left^.location.reference, pstringdef(p^.resulttype)^.len); end else begin concatcopy(p^.left^.location.reference, stackref,p^.resulttype^.size,true); end; end; end; else Message(cg_e_illegal_expression); end; end; LOC_JUMP : begin getlabel(hlabel); inc(pushedparasize,2); emitl(A_LABEL,truelabel); exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_W,1,R_SPPUSH))); emitl(A_JMP,hlabel); emitl(A_LABEL,falselabel); exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_W,0,R_SPPUSH))); emitl(A_LABEL,hlabel); end; LOC_FLAGS : begin exprasmlist^.concat(new(pai68k,op_reg(flag_2_set[p^.left^.location.resflags],S_B, R_D0))); exprasmlist^.concat(new(pai68k,op_reg(A_NEG, S_B, R_D0))); exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_W,$ff, R_D0))); inc(pushedparasize,2); exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_W,R_D0,R_SPPUSH))); end; end; end; 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); end; procedure secondcalln(var p : ptree); var unusedregisters : tregisterset; pushed : tpushed; funcretref : treference; hregister : tregister; oldpushedparasize : longint; { true if a5 must be loaded again after the subroutine } loada5 : 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; pp,params : ptree; { temp register allocation } reg: tregister; { help reference pointer } ref: preference; label dont_call; begin extended_new:=false; iolabel:=nil; loada5:=true; no_virtual_call:=false; unusedregisters:=unused; if not assigned(p^.procdefinition) then exit; { 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 (cs_iocheck in aktswitches) then begin getlabel(iolabel); emitl(A_LABEL,iolabel); end else iolabel:=nil; { save all used registers } pushusedregisters(pushed,p^.procdefinition^.usedregisters); { give used registers through } usedinproc:=usedinproc or p^.procdefinition^.usedregisters; end else begin pushusedregisters(pushed,$ffff); usedinproc:=$ffff; { no IO check for methods and procedure variables } iolabel:=nil; end; { generate the code for the parameter and push them } oldpushedparasize:=pushedparasize; pushedparasize:=0; 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} gettempofsizereference(p^.procdefinition^.retdef^.size,funcretref); end; if assigned(p^.left) then begin pushedparasize:=0; { be found elsewhere } if assigned(p^.right) then secondcallparan(p^.left,pprocvardef(p^.right^.resulttype)^.para1, (p^.procdefinition^.options and poleftright)<>0) else secondcallparan(p^.left,p^.procdefinition^.para1, (p^.procdefinition^.options and poleftright)<>0); end; params:=p^.left; p^.left:=nil; if ret_in_param(p^.resulttype) then begin emitpushreferenceaddr(funcretref); inc(pushedparasize,4); end; { overloaded operator have no symtable } if (p^.right=nil) then begin { 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_A5; { make a reference } new(r); reset_reference(r^); r^.offset:=p^.symtable^.datasize; r^.base:=procinfo.framepointer; exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,r,R_A5))); 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 case p^.methodpointer^.treetype of typen : begin { direct call to inherited method } if (p^.procdefinition^.options and poabstractmethod)<>0 then begin Message(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 a5 } { it is kind of dirty but that is the simplest } { way to accept virtual static functions (PM) } loada5:=true; exprasmlist^.concat(new(pai68k,op_csymbol_reg(A_MOVE,S_L, newcsymbol(pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname,0),R_A5))); concat_external(pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname,EXT_NEAR); exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_A5,R_SPPUSH))); end else { this is a member call, so A5 isn't modfied } loada5:=false; 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(pai68k,op_reg_reg(A_MOVE,S_L,R_A5,R_SPPUSH))); { 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 ((pobjectdef(p^.methodpointer^.resulttype)^.options and oois_class)=0) and assigned(aktprocsym) then begin if not ((aktprocsym^.definition^.options and (poconstructor or podestructor))<>0) then Message(cg_w_member_cd_call_from_method); end; { con- and destructors need a pointer to the vmt } if is_con_or_destructor then begin { classes need the mem ! } if ((pobjectdef(p^.methodpointer^.resulttype)^.options and oois_class)=0) then push_int(0) else begin exprasmlist^.concat(new(pai68k,op_csymbol(A_PEA, S_L,newcsymbol(pobjectdef(p^.methodpointer^. resulttype)^.vmt_mangledname,0)))); concat_external(pobjectdef(p^.methodpointer^.resulttype)^. vmt_mangledname,EXT_NEAR); end; end; end; hnewn : begin { extended syntax of new } { A5 must be zero } exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_L,0,R_A5))); emit_reg_reg(A_MOVE,S_L,R_A5, R_SPPUSH); { insert the vmt } exprasmlist^.concat(new(pai68k,op_csymbol(A_PEA,S_L, newcsymbol(pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname,0)))); concat_external(pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname,EXT_NEAR); extended_new:=true; end; hdisposen : begin secondpass(p^.methodpointer); { destructor with extended syntax called from dispose } { hdisposen always deliver LOC_REFRENZ } exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L, newreference(p^.methodpointer^.location.reference),R_A5))); del_reference(p^.methodpointer^.location.reference); exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_A5,R_SPPUSH))); exprasmlist^.concat(new(pai68k,op_csymbol(A_PEA,S_L, newcsymbol(pobjectdef (p^.methodpointer^.resulttype)^.vmt_mangledname,0)))); concat_external(pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname,EXT_NEAR); end; else begin { call to a instance member } if (p^.symtable^.symtabletype<>withsymtable) then begin secondpass(p^.methodpointer); case p^.methodpointer^.location.loc of LOC_REGISTER : begin ungetregister32(p^.methodpointer^.location.register); emit_reg_reg(A_MOVE,S_L,p^.methodpointer^.location.register,R_A5); end; else begin if (p^.methodpointer^.resulttype^.deftype=objectdef) and pobjectdef(p^.methodpointer^.resulttype)^.isclass then exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L, newreference(p^.methodpointer^.location.reference),R_A5))) else Begin exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L, newreference(p^.methodpointer^.location.reference),R_A5))); end; del_reference(p^.methodpointer^.location.reference); end; end; end; { when calling a class method, we have to load ESI with the VMT ! But that's wrong, if we call a class method via self } if ((p^.procdefinition^.options and poclassmethod)<>0) and not(p^.methodpointer^.treetype=selfn) then begin { class method needs current VMT } new(r); reset_reference(r^); r^.base:=R_A5; exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,r,R_A5))); end; exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_A5,R_SPPUSH))); 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(pai68k,op_csymbol(A_PEA,S_L, newcsymbol(pobjectdef( p^.methodpointer^.resulttype)^.vmt_mangledname,0)))); concat_external(pobjectdef( p^.methodpointer^.resulttype)^.vmt_mangledname,EXT_NEAR); end { destructors haven't to dispose the instance, if this is } { a direct call } else push_int(0); 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_A5; exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,r,R_A5))); end else begin { member call, A5 isn't modified } loada5:=false; end; exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_A5,R_SPPUSH))); { but a con- or destructor here would probably almost } { always be placed wrong } if is_con_or_destructor then begin Message(cg_w_member_cd_call_from_method); { not insert VMT pointer } { VMT-Zeiger nicht eintragen } push_int(0); end; end; end; { push base pointer ?} if (lexlevel>1) and assigned(pprocdef(p^.procdefinition)^.parast) and ((p^.procdefinition^.parast^.symtablelevel)>2) 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(pai68k,op_reg(A_PUSH,S_L,R_ESI))); end; } if lexlevel=(p^.procdefinition^.parast^.symtablelevel) then begin new(r); reset_reference(r^); r^.offset:=procinfo.framepointer_offset; r^.base:=procinfo.framepointer; exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,r,R_SPPUSH))) end { this is only true if the difference is one !! but it cannot be more !! } else if lexlevel=(p^.procdefinition^.parast^.symtablelevel)-1 then begin exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,procinfo.framepointer,R_SPPUSH))) end else if lexlevel>(p^.procdefinition^.parast^.symtablelevel) then begin hregister:=getaddressreg; new(r); reset_reference(r^); r^.offset:=procinfo.framepointer_offset; r^.base:=procinfo.framepointer; exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,r,hregister))); for i:=(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(pai68k,op_ref_reg(A_MOVE,S_L,r,hregister))); end; exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,hregister,R_SPPUSH))); ungetregister32(hregister); end else internalerror(25000); end; { exported methods should be never called direct } if (p^.procdefinition^.options and poexports)<>0 then Message(cg_e_dont_call_exported_direct); 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 } if assigned(aktprocsym) then begin if ((aktprocsym^.properties and sp_static)<>0) or ((aktprocsym^.definition^.options and poclassmethod)<>0) or ((p^.procdefinition^.options and postaticmethod)<>0) or { A5 is already loaded } ((p^.procdefinition^.options and poclassmethod)<>0)then begin new(r); reset_reference(r^); r^.base:=R_a5; end else begin new(r); reset_reference(r^); r^.base:=R_a5; exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,r,R_a0))); new(r); reset_reference(r^); r^.base:=R_a0; end; end else begin new(r); reset_reference(r^); r^.base:=R_a5; exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,r,R_a0))); new(r); reset_reference(r^); r^.base:=R_a0; end; if p^.procdefinition^.extnumber=-1 then internalerror($Da); r^.offset:=p^.procdefinition^.extnumber*4+12; if (cs_rangechecking in aktswitches) then begin { If the base is already A0, the no instruction will } { be emitted! } emit_reg_reg(A_MOVE,S_L,r^.base,R_A0); emitcall('CHECK_OBJECT',true); end; { This was wrong we must then load the address into the } { register a0 and/or a5 } { Because doing an indirect call with offset is NOT } { allowed on the m68k! } exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(r^),R_A0))); { clear the reference } reset_reference(r^); r^.base := R_A0; exprasmlist^.concat(new(pai68k,op_ref(A_JSR,S_NO,r))); end else emitcall(p^.procdefinition^.mangledname, p^.symtableproc^.symtabletype=unitsymtable); if ((p^.procdefinition^.options and poclearstack)<>0) then begin if (pushedparasize > 0) and (pushedparasize < 9) then { restore the stack, to its initial value } exprasmlist^.concat(new(pai68k,op_const_reg(A_ADDQ,S_L,pushedparasize,R_SP))) else { restore the stack, to its initial value } exprasmlist^.concat(new(pai68k,op_const_reg(A_ADDA,S_L,pushedparasize,R_SP))); end; end else begin secondpass(p^.right); case p^.right^.location.loc of LOC_REGISTER, LOC_CREGISTER : begin if p^.right^.location.register in [R_D0..R_D7] then begin reg := getaddressreg; emit_reg_reg(A_MOVE,S_L,p^.right^.location.register,reg); new(ref); reset_reference(ref^); ref^.base := reg; exprasmlist^.concat(new(pai68k,op_ref(A_JSR,S_NO,ref))); ungetregister(reg); end else begin new(ref); reset_reference(ref^); ref^.base := p^.right^.location.register; exprasmlist^.concat(new(pai68k,op_ref(A_JSR,S_NO,ref))); end; ungetregister32(p^.right^.location.register); end else begin if assigned(p^.right^.location.reference.symbol) then { Here we have a symbolic name to the routine, so solve } { problem by loading the address first, and then emitting } { the call. } begin exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L, newreference(p^.right^.location.reference),R_A1))); new(ref); reset_reference(ref^); ref^.base := R_A1; exprasmlist^.concat(new(pai68k,op_ref(A_JSR,S_NO,newreference(ref^)))); end else begin exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L, newreference(p^.right^.location.reference),R_A1))); new(ref); reset_reference(ref^); ref^.base := R_A1; exprasmlist^.concat(new(pai68k,op_ref(A_JSR,S_NO,newreference(ref^)))); end; del_reference(p^.right^.location.reference); end; end; end; dont_call: pushedparasize:=oldpushedparasize; unused:=unusedregisters; { handle function results } if p^.resulttype<>pdef(voiddef) 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} hregister:=getregister32; emit_reg_reg(A_MOVE,S_L,R_D0,hregister); p^.location.register:=hregister; 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; end else begin if (p^.resulttype^.deftype=orddef) then begin p^.location.loc:=LOC_REGISTER; case porddef(p^.resulttype)^.typ of s32bit,u32bit : begin hregister:=getregister32; emit_reg_reg(A_MOVE,S_L,R_D0,hregister); p^.location.register:=hregister; end; uchar,u8bit,bool8bit,s8bit : begin hregister:=getregister32; emit_reg_reg(A_MOVE,S_B,R_D0,hregister); p^.location.register:=hregister; end; s16bit,u16bit : begin hregister:=getregister32; emit_reg_reg(A_MOVE,S_L,R_D0,hregister); p^.location.register:=hregister; 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; hregister:=getregister32; emit_reg_reg(A_MOVE,S_L,R_D0,hregister); p^.location.register:=hregister; end; s32real : Begin p^.location.loc:=LOC_FPU; hregister:=getregister32; emit_reg_reg(A_MOVE,S_L,R_D0,hregister); p^.location.fpureg:=hregister; end; s64bit,s64real,s80real: begin if cs_fp_emulation in aktswitches then begin p^.location.loc:=LOC_FPU; hregister:=getregister32; emit_reg_reg(A_MOVE,S_L,R_D0,hregister); p^.location.fpureg:=hregister; end else begin { TRUE FPU mode } p^.location.loc:=LOC_FPU; { on exit of function result in R_FP0 } p^.location.fpureg:=R_FP0; end; end; else begin p^.location.loc:=LOC_FPU; p^.location.fpureg:=R_FP0; end; end {end case } else begin p^.location.loc:=LOC_REGISTER; hregister:=getregister32; emit_reg_reg(A_MOVE,S_L,R_D0,hregister); p^.location.register:=hregister; end; end; end; { perhaps i/o check ? } if iolabel<>nil then begin exprasmlist^.concat(new(pai68k,op_csymbol(A_PEA,S_L,newcsymbol(lab2str(iolabel),0)))); { this was wrong, probably an error due to diff3 emitcall(p^.procdefinition^.mangledname);} emitcall('IOCHECK',true); end; { restore registers } popusedregisters(pushed); { at last, restore instance pointer (SELF) } if loada5 then maybe_loada5; pp:=params; while assigned(pp) do begin if assigned(pp^.left) then if (pp^.left^.location.loc=LOC_REFERENCE) or (pp^.left^.location.loc=LOC_MEM) then ungetiftemp(pp^.left^.location.reference); pp:=pp^.right; end; disposetree(params); end; { 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; procedure secondloadvmt(var p : ptree); begin p^.location.loc:=LOC_REGISTER; p^.location.register:=getregister32; exprasmlist^.concat(new(pai68k,op_csymbol_reg(A_MOVE, S_L,newcsymbol(pobjectdef(pclassrefdef(p^.resulttype)^.definition)^.vmt_mangledname,0), p^.location.register))); end; procedure secondinline(var p : ptree); const {$ifdef OLDINC} in2size:array[in_inc_byte..in_dec_dword] of Topsize= (S_B,S_W,S_L,S_B,S_W,S_L); in2instr:array[in_inc_byte..in_dec_dword] of Tasmop= (A_ADDQ,A_ADDQ,A_ADDQ,A_SUBQ,A_SUBQ,A_SUBQ); {$endif} { tfloattype = (f32bit,s32real,s64real,s80real,s64bit); } float_name: array[tfloattype] of string[8]= { ('FIXED','SINGLE','REAL','EXTENDED','COMP','FIXED'); } { Since we only support the REAL (SINGLE IEEE) FLOAT } { type, here is what we do... } ('FIXED','REAL','REAL','REAL','COMP','FIXED'); addsubop:array[in_inc_x..in_dec_x] of tasmop=(A_ADDQ,A_SUBQ); var opsize: topsize; asmop: tasmop; aktfile : treference; ft : tfiletype; pushed : tpushed; dummycoll : tdefcoll; procedure handlereadwrite(doread,doln : boolean); { produces code for READ(LN) and WRITE(LN) } procedure loadstream; const io:array[0..1] of string[7]=('_OUTPUT','_INPUT'); var r : preference; begin new(r); reset_reference(r^); r^.symbol:=stringdup('U_'+upper(target_info.system_unit)+io[byte(doread)]); if not (cs_compilesystem in aktswitches) then concat_external(r^.symbol^,EXT_NEAR); exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,r,R_A0))) end; var node,hp : ptree; typedtyp,pararesult : pdef; has_length : boolean; dummycoll : tdefcoll; iolabel : plabel; npara : longint; begin { I/O check } if cs_iocheck in aktswitches then begin getlabel(iolabel); emitl(A_LABEL,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 @Dateivarible in temporary variable } exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,S_L,R_A0,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 } { reference in tempor„re Variable retten } if node^.left^.location.loc<>LOC_REFERENCE then begin Message(cg_e_illegal_expression); exit; end; exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,newreference(node^.left^.location.reference),R_A0))); { skip to the next parameter } node:=node^.right; end else begin { load stdin/stdout stream } loadstream; end; { save @Dateivarible in temporary variable } exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,S_L,R_A0,newreference(aktfile)))); if doread then { parameter by READ gives call by reference } dummycoll.paratyp:=vs_var else { an WRITE Call by "Const" } dummycoll.paratyp:=vs_const; { because of secondcallparan, which otherwise attaches } if ft=ft_typed then begin { this is to avoid copy of simple const parameters } dummycoll.data:=new(pformaldef,init); { use var for write also } { avoids problems with const passed by value } { but will not accept untyped const } { dummycoll.paratyp:=vs_var; } end else { I think, this isn't a good solution (FK) } dummycoll.data:=nil; while assigned(node) do begin pushusedregisters(pushed,$ffff); hp:=node; node:=node^.right; hp^.right:=nil; if hp^.is_colon_para then Message(parser_e_illegal_colon_qualifier); if hp^.is_colon_para then Message(parser_e_illegal_colon_qualifier); if ft=ft_typed then never_copy_const_param:=true; secondcallparan(hp,@dummycoll,false); if ft=ft_typed then never_copy_const_param:=false; 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('TYPED_READ',true) else emitcall('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); 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); hp^.right:=node; if pararesult^.deftype<>floatdef then Message(parser_e_illegal_colon_qualifier); if codegenerror then exit; end else begin if hp^.left^.resulttype^.deftype=floatdef then push_int(-1); end; end; case pararesult^.deftype of stringdef : begin if doread then begin { push maximum string length } push_int(pstringdef(pararesult)^.len); case pstringdef(pararesult)^.string_typ of shortstring: emitcall ('READ_TEXT_STRING',true); ansistring : emitcall ('READ_TEXT_ANSISTRING',true); longstring : emitcall ('READ_TEXT_LONGSTRING',true); widestring : emitcall ('READ_TEXT_ANSISTRING',true); end end else Case pstringdef(Pararesult)^.string_typ of shortstring: emitcall ('WRITE_TEXT_STRING',true); ansistring : emitcall ('WRITE_TEXT_ANSISTRING',true); longstring : emitcall ('WRITE_TEXT_LONGSTRING',true); widestring : emitcall ('WRITE_TEXT_ANSISTRING',true); end; end; pointerdef : begin if is_equal(ppointerdef(pararesult)^.definition,cchardef) then begin if doread then emitcall('READ_TEXT_PCHAR_AS_POINTER',true) else emitcall('WRITE_TEXT_PCHAR_AS_POINTER',true); end else Message(parser_e_illegal_parameter_list); end; arraydef : begin if (parraydef(pararesult)^.lowrange=0) and is_equal(parraydef(pararesult)^.definition,cchardef) then begin if doread then emitcall('READ_TEXT_PCHAR_AS_ARRAY',true) else emitcall('WRITE_TEXT_PCHAR_AS_ARRAY',true); end else Message(parser_e_illegal_parameter_list); end; floatdef : begin if doread then emitcall('READ_TEXT_'+float_name[pfloatdef(pararesult)^.typ],true) else emitcall('WRITE_TEXT_'+float_name[pfloatdef(pararesult)^.typ],true); end; orddef : begin case porddef(pararesult)^.typ of u8bit : if doread then emitcall('READ_TEXT_BYTE',true); s8bit : if doread then emitcall('READ_TEXT_SHORTINT',true); u16bit : if doread then emitcall('READ_TEXT_WORD',true); s16bit : if doread then emitcall('READ_TEXT_INTEGER',true); s32bit : if doread then emitcall('READ_TEXT_LONGINT',true) else emitcall('WRITE_TEXT_LONGINT',true); u32bit : if doread then emitcall('READ_TEXT_CARDINAL',true) else emitcall('WRITE_TEXT_CARDINAL',true); uchar : if doread then emitcall('READ_TEXT_CHAR',true) else emitcall('WRITE_TEXT_CHAR',true); bool8bit, bool16bit, bool32bit : if doread then { emitcall('READ_TEXT_BOOLEAN',true) } Message(parser_e_illegal_parameter_list) else emitcall('WRITE_TEXT_BOOLEAN',true); else Message(parser_e_illegal_parameter_list); end; end; else Message(parser_e_illegal_parameter_list); end; end; { load A5 in methods again } popusedregisters(pushed); maybe_loada5; end; end; { Insert end of writing for textfiles } if ft=ft_text then begin pushusedregisters(pushed,$ffff); emit_push_mem(aktfile); if doread then begin if doln then emitcall('READLN_END',true) else emitcall('READ_END',true); end else begin if doln then emitcall('WRITELN_END',true) else emitcall('WRITE_END',true); end; popusedregisters(pushed); maybe_loada5; end; { Insert IOCheck if set } if iolabel<>nil then begin { registers are saved in the procedure } exprasmlist^.concat(new(pai68k,op_csymbol(A_PEA,S_L,newcsymbol(lab2str(iolabel),0)))); emitcall('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 Message(cg_f_internal_error_in_secondinline); hp:=p^.left; while assigned(hp) do begin if assigned(hp^.left) then if (hp^.left^.location.loc=LOC_REFERENCE) or (hp^.left^.location.loc=LOC_MEM) then ungetiftemp(hp^.left^.location.reference); hp:=hp^.right; end; end; end; procedure handle_str; var hp,node,lentree,paratree : ptree; dummycoll : tdefcoll; is_real,has_length : boolean; real_type : byte; begin pushusedregisters(pushed,$ffff); 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 is_real:=true; node:=p^.left; { we have at least two args } { with at max 2 colon_para in between } { first arg longint or float } hp:=node; node:=node^.right; hp^.right:=nil; dummycoll.data:=hp^.resulttype; { string arg } dummycoll.paratyp:=vs_var; secondcallparan(hp,@dummycoll,false); if codegenerror then exit; dummycoll.paratyp:=vs_const; { second arg } hp:=node; node:=node^.right; hp^.right:=nil; { 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); if codegenerror then exit; 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); if codegenerror then exit; hp:=node; node:=node^.right; hp^.right:=nil; end else if is_real then push_int(-32767) else push_int(-1); { last arg longint or real } secondcallparan(hp,@dummycoll,false); if codegenerror then exit; if is_real then emitcall('STR_'+float_name[pfloatdef(hp^.resulttype)^.typ],true) else if porddef(hp^.resulttype)^.typ=u32bit then emitcall('STR_CARDINAL',true) else emitcall('STR_LONGINT',true); popusedregisters(pushed); end; var r : preference; {inc/dec} addconstant : boolean; addvalue : longint; hregister : tregister; begin case p^.inlinenumber of 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:=getregister32; emit_reg_reg(A_MOVE,S_W,p^.left^.location.register, p^.location.register); end else begin del_reference(p^.left^.location.reference); p^.location.register:=getregister32; exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,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(pai68k,op_const_reg(A_LSR,S_W,8,p^.location.register))); p^.location.register:=p^.location.register; end; in_high_x : begin if is_open_array(p^.left^.resulttype) then begin secondpass(p^.left); del_reference(p^.left^.location.reference); p^.location.register:=getregister32; new(r); reset_reference(r^); r^.base:=highframepointer; r^.offset:=highoffset+4; exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L, r,p^.location.register))); end end; in_sizeof_x, in_typeof_x: begin { load vmt } if p^.left^.treetype=typen then begin p^.location.register:=getregister32; exprasmlist^.concat(new(pai68k,op_csymbol_reg(A_MOVE, S_L,newcsymbol(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 } exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,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^); { load the address in A0 } { because now supposedly p^.location.register is an } { address. } emit_reg_reg(A_MOVE, S_L, p^.location.register, R_A0); r^.base:=R_A0; exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,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_MOVE,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(pai68k,op_ref_reg(A_MOVE,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 begin exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVEQ, S_L, 16, R_D1))); exprasmlist^.concat(new(pai68k,op_reg_reg(A_LSR,S_L,R_D1,p^.location.register))); end; p^.location.register:=p^.location.register; end; in_length_string : begin secondpass(p^.left); set_location(p^.location,p^.left^.location); 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; 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 hregister:=getregister32; exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,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(pai68k,op_const_reg(A_MULS,opsize, addvalue,hregister))); addconstant:=false; end; end; { write the add instruction } if addconstant then begin exprasmlist^.concat(new(pai68k,op_const_ref(addsubop[p^.inlinenumber],opsize, addvalue,newreference(p^.left^.left^.location.reference)))); end else begin exprasmlist^.concat(new(pai68k,op_reg_ref(addsubop[p^.inlinenumber],opsize, hregister,newreference(p^.left^.left^.location.reference)))); ungetregister32(hregister); end; emitoverflowcheck(p^.left^.left); end; {$ifdef OLDINC} in_inc_byte..in_dec_dword: begin secondpass(p^.left); exprasmlist^.concat(new(pai68k,op_const_ref(in2instr[p^.inlinenumber], in2size[p^.inlinenumber],1,newreference(p^.left^.location.reference)))); emitoverflowcheck(p^.left); end; {$endif} in_pred_x, in_succ_x: begin secondpass(p^.left); 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^.left^.location.loc=LOC_CREGISTER then emit_reg_reg(A_MOVE,opsize,p^.left^.location.register, p^.location.register) else if p^.left^.location.loc=LOC_FLAGS then exprasmlist^.concat(new(pai68k,op_reg(flag_2_set[p^.left^.location.resflags],S_NO, p^.location.register))) else begin del_reference(p^.left^.location.reference); exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,opsize,newreference(p^.left^.location.reference), p^.location.register))); end; end else p^.location.register:=p^.left^.location.register; exprasmlist^.concat(new(pai68k,op_const_reg(asmop,opsize,1, p^.location.register))) { here we should insert bounds check ? } { and direct call to bounds will crash the program } { if we are at the limit } { we could also simply say that pred(first)=first and succ(last)=last } { could this be usefull I don't think so (PM) emitoverflowcheck;} end; in_assigned_x: begin secondpass(p^.left^.left); p^.location.loc:=LOC_FLAGS; if (p^.left^.left^.location.loc=LOC_REGISTER) or (p^.left^.left^.location.loc=LOC_CREGISTER) then begin exprasmlist^.concat(new(pai68k,op_reg(A_TST,S_L, p^.left^.left^.location.register))); ungetregister32(p^.left^.left^.location.register); end else begin exprasmlist^.concat(new(pai68k,op_ref(A_TST,S_L, 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(pushed,$ffff); exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_L, pfiledef(p^.left^.resulttype)^.typed_as^.size,R_SPPUSH))); secondload(p^.left); emitpushreferenceaddr(p^.left^.location.reference); if p^.inlinenumber=in_reset_typedfile then emitcall('RESET_TYPED',true) else emitcall('REWRITE_TYPED',true); popusedregisters(pushed); end; in_write_x : handlereadwrite(false,false); in_writeln_x : handlereadwrite(false,true); in_read_x : handlereadwrite(true,false); in_readln_x : handlereadwrite(true,true); in_str_x_string : begin handle_str; maybe_loada5; end; else internalerror(9); end; end; 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 clear_reference(p^.location.reference); case p^.left^.location.loc of LOC_REGISTER: begin { move it to an address register...} hr:=getaddressreg; emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,hr); p^.location.reference.base:=hr; { free register } ungetregister(p^.left^.location.register); end; LOC_CREGISTER: begin { ... and reserve one for the pointer } hr:=getaddressreg; emit_reg_reg(A_MOVE,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:=getaddressreg; exprasmlist^.concat(new(pai68k,op_ref_reg( A_MOVE,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; procedure secondselfn(var p : ptree); begin clear_reference(p^.location.reference); p^.location.reference.base:=R_A5; end; procedure secondhdisposen(var p : ptree); begin secondpass(p^.left); if codegenerror then exit; clear_reference(p^.location.reference); case p^.left^.location.loc of LOC_REGISTER, LOC_CREGISTER : begin p^.location.reference.base:=getaddressreg; exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L, p^.left^.location.register, p^.location.reference.base))); end; LOC_MEM,LOC_REFERENCE : begin del_reference(p^.left^.location.reference); p^.location.reference.base:=getaddressreg; exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(p^.left^.location.reference), p^.location.reference.base))); end; end; end; procedure secondhnewn(var p : ptree); begin end; procedure secondnewn(var p : ptree); begin secondpass(p^.left); if codegenerror then exit; p^.location.register:=p^.left^.location.register; end; procedure secondsimplenewdispose(var p : ptree); var pushed : tpushed; begin secondpass(p^.left); if codegenerror then exit; pushusedregisters(pushed,$ffff); { 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(pai68k,op_reg_reg(A_MOVE,S_L, p^.left^.location.register,R_SPPUSH))); LOC_REFERENCE : emitpushreferenceaddr(p^.left^.location.reference); end; { call the mem handling procedures } case p^.treetype of simpledisposen : emitcall('FREEMEM',true); simplenewn : emitcall('GETMEM',true); end; popusedregisters(pushed); { may be load ESI } maybe_loada5; end; procedure secondsetcons(var p : ptree); var l : plabel; i,smallsetvalue : longint; hp : ptree; href,sref : treference; hl1,hl2: plabel; j: byte; begin { this should be reimplemented for smallsets } { differently (PM) } { produce constant part } j:=0; href.symbol := Nil; clear_reference(href); getlabel(l); href.symbol:=stringdup(lab2str(l)); stringdispose(p^.location.reference.symbol); datasegment^.concat(new(pai_label,init(l))); {if psetdef(p^.resulttype)=smallset then begin smallsetvalue:=(p^.constset^[3]*256)+p^.constset^[2]; smallsetvalue:=((smallset*256+p^.constset^[1])*256+p^.constset^[1]; datasegment^.concat(new(pai_const,init_32bit(smallsetvalue))); hp:=p^.left; if assigned(hp) then begin sref.symbol:=nil; gettempofsizereference(32,sref); concatcopy(href,sref,32,false); while assigned(hp) do begin secondpass(hp^.left); if codegenerror then exit; pushsetelement(hp^.left); emitpushreferenceaddr(sref); register is save in subroutine emitcall('SET_SET_BYTE',true); hp:=hp^.right; end; p^.location.reference:=sref; end else p^.location.reference:=href; end else } begin for i:=0 to (31 div 4) do Begin { This is required because of the ENDIAN of m68k machines } datasegment^.concat(new(pai_const,init_8bit(p^.constset^[j+3]))); datasegment^.concat(new(pai_const,init_8bit(p^.constset^[j+2]))); datasegment^.concat(new(pai_const,init_8bit(p^.constset^[j+1]))); datasegment^.concat(new(pai_const,init_8bit(p^.constset^[j]))); Inc(j,4); { datasegment^.concat(new(pai_const,init_8bit(p^.constset^[i])));} end; hp:=p^.left; if assigned(hp) then begin sref.symbol:=nil; gettempofsizereference(32,sref); concatcopy(href,sref,32,false); while assigned(hp) do begin secondpass(hp^.left); if codegenerror then exit; loadsetelement(hp^.left); exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L, newreference(sref),R_A0)));; { emitpushreferenceaddr(sref); } { register is save in subroutine } emitcall('SET_SET_BYTE',true); hp:=hp^.right; end; p^.location.reference:=sref; end else p^.location.reference:=href; end; end; procedure secondcontinuen(var p : ptree); begin if aktcontinuelabel<>nil then emitl(A_JMP,aktcontinuelabel) else Message(cg_e_continue_not_allowed); end; { var hs : string; } procedure secondexitn(var p : ptree); var is_mem : boolean; {op : tasmop; s : topsize;} otlabel,oflabel : plabel; label do_jmp; begin if assigned(p^.left) then begin otlabel:=truelabel; oflabel:=falselabel; getlabel(truelabel); getlabel(falselabel); secondpass(p^.left); case p^.left^.location.loc of LOC_FPU : goto do_jmp; LOC_MEM,LOC_REFERENCE : is_mem:=true; LOC_CREGISTER, LOC_REGISTER : is_mem:=false; LOC_FLAGS : begin exprasmlist^.concat(new(pai68k,op_reg(flag_2_set[p^.right^.location.resflags],S_B,R_D0))); exprasmlist^.concat(new(pai68k,op_reg(A_NEG, S_B, R_D0))); goto do_jmp; end; LOC_JUMP : begin emitl(A_LABEL,truelabel); exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_B,1,R_D0))); emitl(A_JMP,aktexit2label); exprasmlist^.concat(new(pai68k,op_reg(A_CLR,S_B,R_D0))); goto do_jmp; end; else internalerror(2001); end; if (procinfo.retdef^.deftype=orddef) then begin case porddef(procinfo.retdef)^.typ of s32bit,u32bit : if is_mem then exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L, newreference(p^.left^.location.reference),R_D0))) else emit_reg_reg(A_MOVE,S_L, p^.left^.location.register,R_D0); u8bit,s8bit,uchar,bool8bit : if is_mem then exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_B, newreference(p^.left^.location.reference),R_D0))) else emit_reg_reg(A_MOVE,S_B, p^.left^.location.register,R_D0); s16bit,u16bit : if is_mem then exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_W, newreference(p^.left^.location.reference),R_D0))) else emit_reg_reg(A_MOVE,S_W, p^.left^.location.register,R_D0); end; end else if (procinfo.retdef^.deftype in [pointerdef,enumdef,procvardef]) then begin if is_mem then exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L, newreference(p^.left^.location.reference),R_D0))) else exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L, p^.left^.location.register,R_D0))); end else if (procinfo.retdef^.deftype=floatdef) then { floating point return values .... } { single are returned in d0 } begin if (pfloatdef(procinfo.retdef)^.typ=f32bit) or (pfloatdef(procinfo.retdef)^.typ=s32real) then begin if is_mem then exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L, newreference(p^.left^.location.reference),R_D0))) else begin if pfloatdef(procinfo.retdef)^.typ=f32bit then emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,R_D0) else begin { single values are in the floating point registers } if cs_fp_emulation in aktswitches then emit_reg_reg(A_MOVE,S_L,p^.left^.location.fpureg,R_D0) else exprasmlist^.concat(new(pai68k,op_reg_reg(A_FMOVE,S_FS, p^.left^.location.fpureg,R_D0))); end; end; end else Begin { this is only possible in real non emulation mode } { LOC_MEM,LOC_REFERENCE } if is_mem then begin exprasmlist^.concat(new(pai68k,op_ref_reg(A_FMOVE, getfloatsize(pfloatdef(procinfo.retdef)^.typ), newreference(p^.left^.location.reference),R_FP0))); end else { LOC_FPU } begin { convert from extended to correct type } { when storing } exprasmlist^.concat(new(pai68k,op_reg_reg(A_FMOVE, getfloatsize(pfloatdef(procinfo.retdef)^.typ),p^.left^.location.fpureg,R_FP0))); end; end; end; do_jmp: truelabel:=otlabel; falselabel:=oflabel; emitl(A_JMP,aktexit2label); end else begin emitl(A_JMP,aktexitlabel); end; end; procedure secondgoto(var p : ptree); begin emitl(A_JMP,p^.labelnr); end; procedure secondlabel(var p : ptree); begin emitl(A_LABEL,p^.labelnr); cleartempgen; secondpass(p^.left); end; procedure secondasm(var p : ptree); begin exprasmlist^.concatlist(p^.p_asm); end; procedure secondcase(var p : ptree); var with_sign : boolean; opsize : topsize; jmp_gt,jmp_le,jmp_lee : tasmop; hp : ptree; { register with case expression } hregister : tregister; endlabel,elselabel : plabel; { true, if we can omit the range check of the jump table } jumptable_no_range : boolean; procedure gentreejmp(p : pcaserecord); var lesslabel,greaterlabel : plabel; begin emitl(A_LABEL,p^._at); { calculate labels for left and right } if (p^.less=nil) then lesslabel:=elselabel else lesslabel:=p^.less^._at; if (p^.greater=nil) then greaterlabel:=elselabel else greaterlabel:=p^.greater^._at; { calculate labels for left and right } { no range label: } if p^._low=p^._high then begin exprasmlist^.concat(new(pai68k,op_const_reg(A_CMP,opsize,p^._low,hregister))); if greaterlabel=lesslabel then begin emitl(A_BNE,lesslabel); end else begin emitl(jmp_le,lesslabel); emitl(jmp_gt,greaterlabel); end; emitl(A_JMP,p^.statement); end else begin exprasmlist^.concat(new(pai68k,op_const_reg(A_CMP,opsize,p^._low,hregister))); emitl(jmp_le,lesslabel); exprasmlist^.concat(new(pai68k,op_const_reg(A_CMP,opsize,p^._high,hregister))); emitl(jmp_gt,greaterlabel); emitl(A_JMP,p^.statement); end; if assigned(p^.less) then gentreejmp(p^.less); if assigned(p^.greater) then gentreejmp(p^.greater); end; procedure genlinearlist(hp : pcaserecord); var first : boolean; last : longint; procedure genitem(t : pcaserecord); begin if assigned(t^.less) then genitem(t^.less); if t^._low=t^._high then begin if (t^._low-last > 0) and (t^._low-last < 9) then exprasmlist^.concat(new(pai68k,op_const_reg(A_SUBQ,opsize,t^._low-last,hregister))) else if (t^._low-last = 0) then exprasmlist^.concat(new(pai68k,op_reg(A_TST,opsize,hregister))) else exprasmlist^.concat(new(pai68k,op_const_reg(A_SUB,opsize,t^._low-last,hregister))); last:=t^._low; emitl(A_BEQ,t^.statement); end else begin { it begins with the smallest label, if the value } { is even smaller then jump immediately to the } { ELSE-label } if first then begin if (t^._low-1 > 0) and (t^._low < 9) then exprasmlist^.concat(new(pai68k,op_const_reg(A_SUBQ,opsize,t^._low-1,hregister))) else if t^._low-1=0 then exprasmlist^.concat(new(pai68k,op_reg(A_TST,opsize,hregister))) else exprasmlist^.concat(new(pai68k,op_const_reg(A_SUB,opsize,t^._low-1,hregister))); if t^._low = 0 then emitl(A_BLE,elselabel) else emitl(jmp_lee,elselabel); end { if there is no unused label between the last and the } { present label then the lower limit can be checked } { immediately. else check the range in between: } else if (t^._low-last>1)then begin if ((t^._low-last-1) > 0) and ((t^._low-last-1) < 9) then exprasmlist^.concat(new(pai68k,op_const_reg(A_SUBQ,opsize,t^._low-last-1,hregister))) else exprasmlist^.concat(new(pai68k,op_const_reg(A_SUB,opsize,t^._low-last-1,hregister))); emitl(jmp_lee,elselabel); end; exprasmlist^.concat(new(pai68k,op_const_reg(A_SUB,opsize,t^._high-t^._low+1,hregister))); emitl(jmp_lee,t^.statement); last:=t^._high; end; first:=false; if assigned(t^.greater) then genitem(t^.greater); end; var hr : tregister; begin { case register is modified by the list evalution } if (p^.left^.location.loc=LOC_CREGISTER) then begin hr:=getregister32; end; last:=0; first:=true; genitem(hp); emitl(A_JMP,elselabel); end; procedure genjumptable(hp : pcaserecord;min_,max_ : longint); var table : plabel; last : longint; hr : preference; procedure genitem(t : pcaserecord); var i : longint; begin if assigned(t^.less) then genitem(t^.less); { fill possible hole } for i:=last+1 to t^._low-1 do datasegment^.concat(new(pai_const,init_symbol(strpnew(lab2str (elselabel))))); for i:=t^._low to t^._high do datasegment^.concat(new(pai_const,init_symbol(strpnew(lab2str (t^.statement))))); last:=t^._high; if assigned(t^.greater) then genitem(t^.greater); end; begin if not(jumptable_no_range) then begin exprasmlist^.concat(new(pai68k,op_const_reg(A_CMP,opsize,min_,hregister))); { case expr less than min_ => goto elselabel } emitl(jmp_le,elselabel); exprasmlist^.concat(new(pai68k,op_const_reg(A_CMP,opsize,max_,hregister))); emitl(jmp_gt,elselabel); end; getlabel(table); { extend with sign } if opsize=S_W then begin { word to long - unsigned } exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L,$ffff,hregister))); end else if opsize=S_B then begin { byte to long - unsigned } exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L,$ff,hregister))); end; new(hr); reset_reference(hr^); hr^.symbol:=stringdup(lab2str(table)); hr^.offset:=(-min_)*4; { add scalefactor *4 to index } exprasmlist^.concat(new(pai68k,op_const_reg(A_LSL,S_L,2,hregister))); { hr^.scalefactor:=4; } hr^.base:=getaddressreg; emit_reg_reg(A_MOVE,S_L,hregister,hr^.base); exprasmlist^.concat(new(pai68k,op_ref(A_JMP,S_NO,hr))); { if not(cs_littlesize in aktswitches^ ) then datasegment^.concat(new(pai68k,op_const(A_ALIGN,S_NO,4))); } datasegment^.concat(new(pai_label,init(table))); last:=min_; genitem(hp); if hr^.base <> R_NO then ungetregister(hr^.base); { !!!!!!! if not(cs_littlesize in aktswitches^ ) then exprasmlist^.concat(new(pai68k,op_const(A_ALIGN,S_NO,4))); } end; var lv,hv,min_label,max_label,labels : longint; max_linear_list : longint; begin getlabel(endlabel); getlabel(elselabel); with_sign:=is_signed(p^.left^.resulttype); if with_sign then begin jmp_gt:=A_BGT; jmp_le:=A_BLT; jmp_lee:=A_BLE; end else begin jmp_gt:=A_BHI; jmp_le:=A_BCS; jmp_lee:=A_BLS; end; cleartempgen; secondpass(p^.left); { determines the size of the operand } { determines the size of the operand } opsize:=bytes2Sxx[p^.left^.resulttype^.size]; { copy the case expression to a register } { copy the case expression to a register } case p^.left^.location.loc of LOC_REGISTER, LOC_CREGISTER : hregister:=p^.left^.location.register; LOC_MEM,LOC_REFERENCE : begin del_reference(p^.left^.location.reference); hregister:=getregister32; exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,opsize,newreference( p^.left^.location.reference),hregister))); end; else internalerror(2002); end; { now generate the jumps } if cs_optimize in aktswitches then begin { procedures are empirically passed on } { consumption can also be calculated } { but does it pay on the different } { processors? } { moreover can the size only be appro- } { ximated as it is not known if rel8, } { rel16 or rel32 jumps are used } min_label:=case_get_min(p^.nodes); max_label:=case_get_max(p^.nodes); labels:=case_count_labels(p^.nodes); { can we omit the range check of the jump table } getrange(p^.left^.resulttype,lv,hv); jumptable_no_range:=(lv=min_label) and (hv=max_label); { optimize for size ? } if cs_littlesize in aktswitches then begin if (labels<=2) or ((max_label-min_label)>3*labels) then { a linear list is always smaller than a jump tree } genlinearlist(p^.nodes) else { if the labels less or more a continuum then } genjumptable(p^.nodes,min_label,max_label); end else begin if jumptable_no_range then max_linear_list:=4 else max_linear_list:=2; if (labels<=max_linear_list) then genlinearlist(p^.nodes) else begin if ((max_label-min_label)>4*labels) then begin if labels>16 then gentreejmp(p^.nodes) else genlinearlist(p^.nodes); end else genjumptable(p^.nodes,min_label,max_label); end; end; end else { it's always not bad } genlinearlist(p^.nodes); { now generate the instructions } hp:=p^.right; while assigned(hp) do begin cleartempgen; secondpass(hp^.right); emitl(A_JMP,endlabel); hp:=hp^.left; end; emitl(A_LABEL,elselabel); { ... and the else block } if assigned(p^.elseblock) then begin cleartempgen; secondpass(p^.elseblock); end; emitl(A_LABEL,endlabel); end; procedure secondtryexcept(var p : ptree); begin end; procedure secondtryfinally(var p : ptree); begin end; procedure secondfail(var p : ptree); var hp : preference; begin {if procinfo.exceptions then aktproccode.concat(gennasmrec(CALL,S_NO,'HELP_DESTRUCTOR_E')) else } { we should know if the constructor is called with a new or not, how can we do that ??? exprasmlist^.concat(new(pai68k,op_csymbol(A_CALL,S_NO,newcsymbol('HELP_DESTRUCTOR',0)))); } exprasmlist^.concat(new(pai68k,op_reg(A_CLR,S_L,R_A5))); { also reset to zero in the stack } new(hp); reset_reference(hp^); hp^.offset:=procinfo.ESI_offset; hp^.base:=procinfo.framepointer; exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,S_L,R_A5,hp))); exprasmlist^.concat(new(pai_labeled,init(A_JMP,quickexitlabel))); end; procedure secondas(var p : ptree); var pushed : tpushed; begin set_location(p^.location,p^.left^.location); { save all used registers } pushusedregisters(pushed,$ffff); { push the vmt of the class } exprasmlist^.concat(new(pai68k,op_csymbol_reg(A_MOVE, S_L,newcsymbol(pobjectdef(p^.right^.resulttype)^.vmt_mangledname,0),R_SPPUSH))); concat_external(pobjectdef(p^.right^.resulttype)^.vmt_mangledname,EXT_NEAR); emitpushreferenceaddr(p^.location.reference); emitcall('DO_AS',true); popusedregisters(pushed); end; procedure secondis(var p : ptree); var pushed : tpushed; begin { save all used registers } pushusedregisters(pushed,$ffff); secondpass(p^.left); p^.location.loc:=LOC_FLAGS; p^.location.resflags:=F_NE; { push instance to check: } case p^.left^.location.loc of LOC_REGISTER,LOC_CREGISTER: begin exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE, S_L,p^.left^.location.register,R_SPPUSH))); ungetregister32(p^.left^.location.register); end; LOC_MEM,LOC_REFERENCE: begin exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE, S_L,newreference(p^.left^.location.reference),R_SPPUSH))); del_reference(p^.left^.location.reference); end; else internalerror(100); end; { generate type checking } secondpass(p^.right); case p^.right^.location.loc of LOC_REGISTER,LOC_CREGISTER: begin exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE, S_L,p^.right^.location.register,R_SPPUSH))); ungetregister32(p^.right^.location.register); end; LOC_MEM,LOC_REFERENCE: begin exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE, S_L,newreference(p^.right^.location.reference),R_SPPUSH))); del_reference(p^.right^.location.reference); end; else internalerror(100); end; emitcall('DO_IS',true); exprasmlist^.concat(new(pai68k,op_reg(A_TST,S_B,R_D0))); popusedregisters(pushed); end; procedure secondwith(var p : ptree); var ref : treference; symtable : psymtable; i : longint; begin if assigned(p^.left) then begin secondpass(p^.left); ref.symbol:=nil; gettempofsizereference(4,ref); exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L, newreference(p^.left^.location.reference),R_A0))); exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,S_L, R_A0,newreference(ref)))); del_reference(p^.left^.location.reference); { the offset relative to (%ebp) is only needed here! } symtable:=p^.withsymtable; for i:=1 to p^.tablecount do begin symtable^.datasize:=ref.offset; symtable:=symtable^.next; end; { p^.right can be optimize out !!! } if p^.right<>nil then secondpass(p^.right); { clear some stuff } ungetiftemp(ref); end; end; procedure secondprocinline(var p:ptree); begin end; procedure secondpass(var p : ptree); const procedures : array[ttreetyp] of secondpassproc = (secondadd,secondadd,secondadd,secondmoddiv,secondadd, secondmoddiv,secondassignment,secondload,secondnothing, secondadd,secondadd,secondadd,secondadd, secondadd,secondadd,secondin,secondadd, secondadd,secondshlshr,secondshlshr,secondadd, secondadd,secondsubscriptn,secondderef,secondaddr, seconddoubleaddr, secondordconst,secondtypeconv,secondcalln,secondnothing, secondrealconst,secondfixconst,secondumminus, secondasm,secondvecn, secondstringconst,secondfuncret,secondselfn, secondnot,secondinline,secondniln,seconderror, secondnothing,secondhnewn,secondhdisposen,secondnewn, secondsimplenewdispose,secondnothing,secondsetcons,secondblockn, secondstatement,secondnothing,secondifn,secondbreakn, secondcontinuen,second_while_repeatn,second_while_repeatn,secondfor, secondexitn,secondwith,secondcase,secondlabel, secondgoto,secondsimplenewdispose,secondtryexcept,secondraise, secondnothing,secondtryfinally,secondis,secondas,seconderror, secondfail,secondadd,secondprocinline, secondnothing,secondloadvmt); var oldcodegenerror : boolean; oldswitches : Tcswitches; oldpos : tfileposinfo; begin oldcodegenerror:=codegenerror; oldswitches:=aktswitches; oldpos:=aktfilepos; aktfilepos:=p^.fileinfo; aktswitches:=p^.pragmas; if not(p^.error) then begin codegenerror:=false; procedures[p^.treetype](p); p^.error:=codegenerror; codegenerror:=codegenerror or oldcodegenerror; end else codegenerror:=true; aktswitches:=oldswitches; aktfilepos:=oldpos; end; function do_secondpass(var p : ptree) : boolean; begin codegenerror:=false; if not(p^.error) then secondpass(p); do_secondpass:=codegenerror; end; var regvars : array[1..maxvarregs] of pvarsym; regvars_para : array[1..maxvarregs] of boolean; regvars_refs : array[1..maxvarregs] of longint; parasym : boolean; procedure searchregvars(p : psym); var i,j,k : longint; begin if (p^.typ=varsym) and ((pvarsym(p)^.var_options and vo_regable)<>0) then begin { walk through all momentary register variables } for i:=1 to maxvarregs do begin { free register ? } if regvars[i]=nil then begin regvars[i]:=pvarsym(p); regvars_para[i]:=parasym; break; end; { else throw out a variable ? } j:=pvarsym(p)^.refs; { parameter get a less value } if parasym then begin if cs_littlesize in aktswitches then dec(j,1) else dec(j,100); end; if (j>regvars_refs[i]) and (j>0) then begin for k:=maxvarregs-1 downto i do begin regvars[k+1]:=regvars[k]; regvars_para[k+1]:=regvars_para[k]; end; { calc the new refs pvarsym(p)^.refs:=j; } regvars[i]:=pvarsym(p); regvars_para[i]:=parasym; regvars_refs[i]:=j; break; end; end; end; end; procedure generatecode(var p : ptree); var i : longint; regsize : topsize; regi : tregister; hr : preference; label nextreg; begin cleartempgen; { when size optimization only count occurrence } if cs_littlesize in aktswitches then t_times:=1 else { reference for repetition is 100 } t_times:=100; { clear register count } for regi:=R_D0 to R_A6 do begin reg_pushes[regi]:=0; is_reg_var[regi]:=false; end; use_esp_stackframe:=false; if not(do_firstpass(p)) then begin { max. optimizations } { only if no asm is used } if (cs_maxoptimieren in aktswitches) and ((procinfo.flags and pi_uses_asm)=0) then begin { can we omit the stack frame ? } { conditions: 1. procedure (not main block) 2. no constructor or destructor 3. no call to other procedures 4. no interrupt handler } if assigned(aktprocsym) then begin if (aktprocsym^.definition^.options and (poconstructor+podestructor+poinline+pointerrupt)=0) and ((procinfo.flags and pi_do_call)=0) and (lexlevel>1) then begin { use ESP as frame pointer } procinfo.framepointer:=R_SP; use_esp_stackframe:=true; { calc parameter distance new } dec(procinfo.framepointer_offset,4); dec(procinfo.ESI_offset,4); dec(procinfo.retoffset,4); dec(procinfo.call_offset,4); aktprocsym^.definition^.parast^.call_offset:=procinfo.call_offset; end; end; { endif assigned } if (p^.registers32<4) then begin for i:=1 to maxvarregs do regvars[i]:=nil; parasym:=false; {$ifdef tp} symtablestack^.foreach(searchregvars); {$else} symtablestack^.foreach(@searchregvars); {$endif} { copy parameter into a register ? } parasym:=true; {$ifdef tp} symtablestack^.next^.foreach(searchregvars); {$else} symtablestack^.next^.foreach(@searchregvars); {$endif} { hold needed registers free } for i:=maxvarregs downto maxvarregs-p^.registers32+1 do regvars[i]:=nil; { now assign register } for i:=1 to maxvarregs do begin if assigned(regvars[i]) then begin { it is nonsens, to copy the variable to } { a register because we need then much } { pushes ? } if reg_pushes[varregs[i]]>=regvars[i]^.refs then begin regvars[i]:=nil; goto nextreg; end; { register is no longer available for } { expressions } { search the register which is the most } { unused } usableregs:=usableregs-[varregs[i]]; is_reg_var[varregs[i]]:=true; dec(c_usableregs); { possibly no 32 bit register are needed } if (regvars[i]^.definition^.deftype=orddef) and ( (porddef(regvars[i]^.definition)^.typ=bool8bit) or (porddef(regvars[i]^.definition)^.typ=uchar) or (porddef(regvars[i]^.definition)^.typ=u8bit) or (porddef(regvars[i]^.definition)^.typ=s8bit) ) then begin regvars[i]^.reg:=varregs[i]; regsize:=S_B; end else if (regvars[i]^.definition^.deftype=orddef) and ( (porddef(regvars[i]^.definition)^.typ=u16bit) or (porddef(regvars[i]^.definition)^.typ=s16bit) ) then begin regvars[i]^.reg:=varregs[i]; regsize:=S_W; end else begin regvars[i]^.reg:=varregs[i]; regsize:=S_L; end; { parameter must be load } if regvars_para[i] then begin { procinfo is there actual, } { because we can't never be in a } { nested procedure } { when loading parameter to reg } new(hr); reset_reference(hr^); hr^.offset:=pvarsym(regvars[i])^.address+procinfo.call_offset; hr^.base:=procinfo.framepointer; procinfo.aktentrycode^.concat(new(pai68k,op_ref_reg(A_MOVE,regsize, hr,regvars[i]^.reg))); unused:=unused - [regvars[i]^.reg]; end; { procedure uses this register } usedinproc:=usedinproc or ($800 shr word(varregs[i])); end; nextreg: { dummy } regsize:=S_W; end; if (verbosity and v_debug)=v_debug then begin for i:=1 to maxvarregs do begin if assigned(regvars[i]) then Message3(cg_d_register_weight,reg2str(regvars[i]^.reg), tostr(regvars[i]^.refs),regvars[i]^.name); end; end; end; end; do_secondpass(p); { all registers can be used again } { contains both information on Address registers and data registers } { even if they are allocated separately. } usableregs:=[R_D0,R_D1,R_D2,R_D3,R_D4,R_D5,R_D6,R_D7,R_A0,R_A1,R_A2,R_A3,R_A4, R_FP0,R_FP1,R_FP2,R_FP3,R_FP4,R_FP5,R_FP6,R_FP7]; c_usableregs:=4; end; procinfo.aktproccode^.concatlist(exprasmlist); end; end. { $Log$ Revision 1.12 1998-07-15 16:41:01 jonas * fixed bug that caused the stackframe never to be omitted Revision 1.11 1998/07/14 14:46:43 peter * released NEWINPUT Revision 1.10 1998/07/10 10:50:57 peter * m68k updates Revision 1.9 1998/07/06 15:51:16 michael Added length checking for string reading Revision 1.8 1998/06/12 10:32:22 pierre * column problem hopefully solved + C vars declaration changed Revision 1.7 1998/06/09 16:01:36 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.6 1998/06/08 13:13:36 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.5 1998/06/04 23:51:34 peter * m68k compiles + .def file creation moved to gendef.pas so it could also be used for win32 Revision 1.4 1998/04/29 10:33:44 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/07 22:45:03 florian * bug0092, bug0115 and bug0121 fixed + packed object/class/array }