ninl.pas 75 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947
  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. if not iswrite then
  757. make_not_regable(tcallparanode(hpp).left);
  758. hpp:=tcallparanode(hpp).right;
  759. end;
  760. end;
  761. end; { endif assigned(hp) }
  762. { insert type conversions for write(ln) }
  763. if (not file_is_typed) then
  764. begin
  765. hp:=left;
  766. while assigned(hp) do
  767. begin
  768. if (tcallparanode(hp).left.nodetype=typen) then
  769. CGMessage(type_e_cant_read_write_type);
  770. if assigned(tcallparanode(hp).left.resulttype.def) then
  771. begin
  772. isreal:=false;
  773. { support writeln(procvar) }
  774. if (tcallparanode(hp).left.resulttype.def.deftype=procvardef) then
  775. begin
  776. p1:=ccallnode.create(nil,nil,nil,nil);
  777. tcallnode(p1).set_procvar(tcallparanode(hp).left);
  778. resulttypepass(p1);
  779. tcallparanode(hp).left:=p1;
  780. end;
  781. case tcallparanode(hp).left.resulttype.def.deftype of
  782. filedef :
  783. begin
  784. { only allowed as first parameter }
  785. if assigned(tcallparanode(hp).right) then
  786. CGMessage(type_e_cant_read_write_type);
  787. end;
  788. stringdef :
  789. begin
  790. { generate the high() value for the shortstring }
  791. if (not iswrite) and
  792. is_shortstring(tcallparanode(hp).left.resulttype.def) then
  793. tcallparanode(hp).gen_high_tree(true);
  794. end;
  795. pointerdef :
  796. begin
  797. if not is_pchar(tcallparanode(hp).left.resulttype.def) then
  798. CGMessage(type_e_cant_read_write_type);
  799. end;
  800. floatdef :
  801. begin
  802. isreal:=true;
  803. end;
  804. orddef :
  805. begin
  806. case torddef(tcallparanode(hp).left.resulttype.def).typ of
  807. uchar,uwidechar,
  808. u32bit,s32bit,
  809. u64bit,s64bit:
  810. ;
  811. u8bit,s8bit,
  812. u16bit,s16bit :
  813. if iswrite then
  814. inserttypeconv(tcallparanode(hp).left,s32bittype);
  815. bool8bit,
  816. bool16bit,
  817. bool32bit :
  818. if iswrite then
  819. inserttypeconv(tcallparanode(hp).left,booltype)
  820. else
  821. CGMessage(type_e_cant_read_write_type);
  822. else
  823. CGMessage(type_e_cant_read_write_type);
  824. end;
  825. end;
  826. arraydef :
  827. begin
  828. if is_chararray(tcallparanode(hp).left.resulttype.def) then
  829. tcallparanode(hp).gen_high_tree(true)
  830. else
  831. CGMessage(type_e_cant_read_write_type);
  832. end;
  833. else
  834. CGMessage(type_e_cant_read_write_type);
  835. end;
  836. { some format options ? }
  837. if cpf_is_colon_para in tcallparanode(hp).callparaflags then
  838. begin
  839. if cpf_is_colon_para in tcallparanode(tcallparanode(hp).right).callparaflags then
  840. begin
  841. frac_para:=hp;
  842. length_para:=tcallparanode(hp).right;
  843. hp:=tcallparanode(hp).right;
  844. hpp:=tcallparanode(hp).right;
  845. end
  846. else
  847. begin
  848. length_para:=hp;
  849. frac_para:=nil;
  850. hpp:=tcallparanode(hp).right;
  851. end;
  852. { can be nil if you use "write(e:0:6)" while e is undeclared (JM) }
  853. if assigned(tcallparanode(hpp).left.resulttype.def) then
  854. isreal:=(tcallparanode(hpp).left.resulttype.def.deftype=floatdef)
  855. else
  856. exit;
  857. if (not is_integer(tcallparanode(length_para).left.resulttype.def)) then
  858. CGMessage1(type_e_integer_expr_expected,tcallparanode(length_para).left.resulttype.def.typename)
  859. else
  860. inserttypeconv(tcallparanode(length_para).left,s32bittype);
  861. if assigned(frac_para) then
  862. begin
  863. if isreal then
  864. begin
  865. if (not is_integer(tcallparanode(frac_para).left.resulttype.def)) then
  866. CGMessage1(type_e_integer_expr_expected,tcallparanode(frac_para).left.resulttype.def.typename)
  867. else
  868. inserttypeconv(tcallparanode(frac_para).left,s32bittype);
  869. end
  870. else
  871. CGMessage(parser_e_illegal_colon_qualifier);
  872. end;
  873. { do the checking for the colon'd arg }
  874. hp:=length_para;
  875. end;
  876. end;
  877. hp:=tcallparanode(hp).right;
  878. end;
  879. end;
  880. if codegenerror then
  881. exit;
  882. set_varstate(left,true);
  883. end;
  884. end;
  885. in_settextbuf_file_x :
  886. begin
  887. resulttype:=voidtype;
  888. { now we know the type of buffer }
  889. srsym:=searchsymonlyin(systemunit,'SETTEXTBUF');
  890. hp:=ccallparanode.create(cordconstnode.create(tcallparanode(left).left.resulttype.def.size,s32bittype),left);
  891. hp:=ccallnode.create(hp,tprocsym(srsym),systemunit,nil);
  892. left:=nil;
  893. resulttypepass(hp);
  894. result:=hp;
  895. end;
  896. { the firstpass of the arg has been done in firstcalln ? }
  897. in_reset_typedfile,
  898. in_rewrite_typedfile :
  899. begin
  900. set_varstate(left,true);
  901. resulttype:=voidtype;
  902. end;
  903. in_str_x_string :
  904. begin
  905. resulttype:=voidtype;
  906. set_varstate(left,false);
  907. { remove warning when result is passed }
  908. set_funcret_is_valid(tcallparanode(left).left);
  909. set_varstate(tcallparanode(tcallparanode(left).right).left,true);
  910. hp:=left;
  911. { valid string ? }
  912. if not assigned(hp) or
  913. (tcallparanode(hp).left.resulttype.def.deftype<>stringdef) or
  914. (tcallparanode(hp).right=nil) then
  915. CGMessage(cg_e_illegal_expression);
  916. { we need a var parameter }
  917. valid_for_var(tcallparanode(hp).left);
  918. { generate the high() value for the shortstring }
  919. if is_shortstring(tcallparanode(hp).left.resulttype.def) then
  920. tcallparanode(hp).gen_high_tree(true);
  921. { !!!! check length of string }
  922. while assigned(tcallparanode(hp).right) do
  923. hp:=tcallparanode(hp).right;
  924. if not assigned(tcallparanode(hp).resulttype.def) then
  925. exit;
  926. { check and convert the first param }
  927. if (cpf_is_colon_para in tcallparanode(hp).callparaflags) or
  928. not assigned(hp.resulttype.def) then
  929. CGMessage(cg_e_illegal_expression);
  930. isreal:=false;
  931. case hp.resulttype.def.deftype of
  932. orddef :
  933. begin
  934. case torddef(tcallparanode(hp).left.resulttype.def).typ of
  935. u32bit,s32bit,
  936. s64bit,u64bit:
  937. ;
  938. u8bit,s8bit,
  939. u16bit,s16bit:
  940. inserttypeconv(tcallparanode(hp).left,s32bittype);
  941. else
  942. CGMessage(type_e_integer_or_real_expr_expected);
  943. end;
  944. end;
  945. floatdef :
  946. begin
  947. isreal:=true;
  948. end;
  949. else
  950. CGMessage(type_e_integer_or_real_expr_expected);
  951. end;
  952. { some format options ? }
  953. hpp:=tcallparanode(left).right;
  954. if assigned(hpp) and (cpf_is_colon_para in tcallparanode(hpp).callparaflags) then
  955. begin
  956. set_varstate(tcallparanode(hpp).left,true);
  957. if (not is_integer(tcallparanode(hpp).left.resulttype.def)) then
  958. CGMessage1(type_e_integer_expr_expected,tcallparanode(hpp).left.resulttype.def.typename)
  959. else
  960. inserttypeconv(tcallparanode(hpp).left,s32bittype);
  961. hpp:=tcallparanode(hpp).right;
  962. if assigned(hpp) and (cpf_is_colon_para in tcallparanode(hpp).callparaflags) then
  963. begin
  964. if isreal then
  965. begin
  966. if (not is_integer(tcallparanode(hpp).left.resulttype.def)) then
  967. CGMessage1(type_e_integer_expr_expected,tcallparanode(hpp).left.resulttype.def.typename)
  968. else
  969. begin
  970. set_varstate(tcallparanode(hpp).left,true);
  971. inserttypeconv(tcallparanode(hpp).left,s32bittype);
  972. end;
  973. end
  974. else
  975. CGMessage(parser_e_illegal_colon_qualifier);
  976. end;
  977. end;
  978. end;
  979. in_val_x :
  980. begin
  981. resulttype:=voidtype;
  982. { check the amount of parameters }
  983. if not(assigned(left)) or
  984. not(assigned(tcallparanode(left).right)) then
  985. begin
  986. CGMessage(parser_e_wrong_parameter_size);
  987. exit;
  988. end;
  989. { there is a "code" parameter }
  990. If Assigned(tcallparanode(tcallparanode(left).right).right) Then
  991. Begin
  992. { first pass just the code parameter for first local use}
  993. hp := tcallparanode(left).right;
  994. tcallparanode(left).right := nil;
  995. make_not_regable(tcallparanode(left).left);
  996. set_varstate(left,false);
  997. if codegenerror then
  998. exit;
  999. tcallparanode(left).right := hp;
  1000. { code has to be a var parameter }
  1001. if valid_for_var(tcallparanode(left).left) then
  1002. begin
  1003. if (tcallparanode(left).left.resulttype.def.deftype <> orddef) or
  1004. not(torddef(tcallparanode(left).left.resulttype.def).typ in [u16bit,s16bit,u32bit,s32bit]) then
  1005. CGMessage(type_e_mismatch);
  1006. end;
  1007. hpp := tcallparanode(left).right
  1008. End
  1009. Else
  1010. hpp := left;
  1011. { now hpp = the destination value tree }
  1012. { first pass just the destination parameter for first local use }
  1013. hp:=tcallparanode(hpp).right;
  1014. tcallparanode(hpp).right:=nil;
  1015. { hpp = destination }
  1016. make_not_regable(tcallparanode(hpp).left);
  1017. set_varstate(hpp,false);
  1018. if codegenerror then
  1019. exit;
  1020. { remove warning when result is passed }
  1021. set_funcret_is_valid(tcallparanode(hpp).left);
  1022. tcallparanode(hpp).right := hp;
  1023. if valid_for_var(tcallparanode(hpp).left) then
  1024. begin
  1025. If Not((tcallparanode(hpp).left.resulttype.def.deftype = floatdef) or
  1026. is_integer(tcallparanode(hpp).left.resulttype.def)) then
  1027. CGMessage(type_e_mismatch);
  1028. end;
  1029. { hp = source (String) }
  1030. { if not a stringdef then insert a type conv which
  1031. does the other type checking }
  1032. If (tcallparanode(hp).left.resulttype.def.deftype<>stringdef) then
  1033. inserttypeconv(tcallparanode(hp).left,cshortstringtype);
  1034. set_varstate(hp,true);
  1035. end;
  1036. in_include_x_y,
  1037. in_exclude_x_y:
  1038. begin
  1039. resulttype:=voidtype;
  1040. if assigned(left) then
  1041. begin
  1042. set_varstate(left,true);
  1043. { remove warning when result is passed }
  1044. set_funcret_is_valid(tcallparanode(left).left);
  1045. { first param must be var }
  1046. valid_for_var(tcallparanode(left).left);
  1047. { check type }
  1048. if assigned(left.resulttype.def) and
  1049. (left.resulttype.def.deftype=setdef) then
  1050. begin
  1051. { two paras ? }
  1052. if assigned(tcallparanode(left).right) then
  1053. begin
  1054. { insert a type conversion }
  1055. { to the type of the set elements }
  1056. inserttypeconv(tcallparanode(tcallparanode(left).right).left,
  1057. tsetdef(left.resulttype.def).elementtype);
  1058. { only three parameters are allowed }
  1059. if assigned(tcallparanode(tcallparanode(left).right).right) then
  1060. CGMessage(cg_e_illegal_expression);
  1061. end;
  1062. end
  1063. else
  1064. CGMessage(type_e_mismatch);
  1065. end
  1066. else
  1067. CGMessage(type_e_mismatch);
  1068. end;
  1069. in_low_x,
  1070. in_high_x:
  1071. begin
  1072. set_varstate(left,false);
  1073. case left.resulttype.def.deftype of
  1074. orddef,
  1075. enumdef:
  1076. begin
  1077. hp:=do_lowhigh(left.resulttype);
  1078. resulttypepass(hp);
  1079. result:=hp;
  1080. end;
  1081. setdef:
  1082. begin
  1083. hp:=do_lowhigh(tsetdef(left.resulttype.def).elementtype);
  1084. resulttypepass(hp);
  1085. result:=hp;
  1086. end;
  1087. arraydef:
  1088. begin
  1089. if inlinenumber=in_low_x then
  1090. begin
  1091. hp:=cordconstnode.create(tarraydef(left.resulttype.def).lowrange,tarraydef(left.resulttype.def).rangetype);
  1092. resulttypepass(hp);
  1093. result:=hp;
  1094. end
  1095. else
  1096. begin
  1097. if is_open_array(left.resulttype.def) or
  1098. is_array_of_const(left.resulttype.def) then
  1099. begin
  1100. srsym:=searchsymonlyin(tloadnode(left).symtable,'high'+tvarsym(tloadnode(left).symtableentry).name);
  1101. hp:=cloadnode.create(tvarsym(srsym),tloadnode(left).symtable);
  1102. resulttypepass(hp);
  1103. result:=hp;
  1104. end
  1105. else
  1106. if is_dynamic_array(left.resulttype.def) then
  1107. begin
  1108. {
  1109. Doesn't work because that procedure isn't in
  1110. the interface of the system unit :( (JM)
  1111. srsym:=searchsymonlyin(systemunit,'FPC_DYNARRAY_HIGH');
  1112. if not assigned(srsym) then
  1113. internalerror(200104291);
  1114. inserttypeconv(left,voidpointertype);
  1115. hp:=ccallparanode.create(left,nil);
  1116. hp:=ccallnode.create(hp,tprocsym(srsym),systemunit,nil);
  1117. left:=nil;
  1118. resulttypepass(hp);
  1119. result:=hp;}
  1120. {$warning "high(dynamic_array)" isn't implemented yet }
  1121. end
  1122. else
  1123. begin
  1124. hp:=cordconstnode.create(tarraydef(left.resulttype.def).highrange,tarraydef(left.resulttype.def).rangetype);
  1125. resulttypepass(hp);
  1126. result:=hp;
  1127. end;
  1128. end;
  1129. end;
  1130. stringdef:
  1131. begin
  1132. if inlinenumber=in_low_x then
  1133. begin
  1134. hp:=cordconstnode.create(0,u8bittype);
  1135. resulttypepass(hp);
  1136. result:=hp;
  1137. end
  1138. else
  1139. begin
  1140. if is_open_string(left.resulttype.def) then
  1141. begin
  1142. srsym:=searchsymonlyin(tloadnode(left).symtable,'high'+tvarsym(tloadnode(left).symtableentry).name);
  1143. hp:=cloadnode.create(tvarsym(srsym),tloadnode(left).symtable);
  1144. resulttypepass(hp);
  1145. result:=hp;
  1146. end
  1147. else
  1148. begin
  1149. hp:=cordconstnode.create(tstringdef(left.resulttype.def).len,u8bittype);
  1150. resulttypepass(hp);
  1151. result:=hp;
  1152. end;
  1153. end;
  1154. end;
  1155. else
  1156. CGMessage(type_e_mismatch);
  1157. end;
  1158. end;
  1159. in_pi:
  1160. begin
  1161. if block_type=bt_const then
  1162. setconstrealvalue(pi)
  1163. else
  1164. resulttype:=s80floattype;
  1165. end;
  1166. in_cos_extended :
  1167. begin
  1168. if left.nodetype in [ordconstn,realconstn] then
  1169. setconstrealvalue(cos(getconstrealvalue))
  1170. else
  1171. begin
  1172. set_varstate(left,true);
  1173. inserttypeconv(left,s80floattype);
  1174. resulttype:=s80floattype;
  1175. end;
  1176. end;
  1177. in_sin_extended :
  1178. begin
  1179. if left.nodetype in [ordconstn,realconstn] then
  1180. setconstrealvalue(sin(getconstrealvalue))
  1181. else
  1182. begin
  1183. set_varstate(left,true);
  1184. inserttypeconv(left,s80floattype);
  1185. resulttype:=s80floattype;
  1186. end;
  1187. end;
  1188. in_arctan_extended :
  1189. begin
  1190. if left.nodetype in [ordconstn,realconstn] then
  1191. setconstrealvalue(arctan(getconstrealvalue))
  1192. else
  1193. begin
  1194. set_varstate(left,true);
  1195. inserttypeconv(left,s80floattype);
  1196. resulttype:=s80floattype;
  1197. end;
  1198. end;
  1199. in_abs_extended :
  1200. begin
  1201. if left.nodetype in [ordconstn,realconstn] then
  1202. setconstrealvalue(abs(getconstrealvalue))
  1203. else
  1204. begin
  1205. set_varstate(left,true);
  1206. inserttypeconv(left,s80floattype);
  1207. resulttype:=s80floattype;
  1208. end;
  1209. end;
  1210. in_sqr_extended :
  1211. begin
  1212. if left.nodetype in [ordconstn,realconstn] then
  1213. setconstrealvalue(sqr(getconstrealvalue))
  1214. else
  1215. begin
  1216. set_varstate(left,true);
  1217. inserttypeconv(left,s80floattype);
  1218. resulttype:=s80floattype;
  1219. end;
  1220. end;
  1221. in_sqrt_extended :
  1222. begin
  1223. if left.nodetype in [ordconstn,realconstn] then
  1224. begin
  1225. vr:=getconstrealvalue;
  1226. if vr<0.0 then
  1227. begin
  1228. CGMessage(type_e_wrong_math_argument);
  1229. setconstrealvalue(0);
  1230. end
  1231. else
  1232. setconstrealvalue(sqrt(vr));
  1233. end
  1234. else
  1235. begin
  1236. set_varstate(left,true);
  1237. inserttypeconv(left,s80floattype);
  1238. resulttype:=s80floattype;
  1239. end;
  1240. end;
  1241. in_ln_extended :
  1242. begin
  1243. if left.nodetype in [ordconstn,realconstn] then
  1244. begin
  1245. vr:=getconstrealvalue;
  1246. if vr<=0.0 then
  1247. begin
  1248. CGMessage(type_e_wrong_math_argument);
  1249. setconstrealvalue(0);
  1250. end
  1251. else
  1252. setconstrealvalue(ln(vr));
  1253. end
  1254. else
  1255. begin
  1256. set_varstate(left,true);
  1257. inserttypeconv(left,s80floattype);
  1258. resulttype:=s80floattype;
  1259. end;
  1260. end;
  1261. {$ifdef SUPPORT_MMX}
  1262. in_mmx_pcmpeqb..in_mmx_pcmpgtw:
  1263. begin
  1264. end;
  1265. {$endif SUPPORT_MMX}
  1266. in_assert_x_y :
  1267. begin
  1268. resulttype:=voidtype;
  1269. if assigned(left) then
  1270. begin
  1271. set_varstate(left,true);
  1272. { check type }
  1273. if is_boolean(left.resulttype.def) then
  1274. begin
  1275. { must always be a string }
  1276. inserttypeconv(tcallparanode(tcallparanode(left).right).left,cshortstringtype);
  1277. end
  1278. else
  1279. CGMessage(type_e_mismatch);
  1280. end
  1281. else
  1282. CGMessage(type_e_mismatch);
  1283. end;
  1284. else
  1285. internalerror(8);
  1286. end;
  1287. end;
  1288. myexit:
  1289. { Run get_paratype again to update maybe inserted typeconvs }
  1290. if not codegenerror then
  1291. begin
  1292. if assigned(left) and
  1293. (left.nodetype=callparan) then
  1294. tcallparanode(left).get_paratype;
  1295. end;
  1296. dec(parsing_para_level);
  1297. end;
  1298. {$ifdef fpc}
  1299. {$maxfpuregisters 0}
  1300. {$endif fpc}
  1301. function tinlinenode.pass_1 : tnode;
  1302. var
  1303. srsym : tsym;
  1304. hp,hpp : tnode;
  1305. extra_register,
  1306. iswrite,
  1307. file_is_typed : boolean;
  1308. begin
  1309. result:=nil;
  1310. { if we handle writeln; left contains no valid address }
  1311. if assigned(left) then
  1312. begin
  1313. if left.nodetype=callparan then
  1314. tcallparanode(left).firstcallparan(nil,false)
  1315. else
  1316. firstpass(left);
  1317. left_max;
  1318. set_location(location,left.location);
  1319. end;
  1320. inc(parsing_para_level);
  1321. { intern const should already be handled }
  1322. if nf_inlineconst in flags then
  1323. internalerror(200104044);
  1324. case inlinenumber of
  1325. in_lo_qword,
  1326. in_hi_qword,
  1327. in_lo_long,
  1328. in_hi_long,
  1329. in_lo_word,
  1330. in_hi_word:
  1331. begin
  1332. if registers32<1 then
  1333. registers32:=1;
  1334. location.loc:=LOC_REGISTER;
  1335. end;
  1336. in_sizeof_x:
  1337. begin
  1338. if push_high_param(left.resulttype.def) then
  1339. begin
  1340. srsym:=searchsymonlyin(tloadnode(left).symtable,'high'+tvarsym(tloadnode(left).symtableentry).name);
  1341. hp:=caddnode.create(addn,cloadnode.create(tvarsym(srsym),tloadnode(left).symtable),
  1342. cordconstnode.create(1,s32bittype));
  1343. if (left.resulttype.def.deftype=arraydef) and
  1344. (tarraydef(left.resulttype.def).elesize<>1) then
  1345. hp:=caddnode.create(muln,hp,cordconstnode.create(tarraydef(left.resulttype.def).elesize,s32bittype));
  1346. firstpass(hp);
  1347. result:=hp;
  1348. end
  1349. else
  1350. begin
  1351. if registers32<1 then
  1352. registers32:=1;
  1353. location.loc:=LOC_REGISTER;
  1354. end;
  1355. end;
  1356. in_typeof_x:
  1357. begin
  1358. if registers32<1 then
  1359. registers32:=1;
  1360. location.loc:=LOC_REGISTER;
  1361. end;
  1362. in_ord_x,
  1363. in_chr_byte:
  1364. begin
  1365. { should not happend as it's converted to typeconv }
  1366. internalerror(200104045);
  1367. end;
  1368. in_length_x:
  1369. begin
  1370. if is_shortstring(left.resulttype.def) then
  1371. location.loc:=LOC_REFERENCE
  1372. else
  1373. begin
  1374. { ansi/wide string }
  1375. if registers32<1 then
  1376. registers32:=1;
  1377. location.loc:=LOC_REGISTER;
  1378. end;
  1379. end;
  1380. in_typeinfo_x:
  1381. begin
  1382. location.loc:=LOC_REGISTER;
  1383. registers32:=1;
  1384. end;
  1385. in_assigned_x:
  1386. begin
  1387. location.loc:=LOC_FLAGS;
  1388. end;
  1389. in_ofs_x :
  1390. internalerror(2000101001);
  1391. in_seg_x :
  1392. internalerror(200104046);
  1393. in_pred_x,
  1394. in_succ_x:
  1395. begin
  1396. if is_64bitint(resulttype.def) then
  1397. begin
  1398. if (registers32<2) then
  1399. registers32:=2
  1400. end
  1401. else
  1402. begin
  1403. if (registers32<1) then
  1404. registers32:=1;
  1405. end;
  1406. location.loc:=LOC_REGISTER;
  1407. end;
  1408. in_setlength_x:
  1409. begin
  1410. end;
  1411. in_finalize_x:
  1412. begin
  1413. end;
  1414. in_inc_x,
  1415. in_dec_x:
  1416. begin
  1417. { check type }
  1418. if is_64bitint(left.resulttype.def) or
  1419. { range/overflow checking doesn't work properly }
  1420. { with the inc/dec code that's generated (JM) }
  1421. ((left.resulttype.def.deftype = orddef) and
  1422. not(is_char(left.resulttype.def)) and
  1423. not(is_boolean(left.resulttype.def)) and
  1424. (aktlocalswitches *
  1425. [cs_check_overflow,cs_check_range] <> [])) then
  1426. { convert to simple add (JM) }
  1427. begin
  1428. { extra parameter? }
  1429. if assigned(tcallparanode(left).right) then
  1430. begin
  1431. { Yes, use for add node }
  1432. hpp := tcallparanode(tcallparanode(left).right).left;
  1433. tcallparanode(tcallparanode(left).right).left := nil;
  1434. if assigned(tcallparanode(tcallparanode(left).right).right) then
  1435. CGMessage(cg_e_illegal_expression);
  1436. end
  1437. else
  1438. { no, create constant 1 }
  1439. hpp := cordconstnode.create(1,s32bittype);
  1440. { addition/substraction depending on inc/dec }
  1441. if inlinenumber = in_inc_x then
  1442. hp := caddnode.create(addn,tcallparanode(left).left.getcopy,hpp)
  1443. else
  1444. hp := caddnode.create(subn,tcallparanode(left).left.getcopy,hpp);
  1445. { assign result of addition }
  1446. hpp := cassignmentnode.create(tcallparanode(left).left,hp);
  1447. tcallparanode(left).left := nil;
  1448. { firstpass it }
  1449. firstpass(hpp);
  1450. { return new node }
  1451. result := hpp;
  1452. end
  1453. else if (left.resulttype.def.deftype in [enumdef,pointerdef]) or
  1454. is_ordinal(left.resulttype.def) then
  1455. begin
  1456. { two paras ? }
  1457. if assigned(tcallparanode(left).right) then
  1458. begin
  1459. { need we an additional register ? }
  1460. if not(is_constintnode(tcallparanode(tcallparanode(left).right).left)) and
  1461. (tcallparanode(tcallparanode(left).right).left.location.loc in [LOC_MEM,LOC_REFERENCE]) and
  1462. (tcallparanode(tcallparanode(left).right).left.registers32<=1) then
  1463. inc(registers32);
  1464. { do we need an additional register to restore the first parameter? }
  1465. if tcallparanode(tcallparanode(left).right).left.registers32>=registers32 then
  1466. inc(registers32);
  1467. end;
  1468. end;
  1469. end;
  1470. in_read_x,
  1471. in_readln_x,
  1472. in_write_x,
  1473. in_writeln_x :
  1474. begin
  1475. { needs a call }
  1476. procinfo^.flags:=procinfo^.flags or pi_do_call;
  1477. { true, if readln needs an extra register }
  1478. extra_register:=false;
  1479. { we must know if it is a typed file or not }
  1480. { but we must first do the firstpass for it }
  1481. file_is_typed:=false;
  1482. if assigned(left) then
  1483. begin
  1484. iswrite:=(inlinenumber in [in_write_x,in_writeln_x]);
  1485. { now we can check }
  1486. hp:=left;
  1487. while assigned(tcallparanode(hp).right) do
  1488. hp:=tcallparanode(hp).right;
  1489. { if resulttype.def is not assigned, then automatically }
  1490. { file is not typed. }
  1491. if assigned(hp) then
  1492. Begin
  1493. if (hp.resulttype.def.deftype=filedef) and
  1494. (tfiledef(hp.resulttype.def).filetyp=ft_typed) then
  1495. file_is_typed:=true;
  1496. end; { endif assigned(hp) }
  1497. if (not file_is_typed) then
  1498. begin
  1499. hp:=left;
  1500. while assigned(hp) do
  1501. begin
  1502. {$ifdef i386}
  1503. incrementregisterpushed($ff);
  1504. {$else}
  1505. incrementregisterpushed(ALL_REGISTERS);
  1506. {$endif}
  1507. if assigned(tcallparanode(hp).left.resulttype.def) then
  1508. begin
  1509. case tcallparanode(hp).left.resulttype.def.deftype of
  1510. orddef :
  1511. begin
  1512. if not(iswrite) and
  1513. not(is_64bitint(tcallparanode(hp).left.resulttype.def)) then
  1514. extra_register:=true;
  1515. end;
  1516. end;
  1517. end;
  1518. hp:=tcallparanode(hp).right;
  1519. end;
  1520. end;
  1521. { calc registers }
  1522. left_max;
  1523. if extra_register then
  1524. inc(registers32);
  1525. end;
  1526. end;
  1527. in_settextbuf_file_x :
  1528. internalerror(200104262);
  1529. in_reset_typedfile,
  1530. in_rewrite_typedfile :
  1531. begin
  1532. procinfo^.flags:=procinfo^.flags or pi_do_call;
  1533. end;
  1534. in_str_x_string :
  1535. begin
  1536. procinfo^.flags:=procinfo^.flags or pi_do_call;
  1537. { calc registers }
  1538. left_max;
  1539. end;
  1540. in_val_x :
  1541. begin
  1542. procinfo^.flags:=procinfo^.flags or pi_do_call;
  1543. { calc registers }
  1544. left_max;
  1545. { val doesn't calculate the registers really }
  1546. { correct, we need one register extra (FK) }
  1547. { there is a "code" parameter }
  1548. If Assigned(tcallparanode(tcallparanode(left).right).right) Then
  1549. hpp := tcallparanode(left).right
  1550. Else
  1551. hpp := left;
  1552. { now hpp = the destination value tree }
  1553. if is_64bitint(tcallparanode(hpp).left.resulttype.def) then
  1554. inc(registers32,2)
  1555. else
  1556. inc(registers32,1);
  1557. end;
  1558. in_include_x_y,
  1559. in_exclude_x_y:
  1560. begin
  1561. registers32:=left.registers32;
  1562. registersfpu:=left.registersfpu;
  1563. {$ifdef SUPPORT_MMX}
  1564. registersmmx:=left.registersmmx;
  1565. {$endif SUPPORT_MMX}
  1566. end;
  1567. in_low_x,
  1568. in_high_x:
  1569. internalerror(200104047);
  1570. in_cos_extended:
  1571. begin
  1572. location.loc:=LOC_FPU;
  1573. registers32:=left.registers32;
  1574. registersfpu:=left.registersfpu;
  1575. {$ifdef SUPPORT_MMX}
  1576. registersmmx:=left.registersmmx;
  1577. {$endif SUPPORT_MMX}
  1578. end;
  1579. in_sin_extended:
  1580. begin
  1581. location.loc:=LOC_FPU;
  1582. registers32:=left.registers32;
  1583. registersfpu:=left.registersfpu;
  1584. {$ifdef SUPPORT_MMX}
  1585. registersmmx:=left.registersmmx;
  1586. {$endif SUPPORT_MMX}
  1587. end;
  1588. in_arctan_extended:
  1589. begin
  1590. location.loc:=LOC_FPU;
  1591. registers32:=left.registers32;
  1592. registersfpu:=left.registersfpu;
  1593. {$ifdef SUPPORT_MMX}
  1594. registersmmx:=left.registersmmx;
  1595. {$endif SUPPORT_MMX}
  1596. end;
  1597. in_pi:
  1598. begin
  1599. location.loc:=LOC_FPU;
  1600. end;
  1601. in_abs_extended:
  1602. begin
  1603. location.loc:=LOC_FPU;
  1604. registers32:=left.registers32;
  1605. registersfpu:=left.registersfpu;
  1606. {$ifdef SUPPORT_MMX}
  1607. registersmmx:=left.registersmmx;
  1608. {$endif SUPPORT_MMX}
  1609. end;
  1610. in_sqr_extended:
  1611. begin
  1612. location.loc:=LOC_FPU;
  1613. registers32:=left.registers32;
  1614. registersfpu:=left.registersfpu;
  1615. {$ifdef SUPPORT_MMX}
  1616. registersmmx:=left.registersmmx;
  1617. {$endif SUPPORT_MMX}
  1618. end;
  1619. in_sqrt_extended:
  1620. begin
  1621. location.loc:=LOC_FPU;
  1622. registers32:=left.registers32;
  1623. registersfpu:=left.registersfpu;
  1624. {$ifdef SUPPORT_MMX}
  1625. registersmmx:=left.registersmmx;
  1626. {$endif SUPPORT_MMX}
  1627. end;
  1628. in_ln_extended:
  1629. begin
  1630. location.loc:=LOC_FPU;
  1631. registers32:=left.registers32;
  1632. registersfpu:=left.registersfpu;
  1633. {$ifdef SUPPORT_MMX}
  1634. registersmmx:=left.registersmmx;
  1635. {$endif SUPPORT_MMX}
  1636. end;
  1637. {$ifdef SUPPORT_MMX}
  1638. in_mmx_pcmpeqb..in_mmx_pcmpgtw:
  1639. begin
  1640. end;
  1641. {$endif SUPPORT_MMX}
  1642. in_assert_x_y :
  1643. begin
  1644. { We've checked the whole statement for correctness, now we
  1645. can remove it if assertions are off }
  1646. if not(cs_do_assertion in aktlocalswitches) then
  1647. begin
  1648. { we need a valid node, so insert a nothingn }
  1649. result:=cnothingnode.create;
  1650. end
  1651. else
  1652. begin
  1653. registers32:=left.registers32;
  1654. registersfpu:=left.registersfpu;
  1655. {$ifdef SUPPORT_MMX}
  1656. registersmmx:=left.registersmmx;
  1657. {$endif SUPPORT_MMX}
  1658. end;
  1659. end;
  1660. else
  1661. internalerror(8);
  1662. end;
  1663. dec(parsing_para_level);
  1664. end;
  1665. {$ifdef fpc}
  1666. {$maxfpuregisters default}
  1667. {$endif fpc}
  1668. function tinlinenode.docompare(p: tnode): boolean;
  1669. begin
  1670. docompare :=
  1671. inherited docompare(p) and
  1672. (inlinenumber = tinlinenode(p).inlinenumber);
  1673. end;
  1674. begin
  1675. cinlinenode:=tinlinenode;
  1676. end.
  1677. {
  1678. $Log$
  1679. Revision 1.44 2001-07-09 21:15:40 peter
  1680. * Length made internal
  1681. * Add array support for Length
  1682. Revision 1.43 2001/07/08 21:00:15 peter
  1683. * various widestring updates, it works now mostly without charset
  1684. mapping supported
  1685. Revision 1.42 2001/06/04 11:48:01 peter
  1686. * better const to var checking
  1687. Revision 1.41 2001/06/03 20:12:53 peter
  1688. * changed int64($ffffffff) that is buggy under 1.0.x to expression
  1689. with a shl
  1690. Revision 1.40 2001/05/06 17:16:43 jonas
  1691. + added warning about missing implementation for high(dynamic_array)
  1692. Revision 1.39 2001/04/26 21:57:05 peter
  1693. * moved code from firstpass to det_resulttype and remove extraneous
  1694. calls to firstcallparan for in_str,in_write,in_val
  1695. Revision 1.38 2001/04/21 12:03:11 peter
  1696. * m68k updates merged from fixes branch
  1697. Revision 1.37 2001/04/13 22:22:30 peter
  1698. * call set_varstate for setlength
  1699. * ptr returns pointerconstnode instead of ordconstnode
  1700. Revision 1.36 2001/04/13 01:22:09 peter
  1701. * symtable change to classes
  1702. * range check generation and errors fixed, make cycle DEBUG=1 works
  1703. * memory leaks fixed
  1704. Revision 1.35 2001/04/05 21:02:13 peter
  1705. * fixed fpu inline functions typeconvs
  1706. Revision 1.34 2001/04/04 22:42:40 peter
  1707. * move constant folding into det_resulttype
  1708. Revision 1.33 2001/04/04 21:30:43 florian
  1709. * applied several fixes to get the DD8 Delphi Unit compiled
  1710. e.g. "forward"-interfaces are working now
  1711. Revision 1.32 2001/04/02 21:20:31 peter
  1712. * resulttype rewrite
  1713. Revision 1.31 2001/03/23 00:16:07 florian
  1714. + some stuff to compile FreeCLX added
  1715. Revision 1.30 2001/03/12 12:47:46 michael
  1716. + Patches from peter
  1717. Revision 1.29 2001/03/03 12:38:08 jonas
  1718. * fixed low() for signed types < 64bit
  1719. Revision 1.28 2001/02/26 19:44:53 peter
  1720. * merged generic m68k updates from fixes branch
  1721. Revision 1.27 2001/02/22 11:24:40 jonas
  1722. * fixed bug in previous fix (hopped over revision 1.26 because that one
  1723. also removed the fix for high(cardinal))
  1724. Revision 1.26 2001/02/21 20:50:59 peter
  1725. * fix to compile again, but high(cardinal) with $R+ still fails!
  1726. Revision 1.25 2001/02/21 12:57:46 jonas
  1727. * fixed high/low for cardinal, int64 and qword
  1728. Revision 1.24 2001/01/06 19:54:11 peter
  1729. * merged fix for 1310
  1730. Revision 1.23 2001/01/06 18:28:39 peter
  1731. * fixed wrong notes about locals
  1732. Revision 1.22 2000/12/31 11:14:10 jonas
  1733. + implemented/fixed docompare() mathods for all nodes (not tested)
  1734. + nopt.pas, nadd.pas, i386/n386opt.pas: optimized nodes for adding strings
  1735. and constant strings/chars together
  1736. * n386add.pas: don't copy temp strings (of size 256) to another temp string
  1737. when adding
  1738. Revision 1.21 2000/12/25 00:07:26 peter
  1739. + new tlinkedlist class (merge of old tstringqueue,tcontainer and
  1740. tlinkedlist objects)
  1741. Revision 1.20 2000/12/17 14:35:41 peter
  1742. * fixed crash with val()
  1743. Revision 1.19 2000/11/29 00:30:33 florian
  1744. * unused units removed from uses clause
  1745. * some changes for widestrings
  1746. Revision 1.18 2000/11/12 15:27:22 jonas
  1747. * also don't do conversion for chars/booleans (hopefully final change :/)
  1748. Revision 1.17 2000/11/11 21:08:13 jonas
  1749. * don't do inc/dec to add/sub conversion for enums
  1750. Revision 1.16 2000/11/11 16:18:35 peter
  1751. * ptr returns farpointer
  1752. Revision 1.15 2000/11/11 15:59:07 jonas
  1753. * convert inc/dec to add/sub when range/overflow checking is on
  1754. Revision 1.14 2000/11/09 17:46:54 florian
  1755. * System.TypeInfo fixed
  1756. + System.Finalize implemented
  1757. + some new keywords for interface support added
  1758. Revision 1.13 2000/11/04 16:48:32 florian
  1759. * innr.inc renamed to make compiler compilation easier because the rtl contains
  1760. a file of the same name
  1761. Revision 1.12 2000/10/31 22:02:48 peter
  1762. * symtable splitted, no real code changes
  1763. Revision 1.11 2000/10/26 14:15:06 jonas
  1764. * fixed setlength for shortstrings
  1765. Revision 1.10 2000/10/21 18:16:11 florian
  1766. * a lot of changes:
  1767. - basic dyn. array support
  1768. - basic C++ support
  1769. - some work for interfaces done
  1770. ....
  1771. Revision 1.9 2000/10/15 08:38:46 jonas
  1772. * added missing getcopy for previous addition
  1773. Revision 1.8 2000/10/14 18:27:53 jonas
  1774. * merged fix for inc/dec on 64bit types from tcinl
  1775. Revision 1.7 2000/10/14 10:14:50 peter
  1776. * moehrendorf oct 2000 rewrite
  1777. Revision 1.6 2000/10/01 19:48:24 peter
  1778. * lot of compile updates for cg11
  1779. Revision 1.5 2000/09/28 19:49:52 florian
  1780. *** empty log message ***
  1781. Revision 1.4 2000/09/28 16:34:47 florian
  1782. *** empty log message ***
  1783. Revision 1.3 2000/09/27 21:33:22 florian
  1784. * finally nadd.pas compiles
  1785. Revision 1.2 2000/09/27 20:25:44 florian
  1786. * more stuff fixed
  1787. Revision 1.1 2000/09/26 14:59:34 florian
  1788. * more conversion work done
  1789. }