ptype.pas 30 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849
  1. {
  2. Copyright (c) 1998-2002 by Florian Klaempfl
  3. Does parsing types for Free Pascal
  4. This program is free software; you can redistribute it and/or modify
  5. it under the terms of the GNU General Public License as published by
  6. the Free Software Foundation; either version 2 of the License, or
  7. (at your option) any later version.
  8. This program is distributed in the hope that it will be useful,
  9. but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  11. GNU General Public License for more details.
  12. You should have received a copy of the GNU General Public License
  13. along with this program; if not, write to the Free Software
  14. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  15. ****************************************************************************
  16. }
  17. unit ptype;
  18. {$i fpcdefs.inc}
  19. interface
  20. uses
  21. globtype,cclasses,
  22. symtype,symdef,symbase;
  23. const
  24. { forward types should only be possible inside a TYPE statement }
  25. typecanbeforward : boolean = false;
  26. var
  27. { hack, which allows to use the current parsed }
  28. { object type as function argument type }
  29. testcurobject : byte;
  30. { reads a type identifier }
  31. procedure id_type(var def : tdef;isforwarddef:boolean);
  32. { reads a string, file type or a type identifier }
  33. procedure single_type(var def:tdef;isforwarddef:boolean);
  34. { reads any type declaration, where the resulting type will get name as type identifier }
  35. procedure read_named_type(var def:tdef;const name : TIDString;genericdef:tstoreddef;genericlist:TFPObjectList;parseprocvardir:boolean);
  36. { reads any type declaration }
  37. procedure read_anon_type(var def : tdef;parseprocvardir:boolean);
  38. { generate persistent type information like VMT, RTTI and inittables }
  39. procedure write_persistent_type_info(st:tsymtable);
  40. implementation
  41. uses
  42. { common }
  43. cutils,
  44. { global }
  45. globals,tokens,verbose,
  46. systems,
  47. { target }
  48. paramgr,
  49. { symtable }
  50. symconst,symsym,symtable,
  51. defutil,defcmp,
  52. { pass 1 }
  53. node,ncgrtti,nobj,
  54. nmat,nadd,ncal,nset,ncnv,ninl,ncon,nld,nflw,
  55. { parser }
  56. scanner,
  57. pbase,pexpr,pdecsub,pdecvar,pdecobj;
  58. procedure generate_specialization(var pt1:tnode;const name:string);
  59. var
  60. st : TSymtable;
  61. pt2 : tnode;
  62. first,
  63. err : boolean;
  64. i : longint;
  65. sym : tsym;
  66. genericdef : tstoreddef;
  67. generictype : ttypesym;
  68. generictypelist : TFPObjectList;
  69. begin
  70. { retrieve generic def that we are going to replace }
  71. genericdef:=tstoreddef(pt1.resultdef);
  72. pt1.resultdef:=nil;
  73. if not(df_generic in genericdef.defoptions) then
  74. begin
  75. Message(parser_e_special_onlygenerics);
  76. pt1.resultdef:=generrordef;
  77. { recover }
  78. consume(_LSHARPBRACKET);
  79. repeat
  80. pt2:=factor(false);
  81. pt2.free;
  82. until not try_to_consume(_COMMA);
  83. consume(_RSHARPBRACKET);
  84. exit;
  85. end;
  86. consume(_LSHARPBRACKET);
  87. block_type:=bt_specialize;
  88. { Parse generic parameters, for each undefineddef in the symtable of
  89. the genericdef we need to have a new def }
  90. err:=false;
  91. first:=true;
  92. generictypelist:=TFPObjectList.create(false);
  93. case genericdef.typ of
  94. procdef :
  95. st:=genericdef.GetSymtable(gs_para);
  96. objectdef,
  97. recorddef :
  98. st:=genericdef.GetSymtable(gs_record);
  99. end;
  100. if not assigned(st) then
  101. internalerror(200511182);
  102. for i:=0 to st.SymList.Count-1 do
  103. begin
  104. sym:=tsym(st.SymList[i]);
  105. if (sym.typ=typesym) and
  106. (ttypesym(sym).typedef.typ=undefineddef) then
  107. begin
  108. if not first then
  109. consume(_COMMA)
  110. else
  111. first:=false;
  112. pt2:=factor(false);
  113. if pt2.nodetype=typen then
  114. begin
  115. if df_generic in pt2.resultdef.defoptions then
  116. Message(parser_e_no_generics_as_params);
  117. generictype:=ttypesym.create(sym.realname,pt2.resultdef);
  118. generictypelist.add(generictype);
  119. end
  120. else
  121. begin
  122. Message(type_e_type_id_expected);
  123. err:=true;
  124. end;
  125. pt2.free;
  126. end;
  127. end;
  128. { force correct error location if too much type parameters are passed }
  129. if token<>_RSHARPBRACKET then
  130. consume(_RSHARPBRACKET);
  131. { Reparse the original type definition }
  132. if not err then
  133. begin
  134. if not assigned(genericdef.generictokenbuf) then
  135. internalerror(200511171);
  136. current_scanner.startreplaytokens(genericdef.generictokenbuf);
  137. read_named_type(pt1.resultdef,name,genericdef,generictypelist,false);
  138. { Consume the semicolon if it is also recorded }
  139. try_to_consume(_SEMICOLON);
  140. end;
  141. generictypelist.free;
  142. consume(_RSHARPBRACKET);
  143. end;
  144. procedure id_type(var def : tdef;isforwarddef:boolean);
  145. { reads a type definition }
  146. { to a appropriating tdef, s gets the name of }
  147. { the type to allow name mangling }
  148. var
  149. is_unit_specific : boolean;
  150. pos : tfileposinfo;
  151. srsym : tsym;
  152. srsymtable : TSymtable;
  153. s,sorg : TIDString;
  154. begin
  155. s:=pattern;
  156. sorg:=orgpattern;
  157. pos:=current_tokenpos;
  158. { use of current parsed object:
  159. - classes can be used also in classes
  160. - objects can be parameters }
  161. if assigned(aktobjectdef) and
  162. (aktobjectdef.objname^=pattern) and
  163. (
  164. (testcurobject=2) or
  165. is_class_or_interface(aktobjectdef)
  166. )then
  167. begin
  168. consume(_ID);
  169. def:=aktobjectdef;
  170. exit;
  171. end;
  172. { Use the special searchsym_type that ignores records,objects and
  173. parameters }
  174. searchsym_type(s,srsym,srsymtable);
  175. { handle unit specification like System.Writeln }
  176. is_unit_specific:=try_consume_unitsym(srsym,srsymtable);
  177. consume(_ID);
  178. { Types are first defined with an error def before assigning
  179. the real type so check if it's an errordef. if so then
  180. give an error. Only check for typesyms in the current symbol
  181. table as forwarddef are not resolved directly }
  182. if assigned(srsym) and
  183. (srsym.typ=typesym) and
  184. (ttypesym(srsym).typedef.typ=errordef) then
  185. begin
  186. Message1(type_e_type_is_not_completly_defined,ttypesym(srsym).realname);
  187. def:=generrordef;
  188. exit;
  189. end;
  190. { are we parsing a possible forward def ? }
  191. if isforwarddef and
  192. not(is_unit_specific) then
  193. begin
  194. def:=tforwarddef.create(s,pos);
  195. exit;
  196. end;
  197. { unknown sym ? }
  198. if not assigned(srsym) then
  199. begin
  200. Message1(sym_e_id_not_found,sorg);
  201. def:=generrordef;
  202. exit;
  203. end;
  204. { type sym ? }
  205. if (srsym.typ<>typesym) then
  206. begin
  207. Message(type_e_type_id_expected);
  208. def:=generrordef;
  209. exit;
  210. end;
  211. { Give an error when referring to an errordef }
  212. if (ttypesym(srsym).typedef.typ=errordef) then
  213. begin
  214. Message(sym_e_error_in_type_def);
  215. def:=generrordef;
  216. exit;
  217. end;
  218. def:=ttypesym(srsym).typedef;
  219. end;
  220. procedure single_type(var def:tdef;isforwarddef:boolean);
  221. var
  222. t2 : tdef;
  223. again : boolean;
  224. begin
  225. repeat
  226. again:=false;
  227. case token of
  228. _STRING:
  229. string_dec(def);
  230. _FILE:
  231. begin
  232. consume(_FILE);
  233. if try_to_consume(_OF) then
  234. begin
  235. single_type(t2,false);
  236. def:=tfiledef.createtyped(t2);
  237. end
  238. else
  239. def:=cfiletype;
  240. end;
  241. _ID:
  242. begin
  243. if try_to_consume(_SPECIALIZE) then
  244. begin
  245. if block_type<>bt_type then
  246. Message(parser_f_no_anonymous_specializations);
  247. block_type:=bt_specialize;
  248. again:=true;
  249. end
  250. else
  251. id_type(def,isforwarddef);
  252. end;
  253. else
  254. begin
  255. message(type_e_type_id_expected);
  256. def:=generrordef;
  257. end;
  258. end;
  259. until not again;
  260. end;
  261. { reads a record declaration }
  262. function record_dec : tdef;
  263. var
  264. recst : trecordsymtable;
  265. storetypecanbeforward : boolean;
  266. old_object_option : tsymoptions;
  267. begin
  268. { create recdef }
  269. recst:=trecordsymtable.create(current_settings.packrecords);
  270. record_dec:=trecorddef.create(recst);
  271. { insert in symtablestack }
  272. symtablestack.push(recst);
  273. { parse record }
  274. consume(_RECORD);
  275. old_object_option:=current_object_option;
  276. current_object_option:=[sp_public];
  277. storetypecanbeforward:=typecanbeforward;
  278. { for tp7 don't allow forward types }
  279. if m_tp7 in current_settings.modeswitches then
  280. typecanbeforward:=false;
  281. read_record_fields([vd_record]);
  282. consume(_END);
  283. typecanbeforward:=storetypecanbeforward;
  284. current_object_option:=old_object_option;
  285. { make the record size aligned }
  286. recst.addalignmentpadding;
  287. { restore symtable stack }
  288. symtablestack.pop(recst);
  289. if trecorddef(record_dec).is_packed and
  290. record_dec.needs_inittable then
  291. Message(type_e_no_packed_inittable);
  292. end;
  293. { reads a type definition and returns a pointer to it }
  294. procedure read_named_type(var def : tdef;const name : TIDString;genericdef:tstoreddef;genericlist:TFPObjectList;parseprocvardir:boolean);
  295. var
  296. pt : tnode;
  297. tt2 : tdef;
  298. aktenumdef : tenumdef;
  299. s : TIDString;
  300. l,v : TConstExprInt;
  301. oldpackrecords : longint;
  302. defpos,storepos : tfileposinfo;
  303. procedure expr_type;
  304. var
  305. pt1,pt2 : tnode;
  306. lv,hv : TConstExprInt;
  307. old_block_type : tblock_type;
  308. begin
  309. old_block_type:=block_type;
  310. { use of current parsed object:
  311. - classes can be used also in classes
  312. - objects can be parameters }
  313. if (token=_ID) and
  314. assigned(aktobjectdef) and
  315. (aktobjectdef.objname^=pattern) and
  316. (
  317. (testcurobject=2) or
  318. is_class_or_interface(aktobjectdef)
  319. )then
  320. begin
  321. consume(_ID);
  322. def:=aktobjectdef;
  323. exit;
  324. end;
  325. { Generate a specialization? }
  326. if try_to_consume(_SPECIALIZE) then
  327. begin
  328. if name='' then
  329. Message(parser_f_no_anonymous_specializations);
  330. block_type:=bt_specialize;
  331. end;
  332. { we can't accept a equal in type }
  333. pt1:=comp_expr(false);
  334. if (block_type<>bt_specialize) and
  335. try_to_consume(_POINTPOINT) then
  336. begin
  337. { get high value of range }
  338. pt2:=comp_expr(false);
  339. { make both the same type or give an error. This is not
  340. done when both are integer values, because typecasting
  341. between -3200..3200 will result in a signed-unsigned
  342. conflict and give a range check error (PFV) }
  343. if not(is_integer(pt1.resultdef) and is_integer(pt2.resultdef)) then
  344. inserttypeconv(pt1,pt2.resultdef);
  345. { both must be evaluated to constants now }
  346. if (pt1.nodetype=ordconstn) and
  347. (pt2.nodetype=ordconstn) then
  348. begin
  349. lv:=tordconstnode(pt1).value;
  350. hv:=tordconstnode(pt2).value;
  351. { Check bounds }
  352. if hv<lv then
  353. Message(parser_e_upper_lower_than_lower)
  354. else
  355. begin
  356. { All checks passed, create the new def }
  357. case pt1.resultdef.typ of
  358. enumdef :
  359. def:=tenumdef.create_subrange(tenumdef(pt1.resultdef),lv,hv);
  360. orddef :
  361. begin
  362. if is_char(pt1.resultdef) then
  363. def:=torddef.create(uchar,lv,hv)
  364. else
  365. if is_boolean(pt1.resultdef) then
  366. def:=torddef.create(bool8bit,lv,hv)
  367. else
  368. def:=torddef.create(range_to_basetype(lv,hv),lv,hv);
  369. end;
  370. end;
  371. end;
  372. end
  373. else
  374. Message(sym_e_error_in_type_def);
  375. pt2.free;
  376. end
  377. else
  378. begin
  379. { a simple type renaming or generic specialization }
  380. if (pt1.nodetype=typen) then
  381. begin
  382. if (block_type=bt_specialize) then
  383. generate_specialization(pt1,name);
  384. def:=ttypenode(pt1).resultdef;
  385. if (block_type<>bt_specialize) and (df_generic in def.defoptions) then
  386. begin
  387. Message(parser_e_no_generics_as_types);
  388. def:=generrordef;
  389. end;
  390. end
  391. else
  392. Message(sym_e_error_in_type_def);
  393. end;
  394. pt1.free;
  395. block_type:=old_block_type;
  396. end;
  397. procedure set_dec;
  398. begin
  399. consume(_SET);
  400. consume(_OF);
  401. read_anon_type(tt2,true);
  402. if assigned(tt2) then
  403. begin
  404. case tt2.typ of
  405. { don't forget that min can be negativ PM }
  406. enumdef :
  407. if tenumdef(tt2).min>=0 then
  408. // !! def:=tsetdef.create(tt2,tenumdef(tt2.def).min,tenumdef(tt2.def).max))
  409. def:=tsetdef.create(tt2,tenumdef(tt2).max)
  410. else
  411. Message(sym_e_ill_type_decl_set);
  412. orddef :
  413. begin
  414. if (torddef(tt2).ordtype<>uvoid) and
  415. (torddef(tt2).ordtype<>uwidechar) and
  416. (torddef(tt2).low>=0) then
  417. // !! def:=tsetdef.create(tt2,torddef(tt2.def).low,torddef(tt2.def).high))
  418. def:=tsetdef.create(tt2,torddef(tt2).high)
  419. else
  420. Message(sym_e_ill_type_decl_set);
  421. end;
  422. else
  423. Message(sym_e_ill_type_decl_set);
  424. end;
  425. end
  426. else
  427. def:=generrordef;
  428. end;
  429. procedure array_dec(is_packed: boolean);
  430. var
  431. lowval,
  432. highval : TConstExprInt;
  433. indexdef : tdef;
  434. hdef : tdef;
  435. arrdef : tarraydef;
  436. procedure setdefdecl(def:tdef);
  437. begin
  438. case def.typ of
  439. enumdef :
  440. begin
  441. lowval:=tenumdef(def).min;
  442. highval:=tenumdef(def).max;
  443. if (m_fpc in current_settings.modeswitches) and
  444. (tenumdef(def).has_jumps) then
  445. Message(type_e_array_index_enums_with_assign_not_possible);
  446. indexdef:=def;
  447. end;
  448. orddef :
  449. begin
  450. if torddef(def).ordtype in [uchar,
  451. u8bit,u16bit,
  452. s8bit,s16bit,s32bit,
  453. {$ifdef cpu64bit}
  454. u32bit,s64bit,
  455. {$endif cpu64bit}
  456. bool8bit,bool16bit,bool32bit,bool64bit,
  457. uwidechar] then
  458. begin
  459. lowval:=torddef(def).low;
  460. highval:=torddef(def).high;
  461. indexdef:=def;
  462. end
  463. else
  464. Message1(parser_e_type_cant_be_used_in_array_index,def.GetTypeName);
  465. end;
  466. else
  467. Message(sym_e_error_in_type_def);
  468. end;
  469. end;
  470. begin
  471. arrdef:=nil;
  472. consume(_ARRAY);
  473. { open array? }
  474. if try_to_consume(_LECKKLAMMER) then
  475. begin
  476. { defaults }
  477. indexdef:=generrordef;
  478. lowval:=low(aint);
  479. highval:=high(aint);
  480. repeat
  481. { read the expression and check it, check apart if the
  482. declaration is an enum declaration because that needs to
  483. be parsed by readtype (PFV) }
  484. if token=_LKLAMMER then
  485. begin
  486. read_anon_type(hdef,true);
  487. setdefdecl(hdef);
  488. end
  489. else
  490. begin
  491. pt:=expr;
  492. if pt.nodetype=typen then
  493. setdefdecl(pt.resultdef)
  494. else
  495. begin
  496. if (pt.nodetype=rangen) then
  497. begin
  498. if (trangenode(pt).left.nodetype=ordconstn) and
  499. (trangenode(pt).right.nodetype=ordconstn) then
  500. begin
  501. { make both the same type or give an error. This is not
  502. done when both are integer values, because typecasting
  503. between -3200..3200 will result in a signed-unsigned
  504. conflict and give a range check error (PFV) }
  505. if not(is_integer(trangenode(pt).left.resultdef) and is_integer(trangenode(pt).left.resultdef)) then
  506. inserttypeconv(trangenode(pt).left,trangenode(pt).right.resultdef);
  507. lowval:=tordconstnode(trangenode(pt).left).value;
  508. highval:=tordconstnode(trangenode(pt).right).value;
  509. if highval<lowval then
  510. begin
  511. Message(parser_e_array_lower_less_than_upper_bound);
  512. highval:=lowval;
  513. end
  514. else if (lowval < low(aint)) or
  515. (highval > high(aint)) then
  516. begin
  517. Message(parser_e_array_range_out_of_bounds);
  518. lowval :=0;
  519. highval:=0;
  520. end;
  521. if is_integer(trangenode(pt).left.resultdef) then
  522. range_to_type(lowval,highval,indexdef)
  523. else
  524. indexdef:=trangenode(pt).left.resultdef;
  525. end
  526. else
  527. Message(type_e_cant_eval_constant_expr);
  528. end
  529. else
  530. Message(sym_e_error_in_type_def)
  531. end;
  532. pt.free;
  533. end;
  534. { if the array is already created add the new arrray
  535. as element of the existing array, otherwise create a new array }
  536. if assigned(arrdef) then
  537. begin
  538. arrdef.elementdef:=tarraydef.create(lowval,highval,indexdef);
  539. arrdef:=tarraydef(arrdef.elementdef);
  540. end
  541. else
  542. begin
  543. arrdef:=tarraydef.create(lowval,highval,indexdef);
  544. def:=arrdef;
  545. end;
  546. if is_packed then
  547. include(arrdef.arrayoptions,ado_IsBitPacked);
  548. if token=_COMMA then
  549. consume(_COMMA)
  550. else
  551. break;
  552. until false;
  553. consume(_RECKKLAMMER);
  554. end
  555. else
  556. begin
  557. if is_packed then
  558. Message(parser_e_packed_dynamic_open_array);
  559. arrdef:=tarraydef.create(0,-1,s32inttype);
  560. include(arrdef.arrayoptions,ado_IsDynamicArray);
  561. def:=arrdef;
  562. end;
  563. consume(_OF);
  564. read_anon_type(tt2,true);
  565. { set element type of the last array definition }
  566. if assigned(arrdef) then
  567. begin
  568. arrdef.elementdef:=tt2;
  569. if is_packed and
  570. tt2.needs_inittable then
  571. Message(type_e_no_packed_inittable);
  572. end;
  573. end;
  574. var
  575. p : tnode;
  576. pd : tabstractprocdef;
  577. is_func,
  578. enumdupmsg, first : boolean;
  579. newtype : ttypesym;
  580. oldlocalswitches : tlocalswitches;
  581. bitpacking: boolean;
  582. begin
  583. def:=nil;
  584. case token of
  585. _STRING,_FILE:
  586. begin
  587. single_type(def,false);
  588. end;
  589. _LKLAMMER:
  590. begin
  591. consume(_LKLAMMER);
  592. first := true;
  593. { allow negativ value_str }
  594. l:=-1;
  595. enumdupmsg:=false;
  596. aktenumdef:=tenumdef.create;
  597. repeat
  598. s:=orgpattern;
  599. defpos:=current_tokenpos;
  600. consume(_ID);
  601. { only allow assigning of specific numbers under fpc mode }
  602. if not(m_tp7 in current_settings.modeswitches) and
  603. (
  604. { in fpc mode also allow := to be compatible
  605. with previous 1.0.x versions }
  606. ((m_fpc in current_settings.modeswitches) and
  607. try_to_consume(_ASSIGNMENT)) or
  608. try_to_consume(_EQUAL)
  609. ) then
  610. begin
  611. oldlocalswitches:=current_settings.localswitches;
  612. include(current_settings.localswitches,cs_allow_enum_calc);
  613. p:=comp_expr(true);
  614. current_settings.localswitches:=oldlocalswitches;
  615. if (p.nodetype=ordconstn) then
  616. begin
  617. { we expect an integer or an enum of the
  618. same type }
  619. if is_integer(p.resultdef) or
  620. is_char(p.resultdef) or
  621. equal_defs(p.resultdef,aktenumdef) then
  622. v:=tordconstnode(p).value
  623. else
  624. IncompatibleTypes(p.resultdef,s32inttype);
  625. end
  626. else
  627. Message(parser_e_illegal_expression);
  628. p.free;
  629. { please leave that a note, allows type save }
  630. { declarations in the win32 units ! }
  631. if (not first) and (v<=l) and (not enumdupmsg) then
  632. begin
  633. Message(parser_n_duplicate_enum);
  634. enumdupmsg:=true;
  635. end;
  636. l:=v;
  637. end
  638. else
  639. inc(l);
  640. first := false;
  641. storepos:=current_tokenpos;
  642. current_tokenpos:=defpos;
  643. tstoredsymtable(aktenumdef.owner).insert(tenumsym.create(s,aktenumdef,l));
  644. current_tokenpos:=storepos;
  645. until not try_to_consume(_COMMA);
  646. def:=aktenumdef;
  647. consume(_RKLAMMER);
  648. end;
  649. _ARRAY:
  650. begin
  651. array_dec(false);
  652. end;
  653. _SET:
  654. begin
  655. set_dec;
  656. end;
  657. _CARET:
  658. begin
  659. consume(_CARET);
  660. single_type(tt2,typecanbeforward);
  661. def:=tpointerdef.create(tt2);
  662. end;
  663. _RECORD:
  664. begin
  665. def:=record_dec;
  666. end;
  667. _PACKED,
  668. _BITPACKED:
  669. begin
  670. bitpacking :=
  671. (cs_bitpacking in current_settings.localswitches) or
  672. (token = _BITPACKED);
  673. consume(token);
  674. if token=_ARRAY then
  675. array_dec(bitpacking)
  676. else if token=_SET then
  677. set_dec
  678. else
  679. begin
  680. oldpackrecords:=current_settings.packrecords;
  681. if (not bitpacking) or
  682. (token in [_CLASS,_OBJECT]) then
  683. current_settings.packrecords:=1
  684. else
  685. current_settings.packrecords:=bit_alignment;
  686. if token in [_CLASS,_OBJECT] then
  687. def:=object_dec(name,genericdef,genericlist,nil)
  688. else
  689. def:=record_dec;
  690. current_settings.packrecords:=oldpackrecords;
  691. end;
  692. end;
  693. _DISPINTERFACE,
  694. _CLASS,
  695. _CPPCLASS,
  696. _INTERFACE,
  697. _OBJECT:
  698. begin
  699. def:=object_dec(name,genericdef,genericlist,nil);
  700. end;
  701. _PROCEDURE,
  702. _FUNCTION:
  703. begin
  704. is_func:=(token=_FUNCTION);
  705. consume(token);
  706. pd:=tprocvardef.create(normal_function_level);
  707. if token=_LKLAMMER then
  708. parse_parameter_dec(pd);
  709. if is_func then
  710. begin
  711. consume(_COLON);
  712. single_type(pd.returndef,false);
  713. end;
  714. if token=_OF then
  715. begin
  716. consume(_OF);
  717. consume(_OBJECT);
  718. include(pd.procoptions,po_methodpointer);
  719. end;
  720. def:=pd;
  721. { possible proc directives }
  722. if parseprocvardir then
  723. begin
  724. if check_proc_directive(true) then
  725. begin
  726. newtype:=ttypesym.create('unnamed',def);
  727. parse_var_proc_directives(tsym(newtype));
  728. newtype.typedef:=nil;
  729. def.typesym:=nil;
  730. newtype.free;
  731. end;
  732. { Add implicit hidden parameters and function result }
  733. handle_calling_convention(pd);
  734. end;
  735. end;
  736. else
  737. expr_type;
  738. end;
  739. if def=nil then
  740. def:=generrordef;
  741. end;
  742. procedure read_anon_type(var def : tdef;parseprocvardir:boolean);
  743. begin
  744. read_named_type(def,'',nil,nil,parseprocvardir);
  745. end;
  746. procedure write_persistent_type_info(st:tsymtable);
  747. var
  748. i : longint;
  749. def : tdef;
  750. vmtwriter : TVMTWriter;
  751. begin
  752. for i:=0 to st.DefList.Count-1 do
  753. begin
  754. def:=tdef(st.DefList[i]);
  755. case def.typ of
  756. recorddef :
  757. write_persistent_type_info(trecorddef(def).symtable);
  758. objectdef :
  759. begin
  760. write_persistent_type_info(tobjectdef(def).symtable);
  761. { Write also VMT }
  762. if not(ds_vmt_written in def.defstates) and
  763. not(oo_is_forward in tobjectdef(def).objectoptions) then
  764. begin
  765. vmtwriter:=TVMTWriter.create(tobjectdef(def));
  766. if is_interface(tobjectdef(def)) then
  767. vmtwriter.writeinterfaceids;
  768. if (oo_has_vmt in tobjectdef(def).objectoptions) then
  769. vmtwriter.writevmt;
  770. vmtwriter.free;
  771. include(def.defstates,ds_vmt_written);
  772. end;
  773. end;
  774. procdef :
  775. begin
  776. if assigned(tprocdef(def).localst) and
  777. (tprocdef(def).localst.symtabletype=localsymtable) then
  778. write_persistent_type_info(tprocdef(def).localst);
  779. if assigned(tprocdef(def).parast) then
  780. write_persistent_type_info(tprocdef(def).parast);
  781. end;
  782. end;
  783. { generate always persistent tables for types in the interface so it can
  784. be reused in other units and give always the same pointer location. }
  785. { Init }
  786. if (
  787. assigned(def.typesym) and
  788. (st.symtabletype=globalsymtable)
  789. ) or
  790. def.needs_inittable or
  791. (ds_init_table_used in def.defstates) then
  792. RTTIWriter.write_rtti(def,initrtti);
  793. { RTTI }
  794. if (
  795. assigned(def.typesym) and
  796. (st.symtabletype=globalsymtable)
  797. ) or
  798. (ds_rtti_table_used in def.defstates) then
  799. RTTIWriter.write_rtti(def,fullrtti);
  800. end;
  801. end;
  802. end.