ptconst.pas 35 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867
  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)^.pointertype.def)^.is_related(
  187. pobjectdef(pclassrefdef(def)^.pointertype.def))) then
  188. Message(cg_e_illegal_expression);
  189. curconstsegment^.concat(new(pai_const_symbol,init(newasmsymbol(pobjectdef(
  190. pclassrefdef(p^.resulttype)^.pointertype.def)^.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 is_char(ppointerdef(def)^.pointertype.def) and
  224. (p^.treetype<>addrn) then
  225. begin
  226. getdatalabel(ll);
  227. curconstsegment^.concat(new(pai_const_symbol,init(ll)));
  228. consts^.concat(new(pai_label,init(ll)));
  229. if p^.treetype=stringconstn then
  230. begin
  231. getmem(ca,p^.length+2);
  232. move(p^.value_str^,ca^,p^.length+1);
  233. consts^.concat(new(pai_string,init_length_pchar(ca,p^.length+1)));
  234. end
  235. else
  236. if is_constcharnode(p) then
  237. consts^.concat(new(pai_string,init(char(byte(p^.value))+#0)))
  238. else
  239. Message(cg_e_illegal_expression);
  240. end
  241. else
  242. if p^.treetype=addrn then
  243. begin
  244. hp:=p^.left;
  245. while assigned(hp) and (hp^.treetype in [subscriptn,vecn]) do
  246. hp:=hp^.left;
  247. if (is_equal(ppointerdef(p^.resulttype)^.pointertype.def,ppointerdef(def)^.pointertype.def) or
  248. (is_equal(ppointerdef(p^.resulttype)^.pointertype.def,voiddef)) or
  249. (is_equal(ppointerdef(def)^.pointertype.def,voiddef))) and
  250. (hp^.treetype=loadn) then
  251. begin
  252. do_firstpass(p^.left);
  253. hp:=p^.left;
  254. offset:=0;
  255. while assigned(hp) and (hp^.treetype<>loadn) do
  256. begin
  257. case hp^.treetype of
  258. vecn :
  259. begin
  260. if (hp^.left^.resulttype^.deftype=stringdef) then
  261. begin
  262. { this seems OK for shortstring and ansistrings PM }
  263. { it is wrong for widestrings !! }
  264. len:=1;
  265. base:=0;
  266. end
  267. else if (hp^.left^.resulttype^.deftype=arraydef) then
  268. begin
  269. len:=parraydef(hp^.left^.resulttype)^.elesize;
  270. base:=parraydef(hp^.left^.resulttype)^.lowrange;
  271. end
  272. else
  273. Message(cg_e_illegal_expression);
  274. if is_constintnode(hp^.right) then
  275. inc(offset,len*(get_ordinal_value(hp^.right)-base))
  276. else
  277. Message(cg_e_illegal_expression);
  278. {internalerror(9779);}
  279. end;
  280. subscriptn : inc(offset,hp^.vs^.address)
  281. else
  282. Message(cg_e_illegal_expression);
  283. end;
  284. hp:=hp^.left;
  285. end;
  286. if hp^.symtableentry^.typ=constsym then
  287. Message(type_e_variable_id_expected);
  288. curconstsegment^.concat(new(pai_const_symbol,initname_offset(hp^.symtableentry^.mangledname,offset)));
  289. (*if token=POINT then
  290. begin
  291. offset:=0;
  292. while token=_POINT do
  293. begin
  294. consume(_POINT);
  295. lsym:=pvarsym(precdef(
  296. ppointerdef(p^.resulttype)^.pointertype.def)^.symtable^.search(pattern));
  297. if assigned(sym) then
  298. offset:=offset+lsym^.address
  299. else
  300. begin
  301. Message1(sym_e_illegal_field,pattern);
  302. end;
  303. consume(_ID);
  304. end;
  305. curconstsegment^.concat(new(pai_const_symbol_offset,init(
  306. strpnew(p^.left^.symtableentry^.mangledname),offset)));
  307. end
  308. else
  309. begin
  310. curconstsegment^.concat(new(pai_const,init_symbol(
  311. strpnew(p^.left^.symtableentry^.mangledname))));
  312. end; *)
  313. end
  314. else
  315. Message(cg_e_illegal_expression);
  316. end
  317. else
  318. { allow typeof(Object type)}
  319. if (p^.treetype=inlinen) and
  320. (p^.inlinenumber=in_typeof_x) then
  321. begin
  322. if (p^.left^.treetype=typen) then
  323. begin
  324. curconstsegment^.concat(new(pai_const_symbol,
  325. initname(pobjectdef(p^.left^.resulttype)^.vmt_mangledname)));
  326. end
  327. else
  328. Message(cg_e_illegal_expression);
  329. end
  330. else
  331. Message(cg_e_illegal_expression);
  332. disposetree(p);
  333. end;
  334. setdef:
  335. begin
  336. p:=comp_expr(true);
  337. do_firstpass(p);
  338. if p^.treetype=setconstn then
  339. begin
  340. { we only allow const sets }
  341. if assigned(p^.left) then
  342. Message(cg_e_illegal_expression)
  343. else
  344. begin
  345. {$ifdef i386}
  346. for l:=0 to def^.size-1 do
  347. curconstsegment^.concat(new(pai_const,init_8bit(p^.value_set^[l])));
  348. {$endif}
  349. {$ifdef m68k}
  350. j:=0;
  351. for l:=0 to ((def^.size-1) div 4) do
  352. { HORRIBLE HACK because of endian }
  353. { now use intel endian for constant sets }
  354. begin
  355. curconstsegment^.concat(new(pai_const,init_8bit(p^.value_set^[j+3])));
  356. curconstsegment^.concat(new(pai_const,init_8bit(p^.value_set^[j+2])));
  357. curconstsegment^.concat(new(pai_const,init_8bit(p^.value_set^[j+1])));
  358. curconstsegment^.concat(new(pai_const,init_8bit(p^.value_set^[j])));
  359. Inc(j,4);
  360. end;
  361. {$endif}
  362. end;
  363. end
  364. else
  365. Message(cg_e_illegal_expression);
  366. disposetree(p);
  367. end;
  368. enumdef:
  369. begin
  370. p:=comp_expr(true);
  371. do_firstpass(p);
  372. if p^.treetype=ordconstn then
  373. begin
  374. if is_equal(p^.resulttype,def) then
  375. curconstsegment^.concat(new(pai_const,init_32bit(p^.value)))
  376. else
  377. Message(cg_e_illegal_expression);
  378. end
  379. else
  380. Message(cg_e_illegal_expression);
  381. disposetree(p);
  382. end;
  383. stringdef:
  384. begin
  385. p:=comp_expr(true);
  386. do_firstpass(p);
  387. { first take care of prefixes for long and ansi strings }
  388. case pstringdef(def)^.string_typ of
  389. st_shortstring:
  390. begin
  391. if p^.treetype=stringconstn then
  392. begin
  393. if p^.length>=def^.size then
  394. strlength:=def^.size-1
  395. else
  396. strlength:=p^.length;
  397. curconstsegment^.concat(new(pai_const,init_8bit(strlength)));
  398. { this can also handle longer strings }
  399. getmem(ca,strlength+1);
  400. move(p^.value_str^,ca^,strlength);
  401. ca[strlength]:=#0;
  402. curconstsegment^.concat(new(pai_string,init_length_pchar(ca,strlength)));
  403. end
  404. else if is_constcharnode(p) then
  405. begin
  406. curconstsegment^.concat(new(pai_string,init(#1+char(byte(p^.value)))));
  407. strlength:=1;
  408. end
  409. else Message(cg_e_illegal_expression);
  410. if def^.size>strlength then
  411. begin
  412. getmem(ca,def^.size-strlength);
  413. { def^.size contains also the leading length, so we }
  414. { we have to subtract one }
  415. fillchar(ca[0],def^.size-strlength-1,' ');
  416. ca[def^.size-strlength-1]:=#0;
  417. { this can also handle longer strings }
  418. curconstsegment^.concat(new(pai_string,init_length_pchar(ca,def^.size-strlength-1)));
  419. end;
  420. end;
  421. {$ifdef UseLongString}
  422. st_longstring:
  423. begin
  424. if is_constcharnode(p) then
  425. strlength:=1
  426. else
  427. strlength:=p^.length;
  428. { first write the maximum size }
  429. curconstsegment^.concat(new(pai_const,init_32bit(strlength)))));
  430. { fill byte }
  431. curconstsegment^.concat(new(pai_const,init_8bit(0)));
  432. if p^.treetype=stringconstn then
  433. begin
  434. getmem(ca,strlength+1);
  435. move(p^.value_str^,ca^,strlength);
  436. ca[strlength]:=#0;
  437. generate_pascii(consts,ca,strlength);
  438. end
  439. else if is_constcharnode(p) then
  440. begin
  441. consts^.concat(new(pai_const,init_8bit(p^.value)));
  442. end
  443. else Message(cg_e_illegal_expression);
  444. curconstsegment^.concat(new(pai_const,init_8bit(0)));
  445. end;
  446. {$endif UseLongString}
  447. st_ansistring:
  448. begin
  449. { an empty ansi string is nil! }
  450. if (p^.treetype=stringconstn) and (p^.length=0) then
  451. curconstsegment^.concat(new(pai_const,init_32bit(0)))
  452. else
  453. begin
  454. if is_constcharnode(p) then
  455. strlength:=1
  456. else
  457. strlength:=p^.length;
  458. getdatalabel(ll);
  459. curconstsegment^.concat(new(pai_const_symbol,init(ll)));
  460. { first write the maximum size }
  461. consts^.concat(new(pai_const,init_32bit(strlength)));
  462. { second write the real length }
  463. consts^.concat(new(pai_const,init_32bit(strlength)));
  464. { redondent with maxlength but who knows ... (PM) }
  465. { third write use count (set to -1 for safety ) }
  466. consts^.concat(new(pai_const,init_32bit(-1)));
  467. consts^.concat(new(pai_label,init(ll)));
  468. if p^.treetype=stringconstn then
  469. begin
  470. getmem(ca,strlength+1);
  471. move(p^.value_str^,ca^,strlength);
  472. ca[strlength]:=#0;
  473. consts^.concat(new(pai_string,init_length_pchar(ca,strlength)));
  474. end
  475. else if is_constcharnode(p) then
  476. begin
  477. consts^.concat(new(pai_const,init_8bit(p^.value)));
  478. end
  479. else Message(cg_e_illegal_expression);
  480. consts^.concat(new(pai_const,init_8bit(0)));
  481. end;
  482. end;
  483. end;
  484. disposetree(p);
  485. end;
  486. arraydef:
  487. begin
  488. if token=_LKLAMMER then
  489. begin
  490. consume(_LKLAMMER);
  491. for l:=parraydef(def)^.lowrange to parraydef(def)^.highrange-1 do
  492. begin
  493. readtypedconst(parraydef(def)^.elementtype.def,nil,no_change_allowed);
  494. consume(_COMMA);
  495. end;
  496. readtypedconst(parraydef(def)^.elementtype.def,nil,no_change_allowed);
  497. consume(_RKLAMMER);
  498. end
  499. else
  500. { if array of char then we allow also a string }
  501. if is_char(parraydef(def)^.elementtype.def) then
  502. begin
  503. p:=comp_expr(true);
  504. do_firstpass(p);
  505. if p^.treetype=stringconstn then
  506. begin
  507. if p^.length>255 then
  508. len:=255
  509. else
  510. len:=p^.length;
  511. {$ifndef TP}
  512. {$ifopt H+}
  513. setlength(s,len);
  514. {$else}
  515. s[0]:=chr(len);
  516. {$endif}
  517. {$else}
  518. s[0]:=chr(len);
  519. {$endif}
  520. move(p^.value_str^,s[1],len);
  521. end
  522. else
  523. if is_constcharnode(p) then
  524. s:=char(byte(p^.value))
  525. else
  526. begin
  527. Message(cg_e_illegal_expression);
  528. s:='';
  529. end;
  530. disposetree(p);
  531. l:=length(s);
  532. for i:=Parraydef(def)^.lowrange to Parraydef(def)^.highrange do
  533. begin
  534. if i+1-Parraydef(def)^.lowrange<=l then
  535. begin
  536. curconstsegment^.concat(new(pai_const,init_8bit(byte(s[1]))));
  537. delete(s,1,1);
  538. end
  539. else
  540. {Fill the remaining positions with #0.}
  541. curconstsegment^.concat(new(pai_const,init_8bit(0)));
  542. end;
  543. if length(s)>0 then
  544. Message(parser_e_string_larger_array);
  545. end
  546. else
  547. begin
  548. { we want the ( }
  549. consume(_LKLAMMER);
  550. end;
  551. end;
  552. procvardef:
  553. begin
  554. { Procvars and pointers are no longer compatible. }
  555. { under tp: =nil or =var under fpc: =nil or =@var }
  556. if token=_NIL then
  557. begin
  558. curconstsegment^.concat(new(pai_const,init_32bit(0)));
  559. consume(_NIL);
  560. exit;
  561. end
  562. else
  563. if not(m_tp_procvar in aktmodeswitches) then
  564. if token=_KLAMMERAFFE then
  565. consume(_KLAMMERAFFE);
  566. getprocvar:=true;
  567. getprocvardef:=pprocvardef(def);
  568. p:=comp_expr(true);
  569. getprocvar:=false;
  570. do_firstpass(p);
  571. if codegenerror then
  572. begin
  573. disposetree(p);
  574. exit;
  575. end;
  576. { convert calln to loadn }
  577. if p^.treetype=calln then
  578. begin
  579. if (p^.symtableprocentry^.owner^.symtabletype=objectsymtable) and
  580. (pobjectdef(p^.symtableprocentry^.owner^.defowner)^.is_class) then
  581. hp:=genloadmethodcallnode(pprocsym(p^.symtableprocentry),p^.symtableproc,
  582. getcopy(p^.methodpointer))
  583. else
  584. hp:=genloadcallnode(pprocsym(p^.symtableprocentry),p^.symtableproc);
  585. disposetree(p);
  586. do_firstpass(hp);
  587. p:=hp;
  588. if codegenerror then
  589. begin
  590. disposetree(p);
  591. exit;
  592. end;
  593. end;
  594. { let type conversion check everything needed }
  595. p:=gentypeconvnode(p,def);
  596. do_firstpass(p);
  597. if codegenerror then
  598. begin
  599. disposetree(p);
  600. exit;
  601. end;
  602. { remove typeconvn, that will normally insert a lea
  603. instruction which is not necessary for us }
  604. if p^.treetype=typeconvn then
  605. begin
  606. hp:=p^.left;
  607. putnode(p);
  608. p:=hp;
  609. end;
  610. { remove addrn which we also don't need here }
  611. if p^.treetype=addrn then
  612. begin
  613. hp:=p^.left;
  614. putnode(p);
  615. p:=hp;
  616. end;
  617. { we now need to have a loadn with a procsym }
  618. if (p^.treetype=loadn) and
  619. (p^.symtableentry^.typ=procsym) then
  620. begin
  621. curconstsegment^.concat(new(pai_const_symbol,
  622. initname(pprocsym(p^.symtableentry)^.definition^.mangledname)));
  623. end
  624. else
  625. Message(cg_e_illegal_expression);
  626. disposetree(p);
  627. end;
  628. { reads a typed constant record }
  629. recorddef:
  630. begin
  631. consume(_LKLAMMER);
  632. aktpos:=0;
  633. while token<>_RKLAMMER do
  634. begin
  635. s:=pattern;
  636. consume(_ID);
  637. consume(_COLON);
  638. srsym:=precorddef(def)^.symtable^.search(s);
  639. if srsym=nil then
  640. begin
  641. Message1(sym_e_id_not_found,s);
  642. consume_all_until(_SEMICOLON);
  643. end
  644. else
  645. begin
  646. { check position }
  647. if pvarsym(srsym)^.address<aktpos then
  648. Message(parser_e_invalid_record_const);
  649. { if needed fill }
  650. if pvarsym(srsym)^.address>aktpos then
  651. for i:=1 to pvarsym(srsym)^.address-aktpos do
  652. curconstsegment^.concat(new(pai_const,init_8bit(0)));
  653. { new position }
  654. aktpos:=pvarsym(srsym)^.address+pvarsym(srsym)^.vartype.def^.size;
  655. { read the data }
  656. readtypedconst(pvarsym(srsym)^.vartype.def,nil,no_change_allowed);
  657. if token=_SEMICOLON then
  658. consume(_SEMICOLON)
  659. else break;
  660. end;
  661. end;
  662. for i:=1 to def^.size-aktpos do
  663. curconstsegment^.concat(new(pai_const,init_8bit(0)));
  664. consume(_RKLAMMER);
  665. end;
  666. { reads a typed object }
  667. objectdef:
  668. begin
  669. if ([oo_has_vmt,oo_is_class]*pobjectdef(def)^.objectoptions)<>[] then
  670. begin
  671. Message(parser_e_type_const_not_possible);
  672. consume_all_until(_RKLAMMER);
  673. end
  674. else
  675. begin
  676. consume(_LKLAMMER);
  677. aktpos:=0;
  678. while token<>_RKLAMMER do
  679. begin
  680. s:=pattern;
  681. consume(_ID);
  682. consume(_COLON);
  683. srsym:=nil;
  684. obj:=pobjectdef(def);
  685. symt:=obj^.symtable;
  686. while (srsym=nil) and assigned(symt) do
  687. begin
  688. srsym:=symt^.search(s);
  689. if assigned(obj) then
  690. obj:=obj^.childof;
  691. if assigned(obj) then
  692. symt:=obj^.symtable
  693. else
  694. symt:=nil;
  695. end;
  696. if srsym=nil then
  697. begin
  698. Message1(sym_e_id_not_found,s);
  699. consume_all_until(_SEMICOLON);
  700. end
  701. else
  702. begin
  703. { check position }
  704. if pvarsym(srsym)^.address<aktpos then
  705. Message(parser_e_invalid_record_const);
  706. { if needed fill }
  707. if pvarsym(srsym)^.address>aktpos then
  708. for i:=1 to pvarsym(srsym)^.address-aktpos do
  709. curconstsegment^.concat(new(pai_const,init_8bit(0)));
  710. { new position }
  711. aktpos:=pvarsym(srsym)^.address+pvarsym(srsym)^.vartype.def^.size;
  712. { read the data }
  713. readtypedconst(pvarsym(srsym)^.vartype.def,nil,no_change_allowed);
  714. if token=_SEMICOLON then
  715. consume(_SEMICOLON)
  716. else break;
  717. end;
  718. end;
  719. for i:=1 to def^.size-aktpos do
  720. curconstsegment^.concat(new(pai_const,init_8bit(0)));
  721. consume(_RKLAMMER);
  722. end;
  723. end;
  724. errordef:
  725. begin
  726. { try to consume something useful }
  727. if token=_LKLAMMER then
  728. consume_all_until(_RKLAMMER)
  729. else
  730. consume_all_until(_SEMICOLON);
  731. end;
  732. else Message(parser_e_type_const_not_possible);
  733. end;
  734. end;
  735. end.
  736. {
  737. $Log$
  738. Revision 1.59 1999-11-30 10:40:51 peter
  739. + ttype, tsymlist
  740. Revision 1.58 1999/11/08 18:50:11 florian
  741. * disposetree for classrefdef added
  742. Revision 1.57 1999/11/08 16:24:28 pierre
  743. * missing disposetree added to avoid memory loss
  744. Revision 1.56 1999/11/08 14:02:16 florian
  745. * problem with "index X"-properties solved
  746. * typed constants of class references are now allowed
  747. Revision 1.55 1999/11/06 14:34:23 peter
  748. * truncated log to 20 revs
  749. Revision 1.54 1999/10/14 14:57:54 florian
  750. - removed the hcodegen use in the new cg, use cgbase instead
  751. Revision 1.53 1999/09/26 21:30:20 peter
  752. + constant pointer support which can happend with typecasting like
  753. const p=pointer(1)
  754. * better procvar parsing in typed consts
  755. Revision 1.52 1999/08/10 12:30:02 pierre
  756. * avoid unused locals
  757. Revision 1.51 1999/08/04 13:03:02 jonas
  758. * all tokens now start with an underscore
  759. * PowerPC compiles!!
  760. Revision 1.50 1999/08/04 00:23:21 florian
  761. * renamed i386asm and i386base to cpuasm and cpubase
  762. Revision 1.49 1999/08/03 22:03:08 peter
  763. * moved bitmask constants to sets
  764. * some other type/const renamings
  765. Revision 1.48 1999/07/23 16:05:26 peter
  766. * alignment is now saved in the symtable
  767. * C alignment added for records
  768. * PPU version increased to solve .12 <-> .13 probs
  769. Revision 1.47 1999/07/03 14:14:28 florian
  770. + start of val(int64/qword)
  771. * longbool, wordbool constants weren't written, fixed
  772. Revision 1.46 1999/05/27 19:44:54 peter
  773. * removed oldasm
  774. * plabel -> pasmlabel
  775. * -a switches to source writing automaticly
  776. * assembler readers OOPed
  777. * asmsymbol automaticly external
  778. * jumptables and other label fixes for asm readers
  779. Revision 1.45 1999/05/23 18:42:13 florian
  780. * better error recovering in typed constants
  781. * some problems with arrays of const fixed, some problems
  782. due my previous
  783. - the location type of array constructor is now LOC_MEM
  784. - the pushing of high fixed
  785. - parameter copying fixed
  786. - zero temp. allocation removed
  787. * small problem in the assembler writers fixed:
  788. ref to nil wasn't written correctly
  789. Revision 1.44 1999/05/21 13:55:11 peter
  790. * NEWLAB for label as symbol
  791. Revision 1.43 1999/05/12 00:19:54 peter
  792. * removed R_DEFAULT_SEG
  793. * uniform float names
  794. Revision 1.42 1999/05/06 09:05:24 peter
  795. * generic write_float and str_float
  796. * fixed constant float conversions
  797. Revision 1.41 1999/05/01 13:24:39 peter
  798. * merged nasm compiler
  799. * old asm moved to oldasm/
  800. Revision 1.40 1999/04/25 22:42:17 pierre
  801. + code for initialized vars in Delphi mode
  802. Revision 1.39 1999/03/24 23:17:21 peter
  803. * fixed bugs 212,222,225,227,229,231,233
  804. Revision 1.38 1999/02/25 21:02:45 peter
  805. * ag386bin updates
  806. + coff writer
  807. Revision 1.37 1999/02/22 02:44:13 peter
  808. * ag386bin doesn't use i386.pas anymore
  809. Revision 1.36 1999/02/17 10:15:26 peter
  810. * fixed error messages when parsing typed const array
  811. Revision 1.35 1999/01/20 14:09:28 pierre
  812. * fix to bug0191
  813. }