tcinl.pas 43 KB

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