ninl.pas 96 KB

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