ninl.pas 76 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957
  1. {
  2. $Id$
  3. Copyright (c) 1998-2000 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 defines.inc}
  20. interface
  21. uses
  22. node,htypechk,cpuinfo;
  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. function getcopy : tnode;override;
  29. function pass_1 : tnode;override;
  30. function det_resulttype:tnode;override;
  31. function docompare(p: tnode): boolean; override;
  32. end;
  33. var
  34. cinlinenode : class of tinlinenode;
  35. function geninlinenode(number : byte;is_const:boolean;l : tnode) : tinlinenode;
  36. implementation
  37. uses
  38. verbose,globals,systems,
  39. globtype,
  40. symconst,symtype,symdef,symsym,symtable,types,
  41. pass_1,
  42. ncal,ncon,ncnv,nadd,nld,nbas,
  43. cpubase,hcodegen,tgcpu
  44. {$ifdef newcg}
  45. ,cgbase
  46. {$endif newcg}
  47. ;
  48. function geninlinenode(number : byte;is_const:boolean;l : tnode) : tinlinenode;
  49. begin
  50. geninlinenode:=cinlinenode.create(number,is_const,l);
  51. end;
  52. {*****************************************************************************
  53. TINLINENODE
  54. *****************************************************************************}
  55. constructor tinlinenode.create(number : byte;is_const:boolean;l : tnode);
  56. begin
  57. inherited create(inlinen,l);
  58. if is_const then
  59. include(flags,nf_inlineconst);
  60. inlinenumber:=number;
  61. end;
  62. function tinlinenode.getcopy : tnode;
  63. var
  64. n : tinlinenode;
  65. begin
  66. n:=tinlinenode(inherited getcopy);
  67. n.inlinenumber:=inlinenumber;
  68. result:=n;
  69. end;
  70. function tinlinenode.det_resulttype:tnode;
  71. function do_lowhigh(const t:ttype) : tnode;
  72. var
  73. v : tconstexprint;
  74. enum : tenumsym;
  75. hp : tnode;
  76. begin
  77. case t.def.deftype of
  78. orddef:
  79. begin
  80. if inlinenumber=in_low_x then
  81. v:=torddef(t.def).low
  82. else
  83. v:=torddef(t.def).high;
  84. { low/high of torddef are longints, so we need special }
  85. { handling for cardinal and 64bit types (JM) }
  86. { 1.0.x doesn't support int64($ffffffff) correct, it'll expand
  87. to -1 instead of staying $ffffffff. Therefor we use $ffff with
  88. shl twice (PFV) }
  89. if is_signed(t.def) and
  90. is_64bitint(t.def) then
  91. if (inlinenumber=in_low_x) then
  92. v := int64($80000000) shl 32
  93. else
  94. v := (int64($7fffffff) shl 32) or int64($ffff) shl 16 or int64($ffff)
  95. else
  96. if is_64bitint(t.def) then
  97. { we have to use a dirty trick for high(qword), }
  98. { because it's bigger than high(tconstexprint) (JM) }
  99. v := 0
  100. else
  101. if not is_signed(t.def) then
  102. v := cardinal(v);
  103. hp:=cordconstnode.create(v,t);
  104. resulttypepass(hp);
  105. { fix high(qword) }
  106. if not is_signed(t.def) and
  107. is_64bitint(t.def) and
  108. (inlinenumber = in_high_x) then
  109. tordconstnode(hp).value := -1; { is the same as qword($ffffffffffffffff) }
  110. do_lowhigh:=hp;
  111. end;
  112. enumdef:
  113. begin
  114. enum:=tenumsym(tenumdef(t.def).firstenum);
  115. v:=tenumdef(t.def).maxval;
  116. if inlinenumber=in_high_x then
  117. while assigned(enum) and (enum.value <> v) do
  118. enum:=enum.nextenum;
  119. if not assigned(enum) then
  120. internalerror(309993)
  121. else
  122. hp:=genenumnode(enum);
  123. do_lowhigh:=hp;
  124. end;
  125. else
  126. internalerror(87);
  127. end;
  128. end;
  129. function getconstrealvalue : bestreal;
  130. begin
  131. case left.nodetype of
  132. ordconstn:
  133. getconstrealvalue:=tordconstnode(left).value;
  134. realconstn:
  135. getconstrealvalue:=trealconstnode(left).value_real;
  136. else
  137. internalerror(309992);
  138. end;
  139. end;
  140. procedure setconstrealvalue(r : bestreal);
  141. var
  142. hp : tnode;
  143. begin
  144. hp:=crealconstnode.create(r,pbestrealtype^);
  145. resulttypepass(hp);
  146. result:=hp;
  147. end;
  148. var
  149. counter : longint;
  150. ppn : tcallparanode;
  151. dummycoll : tparaitem;
  152. vl,vl2 : longint;
  153. vr : bestreal;
  154. hp : tnode;
  155. srsym : tsym;
  156. p1,hpp : tnode;
  157. frac_para,
  158. length_para : tnode;
  159. isreal,
  160. iswrite,
  161. file_is_typed : boolean;
  162. label
  163. myexit;
  164. begin
  165. result:=nil;
  166. { if we handle writeln; left contains no valid address }
  167. if assigned(left) then
  168. begin
  169. if left.nodetype=callparan then
  170. tcallparanode(left).get_paratype
  171. else
  172. resulttypepass(left);
  173. end;
  174. inc(parsing_para_level);
  175. { handle intern constant functions in separate case }
  176. if nf_inlineconst in flags then
  177. begin
  178. { no parameters? }
  179. if not assigned(left) then
  180. begin
  181. case inlinenumber of
  182. in_const_pi :
  183. hp:=crealconstnode.create(pi,pbestrealtype^);
  184. else
  185. internalerror(89);
  186. end;
  187. end
  188. else
  189. begin
  190. vl:=0;
  191. vl2:=0; { second parameter Ex: ptr(vl,vl2) }
  192. vr:=0;
  193. isreal:=false;
  194. case left.nodetype of
  195. realconstn :
  196. begin
  197. isreal:=true;
  198. vr:=trealconstnode(left).value_real;
  199. end;
  200. ordconstn :
  201. vl:=tordconstnode(left).value;
  202. callparan :
  203. begin
  204. { both exists, else it was not generated }
  205. vl:=tordconstnode(tcallparanode(left).left).value;
  206. vl2:=tordconstnode(tcallparanode(tcallparanode(left).right).left).value;
  207. end;
  208. else
  209. CGMessage(cg_e_illegal_expression);
  210. end;
  211. case inlinenumber of
  212. in_const_trunc :
  213. begin
  214. if isreal then
  215. begin
  216. if (vr>=2147483648.0) or (vr<=-2147483649.0) then
  217. begin
  218. CGMessage(parser_e_range_check_error);
  219. hp:=cordconstnode.create(1,s32bittype)
  220. end
  221. else
  222. hp:=cordconstnode.create(trunc(vr),s32bittype)
  223. end
  224. else
  225. hp:=cordconstnode.create(trunc(vl),s32bittype);
  226. end;
  227. in_const_round :
  228. begin
  229. if isreal then
  230. begin
  231. if (vr>=2147483647.5) or (vr<=-2147483648.5) then
  232. begin
  233. CGMessage(parser_e_range_check_error);
  234. hp:=cordconstnode.create(1,s32bittype)
  235. end
  236. else
  237. hp:=cordconstnode.create(round(vr),s32bittype)
  238. end
  239. else
  240. hp:=cordconstnode.create(round(vl),s32bittype);
  241. end;
  242. in_const_frac :
  243. begin
  244. if isreal then
  245. hp:=crealconstnode.create(frac(vr),pbestrealtype^)
  246. else
  247. hp:=crealconstnode.create(frac(vl),pbestrealtype^);
  248. end;
  249. in_const_int :
  250. begin
  251. if isreal then
  252. hp:=crealconstnode.create(int(vr),pbestrealtype^)
  253. else
  254. hp:=crealconstnode.create(int(vl),pbestrealtype^);
  255. end;
  256. in_const_abs :
  257. begin
  258. if isreal then
  259. hp:=crealconstnode.create(abs(vr),pbestrealtype^)
  260. else
  261. hp:=cordconstnode.create(abs(vl),left.resulttype);
  262. end;
  263. in_const_sqr :
  264. begin
  265. if isreal then
  266. hp:=crealconstnode.create(sqr(vr),pbestrealtype^)
  267. else
  268. hp:=cordconstnode.create(sqr(vl),left.resulttype);
  269. end;
  270. in_const_odd :
  271. begin
  272. if isreal then
  273. CGMessage1(type_e_integer_expr_expected,left.resulttype.def.typename)
  274. else
  275. hp:=cordconstnode.create(byte(odd(vl)),booltype);
  276. end;
  277. in_const_swap_word :
  278. begin
  279. if isreal then
  280. CGMessage1(type_e_integer_expr_expected,left.resulttype.def.typename)
  281. else
  282. hp:=cordconstnode.create((vl and $ff) shl 8+(vl shr 8),left.resulttype);
  283. end;
  284. in_const_swap_long :
  285. begin
  286. if isreal then
  287. CGMessage(type_e_mismatch)
  288. else
  289. hp:=cordconstnode.create((vl and $ffff) shl 16+(vl shr 16),left.resulttype);
  290. end;
  291. in_const_ptr :
  292. begin
  293. if isreal then
  294. CGMessage(type_e_mismatch)
  295. else
  296. hp:=cpointerconstnode.create((vl2 shl 4)+vl,voidfarpointertype);
  297. end;
  298. in_const_sqrt :
  299. begin
  300. if isreal then
  301. begin
  302. if vr<0.0 then
  303. CGMessage(type_e_wrong_math_argument)
  304. else
  305. hp:=crealconstnode.create(sqrt(vr),pbestrealtype^)
  306. end
  307. else
  308. begin
  309. if vl<0 then
  310. CGMessage(type_e_wrong_math_argument)
  311. else
  312. hp:=crealconstnode.create(sqrt(vl),pbestrealtype^);
  313. end;
  314. end;
  315. in_const_arctan :
  316. begin
  317. if isreal then
  318. hp:=crealconstnode.create(arctan(vr),pbestrealtype^)
  319. else
  320. hp:=crealconstnode.create(arctan(vl),pbestrealtype^);
  321. end;
  322. in_const_cos :
  323. begin
  324. if isreal then
  325. hp:=crealconstnode.create(cos(vr),pbestrealtype^)
  326. else
  327. hp:=crealconstnode.create(cos(vl),pbestrealtype^);
  328. end;
  329. in_const_sin :
  330. begin
  331. if isreal then
  332. hp:=crealconstnode.create(sin(vr),pbestrealtype^)
  333. else
  334. hp:=crealconstnode.create(sin(vl),pbestrealtype^);
  335. end;
  336. in_const_exp :
  337. begin
  338. if isreal then
  339. hp:=crealconstnode.create(exp(vr),pbestrealtype^)
  340. else
  341. hp:=crealconstnode.create(exp(vl),pbestrealtype^);
  342. end;
  343. in_const_ln :
  344. begin
  345. if isreal then
  346. begin
  347. if vr<=0.0 then
  348. CGMessage(type_e_wrong_math_argument)
  349. else
  350. hp:=crealconstnode.create(ln(vr),pbestrealtype^)
  351. end
  352. else
  353. begin
  354. if vl<=0 then
  355. CGMessage(type_e_wrong_math_argument)
  356. else
  357. hp:=crealconstnode.create(ln(vl),pbestrealtype^);
  358. end;
  359. end;
  360. else
  361. internalerror(88);
  362. end;
  363. end;
  364. if hp=nil then
  365. hp:=tnode.create(errorn);
  366. resulttypepass(hp);
  367. result:=hp;
  368. goto myexit;
  369. end
  370. else
  371. begin
  372. case inlinenumber of
  373. in_lo_long,
  374. in_hi_long,
  375. in_lo_qword,
  376. in_hi_qword,
  377. in_lo_word,
  378. in_hi_word :
  379. begin
  380. { give warning for incompatibility with tp and delphi }
  381. if (inlinenumber in [in_lo_long,in_hi_long,in_lo_qword,in_hi_qword]) and
  382. ((m_tp in aktmodeswitches) or
  383. (m_delphi in aktmodeswitches)) then
  384. CGMessage(type_w_maybe_wrong_hi_lo);
  385. { constant folding }
  386. if left.nodetype=ordconstn then
  387. begin
  388. case inlinenumber of
  389. in_lo_word :
  390. hp:=cordconstnode.create(tordconstnode(left).value and $ff,left.resulttype);
  391. in_hi_word :
  392. hp:=cordconstnode.create(tordconstnode(left).value shr 8,left.resulttype);
  393. in_lo_long :
  394. hp:=cordconstnode.create(tordconstnode(left).value and $ffff,left.resulttype);
  395. in_hi_long :
  396. hp:=cordconstnode.create(tordconstnode(left).value shr 16,left.resulttype);
  397. in_lo_qword :
  398. hp:=cordconstnode.create(tordconstnode(left).value and $ffffffff,left.resulttype);
  399. in_hi_qword :
  400. hp:=cordconstnode.create(tordconstnode(left).value shr 32,left.resulttype);
  401. end;
  402. resulttypepass(hp);
  403. result:=hp;
  404. goto myexit;
  405. end;
  406. set_varstate(left,true);
  407. if not is_integer(left.resulttype.def) then
  408. CGMessage(type_e_mismatch);
  409. case inlinenumber of
  410. in_lo_word,
  411. in_hi_word :
  412. resulttype:=u8bittype;
  413. in_lo_long,
  414. in_hi_long :
  415. resulttype:=u16bittype;
  416. in_lo_qword,
  417. in_hi_qword :
  418. resulttype:=u32bittype;
  419. end;
  420. end;
  421. in_sizeof_x:
  422. begin
  423. set_varstate(left,false);
  424. resulttype:=s32bittype;
  425. end;
  426. in_typeof_x:
  427. begin
  428. set_varstate(left,false);
  429. resulttype:=voidpointertype;
  430. end;
  431. in_ord_x:
  432. begin
  433. if (left.nodetype=ordconstn) then
  434. begin
  435. hp:=cordconstnode.create(tordconstnode(left).value,s32bittype);
  436. resulttypepass(hp);
  437. result:=hp;
  438. goto myexit;
  439. end;
  440. set_varstate(left,true);
  441. case left.resulttype.def.deftype of
  442. orddef :
  443. begin
  444. case torddef(left.resulttype.def).typ of
  445. bool8bit,
  446. uchar:
  447. begin
  448. { change to byte() }
  449. hp:=ctypeconvnode.create(left,u8bittype);
  450. left:=nil;
  451. include(hp.flags,nf_explizit);
  452. resulttypepass(hp);
  453. result:=hp;
  454. end;
  455. bool16bit,
  456. uwidechar :
  457. begin
  458. { change to word() }
  459. hp:=ctypeconvnode.create(left,u16bittype);
  460. left:=nil;
  461. include(hp.flags,nf_explizit);
  462. resulttypepass(hp);
  463. result:=hp;
  464. end;
  465. bool32bit :
  466. begin
  467. { change to dword() }
  468. hp:=ctypeconvnode.create(left,u32bittype);
  469. left:=nil;
  470. include(hp.flags,nf_explizit);
  471. resulttypepass(hp);
  472. result:=hp;
  473. end;
  474. uvoid :
  475. CGMessage(type_e_mismatch)
  476. else
  477. begin
  478. { all other orddef need no transformation }
  479. hp:=left;
  480. left:=nil;
  481. result:=hp;
  482. end;
  483. end;
  484. end;
  485. enumdef :
  486. begin
  487. hp:=ctypeconvnode.create(left,s32bittype);
  488. left:=nil;
  489. include(hp.flags,nf_explizit);
  490. resulttypepass(hp);
  491. result:=hp;
  492. end;
  493. else
  494. CGMessage(type_e_mismatch);
  495. end;
  496. end;
  497. in_chr_byte:
  498. begin
  499. { convert to explicit char() }
  500. set_varstate(left,true);
  501. hp:=ctypeconvnode.create(left,cchartype);
  502. include(hp.flags,nf_explizit);
  503. left:=nil;
  504. resulttypepass(hp);
  505. result:=hp;
  506. end;
  507. in_length_x:
  508. begin
  509. set_varstate(left,true);
  510. case left.resulttype.def.deftype of
  511. stringdef :
  512. begin
  513. { we don't need string convertions here }
  514. if (left.nodetype=typeconvn) and
  515. (ttypeconvnode(left).left.resulttype.def.deftype=stringdef) then
  516. begin
  517. hp:=ttypeconvnode(left).left;
  518. ttypeconvnode(left).left:=nil;
  519. left.free;
  520. left:=hp;
  521. end;
  522. { evaluates length of constant strings direct }
  523. if (left.nodetype=stringconstn) then
  524. begin
  525. hp:=cordconstnode.create(tstringconstnode(left).len,s32bittype);
  526. resulttypepass(hp);
  527. result:=hp;
  528. goto myexit;
  529. end;
  530. end;
  531. orddef :
  532. begin
  533. { length of char is one allways }
  534. if is_char(left.resulttype.def) or
  535. is_widechar(left.resulttype.def) then
  536. begin
  537. hp:=cordconstnode.create(1,s32bittype);
  538. resulttypepass(hp);
  539. result:=hp;
  540. goto myexit;
  541. end
  542. else
  543. CGMessage(type_e_mismatch);
  544. end;
  545. arraydef :
  546. begin
  547. if is_open_array(left.resulttype.def) or
  548. is_array_of_const(left.resulttype.def) then
  549. begin
  550. srsym:=searchsymonlyin(tloadnode(left).symtable,'high'+tvarsym(tloadnode(left).symtableentry).name);
  551. hp:=caddnode.create(addn,cloadnode.create(tvarsym(srsym),tloadnode(left).symtable),
  552. cordconstnode.create(1,s32bittype));
  553. resulttypepass(hp);
  554. result:=hp;
  555. goto myexit;
  556. end
  557. else
  558. if not is_dynamic_array(left.resulttype.def) then
  559. begin
  560. hp:=cordconstnode.create(tarraydef(left.resulttype.def).highrange-
  561. tarraydef(left.resulttype.def).lowrange+1,
  562. s32bittype);
  563. resulttypepass(hp);
  564. result:=hp;
  565. goto myexit;
  566. end;
  567. end;
  568. else
  569. CGMessage(type_e_mismatch);
  570. end;
  571. { shortstring return an 8 bit value as the length
  572. is the first byte of the string }
  573. if is_shortstring(left.resulttype.def) then
  574. resulttype:=u8bittype
  575. else
  576. resulttype:=s32bittype;
  577. end;
  578. in_typeinfo_x:
  579. begin
  580. set_varstate(left,true);
  581. resulttype:=voidpointertype;
  582. end;
  583. in_assigned_x:
  584. begin
  585. set_varstate(left,true);
  586. resulttype:=booltype;
  587. end;
  588. in_ofs_x :
  589. internalerror(2000101001);
  590. in_seg_x :
  591. begin
  592. set_varstate(left,false);
  593. hp:=cordconstnode.create(0,s32bittype);
  594. resulttypepass(hp);
  595. result:=hp;
  596. goto myexit;
  597. end;
  598. in_pred_x,
  599. in_succ_x:
  600. begin
  601. set_varstate(left,true);
  602. resulttype:=left.resulttype;
  603. if not is_ordinal(resulttype.def) then
  604. CGMessage(type_e_ordinal_expr_expected)
  605. else
  606. begin
  607. if (resulttype.def.deftype=enumdef) and
  608. (tenumdef(resulttype.def).has_jumps) then
  609. CGMessage(type_e_succ_and_pred_enums_with_assign_not_possible);
  610. end;
  611. { do constant folding after check for jumps }
  612. if left.nodetype=ordconstn then
  613. begin
  614. if inlinenumber=in_succ_x then
  615. hp:=cordconstnode.create(tordconstnode(left).value+1,left.resulttype)
  616. else
  617. hp:=cordconstnode.create(tordconstnode(left).value-1,left.resulttype);
  618. resulttypepass(hp);
  619. result:=hp;
  620. end;
  621. end;
  622. in_setlength_x:
  623. begin
  624. resulttype:=voidtype;
  625. if assigned(left) then
  626. begin
  627. ppn:=tcallparanode(left);
  628. counter:=0;
  629. { check type }
  630. while assigned(ppn.right) do
  631. begin
  632. set_varstate(ppn.left,true);
  633. inserttypeconv(ppn.left,s32bittype);
  634. inc(counter);
  635. ppn:=tcallparanode(ppn.right);
  636. end;
  637. { last param must be var }
  638. valid_for_var(ppn.left);
  639. set_varstate(ppn.left,false);
  640. { first param must be a string or dynamic array ...}
  641. if not((ppn.left.resulttype.def.deftype=stringdef) or
  642. (is_dynamic_array(ppn.left.resulttype.def))) then
  643. CGMessage(type_e_mismatch);
  644. { only dynamic arrays accept more dimensions }
  645. if (counter>1) and
  646. (not(is_dynamic_array(left.resulttype.def))) then
  647. CGMessage(type_e_mismatch);
  648. { convert shortstrings to openstring parameters }
  649. { (generate the hightree) (JM) }
  650. if (ppn.left.resulttype.def.deftype = stringdef) and
  651. (tstringdef(ppn.left.resulttype.def).string_typ =
  652. st_shortstring) then
  653. begin
  654. dummycoll:=tparaitem.create;
  655. dummycoll.paratyp:=vs_var;
  656. dummycoll.paratype:=openshortstringtype;
  657. tcallparanode(ppn).insert_typeconv(dummycoll,false);
  658. dummycoll.destroy;
  659. end;
  660. end
  661. else
  662. CGMessage(type_e_mismatch);
  663. end;
  664. in_finalize_x:
  665. begin
  666. resulttype:=voidtype;
  667. if assigned(left) and assigned(tcallparanode(left).left) then
  668. begin
  669. { first param must be var }
  670. valid_for_var(tcallparanode(left).left);
  671. set_varstate(tcallparanode(left).left,true);
  672. { two parameters?, the last parameter must be a longint }
  673. if assigned(tcallparanode(left).right) then
  674. inserttypeconv(tcallparanode(tcallparanode(left).right).left,s32bittype);
  675. end
  676. else
  677. CGMessage(type_e_mismatch);
  678. end;
  679. in_inc_x,
  680. in_dec_x:
  681. begin
  682. resulttype:=voidtype;
  683. if assigned(left) then
  684. begin
  685. set_varstate(left,true);
  686. if codegenerror then
  687. exit;
  688. { first param must be var }
  689. valid_for_var(tcallparanode(left).left);
  690. if (left.resulttype.def.deftype in [enumdef,pointerdef]) or
  691. is_ordinal(left.resulttype.def) then
  692. begin
  693. { two paras ? }
  694. if assigned(tcallparanode(left).right) then
  695. begin
  696. { insert a type conversion }
  697. { the second param is always longint }
  698. inserttypeconv(tcallparanode(tcallparanode(left).right).left,s32bittype);
  699. if assigned(tcallparanode(tcallparanode(left).right).right) then
  700. CGMessage(cg_e_illegal_expression);
  701. end;
  702. end
  703. else
  704. CGMessage(type_e_ordinal_expr_expected);
  705. end
  706. else
  707. CGMessage(type_e_mismatch);
  708. end;
  709. in_read_x,
  710. in_readln_x,
  711. in_write_x,
  712. in_writeln_x :
  713. begin
  714. resulttype:=voidtype;
  715. { we must know if it is a typed file or not }
  716. { but we must first do the firstpass for it }
  717. file_is_typed:=false;
  718. if assigned(left) then
  719. begin
  720. iswrite:=(inlinenumber in [in_write_x,in_writeln_x]);
  721. set_varstate(left,iswrite);
  722. { now we can check }
  723. hp:=left;
  724. while assigned(tcallparanode(hp).right) do
  725. hp:=tcallparanode(hp).right;
  726. { if resulttype.def is not assigned, then automatically }
  727. { file is not typed. }
  728. if assigned(hp) and assigned(hp.resulttype.def) then
  729. Begin
  730. if (hp.resulttype.def.deftype=filedef) then
  731. if (tfiledef(hp.resulttype.def).filetyp=ft_untyped) then
  732. begin
  733. if (inlinenumber in [in_readln_x,in_writeln_x]) then
  734. CGMessage(type_e_no_readln_writeln_for_typed_file)
  735. else
  736. CGMessage(type_e_no_read_write_for_untyped_file);
  737. end
  738. else if (tfiledef(hp.resulttype.def).filetyp=ft_typed) then
  739. begin
  740. file_is_typed:=true;
  741. { test the type }
  742. if (inlinenumber in [in_readln_x,in_writeln_x]) then
  743. CGMessage(type_e_no_readln_writeln_for_typed_file);
  744. hpp:=left;
  745. while (hpp<>hp) do
  746. begin
  747. if (tcallparanode(hpp).left.nodetype=typen) then
  748. CGMessage(type_e_cant_read_write_type);
  749. if not is_equal(hpp.resulttype.def,tfiledef(hp.resulttype.def).typedfiletype.def) then
  750. CGMessage(type_e_mismatch);
  751. { generate the high() value for the shortstring }
  752. if ((not iswrite) and is_shortstring(tcallparanode(hpp).left.resulttype.def)) or
  753. (is_chararray(tcallparanode(hpp).left.resulttype.def)) then
  754. tcallparanode(hpp).gen_high_tree(true);
  755. { read(ln) is call by reference (JM) }
  756. { and so is the data param of FPC_TYPED_WRITE (JM) }
  757. if not iswrite or file_is_typed then
  758. make_not_regable(tcallparanode(hpp).left);
  759. hpp:=tcallparanode(hpp).right;
  760. end;
  761. end;
  762. end; { endif assigned(hp) }
  763. { insert type conversions for write(ln) }
  764. if (not file_is_typed) then
  765. begin
  766. hp:=left;
  767. while assigned(hp) do
  768. begin
  769. if (tcallparanode(hp).left.nodetype=typen) then
  770. CGMessage(type_e_cant_read_write_type);
  771. if assigned(tcallparanode(hp).left.resulttype.def) then
  772. begin
  773. isreal:=false;
  774. { support writeln(procvar) }
  775. if (tcallparanode(hp).left.resulttype.def.deftype=procvardef) then
  776. begin
  777. p1:=ccallnode.create(nil,nil,nil,nil);
  778. tcallnode(p1).set_procvar(tcallparanode(hp).left);
  779. resulttypepass(p1);
  780. tcallparanode(hp).left:=p1;
  781. end;
  782. case tcallparanode(hp).left.resulttype.def.deftype of
  783. filedef :
  784. begin
  785. { only allowed as first parameter }
  786. if assigned(tcallparanode(hp).right) then
  787. CGMessage(type_e_cant_read_write_type);
  788. end;
  789. stringdef :
  790. begin
  791. { generate the high() value for the shortstring }
  792. if (not iswrite) and
  793. is_shortstring(tcallparanode(hp).left.resulttype.def) then
  794. tcallparanode(hp).gen_high_tree(true);
  795. end;
  796. pointerdef :
  797. begin
  798. if not is_pchar(tcallparanode(hp).left.resulttype.def) then
  799. CGMessage(type_e_cant_read_write_type);
  800. end;
  801. floatdef :
  802. begin
  803. isreal:=true;
  804. end;
  805. orddef :
  806. begin
  807. case torddef(tcallparanode(hp).left.resulttype.def).typ of
  808. uchar,uwidechar,
  809. u32bit,s32bit,
  810. u64bit,s64bit:
  811. ;
  812. u8bit,s8bit,
  813. u16bit,s16bit :
  814. if iswrite then
  815. inserttypeconv(tcallparanode(hp).left,s32bittype);
  816. bool8bit,
  817. bool16bit,
  818. bool32bit :
  819. if iswrite then
  820. inserttypeconv(tcallparanode(hp).left,booltype)
  821. else
  822. CGMessage(type_e_cant_read_write_type);
  823. else
  824. CGMessage(type_e_cant_read_write_type);
  825. end;
  826. end;
  827. arraydef :
  828. begin
  829. if is_chararray(tcallparanode(hp).left.resulttype.def) then
  830. tcallparanode(hp).gen_high_tree(true)
  831. else
  832. CGMessage(type_e_cant_read_write_type);
  833. end;
  834. else
  835. CGMessage(type_e_cant_read_write_type);
  836. end;
  837. { some format options ? }
  838. if cpf_is_colon_para in tcallparanode(hp).callparaflags then
  839. begin
  840. if cpf_is_colon_para in tcallparanode(tcallparanode(hp).right).callparaflags then
  841. begin
  842. frac_para:=hp;
  843. length_para:=tcallparanode(hp).right;
  844. hp:=tcallparanode(hp).right;
  845. hpp:=tcallparanode(hp).right;
  846. end
  847. else
  848. begin
  849. length_para:=hp;
  850. frac_para:=nil;
  851. hpp:=tcallparanode(hp).right;
  852. end;
  853. { can be nil if you use "write(e:0:6)" while e is undeclared (JM) }
  854. if assigned(tcallparanode(hpp).left.resulttype.def) then
  855. isreal:=(tcallparanode(hpp).left.resulttype.def.deftype=floatdef)
  856. else
  857. exit;
  858. if (not is_integer(tcallparanode(length_para).left.resulttype.def)) then
  859. CGMessage1(type_e_integer_expr_expected,tcallparanode(length_para).left.resulttype.def.typename)
  860. else
  861. inserttypeconv(tcallparanode(length_para).left,s32bittype);
  862. if assigned(frac_para) then
  863. begin
  864. if isreal then
  865. begin
  866. if (not is_integer(tcallparanode(frac_para).left.resulttype.def)) then
  867. CGMessage1(type_e_integer_expr_expected,tcallparanode(frac_para).left.resulttype.def.typename)
  868. else
  869. inserttypeconv(tcallparanode(frac_para).left,s32bittype);
  870. end
  871. else
  872. CGMessage(parser_e_illegal_colon_qualifier);
  873. end;
  874. { do the checking for the colon'd arg }
  875. hp:=length_para;
  876. end;
  877. end;
  878. hp:=tcallparanode(hp).right;
  879. end;
  880. end;
  881. if codegenerror then
  882. exit;
  883. set_varstate(left,true);
  884. end;
  885. end;
  886. in_settextbuf_file_x :
  887. begin
  888. resulttype:=voidtype;
  889. { now we know the type of buffer }
  890. srsym:=searchsymonlyin(systemunit,'SETTEXTBUF');
  891. hp:=ccallparanode.create(cordconstnode.create(tcallparanode(left).left.resulttype.def.size,s32bittype),left);
  892. hp:=ccallnode.create(hp,tprocsym(srsym),systemunit,nil);
  893. left:=nil;
  894. resulttypepass(hp);
  895. result:=hp;
  896. end;
  897. { the firstpass of the arg has been done in firstcalln ? }
  898. in_reset_typedfile,
  899. in_rewrite_typedfile :
  900. begin
  901. set_varstate(left,true);
  902. resulttype:=voidtype;
  903. end;
  904. in_str_x_string :
  905. begin
  906. resulttype:=voidtype;
  907. set_varstate(left,false);
  908. { remove warning when result is passed }
  909. set_funcret_is_valid(tcallparanode(left).left);
  910. set_varstate(tcallparanode(tcallparanode(left).right).left,true);
  911. hp:=left;
  912. { valid string ? }
  913. if not assigned(hp) or
  914. (tcallparanode(hp).left.resulttype.def.deftype<>stringdef) or
  915. (tcallparanode(hp).right=nil) then
  916. CGMessage(cg_e_illegal_expression);
  917. { we need a var parameter }
  918. valid_for_var(tcallparanode(hp).left);
  919. { generate the high() value for the shortstring }
  920. if is_shortstring(tcallparanode(hp).left.resulttype.def) then
  921. tcallparanode(hp).gen_high_tree(true);
  922. { !!!! check length of string }
  923. while assigned(tcallparanode(hp).right) do
  924. hp:=tcallparanode(hp).right;
  925. if not assigned(tcallparanode(hp).resulttype.def) then
  926. exit;
  927. { check and convert the first param }
  928. if (cpf_is_colon_para in tcallparanode(hp).callparaflags) or
  929. not assigned(hp.resulttype.def) then
  930. CGMessage(cg_e_illegal_expression);
  931. isreal:=false;
  932. case hp.resulttype.def.deftype of
  933. orddef :
  934. begin
  935. case torddef(tcallparanode(hp).left.resulttype.def).typ of
  936. u32bit,s32bit,
  937. s64bit,u64bit:
  938. ;
  939. u8bit,s8bit,
  940. u16bit,s16bit:
  941. inserttypeconv(tcallparanode(hp).left,s32bittype);
  942. else
  943. CGMessage(type_e_integer_or_real_expr_expected);
  944. end;
  945. end;
  946. floatdef :
  947. begin
  948. isreal:=true;
  949. end;
  950. else
  951. CGMessage(type_e_integer_or_real_expr_expected);
  952. end;
  953. { some format options ? }
  954. hpp:=tcallparanode(left).right;
  955. if assigned(hpp) and (cpf_is_colon_para in tcallparanode(hpp).callparaflags) then
  956. begin
  957. set_varstate(tcallparanode(hpp).left,true);
  958. if (not is_integer(tcallparanode(hpp).left.resulttype.def)) then
  959. CGMessage1(type_e_integer_expr_expected,tcallparanode(hpp).left.resulttype.def.typename)
  960. else
  961. inserttypeconv(tcallparanode(hpp).left,s32bittype);
  962. hpp:=tcallparanode(hpp).right;
  963. if assigned(hpp) and (cpf_is_colon_para in tcallparanode(hpp).callparaflags) then
  964. begin
  965. if isreal then
  966. begin
  967. if (not is_integer(tcallparanode(hpp).left.resulttype.def)) then
  968. CGMessage1(type_e_integer_expr_expected,tcallparanode(hpp).left.resulttype.def.typename)
  969. else
  970. begin
  971. set_varstate(tcallparanode(hpp).left,true);
  972. inserttypeconv(tcallparanode(hpp).left,s32bittype);
  973. end;
  974. end
  975. else
  976. CGMessage(parser_e_illegal_colon_qualifier);
  977. end;
  978. end;
  979. end;
  980. in_val_x :
  981. begin
  982. resulttype:=voidtype;
  983. { check the amount of parameters }
  984. if not(assigned(left)) or
  985. not(assigned(tcallparanode(left).right)) then
  986. begin
  987. CGMessage(parser_e_wrong_parameter_size);
  988. exit;
  989. end;
  990. { there is a "code" parameter }
  991. If Assigned(tcallparanode(tcallparanode(left).right).right) Then
  992. Begin
  993. { first pass just the code parameter for first local use}
  994. hp := tcallparanode(left).right;
  995. tcallparanode(left).right := nil;
  996. make_not_regable(tcallparanode(left).left);
  997. set_varstate(left,false);
  998. if codegenerror then
  999. exit;
  1000. tcallparanode(left).right := hp;
  1001. { code has to be a var parameter }
  1002. if valid_for_var(tcallparanode(left).left) then
  1003. begin
  1004. if (tcallparanode(left).left.resulttype.def.deftype <> orddef) or
  1005. not(torddef(tcallparanode(left).left.resulttype.def).typ in [u16bit,s16bit,u32bit,s32bit]) then
  1006. CGMessage(type_e_mismatch);
  1007. end;
  1008. hpp := tcallparanode(left).right
  1009. End
  1010. Else
  1011. hpp := left;
  1012. { now hpp = the destination value tree }
  1013. { first pass just the destination parameter for first local use }
  1014. hp:=tcallparanode(hpp).right;
  1015. tcallparanode(hpp).right:=nil;
  1016. { hpp = destination }
  1017. make_not_regable(tcallparanode(hpp).left);
  1018. set_varstate(hpp,false);
  1019. if codegenerror then
  1020. exit;
  1021. { remove warning when result is passed }
  1022. set_funcret_is_valid(tcallparanode(hpp).left);
  1023. tcallparanode(hpp).right := hp;
  1024. if valid_for_var(tcallparanode(hpp).left) then
  1025. begin
  1026. If Not((tcallparanode(hpp).left.resulttype.def.deftype = floatdef) or
  1027. is_integer(tcallparanode(hpp).left.resulttype.def)) then
  1028. CGMessage(type_e_mismatch);
  1029. end;
  1030. { hp = source (String) }
  1031. { if not a stringdef then insert a type conv which
  1032. does the other type checking }
  1033. If (tcallparanode(hp).left.resulttype.def.deftype<>stringdef) then
  1034. inserttypeconv(tcallparanode(hp).left,cshortstringtype);
  1035. set_varstate(hp,true);
  1036. end;
  1037. in_include_x_y,
  1038. in_exclude_x_y:
  1039. begin
  1040. resulttype:=voidtype;
  1041. if assigned(left) then
  1042. begin
  1043. set_varstate(left,true);
  1044. { remove warning when result is passed }
  1045. set_funcret_is_valid(tcallparanode(left).left);
  1046. { first param must be var }
  1047. valid_for_var(tcallparanode(left).left);
  1048. { check type }
  1049. if assigned(left.resulttype.def) and
  1050. (left.resulttype.def.deftype=setdef) then
  1051. begin
  1052. { two paras ? }
  1053. if assigned(tcallparanode(left).right) then
  1054. begin
  1055. { insert a type conversion }
  1056. { to the type of the set elements }
  1057. inserttypeconv(tcallparanode(tcallparanode(left).right).left,
  1058. tsetdef(left.resulttype.def).elementtype);
  1059. { only three parameters are allowed }
  1060. if assigned(tcallparanode(tcallparanode(left).right).right) then
  1061. CGMessage(cg_e_illegal_expression);
  1062. end;
  1063. end
  1064. else
  1065. CGMessage(type_e_mismatch);
  1066. end
  1067. else
  1068. CGMessage(type_e_mismatch);
  1069. end;
  1070. in_low_x,
  1071. in_high_x:
  1072. begin
  1073. set_varstate(left,false);
  1074. case left.resulttype.def.deftype of
  1075. orddef,
  1076. enumdef:
  1077. begin
  1078. hp:=do_lowhigh(left.resulttype);
  1079. resulttypepass(hp);
  1080. result:=hp;
  1081. end;
  1082. setdef:
  1083. begin
  1084. hp:=do_lowhigh(tsetdef(left.resulttype.def).elementtype);
  1085. resulttypepass(hp);
  1086. result:=hp;
  1087. end;
  1088. arraydef:
  1089. begin
  1090. if inlinenumber=in_low_x then
  1091. begin
  1092. hp:=cordconstnode.create(tarraydef(left.resulttype.def).lowrange,tarraydef(left.resulttype.def).rangetype);
  1093. resulttypepass(hp);
  1094. result:=hp;
  1095. end
  1096. else
  1097. begin
  1098. if is_open_array(left.resulttype.def) or
  1099. is_array_of_const(left.resulttype.def) then
  1100. begin
  1101. srsym:=searchsymonlyin(tloadnode(left).symtable,'high'+tvarsym(tloadnode(left).symtableentry).name);
  1102. hp:=cloadnode.create(tvarsym(srsym),tloadnode(left).symtable);
  1103. resulttypepass(hp);
  1104. result:=hp;
  1105. end
  1106. else
  1107. if is_dynamic_array(left.resulttype.def) then
  1108. begin
  1109. {$ifndef hascompilerproc}
  1110. writeln('Error: high(dynamic_array) isn''t implemented yet');
  1111. codegenerror := true;
  1112. {$else hascompilerproc}
  1113. { can't use inserttypeconv because we need }
  1114. { an explicit type conversion (JM) }
  1115. hp := ctypeconvnode.create(left,voidpointertype);
  1116. hp.toggleflag(nf_explizit);
  1117. hp := ccallparanode.create(hp,nil);
  1118. hp := ccallnode.createintern('fpc_dynarray_high',hp);
  1119. { make sure the left node doesn't get disposed, since it's }
  1120. { reused in the new node (JM) }
  1121. left:=nil;
  1122. resulttypepass(hp);
  1123. result:=hp;
  1124. {$endif hascompilerproc}
  1125. end
  1126. else
  1127. begin
  1128. hp:=cordconstnode.create(tarraydef(left.resulttype.def).highrange,tarraydef(left.resulttype.def).rangetype);
  1129. resulttypepass(hp);
  1130. result:=hp;
  1131. end;
  1132. end;
  1133. end;
  1134. stringdef:
  1135. begin
  1136. if inlinenumber=in_low_x then
  1137. begin
  1138. hp:=cordconstnode.create(0,u8bittype);
  1139. resulttypepass(hp);
  1140. result:=hp;
  1141. end
  1142. else
  1143. begin
  1144. if is_open_string(left.resulttype.def) then
  1145. begin
  1146. srsym:=searchsymonlyin(tloadnode(left).symtable,'high'+tvarsym(tloadnode(left).symtableentry).name);
  1147. hp:=cloadnode.create(tvarsym(srsym),tloadnode(left).symtable);
  1148. resulttypepass(hp);
  1149. result:=hp;
  1150. end
  1151. else
  1152. begin
  1153. hp:=cordconstnode.create(tstringdef(left.resulttype.def).len,u8bittype);
  1154. resulttypepass(hp);
  1155. result:=hp;
  1156. end;
  1157. end;
  1158. end;
  1159. else
  1160. CGMessage(type_e_mismatch);
  1161. end;
  1162. end;
  1163. in_pi:
  1164. begin
  1165. if block_type=bt_const then
  1166. setconstrealvalue(pi)
  1167. else
  1168. resulttype:=s80floattype;
  1169. end;
  1170. in_cos_extended :
  1171. begin
  1172. if left.nodetype in [ordconstn,realconstn] then
  1173. setconstrealvalue(cos(getconstrealvalue))
  1174. else
  1175. begin
  1176. set_varstate(left,true);
  1177. inserttypeconv(left,s80floattype);
  1178. resulttype:=s80floattype;
  1179. end;
  1180. end;
  1181. in_sin_extended :
  1182. begin
  1183. if left.nodetype in [ordconstn,realconstn] then
  1184. setconstrealvalue(sin(getconstrealvalue))
  1185. else
  1186. begin
  1187. set_varstate(left,true);
  1188. inserttypeconv(left,s80floattype);
  1189. resulttype:=s80floattype;
  1190. end;
  1191. end;
  1192. in_arctan_extended :
  1193. begin
  1194. if left.nodetype in [ordconstn,realconstn] then
  1195. setconstrealvalue(arctan(getconstrealvalue))
  1196. else
  1197. begin
  1198. set_varstate(left,true);
  1199. inserttypeconv(left,s80floattype);
  1200. resulttype:=s80floattype;
  1201. end;
  1202. end;
  1203. in_abs_extended :
  1204. begin
  1205. if left.nodetype in [ordconstn,realconstn] then
  1206. setconstrealvalue(abs(getconstrealvalue))
  1207. else
  1208. begin
  1209. set_varstate(left,true);
  1210. inserttypeconv(left,s80floattype);
  1211. resulttype:=s80floattype;
  1212. end;
  1213. end;
  1214. in_sqr_extended :
  1215. begin
  1216. if left.nodetype in [ordconstn,realconstn] then
  1217. setconstrealvalue(sqr(getconstrealvalue))
  1218. else
  1219. begin
  1220. set_varstate(left,true);
  1221. inserttypeconv(left,s80floattype);
  1222. resulttype:=s80floattype;
  1223. end;
  1224. end;
  1225. in_sqrt_extended :
  1226. begin
  1227. if left.nodetype in [ordconstn,realconstn] then
  1228. begin
  1229. vr:=getconstrealvalue;
  1230. if vr<0.0 then
  1231. begin
  1232. CGMessage(type_e_wrong_math_argument);
  1233. setconstrealvalue(0);
  1234. end
  1235. else
  1236. setconstrealvalue(sqrt(vr));
  1237. end
  1238. else
  1239. begin
  1240. set_varstate(left,true);
  1241. inserttypeconv(left,s80floattype);
  1242. resulttype:=s80floattype;
  1243. end;
  1244. end;
  1245. in_ln_extended :
  1246. begin
  1247. if left.nodetype in [ordconstn,realconstn] then
  1248. begin
  1249. vr:=getconstrealvalue;
  1250. if vr<=0.0 then
  1251. begin
  1252. CGMessage(type_e_wrong_math_argument);
  1253. setconstrealvalue(0);
  1254. end
  1255. else
  1256. setconstrealvalue(ln(vr));
  1257. end
  1258. else
  1259. begin
  1260. set_varstate(left,true);
  1261. inserttypeconv(left,s80floattype);
  1262. resulttype:=s80floattype;
  1263. end;
  1264. end;
  1265. {$ifdef SUPPORT_MMX}
  1266. in_mmx_pcmpeqb..in_mmx_pcmpgtw:
  1267. begin
  1268. end;
  1269. {$endif SUPPORT_MMX}
  1270. in_assert_x_y :
  1271. begin
  1272. resulttype:=voidtype;
  1273. if assigned(left) then
  1274. begin
  1275. set_varstate(left,true);
  1276. { check type }
  1277. if is_boolean(left.resulttype.def) then
  1278. begin
  1279. { must always be a string }
  1280. inserttypeconv(tcallparanode(tcallparanode(left).right).left,cshortstringtype);
  1281. end
  1282. else
  1283. CGMessage(type_e_mismatch);
  1284. end
  1285. else
  1286. CGMessage(type_e_mismatch);
  1287. end;
  1288. else
  1289. internalerror(8);
  1290. end;
  1291. end;
  1292. myexit:
  1293. { Run get_paratype again to update maybe inserted typeconvs }
  1294. if not codegenerror then
  1295. begin
  1296. if assigned(left) and
  1297. (left.nodetype=callparan) then
  1298. tcallparanode(left).get_paratype;
  1299. end;
  1300. dec(parsing_para_level);
  1301. end;
  1302. {$ifdef fpc}
  1303. {$maxfpuregisters 0}
  1304. {$endif fpc}
  1305. function tinlinenode.pass_1 : tnode;
  1306. var
  1307. srsym : tsym;
  1308. hp,hpp : tnode;
  1309. extra_register,
  1310. iswrite,
  1311. file_is_typed : boolean;
  1312. begin
  1313. result:=nil;
  1314. { if we handle writeln; left contains no valid address }
  1315. if assigned(left) then
  1316. begin
  1317. if left.nodetype=callparan then
  1318. tcallparanode(left).firstcallparan(nil,false)
  1319. else
  1320. firstpass(left);
  1321. left_max;
  1322. set_location(location,left.location);
  1323. end;
  1324. inc(parsing_para_level);
  1325. { intern const should already be handled }
  1326. if nf_inlineconst in flags then
  1327. internalerror(200104044);
  1328. case inlinenumber of
  1329. in_lo_qword,
  1330. in_hi_qword,
  1331. in_lo_long,
  1332. in_hi_long,
  1333. in_lo_word,
  1334. in_hi_word:
  1335. begin
  1336. if registers32<1 then
  1337. registers32:=1;
  1338. location.loc:=LOC_REGISTER;
  1339. end;
  1340. in_sizeof_x:
  1341. begin
  1342. if push_high_param(left.resulttype.def) then
  1343. begin
  1344. srsym:=searchsymonlyin(tloadnode(left).symtable,'high'+tvarsym(tloadnode(left).symtableentry).name);
  1345. hp:=caddnode.create(addn,cloadnode.create(tvarsym(srsym),tloadnode(left).symtable),
  1346. cordconstnode.create(1,s32bittype));
  1347. if (left.resulttype.def.deftype=arraydef) and
  1348. (tarraydef(left.resulttype.def).elesize<>1) then
  1349. hp:=caddnode.create(muln,hp,cordconstnode.create(tarraydef(left.resulttype.def).elesize,s32bittype));
  1350. firstpass(hp);
  1351. result:=hp;
  1352. end
  1353. else
  1354. begin
  1355. if registers32<1 then
  1356. registers32:=1;
  1357. location.loc:=LOC_REGISTER;
  1358. end;
  1359. end;
  1360. in_typeof_x:
  1361. begin
  1362. if registers32<1 then
  1363. registers32:=1;
  1364. location.loc:=LOC_REGISTER;
  1365. end;
  1366. in_ord_x,
  1367. in_chr_byte:
  1368. begin
  1369. { should not happend as it's converted to typeconv }
  1370. internalerror(200104045);
  1371. end;
  1372. in_length_x:
  1373. begin
  1374. if is_shortstring(left.resulttype.def) then
  1375. location.loc:=LOC_REFERENCE
  1376. else
  1377. begin
  1378. { ansi/wide string }
  1379. if registers32<1 then
  1380. registers32:=1;
  1381. location.loc:=LOC_REGISTER;
  1382. end;
  1383. end;
  1384. in_typeinfo_x:
  1385. begin
  1386. location.loc:=LOC_REGISTER;
  1387. registers32:=1;
  1388. end;
  1389. in_assigned_x:
  1390. begin
  1391. location.loc:=LOC_FLAGS;
  1392. end;
  1393. in_ofs_x :
  1394. internalerror(2000101001);
  1395. in_seg_x :
  1396. internalerror(200104046);
  1397. in_pred_x,
  1398. in_succ_x:
  1399. begin
  1400. if is_64bitint(resulttype.def) then
  1401. begin
  1402. if (registers32<2) then
  1403. registers32:=2
  1404. end
  1405. else
  1406. begin
  1407. if (registers32<1) then
  1408. registers32:=1;
  1409. end;
  1410. location.loc:=LOC_REGISTER;
  1411. end;
  1412. in_setlength_x:
  1413. begin
  1414. end;
  1415. in_finalize_x:
  1416. begin
  1417. end;
  1418. in_inc_x,
  1419. in_dec_x:
  1420. begin
  1421. { check type }
  1422. if is_64bitint(left.resulttype.def) or
  1423. { range/overflow checking doesn't work properly }
  1424. { with the inc/dec code that's generated (JM) }
  1425. ((left.resulttype.def.deftype = orddef) and
  1426. not(is_char(left.resulttype.def)) and
  1427. not(is_boolean(left.resulttype.def)) and
  1428. (aktlocalswitches *
  1429. [cs_check_overflow,cs_check_range] <> [])) then
  1430. { convert to simple add (JM) }
  1431. begin
  1432. { extra parameter? }
  1433. if assigned(tcallparanode(left).right) then
  1434. begin
  1435. { Yes, use for add node }
  1436. hpp := tcallparanode(tcallparanode(left).right).left;
  1437. tcallparanode(tcallparanode(left).right).left := nil;
  1438. if assigned(tcallparanode(tcallparanode(left).right).right) then
  1439. CGMessage(cg_e_illegal_expression);
  1440. end
  1441. else
  1442. { no, create constant 1 }
  1443. hpp := cordconstnode.create(1,s32bittype);
  1444. { addition/substraction depending on inc/dec }
  1445. if inlinenumber = in_inc_x then
  1446. hp := caddnode.create(addn,tcallparanode(left).left.getcopy,hpp)
  1447. else
  1448. hp := caddnode.create(subn,tcallparanode(left).left.getcopy,hpp);
  1449. { assign result of addition }
  1450. hpp := cassignmentnode.create(tcallparanode(left).left,hp);
  1451. tcallparanode(left).left := nil;
  1452. { firstpass it }
  1453. firstpass(hpp);
  1454. { return new node }
  1455. result := hpp;
  1456. end
  1457. else if (left.resulttype.def.deftype in [enumdef,pointerdef]) or
  1458. is_ordinal(left.resulttype.def) then
  1459. begin
  1460. { two paras ? }
  1461. if assigned(tcallparanode(left).right) then
  1462. begin
  1463. { need we an additional register ? }
  1464. if not(is_constintnode(tcallparanode(tcallparanode(left).right).left)) and
  1465. (tcallparanode(tcallparanode(left).right).left.location.loc in [LOC_MEM,LOC_REFERENCE]) and
  1466. (tcallparanode(tcallparanode(left).right).left.registers32<=1) then
  1467. inc(registers32);
  1468. { do we need an additional register to restore the first parameter? }
  1469. if tcallparanode(tcallparanode(left).right).left.registers32>=registers32 then
  1470. inc(registers32);
  1471. end;
  1472. end;
  1473. end;
  1474. in_read_x,
  1475. in_readln_x,
  1476. in_write_x,
  1477. in_writeln_x :
  1478. begin
  1479. { needs a call }
  1480. procinfo^.flags:=procinfo^.flags or pi_do_call;
  1481. { true, if readln needs an extra register }
  1482. extra_register:=false;
  1483. { we must know if it is a typed file or not }
  1484. { but we must first do the firstpass for it }
  1485. file_is_typed:=false;
  1486. if assigned(left) then
  1487. begin
  1488. iswrite:=(inlinenumber in [in_write_x,in_writeln_x]);
  1489. { now we can check }
  1490. hp:=left;
  1491. while assigned(tcallparanode(hp).right) do
  1492. hp:=tcallparanode(hp).right;
  1493. { if resulttype.def is not assigned, then automatically }
  1494. { file is not typed. }
  1495. if assigned(hp) then
  1496. Begin
  1497. if (hp.resulttype.def.deftype=filedef) and
  1498. (tfiledef(hp.resulttype.def).filetyp=ft_typed) then
  1499. file_is_typed:=true;
  1500. end; { endif assigned(hp) }
  1501. if (not file_is_typed) then
  1502. begin
  1503. hp:=left;
  1504. while assigned(hp) do
  1505. begin
  1506. {$ifdef i386}
  1507. incrementregisterpushed($ff);
  1508. {$else}
  1509. incrementregisterpushed(ALL_REGISTERS);
  1510. {$endif}
  1511. if assigned(tcallparanode(hp).left.resulttype.def) then
  1512. begin
  1513. case tcallparanode(hp).left.resulttype.def.deftype of
  1514. orddef :
  1515. begin
  1516. if not(iswrite) and
  1517. not(is_64bitint(tcallparanode(hp).left.resulttype.def)) then
  1518. extra_register:=true;
  1519. end;
  1520. end;
  1521. end;
  1522. hp:=tcallparanode(hp).right;
  1523. end;
  1524. end;
  1525. { calc registers }
  1526. left_max;
  1527. if extra_register then
  1528. inc(registers32);
  1529. end;
  1530. end;
  1531. in_settextbuf_file_x :
  1532. internalerror(200104262);
  1533. in_reset_typedfile,
  1534. in_rewrite_typedfile :
  1535. begin
  1536. procinfo^.flags:=procinfo^.flags or pi_do_call;
  1537. end;
  1538. in_str_x_string :
  1539. begin
  1540. procinfo^.flags:=procinfo^.flags or pi_do_call;
  1541. { calc registers }
  1542. left_max;
  1543. end;
  1544. in_val_x :
  1545. begin
  1546. procinfo^.flags:=procinfo^.flags or pi_do_call;
  1547. { calc registers }
  1548. left_max;
  1549. { val doesn't calculate the registers really }
  1550. { correct, we need one register extra (FK) }
  1551. { there is a "code" parameter }
  1552. If Assigned(tcallparanode(tcallparanode(left).right).right) Then
  1553. hpp := tcallparanode(left).right
  1554. Else
  1555. hpp := left;
  1556. { now hpp = the destination value tree }
  1557. if is_64bitint(tcallparanode(hpp).left.resulttype.def) then
  1558. inc(registers32,2)
  1559. else
  1560. inc(registers32,1);
  1561. end;
  1562. in_include_x_y,
  1563. in_exclude_x_y:
  1564. begin
  1565. registers32:=left.registers32;
  1566. registersfpu:=left.registersfpu;
  1567. {$ifdef SUPPORT_MMX}
  1568. registersmmx:=left.registersmmx;
  1569. {$endif SUPPORT_MMX}
  1570. end;
  1571. in_low_x,
  1572. in_high_x:
  1573. internalerror(200104047);
  1574. in_cos_extended:
  1575. begin
  1576. location.loc:=LOC_FPU;
  1577. registers32:=left.registers32;
  1578. registersfpu:=left.registersfpu;
  1579. {$ifdef SUPPORT_MMX}
  1580. registersmmx:=left.registersmmx;
  1581. {$endif SUPPORT_MMX}
  1582. end;
  1583. in_sin_extended:
  1584. begin
  1585. location.loc:=LOC_FPU;
  1586. registers32:=left.registers32;
  1587. registersfpu:=left.registersfpu;
  1588. {$ifdef SUPPORT_MMX}
  1589. registersmmx:=left.registersmmx;
  1590. {$endif SUPPORT_MMX}
  1591. end;
  1592. in_arctan_extended:
  1593. begin
  1594. location.loc:=LOC_FPU;
  1595. registers32:=left.registers32;
  1596. registersfpu:=left.registersfpu;
  1597. {$ifdef SUPPORT_MMX}
  1598. registersmmx:=left.registersmmx;
  1599. {$endif SUPPORT_MMX}
  1600. end;
  1601. in_pi:
  1602. begin
  1603. location.loc:=LOC_FPU;
  1604. end;
  1605. in_abs_extended:
  1606. begin
  1607. location.loc:=LOC_FPU;
  1608. registers32:=left.registers32;
  1609. registersfpu:=left.registersfpu;
  1610. {$ifdef SUPPORT_MMX}
  1611. registersmmx:=left.registersmmx;
  1612. {$endif SUPPORT_MMX}
  1613. end;
  1614. in_sqr_extended:
  1615. begin
  1616. location.loc:=LOC_FPU;
  1617. registers32:=left.registers32;
  1618. registersfpu:=left.registersfpu;
  1619. {$ifdef SUPPORT_MMX}
  1620. registersmmx:=left.registersmmx;
  1621. {$endif SUPPORT_MMX}
  1622. end;
  1623. in_sqrt_extended:
  1624. begin
  1625. location.loc:=LOC_FPU;
  1626. registers32:=left.registers32;
  1627. registersfpu:=left.registersfpu;
  1628. {$ifdef SUPPORT_MMX}
  1629. registersmmx:=left.registersmmx;
  1630. {$endif SUPPORT_MMX}
  1631. end;
  1632. in_ln_extended:
  1633. begin
  1634. location.loc:=LOC_FPU;
  1635. registers32:=left.registers32;
  1636. registersfpu:=left.registersfpu;
  1637. {$ifdef SUPPORT_MMX}
  1638. registersmmx:=left.registersmmx;
  1639. {$endif SUPPORT_MMX}
  1640. end;
  1641. {$ifdef SUPPORT_MMX}
  1642. in_mmx_pcmpeqb..in_mmx_pcmpgtw:
  1643. begin
  1644. end;
  1645. {$endif SUPPORT_MMX}
  1646. in_assert_x_y :
  1647. begin
  1648. { We've checked the whole statement for correctness, now we
  1649. can remove it if assertions are off }
  1650. if not(cs_do_assertion in aktlocalswitches) then
  1651. begin
  1652. { we need a valid node, so insert a nothingn }
  1653. result:=cnothingnode.create;
  1654. end
  1655. else
  1656. begin
  1657. registers32:=left.registers32;
  1658. registersfpu:=left.registersfpu;
  1659. {$ifdef SUPPORT_MMX}
  1660. registersmmx:=left.registersmmx;
  1661. {$endif SUPPORT_MMX}
  1662. end;
  1663. end;
  1664. else
  1665. internalerror(8);
  1666. end;
  1667. dec(parsing_para_level);
  1668. end;
  1669. {$ifdef fpc}
  1670. {$maxfpuregisters default}
  1671. {$endif fpc}
  1672. function tinlinenode.docompare(p: tnode): boolean;
  1673. begin
  1674. docompare :=
  1675. inherited docompare(p) and
  1676. (inlinenumber = tinlinenode(p).inlinenumber);
  1677. end;
  1678. begin
  1679. cinlinenode:=tinlinenode;
  1680. end.
  1681. {
  1682. $Log$
  1683. Revision 1.46 2001-08-06 12:47:31 jonas
  1684. * parameters to FPC_TYPED_WRITE can't be regvars (merged)
  1685. Revision 1.45 2001/08/06 09:44:10 jonas
  1686. + support for high(dynarray) using compilerproc (forgot to commit
  1687. previously)
  1688. Revision 1.44 2001/07/09 21:15:40 peter
  1689. * Length made internal
  1690. * Add array support for Length
  1691. Revision 1.43 2001/07/08 21:00:15 peter
  1692. * various widestring updates, it works now mostly without charset
  1693. mapping supported
  1694. Revision 1.42 2001/06/04 11:48:01 peter
  1695. * better const to var checking
  1696. Revision 1.41 2001/06/03 20:12:53 peter
  1697. * changed int64($ffffffff) that is buggy under 1.0.x to expression
  1698. with a shl
  1699. Revision 1.40 2001/05/06 17:16:43 jonas
  1700. + added warning about missing implementation for high(dynamic_array)
  1701. Revision 1.39 2001/04/26 21:57:05 peter
  1702. * moved code from firstpass to det_resulttype and remove extraneous
  1703. calls to firstcallparan for in_str,in_write,in_val
  1704. Revision 1.38 2001/04/21 12:03:11 peter
  1705. * m68k updates merged from fixes branch
  1706. Revision 1.37 2001/04/13 22:22:30 peter
  1707. * call set_varstate for setlength
  1708. * ptr returns pointerconstnode instead of ordconstnode
  1709. Revision 1.36 2001/04/13 01:22:09 peter
  1710. * symtable change to classes
  1711. * range check generation and errors fixed, make cycle DEBUG=1 works
  1712. * memory leaks fixed
  1713. Revision 1.35 2001/04/05 21:02:13 peter
  1714. * fixed fpu inline functions typeconvs
  1715. Revision 1.34 2001/04/04 22:42:40 peter
  1716. * move constant folding into det_resulttype
  1717. Revision 1.33 2001/04/04 21:30:43 florian
  1718. * applied several fixes to get the DD8 Delphi Unit compiled
  1719. e.g. "forward"-interfaces are working now
  1720. Revision 1.32 2001/04/02 21:20:31 peter
  1721. * resulttype rewrite
  1722. Revision 1.31 2001/03/23 00:16:07 florian
  1723. + some stuff to compile FreeCLX added
  1724. Revision 1.30 2001/03/12 12:47:46 michael
  1725. + Patches from peter
  1726. Revision 1.29 2001/03/03 12:38:08 jonas
  1727. * fixed low() for signed types < 64bit
  1728. Revision 1.28 2001/02/26 19:44:53 peter
  1729. * merged generic m68k updates from fixes branch
  1730. Revision 1.27 2001/02/22 11:24:40 jonas
  1731. * fixed bug in previous fix (hopped over revision 1.26 because that one
  1732. also removed the fix for high(cardinal))
  1733. Revision 1.26 2001/02/21 20:50:59 peter
  1734. * fix to compile again, but high(cardinal) with $R+ still fails!
  1735. Revision 1.25 2001/02/21 12:57:46 jonas
  1736. * fixed high/low for cardinal, int64 and qword
  1737. Revision 1.24 2001/01/06 19:54:11 peter
  1738. * merged fix for 1310
  1739. Revision 1.23 2001/01/06 18:28:39 peter
  1740. * fixed wrong notes about locals
  1741. Revision 1.22 2000/12/31 11:14:10 jonas
  1742. + implemented/fixed docompare() mathods for all nodes (not tested)
  1743. + nopt.pas, nadd.pas, i386/n386opt.pas: optimized nodes for adding strings
  1744. and constant strings/chars together
  1745. * n386add.pas: don't copy temp strings (of size 256) to another temp string
  1746. when adding
  1747. Revision 1.21 2000/12/25 00:07:26 peter
  1748. + new tlinkedlist class (merge of old tstringqueue,tcontainer and
  1749. tlinkedlist objects)
  1750. Revision 1.20 2000/12/17 14:35:41 peter
  1751. * fixed crash with val()
  1752. Revision 1.19 2000/11/29 00:30:33 florian
  1753. * unused units removed from uses clause
  1754. * some changes for widestrings
  1755. Revision 1.18 2000/11/12 15:27:22 jonas
  1756. * also don't do conversion for chars/booleans (hopefully final change :/)
  1757. Revision 1.17 2000/11/11 21:08:13 jonas
  1758. * don't do inc/dec to add/sub conversion for enums
  1759. Revision 1.16 2000/11/11 16:18:35 peter
  1760. * ptr returns farpointer
  1761. Revision 1.15 2000/11/11 15:59:07 jonas
  1762. * convert inc/dec to add/sub when range/overflow checking is on
  1763. Revision 1.14 2000/11/09 17:46:54 florian
  1764. * System.TypeInfo fixed
  1765. + System.Finalize implemented
  1766. + some new keywords for interface support added
  1767. Revision 1.13 2000/11/04 16:48:32 florian
  1768. * innr.inc renamed to make compiler compilation easier because the rtl contains
  1769. a file of the same name
  1770. Revision 1.12 2000/10/31 22:02:48 peter
  1771. * symtable splitted, no real code changes
  1772. Revision 1.11 2000/10/26 14:15:06 jonas
  1773. * fixed setlength for shortstrings
  1774. Revision 1.10 2000/10/21 18:16:11 florian
  1775. * a lot of changes:
  1776. - basic dyn. array support
  1777. - basic C++ support
  1778. - some work for interfaces done
  1779. ....
  1780. Revision 1.9 2000/10/15 08:38:46 jonas
  1781. * added missing getcopy for previous addition
  1782. Revision 1.8 2000/10/14 18:27:53 jonas
  1783. * merged fix for inc/dec on 64bit types from tcinl
  1784. Revision 1.7 2000/10/14 10:14:50 peter
  1785. * moehrendorf oct 2000 rewrite
  1786. Revision 1.6 2000/10/01 19:48:24 peter
  1787. * lot of compile updates for cg11
  1788. Revision 1.5 2000/09/28 19:49:52 florian
  1789. *** empty log message ***
  1790. Revision 1.4 2000/09/28 16:34:47 florian
  1791. *** empty log message ***
  1792. Revision 1.3 2000/09/27 21:33:22 florian
  1793. * finally nadd.pas compiles
  1794. Revision 1.2 2000/09/27 20:25:44 florian
  1795. * more stuff fixed
  1796. Revision 1.1 2000/09/26 14:59:34 florian
  1797. * more conversion work done
  1798. }