tcinl.pas 43 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007
  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 shortstring }
  531. if (not dowrite) and
  532. is_shortstring(hp^.left^.resulttype) then
  533. gen_high_tree(hp,true);
  534. end;
  535. pointerdef : begin
  536. if not is_equal(ppointerdef(hp^.left^.resulttype)^.definition,cchardef) then
  537. CGMessage(type_e_cant_read_write_type);
  538. end;
  539. floatdef : begin
  540. isreal:=true;
  541. end;
  542. orddef : begin
  543. case porddef(hp^.left^.resulttype)^.typ of
  544. uchar,
  545. u32bit,
  546. s32bit,
  547. s64bitint,
  548. u64bit:
  549. ;
  550. u8bit,s8bit,
  551. u16bit,s16bit : if dowrite then
  552. hp^.left:=gentypeconvnode(hp^.left,s32bitdef);
  553. bool8bit,
  554. bool16bit,bool32bit : if dowrite then
  555. hp^.left:=gentypeconvnode(hp^.left,booldef)
  556. else
  557. CGMessage(type_e_cant_read_write_type);
  558. else
  559. CGMessage(type_e_cant_read_write_type);
  560. end;
  561. end;
  562. arraydef : begin
  563. if not((parraydef(hp^.left^.resulttype)^.lowrange=0) and
  564. is_equal(parraydef(hp^.left^.resulttype)^.definition,cchardef)) then
  565. begin
  566. { but we convert only if the first index<>0,
  567. because in this case we have a ASCIIZ string }
  568. if dowrite and
  569. (parraydef(hp^.left^.resulttype)^.lowrange<>0) and
  570. (parraydef(hp^.left^.resulttype)^.definition^.deftype=orddef) and
  571. (porddef(parraydef(hp^.left^.resulttype)^.definition)^.typ=uchar) then
  572. hp^.left:=gentypeconvnode(hp^.left,cshortstringdef)
  573. else
  574. CGMessage(type_e_cant_read_write_type);
  575. end;
  576. end;
  577. else
  578. CGMessage(type_e_cant_read_write_type);
  579. end;
  580. { some format options ? }
  581. {$ifndef NOCOLONCHECK}
  582. { commented
  583. because supposes reverse order of parameters
  584. PM : now restored PM }
  585. if hp^.is_colon_para then
  586. begin
  587. if hp^.right^.is_colon_para then
  588. begin
  589. frac_para:=hp;
  590. length_para:=hp^.right;
  591. hp:=hp^.right;
  592. hpp:=hp^.right;
  593. end
  594. else
  595. begin
  596. length_para:=hp;
  597. frac_para:=nil;
  598. hpp:=hp^.right;
  599. end;
  600. isreal:=hpp^.resulttype^.deftype=floatdef;
  601. if (not is_integer(length_para^.resulttype)) then
  602. CGMessage(type_e_integer_expr_expected)
  603. else
  604. length_para^.left:=gentypeconvnode(length_para^.left,s32bitdef);
  605. if assigned(frac_para) then
  606. begin
  607. if isreal then
  608. begin
  609. if (not is_integer(frac_para^.resulttype)) then
  610. CGMessage(type_e_integer_expr_expected)
  611. else
  612. frac_para^.left:=gentypeconvnode(frac_para^.left,s32bitdef);
  613. end
  614. else
  615. CGMessage(parser_e_illegal_colon_qualifier);
  616. end;
  617. { do the checking for the colon'd arg }
  618. hp:=length_para;
  619. end;
  620. {$endif ndef NOCOLONCHECK}
  621. end;
  622. hp:=hp^.right;
  623. end;
  624. end;
  625. { pass all parameters again for the typeconversions }
  626. if codegenerror then
  627. exit;
  628. must_be_valid:=true;
  629. firstcallparan(p^.left,nil);
  630. { calc registers }
  631. left_right_max(p);
  632. end;
  633. end;
  634. in_settextbuf_file_x :
  635. begin
  636. { warning here p^.left is the callparannode
  637. not the argument directly }
  638. { p^.left^.left is text var }
  639. { p^.left^.right^.left is the buffer var }
  640. { firstcallparan(p^.left,nil);
  641. already done in firstcalln }
  642. { now we know the type of buffer }
  643. getsymonlyin(systemunit,'SETTEXTBUF');
  644. hp:=gencallnode(pprocsym(srsym),systemunit);
  645. hp^.left:=gencallparanode(
  646. genordinalconstnode(p^.left^.left^.resulttype^.size,s32bitdef),p^.left);
  647. putnode(p);
  648. p:=hp;
  649. firstpass(p);
  650. end;
  651. { the firstpass of the arg has been done in firstcalln ? }
  652. in_reset_typedfile,in_rewrite_typedfile :
  653. begin
  654. procinfo.flags:=procinfo.flags or pi_do_call;
  655. { to be sure the right definition is loaded }
  656. p^.left^.resulttype:=nil;
  657. firstload(p^.left);
  658. p^.resulttype:=voiddef;
  659. end;
  660. in_str_x_string :
  661. begin
  662. procinfo.flags:=procinfo.flags or pi_do_call;
  663. p^.resulttype:=voiddef;
  664. { check the amount of parameters }
  665. if not(assigned(p^.left)) or
  666. not(assigned(p^.left^.right)) then
  667. begin
  668. CGMessage(parser_e_wrong_parameter_size);
  669. exit;
  670. end;
  671. { first pass just the string for first local use }
  672. hp:=p^.left^.right;
  673. must_be_valid:=false;
  674. count_ref:=true;
  675. p^.left^.right:=nil;
  676. firstcallparan(p^.left,nil);
  677. must_be_valid:=true;
  678. p^.left^.right:=hp;
  679. firstcallparan(p^.left^.right,nil);
  680. hp:=p^.left;
  681. { valid string ? }
  682. if not assigned(hp) or
  683. (hp^.left^.resulttype^.deftype<>stringdef) or
  684. (hp^.right=nil) or
  685. (hp^.left^.location.loc<>LOC_REFERENCE) then
  686. CGMessage(cg_e_illegal_expression);
  687. { generate the high() value for the shortstring }
  688. if is_shortstring(hp^.left^.resulttype) then
  689. gen_high_tree(hp,true);
  690. { !!!! check length of string }
  691. while assigned(hp^.right) do
  692. hp:=hp^.right;
  693. { check and convert the first param }
  694. if hp^.is_colon_para then
  695. CGMessage(cg_e_illegal_expression);
  696. isreal:=false;
  697. case hp^.resulttype^.deftype of
  698. orddef : begin
  699. case porddef(hp^.left^.resulttype)^.typ of
  700. u32bit,
  701. s32bit,
  702. s64bitint,
  703. u64bit:
  704. ;
  705. u8bit,s8bit,
  706. u16bit,s16bit:
  707. hp^.left:=gentypeconvnode(hp^.left,s32bitdef);
  708. else
  709. CGMessage(type_e_integer_or_real_expr_expected);
  710. end;
  711. end;
  712. floatdef : begin
  713. isreal:=true;
  714. end;
  715. else
  716. CGMessage(type_e_integer_or_real_expr_expected);
  717. end;
  718. { some format options ? }
  719. hpp:=p^.left^.right;
  720. if assigned(hpp) and hpp^.is_colon_para then
  721. begin
  722. if (not is_integer(hpp^.resulttype)) then
  723. CGMessage(type_e_integer_expr_expected)
  724. else
  725. hpp^.left:=gentypeconvnode(hpp^.left,s32bitdef);
  726. hpp:=hpp^.right;
  727. if assigned(hpp) and hpp^.is_colon_para then
  728. begin
  729. if isreal then
  730. begin
  731. if (not is_integer(hpp^.resulttype)) then
  732. CGMessage(type_e_integer_expr_expected)
  733. else
  734. hpp^.left:=gentypeconvnode(hpp^.left,s32bitdef);
  735. end
  736. else
  737. CGMessage(parser_e_illegal_colon_qualifier);
  738. end;
  739. end;
  740. { for first local use }
  741. must_be_valid:=false;
  742. count_ref:=true;
  743. { pass all parameters again for the typeconversions }
  744. if codegenerror then
  745. exit;
  746. must_be_valid:=true;
  747. firstcallparan(p^.left,nil);
  748. { calc registers }
  749. left_right_max(p);
  750. end;
  751. in_include_x_y,
  752. in_exclude_x_y:
  753. begin
  754. p^.resulttype:=voiddef;
  755. if assigned(p^.left) then
  756. begin
  757. firstcallparan(p^.left,nil);
  758. p^.registers32:=p^.left^.registers32;
  759. p^.registersfpu:=p^.left^.registersfpu;
  760. {$ifdef SUPPORT_MMX}
  761. p^.registersmmx:=p^.left^.registersmmx;
  762. {$endif SUPPORT_MMX}
  763. { first param must be var }
  764. if (p^.left^.left^.location.loc<>LOC_REFERENCE) and
  765. (p^.left^.left^.location.loc<>LOC_CREGISTER) then
  766. CGMessage(cg_e_illegal_expression);
  767. { check type }
  768. if (p^.left^.resulttype^.deftype=setdef) then
  769. begin
  770. { two paras ? }
  771. if assigned(p^.left^.right) then
  772. begin
  773. { insert a type conversion }
  774. { to the type of the set elements }
  775. p^.left^.right^.left:=gentypeconvnode(
  776. p^.left^.right^.left,
  777. psetdef(p^.left^.resulttype)^.setof);
  778. { check the type conversion }
  779. firstpass(p^.left^.right^.left);
  780. { only three parameters are allowed }
  781. if assigned(p^.left^.right^.right) then
  782. CGMessage(cg_e_illegal_expression);
  783. end;
  784. end
  785. else
  786. CGMessage(type_e_mismatch);
  787. end
  788. else
  789. CGMessage(type_e_mismatch);
  790. end;
  791. in_low_x,in_high_x:
  792. begin
  793. if p^.left^.treetype in [typen,loadn,subscriptn] then
  794. begin
  795. case p^.left^.resulttype^.deftype of
  796. orddef,enumdef:
  797. begin
  798. do_lowhigh(p^.left^.resulttype);
  799. firstpass(p);
  800. end;
  801. setdef:
  802. begin
  803. do_lowhigh(Psetdef(p^.left^.resulttype)^.setof);
  804. firstpass(p);
  805. end;
  806. arraydef:
  807. begin
  808. if p^.inlinenumber=in_low_x then
  809. begin
  810. hp:=genordinalconstnode(Parraydef(p^.left^.resulttype)^.lowrange,s32bitdef);
  811. disposetree(p);
  812. p:=hp;
  813. firstpass(p);
  814. end
  815. else
  816. begin
  817. if is_open_array(p^.left^.resulttype) then
  818. begin
  819. {$ifndef OLDHIGH}
  820. getsymonlyin(p^.left^.symtable,'high'+pvarsym(p^.left^.symtableentry)^.name);
  821. hp:=genloadnode(pvarsym(srsym),p^.left^.symtable);
  822. disposetree(p);
  823. p:=hp;
  824. firstpass(p);
  825. {$else OLDHIGH}
  826. p^.resulttype:=s32bitdef;
  827. p^.registers32:=max(1,p^.registers32);
  828. p^.location.loc:=LOC_REGISTER;
  829. {$endif OLDHIGH}
  830. end
  831. else
  832. begin
  833. hp:=genordinalconstnode(Parraydef(p^.left^.resulttype)^.highrange,s32bitdef);
  834. disposetree(p);
  835. p:=hp;
  836. firstpass(p);
  837. end;
  838. end;
  839. end;
  840. stringdef:
  841. begin
  842. if p^.inlinenumber=in_low_x then
  843. begin
  844. hp:=genordinalconstnode(0,u8bitdef);
  845. disposetree(p);
  846. p:=hp;
  847. firstpass(p);
  848. end
  849. else
  850. begin
  851. if is_open_string(p^.left^.resulttype) then
  852. begin
  853. {$ifndef OLDHIGH}
  854. getsymonlyin(p^.left^.symtable,'high'+pvarsym(p^.left^.symtableentry)^.name);
  855. hp:=genloadnode(pvarsym(srsym),p^.left^.symtable);
  856. disposetree(p);
  857. p:=hp;
  858. firstpass(p);
  859. {$else OLDHIGH}
  860. p^.resulttype:=s32bitdef;
  861. p^.registers32:=max(1,p^.registers32);
  862. p^.location.loc:=LOC_REGISTER;
  863. {$endif OLDHIGH}
  864. end
  865. else
  866. begin
  867. hp:=genordinalconstnode(Pstringdef(p^.left^.resulttype)^.len,u8bitdef);
  868. disposetree(p);
  869. p:=hp;
  870. firstpass(p);
  871. end;
  872. end;
  873. end;
  874. else
  875. CGMessage(type_e_mismatch);
  876. end;
  877. end
  878. else
  879. CGMessage(type_e_varid_or_typeid_expected);
  880. end;
  881. in_assert_x_y :
  882. begin
  883. p^.resulttype:=voiddef;
  884. if assigned(p^.left) then
  885. begin
  886. firstcallparan(p^.left,nil);
  887. p^.registers32:=p^.left^.registers32;
  888. p^.registersfpu:=p^.left^.registersfpu;
  889. {$ifdef SUPPORT_MMX}
  890. p^.registersmmx:=p^.left^.registersmmx;
  891. {$endif SUPPORT_MMX}
  892. { check type }
  893. if is_boolean(p^.left^.resulttype) then
  894. begin
  895. { must always be a string }
  896. p^.left^.right^.left:=gentypeconvnode(p^.left^.right^.left,cshortstringdef);
  897. firstpass(p^.left^.right^.left);
  898. end
  899. else
  900. CGMessage(type_e_mismatch);
  901. end
  902. else
  903. CGMessage(type_e_mismatch);
  904. end;
  905. else
  906. internalerror(8);
  907. end;
  908. end;
  909. { generate an error if no resulttype is set }
  910. if not assigned(p^.resulttype) then
  911. p^.resulttype:=generrordef;
  912. must_be_valid:=store_valid;
  913. count_ref:=store_count_ref;
  914. end;
  915. end.
  916. {
  917. $Log$
  918. Revision 1.16 1999-01-28 19:43:43 peter
  919. * fixed high generation for ansistrings with str,writeln
  920. Revision 1.15 1999/01/27 16:28:22 pierre
  921. * bug0157 solved : write(x:5.3) is rejected now
  922. Revision 1.14 1999/01/21 22:10:50 peter
  923. * fixed array of const
  924. * generic platform independent high() support
  925. Revision 1.13 1998/12/30 22:13:13 peter
  926. * check the amount of paras for Str()
  927. Revision 1.12 1998/12/15 10:23:31 peter
  928. + -iSO, -iSP, -iTO, -iTP
  929. Revision 1.11 1998/12/11 23:36:08 florian
  930. + again more stuff for int64/qword:
  931. - comparision operators
  932. - code generation for: str, read(ln), write(ln)
  933. Revision 1.10 1998/11/27 14:50:53 peter
  934. + open strings, $P switch support
  935. Revision 1.9 1998/11/24 17:04:28 peter
  936. * fixed length(char) when char is a variable
  937. Revision 1.8 1998/11/14 10:51:33 peter
  938. * fixed low/high for record.field
  939. Revision 1.7 1998/11/13 10:15:52 peter
  940. * fixed ptr() with constants
  941. Revision 1.6 1998/11/05 12:03:05 peter
  942. * released useansistring
  943. * removed -Sv, its now available in fpc modes
  944. Revision 1.5 1998/10/20 11:16:47 pierre
  945. + length(c) where C is a char is allways 1
  946. Revision 1.4 1998/10/06 20:49:11 peter
  947. * m68k compiler compiles again
  948. Revision 1.3 1998/10/05 12:32:49 peter
  949. + assert() support
  950. Revision 1.2 1998/10/02 09:24:23 peter
  951. * more constant expression evaluators
  952. Revision 1.1 1998/09/23 20:42:24 peter
  953. * splitted pass_1
  954. }