ninl.pas 95 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268226922702271227222732274227522762277227822792280228122822283228422852286228722882289229022912292229322942295229622972298229923002301230223032304230523062307230823092310231123122313231423152316231723182319232023212322232323242325232623272328232923302331233223332334233523362337233823392340234123422343234423452346234723482349235023512352235323542355235623572358235923602361236223632364236523662367236823692370237123722373237423752376237723782379238023812382238323842385238623872388238923902391239223932394239523962397239823992400240124022403240424052406240724082409241024112412241324142415241624172418241924202421242224232424242524262427242824292430243124322433243424352436243724382439244024412442244324442445244624472448244924502451245224532454245524562457245824592460246124622463246424652466246724682469247024712472247324742475247624772478247924802481248224832484248524862487248824892490
  1. {
  2. $Id$
  3. Copyright (c) 1998-2002 by Florian Klaempfl
  4. Type checking and register allocation for inline nodes
  5. This program is free software; you can redistribute it and/or modify
  6. it under the terms of the GNU General Public License as published by
  7. the Free Software Foundation; either version 2 of the License, or
  8. (at your option) any later version.
  9. This program is distributed in the hope that it will be useful,
  10. but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  12. GNU General Public License for more details.
  13. You should have received a copy of the GNU General Public License
  14. along with this program; if not, write to the Free Software
  15. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  16. ****************************************************************************
  17. }
  18. unit ninl;
  19. {$i fpcdefs.inc}
  20. interface
  21. uses
  22. node,htypechk,cpuinfo,symtype;
  23. {$i compinnr.inc}
  24. type
  25. tinlinenode = class(tunarynode)
  26. inlinenumber : byte;
  27. constructor create(number : byte;is_const:boolean;l : tnode);virtual;
  28. constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
  29. procedure ppuwrite(ppufile:tcompilerppufile);override;
  30. function getcopy : tnode;override;
  31. function pass_1 : tnode;override;
  32. function det_resulttype:tnode;override;
  33. function docompare(p: tnode): boolean; override;
  34. { All the following routines currently
  35. call compilerproc's, unless they are
  36. overriden in which case, the code
  37. generator handles them.
  38. }
  39. function first_pi: tnode ; virtual;
  40. function first_arctan_real: tnode; virtual;
  41. function first_abs_real: tnode; virtual;
  42. function first_sqr_real: tnode; virtual;
  43. function first_sqrt_real: tnode; virtual;
  44. function first_ln_real: tnode; virtual;
  45. function first_cos_real: tnode; virtual;
  46. function first_sin_real: tnode; virtual;
  47. private
  48. function handle_str: tnode;
  49. function handle_reset_rewrite_typed: tnode;
  50. function handle_read_write: tnode;
  51. function handle_val: tnode;
  52. end;
  53. tinlinenodeclass = class of tinlinenode;
  54. var
  55. cinlinenode : tinlinenodeclass;
  56. function geninlinenode(number : byte;is_const:boolean;l : tnode) : tinlinenode;
  57. implementation
  58. uses
  59. verbose,globals,systems,
  60. globtype, cutils,
  61. symbase,symconst,symdef,symsym,symtable,paramgr,defutil,defcmp,
  62. pass_1,
  63. ncal,ncon,ncnv,nadd,nld,nbas,nflw,nmem,nmat,nutils,
  64. cgbase,procinfo
  65. ;
  66. function geninlinenode(number : byte;is_const:boolean;l : tnode) : tinlinenode;
  67. begin
  68. geninlinenode:=cinlinenode.create(number,is_const,l);
  69. end;
  70. {*****************************************************************************
  71. TINLINENODE
  72. *****************************************************************************}
  73. constructor tinlinenode.create(number : byte;is_const:boolean;l : tnode);
  74. begin
  75. inherited create(inlinen,l);
  76. if is_const then
  77. include(flags,nf_inlineconst);
  78. inlinenumber:=number;
  79. end;
  80. constructor tinlinenode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
  81. begin
  82. inherited ppuload(t,ppufile);
  83. inlinenumber:=ppufile.getbyte;
  84. end;
  85. procedure tinlinenode.ppuwrite(ppufile:tcompilerppufile);
  86. begin
  87. inherited ppuwrite(ppufile);
  88. ppufile.putbyte(inlinenumber);
  89. end;
  90. function tinlinenode.getcopy : tnode;
  91. var
  92. n : tinlinenode;
  93. begin
  94. n:=tinlinenode(inherited getcopy);
  95. n.inlinenumber:=inlinenumber;
  96. result:=n;
  97. end;
  98. function tinlinenode.handle_str : tnode;
  99. var
  100. lenpara,
  101. fracpara,
  102. newparas,
  103. dest,
  104. source : tcallparanode;
  105. procname: string;
  106. is_real : boolean;
  107. begin
  108. result := cerrornode.create;
  109. { make sure we got at least two parameters (if we got only one, }
  110. { this parameter may not be encapsulated in a callparan) }
  111. if not assigned(left) or
  112. (left.nodetype <> callparan) then
  113. begin
  114. CGMessage(parser_e_wrong_parameter_size);
  115. exit;
  116. end;
  117. { get destination string }
  118. dest := tcallparanode(left);
  119. { get source para (number) }
  120. source := dest;
  121. while assigned(source.right) do
  122. source := tcallparanode(source.right);
  123. is_real := source.resulttype.def.deftype = floatdef;
  124. if not assigned(dest) or
  125. ((dest.left.resulttype.def.deftype<>stringdef) and
  126. not(is_chararray(dest.left.resulttype.def))) or
  127. not(is_real or
  128. (source.left.resulttype.def.deftype = orddef)) then
  129. begin
  130. { the parser will give this message already because we }
  131. { return an errornode (JM) }
  132. { CGMessagePos(fileinfo,parser_e_illegal_expression); }
  133. exit;
  134. end;
  135. { get len/frac parameters }
  136. lenpara := nil;
  137. fracpara := nil;
  138. if (cpf_is_colon_para in tcallparanode(dest.right).callparaflags) then
  139. begin
  140. lenpara := tcallparanode(dest.right);
  141. { we can let the callnode do the type checking of these parameters too, }
  142. { but then the error messages aren't as nice }
  143. if not is_integer(lenpara.resulttype.def) then
  144. begin
  145. CGMessagePos1(lenpara.fileinfo,
  146. type_e_integer_expr_expected,lenpara.resulttype.def.typename);
  147. exit;
  148. end;
  149. if (cpf_is_colon_para in tcallparanode(lenpara.right).callparaflags) then
  150. begin
  151. { parameters are in reverse order! }
  152. fracpara := lenpara;
  153. lenpara := tcallparanode(lenpara.right);
  154. if not is_real then
  155. begin
  156. CGMessagePos(lenpara.fileinfo,parser_e_illegal_colon_qualifier);
  157. exit
  158. end;
  159. if not is_integer(lenpara.resulttype.def) then
  160. begin
  161. CGMessagePos1(lenpara.fileinfo,
  162. type_e_integer_expr_expected,lenpara.resulttype.def.typename);
  163. exit;
  164. end;
  165. end;
  166. end;
  167. { generate the parameter list for the compilerproc }
  168. newparas := dest;
  169. { if we have a float parameter, insert the realtype, len and fracpara parameters }
  170. if is_real then
  171. begin
  172. { insert realtype parameter }
  173. newparas.right := ccallparanode.create(cordconstnode.create(
  174. ord(tfloatdef(source.left.resulttype.def).typ),s32inttype,true),
  175. newparas.right);
  176. { if necessary, insert a fraction parameter }
  177. if not assigned(fracpara) then
  178. begin
  179. tcallparanode(newparas.right).right := ccallparanode.create(
  180. cordconstnode.create(-1,s32inttype,false),
  181. tcallparanode(newparas.right).right);
  182. fracpara := tcallparanode(tcallparanode(newparas.right).right);
  183. end;
  184. { if necessary, insert a length para }
  185. if not assigned(lenpara) then
  186. fracpara.right := ccallparanode.create(
  187. cordconstnode.create(-32767,s32inttype,false),
  188. fracpara.right);
  189. end
  190. else
  191. { for a normal parameter, insert a only length parameter if one is missing }
  192. if not assigned(lenpara) then
  193. newparas.right := ccallparanode.create(cordconstnode.create(-1,s32inttype,false),
  194. newparas.right);
  195. { remove the parameters from the original node so they won't get disposed, }
  196. { since they're reused }
  197. left := nil;
  198. { create procedure name }
  199. if is_chararray(dest.resulttype.def) then
  200. procname:='fpc_chararray_'
  201. else
  202. procname := 'fpc_' + tstringdef(dest.resulttype.def).stringtypname+'_';
  203. if is_real then
  204. procname := procname + 'float'
  205. else
  206. case torddef(source.resulttype.def).typ of
  207. {$ifdef cpu64bit}
  208. u64bit:
  209. procname := procname + 'uint';
  210. {$else}
  211. u32bit:
  212. procname := procname + 'uint';
  213. u64bit:
  214. procname := procname + 'qword';
  215. scurrency,
  216. s64bit:
  217. procname := procname + 'int64';
  218. {$endif}
  219. else
  220. procname := procname + 'sint';
  221. end;
  222. { free the errornode we generated in the beginning }
  223. result.free;
  224. { create the call node, }
  225. result := ccallnode.createintern(procname,newparas);
  226. end;
  227. function tinlinenode.handle_reset_rewrite_typed: tnode;
  228. begin
  229. { since this is a "in_xxxx_typedfile" node, we can be sure we have }
  230. { a typed file as argument and we don't have to check it again (JM) }
  231. { add the recsize parameter }
  232. { note: for some reason, the parameter of intern procedures with only one }
  233. { parameter is gets lifted out of its original tcallparanode (see round }
  234. { line 1306 of ncal.pas), so recreate a tcallparanode here (JM) }
  235. left := ccallparanode.create(cordconstnode.create(
  236. tfiledef(left.resulttype.def).typedfiletype.def.size,s32inttype,true),
  237. ccallparanode.create(left,nil));
  238. { create the correct call }
  239. if inlinenumber=in_reset_typedfile then
  240. result := ccallnode.createintern('fpc_reset_typed',left)
  241. else
  242. result := ccallnode.createintern('fpc_rewrite_typed',left);
  243. { make sure left doesn't get disposed, since we use it in the new call }
  244. left := nil;
  245. end;
  246. function tinlinenode.handle_read_write: tnode;
  247. const
  248. procnames: array[boolean,boolean] of string[11] =
  249. (('write_text_','read_text_'),('typed_write','typed_read'));
  250. var
  251. filepara,
  252. lenpara,
  253. fracpara,
  254. nextpara,
  255. para : tcallparanode;
  256. newstatement : tstatementnode;
  257. newblock : tblocknode;
  258. p1 : tnode;
  259. filetemp,
  260. temp : ttempcreatenode;
  261. procprefix,
  262. name : string[31];
  263. srsym : tvarsym;
  264. tempowner : tsymtable;
  265. readfunctype : ttype;
  266. is_typed,
  267. do_read,
  268. is_real,
  269. error_para,
  270. found_error : boolean;
  271. begin
  272. filepara := nil;
  273. is_typed := false;
  274. filetemp := nil;
  275. do_read := inlinenumber in [in_read_x,in_readln_x];
  276. { if we fail, we can quickly exit this way. We must generate something }
  277. { instead of the inline node, because firstpass will bomb with an }
  278. { internalerror if it encounters a read/write }
  279. result := cerrornode.create;
  280. { reverse the parameters (needed to get the colon parameters in the }
  281. { correct order when processing write(ln) }
  282. left := reverseparameters(tcallparanode(left));
  283. if assigned(left) then
  284. begin
  285. { check if we have a file parameter and if yes, what kind it is }
  286. filepara := tcallparanode(left);
  287. if (filepara.resulttype.def.deftype=filedef) then
  288. begin
  289. if (tfiledef(filepara.resulttype.def).filetyp=ft_untyped) then
  290. begin
  291. CGMessagePos(fileinfo,type_e_no_read_write_for_untyped_file);
  292. exit;
  293. end
  294. else
  295. begin
  296. if (tfiledef(filepara.resulttype.def).filetyp=ft_typed) then
  297. begin
  298. if (inlinenumber in [in_readln_x,in_writeln_x]) then
  299. begin
  300. CGMessagePos(fileinfo,type_e_no_readln_writeln_for_typed_file);
  301. exit;
  302. end;
  303. is_typed := true;
  304. end
  305. end;
  306. end
  307. else
  308. filepara := nil;
  309. end;
  310. { create a blocknode in which the successive write/read statements will be }
  311. { put, since they belong together. Also create a dummy statement already to }
  312. { make inserting of additional statements easier }
  313. newblock:=internalstatements(newstatement);
  314. { if we don't have a filepara, create one containing the default }
  315. if not assigned(filepara) then
  316. begin
  317. { retrieve the symbols for standard input/output handle }
  318. if do_read then
  319. name := 'INPUT'
  320. else
  321. name := 'OUTPUT';
  322. if not searchsysvar(name,srsym,tempowner) then
  323. internalerror(200108141);
  324. { since the input/output variables are threadvars loading them into
  325. a temp once is faster. Create a temp which will hold a pointer to the file }
  326. filetemp := ctempcreatenode.create_reg(voidpointertype,voidpointertype.def.size,tt_persistent);
  327. addstatement(newstatement,filetemp);
  328. { make sure the resulttype of the temp (and as such of the }
  329. { temprefs coming after it) is set (necessary because the }
  330. { temprefs will be part of the filepara, of which we need }
  331. { the resulttype later on and temprefs can only be }
  332. { resulttypepassed if the resulttype of the temp is known) }
  333. resulttypepass(tnode(filetemp));
  334. { assign the address of the file to the temp }
  335. addstatement(newstatement,
  336. cassignmentnode.create(ctemprefnode.create(filetemp),
  337. caddrnode.create(cloadnode.create(srsym,tempowner))));
  338. { create a new fileparameter as follows: file_type(temp^) }
  339. { (so that we pass the value and not the address of the temp }
  340. { to the read/write routine) }
  341. filepara := ccallparanode.create(ctypeconvnode.create_explicit(
  342. cderefnode.create(ctemprefnode.create(filetemp)),srsym.vartype),nil);
  343. end
  344. else
  345. { remove filepara from the parameter chain }
  346. begin
  347. left := filepara.right;
  348. filepara.right := nil;
  349. { the file para is a var parameter, but it must be valid already }
  350. set_varstate(filepara.left,vs_used,true);
  351. { check if we should make a temp to store the result of a complex }
  352. { expression (better heuristics, anyone?) (JM) }
  353. if (filepara.left.nodetype <> loadn) then
  354. begin
  355. { create a temp which will hold a pointer to the file }
  356. filetemp := ctempcreatenode.create_reg(voidpointertype,voidpointertype.def.size,tt_persistent);
  357. { add it to the statements }
  358. addstatement(newstatement,filetemp);
  359. { make sure the resulttype of the temp (and as such of the }
  360. { temprefs coming after it) is set (necessary because the }
  361. { temprefs will be part of the filepara, of which we need }
  362. { the resulttype later on and temprefs can only be }
  363. { resulttypepassed if the resulttype of the temp is known) }
  364. resulttypepass(tnode(filetemp));
  365. { assign the address of the file to the temp }
  366. addstatement(newstatement,
  367. cassignmentnode.create(ctemprefnode.create(filetemp),
  368. caddrnode.create(filepara.left)));
  369. resulttypepass(newstatement.left);
  370. { create a new fileparameter as follows: file_type(temp^) }
  371. { (so that we pass the value and not the address of the temp }
  372. { to the read/write routine) }
  373. nextpara := ccallparanode.create(ctypeconvnode.create_explicit(
  374. cderefnode.create(ctemprefnode.create(filetemp)),filepara.left.resulttype),nil);
  375. { replace the old file para with the new one }
  376. filepara.left := nil;
  377. filepara.free;
  378. filepara := nextpara;
  379. end;
  380. end;
  381. { the resulttype of the filepara must be set since it's }
  382. { used below }
  383. filepara.get_paratype;
  384. { now, filepara is nowhere referenced anymore, so we can safely dispose it }
  385. { if something goes wrong or at the end of the procedure }
  386. { choose the correct procedure prefix }
  387. procprefix := 'fpc_'+procnames[is_typed,do_read];
  388. { we're going to reuse the paranodes, so make sure they don't get freed }
  389. { twice }
  390. para := tcallparanode(left);
  391. left := nil;
  392. { no errors found yet... }
  393. found_error := false;
  394. if is_typed then
  395. begin
  396. { add the typesize to the filepara }
  397. filepara.right := ccallparanode.create(cordconstnode.create(
  398. tfiledef(filepara.resulttype.def).typedfiletype.def.size,s32inttype,true),nil);
  399. { check for "no parameters" (you need at least one extra para for typed files) }
  400. if not assigned(para) then
  401. begin
  402. CGMessage(parser_e_wrong_parameter_size);
  403. found_error := true;
  404. end;
  405. { process all parameters }
  406. while assigned(para) do
  407. begin
  408. { check if valid parameter }
  409. if para.left.nodetype=typen then
  410. begin
  411. CGMessagePos(para.left.fileinfo,type_e_cant_read_write_type);
  412. found_error := true;
  413. end;
  414. { support writeln(procvar) }
  415. if (para.left.resulttype.def.deftype=procvardef) then
  416. begin
  417. p1:=ccallnode.create_procvar(nil,para.left);
  418. resulttypepass(p1);
  419. para.left:=p1;
  420. end;
  421. inserttypeconv(para.left,tfiledef(filepara.resulttype.def).typedfiletype);
  422. if assigned(para.right) and
  423. (cpf_is_colon_para in tcallparanode(para.right).callparaflags) then
  424. begin
  425. CGMessagePos(para.right.fileinfo,parser_e_illegal_colon_qualifier);
  426. { skip all colon para's }
  427. nextpara := tcallparanode(tcallparanode(para.right).right);
  428. while assigned(nextpara) and
  429. (cpf_is_colon_para in nextpara.callparaflags) do
  430. nextpara := tcallparanode(nextpara.right);
  431. found_error := true;
  432. end
  433. else
  434. { get next parameter }
  435. nextpara := tcallparanode(para.right);
  436. { When we have a call, we have a problem: you can't pass the }
  437. { result of a call as a formal const parameter. Solution: }
  438. { assign the result to a temp and pass this temp as parameter }
  439. { This is not very efficient, but write(typedfile,x) is }
  440. { already slow by itself anyway (no buffering) (JM) }
  441. { Actually, thge same goes for every non-simple expression }
  442. { (such as an addition, ...) -> put everything but load nodes }
  443. { into temps (JM) }
  444. { of course, this must only be allowed for writes!!! (JM) }
  445. if not(do_read) and
  446. (para.left.nodetype <> loadn) then
  447. begin
  448. { create temp for result }
  449. temp := ctempcreatenode.create(para.left.resulttype,
  450. para.left.resulttype.def.size,tt_persistent);
  451. addstatement(newstatement,temp);
  452. { assign result to temp }
  453. addstatement(newstatement,
  454. cassignmentnode.create(ctemprefnode.create(temp),
  455. para.left));
  456. { replace (reused) paranode with temp }
  457. para.left := ctemprefnode.create(temp);
  458. end;
  459. { add fileparameter }
  460. para.right := filepara.getcopy;
  461. { create call statment }
  462. { since the parameters are in the correct order, we have to insert }
  463. { the statements always at the end of the current block }
  464. addstatement(newstatement,ccallnode.createintern(procprefix,para));
  465. { if we used a temp, free it }
  466. if para.left.nodetype = temprefn then
  467. addstatement(newstatement,ctempdeletenode.create(temp));
  468. { process next parameter }
  469. para := nextpara;
  470. end;
  471. { free the file parameter }
  472. filepara.free;
  473. end
  474. else
  475. { text read/write }
  476. begin
  477. while assigned(para) do
  478. begin
  479. { is this parameter faulty? }
  480. error_para := false;
  481. { is this parameter a real? }
  482. is_real:=false;
  483. { type used for the read(), this is used to check
  484. whether a temp is needed for range checking }
  485. readfunctype.reset;
  486. { can't read/write types }
  487. if para.left.nodetype=typen then
  488. begin
  489. CGMessagePos(para.fileinfo,type_e_cant_read_write_type);
  490. error_para := true;
  491. end;
  492. { support writeln(procvar) }
  493. if (para.left.resulttype.def.deftype=procvardef) then
  494. begin
  495. p1:=ccallnode.create_procvar(nil,para.left);
  496. resulttypepass(p1);
  497. para.left:=p1;
  498. end;
  499. { Currency will be written using the bestreal }
  500. if is_currency(para.left.resulttype.def) then
  501. inserttypeconv(para.left,pbestrealtype^);
  502. case para.left.resulttype.def.deftype of
  503. stringdef :
  504. begin
  505. name := procprefix+tstringdef(para.left.resulttype.def).stringtypname;
  506. end;
  507. pointerdef :
  508. begin
  509. if not is_pchar(para.left.resulttype.def) then
  510. begin
  511. CGMessagePos(para.fileinfo,type_e_cant_read_write_type);
  512. error_para := true;
  513. end
  514. else
  515. name := procprefix+'pchar_as_pointer';
  516. end;
  517. floatdef :
  518. begin
  519. is_real:=true;
  520. name := procprefix+'float';
  521. readfunctype:=pbestrealtype^;
  522. end;
  523. orddef :
  524. begin
  525. case torddef(para.left.resulttype.def).typ of
  526. {$ifdef cpu64bit}
  527. s64bit,
  528. {$endif cpu64bit}
  529. s8bit,
  530. s16bit,
  531. s32bit :
  532. begin
  533. name := procprefix+'sint';
  534. readfunctype:=sinttype;
  535. end;
  536. {$ifdef cpu64bit}
  537. u64bit,
  538. {$endif cpu64bit}
  539. u8bit,
  540. u16bit,
  541. u32bit :
  542. begin
  543. name := procprefix+'uint';
  544. readfunctype:=uinttype;
  545. end;
  546. uchar :
  547. begin
  548. name := procprefix+'char';
  549. readfunctype:=cchartype;
  550. end;
  551. uwidechar :
  552. begin
  553. name := procprefix+'widechar';
  554. readfunctype:=cwidechartype;
  555. end;
  556. {$ifndef cpu64bit}
  557. s64bit :
  558. begin
  559. name := procprefix+'int64';
  560. readfunctype:=s64inttype;
  561. end;
  562. u64bit :
  563. begin
  564. name := procprefix+'qword';
  565. readfunctype:=u64inttype;
  566. end;
  567. {$endif cpu64bit}
  568. bool8bit,
  569. bool16bit,
  570. bool32bit :
  571. begin
  572. if do_read then
  573. begin
  574. CGMessagePos(para.fileinfo,type_e_cant_read_write_type);
  575. error_para := true;
  576. end
  577. else
  578. begin
  579. name := procprefix+'boolean';
  580. readfunctype:=booltype;
  581. end;
  582. end
  583. else
  584. begin
  585. CGMessagePos(para.fileinfo,type_e_cant_read_write_type);
  586. error_para := true;
  587. end;
  588. end;
  589. end;
  590. variantdef :
  591. name:=procprefix+'variant';
  592. arraydef :
  593. begin
  594. if is_chararray(para.left.resulttype.def) then
  595. name := procprefix+'pchar_as_array'
  596. else
  597. begin
  598. CGMessagePos(para.fileinfo,type_e_cant_read_write_type);
  599. error_para := true;
  600. end
  601. end
  602. else
  603. begin
  604. CGMessagePos(para.fileinfo,type_e_cant_read_write_type);
  605. error_para := true;
  606. end
  607. end;
  608. { check for length/fractional colon para's }
  609. fracpara := nil;
  610. lenpara := nil;
  611. if assigned(para.right) and
  612. (cpf_is_colon_para in tcallparanode(para.right).callparaflags) then
  613. begin
  614. lenpara := tcallparanode(para.right);
  615. if assigned(lenpara.right) and
  616. (cpf_is_colon_para in tcallparanode(lenpara.right).callparaflags) then
  617. fracpara:=tcallparanode(lenpara.right);
  618. end;
  619. { get the next parameter now already, because we're going }
  620. { to muck around with the pointers }
  621. if assigned(fracpara) then
  622. nextpara := tcallparanode(fracpara.right)
  623. else if assigned(lenpara) then
  624. nextpara := tcallparanode(lenpara.right)
  625. else
  626. nextpara := tcallparanode(para.right);
  627. { check if a fracpara is allowed }
  628. if assigned(fracpara) and not is_real then
  629. begin
  630. CGMessagePos(fracpara.fileinfo,parser_e_illegal_colon_qualifier);
  631. error_para := true;
  632. end
  633. else if assigned(lenpara) and do_read then
  634. begin
  635. { I think this is already filtered out by parsing, but I'm not sure (JM) }
  636. CGMessagePos(lenpara.fileinfo,parser_e_illegal_colon_qualifier);
  637. error_para := true;
  638. end;
  639. { adjust found_error }
  640. found_error := found_error or error_para;
  641. if not error_para then
  642. begin
  643. { create dummy frac/len para's if necessary }
  644. if not do_read then
  645. begin
  646. { difference in default value for floats and the rest :( }
  647. if not is_real then
  648. begin
  649. if not assigned(lenpara) then
  650. lenpara := ccallparanode.create(
  651. cordconstnode.create(0,sinttype,false),nil)
  652. else
  653. { make sure we don't pass the successive }
  654. { parameters too. We also already have a }
  655. { reference to the next parameter in }
  656. { nextpara }
  657. lenpara.right := nil;
  658. end
  659. else
  660. begin
  661. if not assigned(lenpara) then
  662. lenpara := ccallparanode.create(
  663. cordconstnode.create(-32767,sinttype,false),nil);
  664. { also create a default fracpara if necessary }
  665. if not assigned(fracpara) then
  666. fracpara := ccallparanode.create(
  667. cordconstnode.create(-1,sinttype,false),nil);
  668. { add it to the lenpara }
  669. lenpara.right := fracpara;
  670. { and add the realtype para (this also removes the link }
  671. { to any parameters coming after it) }
  672. fracpara.right := ccallparanode.create(
  673. cordconstnode.create(ord(tfloatdef(para.left.resulttype.def).typ),
  674. sinttype,true),nil);
  675. end;
  676. end;
  677. { special handling of reading small numbers, because the helpers }
  678. { expect a longint/card/bestreal var parameter. Use a temp. can't }
  679. { use functions because then the call to FPC_IOCHECK destroys }
  680. { their result before we can store it }
  681. if do_read and
  682. assigned(readfunctype.def) and
  683. (para.left.resulttype.def<>readfunctype.def) then
  684. begin
  685. { create the parameter list: the temp ... }
  686. temp := ctempcreatenode.create(readfunctype,readfunctype.def.size,tt_persistent);
  687. addstatement(newstatement,temp);
  688. { ... and the file }
  689. p1 := ccallparanode.create(ctemprefnode.create(temp),
  690. filepara.getcopy);
  691. { create the call to the helper }
  692. addstatement(newstatement,
  693. ccallnode.createintern(name,tcallparanode(p1)));
  694. { assign the result to the original var (this automatically }
  695. { takes care of range checking) }
  696. addstatement(newstatement,
  697. cassignmentnode.create(para.left,
  698. ctemprefnode.create(temp)));
  699. { release the temp location }
  700. addstatement(newstatement,ctempdeletenode.create(temp));
  701. { statement of para is used }
  702. para.left := nil;
  703. { free the enclosing tcallparanode, but not the }
  704. { parameters coming after it }
  705. para.right := nil;
  706. para.free;
  707. end
  708. else
  709. { read of non s/u-8/16bit, or a write }
  710. begin
  711. { add the filepara to the current parameter }
  712. para.right := filepara.getcopy;
  713. { add the lenpara (fracpara and realtype are already linked }
  714. { with it if necessary) }
  715. tcallparanode(para.right).right := lenpara;
  716. { create the call statement }
  717. addstatement(newstatement,
  718. ccallnode.createintern(name,para));
  719. end
  720. end
  721. else
  722. { error_para = true }
  723. begin
  724. { free the parameter, since it isn't referenced anywhere anymore }
  725. para.right := nil;
  726. para.free;
  727. if assigned(lenpara) then
  728. begin
  729. lenpara.right := nil;
  730. lenpara.free;
  731. end;
  732. if assigned(fracpara) then
  733. begin
  734. fracpara.right := nil;
  735. fracpara.free;
  736. end;
  737. end;
  738. { process next parameter }
  739. para := nextpara;
  740. end;
  741. { if no error, add the write(ln)/read(ln) end calls }
  742. if not found_error then
  743. begin
  744. case inlinenumber of
  745. in_read_x:
  746. name:='fpc_read_end';
  747. in_write_x:
  748. name:='fpc_write_end';
  749. in_readln_x:
  750. name:='fpc_readln_end';
  751. in_writeln_x:
  752. name:='fpc_writeln_end';
  753. end;
  754. addstatement(newstatement,ccallnode.createintern(name,filepara));
  755. end;
  756. end;
  757. { if we found an error, simply delete the generated blocknode }
  758. if found_error then
  759. newblock.free
  760. else
  761. begin
  762. { deallocate the temp for the file para if we used one }
  763. if assigned(filetemp) then
  764. addstatement(newstatement,ctempdeletenode.create(filetemp));
  765. { otherwise return the newly generated block of instructions, }
  766. { but first free the errornode we generated at the beginning }
  767. result.free;
  768. result := newblock
  769. end;
  770. end;
  771. function tinlinenode.handle_val: tnode;
  772. var
  773. procname,
  774. suffix : string[31];
  775. sourcepara,
  776. destpara,
  777. codepara,
  778. sizepara,
  779. newparas : tcallparanode;
  780. orgcode : tnode;
  781. newstatement : tstatementnode;
  782. newblock : tblocknode;
  783. tempcode : ttempcreatenode;
  784. begin
  785. { for easy exiting if something goes wrong }
  786. result := cerrornode.create;
  787. { check the amount of parameters }
  788. if not(assigned(left)) or
  789. not(assigned(tcallparanode(left).right)) then
  790. begin
  791. CGMessage(parser_e_wrong_parameter_size);
  792. exit;
  793. end;
  794. { reverse parameters for easier processing }
  795. left := reverseparameters(tcallparanode(left));
  796. { get the parameters }
  797. tempcode := nil;
  798. orgcode := nil;
  799. sizepara := nil;
  800. sourcepara := tcallparanode(left);
  801. destpara := tcallparanode(sourcepara.right);
  802. codepara := tcallparanode(destpara.right);
  803. { check if codepara is valid }
  804. if assigned(codepara) and
  805. (
  806. (codepara.resulttype.def.deftype <> orddef)
  807. {$ifndef cpu64bit}
  808. or is_64bitint(codepara.resulttype.def)
  809. {$endif cpu64bit}
  810. ) then
  811. begin
  812. CGMessagePos1(codepara.fileinfo,type_e_integer_expr_expected,codepara.resulttype.def.typename);
  813. exit;
  814. end;
  815. { check if dest para is valid }
  816. if not(destpara.resulttype.def.deftype in [orddef,floatdef]) then
  817. begin
  818. CGMessagePos(destpara.fileinfo,type_e_integer_or_real_expr_expected);
  819. exit;
  820. end;
  821. { we're going to reuse the exisiting para's, so make sure they }
  822. { won't be disposed }
  823. left := nil;
  824. { create the blocknode which will hold the generated statements + }
  825. { an initial dummy statement }
  826. newblock:=internalstatements(newstatement);
  827. { do we need a temp for code? Yes, if no code specified, or if }
  828. { code is not a 32bit parameter (we already checked whether the }
  829. { the code para, if specified, was an orddef) }
  830. if not assigned(codepara) or
  831. (codepara.resulttype.def.size<>sinttype.def.size) then
  832. begin
  833. tempcode := ctempcreatenode.create(sinttype,sinttype.def.size,tt_persistent);
  834. addstatement(newstatement,tempcode);
  835. { set the resulttype of the temp (needed to be able to get }
  836. { the resulttype of the tempref used in the new code para) }
  837. resulttypepass(tnode(tempcode));
  838. { create a temp codepara, but save the original code para to }
  839. { assign the result to later on }
  840. if assigned(codepara) then
  841. begin
  842. orgcode := codepara.left;
  843. codepara.left := ctemprefnode.create(tempcode);
  844. end
  845. else
  846. codepara := ccallparanode.create(ctemprefnode.create(tempcode),nil);
  847. { we need its resulttype later on }
  848. codepara.get_paratype;
  849. end
  850. else if (torddef(codepara.resulttype.def).typ = torddef(sinttype.def).typ) then
  851. { because code is a var parameter, it must match types exactly }
  852. { however, since it will return values in [0..255], both longints }
  853. { and cardinals are fine. Since the formal code para type is }
  854. { longint, insert a typecoversion to longint for cardinal para's }
  855. begin
  856. codepara.left := ctypeconvnode.create_explicit(codepara.left,sinttype);
  857. { make it explicit, oterwise you may get a nonsense range }
  858. { check error if the cardinal already contained a value }
  859. { > $7fffffff }
  860. codepara.get_paratype;
  861. end;
  862. { create the procedure name }
  863. procname := 'fpc_val_';
  864. case destpara.resulttype.def.deftype of
  865. orddef:
  866. begin
  867. case torddef(destpara.resulttype.def).typ of
  868. {$ifdef cpu64bit}
  869. scurrency,
  870. s64bit,
  871. {$endif cpu64bit}
  872. s8bit,
  873. s16bit,
  874. s32bit:
  875. begin
  876. suffix := 'sint_';
  877. { we also need a destsize para in this case }
  878. sizepara := ccallparanode.create(cordconstnode.create
  879. (destpara.resulttype.def.size,s32inttype,true),nil);
  880. end;
  881. {$ifdef cpu64bit}
  882. u64bit,
  883. {$endif cpu64bit}
  884. u8bit,
  885. u16bit,
  886. u32bit:
  887. suffix := 'uint_';
  888. {$ifndef cpu64bit}
  889. scurrency,
  890. s64bit: suffix := 'int64_';
  891. u64bit: suffix := 'qword_';
  892. {$endif cpu64bit}
  893. else
  894. internalerror(200304225);
  895. end;
  896. end;
  897. floatdef:
  898. begin
  899. suffix := 'real_';
  900. end;
  901. end;
  902. procname := procname + suffix;
  903. { play a trick to have tcallnode handle invalid source parameters: }
  904. { the shortstring-longint val routine by default }
  905. if (sourcepara.resulttype.def.deftype = stringdef) then
  906. procname := procname + tstringdef(sourcepara.resulttype.def).stringtypname
  907. else
  908. procname := procname + 'shortstr';
  909. { set up the correct parameters for the call: the code para... }
  910. newparas := codepara;
  911. { and the source para }
  912. codepara.right := sourcepara;
  913. { sizepara either contains nil if none is needed (which is ok, since }
  914. { then the next statement severes any possible links with other paras }
  915. { that sourcepara may have) or it contains the necessary size para and }
  916. { its right field is nil }
  917. sourcepara.right := sizepara;
  918. { create the call and assign the result to dest }
  919. { (val helpers are functions) }
  920. { the assignment will take care of rangechecking }
  921. addstatement(newstatement,cassignmentnode.create(
  922. destpara.left,ccallnode.createintern(procname,newparas)));
  923. { dispose of the enclosing paranode of the destination }
  924. destpara.left := nil;
  925. destpara.right := nil;
  926. destpara.free;
  927. { check if we used a temp for code and whether we have to store }
  928. { it to the real code parameter }
  929. if assigned(orgcode) then
  930. addstatement(newstatement,cassignmentnode.create(
  931. orgcode,
  932. ctemprefnode.create(tempcode)));
  933. { release the temp if we allocated one }
  934. if assigned(tempcode) then
  935. addstatement(newstatement,ctempdeletenode.create(tempcode));
  936. { free the errornode }
  937. result.free;
  938. { and return it }
  939. result := newblock;
  940. end;
  941. {$ifdef fpc}
  942. {$maxfpuregisters 0}
  943. {$endif fpc}
  944. function tinlinenode.det_resulttype:tnode;
  945. function do_lowhigh(const t:ttype) : tnode;
  946. var
  947. v : tconstexprint;
  948. enum : tenumsym;
  949. hp : tnode;
  950. begin
  951. case t.def.deftype of
  952. orddef:
  953. begin
  954. if inlinenumber=in_low_x then
  955. v:=torddef(t.def).low
  956. else
  957. v:=torddef(t.def).high;
  958. { low/high of torddef are longints, so we need special }
  959. { handling for cardinal and 64bit types (JM) }
  960. { 1.0.x doesn't support int64($ffffffff) correct, it'll expand
  961. to -1 instead of staying $ffffffff. Therefor we use $ffff with
  962. shl twice (PFV) }
  963. case torddef(t.def).typ of
  964. s64bit,scurrency :
  965. begin
  966. if (inlinenumber=in_low_x) then
  967. v := int64($80000000) shl 32
  968. else
  969. v := (int64($7fffffff) shl 32) or int64($ffff) shl 16 or int64($ffff)
  970. end;
  971. u64bit :
  972. begin
  973. { we have to use a dirty trick for high(qword), }
  974. { because it's bigger than high(tconstexprint) (JM) }
  975. v := 0
  976. end
  977. else
  978. begin
  979. if not is_signed(t.def) then
  980. v := cardinal(v);
  981. end;
  982. end;
  983. hp:=cordconstnode.create(v,t,true);
  984. resulttypepass(hp);
  985. { fix high(qword) }
  986. if (torddef(t.def).typ=u64bit) and
  987. (inlinenumber = in_high_x) then
  988. tordconstnode(hp).value := -1; { is the same as qword($ffffffffffffffff) }
  989. do_lowhigh:=hp;
  990. end;
  991. enumdef:
  992. begin
  993. enum:=tenumsym(tenumdef(t.def).firstenum);
  994. v:=tenumdef(t.def).maxval;
  995. if inlinenumber=in_high_x then
  996. while assigned(enum) and (enum.value <> v) do
  997. enum:=enum.nextenum;
  998. if not assigned(enum) then
  999. internalerror(309993)
  1000. else
  1001. hp:=genenumnode(enum);
  1002. do_lowhigh:=hp;
  1003. end;
  1004. else
  1005. internalerror(87);
  1006. end;
  1007. end;
  1008. function getconstrealvalue : bestreal;
  1009. begin
  1010. case left.nodetype of
  1011. ordconstn:
  1012. getconstrealvalue:=tordconstnode(left).value;
  1013. realconstn:
  1014. getconstrealvalue:=trealconstnode(left).value_real;
  1015. else
  1016. internalerror(309992);
  1017. end;
  1018. end;
  1019. procedure setconstrealvalue(r : bestreal);
  1020. begin
  1021. result:=crealconstnode.create(r,pbestrealtype^);
  1022. end;
  1023. function handle_ln_const(r : bestreal) : tnode;
  1024. begin
  1025. if r<=0.0 then
  1026. if (cs_check_range in aktlocalswitches) or
  1027. (cs_check_overflow in aktlocalswitches) then
  1028. begin
  1029. result:=crealconstnode.create(0,pbestrealtype^);
  1030. CGMessage(type_e_wrong_math_argument)
  1031. end
  1032. else
  1033. begin
  1034. if r=0.0 then
  1035. result:=crealconstnode.create(double(MathQNaN),pbestrealtype^)
  1036. else
  1037. result:=crealconstnode.create(double(MathNegInf),pbestrealtype^)
  1038. end
  1039. else
  1040. result:=crealconstnode.create(ln(r),pbestrealtype^)
  1041. end;
  1042. function handle_sqrt_const(r : bestreal) : tnode;
  1043. begin
  1044. if r<0.0 then
  1045. if (cs_check_range in aktlocalswitches) or
  1046. (cs_check_overflow in aktlocalswitches) then
  1047. begin
  1048. result:=crealconstnode.create(0,pbestrealtype^);
  1049. CGMessage(type_e_wrong_math_argument)
  1050. end
  1051. else
  1052. result:=crealconstnode.create(double(MathQNaN),pbestrealtype^)
  1053. else
  1054. result:=crealconstnode.create(sqrt(r),pbestrealtype^)
  1055. end;
  1056. var
  1057. vl,vl2 : TConstExprInt;
  1058. vr : bestreal;
  1059. hightree,
  1060. hp : tnode;
  1061. srsym : tsym;
  1062. isreal : boolean;
  1063. checkrange : boolean;
  1064. label
  1065. myexit;
  1066. begin
  1067. result:=nil;
  1068. { if we handle writeln; left contains no valid address }
  1069. if assigned(left) then
  1070. begin
  1071. if left.nodetype=callparan then
  1072. tcallparanode(left).get_paratype
  1073. else
  1074. resulttypepass(left);
  1075. end;
  1076. inc(parsing_para_level);
  1077. { handle intern constant functions in separate case }
  1078. if nf_inlineconst in flags then
  1079. begin
  1080. { no parameters? }
  1081. if not assigned(left) then
  1082. begin
  1083. case inlinenumber of
  1084. in_const_pi :
  1085. hp:=crealconstnode.create(pi,pbestrealtype^);
  1086. else
  1087. internalerror(89);
  1088. end;
  1089. end
  1090. else
  1091. begin
  1092. vl:=0;
  1093. vl2:=0; { second parameter Ex: ptr(vl,vl2) }
  1094. vr:=0;
  1095. isreal:=false;
  1096. case left.nodetype of
  1097. realconstn :
  1098. begin
  1099. isreal:=true;
  1100. vr:=trealconstnode(left).value_real;
  1101. end;
  1102. ordconstn :
  1103. vl:=tordconstnode(left).value;
  1104. callparan :
  1105. begin
  1106. { both exists, else it was not generated }
  1107. vl:=tordconstnode(tcallparanode(left).left).value;
  1108. vl2:=tordconstnode(tcallparanode(tcallparanode(left).right).left).value;
  1109. end;
  1110. else
  1111. CGMessage(parser_e_illegal_expression);
  1112. end;
  1113. case inlinenumber of
  1114. in_const_trunc :
  1115. begin
  1116. if isreal then
  1117. begin
  1118. if (vr>=9223372036854775808.0) or (vr<=-9223372036854775809.0) then
  1119. begin
  1120. CGMessage(parser_e_range_check_error);
  1121. hp:=cordconstnode.create(1,s64inttype,false)
  1122. end
  1123. else
  1124. hp:=cordconstnode.create(trunc(vr),s64inttype,true)
  1125. end
  1126. else
  1127. hp:=cordconstnode.create(trunc(vl),s64inttype,true);
  1128. end;
  1129. in_const_round :
  1130. begin
  1131. if isreal then
  1132. begin
  1133. if (vr>=9223372036854775807.5) or (vr<=-9223372036854775808.5) then
  1134. begin
  1135. CGMessage(parser_e_range_check_error);
  1136. hp:=cordconstnode.create(1,s64inttype,false)
  1137. end
  1138. else
  1139. hp:=cordconstnode.create(round(vr),s64inttype,true)
  1140. end
  1141. else
  1142. hp:=cordconstnode.create(round(vl),s64inttype,true);
  1143. end;
  1144. in_const_frac :
  1145. begin
  1146. if isreal then
  1147. hp:=crealconstnode.create(frac(vr),pbestrealtype^)
  1148. else
  1149. hp:=crealconstnode.create(frac(vl),pbestrealtype^);
  1150. end;
  1151. in_const_int :
  1152. begin
  1153. if isreal then
  1154. hp:=crealconstnode.create(int(vr),pbestrealtype^)
  1155. else
  1156. hp:=crealconstnode.create(int(vl),pbestrealtype^);
  1157. end;
  1158. in_const_abs :
  1159. begin
  1160. if isreal then
  1161. hp:=crealconstnode.create(abs(vr),pbestrealtype^)
  1162. else
  1163. hp:=genintconstnode(abs(vl));
  1164. end;
  1165. in_const_sqr :
  1166. begin
  1167. if isreal then
  1168. hp:=crealconstnode.create(sqr(vr),pbestrealtype^)
  1169. else
  1170. hp:=genintconstnode(sqr(vl));
  1171. end;
  1172. in_const_odd :
  1173. begin
  1174. if isreal then
  1175. CGMessage1(type_e_integer_expr_expected,left.resulttype.def.typename)
  1176. else
  1177. hp:=cordconstnode.create(byte(odd(vl)),booltype,true);
  1178. end;
  1179. in_const_swap_word :
  1180. begin
  1181. if isreal then
  1182. CGMessage1(type_e_integer_expr_expected,left.resulttype.def.typename)
  1183. else
  1184. hp:=cordconstnode.create((vl and $ff) shl 8+(vl shr 8),left.resulttype,true);
  1185. end;
  1186. in_const_swap_long :
  1187. begin
  1188. if isreal then
  1189. CGMessage1(type_e_integer_expr_expected,left.resulttype.def.typename)
  1190. else
  1191. hp:=cordconstnode.create((vl and $ffff) shl 16+(vl shr 16),left.resulttype,true);
  1192. end;
  1193. in_const_swap_qword :
  1194. begin
  1195. if isreal then
  1196. CGMessage1(type_e_integer_expr_expected,left.resulttype.def.typename)
  1197. else
  1198. hp:=cordconstnode.create((vl and $ffff) shl 32+(vl shr 32),left.resulttype,true);
  1199. end;
  1200. in_const_ptr :
  1201. begin
  1202. if isreal then
  1203. CGMessage1(type_e_integer_expr_expected,left.resulttype.def.typename)
  1204. else
  1205. hp:=cpointerconstnode.create((vl2 shl 4)+vl,voidfarpointertype);
  1206. end;
  1207. in_const_sqrt :
  1208. begin
  1209. if isreal then
  1210. hp:=handle_sqrt_const(vr)
  1211. else
  1212. hp:=handle_sqrt_const(vl)
  1213. end;
  1214. in_const_arctan :
  1215. begin
  1216. if isreal then
  1217. hp:=crealconstnode.create(arctan(vr),pbestrealtype^)
  1218. else
  1219. hp:=crealconstnode.create(arctan(vl),pbestrealtype^);
  1220. end;
  1221. in_const_cos :
  1222. begin
  1223. if isreal then
  1224. hp:=crealconstnode.create(cos(vr),pbestrealtype^)
  1225. else
  1226. hp:=crealconstnode.create(cos(vl),pbestrealtype^);
  1227. end;
  1228. in_const_sin :
  1229. begin
  1230. if isreal then
  1231. hp:=crealconstnode.create(sin(vr),pbestrealtype^)
  1232. else
  1233. hp:=crealconstnode.create(sin(vl),pbestrealtype^);
  1234. end;
  1235. in_const_exp :
  1236. begin
  1237. if isreal then
  1238. hp:=crealconstnode.create(exp(vr),pbestrealtype^)
  1239. else
  1240. hp:=crealconstnode.create(exp(vl),pbestrealtype^);
  1241. if (trealconstnode(hp).value_real=double(MathInf)) and
  1242. ((cs_check_range in aktlocalswitches) or
  1243. (cs_check_overflow in aktlocalswitches)) then
  1244. begin
  1245. result:=crealconstnode.create(0,pbestrealtype^);
  1246. CGMessage(parser_e_range_check_error);
  1247. end;
  1248. end;
  1249. in_const_ln :
  1250. begin
  1251. if isreal then
  1252. hp:=handle_ln_const(vr)
  1253. else
  1254. hp:=handle_ln_const(vl)
  1255. end;
  1256. else
  1257. internalerror(88);
  1258. end;
  1259. end;
  1260. if hp=nil then
  1261. hp:=tnode.create(errorn);
  1262. result:=hp;
  1263. goto myexit;
  1264. end
  1265. else
  1266. begin
  1267. case inlinenumber of
  1268. in_lo_long,
  1269. in_hi_long,
  1270. in_lo_qword,
  1271. in_hi_qword,
  1272. in_lo_word,
  1273. in_hi_word :
  1274. begin
  1275. { give warning for incompatibility with tp and delphi }
  1276. if (inlinenumber in [in_lo_long,in_hi_long,in_lo_qword,in_hi_qword]) and
  1277. ((m_tp7 in aktmodeswitches) or
  1278. (m_delphi in aktmodeswitches)) then
  1279. CGMessage(type_w_maybe_wrong_hi_lo);
  1280. { constant folding }
  1281. if left.nodetype=ordconstn then
  1282. begin
  1283. case inlinenumber of
  1284. in_lo_word :
  1285. hp:=cordconstnode.create(tordconstnode(left).value and $ff,left.resulttype,true);
  1286. in_hi_word :
  1287. hp:=cordconstnode.create(tordconstnode(left).value shr 8,left.resulttype,true);
  1288. in_lo_long :
  1289. hp:=cordconstnode.create(tordconstnode(left).value and $ffff,left.resulttype,true);
  1290. in_hi_long :
  1291. hp:=cordconstnode.create(tordconstnode(left).value shr 16,left.resulttype,true);
  1292. in_lo_qword :
  1293. hp:=cordconstnode.create(tordconstnode(left).value and $ffffffff,left.resulttype,true);
  1294. in_hi_qword :
  1295. hp:=cordconstnode.create(tordconstnode(left).value shr 32,left.resulttype,true);
  1296. end;
  1297. result:=hp;
  1298. goto myexit;
  1299. end;
  1300. set_varstate(left,vs_used,true);
  1301. if not is_integer(left.resulttype.def) then
  1302. CGMessage1(type_e_integer_expr_expected,left.resulttype.def.typename);
  1303. case inlinenumber of
  1304. in_lo_word,
  1305. in_hi_word :
  1306. resulttype:=u8inttype;
  1307. in_lo_long,
  1308. in_hi_long :
  1309. resulttype:=u16inttype;
  1310. in_lo_qword,
  1311. in_hi_qword :
  1312. resulttype:=u32inttype;
  1313. end;
  1314. end;
  1315. in_sizeof_x:
  1316. begin
  1317. set_varstate(left,vs_used,false);
  1318. if paramanager.push_high_param(vs_value,left.resulttype.def,current_procinfo.procdef.proccalloption) then
  1319. begin
  1320. hightree:=load_high_value_node(tvarsym(tloadnode(left).symtableentry));
  1321. if assigned(hightree) then
  1322. begin
  1323. hp:=caddnode.create(addn,hightree,
  1324. cordconstnode.create(1,sinttype,false));
  1325. if (left.resulttype.def.deftype=arraydef) and
  1326. (tarraydef(left.resulttype.def).elesize<>1) then
  1327. hp:=caddnode.create(muln,hp,cordconstnode.create(tarraydef(
  1328. left.resulttype.def).elesize,sinttype,true));
  1329. result:=hp;
  1330. end;
  1331. end
  1332. else
  1333. resulttype:=sinttype;
  1334. end;
  1335. in_typeof_x:
  1336. begin
  1337. set_varstate(left,vs_used,false);
  1338. resulttype:=voidpointertype;
  1339. end;
  1340. in_ord_x:
  1341. begin
  1342. if (left.nodetype=ordconstn) then
  1343. begin
  1344. hp:=cordconstnode.create(
  1345. tordconstnode(left).value,sinttype,true);
  1346. result:=hp;
  1347. goto myexit;
  1348. end;
  1349. set_varstate(left,vs_used,true);
  1350. case left.resulttype.def.deftype of
  1351. orddef :
  1352. begin
  1353. case torddef(left.resulttype.def).typ of
  1354. bool8bit,
  1355. uchar:
  1356. begin
  1357. { change to byte() }
  1358. hp:=ctypeconvnode.create_explicit(left,u8inttype);
  1359. left:=nil;
  1360. result:=hp;
  1361. end;
  1362. bool16bit,
  1363. uwidechar :
  1364. begin
  1365. { change to word() }
  1366. hp:=ctypeconvnode.create_explicit(left,u16inttype);
  1367. left:=nil;
  1368. result:=hp;
  1369. end;
  1370. bool32bit :
  1371. begin
  1372. { change to dword() }
  1373. hp:=ctypeconvnode.create_explicit(left,u32inttype);
  1374. left:=nil;
  1375. result:=hp;
  1376. end;
  1377. uvoid :
  1378. CGMessage1(type_e_ordinal_expr_expected,left.resulttype.def.typename);
  1379. else
  1380. begin
  1381. { all other orddef need no transformation }
  1382. hp:=left;
  1383. left:=nil;
  1384. result:=hp;
  1385. end;
  1386. end;
  1387. end;
  1388. enumdef :
  1389. begin
  1390. hp:=ctypeconvnode.create_explicit(left,s32inttype);
  1391. left:=nil;
  1392. result:=hp;
  1393. end;
  1394. pointerdef :
  1395. begin
  1396. if m_mac in aktmodeswitches then
  1397. begin
  1398. hp:=ctypeconvnode.create_explicit(left,ptrinttype);
  1399. left:=nil;
  1400. result:=hp;
  1401. end
  1402. else
  1403. CGMessage1(type_e_ordinal_expr_expected,left.resulttype.def.typename);
  1404. end
  1405. else
  1406. CGMessage1(type_e_ordinal_expr_expected,left.resulttype.def.typename);
  1407. end;
  1408. end;
  1409. in_chr_byte:
  1410. begin
  1411. { convert to explicit char() }
  1412. set_varstate(left,vs_used,true);
  1413. hp:=ctypeconvnode.create_explicit(left,cchartype);
  1414. left:=nil;
  1415. result:=hp;
  1416. end;
  1417. in_length_x:
  1418. begin
  1419. set_varstate(left,vs_used,true);
  1420. case left.resulttype.def.deftype of
  1421. stringdef :
  1422. begin
  1423. { we don't need string convertions here }
  1424. if (left.nodetype=typeconvn) and
  1425. (ttypeconvnode(left).left.resulttype.def.deftype=stringdef) then
  1426. begin
  1427. hp:=ttypeconvnode(left).left;
  1428. ttypeconvnode(left).left:=nil;
  1429. left.free;
  1430. left:=hp;
  1431. end;
  1432. { evaluates length of constant strings direct }
  1433. if (left.nodetype=stringconstn) then
  1434. begin
  1435. hp:=cordconstnode.create(
  1436. tstringconstnode(left).len,s32inttype,true);
  1437. result:=hp;
  1438. goto myexit;
  1439. end;
  1440. end;
  1441. orddef :
  1442. begin
  1443. { length of char is one allways }
  1444. if is_char(left.resulttype.def) or
  1445. is_widechar(left.resulttype.def) then
  1446. begin
  1447. hp:=cordconstnode.create(1,s32inttype,false);
  1448. result:=hp;
  1449. goto myexit;
  1450. end
  1451. else
  1452. CGMessage(type_e_mismatch);
  1453. end;
  1454. pointerdef :
  1455. begin
  1456. if is_pchar(left.resulttype.def) then
  1457. begin
  1458. hp := ccallparanode.create(left,nil);
  1459. result := ccallnode.createintern('fpc_pchar_length',hp);
  1460. { make sure the left node doesn't get disposed, since it's }
  1461. { reused in the new node (JM) }
  1462. left:=nil;
  1463. goto myexit;
  1464. end
  1465. else if is_pwidechar(left.resulttype.def) then
  1466. begin
  1467. hp := ccallparanode.create(left,nil);
  1468. result := ccallnode.createintern('fpc_pwidechar_length',hp);
  1469. { make sure the left node doesn't get disposed, since it's }
  1470. { reused in the new node (JM) }
  1471. left:=nil;
  1472. goto myexit;
  1473. end
  1474. else
  1475. CGMessage(type_e_mismatch);
  1476. end;
  1477. arraydef :
  1478. begin
  1479. if is_open_array(left.resulttype.def) or
  1480. is_array_of_const(left.resulttype.def) then
  1481. begin
  1482. hightree:=load_high_value_node(tvarsym(tloadnode(left).symtableentry));
  1483. if assigned(hightree) then
  1484. begin
  1485. hp:=caddnode.create(addn,hightree,
  1486. cordconstnode.create(1,s32inttype,false));
  1487. result:=hp;
  1488. end;
  1489. goto myexit;
  1490. end
  1491. else
  1492. if not is_dynamic_array(left.resulttype.def) then
  1493. begin
  1494. hp:=cordconstnode.create(tarraydef(left.resulttype.def).highrange-
  1495. tarraydef(left.resulttype.def).lowrange+1,
  1496. s32inttype,true);
  1497. result:=hp;
  1498. goto myexit;
  1499. end
  1500. else
  1501. begin
  1502. hp := ccallparanode.create(ctypeconvnode.create_explicit(left,voidpointertype),nil);
  1503. result := ccallnode.createintern('fpc_dynarray_length',hp);
  1504. { make sure the left node doesn't get disposed, since it's }
  1505. { reused in the new node (JM) }
  1506. left:=nil;
  1507. goto myexit;
  1508. end;
  1509. end;
  1510. else
  1511. CGMessage(type_e_mismatch);
  1512. end;
  1513. { shortstring return an 8 bit value as the length
  1514. is the first byte of the string }
  1515. if is_shortstring(left.resulttype.def) then
  1516. resulttype:=u8inttype
  1517. else
  1518. resulttype:=sinttype;
  1519. end;
  1520. in_typeinfo_x:
  1521. begin
  1522. set_varstate(left,vs_used,true);
  1523. resulttype:=voidpointertype;
  1524. end;
  1525. in_assigned_x:
  1526. begin
  1527. { the parser has already made sure the expression is valid }
  1528. { handle constant expressions }
  1529. if is_constnode(tcallparanode(left).left) or
  1530. (tcallparanode(left).left.nodetype = pointerconstn) then
  1531. begin
  1532. { let an add node figure it out }
  1533. result := caddnode.create(unequaln,tcallparanode(left).left,cnilnode.create);
  1534. tcallparanode(left).left := nil;
  1535. { free left, because otherwise some code at 'myexit' tries }
  1536. { to run get_paratype for it, which crashes since left.left }
  1537. { is now nil }
  1538. left.free;
  1539. left := nil;
  1540. goto myexit;
  1541. end;
  1542. { otherwise handle separately, because there could be a procvar, which }
  1543. { is 2*sizeof(pointer), while we must only check the first pointer }
  1544. set_varstate(tcallparanode(left).left,vs_used,true);
  1545. resulttype:=booltype;
  1546. end;
  1547. in_ofs_x :
  1548. internalerror(2000101001);
  1549. in_seg_x :
  1550. begin
  1551. set_varstate(left,vs_used,false);
  1552. hp:=cordconstnode.create(0,s32inttype,false);
  1553. result:=hp;
  1554. goto myexit;
  1555. end;
  1556. in_pred_x,
  1557. in_succ_x:
  1558. begin
  1559. set_varstate(left,vs_used,true);
  1560. resulttype:=left.resulttype;
  1561. if not is_ordinal(resulttype.def) then
  1562. CGMessage(type_e_ordinal_expr_expected)
  1563. else
  1564. begin
  1565. if (resulttype.def.deftype=enumdef) and
  1566. (tenumdef(resulttype.def).has_jumps) then
  1567. CGMessage(type_e_succ_and_pred_enums_with_assign_not_possible);
  1568. end;
  1569. { only if the result is an enum do we do range checking }
  1570. if (resulttype.def.deftype=enumdef) then
  1571. checkrange := true
  1572. else
  1573. checkrange := false;
  1574. { do constant folding after check for jumps }
  1575. if left.nodetype=ordconstn then
  1576. begin
  1577. if inlinenumber=in_succ_x then
  1578. hp:=cordconstnode.create(tordconstnode(left).value+1,left.resulttype,checkrange)
  1579. else
  1580. hp:=cordconstnode.create(tordconstnode(left).value-1,left.resulttype,checkrange);
  1581. result:=hp;
  1582. end;
  1583. end;
  1584. in_initialize_x,
  1585. in_finalize_x,
  1586. in_setlength_x:
  1587. begin
  1588. { inlined from pinline }
  1589. internalerror(200204231);
  1590. end;
  1591. in_inc_x,
  1592. in_dec_x:
  1593. begin
  1594. resulttype:=voidtype;
  1595. if assigned(left) then
  1596. begin
  1597. { first param must be var }
  1598. valid_for_var(tcallparanode(left).left);
  1599. set_varstate(tcallparanode(left).left,vs_used,true);
  1600. if (left.resulttype.def.deftype in [enumdef,pointerdef]) or
  1601. is_ordinal(left.resulttype.def) or
  1602. is_currency(left.resulttype.def) then
  1603. begin
  1604. { value of left gets changed -> must be unique }
  1605. set_unique(tcallparanode(left).left);
  1606. { two paras ? }
  1607. if assigned(tcallparanode(left).right) then
  1608. begin
  1609. set_varstate(tcallparanode(tcallparanode(left).right).left,vs_used,true);
  1610. inserttypeconv_explicit(tcallparanode(tcallparanode(left).right).left,tcallparanode(left).left.resulttype);
  1611. if assigned(tcallparanode(tcallparanode(left).right).right) then
  1612. CGMessage(parser_e_illegal_expression);
  1613. end;
  1614. end
  1615. else
  1616. CGMessage(type_e_ordinal_expr_expected);
  1617. end
  1618. else
  1619. CGMessage(type_e_mismatch);
  1620. end;
  1621. in_read_x,
  1622. in_readln_x,
  1623. in_write_x,
  1624. in_writeln_x :
  1625. begin
  1626. result := handle_read_write;
  1627. end;
  1628. in_settextbuf_file_x :
  1629. begin
  1630. resulttype:=voidtype;
  1631. { now we know the type of buffer }
  1632. srsym:=searchsymonlyin(systemunit,'SETTEXTBUF');
  1633. hp:=ccallparanode.create(cordconstnode.create(
  1634. tcallparanode(left).left.resulttype.def.size,s32inttype,true),left);
  1635. hp:=ccallnode.create(hp,tprocsym(srsym),systemunit,nil,[]);
  1636. left:=nil;
  1637. result:=hp;
  1638. end;
  1639. { the firstpass of the arg has been done in firstcalln ? }
  1640. in_reset_typedfile,
  1641. in_rewrite_typedfile :
  1642. begin
  1643. result := handle_reset_rewrite_typed;
  1644. end;
  1645. in_str_x_string :
  1646. begin
  1647. result := handle_str;
  1648. end;
  1649. in_val_x :
  1650. begin
  1651. result := handle_val;
  1652. end;
  1653. in_include_x_y,
  1654. in_exclude_x_y:
  1655. begin
  1656. resulttype:=voidtype;
  1657. { the parser already checks whether we have two (and exectly two) }
  1658. { parameters (JM) }
  1659. { first param must be var }
  1660. valid_for_var(tcallparanode(left).left);
  1661. set_varstate(tcallparanode(left).left,vs_used,true);
  1662. { check type }
  1663. if (left.resulttype.def.deftype=setdef) then
  1664. begin
  1665. { insert a type conversion }
  1666. { to the type of the set elements }
  1667. set_varstate(tcallparanode(tcallparanode(left).right).left,vs_used,true);
  1668. inserttypeconv(tcallparanode(tcallparanode(left).right).left,
  1669. tsetdef(left.resulttype.def).elementtype);
  1670. end
  1671. else
  1672. CGMessage(type_e_mismatch);
  1673. end;
  1674. in_low_x,
  1675. in_high_x:
  1676. begin
  1677. set_varstate(left,vs_used,false);
  1678. case left.resulttype.def.deftype of
  1679. orddef,
  1680. enumdef:
  1681. begin
  1682. result:=do_lowhigh(left.resulttype);
  1683. end;
  1684. setdef:
  1685. begin
  1686. result:=do_lowhigh(tsetdef(left.resulttype.def).elementtype);
  1687. end;
  1688. arraydef:
  1689. begin
  1690. if inlinenumber=in_low_x then
  1691. begin
  1692. result:=cordconstnode.create(tarraydef(
  1693. left.resulttype.def).lowrange,tarraydef(left.resulttype.def).rangetype,true);
  1694. end
  1695. else
  1696. begin
  1697. if is_open_array(left.resulttype.def) or
  1698. is_array_of_const(left.resulttype.def) then
  1699. begin
  1700. result:=load_high_value_node(tvarsym(tloadnode(left).symtableentry));
  1701. end
  1702. else
  1703. if is_dynamic_array(left.resulttype.def) then
  1704. begin
  1705. { can't use inserttypeconv because we need }
  1706. { an explicit type conversion (JM) }
  1707. hp := ccallparanode.create(ctypeconvnode.create_explicit(left,voidpointertype),nil);
  1708. result := ccallnode.createintern('fpc_dynarray_high',hp);
  1709. { make sure the left node doesn't get disposed, since it's }
  1710. { reused in the new node (JM) }
  1711. left:=nil;
  1712. end
  1713. else
  1714. begin
  1715. result:=cordconstnode.create(tarraydef(
  1716. left.resulttype.def).highrange,tarraydef(left.resulttype.def).rangetype,true);
  1717. end;
  1718. end;
  1719. end;
  1720. stringdef:
  1721. begin
  1722. if inlinenumber=in_low_x then
  1723. begin
  1724. result:=cordconstnode.create(0,u8inttype,false);
  1725. end
  1726. else
  1727. begin
  1728. if is_open_string(left.resulttype.def) then
  1729. result:=load_high_value_node(tvarsym(tloadnode(left).symtableentry))
  1730. else
  1731. result:=cordconstnode.create(tstringdef(left.resulttype.def).len,u8inttype,true);
  1732. end;
  1733. end;
  1734. else
  1735. CGMessage(type_e_mismatch);
  1736. end;
  1737. end;
  1738. in_pi:
  1739. begin
  1740. if block_type=bt_const then
  1741. setconstrealvalue(pi)
  1742. else
  1743. resulttype:=pbestrealtype^;
  1744. end;
  1745. in_cos_extended :
  1746. begin
  1747. if left.nodetype in [ordconstn,realconstn] then
  1748. setconstrealvalue(cos(getconstrealvalue))
  1749. else
  1750. begin
  1751. set_varstate(left,vs_used,true);
  1752. inserttypeconv(left,pbestrealtype^);
  1753. resulttype:=pbestrealtype^;
  1754. end;
  1755. end;
  1756. in_sin_extended :
  1757. begin
  1758. if left.nodetype in [ordconstn,realconstn] then
  1759. setconstrealvalue(sin(getconstrealvalue))
  1760. else
  1761. begin
  1762. set_varstate(left,vs_used,true);
  1763. inserttypeconv(left,pbestrealtype^);
  1764. resulttype:=pbestrealtype^;
  1765. end;
  1766. end;
  1767. in_arctan_extended :
  1768. begin
  1769. if left.nodetype in [ordconstn,realconstn] then
  1770. setconstrealvalue(arctan(getconstrealvalue))
  1771. else
  1772. begin
  1773. set_varstate(left,vs_used,true);
  1774. inserttypeconv(left,pbestrealtype^);
  1775. resulttype:=pbestrealtype^;
  1776. end;
  1777. end;
  1778. in_abs_extended :
  1779. begin
  1780. if left.nodetype in [ordconstn,realconstn] then
  1781. setconstrealvalue(abs(getconstrealvalue))
  1782. else
  1783. begin
  1784. set_varstate(left,vs_used,true);
  1785. inserttypeconv(left,pbestrealtype^);
  1786. resulttype:=pbestrealtype^;
  1787. end;
  1788. end;
  1789. in_sqr_extended :
  1790. begin
  1791. if left.nodetype in [ordconstn,realconstn] then
  1792. setconstrealvalue(sqr(getconstrealvalue))
  1793. else
  1794. begin
  1795. set_varstate(left,vs_used,true);
  1796. inserttypeconv(left,pbestrealtype^);
  1797. resulttype:=pbestrealtype^;
  1798. end;
  1799. end;
  1800. in_sqrt_extended :
  1801. begin
  1802. if left.nodetype in [ordconstn,realconstn] then
  1803. begin
  1804. vr:=getconstrealvalue;
  1805. if vr<0.0 then
  1806. result:=handle_sqrt_const(vr)
  1807. else
  1808. setconstrealvalue(sqrt(vr));
  1809. end
  1810. else
  1811. begin
  1812. set_varstate(left,vs_used,true);
  1813. inserttypeconv(left,pbestrealtype^);
  1814. resulttype:=pbestrealtype^;
  1815. end;
  1816. end;
  1817. in_ln_extended :
  1818. begin
  1819. if left.nodetype in [ordconstn,realconstn] then
  1820. begin
  1821. vr:=getconstrealvalue;
  1822. if vr<=0.0 then
  1823. result:=handle_ln_const(vr)
  1824. else
  1825. setconstrealvalue(ln(vr));
  1826. end
  1827. else
  1828. begin
  1829. set_varstate(left,vs_used,true);
  1830. inserttypeconv(left,pbestrealtype^);
  1831. resulttype:=pbestrealtype^;
  1832. end;
  1833. end;
  1834. {$ifdef SUPPORT_MMX}
  1835. in_mmx_pcmpeqb..in_mmx_pcmpgtw:
  1836. begin
  1837. end;
  1838. {$endif SUPPORT_MMX}
  1839. in_prefetch_var:
  1840. begin
  1841. resulttype:=voidtype;
  1842. end;
  1843. in_assert_x_y :
  1844. begin
  1845. resulttype:=voidtype;
  1846. if assigned(left) then
  1847. begin
  1848. set_varstate(tcallparanode(left).left,vs_used,true);
  1849. { check type }
  1850. if is_boolean(left.resulttype.def) then
  1851. begin
  1852. set_varstate(tcallparanode(tcallparanode(left).right).left,vs_used,true);
  1853. { must always be a string }
  1854. inserttypeconv(tcallparanode(tcallparanode(left).right).left,cshortstringtype);
  1855. end
  1856. else
  1857. CGMessage1(type_e_boolean_expr_expected,left.resulttype.def.typename);
  1858. end
  1859. else
  1860. CGMessage(type_e_mismatch);
  1861. { We've checked the whole statement for correctness, now we
  1862. can remove it if assertions are off }
  1863. if not(cs_do_assertion in aktlocalswitches) then
  1864. begin
  1865. { we need a valid node, so insert a nothingn }
  1866. result:=cnothingnode.create;
  1867. end
  1868. else
  1869. include(current_procinfo.flags,pi_do_call);
  1870. end;
  1871. else
  1872. internalerror(8);
  1873. end;
  1874. end;
  1875. myexit:
  1876. { Run get_paratype again to update maybe inserted typeconvs }
  1877. if not codegenerror then
  1878. begin
  1879. if assigned(left) and
  1880. (left.nodetype=callparan) then
  1881. tcallparanode(left).get_paratype;
  1882. end;
  1883. dec(parsing_para_level);
  1884. end;
  1885. function tinlinenode.pass_1 : tnode;
  1886. var
  1887. hp,hpp : tnode;
  1888. shiftconst: longint;
  1889. tempnode: ttempcreatenode;
  1890. newstatement: tstatementnode;
  1891. newblock: tblocknode;
  1892. begin
  1893. result:=nil;
  1894. { if we handle writeln; left contains no valid address }
  1895. if assigned(left) then
  1896. begin
  1897. if left.nodetype=callparan then
  1898. tcallparanode(left).firstcallparan
  1899. else
  1900. firstpass(left);
  1901. left_max;
  1902. end;
  1903. inc(parsing_para_level);
  1904. { intern const should already be handled }
  1905. if nf_inlineconst in flags then
  1906. internalerror(200104044);
  1907. case inlinenumber of
  1908. in_lo_qword,
  1909. in_hi_qword,
  1910. in_lo_long,
  1911. in_hi_long,
  1912. in_lo_word,
  1913. in_hi_word:
  1914. begin
  1915. shiftconst := 0;
  1916. case inlinenumber of
  1917. in_hi_qword:
  1918. shiftconst := 32;
  1919. in_hi_long:
  1920. shiftconst := 16;
  1921. in_hi_word:
  1922. shiftconst := 8;
  1923. end;
  1924. if shiftconst <> 0 then
  1925. result := ctypeconvnode.create_explicit(cshlshrnode.create(shrn,left,
  1926. cordconstnode.create(shiftconst,u32inttype,false)),resulttype)
  1927. else
  1928. result := ctypeconvnode.create_explicit(left,resulttype);
  1929. left := nil;
  1930. firstpass(result);
  1931. end;
  1932. in_sizeof_x:
  1933. begin
  1934. if registersint<1 then
  1935. registersint:=1;
  1936. expectloc:=LOC_REGISTER;
  1937. end;
  1938. in_typeof_x:
  1939. begin
  1940. if registersint<1 then
  1941. registersint:=1;
  1942. expectloc:=LOC_REGISTER;
  1943. end;
  1944. in_length_x:
  1945. begin
  1946. if is_shortstring(left.resulttype.def) then
  1947. expectloc:=left.expectloc
  1948. else
  1949. begin
  1950. { ansi/wide string }
  1951. if registersint<1 then
  1952. registersint:=1;
  1953. expectloc:=LOC_REGISTER;
  1954. end;
  1955. end;
  1956. in_typeinfo_x:
  1957. begin
  1958. expectloc:=LOC_REGISTER;
  1959. registersint:=1;
  1960. end;
  1961. in_assigned_x:
  1962. begin
  1963. expectloc := LOC_JUMP;
  1964. registersint:=1;
  1965. end;
  1966. in_pred_x,
  1967. in_succ_x:
  1968. begin
  1969. if is_64bit(resulttype.def) then
  1970. begin
  1971. if (registersint<2) then
  1972. registersint:=2
  1973. end
  1974. else
  1975. begin
  1976. if (registersint<1) then
  1977. registersint:=1;
  1978. end;
  1979. expectloc:=LOC_REGISTER;
  1980. end;
  1981. in_setlength_x,
  1982. in_initialize_x,
  1983. in_finalize_x:
  1984. begin
  1985. expectloc:=LOC_VOID;
  1986. end;
  1987. in_inc_x,
  1988. in_dec_x:
  1989. begin
  1990. expectloc:=LOC_VOID;
  1991. { check type }
  1992. if
  1993. {$ifndef cpu64bit}
  1994. is_64bit(left.resulttype.def) or
  1995. {$endif cpu64bit}
  1996. { range/overflow checking doesn't work properly }
  1997. { with the inc/dec code that's generated (JM) }
  1998. (
  1999. (left.resulttype.def.deftype = orddef) and
  2000. not(is_char(left.resulttype.def)) and
  2001. not(is_boolean(left.resulttype.def)) and
  2002. (aktlocalswitches * [cs_check_overflow,cs_check_range] <> [])
  2003. ) then
  2004. { convert to simple add (JM) }
  2005. begin
  2006. newblock := internalstatements(newstatement);
  2007. { extra parameter? }
  2008. if assigned(tcallparanode(left).right) then
  2009. begin
  2010. { Yes, use for add node }
  2011. hpp := tcallparanode(tcallparanode(left).right).left;
  2012. tcallparanode(tcallparanode(left).right).left := nil;
  2013. if assigned(tcallparanode(tcallparanode(left).right).right) then
  2014. CGMessage(parser_e_illegal_expression);
  2015. end
  2016. else
  2017. { no, create constant 1 }
  2018. hpp := cordconstnode.create(1,tcallparanode(left).left.resulttype,false);
  2019. { make sure we don't call functions part of the left node twice (and generally }
  2020. { optimize the code generation) }
  2021. if node_complexity(tcallparanode(left).left) > 1 then
  2022. begin
  2023. tempnode := ctempcreatenode.create_reg(voidpointertype,voidpointertype.def.size,tt_persistent);
  2024. addstatement(newstatement,tempnode);
  2025. addstatement(newstatement,cassignmentnode.create(ctemprefnode.create(tempnode),
  2026. caddrnode.create(tcallparanode(left).left.getcopy)));
  2027. hp := cderefnode.create(ctemprefnode.create(tempnode));
  2028. inserttypeconv_explicit(hp,tcallparanode(left).left.resulttype);
  2029. end
  2030. else
  2031. begin
  2032. hp := tcallparanode(left).left.getcopy;
  2033. tempnode := nil;
  2034. end;
  2035. { addition/substraction depending on inc/dec }
  2036. if inlinenumber = in_inc_x then
  2037. hpp := caddnode.create(addn,hp,hpp)
  2038. else
  2039. hpp := caddnode.create(subn,hp,hpp);
  2040. { assign result of addition }
  2041. addstatement(newstatement,cassignmentnode.create(hp.getcopy,hpp));
  2042. { deallocate the temp }
  2043. if assigned(tempnode) then
  2044. addstatement(newstatement,ctempdeletenode.create(tempnode));
  2045. { firstpass it }
  2046. firstpass(newblock);
  2047. { return new node }
  2048. result := newblock;
  2049. end
  2050. else if (left.resulttype.def.deftype in [enumdef,pointerdef]) or
  2051. is_ordinal(left.resulttype.def) then
  2052. begin
  2053. { two paras ? }
  2054. if assigned(tcallparanode(left).right) then
  2055. begin
  2056. { need we an additional register ? }
  2057. if not(is_constintnode(tcallparanode(tcallparanode(left).right).left)) and
  2058. (tcallparanode(tcallparanode(left).right).left.expectloc in [LOC_CREFERENCE,LOC_REFERENCE]) and
  2059. (tcallparanode(tcallparanode(left).right).left.registersint<=1) then
  2060. inc(registersint);
  2061. { do we need an additional register to restore the first parameter? }
  2062. if tcallparanode(tcallparanode(left).right).left.registersint>=registersint then
  2063. inc(registersint);
  2064. end;
  2065. end;
  2066. end;
  2067. in_include_x_y,
  2068. in_exclude_x_y:
  2069. begin
  2070. expectloc:=LOC_VOID;
  2071. registersint:=left.registersint;
  2072. registersfpu:=left.registersfpu;
  2073. {$ifdef SUPPORT_MMX}
  2074. registersmmx:=left.registersmmx;
  2075. {$endif SUPPORT_MMX}
  2076. end;
  2077. in_cos_extended:
  2078. begin
  2079. result:= first_cos_real;
  2080. end;
  2081. in_sin_extended:
  2082. begin
  2083. result := first_sin_real;
  2084. end;
  2085. in_arctan_extended:
  2086. begin
  2087. result := first_arctan_real;
  2088. end;
  2089. in_pi:
  2090. begin
  2091. result := first_pi;
  2092. end;
  2093. in_abs_extended:
  2094. begin
  2095. result := first_abs_real;
  2096. end;
  2097. in_sqr_extended:
  2098. begin
  2099. result := first_sqr_real;
  2100. end;
  2101. in_sqrt_extended:
  2102. begin
  2103. result := first_sqrt_real;
  2104. end;
  2105. in_ln_extended:
  2106. begin
  2107. result := first_ln_real;
  2108. end;
  2109. {$ifdef SUPPORT_MMX}
  2110. in_mmx_pcmpeqb..in_mmx_pcmpgtw:
  2111. begin
  2112. end;
  2113. {$endif SUPPORT_MMX}
  2114. in_assert_x_y :
  2115. begin
  2116. expectloc:=LOC_VOID;
  2117. registersint:=left.registersint;
  2118. registersfpu:=left.registersfpu;
  2119. {$ifdef SUPPORT_MMX}
  2120. registersmmx:=left.registersmmx;
  2121. {$endif SUPPORT_MMX}
  2122. end;
  2123. in_low_x,
  2124. in_high_x:
  2125. internalerror(200104047);
  2126. in_ord_x,
  2127. in_chr_byte:
  2128. begin
  2129. { should not happend as it's converted to typeconv }
  2130. internalerror(200104045);
  2131. end;
  2132. in_ofs_x :
  2133. internalerror(2000101001);
  2134. in_seg_x :
  2135. internalerror(200104046);
  2136. in_settextbuf_file_x,
  2137. in_reset_typedfile,
  2138. in_rewrite_typedfile,
  2139. in_str_x_string,
  2140. in_val_x,
  2141. in_read_x,
  2142. in_readln_x,
  2143. in_write_x,
  2144. in_writeln_x :
  2145. begin
  2146. { should be handled by det_resulttype }
  2147. internalerror(200108234);
  2148. end;
  2149. in_prefetch_var:
  2150. begin
  2151. expectloc:=LOC_VOID;
  2152. end;
  2153. else
  2154. internalerror(8);
  2155. end;
  2156. dec(parsing_para_level);
  2157. end;
  2158. {$ifdef fpc}
  2159. {$maxfpuregisters default}
  2160. {$endif fpc}
  2161. function tinlinenode.docompare(p: tnode): boolean;
  2162. begin
  2163. docompare :=
  2164. inherited docompare(p) and
  2165. (inlinenumber = tinlinenode(p).inlinenumber);
  2166. end;
  2167. function tinlinenode.first_pi : tnode;
  2168. begin
  2169. result := crealconstnode.create(pi,pbestrealtype^);
  2170. end;
  2171. function tinlinenode.first_arctan_real : tnode;
  2172. begin
  2173. { create the call to the helper }
  2174. { on entry left node contains the parameter }
  2175. first_arctan_real := ccallnode.createintern('fpc_arctan_real',
  2176. ccallparanode.create(left,nil));
  2177. left := nil;
  2178. end;
  2179. function tinlinenode.first_abs_real : tnode;
  2180. begin
  2181. { create the call to the helper }
  2182. { on entry left node contains the parameter }
  2183. first_abs_real := ccallnode.createintern('fpc_abs_real',
  2184. ccallparanode.create(left,nil));
  2185. left := nil;
  2186. end;
  2187. function tinlinenode.first_sqr_real : tnode;
  2188. begin
  2189. { create the call to the helper }
  2190. { on entry left node contains the parameter }
  2191. first_sqr_real := ccallnode.createintern('fpc_sqr_real',
  2192. ccallparanode.create(left,nil));
  2193. left := nil;
  2194. end;
  2195. function tinlinenode.first_sqrt_real : tnode;
  2196. begin
  2197. { create the call to the helper }
  2198. { on entry left node contains the parameter }
  2199. first_sqrt_real := ccallnode.createintern('fpc_sqrt_real',
  2200. ccallparanode.create(left,nil));
  2201. left := nil;
  2202. end;
  2203. function tinlinenode.first_ln_real : tnode;
  2204. begin
  2205. { create the call to the helper }
  2206. { on entry left node contains the parameter }
  2207. first_ln_real := ccallnode.createintern('fpc_ln_real',
  2208. ccallparanode.create(left,nil));
  2209. left := nil;
  2210. end;
  2211. function tinlinenode.first_cos_real : tnode;
  2212. begin
  2213. { create the call to the helper }
  2214. { on entry left node contains the parameter }
  2215. first_cos_real := ccallnode.createintern('fpc_cos_real',
  2216. ccallparanode.create(left,nil));
  2217. left := nil;
  2218. end;
  2219. function tinlinenode.first_sin_real : tnode;
  2220. begin
  2221. { create the call to the helper }
  2222. { on entry left node contains the parameter }
  2223. first_sin_real := ccallnode.createintern('fpc_sin_real',
  2224. ccallparanode.create(left,nil));
  2225. left := nil;
  2226. end;
  2227. begin
  2228. cinlinenode:=tinlinenode;
  2229. end.
  2230. {
  2231. $Log$
  2232. Revision 1.145 2004-09-16 16:32:27 peter
  2233. * another fix for reading of subranges
  2234. Revision 1.144 2004/09/13 20:32:06 peter
  2235. * fix for read(subranges) with subrange typ already being sinttype
  2236. Revision 1.143 2004/08/25 15:56:35 peter
  2237. * fix sqr() and abs() constant range check errors
  2238. Revision 1.142 2004/08/08 16:00:56 florian
  2239. * constant floating point assignments etc. are now overflow checked
  2240. if Q+ or R+ is turned on
  2241. Revision 1.141 2004/07/15 19:55:39 jonas
  2242. + (incomplete) node_complexity function to assess the complexity of a
  2243. tree
  2244. + support for inlining value and const parameters at the node level
  2245. (all procedures without local variables and without formal parameters
  2246. can now be inlined at the node level)
  2247. Revision 1.140 2004/07/14 21:40:52 olle
  2248. + added Ord(pointer) for macpas
  2249. Revision 1.139 2004/07/14 14:38:35 jonas
  2250. * fix for web bug 3210
  2251. Revision 1.138 2004/06/20 08:55:29 florian
  2252. * logs truncated
  2253. Revision 1.137 2004/06/18 15:16:46 peter
  2254. * remove obsolete cardinal() typecasts
  2255. Revision 1.136 2004/06/16 20:07:08 florian
  2256. * dwarf branch merged
  2257. Revision 1.135 2004/05/28 21:15:20 peter
  2258. * inc(x,y) makes y always of type x to prevent 64bit operations
  2259. when x is a u32bit and y is signed
  2260. Revision 1.134 2004/05/23 18:28:41 peter
  2261. * methodpointer is loaded into a temp when it was a calln
  2262. Revision 1.133.2.9 2004/05/03 16:49:00 peter
  2263. * sizeof fixed
  2264. }