ptconst.pas 36 KB

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