ptconst.pas 34 KB

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