ptconst.pas 35 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865
  1. {
  2. $Id$
  3. Copyright (c) 1998 by Florian Klaempfl
  4. Reads typed constants
  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 ptconst;
  19. interface
  20. uses symtable;
  21. { this procedure reads typed constants }
  22. { sym is only needed for ansi strings }
  23. { the assembler label is in the middle (PM) }
  24. procedure readtypedconst(def : pdef;sym : ptypedconstsym;no_change_allowed : boolean);
  25. implementation
  26. uses
  27. globtype,systems,tokens,
  28. cobjects,globals,scanner,
  29. symconst,aasm,types,verbose,
  30. tree,pass_1,
  31. { parser specific stuff }
  32. pbase,pexpr,
  33. { processor specific stuff }
  34. cpubase,
  35. { codegen }
  36. {$ifdef newcg}
  37. cgbase,
  38. {$else}
  39. hcodegen,
  40. {$endif}
  41. hcgdata;
  42. { this procedure reads typed constants }
  43. procedure readtypedconst(def : pdef;sym : ptypedconstsym;no_change_allowed : boolean);
  44. var
  45. {$ifdef m68k}
  46. j : longint;
  47. {$endif m68k}
  48. len,base : longint;
  49. p,hp : ptree;
  50. i,l,offset,
  51. strlength : longint;
  52. curconstsegment : paasmoutput;
  53. ll : pasmlabel;
  54. s : string;
  55. ca : pchar;
  56. aktpos : longint;
  57. obj : pobjectdef;
  58. symt : psymtable;
  59. value : bestreal;
  60. procedure check_range;
  61. begin
  62. if ((p^.value>porddef(def)^.high) or
  63. (p^.value<porddef(def)^.low)) then
  64. begin
  65. if (cs_check_range in aktlocalswitches) then
  66. Message(parser_e_range_check_error)
  67. else
  68. Message(parser_w_range_check_error);
  69. end;
  70. end;
  71. (* function is_po_equal(o1,o2:longint):boolean;
  72. begin
  73. { assembler does not affect }
  74. is_po_equal:=(o1 and not(poassembler))=
  75. (o2 and not(poassembler));
  76. end; *)
  77. {$R-} {Range check creates problem with init_8bit(-1) !!}
  78. begin
  79. if no_change_allowed then
  80. curconstsegment:=consts
  81. else
  82. curconstsegment:=datasegment;
  83. case def^.deftype of
  84. orddef:
  85. begin
  86. p:=comp_expr(true);
  87. do_firstpass(p);
  88. case porddef(def)^.typ of
  89. s8bit,
  90. u8bit : begin
  91. if not is_constintnode(p) then
  92. { is't an int expected }
  93. Message(cg_e_illegal_expression)
  94. else
  95. begin
  96. curconstsegment^.concat(new(pai_const,init_8bit(p^.value)));
  97. check_range;
  98. end;
  99. end;
  100. s32bit : begin
  101. if not is_constintnode(p) then
  102. Message(cg_e_illegal_expression)
  103. else
  104. begin
  105. curconstsegment^.concat(new(pai_const,init_32bit(p^.value)));
  106. check_range;
  107. end;
  108. end;
  109. u32bit : begin
  110. if not is_constintnode(p) then
  111. Message(cg_e_illegal_expression)
  112. else
  113. curconstsegment^.concat(new(pai_const,init_32bit(p^.value)));
  114. end;
  115. bool8bit : begin
  116. if not is_constboolnode(p) then
  117. Message(cg_e_illegal_expression);
  118. curconstsegment^.concat(new(pai_const,init_8bit(p^.value)));
  119. end;
  120. bool16bit : begin
  121. if not is_constboolnode(p) then
  122. Message(cg_e_illegal_expression);
  123. curconstsegment^.concat(new(pai_const,init_16bit(p^.value)));
  124. end;
  125. bool32bit : begin
  126. if not is_constboolnode(p) then
  127. Message(cg_e_illegal_expression);
  128. curconstsegment^.concat(new(pai_const,init_32bit(p^.value)));
  129. end;
  130. uchar : begin
  131. if not is_constcharnode(p) then
  132. Message(cg_e_illegal_expression);
  133. curconstsegment^.concat(new(pai_const,init_8bit(p^.value)));
  134. end;
  135. u16bit,
  136. s16bit : begin
  137. if not is_constintnode(p) then
  138. Message(cg_e_illegal_expression);
  139. curconstsegment^.concat(new(pai_const,init_16bit(p^.value)));
  140. check_range;
  141. end;
  142. s64bit,
  143. u64bit:
  144. begin
  145. if not is_constintnode(p) then
  146. Message(cg_e_illegal_expression)
  147. else
  148. begin
  149. {!!!!! hmmm, we can write yet only consts til 2^32-1 :( (FK) }
  150. curconstsegment^.concat(new(pai_const,init_32bit(p^.value)));
  151. curconstsegment^.concat(new(pai_const,init_32bit(0)));
  152. end;
  153. end;
  154. else
  155. internalerror(3799);
  156. end;
  157. disposetree(p);
  158. end;
  159. floatdef:
  160. begin
  161. p:=comp_expr(true);
  162. do_firstpass(p);
  163. if is_constrealnode(p) then
  164. value:=p^.value_real
  165. else if is_constintnode(p) then
  166. value:=p^.value
  167. else
  168. Message(cg_e_illegal_expression);
  169. case pfloatdef(def)^.typ of
  170. s32real : curconstsegment^.concat(new(pai_real_32bit,init(value)));
  171. s64real : curconstsegment^.concat(new(pai_real_64bit,init(value)));
  172. s80real : curconstsegment^.concat(new(pai_real_80bit,init(value)));
  173. s64comp : curconstsegment^.concat(new(pai_comp_64bit,init(value)));
  174. f32bit : curconstsegment^.concat(new(pai_const,init_32bit(trunc(value*65536))));
  175. else internalerror(18);
  176. end;
  177. disposetree(p);
  178. end;
  179. classrefdef:
  180. begin
  181. p:=comp_expr(true);
  182. do_firstpass(p);
  183. case p^.treetype of
  184. loadvmtn:
  185. begin
  186. if not(pobjectdef(pclassrefdef(p^.resulttype)^.definition)^.is_related(
  187. pobjectdef(pclassrefdef(def)^.definition))) then
  188. Message(cg_e_illegal_expression);
  189. curconstsegment^.concat(new(pai_const_symbol,init(newasmsymbol(pobjectdef(
  190. pclassrefdef(p^.resulttype)^.definition)^.vmt_mangledname))));
  191. end;
  192. niln:
  193. curconstsegment^.concat(new(pai_const,init_32bit(0)));
  194. else Message(cg_e_illegal_expression);
  195. end;
  196. disposetree(p);
  197. end;
  198. pointerdef:
  199. begin
  200. p:=comp_expr(true);
  201. do_firstpass(p);
  202. if (p^.treetype=typeconvn) and
  203. ((p^.left^.treetype=addrn) or (p^.left^.treetype=niln)) and
  204. is_equal(def,p^.resulttype) then
  205. begin
  206. hp:=p^.left;
  207. putnode(p);
  208. p:=hp;
  209. end;
  210. { allows horrible ofs(typeof(TButton)^) code !! }
  211. if (p^.treetype=addrn) and (p^.left^.treetype=derefn) then
  212. begin
  213. hp:=p^.left^.left;
  214. p^.left^.left:=nil;
  215. disposetree(p);
  216. p:=hp;
  217. end;
  218. { nil pointer ? }
  219. if p^.treetype=niln then
  220. curconstsegment^.concat(new(pai_const,init_32bit(0)))
  221. { maybe pchar ? }
  222. else
  223. if (ppointerdef(def)^.definition^.deftype=orddef) and
  224. (porddef(ppointerdef(def)^.definition)^.typ=uchar) and
  225. (p^.treetype<>addrn) then
  226. begin
  227. getdatalabel(ll);
  228. curconstsegment^.concat(new(pai_const_symbol,init(ll)));
  229. consts^.concat(new(pai_label,init(ll)));
  230. if p^.treetype=stringconstn then
  231. begin
  232. getmem(ca,p^.length+2);
  233. move(p^.value_str^,ca^,p^.length+1);
  234. consts^.concat(new(pai_string,init_length_pchar(ca,p^.length+1)));
  235. end
  236. else
  237. if is_constcharnode(p) then
  238. consts^.concat(new(pai_string,init(char(byte(p^.value))+#0)))
  239. else
  240. Message(cg_e_illegal_expression);
  241. end
  242. else
  243. if p^.treetype=addrn then
  244. begin
  245. hp:=p^.left;
  246. while assigned(hp) and (hp^.treetype in [subscriptn,vecn]) do
  247. hp:=hp^.left;
  248. if (is_equal(ppointerdef(p^.resulttype)^.definition,ppointerdef(def)^.definition) or
  249. (is_equal(ppointerdef(p^.resulttype)^.definition,voiddef)) or
  250. (is_equal(ppointerdef(def)^.definition,voiddef))) and
  251. (hp^.treetype=loadn) then
  252. begin
  253. do_firstpass(p^.left);
  254. hp:=p^.left;
  255. offset:=0;
  256. while assigned(hp) and (hp^.treetype<>loadn) do
  257. begin
  258. case hp^.treetype of
  259. vecn :
  260. begin
  261. if (hp^.left^.resulttype^.deftype=stringdef) then
  262. begin
  263. { this seems OK for shortstring and ansistrings PM }
  264. { it is wrong for widestrings !! }
  265. len:=1;
  266. base:=0;
  267. end
  268. else if (hp^.left^.resulttype^.deftype=arraydef) then
  269. begin
  270. len:=parraydef(hp^.left^.resulttype)^.elesize;
  271. base:=parraydef(hp^.left^.resulttype)^.lowrange;
  272. end
  273. else
  274. Message(cg_e_illegal_expression);
  275. if is_constintnode(hp^.right) then
  276. inc(offset,len*(get_ordinal_value(hp^.right)-base))
  277. else
  278. Message(cg_e_illegal_expression);
  279. {internalerror(9779);}
  280. end;
  281. subscriptn : inc(offset,hp^.vs^.address)
  282. else
  283. Message(cg_e_illegal_expression);
  284. end;
  285. hp:=hp^.left;
  286. end;
  287. if hp^.symtableentry^.typ=constsym then
  288. Message(type_e_variable_id_expected);
  289. curconstsegment^.concat(new(pai_const_symbol,initname_offset(hp^.symtableentry^.mangledname,offset)));
  290. (*if token=POINT then
  291. begin
  292. offset:=0;
  293. while token=_POINT do
  294. begin
  295. consume(_POINT);
  296. lsym:=pvarsym(precdef(
  297. ppointerdef(p^.resulttype)^.definition)^.symtable^.search(pattern));
  298. if assigned(sym) then
  299. offset:=offset+lsym^.address
  300. else
  301. begin
  302. Message1(sym_e_illegal_field,pattern);
  303. end;
  304. consume(_ID);
  305. end;
  306. curconstsegment^.concat(new(pai_const_symbol_offset,init(
  307. strpnew(p^.left^.symtableentry^.mangledname),offset)));
  308. end
  309. else
  310. begin
  311. curconstsegment^.concat(new(pai_const,init_symbol(
  312. strpnew(p^.left^.symtableentry^.mangledname))));
  313. end; *)
  314. end
  315. else
  316. Message(cg_e_illegal_expression);
  317. end
  318. else
  319. { allow typeof(Object type)}
  320. if (p^.treetype=inlinen) and
  321. (p^.inlinenumber=in_typeof_x) then
  322. begin
  323. if (p^.left^.treetype=typen) then
  324. begin
  325. curconstsegment^.concat(new(pai_const_symbol,
  326. initname(pobjectdef(p^.left^.resulttype)^.vmt_mangledname)));
  327. end
  328. else
  329. Message(cg_e_illegal_expression);
  330. end
  331. else
  332. Message(cg_e_illegal_expression);
  333. disposetree(p);
  334. end;
  335. setdef:
  336. begin
  337. p:=comp_expr(true);
  338. do_firstpass(p);
  339. if p^.treetype=setconstn then
  340. begin
  341. { we only allow const sets }
  342. if assigned(p^.left) then
  343. Message(cg_e_illegal_expression)
  344. else
  345. begin
  346. {$ifdef i386}
  347. for l:=0 to def^.size-1 do
  348. curconstsegment^.concat(new(pai_const,init_8bit(p^.value_set^[l])));
  349. {$endif}
  350. {$ifdef m68k}
  351. j:=0;
  352. for l:=0 to ((def^.size-1) div 4) do
  353. { HORRIBLE HACK because of endian }
  354. { now use intel endian for constant sets }
  355. begin
  356. curconstsegment^.concat(new(pai_const,init_8bit(p^.value_set^[j+3])));
  357. curconstsegment^.concat(new(pai_const,init_8bit(p^.value_set^[j+2])));
  358. curconstsegment^.concat(new(pai_const,init_8bit(p^.value_set^[j+1])));
  359. curconstsegment^.concat(new(pai_const,init_8bit(p^.value_set^[j])));
  360. Inc(j,4);
  361. end;
  362. {$endif}
  363. end;
  364. end
  365. else
  366. Message(cg_e_illegal_expression);
  367. disposetree(p);
  368. end;
  369. enumdef:
  370. begin
  371. p:=comp_expr(true);
  372. do_firstpass(p);
  373. if p^.treetype=ordconstn then
  374. begin
  375. if is_equal(p^.resulttype,def) then
  376. curconstsegment^.concat(new(pai_const,init_32bit(p^.value)))
  377. else
  378. Message(cg_e_illegal_expression);
  379. end
  380. else
  381. Message(cg_e_illegal_expression);
  382. disposetree(p);
  383. end;
  384. stringdef:
  385. begin
  386. p:=comp_expr(true);
  387. do_firstpass(p);
  388. { first take care of prefixes for long and ansi strings }
  389. case pstringdef(def)^.string_typ of
  390. st_shortstring:
  391. begin
  392. if p^.treetype=stringconstn then
  393. begin
  394. if p^.length>=def^.size then
  395. strlength:=def^.size-1
  396. else
  397. strlength:=p^.length;
  398. curconstsegment^.concat(new(pai_const,init_8bit(strlength)));
  399. { this can also handle longer strings }
  400. getmem(ca,strlength+1);
  401. move(p^.value_str^,ca^,strlength);
  402. ca[strlength]:=#0;
  403. curconstsegment^.concat(new(pai_string,init_length_pchar(ca,strlength)));
  404. end
  405. else if is_constcharnode(p) then
  406. begin
  407. curconstsegment^.concat(new(pai_string,init(#1+char(byte(p^.value)))));
  408. strlength:=1;
  409. end
  410. else Message(cg_e_illegal_expression);
  411. if def^.size>strlength then
  412. begin
  413. getmem(ca,def^.size-strlength);
  414. { def^.size contains also the leading length, so we }
  415. { we have to subtract one }
  416. fillchar(ca[0],def^.size-strlength-1,' ');
  417. ca[def^.size-strlength-1]:=#0;
  418. { this can also handle longer strings }
  419. curconstsegment^.concat(new(pai_string,init_length_pchar(ca,def^.size-strlength-1)));
  420. end;
  421. end;
  422. {$ifdef UseLongString}
  423. st_longstring:
  424. begin
  425. if is_constcharnode(p) then
  426. strlength:=1
  427. else
  428. strlength:=p^.length;
  429. { first write the maximum size }
  430. curconstsegment^.concat(new(pai_const,init_32bit(strlength)))));
  431. { fill byte }
  432. curconstsegment^.concat(new(pai_const,init_8bit(0)));
  433. if p^.treetype=stringconstn then
  434. begin
  435. getmem(ca,strlength+1);
  436. move(p^.value_str^,ca^,strlength);
  437. ca[strlength]:=#0;
  438. generate_pascii(consts,ca,strlength);
  439. end
  440. else if is_constcharnode(p) then
  441. begin
  442. consts^.concat(new(pai_const,init_8bit(p^.value)));
  443. end
  444. else Message(cg_e_illegal_expression);
  445. curconstsegment^.concat(new(pai_const,init_8bit(0)));
  446. end;
  447. {$endif UseLongString}
  448. st_ansistring:
  449. begin
  450. { an empty ansi string is nil! }
  451. if (p^.treetype=stringconstn) and (p^.length=0) then
  452. curconstsegment^.concat(new(pai_const,init_32bit(0)))
  453. else
  454. begin
  455. if is_constcharnode(p) then
  456. strlength:=1
  457. else
  458. strlength:=p^.length;
  459. getdatalabel(ll);
  460. curconstsegment^.concat(new(pai_const_symbol,init(ll)));
  461. { first write the maximum size }
  462. consts^.concat(new(pai_const,init_32bit(strlength)));
  463. { second write the real length }
  464. consts^.concat(new(pai_const,init_32bit(strlength)));
  465. { redondent with maxlength but who knows ... (PM) }
  466. { third write use count (set to -1 for safety ) }
  467. consts^.concat(new(pai_const,init_32bit(-1)));
  468. consts^.concat(new(pai_label,init(ll)));
  469. if p^.treetype=stringconstn then
  470. begin
  471. getmem(ca,strlength+1);
  472. move(p^.value_str^,ca^,strlength);
  473. ca[strlength]:=#0;
  474. consts^.concat(new(pai_string,init_length_pchar(ca,strlength)));
  475. end
  476. else if is_constcharnode(p) then
  477. begin
  478. consts^.concat(new(pai_const,init_8bit(p^.value)));
  479. end
  480. else Message(cg_e_illegal_expression);
  481. consts^.concat(new(pai_const,init_8bit(0)));
  482. end;
  483. end;
  484. end;
  485. disposetree(p);
  486. end;
  487. arraydef:
  488. begin
  489. if token=_LKLAMMER then
  490. begin
  491. consume(_LKLAMMER);
  492. for l:=parraydef(def)^.lowrange to parraydef(def)^.highrange-1 do
  493. begin
  494. readtypedconst(parraydef(def)^.definition,nil,no_change_allowed);
  495. consume(_COMMA);
  496. end;
  497. readtypedconst(parraydef(def)^.definition,nil,no_change_allowed);
  498. consume(_RKLAMMER);
  499. end
  500. else
  501. { if array of char then we allow also a string }
  502. if is_char(parraydef(def)^.definition) then
  503. begin
  504. p:=comp_expr(true);
  505. do_firstpass(p);
  506. if p^.treetype=stringconstn then
  507. begin
  508. if p^.length>255 then
  509. len:=255
  510. else
  511. len:=p^.length;
  512. {$ifndef TP}
  513. {$ifopt H+}
  514. setlength(s,len);
  515. {$else}
  516. s[0]:=chr(len);
  517. {$endif}
  518. {$else}
  519. s[0]:=chr(len);
  520. {$endif}
  521. move(p^.value_str^,s[1],len);
  522. end
  523. else
  524. if is_constcharnode(p) then
  525. s:=char(byte(p^.value))
  526. else
  527. begin
  528. Message(cg_e_illegal_expression);
  529. s:='';
  530. end;
  531. disposetree(p);
  532. l:=length(s);
  533. for i:=Parraydef(def)^.lowrange to Parraydef(def)^.highrange do
  534. begin
  535. if i+1-Parraydef(def)^.lowrange<=l then
  536. begin
  537. curconstsegment^.concat(new(pai_const,init_8bit(byte(s[1]))));
  538. delete(s,1,1);
  539. end
  540. else
  541. {Fill the remaining positions with #0.}
  542. curconstsegment^.concat(new(pai_const,init_8bit(0)));
  543. end;
  544. if length(s)>0 then
  545. Message(parser_e_string_larger_array);
  546. end
  547. else
  548. begin
  549. { we want the ( }
  550. consume(_LKLAMMER);
  551. end;
  552. end;
  553. procvardef:
  554. begin
  555. { Procvars and pointers are no longer compatible. }
  556. { under tp: =nil or =var under fpc: =nil or =@var }
  557. if token=_NIL then
  558. begin
  559. curconstsegment^.concat(new(pai_const,init_32bit(0)));
  560. consume(_NIL);
  561. exit;
  562. end
  563. else
  564. if not(m_tp_procvar in aktmodeswitches) then
  565. if token=_KLAMMERAFFE then
  566. consume(_KLAMMERAFFE);
  567. getprocvar:=true;
  568. getprocvardef:=pprocvardef(def);
  569. p:=comp_expr(true);
  570. getprocvar:=false;
  571. do_firstpass(p);
  572. if codegenerror then
  573. begin
  574. disposetree(p);
  575. exit;
  576. end;
  577. { convert calln to loadn }
  578. if p^.treetype=calln then
  579. begin
  580. if (p^.symtableprocentry^.owner^.symtabletype=objectsymtable) and
  581. (pobjectdef(p^.symtableprocentry^.owner^.defowner)^.is_class) then
  582. hp:=genloadmethodcallnode(pprocsym(p^.symtableprocentry),p^.symtableproc,
  583. getcopy(p^.methodpointer))
  584. else
  585. hp:=genloadcallnode(pprocsym(p^.symtableprocentry),p^.symtableproc);
  586. disposetree(p);
  587. do_firstpass(hp);
  588. p:=hp;
  589. if codegenerror then
  590. begin
  591. disposetree(p);
  592. exit;
  593. end;
  594. end;
  595. { let type conversion check everything needed }
  596. p:=gentypeconvnode(p,def);
  597. do_firstpass(p);
  598. if codegenerror then
  599. begin
  600. disposetree(p);
  601. exit;
  602. end;
  603. { remove typeconvn, that will normally insert a lea
  604. instruction which is not necessary for us }
  605. if p^.treetype=typeconvn then
  606. begin
  607. hp:=p^.left;
  608. putnode(p);
  609. p:=hp;
  610. end;
  611. { remove addrn which we also don't need here }
  612. if p^.treetype=addrn then
  613. begin
  614. hp:=p^.left;
  615. putnode(p);
  616. p:=hp;
  617. end;
  618. { we now need to have a loadn with a procsym }
  619. if (p^.treetype=loadn) and
  620. (p^.symtableentry^.typ=procsym) then
  621. begin
  622. curconstsegment^.concat(new(pai_const_symbol,
  623. initname(pprocsym(p^.symtableentry)^.definition^.mangledname)));
  624. end
  625. else
  626. Message(cg_e_illegal_expression);
  627. disposetree(p);
  628. end;
  629. { reads a typed constant record }
  630. recorddef:
  631. begin
  632. consume(_LKLAMMER);
  633. aktpos:=0;
  634. while token<>_RKLAMMER do
  635. begin
  636. s:=pattern;
  637. consume(_ID);
  638. consume(_COLON);
  639. srsym:=precorddef(def)^.symtable^.search(s);
  640. if srsym=nil then
  641. begin
  642. Message1(sym_e_id_not_found,s);
  643. consume_all_until(_SEMICOLON);
  644. end
  645. else
  646. begin
  647. { check position }
  648. if pvarsym(srsym)^.address<aktpos then
  649. Message(parser_e_invalid_record_const);
  650. { if needed fill }
  651. if pvarsym(srsym)^.address>aktpos then
  652. for i:=1 to pvarsym(srsym)^.address-aktpos do
  653. curconstsegment^.concat(new(pai_const,init_8bit(0)));
  654. { new position }
  655. aktpos:=pvarsym(srsym)^.address+pvarsym(srsym)^.definition^.size;
  656. { read the data }
  657. readtypedconst(pvarsym(srsym)^.definition,nil,no_change_allowed);
  658. if token=_SEMICOLON then
  659. consume(_SEMICOLON)
  660. else break;
  661. end;
  662. end;
  663. for i:=1 to def^.size-aktpos do
  664. curconstsegment^.concat(new(pai_const,init_8bit(0)));
  665. consume(_RKLAMMER);
  666. end;
  667. { reads a typed object }
  668. objectdef:
  669. begin
  670. if ([oo_has_vmt,oo_is_class]*pobjectdef(def)^.objectoptions)<>[] then
  671. begin
  672. Message(parser_e_type_const_not_possible);
  673. consume_all_until(_RKLAMMER);
  674. end
  675. else
  676. begin
  677. consume(_LKLAMMER);
  678. aktpos:=0;
  679. while token<>_RKLAMMER do
  680. begin
  681. s:=pattern;
  682. consume(_ID);
  683. consume(_COLON);
  684. srsym:=nil;
  685. obj:=pobjectdef(def);
  686. symt:=obj^.symtable;
  687. while (srsym=nil) and assigned(symt) do
  688. begin
  689. srsym:=symt^.search(s);
  690. if assigned(obj) then
  691. obj:=obj^.childof;
  692. if assigned(obj) then
  693. symt:=obj^.symtable
  694. else
  695. symt:=nil;
  696. end;
  697. if srsym=nil then
  698. begin
  699. Message1(sym_e_id_not_found,s);
  700. consume_all_until(_SEMICOLON);
  701. end
  702. else
  703. begin
  704. { check position }
  705. if pvarsym(srsym)^.address<aktpos then
  706. Message(parser_e_invalid_record_const);
  707. { if needed fill }
  708. if pvarsym(srsym)^.address>aktpos then
  709. for i:=1 to pvarsym(srsym)^.address-aktpos do
  710. curconstsegment^.concat(new(pai_const,init_8bit(0)));
  711. { new position }
  712. aktpos:=pvarsym(srsym)^.address+pvarsym(srsym)^.definition^.size;
  713. { read the data }
  714. readtypedconst(pvarsym(srsym)^.definition,nil,no_change_allowed);
  715. if token=_SEMICOLON then
  716. consume(_SEMICOLON)
  717. else break;
  718. end;
  719. end;
  720. for i:=1 to def^.size-aktpos do
  721. curconstsegment^.concat(new(pai_const,init_8bit(0)));
  722. consume(_RKLAMMER);
  723. end;
  724. end;
  725. errordef:
  726. begin
  727. { try to consume something useful }
  728. if token=_LKLAMMER then
  729. consume_all_until(_RKLAMMER)
  730. else
  731. consume_all_until(_SEMICOLON);
  732. end;
  733. else Message(parser_e_type_const_not_possible);
  734. end;
  735. end;
  736. end.
  737. {
  738. $Log$
  739. Revision 1.58 1999-11-08 18:50:11 florian
  740. * disposetree for classrefdef added
  741. Revision 1.57 1999/11/08 16:24:28 pierre
  742. * missing disposetree added to avoid memory loss
  743. Revision 1.56 1999/11/08 14:02:16 florian
  744. * problem with "index X"-properties solved
  745. * typed constants of class references are now allowed
  746. Revision 1.55 1999/11/06 14:34:23 peter
  747. * truncated log to 20 revs
  748. Revision 1.54 1999/10/14 14:57:54 florian
  749. - removed the hcodegen use in the new cg, use cgbase instead
  750. Revision 1.53 1999/09/26 21:30:20 peter
  751. + constant pointer support which can happend with typecasting like
  752. const p=pointer(1)
  753. * better procvar parsing in typed consts
  754. Revision 1.52 1999/08/10 12:30:02 pierre
  755. * avoid unused locals
  756. Revision 1.51 1999/08/04 13:03:02 jonas
  757. * all tokens now start with an underscore
  758. * PowerPC compiles!!
  759. Revision 1.50 1999/08/04 00:23:21 florian
  760. * renamed i386asm and i386base to cpuasm and cpubase
  761. Revision 1.49 1999/08/03 22:03:08 peter
  762. * moved bitmask constants to sets
  763. * some other type/const renamings
  764. Revision 1.48 1999/07/23 16:05:26 peter
  765. * alignment is now saved in the symtable
  766. * C alignment added for records
  767. * PPU version increased to solve .12 <-> .13 probs
  768. Revision 1.47 1999/07/03 14:14:28 florian
  769. + start of val(int64/qword)
  770. * longbool, wordbool constants weren't written, fixed
  771. Revision 1.46 1999/05/27 19:44:54 peter
  772. * removed oldasm
  773. * plabel -> pasmlabel
  774. * -a switches to source writing automaticly
  775. * assembler readers OOPed
  776. * asmsymbol automaticly external
  777. * jumptables and other label fixes for asm readers
  778. Revision 1.45 1999/05/23 18:42:13 florian
  779. * better error recovering in typed constants
  780. * some problems with arrays of const fixed, some problems
  781. due my previous
  782. - the location type of array constructor is now LOC_MEM
  783. - the pushing of high fixed
  784. - parameter copying fixed
  785. - zero temp. allocation removed
  786. * small problem in the assembler writers fixed:
  787. ref to nil wasn't written correctly
  788. Revision 1.44 1999/05/21 13:55:11 peter
  789. * NEWLAB for label as symbol
  790. Revision 1.43 1999/05/12 00:19:54 peter
  791. * removed R_DEFAULT_SEG
  792. * uniform float names
  793. Revision 1.42 1999/05/06 09:05:24 peter
  794. * generic write_float and str_float
  795. * fixed constant float conversions
  796. Revision 1.41 1999/05/01 13:24:39 peter
  797. * merged nasm compiler
  798. * old asm moved to oldasm/
  799. Revision 1.40 1999/04/25 22:42:17 pierre
  800. + code for initialized vars in Delphi mode
  801. Revision 1.39 1999/03/24 23:17:21 peter
  802. * fixed bugs 212,222,225,227,229,231,233
  803. Revision 1.38 1999/02/25 21:02:45 peter
  804. * ag386bin updates
  805. + coff writer
  806. Revision 1.37 1999/02/22 02:44:13 peter
  807. * ag386bin doesn't use i386.pas anymore
  808. Revision 1.36 1999/02/17 10:15:26 peter
  809. * fixed error messages when parsing typed const array
  810. Revision 1.35 1999/01/20 14:09:28 pierre
  811. * fix to bug0191
  812. }