ptconst.pas 35 KB

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