tcinl.pas 44 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027
  1. {
  2. $Id$
  3. Copyright (c) 1993-98 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 tcinl;
  19. interface
  20. uses
  21. tree;
  22. procedure firstinline(var p : ptree);
  23. implementation
  24. uses
  25. cobjects,verbose,globals,systems,
  26. symtable,aasm,types,
  27. hcodegen,htypechk,pass_1,
  28. tccal,tcld
  29. {$ifdef i386}
  30. ,i386,tgeni386
  31. {$endif}
  32. {$ifdef m68k}
  33. ,m68k,tgen68k
  34. {$endif}
  35. ;
  36. {*****************************************************************************
  37. FirstInLine
  38. *****************************************************************************}
  39. procedure firstinline(var p : ptree);
  40. var
  41. vl,vl2 : longint;
  42. vr : bestreal;
  43. hp,hpp : ptree;
  44. {$ifndef NOCOLONCHECK}
  45. frac_para,length_para : ptree;
  46. {$endif ndef NOCOLONCHECK}
  47. store_count_ref,
  48. isreal,
  49. dowrite,
  50. store_valid,
  51. file_is_typed : boolean;
  52. procedure do_lowhigh(adef : pdef);
  53. var
  54. v : longint;
  55. enum : penumsym;
  56. begin
  57. case Adef^.deftype of
  58. orddef:
  59. begin
  60. if p^.inlinenumber=in_low_x then
  61. v:=porddef(Adef)^.low
  62. else
  63. v:=porddef(Adef)^.high;
  64. hp:=genordinalconstnode(v,adef);
  65. firstpass(hp);
  66. disposetree(p);
  67. p:=hp;
  68. end;
  69. enumdef:
  70. begin
  71. enum:=Penumdef(Adef)^.first;
  72. if p^.inlinenumber=in_high_x then
  73. while enum^.next<>nil do
  74. enum:=enum^.next;
  75. hp:=genenumnode(enum);
  76. disposetree(p);
  77. p:=hp;
  78. end
  79. end;
  80. end;
  81. begin
  82. store_valid:=must_be_valid;
  83. store_count_ref:=count_ref;
  84. count_ref:=false;
  85. if not (p^.inlinenumber in [in_read_x,in_readln_x,in_sizeof_x,
  86. in_typeof_x,in_ord_x,in_str_x_string,
  87. in_reset_typedfile,in_rewrite_typedfile]) then
  88. must_be_valid:=true
  89. else
  90. must_be_valid:=false;
  91. { if we handle writeln; p^.left contains no valid address }
  92. if assigned(p^.left) then
  93. begin
  94. if p^.left^.treetype=callparan then
  95. firstcallparan(p^.left,nil)
  96. else
  97. firstpass(p^.left);
  98. left_right_max(p);
  99. set_location(p^.location,p^.left^.location);
  100. end;
  101. { handle intern constant functions in separate case }
  102. if p^.inlineconst then
  103. begin
  104. { no parameters? }
  105. if not assigned(p^.left) then
  106. begin
  107. case p^.inlinenumber of
  108. in_const_pi : begin
  109. hp:=genrealconstnode(pi);
  110. end;
  111. else
  112. internalerror(89);
  113. end;
  114. end
  115. else
  116. { process constant expression with parameter }
  117. begin
  118. vl:=0;
  119. vl2:=0; { second parameter Ex: ptr(vl,vl2) }
  120. vr:=0;
  121. isreal:=false;
  122. case p^.left^.treetype of
  123. realconstn :
  124. begin
  125. isreal:=true;
  126. vr:=p^.left^.value_real;
  127. end;
  128. ordconstn :
  129. vl:=p^.left^.value;
  130. callparan :
  131. begin
  132. { both exists, else it was not generated }
  133. vl:=p^.left^.left^.value;
  134. vl2:=p^.left^.right^.left^.value;
  135. end;
  136. else
  137. CGMessage(cg_e_illegal_expression);
  138. end;
  139. case p^.inlinenumber of
  140. in_const_trunc : begin
  141. if isreal then
  142. begin
  143. if (vr>=2147483648.0) or (vr<=-2147483649.0) then
  144. begin
  145. CGMessage(parser_e_range_check_error);
  146. hp:=genordinalconstnode(1,s32bitdef)
  147. end
  148. else
  149. hp:=genordinalconstnode(trunc(vr),s32bitdef)
  150. end
  151. else
  152. hp:=genordinalconstnode(trunc(vl),s32bitdef);
  153. end;
  154. in_const_round : begin
  155. if isreal then
  156. begin
  157. if (vr>=2147483647.5) or (vr<=-2147483648.5) then
  158. begin
  159. CGMessage(parser_e_range_check_error);
  160. hp:=genordinalconstnode(1,s32bitdef)
  161. end
  162. else
  163. hp:=genordinalconstnode(round(vr),s32bitdef)
  164. end
  165. else
  166. hp:=genordinalconstnode(round(vl),s32bitdef);
  167. end;
  168. in_const_frac : begin
  169. if isreal then
  170. hp:=genrealconstnode(frac(vr))
  171. else
  172. hp:=genrealconstnode(frac(vl));
  173. end;
  174. in_const_int : begin
  175. if isreal then
  176. hp:=genrealconstnode(int(vr))
  177. else
  178. hp:=genrealconstnode(int(vl));
  179. end;
  180. in_const_abs : begin
  181. if isreal then
  182. hp:=genrealconstnode(abs(vr))
  183. else
  184. hp:=genordinalconstnode(abs(vl),p^.left^.resulttype);
  185. end;
  186. in_const_sqr : begin
  187. if isreal then
  188. hp:=genrealconstnode(sqr(vr))
  189. else
  190. hp:=genordinalconstnode(sqr(vl),p^.left^.resulttype);
  191. end;
  192. in_const_odd : begin
  193. if isreal then
  194. CGMessage(type_e_integer_expr_expected)
  195. else
  196. hp:=genordinalconstnode(byte(odd(vl)),booldef);
  197. end;
  198. in_const_swap_word : begin
  199. if isreal then
  200. CGMessage(type_e_integer_expr_expected)
  201. else
  202. hp:=genordinalconstnode((vl and $ff) shl 8+(vl shr 8),p^.left^.resulttype);
  203. end;
  204. in_const_swap_long : begin
  205. if isreal then
  206. CGMessage(type_e_mismatch)
  207. else
  208. hp:=genordinalconstnode((vl and $ffff) shl 16+(vl shr 16),p^.left^.resulttype);
  209. end;
  210. in_const_ptr : begin
  211. if isreal then
  212. CGMessage(type_e_mismatch)
  213. else
  214. hp:=genordinalconstnode((vl2 shl 16) or vl,voidpointerdef);
  215. end;
  216. in_const_sqrt : begin
  217. if isreal then
  218. hp:=genrealconstnode(sqrt(vr))
  219. else
  220. hp:=genrealconstnode(sqrt(vl));
  221. end;
  222. in_const_arctan : begin
  223. if isreal then
  224. hp:=genrealconstnode(arctan(vr))
  225. else
  226. hp:=genrealconstnode(arctan(vl));
  227. end;
  228. in_const_cos : begin
  229. if isreal then
  230. hp:=genrealconstnode(cos(vr))
  231. else
  232. hp:=genrealconstnode(cos(vl));
  233. end;
  234. in_const_sin : begin
  235. if isreal then
  236. hp:=genrealconstnode(sin(vr))
  237. else
  238. hp:=genrealconstnode(sin(vl));
  239. end;
  240. in_const_exp : begin
  241. if isreal then
  242. hp:=genrealconstnode(exp(vr))
  243. else
  244. hp:=genrealconstnode(exp(vl));
  245. end;
  246. in_const_ln : begin
  247. if isreal then
  248. hp:=genrealconstnode(ln(vr))
  249. else
  250. hp:=genrealconstnode(ln(vl));
  251. end;
  252. else
  253. internalerror(88);
  254. end;
  255. end;
  256. disposetree(p);
  257. firstpass(hp);
  258. p:=hp;
  259. end
  260. else
  261. begin
  262. case p^.inlinenumber of
  263. in_lo_long,in_hi_long,
  264. in_lo_word,in_hi_word:
  265. begin
  266. if p^.registers32<1 then
  267. p^.registers32:=1;
  268. if p^.inlinenumber in [in_lo_word,in_hi_word] then
  269. p^.resulttype:=u8bitdef
  270. else
  271. p^.resulttype:=u16bitdef;
  272. p^.location.loc:=LOC_REGISTER;
  273. if not is_integer(p^.left^.resulttype) then
  274. CGMessage(type_e_mismatch)
  275. else
  276. begin
  277. if p^.left^.treetype=ordconstn then
  278. begin
  279. case p^.inlinenumber of
  280. in_lo_word : hp:=genordinalconstnode(p^.left^.value and $ff,p^.left^.resulttype);
  281. in_hi_word : hp:=genordinalconstnode(p^.left^.value shr 8,p^.left^.resulttype);
  282. in_lo_long : hp:=genordinalconstnode(p^.left^.value and $ffff,p^.left^.resulttype);
  283. in_hi_long : hp:=genordinalconstnode(p^.left^.value shr 16,p^.left^.resulttype);
  284. end;
  285. disposetree(p);
  286. firstpass(hp);
  287. p:=hp;
  288. end;
  289. end;
  290. end;
  291. in_sizeof_x:
  292. begin
  293. {$ifndef OLDHIGH}
  294. if push_high_param(p^.left^.resulttype) then
  295. begin
  296. getsymonlyin(p^.left^.symtable,'high'+pvarsym(p^.left^.symtableentry)^.name);
  297. hp:=gennode(addn,genloadnode(pvarsym(srsym),p^.left^.symtable),
  298. genordinalconstnode(1,s32bitdef));
  299. if (p^.left^.resulttype^.deftype=arraydef) and
  300. (parraydef(p^.left^.resulttype)^.elesize<>1) then
  301. hp:=gennode(muln,hp,genordinalconstnode(parraydef(p^.left^.resulttype)^.elesize,s32bitdef));
  302. disposetree(p);
  303. p:=hp;
  304. firstpass(p);
  305. end;
  306. {$endif OLDHIGH}
  307. if p^.registers32<1 then
  308. p^.registers32:=1;
  309. p^.resulttype:=s32bitdef;
  310. p^.location.loc:=LOC_REGISTER;
  311. end;
  312. in_typeof_x:
  313. begin
  314. if p^.registers32<1 then
  315. p^.registers32:=1;
  316. p^.location.loc:=LOC_REGISTER;
  317. p^.resulttype:=voidpointerdef;
  318. end;
  319. in_ord_x:
  320. begin
  321. if (p^.left^.treetype=ordconstn) then
  322. begin
  323. hp:=genordinalconstnode(p^.left^.value,s32bitdef);
  324. disposetree(p);
  325. p:=hp;
  326. firstpass(p);
  327. end
  328. else
  329. begin
  330. if (p^.left^.resulttype^.deftype=orddef) then
  331. if (porddef(p^.left^.resulttype)^.typ in [uchar,bool8bit]) then
  332. begin
  333. if porddef(p^.left^.resulttype)^.typ=bool8bit then
  334. begin
  335. hp:=gentypeconvnode(p^.left,u8bitdef);
  336. putnode(p);
  337. p:=hp;
  338. p^.convtyp:=tc_bool_2_int;
  339. p^.explizit:=true;
  340. firstpass(p);
  341. end
  342. else
  343. begin
  344. hp:=gentypeconvnode(p^.left,u8bitdef);
  345. putnode(p);
  346. p:=hp;
  347. p^.explizit:=true;
  348. firstpass(p);
  349. end;
  350. end
  351. { can this happen ? }
  352. else if (porddef(p^.left^.resulttype)^.typ=uvoid) then
  353. CGMessage(type_e_mismatch)
  354. else
  355. { all other orddef need no transformation }
  356. begin
  357. hp:=p^.left;
  358. putnode(p);
  359. p:=hp;
  360. end
  361. else if (p^.left^.resulttype^.deftype=enumdef) then
  362. begin
  363. hp:=gentypeconvnode(p^.left,s32bitdef);
  364. putnode(p);
  365. p:=hp;
  366. p^.explizit:=true;
  367. firstpass(p);
  368. end
  369. else
  370. begin
  371. { can anything else be ord() ?}
  372. CGMessage(type_e_mismatch);
  373. end;
  374. end;
  375. end;
  376. in_chr_byte:
  377. begin
  378. hp:=gentypeconvnode(p^.left,cchardef);
  379. putnode(p);
  380. p:=hp;
  381. p^.explizit:=true;
  382. firstpass(p);
  383. end;
  384. in_length_string:
  385. begin
  386. if is_ansistring(p^.left^.resulttype) then
  387. p^.resulttype:=s32bitdef
  388. else
  389. p^.resulttype:=u8bitdef;
  390. { we don't need string conversations here }
  391. if (p^.left^.treetype=typeconvn) and
  392. (p^.left^.left^.resulttype^.deftype=stringdef) then
  393. begin
  394. hp:=p^.left^.left;
  395. putnode(p^.left);
  396. p^.left:=hp;
  397. end;
  398. { check the type, must be string or char }
  399. if (p^.left^.resulttype^.deftype<>stringdef) and
  400. (not is_char(p^.left^.resulttype)) then
  401. CGMessage(type_e_mismatch);
  402. { evaluates length of constant strings direct }
  403. if (p^.left^.treetype=stringconstn) then
  404. begin
  405. hp:=genordinalconstnode(p^.left^.length,s32bitdef);
  406. disposetree(p);
  407. firstpass(hp);
  408. p:=hp;
  409. end
  410. { length of char is one allways }
  411. else if is_constcharnode(p^.left) then
  412. begin
  413. hp:=genordinalconstnode(1,s32bitdef);
  414. disposetree(p);
  415. firstpass(hp);
  416. p:=hp;
  417. end;
  418. end;
  419. in_assigned_x:
  420. begin
  421. p^.resulttype:=booldef;
  422. p^.location.loc:=LOC_FLAGS;
  423. end;
  424. in_pred_x,
  425. in_succ_x:
  426. begin
  427. inc(p^.registers32);
  428. p^.resulttype:=p^.left^.resulttype;
  429. p^.location.loc:=LOC_REGISTER;
  430. if not is_ordinal(p^.resulttype) then
  431. CGMessage(type_e_ordinal_expr_expected)
  432. else
  433. begin
  434. if (p^.resulttype^.deftype=enumdef) and
  435. (penumdef(p^.resulttype)^.has_jumps) then
  436. CGMessage(type_e_succ_and_pred_enums_with_assign_not_possible)
  437. else
  438. if p^.left^.treetype=ordconstn then
  439. begin
  440. if p^.inlinenumber=in_succ_x then
  441. hp:=genordinalconstnode(p^.left^.value+1,p^.left^.resulttype)
  442. else
  443. hp:=genordinalconstnode(p^.left^.value-1,p^.left^.resulttype);
  444. disposetree(p);
  445. firstpass(hp);
  446. p:=hp;
  447. end;
  448. end;
  449. end;
  450. in_inc_x,
  451. in_dec_x:
  452. begin
  453. p^.resulttype:=voiddef;
  454. if assigned(p^.left) then
  455. begin
  456. firstcallparan(p^.left,nil);
  457. if codegenerror then
  458. exit;
  459. { first param must be var }
  460. if is_constnode(p^.left^.left) then
  461. CGMessage(type_e_variable_id_expected);
  462. { check type }
  463. if (p^.left^.resulttype^.deftype in [enumdef,pointerdef]) or
  464. is_ordinal(p^.left^.resulttype) then
  465. begin
  466. { two paras ? }
  467. if assigned(p^.left^.right) then
  468. begin
  469. { insert a type conversion }
  470. { the second param is always longint }
  471. p^.left^.right^.left:=gentypeconvnode(p^.left^.right^.left,s32bitdef);
  472. { check the type conversion }
  473. firstpass(p^.left^.right^.left);
  474. { need we an additional register ? }
  475. if not(is_constintnode(p^.left^.right^.left)) and
  476. (p^.left^.right^.left^.location.loc in [LOC_MEM,LOC_REFERENCE]) and
  477. (p^.left^.right^.left^.registers32<1) then
  478. inc(p^.registers32);
  479. if assigned(p^.left^.right^.right) then
  480. CGMessage(cg_e_illegal_expression);
  481. end;
  482. end
  483. else
  484. CGMessage(type_e_ordinal_expr_expected);
  485. end
  486. else
  487. CGMessage(type_e_mismatch);
  488. end;
  489. in_read_x,
  490. in_readln_x,
  491. in_write_x,
  492. in_writeln_x :
  493. begin
  494. { needs a call }
  495. procinfo.flags:=procinfo.flags or pi_do_call;
  496. p^.resulttype:=voiddef;
  497. { we must know if it is a typed file or not }
  498. { but we must first do the firstpass for it }
  499. file_is_typed:=false;
  500. if assigned(p^.left) then
  501. begin
  502. firstcallparan(p^.left,nil);
  503. { now we can check }
  504. hp:=p^.left;
  505. while assigned(hp^.right) do
  506. hp:=hp^.right;
  507. { if resulttype is not assigned, then automatically }
  508. { file is not typed. }
  509. if assigned(hp) and assigned(hp^.resulttype) then
  510. Begin
  511. if (hp^.resulttype^.deftype=filedef) and
  512. (pfiledef(hp^.resulttype)^.filetype=ft_typed) then
  513. begin
  514. file_is_typed:=true;
  515. { test the type }
  516. hpp:=p^.left;
  517. while (hpp<>hp) do
  518. begin
  519. if (hpp^.left^.treetype=typen) then
  520. CGMessage(type_e_cant_read_write_type);
  521. if not is_equal(hpp^.resulttype,pfiledef(hp^.resulttype)^.typed_as) then
  522. CGMessage(type_e_mismatch);
  523. hpp:=hpp^.right;
  524. end;
  525. end;
  526. end; { endif assigned(hp) }
  527. { insert type conversions for write(ln) }
  528. if (not file_is_typed) then
  529. begin
  530. dowrite:=(p^.inlinenumber in [in_write_x,in_writeln_x]);
  531. hp:=p^.left;
  532. while assigned(hp) do
  533. begin
  534. if (hp^.left^.treetype=typen) then
  535. CGMessage(type_e_cant_read_write_type);
  536. if assigned(hp^.left^.resulttype) then
  537. begin
  538. isreal:=false;
  539. case hp^.left^.resulttype^.deftype of
  540. filedef : begin
  541. { only allowed as first parameter }
  542. if assigned(hp^.right) then
  543. CGMessage(type_e_cant_read_write_type);
  544. end;
  545. stringdef : begin
  546. { generate the high() value for the shortstring }
  547. if (not dowrite) and
  548. is_shortstring(hp^.left^.resulttype) then
  549. gen_high_tree(hp,true);
  550. end;
  551. pointerdef : begin
  552. if not is_equal(ppointerdef(hp^.left^.resulttype)^.definition,cchardef) then
  553. CGMessage(type_e_cant_read_write_type);
  554. end;
  555. floatdef : begin
  556. isreal:=true;
  557. end;
  558. orddef : begin
  559. case porddef(hp^.left^.resulttype)^.typ of
  560. uchar,
  561. u32bit,
  562. s32bit,
  563. s64bitint,
  564. u64bit:
  565. ;
  566. u8bit,s8bit,
  567. u16bit,s16bit : if dowrite then
  568. hp^.left:=gentypeconvnode(hp^.left,s32bitdef);
  569. bool8bit,
  570. bool16bit,bool32bit : if dowrite then
  571. hp^.left:=gentypeconvnode(hp^.left,booldef)
  572. else
  573. CGMessage(type_e_cant_read_write_type);
  574. else
  575. CGMessage(type_e_cant_read_write_type);
  576. end;
  577. end;
  578. arraydef : begin
  579. if not((parraydef(hp^.left^.resulttype)^.lowrange=0) and
  580. is_equal(parraydef(hp^.left^.resulttype)^.definition,cchardef)) then
  581. begin
  582. { but we convert only if the first index<>0,
  583. because in this case we have a ASCIIZ string }
  584. if dowrite and
  585. (parraydef(hp^.left^.resulttype)^.lowrange<>0) and
  586. (parraydef(hp^.left^.resulttype)^.definition^.deftype=orddef) and
  587. (porddef(parraydef(hp^.left^.resulttype)^.definition)^.typ=uchar) then
  588. hp^.left:=gentypeconvnode(hp^.left,cshortstringdef)
  589. else
  590. CGMessage(type_e_cant_read_write_type);
  591. end;
  592. end;
  593. else
  594. CGMessage(type_e_cant_read_write_type);
  595. end;
  596. { some format options ? }
  597. {$ifndef NOCOLONCHECK}
  598. { commented
  599. because supposes reverse order of parameters
  600. PM : now restored PM }
  601. if hp^.is_colon_para then
  602. begin
  603. if hp^.right^.is_colon_para then
  604. begin
  605. frac_para:=hp;
  606. length_para:=hp^.right;
  607. hp:=hp^.right;
  608. hpp:=hp^.right;
  609. end
  610. else
  611. begin
  612. length_para:=hp;
  613. frac_para:=nil;
  614. hpp:=hp^.right;
  615. end;
  616. isreal:=hpp^.resulttype^.deftype=floatdef;
  617. if (not is_integer(length_para^.resulttype)) then
  618. CGMessage(type_e_integer_expr_expected)
  619. else
  620. length_para^.left:=gentypeconvnode(length_para^.left,s32bitdef);
  621. if assigned(frac_para) then
  622. begin
  623. if isreal then
  624. begin
  625. if (not is_integer(frac_para^.resulttype)) then
  626. CGMessage(type_e_integer_expr_expected)
  627. else
  628. frac_para^.left:=gentypeconvnode(frac_para^.left,s32bitdef);
  629. end
  630. else
  631. CGMessage(parser_e_illegal_colon_qualifier);
  632. end;
  633. { do the checking for the colon'd arg }
  634. hp:=length_para;
  635. end;
  636. {$endif ndef NOCOLONCHECK}
  637. end;
  638. hp:=hp^.right;
  639. end;
  640. end;
  641. { pass all parameters again for the typeconversions }
  642. if codegenerror then
  643. exit;
  644. must_be_valid:=true;
  645. firstcallparan(p^.left,nil);
  646. { calc registers }
  647. left_right_max(p);
  648. end;
  649. end;
  650. in_settextbuf_file_x :
  651. begin
  652. { warning here p^.left is the callparannode
  653. not the argument directly }
  654. { p^.left^.left is text var }
  655. { p^.left^.right^.left is the buffer var }
  656. { firstcallparan(p^.left,nil);
  657. already done in firstcalln }
  658. { now we know the type of buffer }
  659. getsymonlyin(systemunit,'SETTEXTBUF');
  660. hp:=gencallnode(pprocsym(srsym),systemunit);
  661. hp^.left:=gencallparanode(
  662. genordinalconstnode(p^.left^.left^.resulttype^.size,s32bitdef),p^.left);
  663. putnode(p);
  664. p:=hp;
  665. firstpass(p);
  666. end;
  667. { the firstpass of the arg has been done in firstcalln ? }
  668. in_reset_typedfile,in_rewrite_typedfile :
  669. begin
  670. procinfo.flags:=procinfo.flags or pi_do_call;
  671. { to be sure the right definition is loaded }
  672. p^.left^.resulttype:=nil;
  673. firstload(p^.left);
  674. p^.resulttype:=voiddef;
  675. end;
  676. in_str_x_string :
  677. begin
  678. procinfo.flags:=procinfo.flags or pi_do_call;
  679. p^.resulttype:=voiddef;
  680. { check the amount of parameters }
  681. if not(assigned(p^.left)) or
  682. not(assigned(p^.left^.right)) then
  683. begin
  684. CGMessage(parser_e_wrong_parameter_size);
  685. exit;
  686. end;
  687. { first pass just the string for first local use }
  688. hp:=p^.left^.right;
  689. must_be_valid:=false;
  690. count_ref:=true;
  691. p^.left^.right:=nil;
  692. firstcallparan(p^.left,nil);
  693. must_be_valid:=true;
  694. p^.left^.right:=hp;
  695. firstcallparan(p^.left^.right,nil);
  696. hp:=p^.left;
  697. { valid string ? }
  698. if not assigned(hp) or
  699. (hp^.left^.resulttype^.deftype<>stringdef) or
  700. (hp^.right=nil) or
  701. (hp^.left^.location.loc<>LOC_REFERENCE) then
  702. CGMessage(cg_e_illegal_expression);
  703. { generate the high() value for the shortstring }
  704. if is_shortstring(hp^.left^.resulttype) then
  705. gen_high_tree(hp,true);
  706. { !!!! check length of string }
  707. while assigned(hp^.right) do
  708. hp:=hp^.right;
  709. { check and convert the first param }
  710. if hp^.is_colon_para then
  711. CGMessage(cg_e_illegal_expression);
  712. isreal:=false;
  713. case hp^.resulttype^.deftype of
  714. orddef : begin
  715. case porddef(hp^.left^.resulttype)^.typ of
  716. u32bit,
  717. s32bit,
  718. s64bitint,
  719. u64bit:
  720. ;
  721. u8bit,s8bit,
  722. u16bit,s16bit:
  723. hp^.left:=gentypeconvnode(hp^.left,s32bitdef);
  724. else
  725. CGMessage(type_e_integer_or_real_expr_expected);
  726. end;
  727. end;
  728. floatdef : begin
  729. isreal:=true;
  730. end;
  731. else
  732. CGMessage(type_e_integer_or_real_expr_expected);
  733. end;
  734. { some format options ? }
  735. hpp:=p^.left^.right;
  736. if assigned(hpp) and hpp^.is_colon_para then
  737. begin
  738. if (not is_integer(hpp^.resulttype)) then
  739. CGMessage(type_e_integer_expr_expected)
  740. else
  741. hpp^.left:=gentypeconvnode(hpp^.left,s32bitdef);
  742. hpp:=hpp^.right;
  743. if assigned(hpp) and hpp^.is_colon_para then
  744. begin
  745. if isreal then
  746. begin
  747. if (not is_integer(hpp^.resulttype)) then
  748. CGMessage(type_e_integer_expr_expected)
  749. else
  750. hpp^.left:=gentypeconvnode(hpp^.left,s32bitdef);
  751. end
  752. else
  753. CGMessage(parser_e_illegal_colon_qualifier);
  754. end;
  755. end;
  756. { for first local use }
  757. must_be_valid:=false;
  758. count_ref:=true;
  759. { pass all parameters again for the typeconversions }
  760. if codegenerror then
  761. exit;
  762. must_be_valid:=true;
  763. firstcallparan(p^.left,nil);
  764. { calc registers }
  765. left_right_max(p);
  766. end;
  767. in_include_x_y,
  768. in_exclude_x_y:
  769. begin
  770. p^.resulttype:=voiddef;
  771. if assigned(p^.left) then
  772. begin
  773. firstcallparan(p^.left,nil);
  774. p^.registers32:=p^.left^.registers32;
  775. p^.registersfpu:=p^.left^.registersfpu;
  776. {$ifdef SUPPORT_MMX}
  777. p^.registersmmx:=p^.left^.registersmmx;
  778. {$endif SUPPORT_MMX}
  779. { first param must be var }
  780. if (p^.left^.left^.location.loc<>LOC_REFERENCE) and
  781. (p^.left^.left^.location.loc<>LOC_CREGISTER) then
  782. CGMessage(cg_e_illegal_expression);
  783. { check type }
  784. if (p^.left^.resulttype^.deftype=setdef) then
  785. begin
  786. { two paras ? }
  787. if assigned(p^.left^.right) then
  788. begin
  789. { insert a type conversion }
  790. { to the type of the set elements }
  791. p^.left^.right^.left:=gentypeconvnode(
  792. p^.left^.right^.left,
  793. psetdef(p^.left^.resulttype)^.setof);
  794. { check the type conversion }
  795. firstpass(p^.left^.right^.left);
  796. { only three parameters are allowed }
  797. if assigned(p^.left^.right^.right) then
  798. CGMessage(cg_e_illegal_expression);
  799. end;
  800. end
  801. else
  802. CGMessage(type_e_mismatch);
  803. end
  804. else
  805. CGMessage(type_e_mismatch);
  806. end;
  807. in_low_x,in_high_x:
  808. begin
  809. if p^.left^.treetype in [typen,loadn,subscriptn] then
  810. begin
  811. case p^.left^.resulttype^.deftype of
  812. orddef,enumdef:
  813. begin
  814. do_lowhigh(p^.left^.resulttype);
  815. firstpass(p);
  816. end;
  817. setdef:
  818. begin
  819. do_lowhigh(Psetdef(p^.left^.resulttype)^.setof);
  820. firstpass(p);
  821. end;
  822. arraydef:
  823. begin
  824. if p^.inlinenumber=in_low_x then
  825. begin
  826. hp:=genordinalconstnode(Parraydef(p^.left^.resulttype)^.lowrange,s32bitdef);
  827. disposetree(p);
  828. p:=hp;
  829. firstpass(p);
  830. end
  831. else
  832. begin
  833. if is_open_array(p^.left^.resulttype) then
  834. begin
  835. {$ifndef OLDHIGH}
  836. getsymonlyin(p^.left^.symtable,'high'+pvarsym(p^.left^.symtableentry)^.name);
  837. hp:=genloadnode(pvarsym(srsym),p^.left^.symtable);
  838. disposetree(p);
  839. p:=hp;
  840. firstpass(p);
  841. {$else OLDHIGH}
  842. p^.resulttype:=s32bitdef;
  843. p^.registers32:=max(1,p^.registers32);
  844. p^.location.loc:=LOC_REGISTER;
  845. {$endif OLDHIGH}
  846. end
  847. else
  848. begin
  849. hp:=genordinalconstnode(Parraydef(p^.left^.resulttype)^.highrange,s32bitdef);
  850. disposetree(p);
  851. p:=hp;
  852. firstpass(p);
  853. end;
  854. end;
  855. end;
  856. stringdef:
  857. begin
  858. if p^.inlinenumber=in_low_x then
  859. begin
  860. hp:=genordinalconstnode(0,u8bitdef);
  861. disposetree(p);
  862. p:=hp;
  863. firstpass(p);
  864. end
  865. else
  866. begin
  867. if is_open_string(p^.left^.resulttype) then
  868. begin
  869. {$ifndef OLDHIGH}
  870. getsymonlyin(p^.left^.symtable,'high'+pvarsym(p^.left^.symtableentry)^.name);
  871. hp:=genloadnode(pvarsym(srsym),p^.left^.symtable);
  872. disposetree(p);
  873. p:=hp;
  874. firstpass(p);
  875. {$else OLDHIGH}
  876. p^.resulttype:=s32bitdef;
  877. p^.registers32:=max(1,p^.registers32);
  878. p^.location.loc:=LOC_REGISTER;
  879. {$endif OLDHIGH}
  880. end
  881. else
  882. begin
  883. hp:=genordinalconstnode(Pstringdef(p^.left^.resulttype)^.len,u8bitdef);
  884. disposetree(p);
  885. p:=hp;
  886. firstpass(p);
  887. end;
  888. end;
  889. end;
  890. else
  891. CGMessage(type_e_mismatch);
  892. end;
  893. end
  894. else
  895. CGMessage(type_e_varid_or_typeid_expected);
  896. end;
  897. in_assert_x_y :
  898. begin
  899. p^.resulttype:=voiddef;
  900. if assigned(p^.left) then
  901. begin
  902. firstcallparan(p^.left,nil);
  903. p^.registers32:=p^.left^.registers32;
  904. p^.registersfpu:=p^.left^.registersfpu;
  905. {$ifdef SUPPORT_MMX}
  906. p^.registersmmx:=p^.left^.registersmmx;
  907. {$endif SUPPORT_MMX}
  908. { check type }
  909. if is_boolean(p^.left^.resulttype) then
  910. begin
  911. { must always be a string }
  912. p^.left^.right^.left:=gentypeconvnode(p^.left^.right^.left,cshortstringdef);
  913. firstpass(p^.left^.right^.left);
  914. end
  915. else
  916. CGMessage(type_e_mismatch);
  917. end
  918. else
  919. CGMessage(type_e_mismatch);
  920. end;
  921. else
  922. internalerror(8);
  923. end;
  924. end;
  925. { generate an error if no resulttype is set }
  926. if not assigned(p^.resulttype) then
  927. p^.resulttype:=generrordef;
  928. must_be_valid:=store_valid;
  929. count_ref:=store_count_ref;
  930. end;
  931. end.
  932. {
  933. $Log$
  934. Revision 1.17 1999-02-01 00:00:50 florian
  935. * compiler crash fixed when constant arguments passed to round/trunc
  936. exceeds the longint range
  937. Revision 1.16 1999/01/28 19:43:43 peter
  938. * fixed high generation for ansistrings with str,writeln
  939. Revision 1.15 1999/01/27 16:28:22 pierre
  940. * bug0157 solved : write(x:5.3) is rejected now
  941. Revision 1.14 1999/01/21 22:10:50 peter
  942. * fixed array of const
  943. * generic platform independent high() support
  944. Revision 1.13 1998/12/30 22:13:13 peter
  945. * check the amount of paras for Str()
  946. Revision 1.12 1998/12/15 10:23:31 peter
  947. + -iSO, -iSP, -iTO, -iTP
  948. Revision 1.11 1998/12/11 23:36:08 florian
  949. + again more stuff for int64/qword:
  950. - comparision operators
  951. - code generation for: str, read(ln), write(ln)
  952. Revision 1.10 1998/11/27 14:50:53 peter
  953. + open strings, $P switch support
  954. Revision 1.9 1998/11/24 17:04:28 peter
  955. * fixed length(char) when char is a variable
  956. Revision 1.8 1998/11/14 10:51:33 peter
  957. * fixed low/high for record.field
  958. Revision 1.7 1998/11/13 10:15:52 peter
  959. * fixed ptr() with constants
  960. Revision 1.6 1998/11/05 12:03:05 peter
  961. * released useansistring
  962. * removed -Sv, its now available in fpc modes
  963. Revision 1.5 1998/10/20 11:16:47 pierre
  964. + length(c) where C is a char is allways 1
  965. Revision 1.4 1998/10/06 20:49:11 peter
  966. * m68k compiler compiles again
  967. Revision 1.3 1998/10/05 12:32:49 peter
  968. + assert() support
  969. Revision 1.2 1998/10/02 09:24:23 peter
  970. * more constant expression evaluators
  971. Revision 1.1 1998/09/23 20:42:24 peter
  972. * splitted pass_1
  973. }