2
0

ptype.pas 44 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183
  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. var
  24. { hack, which allows to use the current parsed }
  25. { object type as function argument type }
  26. testcurobject : byte;
  27. procedure resolve_forward_types;
  28. { reads a type identifier }
  29. procedure id_type(var def : tdef;isforwarddef:boolean);
  30. { reads a string, file type or a type identifier }
  31. procedure single_type(var def:tdef;isforwarddef,allowtypedef:boolean);
  32. { reads any type declaration, where the resulting type will get name as type identifier }
  33. procedure read_named_type(var def:tdef;const name : TIDString;genericdef:tstoreddef;genericlist:TFPObjectList;parseprocvardir:boolean);
  34. { reads any type declaration }
  35. procedure read_anon_type(var def : tdef;parseprocvardir:boolean);
  36. { generate persistent type information like VMT, RTTI and inittables }
  37. procedure write_persistent_type_info(st:tsymtable);
  38. implementation
  39. uses
  40. { common }
  41. cutils,
  42. { global }
  43. globals,tokens,verbose,constexp,
  44. systems,
  45. { target }
  46. paramgr,procinfo,
  47. { symtable }
  48. symconst,symsym,symtable,
  49. defutil,defcmp,
  50. { modules }
  51. fmodule,
  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 resolve_forward_types;
  59. var
  60. i: longint;
  61. hpd,
  62. def : tdef;
  63. srsym : tsym;
  64. srsymtable : TSymtable;
  65. hs : string;
  66. begin
  67. for i:=0 to current_module.checkforwarddefs.Count-1 do
  68. begin
  69. def:=tdef(current_module.checkforwarddefs[i]);
  70. case def.typ of
  71. pointerdef,
  72. classrefdef :
  73. begin
  74. { classrefdef inherits from pointerdef }
  75. hpd:=tabstractpointerdef(def).pointeddef;
  76. { still a forward def ? }
  77. if hpd.typ=forwarddef then
  78. begin
  79. { try to resolve the forward }
  80. if not assigned(tforwarddef(hpd).tosymname) then
  81. internalerror(200211201);
  82. hs:=tforwarddef(hpd).tosymname^;
  83. searchsym(upper(hs),srsym,srsymtable);
  84. { we don't need the forwarddef anymore, dispose it }
  85. hpd.free;
  86. tabstractpointerdef(def).pointeddef:=nil; { if error occurs }
  87. { was a type sym found ? }
  88. if assigned(srsym) and
  89. (srsym.typ=typesym) then
  90. begin
  91. tabstractpointerdef(def).pointeddef:=ttypesym(srsym).typedef;
  92. { avoid wrong unused warnings web bug 801 PM }
  93. inc(ttypesym(srsym).refs);
  94. { we need a class type for classrefdef }
  95. if (def.typ=classrefdef) and
  96. not(is_class(ttypesym(srsym).typedef)) and
  97. not(is_objcclass(ttypesym(srsym).typedef)) then
  98. MessagePos1(def.typesym.fileinfo,type_e_class_type_expected,ttypesym(srsym).typedef.typename);
  99. end
  100. else
  101. begin
  102. Message1(sym_e_forward_type_not_resolved,hs);
  103. { try to recover }
  104. tabstractpointerdef(def).pointeddef:=generrordef;
  105. end;
  106. end;
  107. end;
  108. objectdef :
  109. begin
  110. { give an error as the implementation may follow in an
  111. other type block which is allowed by FPC modes }
  112. if not(m_fpc in current_settings.modeswitches) and
  113. (oo_is_forward in tobjectdef(def).objectoptions) then
  114. MessagePos1(def.typesym.fileinfo,type_e_type_is_not_completly_defined,def.typename);
  115. end;
  116. else
  117. internalerror(200811071);
  118. end;
  119. end;
  120. current_module.checkforwarddefs.clear;
  121. end;
  122. procedure generate_specialization(var tt:tdef);
  123. var
  124. st : TSymtable;
  125. srsym : tsym;
  126. pt2 : tnode;
  127. first,
  128. err : boolean;
  129. i : longint;
  130. sym : tsym;
  131. genericdef : tstoreddef;
  132. generictype : ttypesym;
  133. generictypelist : TFPObjectList;
  134. oldsymtablestack : tsymtablestack;
  135. hmodule : tmodule;
  136. pu : tused_unit;
  137. uspecializename,
  138. specializename : string;
  139. vmtbuilder : TVMTBuilder;
  140. onlyparsepara : boolean;
  141. specializest : tsymtable;
  142. begin
  143. { retrieve generic def that we are going to replace }
  144. genericdef:=tstoreddef(tt);
  145. tt:=nil;
  146. onlyparsepara:=false;
  147. if not(df_generic in genericdef.defoptions) then
  148. begin
  149. Message(parser_e_special_onlygenerics);
  150. tt:=generrordef;
  151. onlyparsepara:=true;
  152. end;
  153. { only need to record the tokens, then we don't know the type yet ... }
  154. if parse_generic then
  155. begin
  156. { ... but we have to insert a def into the symtable else the deflist
  157. of generic and specialization might not be equally sized which
  158. is later assumed }
  159. tt:=tundefineddef.create;
  160. onlyparsepara:=true;
  161. end;
  162. { Only parse the parameters for recovery or
  163. for recording in genericbuf }
  164. if onlyparsepara then
  165. begin
  166. consume(_LSHARPBRACKET);
  167. repeat
  168. pt2:=factor(false);
  169. pt2.free;
  170. until not try_to_consume(_COMMA);
  171. consume(_RSHARPBRACKET);
  172. exit;
  173. end;
  174. consume(_LSHARPBRACKET);
  175. { Parse generic parameters, for each undefineddef in the symtable of
  176. the genericdef we need to have a new def }
  177. err:=false;
  178. first:=true;
  179. generictypelist:=TFPObjectList.create(false);
  180. case genericdef.typ of
  181. procdef :
  182. st:=genericdef.GetSymtable(gs_para);
  183. objectdef,
  184. recorddef :
  185. st:=genericdef.GetSymtable(gs_record);
  186. end;
  187. if not assigned(st) then
  188. internalerror(200511182);
  189. { Parse type parameters }
  190. if not assigned(genericdef.typesym) then
  191. internalerror(200710173);
  192. specializename:=genericdef.typesym.realname;
  193. for i:=0 to st.SymList.Count-1 do
  194. begin
  195. sym:=tsym(st.SymList[i]);
  196. if (sp_generic_para in sym.symoptions) then
  197. begin
  198. if not first then
  199. consume(_COMMA)
  200. else
  201. first:=false;
  202. pt2:=factor(false);
  203. if pt2.nodetype=typen then
  204. begin
  205. if df_generic in pt2.resultdef.defoptions then
  206. Message(parser_e_no_generics_as_params);
  207. generictype:=ttypesym.create(sym.realname,pt2.resultdef);
  208. generictypelist.add(generictype);
  209. if not assigned(pt2.resultdef.typesym) then
  210. message(type_e_generics_cannot_reference_itself)
  211. else
  212. specializename:=specializename+'$'+pt2.resultdef.typesym.realname;
  213. end
  214. else
  215. begin
  216. Message(type_e_type_id_expected);
  217. err:=true;
  218. end;
  219. pt2.free;
  220. end;
  221. end;
  222. uspecializename:=upper(specializename);
  223. { force correct error location if too much type parameters are passed }
  224. if token<>_RSHARPBRACKET then
  225. consume(_RSHARPBRACKET);
  226. { Special case if we are referencing the current defined object }
  227. if assigned(current_objectdef) and
  228. (current_objectdef.objname^=uspecializename) then
  229. tt:=current_objectdef;
  230. { for units specializations can already be needed in the interface, therefor we
  231. will use the global symtable. Programs don't have a globalsymtable and there we
  232. use the localsymtable }
  233. if current_module.is_unit then
  234. specializest:=current_module.globalsymtable
  235. else
  236. specializest:=current_module.localsymtable;
  237. { Can we reuse an already specialized type? }
  238. if not assigned(tt) then
  239. begin
  240. srsym:=tsym(specializest.find(uspecializename));
  241. if assigned(srsym) then
  242. begin
  243. if srsym.typ<>typesym then
  244. internalerror(200710171);
  245. tt:=ttypesym(srsym).typedef;
  246. end;
  247. end;
  248. if not assigned(tt) then
  249. begin
  250. { Setup symtablestack at definition time
  251. to get types right, however this is not perfect, we should probably record
  252. the resolved symbols }
  253. oldsymtablestack:=symtablestack;
  254. symtablestack:=tsymtablestack.create;
  255. if not assigned(genericdef) then
  256. internalerror(200705151);
  257. hmodule:=find_module_from_symtable(genericdef.owner);
  258. if hmodule=nil then
  259. internalerror(200705152);
  260. pu:=tused_unit(hmodule.used_units.first);
  261. while assigned(pu) do
  262. begin
  263. if not assigned(pu.u.globalsymtable) then
  264. internalerror(200705153);
  265. symtablestack.push(pu.u.globalsymtable);
  266. pu:=tused_unit(pu.next);
  267. end;
  268. if assigned(hmodule.globalsymtable) then
  269. symtablestack.push(hmodule.globalsymtable);
  270. { hacky, but necessary to insert the newly generated class properly }
  271. symtablestack.push(oldsymtablestack.top);
  272. { Reparse the original type definition }
  273. if not err then
  274. begin
  275. { First a new typesym so we can reuse this specialization and
  276. references to this specialization can be handled }
  277. srsym:=ttypesym.create(specializename,generrordef);
  278. specializest.insert(srsym);
  279. if not assigned(genericdef.generictokenbuf) then
  280. internalerror(200511171);
  281. current_scanner.startreplaytokens(genericdef.generictokenbuf);
  282. read_named_type(tt,specializename,genericdef,generictypelist,false);
  283. ttypesym(srsym).typedef:=tt;
  284. tt.typesym:=srsym;
  285. { Consume the semicolon if it is also recorded }
  286. try_to_consume(_SEMICOLON);
  287. { Build VMT indexes for classes }
  288. if (tt.typ=objectdef) then
  289. begin
  290. vmtbuilder:=TVMTBuilder.Create(tobjectdef(tt));
  291. vmtbuilder.generate_vmt;
  292. vmtbuilder.free;
  293. end;
  294. end;
  295. { Restore symtablestack }
  296. symtablestack.free;
  297. symtablestack:=oldsymtablestack;
  298. end;
  299. generictypelist.free;
  300. consume(_RSHARPBRACKET);
  301. end;
  302. procedure id_type(var def : tdef;isforwarddef:boolean);
  303. { reads a type definition }
  304. { to a appropriating tdef, s gets the name of }
  305. { the type to allow name mangling }
  306. var
  307. is_unit_specific : boolean;
  308. pos : tfileposinfo;
  309. srsym : tsym;
  310. srsymtable : TSymtable;
  311. s,sorg : TIDString;
  312. t : ttoken;
  313. begin
  314. s:=pattern;
  315. sorg:=orgpattern;
  316. pos:=current_tokenpos;
  317. { use of current parsed object:
  318. - classes can be used also in classes
  319. - objects can be parameters }
  320. if assigned(current_objectdef) and
  321. (current_objectdef.objname^=pattern) and
  322. (
  323. (testcurobject=2) or
  324. is_class_or_interface_or_objc(current_objectdef)
  325. )then
  326. begin
  327. consume(_ID);
  328. def:=current_objectdef;
  329. exit;
  330. end;
  331. { Use the special searchsym_type that ignores records,objects and
  332. parameters }
  333. searchsym_type(s,srsym,srsymtable);
  334. { handle unit specification like System.Writeln }
  335. is_unit_specific:=try_consume_unitsym(srsym,srsymtable,t);
  336. consume(t);
  337. { Types are first defined with an error def before assigning
  338. the real type so check if it's an errordef. if so then
  339. give an error. Only check for typesyms in the current symbol
  340. table as forwarddef are not resolved directly }
  341. if assigned(srsym) and
  342. (srsym.typ=typesym) and
  343. (ttypesym(srsym).typedef.typ=errordef) then
  344. begin
  345. Message1(type_e_type_is_not_completly_defined,ttypesym(srsym).realname);
  346. def:=generrordef;
  347. exit;
  348. end;
  349. { are we parsing a possible forward def ? }
  350. if isforwarddef and
  351. not(is_unit_specific) then
  352. begin
  353. def:=tforwarddef.create(sorg,pos);
  354. exit;
  355. end;
  356. { unknown sym ? }
  357. if not assigned(srsym) then
  358. begin
  359. Message1(sym_e_id_not_found,sorg);
  360. def:=generrordef;
  361. exit;
  362. end;
  363. { type sym ? }
  364. if (srsym.typ<>typesym) then
  365. begin
  366. Message(type_e_type_id_expected);
  367. def:=generrordef;
  368. exit;
  369. end;
  370. { Give an error when referring to an errordef }
  371. if (ttypesym(srsym).typedef.typ=errordef) then
  372. begin
  373. Message(sym_e_error_in_type_def);
  374. def:=generrordef;
  375. exit;
  376. end;
  377. def:=ttypesym(srsym).typedef;
  378. end;
  379. procedure single_type(var def:tdef;isforwarddef,allowtypedef:boolean);
  380. var
  381. t2 : tdef;
  382. dospecialize,
  383. again : boolean;
  384. begin
  385. dospecialize:=false;
  386. repeat
  387. again:=false;
  388. case token of
  389. _STRING:
  390. string_dec(def,allowtypedef);
  391. _FILE:
  392. begin
  393. consume(_FILE);
  394. if (token=_OF) then
  395. begin
  396. if not(allowtypedef) then
  397. Message(parser_e_no_local_para_def);
  398. consume(_OF);
  399. single_type(t2,false,false);
  400. if is_managed_type(t2) then
  401. Message(parser_e_no_refcounted_typed_file);
  402. def:=tfiledef.createtyped(t2);
  403. end
  404. else
  405. def:=cfiletype;
  406. end;
  407. _ID:
  408. begin
  409. if try_to_consume(_SPECIALIZE) then
  410. begin
  411. dospecialize:=true;
  412. again:=true;
  413. end
  414. else
  415. begin
  416. id_type(def,isforwarddef);
  417. { handle types inside classes, e.g. TNode.TLongint }
  418. while (token=_POINT) do
  419. begin
  420. if parse_generic then
  421. begin
  422. consume(_POINT);
  423. consume(_ID);
  424. end
  425. else if is_class(def) then
  426. begin
  427. symtablestack.push(tobjectdef(def).symtable);
  428. consume(_POINT);
  429. id_type(t2,isforwarddef);
  430. symtablestack.pop(tobjectdef(def).symtable);
  431. def:=t2;
  432. end
  433. else
  434. break;
  435. end;
  436. end;
  437. end;
  438. else
  439. begin
  440. message(type_e_type_id_expected);
  441. def:=generrordef;
  442. end;
  443. end;
  444. until not again;
  445. if dospecialize then
  446. generate_specialization(def)
  447. else
  448. begin
  449. if (df_generic in def.defoptions) then
  450. begin
  451. Message(parser_e_no_generics_as_types);
  452. def:=generrordef;
  453. end
  454. else if is_objccategory(def) then
  455. begin
  456. Message(parser_e_no_category_as_types);
  457. def:=generrordef
  458. end
  459. end;
  460. end;
  461. { reads a record declaration }
  462. function record_dec : tdef;
  463. var
  464. recst : trecordsymtable;
  465. begin
  466. { create recdef }
  467. recst:=trecordsymtable.create(current_settings.packrecords);
  468. record_dec:=trecorddef.create(recst);
  469. { insert in symtablestack }
  470. symtablestack.push(recst);
  471. { parse record }
  472. consume(_RECORD);
  473. read_record_fields([vd_record]);
  474. consume(_END);
  475. { make the record size aligned }
  476. recst.addalignmentpadding;
  477. { restore symtable stack }
  478. symtablestack.pop(recst);
  479. if trecorddef(record_dec).is_packed and
  480. is_managed_type(record_dec) then
  481. Message(type_e_no_packed_inittable);
  482. end;
  483. { reads a type definition and returns a pointer to it }
  484. procedure read_named_type(var def : tdef;const name : TIDString;genericdef:tstoreddef;genericlist:TFPObjectList;parseprocvardir:boolean);
  485. var
  486. pt : tnode;
  487. tt2 : tdef;
  488. aktenumdef : tenumdef;
  489. s : TIDString;
  490. l,v : TConstExprInt;
  491. oldpackrecords : longint;
  492. defpos,storepos : tfileposinfo;
  493. procedure expr_type;
  494. var
  495. pt1,pt2 : tnode;
  496. lv,hv : TConstExprInt;
  497. old_block_type : tblock_type;
  498. dospecialize : boolean;
  499. begin
  500. old_block_type:=block_type;
  501. dospecialize:=false;
  502. { use of current parsed object:
  503. - classes can be used also in classes
  504. - objects can be parameters }
  505. if (token=_ID) and
  506. assigned(current_objectdef) and
  507. (current_objectdef.objname^=pattern) and
  508. (
  509. (testcurobject=2) or
  510. is_class_or_interface_or_objc(current_objectdef)
  511. )then
  512. begin
  513. consume(_ID);
  514. def:=current_objectdef;
  515. exit;
  516. end;
  517. { Generate a specialization? }
  518. if try_to_consume(_SPECIALIZE) then
  519. dospecialize:=true;
  520. { we can't accept a equal in type }
  521. pt1:=comp_expr(false);
  522. if not dospecialize and
  523. try_to_consume(_POINTPOINT) then
  524. begin
  525. { get high value of range }
  526. pt2:=comp_expr(false);
  527. { make both the same type or give an error. This is not
  528. done when both are integer values, because typecasting
  529. between -3200..3200 will result in a signed-unsigned
  530. conflict and give a range check error (PFV) }
  531. if not(is_integer(pt1.resultdef) and is_integer(pt2.resultdef)) then
  532. inserttypeconv(pt1,pt2.resultdef);
  533. { both must be evaluated to constants now }
  534. if (pt1.nodetype=ordconstn) and
  535. (pt2.nodetype=ordconstn) then
  536. begin
  537. lv:=tordconstnode(pt1).value;
  538. hv:=tordconstnode(pt2).value;
  539. { Check bounds }
  540. if hv<lv then
  541. message(parser_e_upper_lower_than_lower)
  542. else if (lv.signed and (lv.svalue<0)) and (not hv.signed and (hv.uvalue>qword(high(int64)))) then
  543. message(type_e_cant_eval_constant_expr)
  544. else
  545. begin
  546. { All checks passed, create the new def }
  547. case pt1.resultdef.typ of
  548. enumdef :
  549. def:=tenumdef.create_subrange(tenumdef(pt1.resultdef),lv.svalue,hv.svalue);
  550. orddef :
  551. begin
  552. if is_char(pt1.resultdef) then
  553. def:=torddef.create(uchar,lv,hv)
  554. else
  555. if is_boolean(pt1.resultdef) then
  556. def:=torddef.create(pasbool,lv,hv)
  557. else if is_signed(pt1.resultdef) then
  558. def:=torddef.create(range_to_basetype(lv,hv),lv,hv)
  559. else
  560. def:=torddef.create(range_to_basetype(lv,hv),lv,hv);
  561. end;
  562. end;
  563. end;
  564. end
  565. else
  566. Message(sym_e_error_in_type_def);
  567. pt2.free;
  568. end
  569. else
  570. begin
  571. { a simple type renaming or generic specialization }
  572. if (pt1.nodetype=typen) then
  573. begin
  574. def:=ttypenode(pt1).resultdef;
  575. if dospecialize then
  576. generate_specialization(def)
  577. else
  578. begin
  579. if (df_generic in def.defoptions) then
  580. begin
  581. Message(parser_e_no_generics_as_types);
  582. def:=generrordef;
  583. end
  584. else if is_objccategory(def) then
  585. begin
  586. Message(parser_e_no_category_as_types);
  587. def:=generrordef
  588. end
  589. end;
  590. end
  591. else
  592. Message(sym_e_error_in_type_def);
  593. end;
  594. pt1.free;
  595. block_type:=old_block_type;
  596. end;
  597. procedure set_dec;
  598. begin
  599. consume(_SET);
  600. consume(_OF);
  601. read_anon_type(tt2,true);
  602. if assigned(tt2) then
  603. begin
  604. case tt2.typ of
  605. { don't forget that min can be negativ PM }
  606. enumdef :
  607. if (tenumdef(tt2).min>=0) and
  608. (tenumdef(tt2).max<=255) then
  609. // !! def:=tsetdef.create(tt2,tenumdef(tt2.def).min,tenumdef(tt2.def).max))
  610. def:=tsetdef.create(tt2,tenumdef(tt2).min,tenumdef(tt2).max)
  611. else
  612. Message(sym_e_ill_type_decl_set);
  613. orddef :
  614. begin
  615. if (torddef(tt2).ordtype<>uvoid) and
  616. (torddef(tt2).ordtype<>uwidechar) and
  617. (torddef(tt2).low>=0) then
  618. // !! def:=tsetdef.create(tt2,torddef(tt2.def).low,torddef(tt2.def).high))
  619. if Torddef(tt2).high>int64(high(byte)) then
  620. message(sym_e_ill_type_decl_set)
  621. else
  622. def:=tsetdef.create(tt2,torddef(tt2).low.svalue,torddef(tt2).high.svalue)
  623. else
  624. Message(sym_e_ill_type_decl_set);
  625. end;
  626. else
  627. Message(sym_e_ill_type_decl_set);
  628. end;
  629. end
  630. else
  631. def:=generrordef;
  632. end;
  633. procedure array_dec(is_packed: boolean);
  634. var
  635. lowval,
  636. highval : TConstExprInt;
  637. indexdef : tdef;
  638. hdef : tdef;
  639. arrdef : tarraydef;
  640. procedure setdefdecl(def:tdef);
  641. begin
  642. case def.typ of
  643. enumdef :
  644. begin
  645. lowval:=tenumdef(def).min;
  646. highval:=tenumdef(def).max;
  647. if (m_fpc in current_settings.modeswitches) and
  648. (tenumdef(def).has_jumps) then
  649. Message(type_e_array_index_enums_with_assign_not_possible);
  650. indexdef:=def;
  651. end;
  652. orddef :
  653. begin
  654. if torddef(def).ordtype in [uchar,
  655. u8bit,u16bit,
  656. s8bit,s16bit,s32bit,
  657. {$ifdef cpu64bitaddr}
  658. u32bit,s64bit,
  659. {$endif cpu64bitaddr}
  660. pasbool,bool8bit,bool16bit,bool32bit,bool64bit,
  661. uwidechar] then
  662. begin
  663. lowval:=torddef(def).low;
  664. highval:=torddef(def).high;
  665. indexdef:=def;
  666. end
  667. else
  668. Message1(parser_e_type_cant_be_used_in_array_index,def.GetTypeName);
  669. end;
  670. else
  671. Message(sym_e_error_in_type_def);
  672. end;
  673. end;
  674. begin
  675. arrdef:=nil;
  676. consume(_ARRAY);
  677. { open array? }
  678. if try_to_consume(_LECKKLAMMER) then
  679. begin
  680. { defaults }
  681. indexdef:=generrordef;
  682. { use defaults which don't overflow the compiler }
  683. lowval:=0;
  684. highval:=0;
  685. repeat
  686. { read the expression and check it, check apart if the
  687. declaration is an enum declaration because that needs to
  688. be parsed by readtype (PFV) }
  689. if token=_LKLAMMER then
  690. begin
  691. read_anon_type(hdef,true);
  692. setdefdecl(hdef);
  693. end
  694. else
  695. begin
  696. pt:=expr(true);
  697. if pt.nodetype=typen then
  698. setdefdecl(pt.resultdef)
  699. else
  700. begin
  701. if (pt.nodetype=rangen) then
  702. begin
  703. if (trangenode(pt).left.nodetype=ordconstn) and
  704. (trangenode(pt).right.nodetype=ordconstn) then
  705. begin
  706. { make both the same type or give an error. This is not
  707. done when both are integer values, because typecasting
  708. between -3200..3200 will result in a signed-unsigned
  709. conflict and give a range check error (PFV) }
  710. if not(is_integer(trangenode(pt).left.resultdef) and is_integer(trangenode(pt).left.resultdef)) then
  711. inserttypeconv(trangenode(pt).left,trangenode(pt).right.resultdef);
  712. lowval:=tordconstnode(trangenode(pt).left).value;
  713. highval:=tordconstnode(trangenode(pt).right).value;
  714. if highval<lowval then
  715. begin
  716. Message(parser_e_array_lower_less_than_upper_bound);
  717. highval:=lowval;
  718. end
  719. else if (lowval<int64(low(aint))) or
  720. (highval > high(aint)) then
  721. begin
  722. Message(parser_e_array_range_out_of_bounds);
  723. lowval :=0;
  724. highval:=0;
  725. end;
  726. if is_integer(trangenode(pt).left.resultdef) then
  727. range_to_type(lowval,highval,indexdef)
  728. else
  729. indexdef:=trangenode(pt).left.resultdef;
  730. end
  731. else
  732. Message(type_e_cant_eval_constant_expr);
  733. end
  734. else
  735. Message(sym_e_error_in_type_def)
  736. end;
  737. pt.free;
  738. end;
  739. { if the array is already created add the new arrray
  740. as element of the existing array, otherwise create a new array }
  741. if assigned(arrdef) then
  742. begin
  743. arrdef.elementdef:=tarraydef.create(lowval.svalue,highval.svalue,indexdef);
  744. arrdef:=tarraydef(arrdef.elementdef);
  745. end
  746. else
  747. begin
  748. arrdef:=tarraydef.create(lowval.svalue,highval.svalue,indexdef);
  749. def:=arrdef;
  750. end;
  751. if is_packed then
  752. include(arrdef.arrayoptions,ado_IsBitPacked);
  753. if token=_COMMA then
  754. consume(_COMMA)
  755. else
  756. break;
  757. until false;
  758. consume(_RECKKLAMMER);
  759. end
  760. else
  761. begin
  762. if is_packed then
  763. Message(parser_e_packed_dynamic_open_array);
  764. arrdef:=tarraydef.create(0,-1,s32inttype);
  765. include(arrdef.arrayoptions,ado_IsDynamicArray);
  766. def:=arrdef;
  767. end;
  768. consume(_OF);
  769. read_anon_type(tt2,true);
  770. { set element type of the last array definition }
  771. if assigned(arrdef) then
  772. begin
  773. arrdef.elementdef:=tt2;
  774. if is_packed and
  775. is_managed_type(tt2) then
  776. Message(type_e_no_packed_inittable);
  777. end;
  778. end;
  779. var
  780. p : tnode;
  781. hdef : tdef;
  782. pd : tabstractprocdef;
  783. is_func,
  784. enumdupmsg, first : boolean;
  785. newtype : ttypesym;
  786. oldlocalswitches : tlocalswitches;
  787. bitpacking: boolean;
  788. begin
  789. def:=nil;
  790. case token of
  791. _STRING,_FILE:
  792. begin
  793. single_type(def,false,true);
  794. end;
  795. _LKLAMMER:
  796. begin
  797. consume(_LKLAMMER);
  798. first := true;
  799. { allow negativ value_str }
  800. l:=int64(-1);
  801. enumdupmsg:=false;
  802. aktenumdef:=tenumdef.create;
  803. repeat
  804. s:=orgpattern;
  805. defpos:=current_tokenpos;
  806. consume(_ID);
  807. { only allow assigning of specific numbers under fpc mode }
  808. if not(m_tp7 in current_settings.modeswitches) and
  809. (
  810. { in fpc mode also allow := to be compatible
  811. with previous 1.0.x versions }
  812. ((m_fpc in current_settings.modeswitches) and
  813. try_to_consume(_ASSIGNMENT)) or
  814. try_to_consume(_EQUAL)
  815. ) then
  816. begin
  817. oldlocalswitches:=current_settings.localswitches;
  818. include(current_settings.localswitches,cs_allow_enum_calc);
  819. p:=comp_expr(true);
  820. current_settings.localswitches:=oldlocalswitches;
  821. if (p.nodetype=ordconstn) then
  822. begin
  823. { we expect an integer or an enum of the
  824. same type }
  825. if is_integer(p.resultdef) or
  826. is_char(p.resultdef) or
  827. equal_defs(p.resultdef,aktenumdef) then
  828. v:=tordconstnode(p).value
  829. else
  830. IncompatibleTypes(p.resultdef,s32inttype);
  831. end
  832. else
  833. Message(parser_e_illegal_expression);
  834. p.free;
  835. { please leave that a note, allows type save }
  836. { declarations in the win32 units ! }
  837. if (not first) and (v<=l) and (not enumdupmsg) then
  838. begin
  839. Message(parser_n_duplicate_enum);
  840. enumdupmsg:=true;
  841. end;
  842. l:=v;
  843. end
  844. else
  845. inc(l.svalue);
  846. first := false;
  847. storepos:=current_tokenpos;
  848. current_tokenpos:=defpos;
  849. tenumsymtable(aktenumdef.symtable).insert(tenumsym.create(s,aktenumdef,longint(l.svalue)));
  850. if not (cs_scopedenums in current_settings.localswitches) then
  851. tstoredsymtable(aktenumdef.owner).insert(tenumsym.create(s,aktenumdef,longint(l.svalue)));
  852. current_tokenpos:=storepos;
  853. until not try_to_consume(_COMMA);
  854. def:=aktenumdef;
  855. consume(_RKLAMMER);
  856. end;
  857. _ARRAY:
  858. begin
  859. array_dec(false);
  860. end;
  861. _SET:
  862. begin
  863. set_dec;
  864. end;
  865. _CARET:
  866. begin
  867. consume(_CARET);
  868. single_type(tt2,(block_type=bt_type),false);
  869. def:=tpointerdef.create(tt2);
  870. if tt2.typ=forwarddef then
  871. current_module.checkforwarddefs.add(def);
  872. end;
  873. _RECORD:
  874. begin
  875. def:=record_dec;
  876. end;
  877. _PACKED,
  878. _BITPACKED:
  879. begin
  880. bitpacking :=
  881. (cs_bitpacking in current_settings.localswitches) or
  882. (token = _BITPACKED);
  883. consume(token);
  884. if token=_ARRAY then
  885. array_dec(bitpacking)
  886. else if token=_SET then
  887. set_dec
  888. else if token=_FILE then
  889. single_type(def,false,true)
  890. else
  891. begin
  892. oldpackrecords:=current_settings.packrecords;
  893. if (not bitpacking) or
  894. (token in [_CLASS,_OBJECT]) then
  895. current_settings.packrecords:=1
  896. else
  897. current_settings.packrecords:=bit_alignment;
  898. case token of
  899. _CLASS :
  900. begin
  901. consume(_CLASS);
  902. def:=object_dec(odt_class,name,genericdef,genericlist,nil);
  903. end;
  904. _OBJECT :
  905. begin
  906. consume(_OBJECT);
  907. def:=object_dec(odt_object,name,genericdef,genericlist,nil);
  908. end;
  909. else
  910. def:=record_dec;
  911. end;
  912. current_settings.packrecords:=oldpackrecords;
  913. end;
  914. end;
  915. _DISPINTERFACE :
  916. begin
  917. { need extra check here since interface is a keyword
  918. in all pascal modes }
  919. if not(m_class in current_settings.modeswitches) then
  920. Message(parser_f_need_objfpc_or_delphi_mode);
  921. consume(token);
  922. def:=object_dec(odt_dispinterface,name,genericdef,genericlist,nil);
  923. end;
  924. _CLASS :
  925. begin
  926. consume(token);
  927. { Delphi only allows class of in type blocks }
  928. if (token=_OF) and
  929. (
  930. not(m_delphi in current_settings.modeswitches) or
  931. (block_type=bt_type)
  932. ) then
  933. begin
  934. consume(_OF);
  935. single_type(hdef,(block_type=bt_type),false);
  936. if is_class(hdef) or
  937. is_objcclass(hdef) then
  938. def:=tclassrefdef.create(hdef)
  939. else
  940. if hdef.typ=forwarddef then
  941. begin
  942. def:=tclassrefdef.create(hdef);
  943. current_module.checkforwarddefs.add(def);
  944. end
  945. else
  946. Message1(type_e_class_or_objcclass_type_expected,hdef.typename);
  947. end
  948. else
  949. def:=object_dec(odt_class,name,genericdef,genericlist,nil);
  950. end;
  951. _CPPCLASS :
  952. begin
  953. consume(token);
  954. def:=object_dec(odt_cppclass,name,genericdef,genericlist,nil);
  955. end;
  956. _OBJCCLASS :
  957. begin
  958. if not(m_objectivec1 in current_settings.modeswitches) then
  959. Message(parser_f_need_objc);
  960. consume(token);
  961. def:=object_dec(odt_objcclass,name,genericdef,genericlist,nil);
  962. end;
  963. _INTERFACE :
  964. begin
  965. { need extra check here since interface is a keyword
  966. in all pascal modes }
  967. if not(m_class in current_settings.modeswitches) then
  968. Message(parser_f_need_objfpc_or_delphi_mode);
  969. consume(token);
  970. if current_settings.interfacetype=it_interfacecom then
  971. def:=object_dec(odt_interfacecom,name,genericdef,genericlist,nil)
  972. else {it_interfacecorba}
  973. def:=object_dec(odt_interfacecorba,name,genericdef,genericlist,nil);
  974. end;
  975. _OBJCPROTOCOL :
  976. begin
  977. if not(m_objectivec1 in current_settings.modeswitches) then
  978. Message(parser_f_need_objc);
  979. consume(token);
  980. def:=object_dec(odt_objcprotocol,name,genericdef,genericlist,nil);
  981. end;
  982. _OBJCCATEGORY :
  983. begin
  984. if not(m_objectivec1 in current_settings.modeswitches) then
  985. Message(parser_f_need_objc);
  986. consume(token);
  987. def:=object_dec(odt_objccategory,name,genericdef,genericlist,nil);
  988. end;
  989. _OBJECT :
  990. begin
  991. consume(token);
  992. def:=object_dec(odt_object,name,genericdef,genericlist,nil);
  993. end;
  994. _PROCEDURE,
  995. _FUNCTION:
  996. begin
  997. is_func:=(token=_FUNCTION);
  998. consume(token);
  999. pd:=tprocvardef.create(normal_function_level);
  1000. if token=_LKLAMMER then
  1001. parse_parameter_dec(pd);
  1002. if is_func then
  1003. begin
  1004. consume(_COLON);
  1005. single_type(pd.returndef,false,false);
  1006. end;
  1007. if try_to_consume(_OF) then
  1008. begin
  1009. consume(_OBJECT);
  1010. include(pd.procoptions,po_methodpointer);
  1011. end
  1012. else if (m_nested_procvars in current_settings.modeswitches) and
  1013. try_to_consume(_IS) then
  1014. begin
  1015. consume(_NESTED);
  1016. pd.parast.symtablelevel:=normal_function_level+1;
  1017. pd.check_mark_as_nested;
  1018. end;
  1019. def:=pd;
  1020. { possible proc directives }
  1021. if parseprocvardir then
  1022. begin
  1023. if check_proc_directive(true) then
  1024. begin
  1025. newtype:=ttypesym.create('unnamed',def);
  1026. parse_var_proc_directives(tsym(newtype));
  1027. newtype.typedef:=nil;
  1028. def.typesym:=nil;
  1029. newtype.free;
  1030. end;
  1031. { Add implicit hidden parameters and function result }
  1032. handle_calling_convention(pd);
  1033. end;
  1034. end;
  1035. else
  1036. if (token=_KLAMMERAFFE) and (m_iso in current_settings.modeswitches) then
  1037. begin
  1038. consume(_KLAMMERAFFE);
  1039. single_type(tt2,(block_type=bt_type),false);
  1040. def:=tpointerdef.create(tt2);
  1041. if tt2.typ=forwarddef then
  1042. current_module.checkforwarddefs.add(def);
  1043. end
  1044. else
  1045. expr_type;
  1046. end;
  1047. if def=nil then
  1048. def:=generrordef;
  1049. end;
  1050. procedure read_anon_type(var def : tdef;parseprocvardir:boolean);
  1051. begin
  1052. read_named_type(def,'',nil,nil,parseprocvardir);
  1053. end;
  1054. procedure write_persistent_type_info(st:tsymtable);
  1055. var
  1056. i : longint;
  1057. def : tdef;
  1058. vmtwriter : TVMTWriter;
  1059. begin
  1060. for i:=0 to st.DefList.Count-1 do
  1061. begin
  1062. def:=tdef(st.DefList[i]);
  1063. case def.typ of
  1064. recorddef :
  1065. write_persistent_type_info(trecorddef(def).symtable);
  1066. objectdef :
  1067. begin
  1068. { Skip generics and forward defs }
  1069. if (df_generic in def.defoptions) or
  1070. (oo_is_forward in tobjectdef(def).objectoptions) then
  1071. continue;
  1072. write_persistent_type_info(tobjectdef(def).symtable);
  1073. { Write also VMT if not done yet }
  1074. if not(ds_vmt_written in def.defstates) then
  1075. begin
  1076. vmtwriter:=TVMTWriter.create(tobjectdef(def));
  1077. if is_interface(tobjectdef(def)) then
  1078. vmtwriter.writeinterfaceids;
  1079. if (oo_has_vmt in tobjectdef(def).objectoptions) then
  1080. vmtwriter.writevmt;
  1081. vmtwriter.free;
  1082. include(def.defstates,ds_vmt_written);
  1083. end;
  1084. end;
  1085. procdef :
  1086. begin
  1087. if assigned(tprocdef(def).localst) and
  1088. (tprocdef(def).localst.symtabletype=localsymtable) then
  1089. write_persistent_type_info(tprocdef(def).localst);
  1090. if assigned(tprocdef(def).parast) then
  1091. write_persistent_type_info(tprocdef(def).parast);
  1092. end;
  1093. end;
  1094. { generate always persistent tables for types in the interface so it can
  1095. be reused in other units and give always the same pointer location. }
  1096. { Init }
  1097. if (
  1098. assigned(def.typesym) and
  1099. (st.symtabletype=globalsymtable) and
  1100. not is_objc_class_or_protocol(def)
  1101. ) or
  1102. is_managed_type(def) or
  1103. (ds_init_table_used in def.defstates) then
  1104. RTTIWriter.write_rtti(def,initrtti);
  1105. { RTTI }
  1106. if (
  1107. assigned(def.typesym) and
  1108. (st.symtabletype=globalsymtable) and
  1109. not is_objc_class_or_protocol(def)
  1110. ) or
  1111. (ds_rtti_table_used in def.defstates) then
  1112. RTTIWriter.write_rtti(def,fullrtti);
  1113. end;
  1114. end;
  1115. end.