ptconst.pas 35 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896
  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,aasm,tree,pass_1,
  29. types,verbose
  30. { parser specific stuff }
  31. ,pbase,pexpr
  32. { processor specific stuff }
  33. {$ifdef i386}
  34. ,i386base
  35. {$endif}
  36. {$ifdef m68k}
  37. ,m68k
  38. {$endif}
  39. { codegen }
  40. ,hcodegen,hcgdata
  41. ;
  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. pd : pprocdef;
  58. obj : pobjectdef;
  59. symt : psymtable;
  60. hp1,hp2 : pdefcoll;
  61. value : bestreal;
  62. procedure check_range;
  63. begin
  64. if ((p^.value>porddef(def)^.high) or
  65. (p^.value<porddef(def)^.low)) then
  66. begin
  67. if (cs_check_range in aktlocalswitches) then
  68. Message(parser_e_range_check_error)
  69. else
  70. Message(parser_w_range_check_error);
  71. end;
  72. end;
  73. function is_po_equal(o1,o2:longint):boolean;
  74. begin
  75. { assembler does not affect }
  76. is_po_equal:=(o1 and not(poassembler))=
  77. (o2 and not(poassembler));
  78. end;
  79. {$R-} {Range check creates problem with init_8bit(-1) !!}
  80. begin
  81. if no_change_allowed then
  82. curconstsegment:=consts
  83. else
  84. curconstsegment:=datasegment;
  85. case def^.deftype of
  86. orddef:
  87. begin
  88. p:=comp_expr(true);
  89. do_firstpass(p);
  90. case porddef(def)^.typ of
  91. s8bit,
  92. u8bit : begin
  93. if not is_constintnode(p) then
  94. { is't an int expected }
  95. Message(cg_e_illegal_expression)
  96. else
  97. begin
  98. curconstsegment^.concat(new(pai_const,init_8bit(p^.value)));
  99. check_range;
  100. end;
  101. end;
  102. s32bit : begin
  103. if not is_constintnode(p) then
  104. Message(cg_e_illegal_expression)
  105. else
  106. begin
  107. curconstsegment^.concat(new(pai_const,init_32bit(p^.value)));
  108. check_range;
  109. end;
  110. end;
  111. u32bit : begin
  112. if not is_constintnode(p) then
  113. Message(cg_e_illegal_expression)
  114. else
  115. curconstsegment^.concat(new(pai_const,init_32bit(p^.value)));
  116. end;
  117. bool8bit : begin
  118. if not is_constboolnode(p) then
  119. Message(cg_e_illegal_expression);
  120. curconstsegment^.concat(new(pai_const,init_8bit(p^.value)));
  121. end;
  122. uchar : begin
  123. if not is_constcharnode(p) then
  124. Message(cg_e_illegal_expression);
  125. curconstsegment^.concat(new(pai_const,init_8bit(p^.value)));
  126. end;
  127. u16bit,
  128. s16bit : begin
  129. if not is_constintnode(p) then
  130. Message(cg_e_illegal_expression);
  131. curconstsegment^.concat(new(pai_const,init_16bit(p^.value)));
  132. check_range;
  133. end;
  134. s64bitint,
  135. u64bit:
  136. begin
  137. if not is_constintnode(p) then
  138. Message(cg_e_illegal_expression)
  139. else
  140. begin
  141. {!!!!! hmmm, we can write yet only consts til 2^32-1 :( (FK) }
  142. curconstsegment^.concat(new(pai_const,init_32bit(p^.value)));
  143. curconstsegment^.concat(new(pai_const,init_32bit(0)));
  144. end;
  145. end;
  146. end;
  147. disposetree(p);
  148. end;
  149. floatdef:
  150. begin
  151. p:=comp_expr(true);
  152. do_firstpass(p);
  153. if is_constrealnode(p) then
  154. value:=p^.value_real
  155. else if is_constintnode(p) then
  156. value:=p^.value
  157. else
  158. Message(cg_e_illegal_expression);
  159. case pfloatdef(def)^.typ of
  160. s32real : curconstsegment^.concat(new(pai_real_32bit,init(value)));
  161. s64real : curconstsegment^.concat(new(pai_real_64bit,init(value)));
  162. s80real : curconstsegment^.concat(new(pai_real_80bit,init(value)));
  163. s64comp : curconstsegment^.concat(new(pai_comp_64bit,init(value)));
  164. f32bit : curconstsegment^.concat(new(pai_const,init_32bit(trunc(value*65536))));
  165. else internalerror(18);
  166. end;
  167. disposetree(p);
  168. end;
  169. pointerdef:
  170. begin
  171. p:=comp_expr(true);
  172. do_firstpass(p);
  173. if (p^.treetype=typeconvn) and
  174. ((p^.left^.treetype=addrn) or (p^.left^.treetype=niln)) and
  175. is_equal(def,p^.resulttype) then
  176. begin
  177. hp:=p^.left;
  178. putnode(p);
  179. p:=hp;
  180. end;
  181. { allows horrible ofs(typeof(TButton)^) code !! }
  182. if (p^.treetype=addrn) and (p^.left^.treetype=derefn) then
  183. begin
  184. hp:=p^.left^.left;
  185. p^.left^.left:=nil;
  186. disposetree(p);
  187. p:=hp;
  188. end;
  189. { nil pointer ? }
  190. if p^.treetype=niln then
  191. curconstsegment^.concat(new(pai_const,init_32bit(0)))
  192. { maybe pchar ? }
  193. else
  194. if (ppointerdef(def)^.definition^.deftype=orddef) and
  195. (porddef(ppointerdef(def)^.definition)^.typ=uchar) and
  196. (p^.treetype<>addrn) then
  197. begin
  198. getdatalabel(ll);
  199. curconstsegment^.concat(new(pai_const_symbol,init(ll)));
  200. consts^.concat(new(pai_label,init(ll)));
  201. if p^.treetype=stringconstn then
  202. begin
  203. getmem(ca,p^.length+2);
  204. move(p^.value_str^,ca^,p^.length+1);
  205. consts^.concat(new(pai_string,init_length_pchar(ca,p^.length+1)));
  206. end
  207. else
  208. if is_constcharnode(p) then
  209. consts^.concat(new(pai_string,init(char(byte(p^.value))+#0)))
  210. else
  211. Message(cg_e_illegal_expression);
  212. end
  213. else
  214. if p^.treetype=addrn then
  215. begin
  216. hp:=p^.left;
  217. while assigned(hp) and (hp^.treetype in [subscriptn,vecn]) do
  218. hp:=hp^.left;
  219. if (is_equal(ppointerdef(p^.resulttype)^.definition,ppointerdef(def)^.definition) or
  220. (is_equal(ppointerdef(p^.resulttype)^.definition,voiddef)) or
  221. (is_equal(ppointerdef(def)^.definition,voiddef))) and
  222. (hp^.treetype=loadn) then
  223. begin
  224. do_firstpass(p^.left);
  225. hp:=p^.left;
  226. offset:=0;
  227. while assigned(hp) and (hp^.treetype<>loadn) do
  228. begin
  229. case hp^.treetype of
  230. vecn :
  231. begin
  232. if (hp^.left^.resulttype^.deftype=stringdef) then
  233. begin
  234. { this seems OK for shortstring and ansistrings PM }
  235. { it is wrong for widestrings !! }
  236. len:=1;
  237. base:=0;
  238. end
  239. else if (hp^.left^.resulttype^.deftype=arraydef) then
  240. begin
  241. len:=parraydef(hp^.left^.resulttype)^.elesize;
  242. base:=parraydef(hp^.left^.resulttype)^.lowrange;
  243. end
  244. else
  245. Message(cg_e_illegal_expression);
  246. if is_constintnode(hp^.right) then
  247. inc(offset,len*(get_ordinal_value(hp^.right)-base))
  248. else
  249. Message(cg_e_illegal_expression);
  250. {internalerror(9779);}
  251. end;
  252. subscriptn : inc(offset,hp^.vs^.address)
  253. else
  254. Message(cg_e_illegal_expression);
  255. end;
  256. hp:=hp^.left;
  257. end;
  258. if hp^.symtableentry^.typ=constsym then
  259. Message(type_e_variable_id_expected);
  260. curconstsegment^.concat(new(pai_const_symbol,initname_offset(hp^.symtableentry^.mangledname,offset)));
  261. (*if token=POINT then
  262. begin
  263. offset:=0;
  264. while token=POINT do
  265. begin
  266. consume(POINT);
  267. lsym:=pvarsym(precdef(
  268. ppointerdef(p^.resulttype)^.definition)^.symtable^.search(pattern));
  269. if assigned(sym) then
  270. offset:=offset+lsym^.address
  271. else
  272. begin
  273. Message1(sym_e_illegal_field,pattern);
  274. end;
  275. consume(ID);
  276. end;
  277. curconstsegment^.concat(new(pai_const_symbol_offset,init(
  278. strpnew(p^.left^.symtableentry^.mangledname),offset)));
  279. end
  280. else
  281. begin
  282. curconstsegment^.concat(new(pai_const,init_symbol(
  283. strpnew(p^.left^.symtableentry^.mangledname))));
  284. end; *)
  285. end
  286. else
  287. Message(cg_e_illegal_expression);
  288. end
  289. else
  290. { allow typeof(Object type)}
  291. if (p^.treetype=inlinen) and
  292. (p^.inlinenumber=in_typeof_x) then
  293. begin
  294. if (p^.left^.treetype=typen) then
  295. begin
  296. curconstsegment^.concat(new(pai_const_symbol,
  297. initname(pobjectdef(p^.left^.resulttype)^.vmt_mangledname)));
  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. curconstsegment^.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. curconstsegment^.concat(new(pai_const,init_8bit(p^.value_set^[j+3])));
  328. curconstsegment^.concat(new(pai_const,init_8bit(p^.value_set^[j+2])));
  329. curconstsegment^.concat(new(pai_const,init_8bit(p^.value_set^[j+1])));
  330. curconstsegment^.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. curconstsegment^.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. curconstsegment^.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. curconstsegment^.concat(new(pai_string,init_length_pchar(ca,strlength)));
  375. end
  376. else if is_constcharnode(p) then
  377. begin
  378. curconstsegment^.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. curconstsegment^.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. curconstsegment^.concat(new(pai_const,init_32bit(strlength)))));
  402. { fill byte }
  403. curconstsegment^.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. curconstsegment^.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. curconstsegment^.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. curconstsegment^.concat(new(pai_const_symbol,init(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,no_change_allowed);
  466. consume(COMMA);
  467. end;
  468. readtypedconst(parraydef(def)^.definition,nil,no_change_allowed);
  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. curconstsegment^.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. curconstsegment^.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. curconstsegment^.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. curconstsegment^.concat(new(pai_const_symbol,initname(pd^.mangledname)));
  575. end;
  576. end;
  577. { reads a typed constant record }
  578. recorddef:
  579. begin
  580. consume(LKLAMMER);
  581. aktpos:=0;
  582. while token<>RKLAMMER do
  583. begin
  584. s:=pattern;
  585. consume(ID);
  586. consume(COLON);
  587. srsym:=precdef(def)^.symtable^.search(s);
  588. if srsym=nil then
  589. begin
  590. Message1(sym_e_id_not_found,s);
  591. consume_all_until(SEMICOLON);
  592. end
  593. else
  594. begin
  595. { check position }
  596. if pvarsym(srsym)^.address<aktpos then
  597. Message(parser_e_invalid_record_const);
  598. { if needed fill }
  599. if pvarsym(srsym)^.address>aktpos then
  600. for i:=1 to pvarsym(srsym)^.address-aktpos do
  601. curconstsegment^.concat(new(pai_const,init_8bit(0)));
  602. { new position }
  603. aktpos:=pvarsym(srsym)^.address+pvarsym(srsym)^.definition^.size;
  604. { read the data }
  605. readtypedconst(pvarsym(srsym)^.definition,nil,no_change_allowed);
  606. if token=SEMICOLON then
  607. consume(SEMICOLON)
  608. else break;
  609. end;
  610. end;
  611. for i:=1 to def^.size-aktpos do
  612. curconstsegment^.concat(new(pai_const,init_8bit(0)));
  613. consume(RKLAMMER);
  614. end;
  615. { reads a typed object }
  616. objectdef:
  617. begin
  618. if (pobjectdef(def)^.options and (oo_hasvmt or oo_is_class))<>0 then
  619. begin
  620. Message(parser_e_type_const_not_possible);
  621. consume_all_until(RKLAMMER);
  622. end
  623. else
  624. begin
  625. consume(LKLAMMER);
  626. aktpos:=0;
  627. while token<>RKLAMMER do
  628. begin
  629. s:=pattern;
  630. consume(ID);
  631. consume(COLON);
  632. srsym:=nil;
  633. obj:=pobjectdef(def);
  634. symt:=obj^.publicsyms;
  635. while (srsym=nil) and assigned(symt) do
  636. begin
  637. srsym:=symt^.search(s);
  638. if assigned(obj) then
  639. obj:=obj^.childof;
  640. if assigned(obj) then
  641. symt:=obj^.publicsyms
  642. else
  643. symt:=nil;
  644. end;
  645. if srsym=nil then
  646. begin
  647. Message1(sym_e_id_not_found,s);
  648. consume_all_until(SEMICOLON);
  649. end
  650. else
  651. begin
  652. { check position }
  653. if pvarsym(srsym)^.address<aktpos then
  654. Message(parser_e_invalid_record_const);
  655. { if needed fill }
  656. if pvarsym(srsym)^.address>aktpos then
  657. for i:=1 to pvarsym(srsym)^.address-aktpos do
  658. curconstsegment^.concat(new(pai_const,init_8bit(0)));
  659. { new position }
  660. aktpos:=pvarsym(srsym)^.address+pvarsym(srsym)^.definition^.size;
  661. { read the data }
  662. readtypedconst(pvarsym(srsym)^.definition,nil,no_change_allowed);
  663. if token=SEMICOLON then
  664. consume(SEMICOLON)
  665. else break;
  666. end;
  667. end;
  668. for i:=1 to def^.size-aktpos do
  669. curconstsegment^.concat(new(pai_const,init_8bit(0)));
  670. consume(RKLAMMER);
  671. end;
  672. end;
  673. errordef:
  674. begin
  675. { try to consume something useful }
  676. if token=LKLAMMER then
  677. consume_all_until(RKLAMMER)
  678. else
  679. consume_all_until(SEMICOLON);
  680. end;
  681. else Message(parser_e_type_const_not_possible);
  682. end;
  683. end;
  684. end.
  685. {
  686. $Log$
  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. }