tcinl.pas 42 KB

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