|
|
@@ -79,105 +79,6 @@ implementation
|
|
|
TI386INLINENODE
|
|
|
*****************************************************************************}
|
|
|
|
|
|
-{$ifndef hascompilerproc}
|
|
|
- procedure StoreDirectFuncResult(var dest:tnode);
|
|
|
- var
|
|
|
- hp : tnode;
|
|
|
- htype : ttype;
|
|
|
- hreg : tregister;
|
|
|
- hregister : tregister;
|
|
|
- oldregisterdef : boolean;
|
|
|
- op : tasmop;
|
|
|
- opsize : topsize;
|
|
|
-
|
|
|
- begin
|
|
|
- { Get the accumulator first so it can't be used in the dest }
|
|
|
- if (dest.resulttype.def.deftype=orddef) and
|
|
|
- not(is_64bitint(dest.resulttype.def)) then
|
|
|
- hregister:=getexplicitregister32(accumulator);
|
|
|
- { process dest }
|
|
|
- SecondPass(dest);
|
|
|
- if Codegenerror then
|
|
|
- exit;
|
|
|
- { store the value }
|
|
|
- Case dest.resulttype.def.deftype of
|
|
|
- floatdef:
|
|
|
- if dest.location.loc=LOC_CFPUREGISTER then
|
|
|
- begin
|
|
|
- floatstoreops(tfloatdef(dest.resulttype.def).typ,op,opsize);
|
|
|
- emit_reg(op,opsize,correct_fpuregister(dest.location.register,fpuvaroffset+1));
|
|
|
- end
|
|
|
- else
|
|
|
- begin
|
|
|
- inc(fpuvaroffset);
|
|
|
- floatstore(tfloatdef(dest.resulttype.def).typ,dest.location.reference);
|
|
|
- { floatstore decrements the fpu var offset }
|
|
|
- { but in fact we didn't increment it }
|
|
|
- end;
|
|
|
- orddef:
|
|
|
- begin
|
|
|
- if is_64bitint(dest.resulttype.def) then
|
|
|
- begin
|
|
|
- emit_movq_reg_loc(R_EDX,R_EAX,dest.location);
|
|
|
- end
|
|
|
- else
|
|
|
- begin
|
|
|
- Case dest.resulttype.def.size of
|
|
|
- 1 : hreg:=regtoreg8(hregister);
|
|
|
- 2 : hreg:=regtoreg16(hregister);
|
|
|
- 4 : hreg:=hregister;
|
|
|
- End;
|
|
|
- emit_mov_reg_loc(hreg,dest.location);
|
|
|
- If (cs_check_range in aktlocalswitches) and
|
|
|
- {no need to rangecheck longints or cardinals on 32bit processors}
|
|
|
- not((torddef(dest.resulttype.def).typ = s32bit) and
|
|
|
- (torddef(dest.resulttype.def).low = longint($80000000)) and
|
|
|
- (torddef(dest.resulttype.def).high = $7fffffff)) and
|
|
|
- not((torddef(dest.resulttype.def).typ = u32bit) and
|
|
|
- (torddef(dest.resulttype.def).low = 0) and
|
|
|
- (torddef(dest.resulttype.def).high = longint($ffffffff))) then
|
|
|
- Begin
|
|
|
- {do not register this temporary def}
|
|
|
- OldRegisterDef := RegisterDef;
|
|
|
- RegisterDef := False;
|
|
|
- htype.reset;
|
|
|
- Case torddef(dest.resulttype.def).typ of
|
|
|
- u8bit,u16bit,u32bit:
|
|
|
- begin
|
|
|
- htype.setdef(torddef.create(u32bit,0,longint($ffffffff)));
|
|
|
- hreg:=hregister;
|
|
|
- end;
|
|
|
- s8bit,s16bit,s32bit:
|
|
|
- begin
|
|
|
- htype.setdef(torddef.create(s32bit,longint($80000000),$7fffffff));
|
|
|
- hreg:=hregister;
|
|
|
- end;
|
|
|
- end;
|
|
|
- { create a fake node }
|
|
|
- hp := cnothingnode.create;
|
|
|
- hp.location.loc := LOC_REGISTER;
|
|
|
- hp.location.register := hreg;
|
|
|
- if assigned(htype.def) then
|
|
|
- hp.resulttype:=htype
|
|
|
- else
|
|
|
- hp.resulttype:=dest.resulttype;
|
|
|
- { emit the range check }
|
|
|
- emitrangecheck(hp,dest.resulttype.def);
|
|
|
- if assigned(htype.def) then
|
|
|
- htype.def.free;
|
|
|
- RegisterDef := OldRegisterDef;
|
|
|
- hp.free;
|
|
|
- End;
|
|
|
- ungetregister(hregister);
|
|
|
- end;
|
|
|
- End;
|
|
|
- else
|
|
|
- internalerror(66766766);
|
|
|
- end;
|
|
|
- { free used registers }
|
|
|
- del_locref(dest.location);
|
|
|
- end;
|
|
|
-{$endif not hascomppilerproc}
|
|
|
|
|
|
procedure ti386inlinenode.pass_2;
|
|
|
const
|
|
|
@@ -198,711 +99,6 @@ implementation
|
|
|
addvalue : longint;
|
|
|
hp : tnode;
|
|
|
|
|
|
-{$ifndef hascompilerproc}
|
|
|
- procedure handlereadwrite(doread,doln : boolean);
|
|
|
- { produces code for READ(LN) and WRITE(LN) }
|
|
|
-
|
|
|
- procedure loadstream;
|
|
|
- const
|
|
|
- io:array[boolean] of string[6]=('OUTPUT','INPUT');
|
|
|
- var
|
|
|
- r : preference;
|
|
|
- begin
|
|
|
- new(r);
|
|
|
- reset_reference(r^);
|
|
|
- r^.symbol:=newasmsymbol(
|
|
|
- 'U_SYSTEM_'+io[doread]);
|
|
|
- getexplicitregister32(R_EDI);
|
|
|
- emit_ref_reg(A_LEA,S_L,r,R_EDI)
|
|
|
- end;
|
|
|
-
|
|
|
- const
|
|
|
- rdwrprefix:array[boolean] of string[15]=('FPC_WRITE_TEXT_','FPC_READ_TEXT_');
|
|
|
- var
|
|
|
- node : tcallparanode;
|
|
|
- hp : tnode;
|
|
|
- typedtyp,
|
|
|
- pararesult : tdef;
|
|
|
- orgfloattype : tfloattype;
|
|
|
- dummycoll : tparaitem;
|
|
|
- iolabel : tasmlabel;
|
|
|
- npara : longint;
|
|
|
- esireloaded : boolean;
|
|
|
- label
|
|
|
- myexit;
|
|
|
- begin
|
|
|
- { here we don't use register calling conventions }
|
|
|
- dummycoll:=TParaItem.Create;
|
|
|
- dummycoll.register:=R_NO;
|
|
|
- { I/O check }
|
|
|
- if (cs_check_io in aktlocalswitches) and
|
|
|
- not(po_iocheck in aktprocsym.definition.procoptions) then
|
|
|
- begin
|
|
|
- getaddrlabel(iolabel);
|
|
|
- emitlab(iolabel);
|
|
|
- end
|
|
|
- else
|
|
|
- iolabel:=nil;
|
|
|
- { for write of real with the length specified }
|
|
|
- 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 left=nil then
|
|
|
- begin
|
|
|
- { the following instructions are for "writeln;" }
|
|
|
- loadstream;
|
|
|
- { save @aktfile in temporary variable }
|
|
|
- emit_reg_ref(A_MOV,S_L,R_EDI,newreference(aktfile));
|
|
|
- ungetregister32(R_EDI);
|
|
|
- end
|
|
|
- else
|
|
|
- begin
|
|
|
- { revers paramters }
|
|
|
- node:=tcallparanode(reversparameter(left));
|
|
|
-
|
|
|
- left := node;
|
|
|
- npara := nb_para;
|
|
|
- { calculate data variable }
|
|
|
- { is first parameter a file type ? }
|
|
|
- if node.left.resulttype.def.deftype=filedef then
|
|
|
- begin
|
|
|
- ft:=tfiledef(node.left.resulttype.def).filetyp;
|
|
|
- if ft=ft_typed then
|
|
|
- typedtyp:=tfiledef(node.left.resulttype.def).typedfiletype.def;
|
|
|
- secondpass(node.left);
|
|
|
- if codegenerror then
|
|
|
- goto myexit;
|
|
|
-
|
|
|
- { save reference in temporary variables }
|
|
|
- if node.left.location.loc<>LOC_REFERENCE then
|
|
|
- begin
|
|
|
- CGMessage(cg_e_illegal_expression);
|
|
|
- goto myexit;
|
|
|
- end;
|
|
|
- getexplicitregister32(R_EDI);
|
|
|
- emit_ref_reg(A_LEA,S_L,newreference(node.left.location.reference),R_EDI);
|
|
|
- del_reference(node.left.location.reference);
|
|
|
- { skip to the next parameter }
|
|
|
- node:=tcallparanode(node.right);
|
|
|
- end
|
|
|
- else
|
|
|
- begin
|
|
|
- { load stdin/stdout stream }
|
|
|
- loadstream;
|
|
|
- end;
|
|
|
-
|
|
|
- { save @aktfile in temporary variable }
|
|
|
- emit_reg_ref(A_MOV,S_L,R_EDI,newreference(aktfile));
|
|
|
- ungetregister32(R_EDI);
|
|
|
- if doread then
|
|
|
- { parameter by READ gives call by reference }
|
|
|
- dummycoll.paratyp:=vs_var
|
|
|
- { an WRITE Call by "Const" }
|
|
|
- else
|
|
|
- dummycoll.paratyp:=vs_const;
|
|
|
-
|
|
|
- { because of secondcallparan, which otherwise attaches }
|
|
|
- if ft=ft_typed then
|
|
|
- { this is to avoid copy of simple const parameters }
|
|
|
- {dummycoll.data:=new(pformaldef.create)}
|
|
|
- dummycoll.paratype:=cformaltype
|
|
|
- else
|
|
|
- { I think, this isn't a good solution (FK) }
|
|
|
- dummycoll.paratype.reset;
|
|
|
-
|
|
|
- while assigned(node) do
|
|
|
- begin
|
|
|
- esireloaded:=false;
|
|
|
- pushusedregisters(pushed,$ff);
|
|
|
- hp:=node;
|
|
|
- node:=tcallparanode(node.right);
|
|
|
- tcallparanode(hp).right:=nil;
|
|
|
- if cpf_is_colon_para in tcallparanode(hp).callparaflags then
|
|
|
- CGMessage(parser_e_illegal_colon_qualifier);
|
|
|
- { when float is written then we need bestreal to be pushed
|
|
|
- convert here else we loose the old float type }
|
|
|
- if (not doread) and
|
|
|
- (ft<>ft_typed) and
|
|
|
- (tcallparanode(hp).left.resulttype.def.deftype=floatdef) then
|
|
|
- begin
|
|
|
- orgfloattype:=tfloatdef(tcallparanode(hp).left.resulttype.def).typ;
|
|
|
- tcallparanode(hp).left:=ctypeconvnode.create(tcallparanode(hp).left,pbestrealtype^);
|
|
|
- firstpass(tcallparanode(hp).left);
|
|
|
- end;
|
|
|
- { when read ord,floats are functions, so they need this
|
|
|
- parameter as their destination instead of being pushed }
|
|
|
- if doread and
|
|
|
- (ft<>ft_typed) and
|
|
|
- (tcallparanode(hp).resulttype.def.deftype in [orddef,floatdef]) then
|
|
|
- begin
|
|
|
- end
|
|
|
- else
|
|
|
- begin
|
|
|
- if ft=ft_typed then
|
|
|
- never_copy_const_param:=true;
|
|
|
- { reset data type }
|
|
|
- dummycoll.paratype.reset;
|
|
|
- { create temporary defs for high tree generation }
|
|
|
- if doread and (is_shortstring(tcallparanode(hp).resulttype.def)) then
|
|
|
- dummycoll.paratype:=openshortstringtype
|
|
|
- else
|
|
|
- if (is_chararray(tcallparanode(hp).resulttype.def)) then
|
|
|
- dummycoll.paratype:=openchararraytype;
|
|
|
- tcallparanode(hp).secondcallparan(dummycoll,false,false,false,0,0);
|
|
|
- if ft=ft_typed then
|
|
|
- never_copy_const_param:=false;
|
|
|
- end;
|
|
|
- tcallparanode(hp).right:=node;
|
|
|
- if codegenerror then
|
|
|
- goto myexit;
|
|
|
-
|
|
|
- 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);
|
|
|
- saveregvars($ff);
|
|
|
- if doread then
|
|
|
- emitcall('FPC_TYPED_READ')
|
|
|
- else
|
|
|
- emitcall('FPC_TYPED_WRITE');
|
|
|
- end
|
|
|
- else
|
|
|
- begin
|
|
|
- { save current position }
|
|
|
- pararesult:=tcallparanode(hp).left.resulttype.def;
|
|
|
- { handle possible field width }
|
|
|
- { of course only for write(ln) }
|
|
|
- if not doread then
|
|
|
- begin
|
|
|
- { handle total width parameter }
|
|
|
- if assigned(node) and (cpf_is_colon_para in node.callparaflags) then
|
|
|
- begin
|
|
|
- hp:=node;
|
|
|
- node:=tcallparanode(node.right);
|
|
|
- tcallparanode(hp).right:=nil;
|
|
|
- dummycoll.paratype.setdef(hp.resulttype.def);
|
|
|
- dummycoll.paratyp:=vs_value;
|
|
|
- tcallparanode(hp).secondcallparan(dummycoll,false,false,false,0,0);
|
|
|
- tcallparanode(hp).right:=node;
|
|
|
- if codegenerror then
|
|
|
- goto myexit;
|
|
|
- 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 (cpf_is_colon_para in node.callparaflags) then
|
|
|
- begin
|
|
|
- hp:=node;
|
|
|
- node:=tcallparanode(node.right);
|
|
|
- tcallparanode(hp).right:=nil;
|
|
|
- dummycoll.paratype.setdef(hp.resulttype.def);
|
|
|
- dummycoll.paratyp:=vs_value;
|
|
|
- tcallparanode(hp).secondcallparan(dummycoll,false,false,false,0,0);
|
|
|
- tcallparanode(hp).right:=node;
|
|
|
- if pararesult.deftype<>floatdef then
|
|
|
- CGMessage(parser_e_illegal_colon_qualifier);
|
|
|
- if codegenerror then
|
|
|
- goto myexit;
|
|
|
- end
|
|
|
- else
|
|
|
- begin
|
|
|
- if pararesult.deftype=floatdef then
|
|
|
- push_int(-1);
|
|
|
- end;
|
|
|
- { push also the real type for floats }
|
|
|
- if pararesult.deftype=floatdef then
|
|
|
- push_int(ord(orgfloattype));
|
|
|
- end;
|
|
|
- saveregvars($ff);
|
|
|
- case pararesult.deftype of
|
|
|
- stringdef :
|
|
|
- begin
|
|
|
- emitcall(rdwrprefix[doread]+tstringdef(pararesult).stringtypname);
|
|
|
- end;
|
|
|
- pointerdef :
|
|
|
- begin
|
|
|
- if is_pchar(pararesult) then
|
|
|
- emitcall(rdwrprefix[doread]+'PCHAR_AS_POINTER')
|
|
|
- end;
|
|
|
- arraydef :
|
|
|
- begin
|
|
|
- if is_chararray(pararesult) then
|
|
|
- emitcall(rdwrprefix[doread]+'PCHAR_AS_ARRAY')
|
|
|
- end;
|
|
|
- floatdef :
|
|
|
- begin
|
|
|
- emitcall(rdwrprefix[doread]+'FLOAT');
|
|
|
- {
|
|
|
- if tfloatdef(resulttype.def).typ<>f32bit then
|
|
|
- dec(fpuvaroffset);
|
|
|
- }
|
|
|
- if doread then
|
|
|
- begin
|
|
|
- maybe_loadself;
|
|
|
- esireloaded:=true;
|
|
|
- StoreDirectFuncResult(tcallparanode(hp).left);
|
|
|
- end;
|
|
|
- end;
|
|
|
- orddef :
|
|
|
- begin
|
|
|
- case torddef(pararesult).typ of
|
|
|
- s8bit,s16bit,s32bit :
|
|
|
- emitcall(rdwrprefix[doread]+'SINT');
|
|
|
- u8bit,u16bit,u32bit :
|
|
|
- emitcall(rdwrprefix[doread]+'UINT');
|
|
|
- uchar :
|
|
|
- emitcall(rdwrprefix[doread]+'CHAR');
|
|
|
- uwidechar :
|
|
|
- emitcall(rdwrprefix[doread]+'WIDECHAR');
|
|
|
- s64bit :
|
|
|
- emitcall(rdwrprefix[doread]+'INT64');
|
|
|
- u64bit :
|
|
|
- emitcall(rdwrprefix[doread]+'QWORD');
|
|
|
- bool8bit,
|
|
|
- bool16bit,
|
|
|
- bool32bit :
|
|
|
- emitcall(rdwrprefix[doread]+'BOOLEAN');
|
|
|
- end;
|
|
|
- if doread then
|
|
|
- begin
|
|
|
- maybe_loadself;
|
|
|
- esireloaded:=true;
|
|
|
- StoreDirectFuncResult(tcallparanode(hp).left);
|
|
|
- end;
|
|
|
- end;
|
|
|
- end;
|
|
|
- end;
|
|
|
- { load ESI in methods again }
|
|
|
- popusedregisters(pushed);
|
|
|
- if not(esireloaded) then
|
|
|
- maybe_loadself;
|
|
|
- end;
|
|
|
- end;
|
|
|
- { Insert end of writing for textfiles }
|
|
|
- if ft=ft_text then
|
|
|
- begin
|
|
|
- pushusedregisters(pushed,$ff);
|
|
|
- emit_push_mem(aktfile);
|
|
|
- saveregvars($ff);
|
|
|
- if doread then
|
|
|
- begin
|
|
|
- if doln then
|
|
|
- emitcall('FPC_READLN_END')
|
|
|
- else
|
|
|
- emitcall('FPC_READ_END');
|
|
|
- end
|
|
|
- else
|
|
|
- begin
|
|
|
- if doln then
|
|
|
- emitcall('FPC_WRITELN_END')
|
|
|
- else
|
|
|
- emitcall('FPC_WRITE_END');
|
|
|
- end;
|
|
|
- popusedregisters(pushed);
|
|
|
- maybe_loadself;
|
|
|
- end;
|
|
|
- { Insert IOCheck if set }
|
|
|
- if assigned(iolabel) then
|
|
|
- begin
|
|
|
- { registers are saved in the procedure }
|
|
|
- emit_sym(A_PUSH,S_L,iolabel);
|
|
|
- emitcall('FPC_IOCHECK');
|
|
|
- end;
|
|
|
- { Freeup all used temps }
|
|
|
- ungetiftemp(aktfile);
|
|
|
- if assigned(left) then
|
|
|
- begin
|
|
|
- left:=reversparameter(left);
|
|
|
- if npara<>nb_para then
|
|
|
- CGMessage(cg_f_internal_error_in_secondinline);
|
|
|
- hp:=left;
|
|
|
- while assigned(hp) do
|
|
|
- begin
|
|
|
- if assigned(tcallparanode(hp).left) then
|
|
|
- if (tcallparanode(hp).left.location.loc in [LOC_MEM,LOC_REFERENCE]) then
|
|
|
- ungetiftemp(tcallparanode(hp).left.location.reference);
|
|
|
- hp:=tcallparanode(hp).right;
|
|
|
- end;
|
|
|
- end;
|
|
|
-
|
|
|
- myexit:
|
|
|
- dummycoll.free;
|
|
|
- end;
|
|
|
-
|
|
|
- procedure handle_str;
|
|
|
-
|
|
|
- var
|
|
|
- hp,
|
|
|
- node : tcallparanode;
|
|
|
- dummycoll : tparaitem;
|
|
|
- //hp2 : tstringconstnode;
|
|
|
- is_real : boolean;
|
|
|
- realtype : tfloattype;
|
|
|
- procedureprefix : string;
|
|
|
- label
|
|
|
- myexit;
|
|
|
- begin
|
|
|
- dummycoll:=TParaItem.Create;
|
|
|
- dummycoll.register:=R_NO;
|
|
|
- pushusedregisters(pushed,$ff);
|
|
|
- node:=tcallparanode(left);
|
|
|
- is_real:=false;
|
|
|
- while assigned(node.right) do node:=tcallparanode(node.right);
|
|
|
- { if a real parameter somewhere then call REALSTR }
|
|
|
- if (node.left.resulttype.def.deftype=floatdef) then
|
|
|
- begin
|
|
|
- is_real:=true;
|
|
|
- realtype:=tfloatdef(node.left.resulttype.def).typ;
|
|
|
- end;
|
|
|
-
|
|
|
- node:=tcallparanode(left);
|
|
|
- { we have at least two args }
|
|
|
- { with at max 2 colon_para in between }
|
|
|
-
|
|
|
- { string arg }
|
|
|
- hp:=node;
|
|
|
- node:=tcallparanode(node.right);
|
|
|
- hp.right:=nil;
|
|
|
- dummycoll.paratyp:=vs_var;
|
|
|
- if is_shortstring(hp.resulttype.def) then
|
|
|
- dummycoll.paratype:=openshortstringtype
|
|
|
- else
|
|
|
- dummycoll.paratype:=hp.resulttype;
|
|
|
- procedureprefix:='FPC_'+tstringdef(hp.resulttype.def).stringtypname+'_';
|
|
|
- tcallparanode(hp).secondcallparan(dummycoll,false,false,false,0,0);
|
|
|
- if codegenerror then
|
|
|
- goto myexit;
|
|
|
-
|
|
|
- dummycoll.paratyp:=vs_const;
|
|
|
- left.free;
|
|
|
- left:=nil;
|
|
|
- { second arg }
|
|
|
- hp:=node;
|
|
|
- node:=tcallparanode(node.right);
|
|
|
- hp.right:=nil;
|
|
|
-
|
|
|
- { if real push real type }
|
|
|
- if is_real then
|
|
|
- push_int(ord(realtype));
|
|
|
-
|
|
|
- { frac para }
|
|
|
- if (cpf_is_colon_para in hp.callparaflags) and assigned(node) and
|
|
|
- (cpf_is_colon_para in node.callparaflags) then
|
|
|
- begin
|
|
|
- dummycoll.paratype.setdef(hp.resulttype.def);
|
|
|
- dummycoll.paratyp:=vs_value;
|
|
|
- tcallparanode(hp).secondcallparan(dummycoll,false,false,false,0,0);
|
|
|
- if codegenerror then
|
|
|
- goto myexit;
|
|
|
- hp.free;
|
|
|
- hp:=node;
|
|
|
- node:=tcallparanode(node.right);
|
|
|
- hp.right:=nil;
|
|
|
- end
|
|
|
- else
|
|
|
- if is_real then
|
|
|
- push_int(-1);
|
|
|
-
|
|
|
- { third arg, length only if is_real }
|
|
|
- if (cpf_is_colon_para in hp.callparaflags) then
|
|
|
- begin
|
|
|
- dummycoll.paratype.setdef(hp.resulttype.def);
|
|
|
- dummycoll.paratyp:=vs_value;
|
|
|
- tcallparanode(hp).secondcallparan(dummycoll,false,false,false,0,0);
|
|
|
- if codegenerror then
|
|
|
- goto myexit;
|
|
|
- hp.free;
|
|
|
- hp:=node;
|
|
|
- node:=tcallparanode(node.right);
|
|
|
- hp.right:=nil;
|
|
|
- end
|
|
|
- else
|
|
|
- if is_real then
|
|
|
- push_int(-32767)
|
|
|
- else
|
|
|
- push_int(-1);
|
|
|
-
|
|
|
- { Convert float to bestreal }
|
|
|
- if is_real then
|
|
|
- begin
|
|
|
- hp.left:=ctypeconvnode.create(hp.left,pbestrealtype^);
|
|
|
- firstpass(hp.left);
|
|
|
- end;
|
|
|
-
|
|
|
- { last arg longint or real }
|
|
|
- dummycoll.paratype.setdef(hp.resulttype.def);
|
|
|
- dummycoll.paratyp:=vs_value;
|
|
|
- tcallparanode(hp).secondcallparan(dummycoll,false,false,false,0,0);
|
|
|
- if codegenerror then
|
|
|
- goto myexit;
|
|
|
-
|
|
|
- saveregvars($ff);
|
|
|
- if is_real then
|
|
|
- emitcall(procedureprefix+'FLOAT')
|
|
|
- else
|
|
|
- case torddef(hp.resulttype.def).typ of
|
|
|
- u32bit:
|
|
|
- emitcall(procedureprefix+'CARDINAL');
|
|
|
-
|
|
|
- u64bit:
|
|
|
- emitcall(procedureprefix+'QWORD');
|
|
|
-
|
|
|
- s64bit:
|
|
|
- emitcall(procedureprefix+'INT64');
|
|
|
-
|
|
|
- else
|
|
|
- emitcall(procedureprefix+'LONGINT');
|
|
|
- end;
|
|
|
- popusedregisters(pushed);
|
|
|
- hp.free;
|
|
|
-
|
|
|
- myexit:
|
|
|
- dummycoll.free;
|
|
|
- end;
|
|
|
-
|
|
|
- Procedure Handle_Val;
|
|
|
- var
|
|
|
- hp,node,
|
|
|
- code_para, dest_para : tcallparanode;
|
|
|
- hreg,hreg2: TRegister;
|
|
|
- hdef: torddef;
|
|
|
- procedureprefix : string;
|
|
|
- hr, hr2: TReference;
|
|
|
- dummycoll : tparaitem;
|
|
|
- has_code, has_32bit_code, oldregisterdef: boolean;
|
|
|
- r : preference;
|
|
|
- label
|
|
|
- myexit;
|
|
|
- begin
|
|
|
- dummycoll:=TParaItem.Create;
|
|
|
- dummycoll.register:=R_NO;
|
|
|
- node:=tcallparanode(left);
|
|
|
- hp:=node;
|
|
|
- node:=tcallparanode(node.right);
|
|
|
- hp.right:=nil;
|
|
|
- {if we have 3 parameters, we have a code parameter}
|
|
|
- has_code := Assigned(node.right);
|
|
|
- has_32bit_code := false;
|
|
|
- reset_reference(hr);
|
|
|
- hreg := R_NO;
|
|
|
-
|
|
|
- If has_code then
|
|
|
- Begin
|
|
|
- {code is an orddef, that's checked in tcinl}
|
|
|
- code_para := hp;
|
|
|
- hp := node;
|
|
|
- node := tcallparanode(node.right);
|
|
|
- hp.right := nil;
|
|
|
- has_32bit_code := (torddef(tcallparanode(code_para).left.resulttype.def).typ in [u32bit,s32bit]);
|
|
|
- End;
|
|
|
-
|
|
|
- {hp = destination now, save for later use}
|
|
|
- dest_para := hp;
|
|
|
-
|
|
|
- {if EAX is already in use, it's a register variable. Since we don't
|
|
|
- need another register besides EAX, release the one we got}
|
|
|
- If hreg <> R_EAX Then ungetregister32(hreg);
|
|
|
-
|
|
|
- {load and push the address of the destination}
|
|
|
- dummycoll.paratyp:=vs_var;
|
|
|
- dummycoll.paratype.setdef(dest_para.resulttype.def);
|
|
|
- dest_para.secondcallparan(dummycoll,false,false,false,0,0);
|
|
|
- if codegenerror then
|
|
|
- goto myexit;
|
|
|
-
|
|
|
- {save the regvars}
|
|
|
- pushusedregisters(pushed,$ff);
|
|
|
-
|
|
|
- {now that we've already pushed the addres of dest_para.left on the
|
|
|
- stack, we can put the real parameters on the stack}
|
|
|
-
|
|
|
- If has_32bit_code Then
|
|
|
- Begin
|
|
|
- dummycoll.paratyp:=vs_var;
|
|
|
- dummycoll.paratype.setdef(code_para.resulttype.def);
|
|
|
- code_para.secondcallparan(dummycoll,false,false,false,0,0);
|
|
|
- if codegenerror then
|
|
|
- goto myexit;
|
|
|
- code_para.free;
|
|
|
- End
|
|
|
- Else
|
|
|
- Begin
|
|
|
- {only 32bit code parameter is supported, so fake one}
|
|
|
- GetTempOfSizeReference(4,hr);
|
|
|
- emitpushreferenceaddr(hr);
|
|
|
- End;
|
|
|
-
|
|
|
- {node = first parameter = string}
|
|
|
- dummycoll.paratyp:=vs_const;
|
|
|
- dummycoll.paratype.setdef(node.resulttype.def);
|
|
|
- node.secondcallparan(dummycoll,false,false,false,0,0);
|
|
|
- if codegenerror then
|
|
|
- goto myexit;
|
|
|
-
|
|
|
- Case dest_para.resulttype.def.deftype of
|
|
|
- floatdef:
|
|
|
- begin
|
|
|
- procedureprefix := 'FPC_VAL_REAL_';
|
|
|
- inc(fpuvaroffset);
|
|
|
- end;
|
|
|
- orddef:
|
|
|
- if is_64bitint(dest_para.resulttype.def) then
|
|
|
- begin
|
|
|
- if is_signed(dest_para.resulttype.def) then
|
|
|
- procedureprefix := 'FPC_VAL_INT64_'
|
|
|
- else
|
|
|
- procedureprefix := 'FPC_VAL_QWORD_';
|
|
|
- end
|
|
|
- else
|
|
|
- begin
|
|
|
- if is_signed(dest_para.resulttype.def) then
|
|
|
- begin
|
|
|
- {if we are converting to a signed number, we have to include the
|
|
|
- size of the destination, so the Val function can extend the sign
|
|
|
- of the result to allow proper range checking}
|
|
|
- emit_const(A_PUSH,S_L,dest_para.resulttype.def.size);
|
|
|
- procedureprefix := 'FPC_VAL_SINT_'
|
|
|
- end
|
|
|
- else
|
|
|
- procedureprefix := 'FPC_VAL_UINT_';
|
|
|
- end;
|
|
|
- End;
|
|
|
-
|
|
|
- saveregvars($ff);
|
|
|
- emitcall(procedureprefix+tstringdef(node.resulttype.def).stringtypname);
|
|
|
- { before disposing node we need to ungettemp !! PM }
|
|
|
- if node.left.location.loc in [LOC_REFERENCE,LOC_MEM] then
|
|
|
- ungetiftemp(node.left.location.reference);
|
|
|
- node.free;
|
|
|
- left := nil;
|
|
|
-
|
|
|
- {reload esi in case the dest_para/code_para is a class variable or so}
|
|
|
- maybe_loadself;
|
|
|
-
|
|
|
- If (dest_para.resulttype.def.deftype = orddef) Then
|
|
|
- Begin
|
|
|
- {store the result in a safe place, because EAX may be used by a
|
|
|
- register variable}
|
|
|
- hreg := getexplicitregister32(R_EAX);
|
|
|
- emit_reg_reg(A_MOV,S_L,R_EAX,hreg);
|
|
|
- if is_64bitint(dest_para.resulttype.def) then
|
|
|
- begin
|
|
|
- hreg2:=getexplicitregister32(R_EDX);
|
|
|
- emit_reg_reg(A_MOV,S_L,R_EDX,hreg2);
|
|
|
- end;
|
|
|
- {as of now, hreg now holds the location of the result, if it was
|
|
|
- integer}
|
|
|
- End;
|
|
|
-
|
|
|
- { restore the register vars}
|
|
|
-
|
|
|
- popusedregisters(pushed);
|
|
|
-
|
|
|
- If has_code and Not(has_32bit_code) Then
|
|
|
- {only 16bit code is possible}
|
|
|
- Begin
|
|
|
- {load the address of the code parameter}
|
|
|
- secondpass(code_para.left);
|
|
|
- {move the code to its destination}
|
|
|
- getexplicitregister32(R_EDI);
|
|
|
- emit_ref_reg(A_MOV,S_L,NewReference(hr),R_EDI);
|
|
|
- emit_mov_reg_loc(R_DI,code_para.left.location);
|
|
|
- ungetregister32(R_EDI);
|
|
|
- code_para.free;
|
|
|
- End;
|
|
|
-
|
|
|
- {restore the address of the result}
|
|
|
- getexplicitregister32(R_EDI);
|
|
|
- emit_reg(A_POP,S_L,R_EDI);
|
|
|
-
|
|
|
- {set up hr2 to a refernce with EDI as base register}
|
|
|
- reset_reference(hr2);
|
|
|
- hr2.base := R_EDI;
|
|
|
-
|
|
|
- {save the function result in the destination variable}
|
|
|
- Case dest_para.left.resulttype.def.deftype of
|
|
|
- floatdef:
|
|
|
- floatstore(tfloatdef(dest_para.left.resulttype.def).typ, hr2);
|
|
|
- orddef:
|
|
|
- Case torddef(dest_para.left.resulttype.def).typ of
|
|
|
- u8bit,s8bit:
|
|
|
- emit_reg_ref(A_MOV, S_B,
|
|
|
- RegToReg8(hreg),newreference(hr2));
|
|
|
- u16bit,s16bit:
|
|
|
- emit_reg_ref(A_MOV, S_W,
|
|
|
- RegToReg16(hreg),newreference(hr2));
|
|
|
- u32bit,s32bit:
|
|
|
- emit_reg_ref(A_MOV, S_L,
|
|
|
- hreg,newreference(hr2));
|
|
|
- u64bit,s64bit:
|
|
|
- begin
|
|
|
- emit_reg_ref(A_MOV, S_L,
|
|
|
- hreg,newreference(hr2));
|
|
|
- r:=newreference(hr2);
|
|
|
- inc(r^.offset,4);
|
|
|
- emit_reg_ref(A_MOV, S_L,
|
|
|
- hreg2,r);
|
|
|
- end;
|
|
|
- End;
|
|
|
- End;
|
|
|
- ungetregister32(R_EDI);
|
|
|
- If (cs_check_range in aktlocalswitches) and
|
|
|
- (dest_para.left.resulttype.def.deftype = orddef) and
|
|
|
- (not(is_64bitint(dest_para.left.resulttype.def))) and
|
|
|
- {the following has to be changed to 64bit checking, once Val
|
|
|
- returns 64 bit values (unless a special Val function is created
|
|
|
- for that)}
|
|
|
- {no need to rangecheck longints or cardinals on 32bit processors}
|
|
|
- not((torddef(dest_para.left.resulttype.def).typ = s32bit) and
|
|
|
- (torddef(dest_para.left.resulttype.def).low = longint($80000000)) and
|
|
|
- (torddef(dest_para.left.resulttype.def).high = $7fffffff)) and
|
|
|
- not((torddef(dest_para.left.resulttype.def).typ = u32bit) and
|
|
|
- (torddef(dest_para.left.resulttype.def).low = 0) and
|
|
|
- (torddef(dest_para.left.resulttype.def).high = longint($ffffffff))) then
|
|
|
- Begin
|
|
|
- hp:=tcallparanode(dest_para.left.getcopy);
|
|
|
- hp.location.loc := LOC_REGISTER;
|
|
|
- hp.location.register := hreg;
|
|
|
- {do not register this temporary def}
|
|
|
- OldRegisterDef := RegisterDef;
|
|
|
- RegisterDef := False;
|
|
|
- Case torddef(dest_para.left.resulttype.def).typ of
|
|
|
- u8bit,u16bit,u32bit: hdef:=torddef.create(u32bit,0,longint($ffffffff));
|
|
|
- s8bit,s16bit,s32bit: hdef:=torddef.create(s32bit,longint($80000000),$7fffffff);
|
|
|
- end;
|
|
|
- hp.resulttype.def := hdef;
|
|
|
- emitrangecheck(hp,dest_para.left.resulttype.def);
|
|
|
- hp.right := nil;
|
|
|
- hp.resulttype.def.free;
|
|
|
- RegisterDef := OldRegisterDef;
|
|
|
- hp.free;
|
|
|
- End;
|
|
|
- {dest_para.right is already nil}
|
|
|
- dest_para.free;
|
|
|
- UnGetIfTemp(hr);
|
|
|
- myexit:
|
|
|
- dummycoll.free;
|
|
|
- end;
|
|
|
-{$endif not hascompilerproc}
|
|
|
-
|
|
|
var
|
|
|
r : preference;
|
|
|
//hp : tcallparanode;
|
|
|
@@ -1388,21 +584,8 @@ implementation
|
|
|
end;
|
|
|
in_reset_typedfile,in_rewrite_typedfile :
|
|
|
begin
|
|
|
-{$ifndef hascompilerproc}
|
|
|
- pushusedregisters(pushed,$ff);
|
|
|
- emit_const(A_PUSH,S_L,tfiledef(left.resulttype.def).typedfiletype.def.size);
|
|
|
- secondpass(left);
|
|
|
- emitpushreferenceaddr(left.location.reference);
|
|
|
- saveregvars($ff);
|
|
|
- if inlinenumber=in_reset_typedfile then
|
|
|
- emitcall('FPC_RESET_TYPED')
|
|
|
- else
|
|
|
- emitcall('FPC_REWRITE_TYPED');
|
|
|
- popusedregisters(pushed);
|
|
|
-{$else not hascompilerproc}
|
|
|
{ should be removed in pass_1 (JM) }
|
|
|
internalerror(200108132);
|
|
|
-{$endif not hascompilerproc}
|
|
|
end;
|
|
|
in_setlength_x:
|
|
|
begin
|
|
|
@@ -1491,41 +674,21 @@ implementation
|
|
|
end;
|
|
|
popusedregisters(pushed);
|
|
|
end;
|
|
|
-{$ifndef hascompilerproc}
|
|
|
- in_write_x :
|
|
|
- handlereadwrite(false,false);
|
|
|
- in_writeln_x :
|
|
|
- handlereadwrite(false,true);
|
|
|
- in_read_x :
|
|
|
- handlereadwrite(true,false);
|
|
|
- in_readln_x :
|
|
|
- handlereadwrite(true,true);
|
|
|
-{$else hascomppilerproc}
|
|
|
in_read_x,
|
|
|
in_readln_x,
|
|
|
in_write_x,
|
|
|
in_writeln_x :
|
|
|
{ should be removed in the resulttype pass already (JM) }
|
|
|
internalerror(200108162);
|
|
|
-{$endif not hascomppilerproc}
|
|
|
in_str_x_string :
|
|
|
begin
|
|
|
-{$ifndef hascompilerproc}
|
|
|
- handle_str;
|
|
|
- maybe_loadself;
|
|
|
-{$else not hascompilerproc}
|
|
|
{ should be removed in det_resulttype (JM) }
|
|
|
internalerror(200108131);
|
|
|
-{$endif not hascompilerproc}
|
|
|
end;
|
|
|
in_val_x :
|
|
|
Begin
|
|
|
-{$ifdef hascompilerproc}
|
|
|
{ should be removed in det_resulttype (JM) }
|
|
|
internalerror(200108241);
|
|
|
-{$else hascompilerproc}
|
|
|
- handle_val;
|
|
|
-{$endif hascompilerproc}
|
|
|
End;
|
|
|
in_include_x_y,
|
|
|
in_exclude_x_y:
|
|
|
@@ -1719,7 +882,13 @@ begin
|
|
|
end.
|
|
|
{
|
|
|
$Log$
|
|
|
- Revision 1.21 2001-08-26 13:36:58 florian
|
|
|
+ Revision 1.22 2001-08-28 13:24:47 jonas
|
|
|
+ + compilerproc implementation of most string-related type conversions
|
|
|
+ - removed all code from the compiler which has been replaced by
|
|
|
+ compilerproc implementations (using {$ifdef hascompilerproc} is not
|
|
|
+ necessary in the compiler)
|
|
|
+
|
|
|
+ Revision 1.21 2001/08/26 13:36:58 florian
|
|
|
* some cg reorganisation
|
|
|
* some PPC updates
|
|
|
|
Jonas Maebe