diff options
Diffstat (limited to 'compiler/ninl.pas')
| -rw-r--r-- | compiler/ninl.pas | 2526 |
1 files changed, 2526 insertions, 0 deletions
diff --git a/compiler/ninl.pas b/compiler/ninl.pas new file mode 100644 index 0000000000..332f728d4d --- /dev/null +++ b/compiler/ninl.pas @@ -0,0 +1,2526 @@ +{ + Copyright (c) 1998-2002 by Florian Klaempfl + + Type checking and register allocation for inline nodes + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit ninl; + +{$i fpcdefs.inc} + +interface + + uses + node,htypechk,cpuinfo,symtype; + + {$i compinnr.inc} + + type + tinlinenode = class(tunarynode) + inlinenumber : byte; + constructor create(number : byte;is_const:boolean;l : tnode);virtual; + constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override; + procedure ppuwrite(ppufile:tcompilerppufile);override; + function _getcopy : tnode;override; + function pass_1 : tnode;override; + function det_resulttype:tnode;override; + function docompare(p: tnode): boolean; override; + { All the following routines currently + call compilerprocs, unless they are + overriden in which case, the code + generator handles them. + } + function first_pi: tnode ; virtual; + function first_arctan_real: tnode; virtual; + function first_abs_real: tnode; virtual; + function first_sqr_real: tnode; virtual; + function first_sqrt_real: tnode; virtual; + function first_ln_real: tnode; virtual; + function first_cos_real: tnode; virtual; + function first_sin_real: tnode; virtual; + function first_exp_real: tnode; virtual; + function first_frac_real: tnode; virtual; + function first_round_real: tnode; virtual; + function first_trunc_real: tnode; virtual; + function first_int_real: tnode; virtual; + private + function handle_str: tnode; + function handle_reset_rewrite_typed: tnode; + function handle_read_write: tnode; + function handle_val: tnode; + end; + tinlinenodeclass = class of tinlinenode; + + var + cinlinenode : tinlinenodeclass; + + function geninlinenode(number : byte;is_const:boolean;l : tnode) : tinlinenode; + +implementation + + uses + verbose,globals,systems, + globtype, cutils, + symconst,symdef,symsym,symtable,paramgr,defutil, + pass_1, + ncal,ncon,ncnv,nadd,nld,nbas,nflw,nmem,nmat,nutils, + cgbase,procinfo + ; + + function geninlinenode(number : byte;is_const:boolean;l : tnode) : tinlinenode; + + begin + geninlinenode:=cinlinenode.create(number,is_const,l); + end; + +{***************************************************************************** + TINLINENODE +*****************************************************************************} + + constructor tinlinenode.create(number : byte;is_const:boolean;l : tnode); + + begin + inherited create(inlinen,l); + if is_const then + include(flags,nf_inlineconst); + inlinenumber:=number; + end; + + + constructor tinlinenode.ppuload(t:tnodetype;ppufile:tcompilerppufile); + begin + inherited ppuload(t,ppufile); + inlinenumber:=ppufile.getbyte; + end; + + + procedure tinlinenode.ppuwrite(ppufile:tcompilerppufile); + begin + inherited ppuwrite(ppufile); + ppufile.putbyte(inlinenumber); + end; + + + function tinlinenode._getcopy : tnode; + var + n : tinlinenode; + begin + n:=tinlinenode(inherited _getcopy); + n.inlinenumber:=inlinenumber; + result:=n; + end; + + + function tinlinenode.handle_str : tnode; + var + lenpara, + fracpara, + newparas, + dest, + source : tcallparanode; + procname: string; + is_real : boolean; + + begin + result := cerrornode.create; + + { make sure we got at least two parameters (if we got only one, } + { this parameter may not be encapsulated in a callparan) } + if not assigned(left) or + (left.nodetype <> callparan) then + begin + CGMessage(parser_e_wrong_parameter_size); + exit; + end; + + { get destination string } + dest := tcallparanode(left); + + { get source para (number) } + source := dest; + while assigned(source.right) do + source := tcallparanode(source.right); + + { destination parameter must be a normal (not a colon) parameter, this + check is needed because str(v:len) also has 2 parameters } + if (source=dest) or + (cpf_is_colon_para in tcallparanode(dest).callparaflags) then + begin + CGMessage(parser_e_wrong_parameter_size); + exit; + end; + + is_real := source.resulttype.def.deftype = floatdef; + + if ((dest.left.resulttype.def.deftype<>stringdef) and + not(is_chararray(dest.left.resulttype.def))) or + not(is_real or + (source.left.resulttype.def.deftype = orddef)) then + begin + CGMessagePos(fileinfo,parser_e_illegal_expression); + exit; + end; + + { get len/frac parameters } + lenpara := nil; + fracpara := nil; + if (cpf_is_colon_para in tcallparanode(dest.right).callparaflags) then + begin + lenpara := tcallparanode(dest.right); + + { we can let the callnode do the type checking of these parameters too, } + { but then the error messages aren't as nice } + if not is_integer(lenpara.resulttype.def) then + begin + CGMessagePos1(lenpara.fileinfo, + type_e_integer_expr_expected,lenpara.resulttype.def.typename); + exit; + end; + if (cpf_is_colon_para in tcallparanode(lenpara.right).callparaflags) then + begin + { parameters are in reverse order! } + fracpara := lenpara; + lenpara := tcallparanode(lenpara.right); + if not is_real then + begin + CGMessagePos(lenpara.fileinfo,parser_e_illegal_colon_qualifier); + exit + end; + if not is_integer(lenpara.resulttype.def) then + begin + CGMessagePos1(lenpara.fileinfo, + type_e_integer_expr_expected,lenpara.resulttype.def.typename); + exit; + end; + end; + end; + + { generate the parameter list for the compilerproc } + newparas := dest; + + { if we have a float parameter, insert the realtype, len and fracpara parameters } + if is_real then + begin + { insert realtype parameter } + newparas.right := ccallparanode.create(cordconstnode.create( + ord(tfloatdef(source.left.resulttype.def).typ),s32inttype,true), + newparas.right); + { if necessary, insert a fraction parameter } + if not assigned(fracpara) then + begin + tcallparanode(newparas.right).right := ccallparanode.create( + cordconstnode.create(-1,s32inttype,false), + tcallparanode(newparas.right).right); + fracpara := tcallparanode(tcallparanode(newparas.right).right); + end; + { if necessary, insert a length para } + if not assigned(lenpara) then + fracpara.right := ccallparanode.create( + cordconstnode.create(-32767,s32inttype,false), + fracpara.right); + end + else + { for a normal parameter, insert a only length parameter if one is missing } + if not assigned(lenpara) then + newparas.right := ccallparanode.create(cordconstnode.create(-1,s32inttype,false), + newparas.right); + + { remove the parameters from the original node so they won't get disposed, } + { since they're reused } + left := nil; + + { create procedure name } + if is_chararray(dest.resulttype.def) then + procname:='fpc_chararray_' + else + procname := 'fpc_' + tstringdef(dest.resulttype.def).stringtypname+'_'; + if is_real then + procname := procname + 'float' + else + case torddef(source.resulttype.def).typ of +{$ifdef cpu64bit} + u64bit: + procname := procname + 'uint'; +{$else} + u32bit: + procname := procname + 'uint'; + u64bit: + procname := procname + 'qword'; + scurrency, + s64bit: + procname := procname + 'int64'; +{$endif} + else + procname := procname + 'sint'; + end; + + { free the errornode we generated in the beginning } + result.free; + { create the call node, } + result := ccallnode.createintern(procname,newparas); + end; + + + function tinlinenode.handle_reset_rewrite_typed: tnode; + begin + { since this is a "in_xxxx_typedfile" node, we can be sure we have } + { a typed file as argument and we don't have to check it again (JM) } + + { add the recsize parameter } + { note: for some reason, the parameter of intern procedures with only one } + { parameter is gets lifted out of its original tcallparanode (see round } + { line 1306 of ncal.pas), so recreate a tcallparanode here (JM) } + left := ccallparanode.create(cordconstnode.create( + tfiledef(left.resulttype.def).typedfiletype.def.size,s32inttype,true), + ccallparanode.create(left,nil)); + { create the correct call } + if inlinenumber=in_reset_typedfile then + result := ccallnode.createintern('fpc_reset_typed',left) + else + result := ccallnode.createintern('fpc_rewrite_typed',left); + { make sure left doesn't get disposed, since we use it in the new call } + left := nil; + end; + + + function tinlinenode.handle_read_write: tnode; + + const + procnames: array[boolean,boolean] of string[11] = + (('write_text_','read_text_'),('typed_write','typed_read')); + + var + filepara, + lenpara, + fracpara, + nextpara, + para : tcallparanode; + newstatement : tstatementnode; + newblock : tblocknode; + p1 : tnode; + filetemp, + temp : ttempcreatenode; + procprefix, + name : string[31]; + textsym : ttypesym; + readfunctype : ttype; + is_typed, + do_read, + is_real, + error_para, + found_error : boolean; + begin + filepara := nil; + is_typed := false; + filetemp := nil; + do_read := inlinenumber in [in_read_x,in_readln_x]; + { if we fail, we can quickly exit this way. We must generate something } + { instead of the inline node, because firstpass will bomb with an } + { internalerror if it encounters a read/write } + result := cerrornode.create; + + { reverse the parameters (needed to get the colon parameters in the } + { correct order when processing write(ln) } + left := reverseparameters(tcallparanode(left)); + + if assigned(left) then + begin + { check if we have a file parameter and if yes, what kind it is } + filepara := tcallparanode(left); + + if (filepara.resulttype.def.deftype=filedef) then + begin + if (tfiledef(filepara.resulttype.def).filetyp=ft_untyped) then + begin + CGMessagePos(fileinfo,type_e_no_read_write_for_untyped_file); + exit; + end + else + begin + if (tfiledef(filepara.resulttype.def).filetyp=ft_typed) then + begin + if (inlinenumber in [in_readln_x,in_writeln_x]) then + begin + CGMessagePos(fileinfo,type_e_no_readln_writeln_for_typed_file); + exit; + end; + is_typed := true; + end + end; + end + else + filepara := nil; + end; + + { create a blocknode in which the successive write/read statements will be } + { put, since they belong together. Also create a dummy statement already to } + { make inserting of additional statements easier } + newblock:=internalstatements(newstatement); + + { if we don't have a filepara, create one containing the default } + if not assigned(filepara) then + begin + { since the input/output variables are threadvars loading them into + a temp once is faster. Create a temp which will hold a pointer to the file } + filetemp := ctempcreatenode.create(voidpointertype,voidpointertype.def.size,tt_persistent,true); + addstatement(newstatement,filetemp); + + { make sure the resulttype of the temp (and as such of the } + { temprefs coming after it) is set (necessary because the } + { temprefs will be part of the filepara, of which we need } + { the resulttype later on and temprefs can only be } + { resulttypepassed if the resulttype of the temp is known) } + resulttypepass(tnode(filetemp)); + + { assign the address of the file to the temp } + if do_read then + name := 'input' + else + name := 'output'; + addstatement(newstatement, + cassignmentnode.create(ctemprefnode.create(filetemp), + ccallnode.createintern('fpc_get_'+name,nil))); + + { create a new fileparameter as follows: file_type(temp^) } + { (so that we pass the value and not the address of the temp } + { to the read/write routine) } + if not searchsystype('TEXT',textsym) then + internalerror(200108313); + filepara := ccallparanode.create(ctypeconvnode.create_internal( + cderefnode.create(ctemprefnode.create(filetemp)),textsym.restype),nil); + end + else + { remove filepara from the parameter chain } + begin + left := filepara.right; + filepara.right := nil; + { the file para is a var parameter, but it must be valid already } + set_varstate(filepara.left,vs_used,[vsf_must_be_valid]); + { check if we should make a temp to store the result of a complex } + { expression (better heuristics, anyone?) (JM) } + if (filepara.left.nodetype <> loadn) then + begin + { create a temp which will hold a pointer to the file } + filetemp := ctempcreatenode.create(voidpointertype,voidpointertype.def.size,tt_persistent,true); + + { add it to the statements } + addstatement(newstatement,filetemp); + + { make sure the resulttype of the temp (and as such of the } + { temprefs coming after it) is set (necessary because the } + { temprefs will be part of the filepara, of which we need } + { the resulttype later on and temprefs can only be } + { resulttypepassed if the resulttype of the temp is known) } + resulttypepass(tnode(filetemp)); + + { assign the address of the file to the temp } + addstatement(newstatement, + cassignmentnode.create(ctemprefnode.create(filetemp), + caddrnode.create_internal(filepara.left))); + resulttypepass(newstatement.left); + { create a new fileparameter as follows: file_type(temp^) } + { (so that we pass the value and not the address of the temp } + { to the read/write routine) } + nextpara := ccallparanode.create(ctypeconvnode.create_internal( + cderefnode.create(ctemprefnode.create(filetemp)),filepara.left.resulttype),nil); + + { replace the old file para with the new one } + filepara.left := nil; + filepara.free; + filepara := nextpara; + end; + end; + + { the resulttype of the filepara must be set since it's } + { used below } + filepara.get_paratype; + + { now, filepara is nowhere referenced anymore, so we can safely dispose it } + { if something goes wrong or at the end of the procedure } + + { choose the correct procedure prefix } + procprefix := 'fpc_'+procnames[is_typed,do_read]; + + { we're going to reuse the paranodes, so make sure they don't get freed } + { twice } + para := tcallparanode(left); + left := nil; + + { no errors found yet... } + found_error := false; + + if is_typed then + begin + { add the typesize to the filepara } + if filepara.resulttype.def.deftype=filedef then + filepara.right := ccallparanode.create(cordconstnode.create( + tfiledef(filepara.resulttype.def).typedfiletype.def.size,s32inttype,true),nil); + + { check for "no parameters" (you need at least one extra para for typed files) } + if not assigned(para) then + begin + CGMessage(parser_e_wrong_parameter_size); + found_error := true; + end; + + { process all parameters } + while assigned(para) do + begin + { check if valid parameter } + if para.left.nodetype=typen then + begin + CGMessagePos(para.left.fileinfo,type_e_cant_read_write_type); + found_error := true; + end; + + { support writeln(procvar) } + if (para.left.resulttype.def.deftype=procvardef) then + begin + p1:=ccallnode.create_procvar(nil,para.left); + resulttypepass(p1); + para.left:=p1; + end; + + if filepara.resulttype.def.deftype=filedef then + inserttypeconv(para.left,tfiledef(filepara.resulttype.def).typedfiletype); + + if assigned(para.right) and + (cpf_is_colon_para in tcallparanode(para.right).callparaflags) then + begin + CGMessagePos(para.right.fileinfo,parser_e_illegal_colon_qualifier); + + { skip all colon para's } + nextpara := tcallparanode(tcallparanode(para.right).right); + while assigned(nextpara) and + (cpf_is_colon_para in nextpara.callparaflags) do + nextpara := tcallparanode(nextpara.right); + + found_error := true; + end + else + { get next parameter } + nextpara := tcallparanode(para.right); + + { When we have a call, we have a problem: you can't pass the } + { result of a call as a formal const parameter. Solution: } + { assign the result to a temp and pass this temp as parameter } + { This is not very efficient, but write(typedfile,x) is } + { already slow by itself anyway (no buffering) (JM) } + { Actually, thge same goes for every non-simple expression } + { (such as an addition, ...) -> put everything but load nodes } + { into temps (JM) } + { of course, this must only be allowed for writes!!! (JM) } + if not(do_read) and + (para.left.nodetype <> loadn) then + begin + { create temp for result } + temp := ctempcreatenode.create(para.left.resulttype, + para.left.resulttype.def.size,tt_persistent,false); + addstatement(newstatement,temp); + { assign result to temp } + addstatement(newstatement, + cassignmentnode.create(ctemprefnode.create(temp), + para.left)); + { replace (reused) paranode with temp } + para.left := ctemprefnode.create(temp); + end; + { add fileparameter } + para.right := filepara.getcopy; + + { create call statment } + { since the parameters are in the correct order, we have to insert } + { the statements always at the end of the current block } + addstatement(newstatement,ccallnode.createintern(procprefix,para)); + + { if we used a temp, free it } + if para.left.nodetype = temprefn then + addstatement(newstatement,ctempdeletenode.create(temp)); + + { process next parameter } + para := nextpara; + end; + + { free the file parameter } + filepara.free; + end + else + { text read/write } + begin + while assigned(para) do + begin + { is this parameter faulty? } + error_para := false; + { is this parameter a real? } + is_real:=false; + { type used for the read(), this is used to check + whether a temp is needed for range checking } + readfunctype.reset; + + { can't read/write types } + if para.left.nodetype=typen then + begin + CGMessagePos(para.fileinfo,type_e_cant_read_write_type); + error_para := true; + end; + + { support writeln(procvar) } + if (para.left.resulttype.def.deftype=procvardef) then + begin + p1:=ccallnode.create_procvar(nil,para.left); + resulttypepass(p1); + para.left:=p1; + end; + + { Currency will be written using the bestreal } + if is_currency(para.left.resulttype.def) then + inserttypeconv(para.left,pbestrealtype^); + + case para.left.resulttype.def.deftype of + stringdef : + begin + name := procprefix+tstringdef(para.left.resulttype.def).stringtypname; + end; + pointerdef : + begin + if (not is_pchar(para.left.resulttype.def)) or do_read then + begin + CGMessagePos(para.fileinfo,type_e_cant_read_write_type); + error_para := true; + end + else + name := procprefix+'pchar_as_pointer'; + end; + floatdef : + begin + is_real:=true; + name := procprefix+'float'; + readfunctype:=pbestrealtype^; + end; + orddef : + begin + case torddef(para.left.resulttype.def).typ of +{$ifdef cpu64bit} + s64bit, +{$endif cpu64bit} + s8bit, + s16bit, + s32bit : + begin + name := procprefix+'sint'; + readfunctype:=sinttype; + end; +{$ifdef cpu64bit} + u64bit, +{$endif cpu64bit} + u8bit, + u16bit, + u32bit : + begin + name := procprefix+'uint'; + readfunctype:=uinttype; + end; + uchar : + begin + name := procprefix+'char'; + readfunctype:=cchartype; + end; + uwidechar : + begin + name := procprefix+'widechar'; + readfunctype:=cwidechartype; + end; +{$ifndef cpu64bit} + s64bit : + begin + name := procprefix+'int64'; + readfunctype:=s64inttype; + end; + u64bit : + begin + name := procprefix+'qword'; + readfunctype:=u64inttype; + end; +{$endif cpu64bit} + bool8bit, + bool16bit, + bool32bit : + begin + if do_read then + begin + CGMessagePos(para.fileinfo,type_e_cant_read_write_type); + error_para := true; + end + else + begin + name := procprefix+'boolean'; + readfunctype:=booltype; + end; + end + else + begin + CGMessagePos(para.fileinfo,type_e_cant_read_write_type); + error_para := true; + end; + end; + end; + variantdef : + name:=procprefix+'variant'; + arraydef : + begin + if is_chararray(para.left.resulttype.def) then + name := procprefix+'pchar_as_array' + else + begin + CGMessagePos(para.fileinfo,type_e_cant_read_write_type); + error_para := true; + end + end + else + begin + CGMessagePos(para.fileinfo,type_e_cant_read_write_type); + error_para := true; + end + end; + + { check for length/fractional colon para's } + fracpara := nil; + lenpara := nil; + if assigned(para.right) and + (cpf_is_colon_para in tcallparanode(para.right).callparaflags) then + begin + lenpara := tcallparanode(para.right); + if assigned(lenpara.right) and + (cpf_is_colon_para in tcallparanode(lenpara.right).callparaflags) then + fracpara:=tcallparanode(lenpara.right); + end; + { get the next parameter now already, because we're going } + { to muck around with the pointers } + if assigned(fracpara) then + nextpara := tcallparanode(fracpara.right) + else if assigned(lenpara) then + nextpara := tcallparanode(lenpara.right) + else + nextpara := tcallparanode(para.right); + + { check if a fracpara is allowed } + if assigned(fracpara) and not is_real then + begin + CGMessagePos(fracpara.fileinfo,parser_e_illegal_colon_qualifier); + error_para := true; + end + else if assigned(lenpara) and do_read then + begin + { I think this is already filtered out by parsing, but I'm not sure (JM) } + CGMessagePos(lenpara.fileinfo,parser_e_illegal_colon_qualifier); + error_para := true; + end; + + { adjust found_error } + found_error := found_error or error_para; + + if not error_para then + begin + { create dummy frac/len para's if necessary } + if not do_read then + begin + { difference in default value for floats and the rest :( } + if not is_real then + begin + if not assigned(lenpara) then + lenpara := ccallparanode.create( + cordconstnode.create(0,sinttype,false),nil) + else + { make sure we don't pass the successive } + { parameters too. We also already have a } + { reference to the next parameter in } + { nextpara } + lenpara.right := nil; + end + else + begin + if not assigned(lenpara) then + lenpara := ccallparanode.create( + cordconstnode.create(-32767,sinttype,false),nil); + { also create a default fracpara if necessary } + if not assigned(fracpara) then + fracpara := ccallparanode.create( + cordconstnode.create(-1,sinttype,false),nil); + { add it to the lenpara } + lenpara.right := fracpara; + { and add the realtype para (this also removes the link } + { to any parameters coming after it) } + fracpara.right := ccallparanode.create( + cordconstnode.create(ord(tfloatdef(para.left.resulttype.def).typ), + sinttype,true),nil); + end; + end; + + { special handling of reading small numbers, because the helpers } + { expect a longint/card/bestreal var parameter. Use a temp. can't } + { use functions because then the call to FPC_IOCHECK destroys } + { their result before we can store it } + if do_read and + assigned(readfunctype.def) and + (para.left.resulttype.def<>readfunctype.def) then + begin + { create the parameter list: the temp ... } + temp := ctempcreatenode.create(readfunctype,readfunctype.def.size,tt_persistent,false); + addstatement(newstatement,temp); + + { ... and the file } + p1 := ccallparanode.create(ctemprefnode.create(temp), + filepara.getcopy); + + { create the call to the helper } + addstatement(newstatement, + ccallnode.createintern(name,tcallparanode(p1))); + + { assign the result to the original var (this automatically } + { takes care of range checking) } + addstatement(newstatement, + cassignmentnode.create(para.left, + ctemprefnode.create(temp))); + + { release the temp location } + addstatement(newstatement,ctempdeletenode.create(temp)); + + { statement of para is used } + para.left := nil; + + { free the enclosing tcallparanode, but not the } + { parameters coming after it } + para.right := nil; + para.free; + end + else + { read of non s/u-8/16bit, or a write } + begin + { add the filepara to the current parameter } + para.right := filepara.getcopy; + { add the lenpara (fracpara and realtype are already linked } + { with it if necessary) } + tcallparanode(para.right).right := lenpara; + { create the call statement } + addstatement(newstatement, + ccallnode.createintern(name,para)); + end + end + else + { error_para = true } + begin + { free the parameter, since it isn't referenced anywhere anymore } + para.right := nil; + para.free; + if assigned(lenpara) then + begin + lenpara.right := nil; + lenpara.free; + end; + if assigned(fracpara) then + begin + fracpara.right := nil; + fracpara.free; + end; + end; + + { process next parameter } + para := nextpara; + end; + + { if no error, add the write(ln)/read(ln) end calls } + if not found_error then + begin + case inlinenumber of + in_read_x: + name:='fpc_read_end'; + in_write_x: + name:='fpc_write_end'; + in_readln_x: + name:='fpc_readln_end'; + in_writeln_x: + name:='fpc_writeln_end'; + end; + addstatement(newstatement,ccallnode.createintern(name,filepara)); + end; + end; + + { if we found an error, simply delete the generated blocknode } + if found_error then + newblock.free + else + begin + { deallocate the temp for the file para if we used one } + if assigned(filetemp) then + addstatement(newstatement,ctempdeletenode.create(filetemp)); + { otherwise return the newly generated block of instructions, } + { but first free the errornode we generated at the beginning } + result.free; + result := newblock + end; + end; + + + function tinlinenode.handle_val: tnode; + var + procname, + suffix : string[31]; + sourcepara, + destpara, + codepara, + sizepara, + newparas : tcallparanode; + orgcode : tnode; + newstatement : tstatementnode; + newblock : tblocknode; + tempcode : ttempcreatenode; + begin + { for easy exiting if something goes wrong } + result := cerrornode.create; + + { check the amount of parameters } + if not(assigned(left)) or + not(assigned(tcallparanode(left).right)) then + begin + CGMessage(parser_e_wrong_parameter_size); + exit; + end; + + { reverse parameters for easier processing } + left := reverseparameters(tcallparanode(left)); + + { get the parameters } + tempcode := nil; + orgcode := nil; + sizepara := nil; + sourcepara := tcallparanode(left); + destpara := tcallparanode(sourcepara.right); + codepara := tcallparanode(destpara.right); + + { check if codepara is valid } + if assigned(codepara) and + ( + (codepara.resulttype.def.deftype <> orddef) +{$ifndef cpu64bit} + or is_64bitint(codepara.resulttype.def) +{$endif cpu64bit} + ) then + begin + CGMessagePos1(codepara.fileinfo,type_e_integer_expr_expected,codepara.resulttype.def.typename); + exit; + end; + + { check if dest para is valid } + if not(destpara.resulttype.def.deftype in [orddef,floatdef]) then + begin + CGMessagePos(destpara.fileinfo,type_e_integer_or_real_expr_expected); + exit; + end; + + { we're going to reuse the exisiting para's, so make sure they } + { won't be disposed } + left := nil; + + { create the blocknode which will hold the generated statements + } + { an initial dummy statement } + + newblock:=internalstatements(newstatement); + + { do we need a temp for code? Yes, if no code specified, or if } + { code is not a 32bit parameter (we already checked whether the } + { the code para, if specified, was an orddef) } + if not assigned(codepara) or + (codepara.resulttype.def.size<>sinttype.def.size) then + begin + tempcode := ctempcreatenode.create(sinttype,sinttype.def.size,tt_persistent,false); + addstatement(newstatement,tempcode); + { set the resulttype of the temp (needed to be able to get } + { the resulttype of the tempref used in the new code para) } + resulttypepass(tnode(tempcode)); + { create a temp codepara, but save the original code para to } + { assign the result to later on } + if assigned(codepara) then + begin + orgcode := codepara.left; + codepara.left := ctemprefnode.create(tempcode); + end + else + codepara := ccallparanode.create(ctemprefnode.create(tempcode),nil); + { we need its resulttype later on } + codepara.get_paratype; + end + else if (torddef(codepara.resulttype.def).typ = torddef(sinttype.def).typ) then + { because code is a var parameter, it must match types exactly } + { however, since it will return values in [0..255], both longints } + { and cardinals are fine. Since the formal code para type is } + { longint, insert a typecoversion to longint for cardinal para's } + begin + codepara.left := ctypeconvnode.create_internal(codepara.left,sinttype); + { make it explicit, oterwise you may get a nonsense range } + { check error if the cardinal already contained a value } + { > $7fffffff } + codepara.get_paratype; + end; + + { create the procedure name } + procname := 'fpc_val_'; + + case destpara.resulttype.def.deftype of + orddef: + begin + case torddef(destpara.resulttype.def).typ of +{$ifdef cpu64bit} + scurrency, + s64bit, +{$endif cpu64bit} + s8bit, + s16bit, + s32bit: + begin + suffix := 'sint_'; + { we also need a destsize para in this case } + sizepara := ccallparanode.create(cordconstnode.create + (destpara.resulttype.def.size,s32inttype,true),nil); + end; +{$ifdef cpu64bit} + u64bit, +{$endif cpu64bit} + u8bit, + u16bit, + u32bit: + suffix := 'uint_'; +{$ifndef cpu64bit} + scurrency, + s64bit: suffix := 'int64_'; + u64bit: suffix := 'qword_'; +{$endif cpu64bit} + else + internalerror(200304225); + end; + end; + floatdef: + begin + suffix := 'real_'; + end; + end; + + procname := procname + suffix; + + { play a trick to have tcallnode handle invalid source parameters: } + { the shortstring-longint val routine by default } + if (sourcepara.resulttype.def.deftype = stringdef) then + procname := procname + tstringdef(sourcepara.resulttype.def).stringtypname + else + procname := procname + 'shortstr'; + + { set up the correct parameters for the call: the code para... } + newparas := codepara; + { and the source para } + codepara.right := sourcepara; + { sizepara either contains nil if none is needed (which is ok, since } + { then the next statement severes any possible links with other paras } + { that sourcepara may have) or it contains the necessary size para and } + { its right field is nil } + sourcepara.right := sizepara; + + { create the call and assign the result to dest (val helpers are functions). + Use a trick to prevent a type size mismatch warning to be generated by the + assignment node. First convert implicitly to the resulttype. This will insert + the range check. The Second conversion is done explicitly to hide the implicit conversion + for the assignment node and therefor preventing the warning (PFV) } + addstatement(newstatement,cassignmentnode.create( + destpara.left,ctypeconvnode.create_internal(ctypeconvnode.create(ccallnode.createintern(procname,newparas),destpara.left.resulttype),destpara.left.resulttype))); + + { dispose of the enclosing paranode of the destination } + destpara.left := nil; + destpara.right := nil; + destpara.free; + + { check if we used a temp for code and whether we have to store } + { it to the real code parameter } + if assigned(orgcode) then + addstatement(newstatement,cassignmentnode.create( + orgcode, + ctemprefnode.create(tempcode))); + + { release the temp if we allocated one } + if assigned(tempcode) then + addstatement(newstatement,ctempdeletenode.create(tempcode)); + + { free the errornode } + result.free; + { and return it } + result := newblock; + end; + + +{$ifdef fpc} +{$maxfpuregisters 0} +{$endif fpc} + + function getpi : bestreal; + begin + {$ifdef x86} + { x86 has pi in hardware } + result:=pi; + {$else x86} + {$ifdef cpuextended} + result:=extended(MathPiExtended); + {$else cpuextended} + result:=double(MathPi); + {$endif cpuextended} + {$endif x86} + end; + + + function tinlinenode.det_resulttype:tnode; + + function do_lowhigh(const t:ttype) : tnode; + var + v : tconstexprint; + enum : tenumsym; + hp : tnode; + begin + case t.def.deftype of + orddef: + begin + if inlinenumber=in_low_x then + v:=torddef(t.def).low + else + v:=torddef(t.def).high; + { low/high of torddef are longints, so we need special } + { handling for cardinal and 64bit types (JM) } + { 1.0.x doesn't support int64($ffffffff) correct, it'll expand + to -1 instead of staying $ffffffff. Therefor we use $ffff with + shl twice (PFV) } + case torddef(t.def).typ of + s64bit,scurrency : + begin + if (inlinenumber=in_low_x) then + v := int64($80000000) shl 32 + else + v := (int64($7fffffff) shl 32) or int64($ffff) shl 16 or int64($ffff) + end; + u64bit : + begin + { we have to use a dirty trick for high(qword), } + { because it's bigger than high(tconstexprint) (JM) } + v := 0 + end + else + begin + if not is_signed(t.def) then + v := cardinal(v); + end; + end; + hp:=cordconstnode.create(v,t,true); + resulttypepass(hp); + { fix high(qword) } + if (torddef(t.def).typ=u64bit) and + (inlinenumber = in_high_x) then + tordconstnode(hp).value := -1; { is the same as qword($ffffffffffffffff) } + do_lowhigh:=hp; + end; + enumdef: + begin + enum:=tenumsym(tenumdef(t.def).firstenum); + v:=tenumdef(t.def).maxval; + if inlinenumber=in_high_x then + while assigned(enum) and (enum.value <> v) do + enum:=enum.nextenum; + if not assigned(enum) then + internalerror(309993) + else + hp:=genenumnode(enum); + do_lowhigh:=hp; + end; + else + internalerror(87); + end; + end; + + function getconstrealvalue : bestreal; + begin + case left.nodetype of + ordconstn: + getconstrealvalue:=tordconstnode(left).value; + realconstn: + getconstrealvalue:=trealconstnode(left).value_real; + else + internalerror(309992); + end; + end; + + procedure setconstrealvalue(r : bestreal); + begin + result:=crealconstnode.create(r,pbestrealtype^); + end; + + + function handle_ln_const(r : bestreal) : tnode; + begin + if r<=0.0 then + if (cs_check_range in aktlocalswitches) or + (cs_check_overflow in aktlocalswitches) then + begin + result:=crealconstnode.create(0,pbestrealtype^); + CGMessage(type_e_wrong_math_argument) + end + else + begin + if r=0.0 then + result:=crealconstnode.create(double(MathQNaN),pbestrealtype^) + else + result:=crealconstnode.create(double(MathNegInf),pbestrealtype^) + end + else + result:=crealconstnode.create(ln(r),pbestrealtype^) + end; + + + function handle_sqrt_const(r : bestreal) : tnode; + begin + if r<0.0 then + if (cs_check_range in aktlocalswitches) or + (cs_check_overflow in aktlocalswitches) then + begin + result:=crealconstnode.create(0,pbestrealtype^); + CGMessage(type_e_wrong_math_argument) + end + else + result:=crealconstnode.create(double(MathQNaN),pbestrealtype^) + else + result:=crealconstnode.create(sqrt(r),pbestrealtype^) + end; + + + procedure setfloatresulttype; + begin + if (left.resulttype.def.deftype=floatdef) and + (tfloatdef(left.resulttype.def).typ in [s32real,s64real,s80real,s128real]) then + resulttype:=left.resulttype + else + begin + inserttypeconv(left,pbestrealtype^); + resulttype:=pbestrealtype^; + end; + end; + + + var + vl,vl2 : TConstExprInt; + vr : bestreal; + hightree, + hp : tnode; + srsym : tsym; + checkrange : boolean; + label + myexit; + begin + result:=nil; + { if we handle writeln; left contains no valid address } + if assigned(left) then + begin + if left.nodetype=callparan then + tcallparanode(left).get_paratype + else + resulttypepass(left); + end; + inc(parsing_para_level); + + { handle intern constant functions in separate case } + if nf_inlineconst in flags then + begin + { no parameters? } + if not assigned(left) then + internalerror(200501231) + else + begin + vl:=0; + vl2:=0; { second parameter Ex: ptr(vl,vl2) } + case left.nodetype of + realconstn : + begin + { Real functions are all handled with internproc below } + CGMessage1(type_e_integer_expr_expected,left.resulttype.def.typename) + end; + ordconstn : + vl:=tordconstnode(left).value; + callparan : + begin + { both exists, else it was not generated } + vl:=tordconstnode(tcallparanode(left).left).value; + vl2:=tordconstnode(tcallparanode(tcallparanode(left).right).left).value; + end; + else + CGMessage(parser_e_illegal_expression); + end; + case inlinenumber of + in_const_abs : + hp:=genintconstnode(abs(vl)); + in_const_sqr : + hp:=genintconstnode(sqr(vl)); + in_const_odd : + hp:=cordconstnode.create(byte(odd(vl)),booltype,true); + in_const_swap_word : + hp:=cordconstnode.create((vl and $ff) shl 8+(vl shr 8),left.resulttype,true); + in_const_swap_long : + hp:=cordconstnode.create((vl and $ffff) shl 16+(vl shr 16),left.resulttype,true); + in_const_swap_qword : + hp:=cordconstnode.create((vl and $ffff) shl 32+(vl shr 32),left.resulttype,true); + in_const_ptr : + hp:=cpointerconstnode.create((vl2 shl 4)+vl,voidfarpointertype); + else + internalerror(88); + end; + end; + if hp=nil then + hp:=cerrornode.create; + result:=hp; + goto myexit; + end + else + begin + case inlinenumber of + in_lo_long, + in_hi_long, + in_lo_qword, + in_hi_qword, + in_lo_word, + in_hi_word : + begin + { give warning for incompatibility with tp and delphi } + if (inlinenumber in [in_lo_long,in_hi_long,in_lo_qword,in_hi_qword]) and + ((m_tp7 in aktmodeswitches) or + (m_delphi in aktmodeswitches)) then + CGMessage(type_w_maybe_wrong_hi_lo); + { constant folding } + if left.nodetype=ordconstn then + begin + case inlinenumber of + in_lo_word : + hp:=cordconstnode.create(tordconstnode(left).value and $ff,left.resulttype,true); + in_hi_word : + hp:=cordconstnode.create(tordconstnode(left).value shr 8,left.resulttype,true); + in_lo_long : + hp:=cordconstnode.create(tordconstnode(left).value and $ffff,left.resulttype,true); + in_hi_long : + hp:=cordconstnode.create(tordconstnode(left).value shr 16,left.resulttype,true); + in_lo_qword : + hp:=cordconstnode.create(tordconstnode(left).value and $ffffffff,left.resulttype,true); + in_hi_qword : + hp:=cordconstnode.create(tordconstnode(left).value shr 32,left.resulttype,true); + end; + result:=hp; + goto myexit; + end; + set_varstate(left,vs_used,[vsf_must_be_valid]); + if not is_integer(left.resulttype.def) then + CGMessage1(type_e_integer_expr_expected,left.resulttype.def.typename); + case inlinenumber of + in_lo_word, + in_hi_word : + resulttype:=u8inttype; + in_lo_long, + in_hi_long : + resulttype:=u16inttype; + in_lo_qword, + in_hi_qword : + resulttype:=u32inttype; + end; + end; + + + in_sizeof_x: + begin + set_varstate(left,vs_used,[]); + if paramanager.push_high_param(vs_value,left.resulttype.def,current_procinfo.procdef.proccalloption) then + begin + hightree:=load_high_value_node(tparavarsym(tloadnode(left).symtableentry)); + if assigned(hightree) then + begin + hp:=caddnode.create(addn,hightree, + cordconstnode.create(1,sinttype,false)); + if (left.resulttype.def.deftype=arraydef) and + (tarraydef(left.resulttype.def).elesize<>1) then + hp:=caddnode.create(muln,hp,cordconstnode.create(tarraydef( + left.resulttype.def).elesize,sinttype,true)); + result:=hp; + end; + end + else + resulttype:=sinttype; + end; + + in_typeof_x: + begin + set_varstate(left,vs_used,[]); + resulttype:=voidpointertype; + end; + + in_ord_x: + begin + if (left.nodetype=ordconstn) then + begin + hp:=cordconstnode.create( + tordconstnode(left).value,sinttype,true); + result:=hp; + goto myexit; + end; + set_varstate(left,vs_used,[vsf_must_be_valid]); + case left.resulttype.def.deftype of + orddef : + begin + case torddef(left.resulttype.def).typ of + bool8bit, + uchar: + begin + { change to byte() } + hp:=ctypeconvnode.create_internal(left,u8inttype); + left:=nil; + result:=hp; + end; + bool16bit, + uwidechar : + begin + { change to word() } + hp:=ctypeconvnode.create_internal(left,u16inttype); + left:=nil; + result:=hp; + end; + bool32bit : + begin + { change to dword() } + hp:=ctypeconvnode.create_internal(left,u32inttype); + left:=nil; + result:=hp; + end; + uvoid : + CGMessage1(type_e_ordinal_expr_expected,left.resulttype.def.typename); + else + begin + { all other orddef need no transformation } + hp:=left; + left:=nil; + result:=hp; + end; + end; + end; + enumdef : + begin + hp:=ctypeconvnode.create_internal(left,s32inttype); + left:=nil; + result:=hp; + end; + pointerdef : + begin + if m_mac in aktmodeswitches then + begin + hp:=ctypeconvnode.create_internal(left,ptrinttype); + left:=nil; + result:=hp; + end + else + CGMessage1(type_e_ordinal_expr_expected,left.resulttype.def.typename); + end + else + CGMessage1(type_e_ordinal_expr_expected,left.resulttype.def.typename); + end; + end; + + in_chr_byte: + begin + { convert to explicit char() } + set_varstate(left,vs_used,[vsf_must_be_valid]); + hp:=ctypeconvnode.create_internal(left,cchartype); + left:=nil; + result:=hp; + end; + + in_length_x: + begin + set_varstate(left,vs_used,[vsf_must_be_valid]); + + case left.resulttype.def.deftype of + variantdef: + begin + inserttypeconv(left,cansistringtype); + end; + + stringdef : + begin + { we don't need string convertions here } + if (left.nodetype=typeconvn) and + (ttypeconvnode(left).left.resulttype.def.deftype=stringdef) then + begin + hp:=ttypeconvnode(left).left; + ttypeconvnode(left).left:=nil; + left.free; + left:=hp; + end; + + { evaluates length of constant strings direct } + if (left.nodetype=stringconstn) then + begin + hp:=cordconstnode.create( + tstringconstnode(left).len,s32inttype,true); + result:=hp; + goto myexit; + end; + end; + orddef : + begin + { length of char is one allways } + if is_char(left.resulttype.def) or + is_widechar(left.resulttype.def) then + begin + hp:=cordconstnode.create(1,s32inttype,false); + result:=hp; + goto myexit; + end + else + CGMessage(type_e_mismatch); + end; + pointerdef : + begin + if is_pchar(left.resulttype.def) then + begin + hp := ccallparanode.create(left,nil); + result := ccallnode.createintern('fpc_pchar_length',hp); + { make sure the left node doesn't get disposed, since it's } + { reused in the new node (JM) } + left:=nil; + goto myexit; + end + else if is_pwidechar(left.resulttype.def) then + begin + hp := ccallparanode.create(left,nil); + result := ccallnode.createintern('fpc_pwidechar_length',hp); + { make sure the left node doesn't get disposed, since it's } + { reused in the new node (JM) } + left:=nil; + goto myexit; + end + else + CGMessage(type_e_mismatch); + end; + arraydef : + begin + if is_open_array(left.resulttype.def) or + is_array_of_const(left.resulttype.def) then + begin + hightree:=load_high_value_node(tparavarsym(tloadnode(left).symtableentry)); + if assigned(hightree) then + begin + hp:=caddnode.create(addn,hightree, + cordconstnode.create(1,s32inttype,false)); + result:=hp; + end; + goto myexit; + end + else + if not is_dynamic_array(left.resulttype.def) then + begin + hp:=cordconstnode.create(tarraydef(left.resulttype.def).highrange- + tarraydef(left.resulttype.def).lowrange+1, + s32inttype,true); + result:=hp; + goto myexit; + end + else + begin + hp := ccallparanode.create(ctypeconvnode.create_internal(left,voidpointertype),nil); + result := ccallnode.createintern('fpc_dynarray_length',hp); + { make sure the left node doesn't get disposed, since it's } + { reused in the new node (JM) } + left:=nil; + goto myexit; + end; + end; + else + CGMessage(type_e_mismatch); + end; + + { shortstring return an 8 bit value as the length + is the first byte of the string } + if is_shortstring(left.resulttype.def) then + resulttype:=u8inttype + else + resulttype:=sinttype; + end; + + in_typeinfo_x: + begin + set_varstate(left,vs_used,[vsf_must_be_valid]); + resulttype:=voidpointertype; + end; + + in_assigned_x: + begin + { the parser has already made sure the expression is valid } + + { handle constant expressions } + if is_constnode(tcallparanode(left).left) or + (tcallparanode(left).left.nodetype = pointerconstn) then + begin + { let an add node figure it out } + result := caddnode.create(unequaln,tcallparanode(left).left,cnilnode.create); + tcallparanode(left).left := nil; + { free left, because otherwise some code at 'myexit' tries } + { to run get_paratype for it, which crashes since left.left } + { is now nil } + left.free; + left := nil; + goto myexit; + end; + { otherwise handle separately, because there could be a procvar, which } + { is 2*sizeof(pointer), while we must only check the first pointer } + set_varstate(tcallparanode(left).left,vs_used,[vsf_must_be_valid]); + resulttype:=booltype; + end; + + in_ofs_x : + internalerror(2000101001); + + in_seg_x : + begin + set_varstate(left,vs_used,[]); + result:=cordconstnode.create(0,s32inttype,false); + goto myexit; + end; + + in_pred_x, + in_succ_x: + begin + set_varstate(left,vs_used,[vsf_must_be_valid]); + resulttype:=left.resulttype; + if not is_ordinal(resulttype.def) then + CGMessage(type_e_ordinal_expr_expected) + else + begin + if (resulttype.def.deftype=enumdef) and + (tenumdef(resulttype.def).has_jumps) then + CGMessage(type_e_succ_and_pred_enums_with_assign_not_possible); + end; + + { only if the result is an enum do we do range checking } + if (resulttype.def.deftype=enumdef) then + checkrange := true + else + checkrange := false; + + { do constant folding after check for jumps } + if left.nodetype=ordconstn then + begin + if inlinenumber=in_succ_x then + result:=cordconstnode.create(tordconstnode(left).value+1,left.resulttype,checkrange) + else + result:=cordconstnode.create(tordconstnode(left).value-1,left.resulttype,checkrange); + end; + end; + + in_initialize_x, + in_finalize_x, + in_setlength_x: + begin + { inlined from pinline } + internalerror(200204231); + end; + + in_inc_x, + in_dec_x: + begin + resulttype:=voidtype; + if assigned(left) then + begin + { first param must be var } + valid_for_var(tcallparanode(left).left); + set_varstate(tcallparanode(left).left,vs_used,[vsf_must_be_valid]); + + if (left.resulttype.def.deftype in [enumdef,pointerdef]) or + is_ordinal(left.resulttype.def) or + is_currency(left.resulttype.def) then + begin + { value of left gets changed -> must be unique } + set_unique(tcallparanode(left).left); + { two paras ? } + if assigned(tcallparanode(left).right) then + begin + set_varstate(tcallparanode(tcallparanode(left).right).left,vs_used,[vsf_must_be_valid]); + inserttypeconv_internal(tcallparanode(tcallparanode(left).right).left,tcallparanode(left).left.resulttype); + if assigned(tcallparanode(tcallparanode(left).right).right) then + CGMessage(parser_e_illegal_expression); + end; + end + else + CGMessage(type_e_ordinal_expr_expected); + end + else + CGMessage(type_e_mismatch); + end; + + in_read_x, + in_readln_x, + in_write_x, + in_writeln_x : + begin + result := handle_read_write; + end; + + in_settextbuf_file_x : + begin + resulttype:=voidtype; + { now we know the type of buffer } + srsym:=searchsymonlyin(systemunit,'SETTEXTBUF'); + hp:=ccallparanode.create(cordconstnode.create( + tcallparanode(left).left.resulttype.def.size,s32inttype,true),left); + result:=ccallnode.create(hp,tprocsym(srsym),systemunit,nil,[]); + left:=nil; + end; + + { the firstpass of the arg has been done in firstcalln ? } + in_reset_typedfile, + in_rewrite_typedfile : + begin + result := handle_reset_rewrite_typed; + end; + + in_str_x_string : + begin + result := handle_str; + end; + + in_val_x : + begin + result := handle_val; + end; + + in_include_x_y, + in_exclude_x_y: + begin + resulttype:=voidtype; + { the parser already checks whether we have two (and exectly two) } + { parameters (JM) } + { first param must be var } + valid_for_var(tcallparanode(left).left); + set_varstate(tcallparanode(left).left,vs_used,[vsf_must_be_valid]); + { check type } + if (left.resulttype.def.deftype=setdef) then + begin + { insert a type conversion } + { to the type of the set elements } + set_varstate(tcallparanode(tcallparanode(left).right).left,vs_used,[vsf_must_be_valid]); + inserttypeconv(tcallparanode(tcallparanode(left).right).left, + tsetdef(left.resulttype.def).elementtype); + end + else + CGMessage(type_e_mismatch); + end; + + in_slice_x: + begin + result:=nil; + resulttype:=tcallparanode(tcallparanode(left).left).resulttype; + if not(resulttype.def.deftype=arraydef) then + CGMessage(type_e_mismatch); + end; + + in_low_x, + in_high_x: + begin + case left.resulttype.def.deftype of + orddef, + enumdef: + begin + result:=do_lowhigh(left.resulttype); + end; + setdef: + begin + result:=do_lowhigh(tsetdef(left.resulttype.def).elementtype); + end; + arraydef: + begin + if inlinenumber=in_low_x then + begin + result:=cordconstnode.create(tarraydef( + left.resulttype.def).lowrange,tarraydef(left.resulttype.def).rangetype,true); + end + else + begin + if is_open_array(left.resulttype.def) or + is_array_of_const(left.resulttype.def) then + begin + set_varstate(left,vs_used,[vsf_must_be_valid]); + result:=load_high_value_node(tparavarsym(tloadnode(left).symtableentry)); + end + else + if is_dynamic_array(left.resulttype.def) then + begin + set_varstate(left,vs_used,[vsf_must_be_valid]); + { can't use inserttypeconv because we need } + { an explicit type conversion (JM) } + hp := ccallparanode.create(ctypeconvnode.create_internal(left,voidpointertype),nil); + result := ccallnode.createintern('fpc_dynarray_high',hp); + { make sure the left node doesn't get disposed, since it's } + { reused in the new node (JM) } + left:=nil; + end + else + begin + result:=cordconstnode.create(tarraydef( + left.resulttype.def).highrange,tarraydef(left.resulttype.def).rangetype,true); + end; + end; + end; + stringdef: + begin + if inlinenumber=in_low_x then + begin + result:=cordconstnode.create(0,u8inttype,false); + end + else + begin + if is_open_string(left.resulttype.def) then + begin + set_varstate(left,vs_used,[vsf_must_be_valid]); + result:=load_high_value_node(tparavarsym(tloadnode(left).symtableentry)) + end + else + result:=cordconstnode.create(tstringdef(left.resulttype.def).len,u8inttype,true); + end; + end; + else + CGMessage(type_e_mismatch); + end; + end; + + in_exp_real : + begin + if left.nodetype in [ordconstn,realconstn] then + begin + result:=crealconstnode.create(exp(getconstrealvalue),pbestrealtype^); + if (trealconstnode(result).value_real=double(MathInf)) and + ((cs_check_range in aktlocalswitches) or + (cs_check_overflow in aktlocalswitches)) then + begin + result:=crealconstnode.create(0,pbestrealtype^); + CGMessage(parser_e_range_check_error); + end; + end + else + begin + set_varstate(left,vs_used,[vsf_must_be_valid]); + inserttypeconv(left,pbestrealtype^); + resulttype:=pbestrealtype^; + end; + end; + + in_trunc_real : + begin + if left.nodetype in [ordconstn,realconstn] then + begin + vr:=getconstrealvalue; + if (vr>=9223372036854775807.5) or (vr<=-9223372036854775808.5) then + begin + CGMessage(parser_e_range_check_error); + result:=cordconstnode.create(1,s64inttype,false) + end + else + result:=cordconstnode.create(trunc(vr),s64inttype,true) + end + else + begin + set_varstate(left,vs_used,[vsf_must_be_valid]); + inserttypeconv(left,pbestrealtype^); + resulttype:=s64inttype; + end; + end; + + in_round_real : + begin + if left.nodetype in [ordconstn,realconstn] then + begin + vr:=getconstrealvalue; + if (vr>=9223372036854775807.5) or (vr<=-9223372036854775808.5) then + begin + CGMessage(parser_e_range_check_error); + result:=cordconstnode.create(1,s64inttype,false) + end + else + result:=cordconstnode.create(round(vr),s64inttype,true) + end + else + begin + set_varstate(left,vs_used,[vsf_must_be_valid]); + inserttypeconv(left,pbestrealtype^); + resulttype:=s64inttype; + end; + end; + + in_frac_real : + begin + if left.nodetype in [ordconstn,realconstn] then + setconstrealvalue(frac(getconstrealvalue)) + else + begin + set_varstate(left,vs_used,[vsf_must_be_valid]); + inserttypeconv(left,pbestrealtype^); + resulttype:=pbestrealtype^; + end; + end; + + in_int_real : + begin + if left.nodetype in [ordconstn,realconstn] then + setconstrealvalue(int(getconstrealvalue)) + else + begin + set_varstate(left,vs_used,[vsf_must_be_valid]); + inserttypeconv(left,pbestrealtype^); + resulttype:=pbestrealtype^; + end; + end; + + in_pi_real : + begin + if block_type=bt_const then + setconstrealvalue(getpi) + else + resulttype:=pbestrealtype^; + end; + + in_cos_real : + begin + if left.nodetype in [ordconstn,realconstn] then + setconstrealvalue(cos(getconstrealvalue)) + else + begin + set_varstate(left,vs_used,[vsf_must_be_valid]); + inserttypeconv(left,pbestrealtype^); + resulttype:=pbestrealtype^; + end; + end; + + in_sin_real : + begin + if left.nodetype in [ordconstn,realconstn] then + setconstrealvalue(sin(getconstrealvalue)) + else + begin + set_varstate(left,vs_used,[vsf_must_be_valid]); + inserttypeconv(left,pbestrealtype^); + resulttype:=pbestrealtype^; + end; + end; + + in_arctan_real : + begin + if left.nodetype in [ordconstn,realconstn] then + setconstrealvalue(arctan(getconstrealvalue)) + else + begin + set_varstate(left,vs_used,[vsf_must_be_valid]); + inserttypeconv(left,pbestrealtype^); + resulttype:=pbestrealtype^; + end; + end; + + in_abs_real : + begin + if left.nodetype in [ordconstn,realconstn] then + setconstrealvalue(abs(getconstrealvalue)) + else + begin + set_varstate(left,vs_used,[vsf_must_be_valid]); + inserttypeconv(left,pbestrealtype^); + resulttype:=pbestrealtype^; + end; + end; + + in_sqr_real : + begin + if left.nodetype in [ordconstn,realconstn] then + setconstrealvalue(sqr(getconstrealvalue)) + else + begin + set_varstate(left,vs_used,[vsf_must_be_valid]); + setfloatresulttype; + end; + end; + + in_sqrt_real : + begin + if left.nodetype in [ordconstn,realconstn] then + begin + vr:=getconstrealvalue; + if vr<0.0 then + result:=handle_sqrt_const(vr) + else + setconstrealvalue(sqrt(vr)); + end + else + begin + set_varstate(left,vs_used,[vsf_must_be_valid]); + setfloatresulttype; + end; + end; + + in_ln_real : + begin + if left.nodetype in [ordconstn,realconstn] then + begin + vr:=getconstrealvalue; + if vr<=0.0 then + result:=handle_ln_const(vr) + else + setconstrealvalue(ln(vr)); + end + else + begin + set_varstate(left,vs_used,[vsf_must_be_valid]); + inserttypeconv(left,pbestrealtype^); + resulttype:=pbestrealtype^; + end; + end; + + {$ifdef SUPPORT_MMX} + in_mmx_pcmpeqb..in_mmx_pcmpgtw: + begin + end; + {$endif SUPPORT_MMX} + in_prefetch_var: + begin + resulttype:=voidtype; + end; + in_assert_x_y : + begin + resulttype:=voidtype; + if assigned(left) then + begin + set_varstate(tcallparanode(left).left,vs_used,[vsf_must_be_valid]); + { check type } + if is_boolean(left.resulttype.def) then + begin + set_varstate(tcallparanode(tcallparanode(left).right).left,vs_used,[vsf_must_be_valid]); + { must always be a string } + inserttypeconv(tcallparanode(tcallparanode(left).right).left,cshortstringtype); + end + else + CGMessage1(type_e_boolean_expr_expected,left.resulttype.def.typename); + end + else + CGMessage(type_e_mismatch); + + { We've checked the whole statement for correctness, now we + can remove it if assertions are off } + if not(cs_do_assertion in aktlocalswitches) then + begin + { we need a valid node, so insert a nothingn } + result:=cnothingnode.create; + end + else + include(current_procinfo.flags,pi_do_call); + end; + + else + internalerror(8); + end; + end; + + myexit: + { Run get_paratype again to update maybe inserted typeconvs } + if not codegenerror then + begin + if assigned(left) and + (left.nodetype=callparan) then + tcallparanode(left).get_paratype; + end; + dec(parsing_para_level); + end; + + + function tinlinenode.pass_1 : tnode; + var + hp,hpp : tnode; + shiftconst: longint; + tempnode: ttempcreatenode; + newstatement: tstatementnode; + newblock: tblocknode; + + begin + result:=nil; + { if we handle writeln; left contains no valid address } + if assigned(left) then + begin + if left.nodetype=callparan then + tcallparanode(left).firstcallparan + else + firstpass(left); + left_max; + end; + + inc(parsing_para_level); + { intern const should already be handled } + if nf_inlineconst in flags then + internalerror(200104044); + case inlinenumber of + in_lo_qword, + in_hi_qword, + in_lo_long, + in_hi_long, + in_lo_word, + in_hi_word: + begin + shiftconst := 0; + case inlinenumber of + in_hi_qword: + shiftconst := 32; + in_hi_long: + shiftconst := 16; + in_hi_word: + shiftconst := 8; + end; + if shiftconst <> 0 then + result := ctypeconvnode.create_internal(cshlshrnode.create(shrn,left, + cordconstnode.create(shiftconst,u32inttype,false)),resulttype) + else + result := ctypeconvnode.create_internal(left,resulttype); + left := nil; + firstpass(result); + end; + + in_sizeof_x: + begin + if registersint<1 then + registersint:=1; + expectloc:=LOC_REGISTER; + end; + + in_typeof_x: + begin + if registersint<1 then + registersint:=1; + expectloc:=LOC_REGISTER; + end; + + in_length_x: + begin + if is_shortstring(left.resulttype.def) then + expectloc:=left.expectloc + else + begin + { ansi/wide string } + if registersint<1 then + registersint:=1; + expectloc:=LOC_REGISTER; + end; + end; + + in_typeinfo_x: + begin + expectloc:=LOC_REGISTER; + registersint:=1; + end; + + in_assigned_x: + begin + expectloc := LOC_JUMP; + registersint:=1; + end; + + in_pred_x, + in_succ_x: + begin + if is_64bit(resulttype.def) then + begin + if (registersint<2) then + registersint:=2 + end + else + begin + if (registersint<1) then + registersint:=1; + end; + expectloc:=LOC_REGISTER; + end; + + in_setlength_x, + in_initialize_x, + in_finalize_x: + begin + expectloc:=LOC_VOID; + end; + + in_inc_x, + in_dec_x: + begin + expectloc:=LOC_VOID; + + { check type } + if +{$ifndef cpu64bit} + is_64bit(left.resulttype.def) or +{$endif cpu64bit} + { range/overflow checking doesn't work properly } + { with the inc/dec code that's generated (JM) } + ( + (((left.resulttype.def.deftype = orddef) and + not(is_char(left.resulttype.def)) and + not(is_boolean(left.resulttype.def))) or + (left.resulttype.def.deftype = pointerdef)) and + (aktlocalswitches * [cs_check_overflow,cs_check_range] <> []) + ) then + { convert to simple add (JM) } + begin + newblock := internalstatements(newstatement); + { extra parameter? } + if assigned(tcallparanode(left).right) then + begin + { Yes, use for add node } + hpp := tcallparanode(tcallparanode(left).right).left; + tcallparanode(tcallparanode(left).right).left := nil; + if assigned(tcallparanode(tcallparanode(left).right).right) then + CGMessage(parser_e_illegal_expression); + end + else + begin + { no, create constant 1 } + hpp := cordconstnode.create(1,tcallparanode(left).left.resulttype,false); + end; + resulttypepass(hpp); +{$ifndef cpu64bit} + if not((hpp.resulttype.def.deftype=orddef) and + (torddef(hpp.resulttype.def).typ<>u32bit)) then +{$endif cpu64bit} + inserttypeconv_internal(hpp,sinttype); + { No overflow check for pointer operations, because inc(pointer,-1) will always + trigger an overflow. For uint32 it works because then the operation is done + in 64bit } + if (tcallparanode(left).left.resulttype.def.deftype=pointerdef) then + exclude(aktlocalswitches,cs_check_overflow); + { make sure we don't call functions part of the left node twice (and generally } + { optimize the code generation) } + if node_complexity(tcallparanode(left).left) > 1 then + begin + tempnode := ctempcreatenode.create(voidpointertype,voidpointertype.def.size,tt_persistent,true); + addstatement(newstatement,tempnode); + addstatement(newstatement,cassignmentnode.create(ctemprefnode.create(tempnode), + caddrnode.create_internal(tcallparanode(left).left.getcopy))); + hp := cderefnode.create(ctemprefnode.create(tempnode)); + inserttypeconv_internal(hp,tcallparanode(left).left.resulttype); + end + else + begin + hp := tcallparanode(left).left.getcopy; + tempnode := nil; + end; + { addition/substraction depending on inc/dec } + if inlinenumber = in_inc_x then + hpp := caddnode.create(addn,hp,hpp) + else + hpp := caddnode.create(subn,hp,hpp); + { assign result of addition } + inserttypeconv_internal(hpp,hp.resulttype); + addstatement(newstatement,cassignmentnode.create(hp.getcopy,hpp)); + { deallocate the temp } + if assigned(tempnode) then + addstatement(newstatement,ctempdeletenode.create(tempnode)); + { firstpass it } + firstpass(newblock); + { return new node } + result := newblock; + end + else if (left.resulttype.def.deftype in [enumdef,pointerdef]) or + is_ordinal(left.resulttype.def) then + begin + { two paras ? } + if assigned(tcallparanode(left).right) then + begin + { need we an additional register ? } + if not(is_constintnode(tcallparanode(tcallparanode(left).right).left)) and + (tcallparanode(tcallparanode(left).right).left.expectloc in [LOC_CREFERENCE,LOC_REFERENCE]) and + (tcallparanode(tcallparanode(left).right).left.registersint<=1) then + inc(registersint); + + { do we need an additional register to restore the first parameter? } + if tcallparanode(tcallparanode(left).right).left.registersint>=registersint then + inc(registersint); + end; + end; + end; + + in_include_x_y, + in_exclude_x_y: + begin + expectloc:=LOC_VOID; + + registersint:=left.registersint; + registersfpu:=left.registersfpu; +{$ifdef SUPPORT_MMX} + registersmmx:=left.registersmmx; +{$endif SUPPORT_MMX} + end; + + in_exp_real: + begin + result:= first_exp_real; + end; + + in_round_real: + begin + result:= first_round_real; + end; + + in_trunc_real: + begin + result:= first_trunc_real; + end; + + in_int_real: + begin + result:= first_int_real; + end; + + in_frac_real: + begin + result:= first_frac_real; + end; + + in_cos_real: + begin + result:= first_cos_real; + end; + + in_sin_real: + begin + result := first_sin_real; + end; + + in_arctan_real: + begin + result := first_arctan_real; + end; + + in_pi_real : + begin + result := first_pi; + end; + + in_abs_real: + begin + result := first_abs_real; + end; + + in_sqr_real: + begin + result := first_sqr_real; + end; + + in_sqrt_real: + begin + result := first_sqrt_real; + end; + + in_ln_real: + begin + result := first_ln_real; + end; + +{$ifdef SUPPORT_MMX} + in_mmx_pcmpeqb..in_mmx_pcmpgtw: + begin + end; +{$endif SUPPORT_MMX} + + in_assert_x_y : + begin + expectloc:=LOC_VOID; + registersint:=left.registersint; + registersfpu:=left.registersfpu; +{$ifdef SUPPORT_MMX} + registersmmx:=left.registersmmx; +{$endif SUPPORT_MMX} + end; + + in_low_x, + in_high_x: + internalerror(200104047); + + in_slice_x: + internalerror(2005101501); + + in_ord_x, + in_chr_byte: + begin + { should not happend as it's converted to typeconv } + internalerror(200104045); + end; + + in_ofs_x : + internalerror(2000101001); + + in_seg_x : + internalerror(200104046); + + in_settextbuf_file_x, + in_reset_typedfile, + in_rewrite_typedfile, + in_str_x_string, + in_val_x, + in_read_x, + in_readln_x, + in_write_x, + in_writeln_x : + begin + { should be handled by det_resulttype } + internalerror(200108234); + end; + + in_prefetch_var: + begin + expectloc:=LOC_VOID; + end; + + else + internalerror(8); + end; + dec(parsing_para_level); + end; +{$ifdef fpc} +{$maxfpuregisters default} +{$endif fpc} + + function tinlinenode.docompare(p: tnode): boolean; + begin + docompare := + inherited docompare(p) and + (inlinenumber = tinlinenode(p).inlinenumber); + end; + + + function tinlinenode.first_pi : tnode; + begin + result:=crealconstnode.create(getpi,pbestrealtype^); + end; + + + function tinlinenode.first_arctan_real : tnode; + begin + { create the call to the helper } + { on entry left node contains the parameter } + first_arctan_real := ccallnode.createintern('fpc_arctan_real', + ccallparanode.create(left,nil)); + left := nil; + end; + + function tinlinenode.first_abs_real : tnode; + begin + { create the call to the helper } + { on entry left node contains the parameter } + first_abs_real := ccallnode.createintern('fpc_abs_real', + ccallparanode.create(left,nil)); + left := nil; + end; + + function tinlinenode.first_sqr_real : tnode; + begin + { create the call to the helper } + { on entry left node contains the parameter } + first_sqr_real := ctypeconvnode.create_internal(ccallnode.createintern('fpc_sqr_real', + ccallparanode.create(left,nil)),resulttype); + left := nil; + end; + + function tinlinenode.first_sqrt_real : tnode; + begin + { create the call to the helper } + { on entry left node contains the parameter } + first_sqrt_real := ctypeconvnode.create_internal(ccallnode.createintern('fpc_sqrt_real', + ccallparanode.create(left,nil)),resulttype); + left := nil; + end; + + function tinlinenode.first_ln_real : tnode; + begin + { create the call to the helper } + { on entry left node contains the parameter } + first_ln_real := ccallnode.createintern('fpc_ln_real', + ccallparanode.create(left,nil)); + left := nil; + end; + + function tinlinenode.first_cos_real : tnode; + begin + { create the call to the helper } + { on entry left node contains the parameter } + first_cos_real := ccallnode.createintern('fpc_cos_real', + ccallparanode.create(left,nil)); + left := nil; + end; + + function tinlinenode.first_sin_real : tnode; + begin + { create the call to the helper } + { on entry left node contains the parameter } + first_sin_real := ccallnode.createintern('fpc_sin_real', + ccallparanode.create(left,nil)); + left := nil; + end; + + function tinlinenode.first_exp_real : tnode; + begin + { create the call to the helper } + { on entry left node contains the parameter } + result := ccallnode.createintern('fpc_exp_real',ccallparanode.create(left,nil)); + left := nil; + end; + + function tinlinenode.first_int_real : tnode; + begin + { create the call to the helper } + { on entry left node contains the parameter } + result := ccallnode.createintern('fpc_int_real',ccallparanode.create(left,nil)); + left := nil; + end; + + function tinlinenode.first_frac_real : tnode; + begin + { create the call to the helper } + { on entry left node contains the parameter } + result := ccallnode.createintern('fpc_frac_real',ccallparanode.create(left,nil)); + left := nil; + end; + + function tinlinenode.first_round_real : tnode; + begin + { create the call to the helper } + { on entry left node contains the parameter } + result := ccallnode.createintern('fpc_round_real',ccallparanode.create(left,nil)); + left := nil; + end; + + function tinlinenode.first_trunc_real : tnode; + begin + { create the call to the helper } + { on entry left node contains the parameter } + result := ccallnode.createintern('fpc_trunc_real',ccallparanode.create(left,nil)); + left := nil; + end; + +begin + cinlinenode:=tinlinenode; +end. |