pdecl.pas 103 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038203920402041204220432044204520462047204820492050205120522053205420552056205720582059206020612062206320642065206620672068206920702071207220732074207520762077207820792080208120822083208420852086208720882089209020912092209320942095209620972098209921002101210221032104210521062107210821092110211121122113211421152116211721182119212021212122212321242125212621272128212921302131213221332134213521362137213821392140214121422143214421452146214721482149215021512152215321542155215621572158215921602161216221632164216521662167216821692170217121722173217421752176217721782179218021812182218321842185218621872188218921902191219221932194219521962197219821992200220122022203220422052206220722082209221022112212221322142215221622172218221922202221222222232224222522262227222822292230223122322233223422352236223722382239224022412242224322442245224622472248224922502251225222532254225522562257225822592260226122622263226422652266226722682269227022712272227322742275227622772278227922802281228222832284228522862287228822892290229122922293229422952296229722982299230023012302230323042305230623072308230923102311231223132314231523162317231823192320232123222323232423252326232723282329233023312332233323342335233623372338233923402341234223432344234523462347234823492350235123522353235423552356235723582359236023612362236323642365236623672368236923702371237223732374237523762377237823792380238123822383238423852386238723882389239023912392239323942395239623972398239924002401240224032404240524062407240824092410241124122413241424152416241724182419242024212422242324242425242624272428242924302431243224332434243524362437243824392440244124422443244424452446244724482449245024512452245324542455245624572458245924602461246224632464246524662467246824692470247124722473247424752476247724782479248024812482248324842485248624872488248924902491249224932494249524962497249824992500250125022503250425052506250725082509251025112512251325142515251625172518251925202521252225232524252525262527252825292530253125322533253425352536253725382539254025412542254325442545254625472548254925502551255225532554255525562557255825592560256125622563256425652566256725682569257025712572257325742575257625772578257925802581258225832584258525862587258825892590259125922593259425952596259725982599260026012602260326042605260626072608260926102611261226132614261526162617261826192620262126222623262426252626262726282629263026312632263326342635263626372638263926402641264226432644264526462647264826492650265126522653265426552656265726582659266026612662266326642665266626672668266926702671267226732674267526762677267826792680268126822683268426852686268726882689269026912692269326942695269626972698269927002701270227032704270527062707270827092710271127122713271427152716271727182719272027212722272327242725272627272728272927302731273227332734273527362737273827392740274127422743
  1. {
  2. $Id$
  3. Copyright (c) 1993-98 by Florian Klaempfl
  4. Does declaration parsing for Free Pascal
  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 pdecl;
  19. interface
  20. uses
  21. globtype,tokens,globals,symtable;
  22. var
  23. { pointer to the last read type symbol, (for "forward" }
  24. { types) }
  25. lasttypesym : ptypesym;
  26. { hack, which allows to use the current parsed }
  27. { object type as function argument type }
  28. testcurobject : byte;
  29. curobjectname : stringid;
  30. { reads a string type with optional length }
  31. { and returns a pointer to the string }
  32. { definition }
  33. function stringtype : pdef;
  34. { reads a string, file type or a type id and returns a name and }
  35. { pdef }
  36. function single_type(var s : string) : pdef;
  37. { reads the declaration blocks }
  38. procedure read_declarations(islibrary : boolean);
  39. { reads declarations in the interface part of a unit }
  40. procedure read_interface_declarations;
  41. implementation
  42. uses
  43. cobjects,scanner,aasm,tree,pass_1,strings,
  44. files,types,verbose,systems,import,tccnv
  45. {$ifdef GDB}
  46. ,gdb
  47. {$endif GDB}
  48. { parser specific stuff }
  49. ,pbase,ptconst,pexpr,psub,pexports
  50. { processor specific stuff }
  51. {$ifdef i386}
  52. ,i386base
  53. {$endif}
  54. {$ifdef m68k}
  55. ,m68k
  56. {$endif}
  57. { codegen }
  58. ,hcodegen,hcgdata
  59. ;
  60. function read_type(const name : stringid) : pdef;forward;
  61. { search in symtablestack used, but not defined type }
  62. procedure testforward_type(p : pnamedindexobject);{$ifndef FPC}far;{$endif}
  63. var
  64. reaktvarsymtable : psymtable;
  65. oldaktfilepos : tfileposinfo;
  66. begin
  67. if not(psym(p)^.typ=typesym) then
  68. exit;
  69. if ((psym(p)^.properties and sp_forwarddef)<>0) then
  70. begin
  71. oldaktfilepos:=aktfilepos;
  72. aktfilepos:=psym(p)^.fileinfo;
  73. Message1(sym_e_forward_type_not_resolved,p^.name);
  74. aktfilepos:=oldaktfilepos;
  75. { try to recover }
  76. ptypesym(p)^.definition:=generrordef;
  77. psym(p)^.properties:=psym(p)^.properties and (not sp_forwarddef);
  78. end
  79. else
  80. if (ptypesym(p)^.definition^.deftype in [recorddef,objectdef]) then
  81. begin
  82. if (ptypesym(p)^.definition^.deftype=recorddef) then
  83. reaktvarsymtable:=precdef(ptypesym(p)^.definition)^.symtable
  84. else
  85. reaktvarsymtable:=pobjectdef(ptypesym(p)^.definition)^.publicsyms;
  86. {$ifdef tp}
  87. reaktvarsymtable^.foreach(testforward_type);
  88. {$else}
  89. reaktvarsymtable^.foreach(@testforward_type);
  90. {$endif}
  91. end;
  92. end;
  93. procedure const_dec;
  94. var
  95. name : stringid;
  96. p : ptree;
  97. def : pdef;
  98. sym : psym;
  99. storetokenpos,filepos : tfileposinfo;
  100. old_block_type : tblock_type;
  101. ps : pconstset;
  102. pd : pbestreal;
  103. sp : pchar;
  104. begin
  105. consume(_CONST);
  106. old_block_type:=block_type;
  107. block_type:=bt_const;
  108. repeat
  109. name:=pattern;
  110. filepos:=tokenpos;
  111. consume(ID);
  112. case token of
  113. EQUAL:
  114. begin
  115. consume(EQUAL);
  116. p:=comp_expr(true);
  117. do_firstpass(p);
  118. storetokenpos:=tokenpos;
  119. tokenpos:=filepos;
  120. case p^.treetype of
  121. ordconstn:
  122. begin
  123. if is_constintnode(p) then
  124. symtablestack^.insert(new(pconstsym,init_def(name,constint,p^.value,nil)))
  125. else if is_constcharnode(p) then
  126. symtablestack^.insert(new(pconstsym,init_def(name,constchar,p^.value,nil)))
  127. else if is_constboolnode(p) then
  128. symtablestack^.insert(new(pconstsym,init_def(name,constbool,p^.value,nil)))
  129. else if p^.resulttype^.deftype=enumdef then
  130. symtablestack^.insert(new(pconstsym,init_def(name,constord,p^.value,p^.resulttype)))
  131. else if p^.resulttype^.deftype=pointerdef then
  132. symtablestack^.insert(new(pconstsym,init_def(name,constord,p^.value,p^.resulttype)))
  133. else internalerror(111);
  134. end;
  135. stringconstn:
  136. begin
  137. getmem(sp,p^.length+1);
  138. move(p^.value_str^,sp^,p^.length+1);
  139. symtablestack^.insert(new(pconstsym,init_string(name,conststring,sp,p^.length)));
  140. end;
  141. realconstn :
  142. begin
  143. new(pd);
  144. pd^:=p^.value_real;
  145. symtablestack^.insert(new(pconstsym,init(name,constreal,longint(pd))));
  146. end;
  147. setconstn :
  148. begin
  149. new(ps);
  150. ps^:=p^.value_set^;
  151. symtablestack^.insert(new(pconstsym,init_def(name,constset,longint(ps),p^.resulttype)));
  152. end;
  153. niln :
  154. begin
  155. symtablestack^.insert(new(pconstsym,init_def(name,constnil,0,p^.resulttype)));
  156. end;
  157. else
  158. Message(cg_e_illegal_expression);
  159. end;
  160. tokenpos:=storetokenpos;
  161. consume(SEMICOLON);
  162. disposetree(p);
  163. end;
  164. COLON:
  165. begin
  166. { set the blocktype first so a consume also supports a
  167. caret, to support const s : ^string = nil }
  168. block_type:=bt_type;
  169. consume(COLON);
  170. ignore_equal:=true;
  171. def:=read_type('');
  172. ignore_equal:=false;
  173. block_type:=bt_const;
  174. storetokenpos:=tokenpos;
  175. tokenpos:=filepos;
  176. {$ifdef DELPHI_CONST_IN_RODATA}
  177. if m_delphi in aktmodeswitches then
  178. sym:=new(ptypedconstsym,init(name,def,true))
  179. else
  180. {$endif DELPHI_CONST_IN_RODATA}
  181. sym:=new(ptypedconstsym,init(name,def,false));
  182. tokenpos:=storetokenpos;
  183. symtablestack^.insert(sym);
  184. consume(EQUAL);
  185. {$ifdef DELPHI_CONST_IN_RODATA}
  186. if m_delphi in aktmodeswitches then
  187. readtypedconst(def,ptypedconstsym(sym),true)
  188. else
  189. {$endif DELPHI_CONST_IN_RODATA}
  190. readtypedconst(def,ptypedconstsym(sym),false);
  191. consume(SEMICOLON);
  192. end;
  193. else consume(EQUAL);
  194. end;
  195. until token<>ID;
  196. block_type:=old_block_type;
  197. end;
  198. procedure label_dec;
  199. var
  200. hl : pasmlabel;
  201. begin
  202. consume(_LABEL);
  203. if not(cs_support_goto in aktmoduleswitches) then
  204. Message(sym_e_goto_and_label_not_supported);
  205. repeat
  206. if not(token in [ID,INTCONST]) then
  207. consume(ID)
  208. else
  209. begin
  210. getlabel(hl);
  211. symtablestack^.insert(new(plabelsym,init(pattern,hl)));
  212. consume(token);
  213. end;
  214. if token<>SEMICOLON then consume(COMMA);
  215. until not(token in [ID,INTCONST]);
  216. consume(SEMICOLON);
  217. end;
  218. procedure read_var_decs(is_record,is_object,is_threadvar:boolean);
  219. { reads the filed of a record into a }
  220. { symtablestack, if record=false }
  221. { variants are forbidden, so this procedure }
  222. { can be used to read object fields }
  223. { if absolute is true, ABSOLUTE and file }
  224. { types are allowed }
  225. { => the procedure is also used to read }
  226. { a sequence of variable declaration }
  227. var
  228. sc : pstringcontainer;
  229. s : stringid;
  230. old_block_type : tblock_type;
  231. declarepos,storetokenpos : tfileposinfo;
  232. symdone : boolean;
  233. { to handle absolute }
  234. abssym : pabsolutesym;
  235. l : longint;
  236. code : integer;
  237. { c var }
  238. newtype : ptypesym;
  239. is_dll,
  240. is_gpc_name,is_cdecl,extern_aktvarsym,export_aktvarsym : boolean;
  241. dll_name,
  242. C_name : string;
  243. { case }
  244. p,casedef : pdef;
  245. { Delphi initialized vars }
  246. pconstsym : ptypedconstsym;
  247. { maxsize contains the max. size of a variant }
  248. { startvarrec contains the start of the variant part of a record }
  249. maxsize,startvarrec : longint;
  250. pt : ptree;
  251. begin
  252. old_block_type:=block_type;
  253. block_type:=bt_type;
  254. is_gpc_name:=false;
  255. { Force an expected ID error message }
  256. if not (token in [ID,_CASE,_END]) then
  257. consume(ID);
  258. { read vars }
  259. while (token=ID) and
  260. not(is_object and (idtoken in [_PUBLIC,_PRIVATE,_PUBLISHED,_PROTECTED])) do
  261. begin
  262. C_name:=orgpattern;
  263. sc:=idlist;
  264. consume(COLON);
  265. if (m_gpc in aktmodeswitches) and
  266. not(is_record or is_object or is_threadvar) and
  267. (token=ID) and (orgpattern='__asmname__') then
  268. begin
  269. consume(ID);
  270. C_name:=pattern;
  271. if token=CCHAR then
  272. consume(CCHAR)
  273. else
  274. consume(CSTRING);
  275. Is_gpc_name:=true;
  276. end;
  277. { this is needed for Delphi mode at least
  278. but should be OK for all modes !! (PM) }
  279. ignore_equal:=true;
  280. p:=read_type('');
  281. ignore_equal:=false;
  282. symdone:=false;
  283. if is_gpc_name then
  284. begin
  285. storetokenpos:=tokenpos;
  286. s:=sc^.get_with_tokeninfo(tokenpos);
  287. if not sc^.empty then
  288. Message(parser_e_absolute_only_one_var);
  289. dispose(sc,done);
  290. aktvarsym:=new(pvarsym,init_C(s,target_os.Cprefix+C_name,p));
  291. aktvarsym^.var_options:=aktvarsym^.var_options or vo_is_external;
  292. symtablestack^.insert(aktvarsym);
  293. tokenpos:=storetokenpos;
  294. symdone:=true;
  295. end;
  296. { check for absolute }
  297. if not symdone and
  298. (idtoken=_ABSOLUTE) and not(is_record or is_object or is_threadvar) then
  299. begin
  300. consume(_ABSOLUTE);
  301. { only allowed for one var }
  302. s:=sc^.get_with_tokeninfo(declarepos);
  303. if not sc^.empty then
  304. Message(parser_e_absolute_only_one_var);
  305. dispose(sc,done);
  306. { parse the rest }
  307. if token=ID then
  308. begin
  309. getsym(pattern,true);
  310. consume(ID);
  311. { we should check the result type of srsym }
  312. if not (srsym^.typ in [varsym,typedconstsym]) then
  313. Message(parser_e_absolute_only_to_var_or_const);
  314. storetokenpos:=tokenpos;
  315. tokenpos:=declarepos;
  316. abssym:=new(pabsolutesym,init(s,p));
  317. abssym^.abstyp:=tovar;
  318. abssym^.ref:=srsym;
  319. symtablestack^.insert(abssym);
  320. tokenpos:=storetokenpos;
  321. end
  322. else
  323. if (token=CSTRING) or (token=CCHAR) then
  324. begin
  325. storetokenpos:=tokenpos;
  326. tokenpos:=declarepos;
  327. abssym:=new(pabsolutesym,init(s,p));
  328. s:=pattern;
  329. consume(token);
  330. abssym^.abstyp:=toasm;
  331. abssym^.asmname:=stringdup(s);
  332. symtablestack^.insert(abssym);
  333. tokenpos:=storetokenpos;
  334. end
  335. else
  336. { absolute address ?!? }
  337. if token=INTCONST then
  338. begin
  339. if (target_info.target=target_i386_go32v2) then
  340. begin
  341. storetokenpos:=tokenpos;
  342. tokenpos:=declarepos;
  343. abssym:=new(pabsolutesym,init(s,p));
  344. abssym^.abstyp:=toaddr;
  345. abssym^.absseg:=false;
  346. s:=pattern;
  347. consume(INTCONST);
  348. val(s,abssym^.address,code);
  349. if token=COLON then
  350. begin
  351. consume(token);
  352. s:=pattern;
  353. consume(INTCONST);
  354. val(s,l,code);
  355. abssym^.address:=abssym^.address shl 4+l;
  356. abssym^.absseg:=true;
  357. end;
  358. symtablestack^.insert(abssym);
  359. tokenpos:=storetokenpos;
  360. end
  361. else
  362. Message(parser_e_absolute_only_to_var_or_const);
  363. end
  364. else
  365. Message(parser_e_absolute_only_to_var_or_const);
  366. symdone:=true;
  367. end;
  368. { Handling of Delphi typed const = initialized vars ! }
  369. { When should this be rejected ?
  370. - in parasymtable
  371. - in record or object
  372. - ... (PM) }
  373. if (m_delphi in aktmodeswitches) and (token=EQUAL) and
  374. not (symtablestack^.symtabletype in [parasymtable]) and
  375. not is_record and not is_object then
  376. begin
  377. storetokenpos:=tokenpos;
  378. s:=sc^.get_with_tokeninfo(tokenpos);
  379. if not sc^.empty then
  380. Message(parser_e_initialized_only_one_var);
  381. pconstsym:=new(ptypedconstsym,init(s,p,false));
  382. symtablestack^.insert(pconstsym);
  383. tokenpos:=storetokenpos;
  384. consume(EQUAL);
  385. readtypedconst(p,pconstsym,false);
  386. symdone:=true;
  387. end;
  388. { for a record there doesn't need to be a ; before the END or ) }
  389. if not((is_record or is_object) and (token in [_END,RKLAMMER])) then
  390. consume(SEMICOLON);
  391. { procvar handling }
  392. if (p^.deftype=procvardef) and (p^.sym=nil) then
  393. begin
  394. newtype:=new(ptypesym,init('unnamed',p));
  395. parse_var_proc_directives(newtype);
  396. newtype^.definition:=nil;
  397. p^.sym:=nil;
  398. dispose(newtype,done);
  399. end;
  400. { Check for variable directives }
  401. if not symdone and (token=ID) then
  402. begin
  403. { Check for C Variable declarations }
  404. if (m_cvar_support in aktmodeswitches) and
  405. not(is_record or is_object or is_threadvar) and
  406. (idtoken in [_EXPORT,_EXTERNAL,_PUBLIC,_CVAR]) then
  407. begin
  408. { only allowed for one var }
  409. s:=sc^.get_with_tokeninfo(declarepos);
  410. if not sc^.empty then
  411. Message(parser_e_absolute_only_one_var);
  412. dispose(sc,done);
  413. { defaults }
  414. is_dll:=false;
  415. is_cdecl:=false;
  416. extern_aktvarsym:=false;
  417. export_aktvarsym:=false;
  418. { cdecl }
  419. if idtoken=_CVAR then
  420. begin
  421. consume(_CVAR);
  422. consume(SEMICOLON);
  423. is_cdecl:=true;
  424. C_name:=target_os.Cprefix+C_name;
  425. end;
  426. { external }
  427. if idtoken=_EXTERNAL then
  428. begin
  429. consume(_EXTERNAL);
  430. extern_aktvarsym:=true;
  431. end;
  432. { export }
  433. if idtoken in [_EXPORT,_PUBLIC] then
  434. begin
  435. consume(ID);
  436. if extern_aktvarsym then
  437. Message(parser_e_not_external_and_export)
  438. else
  439. export_aktvarsym:=true;
  440. end;
  441. { external and export need a name after when no cdecl is used }
  442. if not is_cdecl then
  443. begin
  444. { dll name ? }
  445. if (extern_aktvarsym) and (idtoken<>_NAME) then
  446. begin
  447. is_dll:=true;
  448. dll_name:=get_stringconst;
  449. end;
  450. consume(_NAME);
  451. C_name:=get_stringconst;
  452. end;
  453. { consume the ; when export or external is used }
  454. if extern_aktvarsym or export_aktvarsym then
  455. consume(SEMICOLON);
  456. { insert in the symtable }
  457. storetokenpos:=tokenpos;
  458. tokenpos:=declarepos;
  459. if is_dll then
  460. aktvarsym:=new(pvarsym,init_dll(s,p))
  461. else
  462. aktvarsym:=new(pvarsym,init_C(s,C_name,p));
  463. { set some vars options }
  464. if export_aktvarsym then
  465. inc(aktvarsym^.refs);
  466. if extern_aktvarsym then
  467. aktvarsym^.var_options:=aktvarsym^.var_options or vo_is_external;
  468. { insert in the stack/datasegment }
  469. symtablestack^.insert(aktvarsym);
  470. tokenpos:=storetokenpos;
  471. { now we can insert it in the import lib if its a dll, or
  472. add it to the externals }
  473. if extern_aktvarsym then
  474. begin
  475. if is_dll then
  476. begin
  477. if not(current_module^.uses_imports) then
  478. begin
  479. current_module^.uses_imports:=true;
  480. importlib^.preparelib(current_module^.modulename^);
  481. end;
  482. importlib^.importvariable(aktvarsym^.mangledname,dll_name,C_name)
  483. end
  484. end;
  485. symdone:=true;
  486. end
  487. else
  488. if (is_object) and (cs_static_keyword in aktmoduleswitches) and (idtoken=_STATIC) then
  489. begin
  490. current_object_option:=current_object_option or sp_static;
  491. insert_syms(symtablestack,sc,p,false);
  492. current_object_option:=current_object_option - sp_static;
  493. consume(_STATIC);
  494. consume(SEMICOLON);
  495. symdone:=true;
  496. end;
  497. end;
  498. { insert it in the symtable, if not done yet }
  499. if not symdone then
  500. begin
  501. if (current_object_option=sp_published) and
  502. (not((p^.deftype=objectdef) and (pobjectdef(p)^.isclass))) then
  503. Message(parser_e_cant_publish_that);
  504. insert_syms(symtablestack,sc,p,is_threadvar);
  505. end;
  506. end;
  507. { Check for Case }
  508. if is_record and (token=_CASE) then
  509. begin
  510. maxsize:=0;
  511. consume(_CASE);
  512. s:=pattern;
  513. getsym(s,false);
  514. { may be only a type: }
  515. if assigned(srsym) and (srsym^.typ in [typesym,unitsym]) then
  516. casedef:=read_type('')
  517. else
  518. begin
  519. consume(ID);
  520. consume(COLON);
  521. casedef:=read_type('');
  522. symtablestack^.insert(new(pvarsym,init(s,casedef)));
  523. end;
  524. if not is_ordinal(casedef) then
  525. Message(type_e_ordinal_expr_expected);
  526. consume(_OF);
  527. startvarrec:=symtablestack^.datasize;
  528. repeat
  529. repeat
  530. pt:=comp_expr(true);
  531. do_firstpass(pt);
  532. if not(pt^.treetype=ordconstn) then
  533. Message(cg_e_illegal_expression);
  534. disposetree(pt);
  535. if token=COMMA then
  536. consume(COMMA)
  537. else
  538. break;
  539. until false;
  540. consume(COLON);
  541. { read the vars }
  542. consume(LKLAMMER);
  543. if token<>RKLAMMER then
  544. read_var_decs(true,false,false);
  545. consume(RKLAMMER);
  546. { calculates maximal variant size }
  547. maxsize:=max(maxsize,symtablestack^.datasize);
  548. { the items of the next variant are overlayed }
  549. symtablestack^.datasize:=startvarrec;
  550. if (token<>_END) and (token<>RKLAMMER) then
  551. consume(SEMICOLON)
  552. else
  553. break;
  554. until (token=_END) or (token=RKLAMMER);
  555. { at last set the record size to that of the biggest variant }
  556. symtablestack^.datasize:=maxsize;
  557. end;
  558. block_type:=old_block_type;
  559. end;
  560. function stringtype : pdef;
  561. { reads a string type with optional length }
  562. { and returns a pointer to the string }
  563. { definition }
  564. var
  565. p : ptree;
  566. d : pdef;
  567. begin
  568. consume(_STRING);
  569. if token=LECKKLAMMER then
  570. begin
  571. consume(LECKKLAMMER);
  572. p:=comp_expr(true);
  573. do_firstpass(p);
  574. if not is_constintnode(p) then
  575. Message(cg_e_illegal_expression);
  576. if (p^.value<=0) then
  577. begin
  578. Message(parser_e_invalid_string_size);
  579. p^.value:=255;
  580. end;
  581. consume(RECKKLAMMER);
  582. if p^.value>255 then
  583. d:=new(pstringdef,longinit(p^.value))
  584. else
  585. if p^.value<>255 then
  586. d:=new(pstringdef,shortinit(p^.value))
  587. else
  588. d:=cshortstringdef;
  589. disposetree(p);
  590. end
  591. else
  592. begin
  593. if cs_ansistrings in aktlocalswitches then
  594. d:=cansistringdef
  595. else
  596. d:=cshortstringdef;
  597. end;
  598. stringtype:=d;
  599. end;
  600. function id_type(var s : string) : pdef;
  601. { reads a type definition and returns a pointer }
  602. { to a appropriating pdef, s gets the name of }
  603. { the type to allow name mangling }
  604. begin
  605. s:=pattern;
  606. consume(ID);
  607. { classes can be used also in classes }
  608. if (curobjectname=pattern) and aktobjectdef^.isclass then
  609. begin
  610. id_type:=aktobjectdef;
  611. exit;
  612. end;
  613. { objects can be parameters }
  614. if (testcurobject=2) and (curobjectname=pattern) then
  615. begin
  616. id_type:=aktobjectdef;
  617. exit;
  618. end;
  619. getsym(s,true);
  620. if assigned(srsym) then
  621. begin
  622. if srsym^.typ=unitsym then
  623. begin
  624. consume(POINT);
  625. getsymonlyin(punitsym(srsym)^.unitsymtable,pattern);
  626. s:=pattern;
  627. consume(ID);
  628. end;
  629. if not assigned(srsym) or
  630. (srsym^.typ<>typesym) then
  631. begin
  632. Message(type_e_type_id_expected);
  633. lasttypesym:=ptypesym(srsym);
  634. id_type:=generrordef;
  635. exit;
  636. end;
  637. if not forwardsallowed then
  638. testforward_type(srsym);
  639. end;
  640. lasttypesym:=ptypesym(srsym);
  641. id_type:=ptypesym(srsym)^.definition;
  642. end;
  643. function single_type(var s : string) : pdef;
  644. { reads a string, file type or a type id and returns a name and }
  645. { pdef }
  646. var
  647. hs : string;
  648. begin
  649. case token of
  650. _STRING:
  651. begin
  652. single_type:=stringtype;
  653. s:='STRING';
  654. lasttypesym:=nil;
  655. end;
  656. _FILE:
  657. begin
  658. consume(_FILE);
  659. if token=_OF then
  660. begin
  661. consume(_OF);
  662. single_type:=new(pfiledef,init(ft_typed,single_type(hs)));
  663. s:='FILE$OF$'+hs;
  664. end
  665. else
  666. begin
  667. { single_type:=new(pfiledef,init(ft_untyped,nil));}
  668. single_type:=cfiledef;
  669. s:='FILE';
  670. end;
  671. lasttypesym:=nil;
  672. end;
  673. else single_type:=id_type(s);
  674. end;
  675. end;
  676. function object_dec(const n : stringid;fd : pobjectdef) : pdef;
  677. { this function parses an object or class declaration }
  678. var
  679. actmembertype : symprop;
  680. there_is_a_destructor : boolean;
  681. is_a_class : boolean;
  682. childof : pobjectdef;
  683. aktclass : pobjectdef;
  684. procedure constructor_head;
  685. begin
  686. consume(_CONSTRUCTOR);
  687. { must be at same level as in implementation }
  688. inc(lexlevel);
  689. parse_proc_head(poconstructor);
  690. dec(lexlevel);
  691. if (cs_constructor_name in aktglobalswitches) and (aktprocsym^.name<>'INIT') then
  692. Message(parser_e_constructorname_must_be_init);
  693. aktclass^.options:=aktclass^.options or oo_hasconstructor;
  694. consume(SEMICOLON);
  695. begin
  696. if (aktclass^.options and oo_is_class)<>0 then
  697. begin
  698. { CLASS constructors return the created instance }
  699. aktprocsym^.definition^.retdef:=aktclass;
  700. end
  701. else
  702. begin
  703. { OBJECT constructors return a boolean }
  704. {$IfDef GDB}
  705. {GDB doesn't like unnamed types !}
  706. aktprocsym^.definition^.retdef:=
  707. globaldef('boolean');
  708. {$Else GDB}
  709. aktprocsym^.definition^.retdef:=
  710. new(porddef,init(bool8bit,0,1));
  711. {$Endif GDB}
  712. end;
  713. end;
  714. end;
  715. procedure property_dec;
  716. var
  717. sym : psym;
  718. propertyparas : pdefcoll;
  719. { returns the matching procedure to access a property }
  720. function get_procdef : pprocdef;
  721. var
  722. p : pprocdef;
  723. begin
  724. p:=pprocsym(sym)^.definition;
  725. get_procdef:=nil;
  726. while assigned(p) do
  727. begin
  728. if equal_paras(p^.para1,propertyparas,true) then
  729. break;
  730. p:=p^.nextoverloaded;
  731. end;
  732. get_procdef:=p;
  733. end;
  734. var
  735. hp2,datacoll : pdefcoll;
  736. p,p2 : ppropertysym;
  737. overriden : psym;
  738. hs : string;
  739. code : integer;
  740. varspez : tvarspez;
  741. sc : pstringcontainer;
  742. hp : pdef;
  743. s : string;
  744. declarepos : tfileposinfo;
  745. pp : pprocdef;
  746. pt : ptree;
  747. propname : stringid;
  748. begin
  749. { check for a class }
  750. if (aktclass^.options and oo_is_class=0) then
  751. Message(parser_e_syntax_error);
  752. consume(_PROPERTY);
  753. propertyparas:=nil;
  754. datacoll:=nil;
  755. if token=ID then
  756. begin
  757. p:=new(ppropertysym,init(pattern));
  758. propname:=pattern;
  759. consume(ID);
  760. { property parameters ? }
  761. if token=LECKKLAMMER then
  762. begin
  763. if current_object_option=sp_published then
  764. Message(parser_e_cant_publish_that_property);
  765. { create a list of the parameters in propertyparas }
  766. consume(LECKKLAMMER);
  767. inc(testcurobject);
  768. repeat
  769. if token=_VAR then
  770. begin
  771. consume(_VAR);
  772. varspez:=vs_var;
  773. end
  774. else if token=_CONST then
  775. begin
  776. consume(_CONST);
  777. varspez:=vs_const;
  778. end
  779. else varspez:=vs_value;
  780. sc:=idlist;
  781. if token=COLON then
  782. begin
  783. consume(COLON);
  784. if token=_ARRAY then
  785. begin
  786. {
  787. if (varspez<>vs_const) and
  788. (varspez<>vs_var) then
  789. begin
  790. varspez:=vs_const;
  791. Message(parser_e_illegal_open_parameter);
  792. end;
  793. }
  794. consume(_ARRAY);
  795. consume(_OF);
  796. { define range and type of range }
  797. hp:=new(parraydef,init(0,-1,s32bitdef));
  798. { define field type }
  799. parraydef(hp)^.definition:=single_type(s);
  800. end
  801. else
  802. hp:=single_type(s);
  803. end
  804. else
  805. hp:=cformaldef;
  806. s:=sc^.get_with_tokeninfo(declarepos);
  807. while s<>'' do
  808. begin
  809. new(hp2);
  810. hp2^.paratyp:=varspez;
  811. hp2^.data:=hp;
  812. hp2^.next:=propertyparas;
  813. propertyparas:=hp2;
  814. s:=sc^.get_with_tokeninfo(declarepos);
  815. end;
  816. dispose(sc,done);
  817. if token=SEMICOLON then consume(SEMICOLON)
  818. else break;
  819. until false;
  820. dec(testcurobject);
  821. consume(RECKKLAMMER);
  822. end;
  823. { overriden property ? }
  824. { force property interface, if there is a property parameter }
  825. if (token=COLON) or assigned(propertyparas) then
  826. begin
  827. consume(COLON);
  828. p^.proptype:=single_type(hs);
  829. if (idtoken=_INDEX) then
  830. begin
  831. consume(_INDEX);
  832. p^.options:=p^.options or ppo_indexed;
  833. if token=INTCONST then
  834. val(pattern,p^.index,code);
  835. consume(INTCONST);
  836. { concat a longint to the para template }
  837. new(hp2);
  838. hp2^.paratyp:=vs_value;
  839. hp2^.data:=s32bitdef;
  840. hp2^.next:=propertyparas;
  841. propertyparas:=hp2;
  842. end;
  843. end
  844. else
  845. begin
  846. { do an property override }
  847. overriden:=search_class_member(aktclass,propname);
  848. if assigned(overriden) and (overriden^.typ=propertysym) then
  849. begin
  850. { take the whole info: }
  851. p^.options:=ppropertysym(overriden)^.options;
  852. p^.index:=ppropertysym(overriden)^.index;
  853. p^.proptype:=ppropertysym(overriden)^.proptype;
  854. p^.writeaccesssym:=ppropertysym(overriden)^.writeaccesssym;
  855. p^.readaccesssym:=ppropertysym(overriden)^.readaccesssym;
  856. p^.writeaccessdef:=ppropertysym(overriden)^.writeaccessdef;
  857. p^.readaccessdef:=ppropertysym(overriden)^.readaccessdef;
  858. p^.storedsym:=ppropertysym(overriden)^.storedsym;
  859. p^.storeddef:=ppropertysym(overriden)^.storeddef;
  860. p^.default:=ppropertysym(overriden)^.default;
  861. end
  862. else
  863. begin
  864. p^.proptype:=generrordef;
  865. message(parser_e_no_property_found_to_override);
  866. end;
  867. end;
  868. if (current_object_option=sp_published) and
  869. not(p^.proptype^.is_publishable) then
  870. Message(parser_e_cant_publish_that_property);
  871. { create data defcoll to allow correct parameter checks }
  872. new(datacoll);
  873. datacoll^.paratyp:=vs_value;
  874. datacoll^.data:=p^.proptype;
  875. datacoll^.next:=nil;
  876. if (idtoken=_READ) then
  877. begin
  878. consume(_READ);
  879. sym:=search_class_member(aktclass,pattern);
  880. if not(assigned(sym)) then
  881. begin
  882. Message1(sym_e_unknown_id,pattern);
  883. consume(ID);
  884. end
  885. else
  886. begin
  887. consume(ID);
  888. if (token=POINT) and
  889. ((sym^.typ=varsym) and (pvarsym(sym)^.definition^.deftype=recorddef)) then
  890. begin
  891. consume(POINT);
  892. getsymonlyin(precdef(pvarsym(sym)^.definition)^.symtable,pattern);
  893. if not assigned(srsym) then
  894. Message1(sym_e_illegal_field,pattern);
  895. sym:=srsym;
  896. consume(ID);
  897. end;
  898. end;
  899. if assigned(sym) then
  900. begin
  901. { varsym aren't allowed for an indexed property
  902. or an property with parameters }
  903. if ((sym^.typ=varsym) and
  904. { not necessary, an index forces propertyparas
  905. to be assigned
  906. }
  907. { (((p^.options and ppo_indexed)<>0) or }
  908. assigned(propertyparas)) or
  909. not(sym^.typ in [varsym,procsym]) then
  910. Message(parser_e_ill_property_access_sym);
  911. { search the matching definition }
  912. if sym^.typ=procsym then
  913. begin
  914. pp:=get_procdef;
  915. if not(assigned(pp)) or
  916. not(is_equal(pp^.retdef,p^.proptype)) then
  917. Message(parser_e_ill_property_access_sym);
  918. p^.readaccessdef:=pp;
  919. end
  920. else if sym^.typ=varsym then
  921. begin
  922. if not(is_equal(pvarsym(sym)^.definition,
  923. p^.proptype)) then
  924. Message(parser_e_ill_property_access_sym);
  925. end;
  926. p^.readaccesssym:=sym;
  927. end;
  928. end;
  929. if (idtoken=_WRITE) then
  930. begin
  931. consume(_WRITE);
  932. sym:=search_class_member(aktclass,pattern);
  933. if not(assigned(sym)) then
  934. begin
  935. Message1(sym_e_unknown_id,pattern);
  936. consume(ID);
  937. end
  938. else
  939. begin
  940. consume(ID);
  941. if (token=POINT) and
  942. ((sym^.typ=varsym) and (pvarsym(sym)^.definition^.deftype=recorddef)) then
  943. begin
  944. consume(POINT);
  945. getsymonlyin(precdef(pvarsym(sym)^.definition)^.symtable,pattern);
  946. if not assigned(srsym) then
  947. Message1(sym_e_illegal_field,pattern);
  948. sym:=srsym;
  949. consume(ID);
  950. end;
  951. end;
  952. if assigned(sym) then
  953. begin
  954. if ((sym^.typ=varsym) and
  955. assigned(propertyparas)) or
  956. not(sym^.typ in [varsym,procsym]) then
  957. Message(parser_e_ill_property_access_sym);
  958. { search the matching definition }
  959. if sym^.typ=procsym then
  960. begin
  961. { insert data entry to check access method }
  962. datacoll^.next:=propertyparas;
  963. propertyparas:=datacoll;
  964. pp:=get_procdef;
  965. { ... and remove it }
  966. propertyparas:=propertyparas^.next;
  967. datacoll^.next:=nil;
  968. if not(assigned(pp)) then
  969. Message(parser_e_ill_property_access_sym);
  970. p^.writeaccessdef:=pp;
  971. end
  972. else if sym^.typ=varsym then
  973. begin
  974. if not(is_equal(pvarsym(sym)^.definition,
  975. p^.proptype)) then
  976. Message(parser_e_ill_property_access_sym);
  977. end;
  978. p^.writeaccesssym:=sym;
  979. end;
  980. end;
  981. if (idtoken=_STORED) then
  982. begin
  983. consume(_STORED);
  984. Message(parser_w_stored_not_implemented);
  985. { !!!!!!!! }
  986. end;
  987. if (idtoken=_DEFAULT) then
  988. begin
  989. consume(_DEFAULT);
  990. if not(is_ordinal(p^.proptype) or
  991. ((p^.proptype^.deftype=setdef) and
  992. (psetdef(p^.proptype)^.settype=smallset)
  993. ) or
  994. assigned(propertyparas)
  995. ) then
  996. Message(parser_e_property_cant_have_a_default_value);
  997. pt:=comp_expr(true);
  998. if p^.proptype^.deftype=setdef then
  999. begin
  1000. do_firstpass(pt);
  1001. arrayconstructor_to_set(pt);
  1002. end;
  1003. pt:=gentypeconvnode(pt,p^.proptype);
  1004. do_firstpass(pt);
  1005. if not(is_constnode(pt)) then
  1006. Message(parser_e_property_default_value_must_const);
  1007. if pt^.treetype=setconstn then
  1008. p^.default:=plongint(pt^.value_set)^
  1009. else
  1010. p^.default:=pt^.value;
  1011. disposetree(pt);
  1012. end
  1013. else if (idtoken=_NODEFAULT) then
  1014. begin
  1015. consume(_NODEFAULT);
  1016. p^.default:=0;
  1017. end;
  1018. symtablestack^.insert(p);
  1019. { default property ? }
  1020. consume(SEMICOLON);
  1021. if (idtoken=_DEFAULT) then
  1022. begin
  1023. consume(_DEFAULT);
  1024. p2:=search_default_property(aktclass);
  1025. if assigned(p2) then
  1026. message1(parser_e_only_one_default_property,
  1027. pobjectdef(p2^.owner^.defowner)^.objname^)
  1028. else
  1029. begin
  1030. p^.options:=p^.options or ppo_defaultproperty;
  1031. if not(assigned(propertyparas)) then
  1032. message(parser_e_property_need_paras);
  1033. end;
  1034. consume(SEMICOLON);
  1035. end;
  1036. { clean up }
  1037. if assigned(datacoll) then
  1038. disposepdefcoll(datacoll);
  1039. end
  1040. else
  1041. begin
  1042. consume(ID);
  1043. consume(SEMICOLON);
  1044. end;
  1045. if assigned(propertyparas) then
  1046. disposepdefcoll(propertyparas);
  1047. end;
  1048. procedure destructor_head;
  1049. begin
  1050. consume(_DESTRUCTOR);
  1051. inc(lexlevel);
  1052. parse_proc_head(podestructor);
  1053. dec(lexlevel);
  1054. if (cs_constructor_name in aktglobalswitches) and (aktprocsym^.name<>'DONE') then
  1055. Message(parser_e_destructorname_must_be_done);
  1056. aktclass^.options:=aktclass^.options or oo_hasdestructor;
  1057. consume(SEMICOLON);
  1058. if assigned(aktprocsym^.definition^.para1) then
  1059. Message(parser_e_no_paras_for_destructor);
  1060. { no return value }
  1061. aktprocsym^.definition^.retdef:=voiddef;
  1062. end;
  1063. var
  1064. hs : string;
  1065. pcrd : pclassrefdef;
  1066. hp1 : pdef;
  1067. oldprocsym : pprocsym;
  1068. oldparse_only : boolean;
  1069. intmessagetable,strmessagetable,classnamelabel : pasmlabel;
  1070. storetypeforwardsallowed : boolean;
  1071. pt : ptree;
  1072. begin
  1073. {Nowadays aktprocsym may already have a value, so we need to save
  1074. it.}
  1075. oldprocsym:=aktprocsym;
  1076. { forward is resolved }
  1077. if assigned(fd) then
  1078. fd^.options:=fd^.options and not(oo_isforward);
  1079. there_is_a_destructor:=false;
  1080. actmembertype:=sp_public;
  1081. { objects and class types can't be declared local }
  1082. if (symtablestack^.symtabletype<>globalsymtable) and
  1083. (symtablestack^.symtabletype<>staticsymtable) then
  1084. Message(parser_e_no_local_objects);
  1085. storetypeforwardsallowed:=typecanbeforward;
  1086. if m_tp in aktmodeswitches then
  1087. typecanbeforward:=false;
  1088. { distinguish classes and objects }
  1089. if token=_OBJECT then
  1090. begin
  1091. is_a_class:=false;
  1092. consume(_OBJECT)
  1093. end
  1094. else
  1095. begin
  1096. is_a_class:=true;
  1097. consume(_CLASS);
  1098. if not(assigned(fd)) and (token=_OF) then
  1099. begin
  1100. { a hack, but it's easy to handle }
  1101. { class reference type }
  1102. consume(_OF);
  1103. if typecanbeforward then
  1104. forwardsallowed:=true;
  1105. hp1:=single_type(hs);
  1106. { accept hp1, if is a forward def ...}
  1107. if ((lasttypesym<>nil)
  1108. and ((lasttypesym^.properties and sp_forwarddef)<>0)) or
  1109. { or a class
  1110. (if the foward defined type is a class is checked, when
  1111. the forward is resolved)
  1112. }
  1113. ((hp1^.deftype=objectdef) and (
  1114. (pobjectdef(hp1)^.options and oo_is_class)<>0)) then
  1115. begin
  1116. pcrd:=new(pclassrefdef,init(hp1));
  1117. object_dec:=pcrd;
  1118. if assigned(lasttypesym) and ((lasttypesym^.properties and sp_forwarddef)<>0) then
  1119. lasttypesym^.addforwardpointer(ppointerdef(pcrd));
  1120. forwardsallowed:=false;
  1121. end
  1122. else
  1123. begin
  1124. Message(type_e_class_type_expected);
  1125. object_dec:=new(perrordef,init);
  1126. end;
  1127. typecanbeforward:=storetypeforwardsallowed;
  1128. exit;
  1129. end
  1130. { forward class }
  1131. else if not(assigned(fd)) and (token=SEMICOLON) then
  1132. begin
  1133. { also anonym objects aren't allow (o : object a : longint; end;) }
  1134. if n='' then
  1135. begin
  1136. Message(parser_f_no_anonym_objects)
  1137. end;
  1138. if n='TOBJECT' then
  1139. begin
  1140. aktclass:=new(pobjectdef,init(n,nil));
  1141. class_tobject:=aktclass;
  1142. end
  1143. else
  1144. aktclass:=new(pobjectdef,init(n,nil));
  1145. aktclass^.options:=aktclass^.options or oo_is_class or oo_isforward;
  1146. { all classes must have a vmt !! at offset zero }
  1147. if (aktclass^.options and oo_hasvmt)=0 then
  1148. aktclass^.insertvmt;
  1149. object_dec:=aktclass;
  1150. typecanbeforward:=storetypeforwardsallowed;
  1151. exit;
  1152. end;
  1153. end;
  1154. { also anonym objects aren't allow (o : object a : longint; end;) }
  1155. if n='' then
  1156. Message(parser_f_no_anonym_objects);
  1157. { read the parent class }
  1158. if token=LKLAMMER then
  1159. begin
  1160. consume(LKLAMMER);
  1161. { does not allow objects.tobject !! }
  1162. {if token<>ID then
  1163. consume(ID);
  1164. getsym(pattern,true);}
  1165. childof:=pobjectdef(id_type(pattern));
  1166. if (childof^.deftype<>objectdef) then
  1167. begin
  1168. Message(type_e_class_type_expected);
  1169. childof:=nil;
  1170. end
  1171. else
  1172. begin
  1173. { a mix of class and object isn't allowed }
  1174. if (((childof^.options and oo_is_class)<>0) and not is_a_class) or
  1175. (((childof^.options and oo_is_class)=0) and is_a_class) then
  1176. Message(parser_e_mix_of_classes_and_objects);
  1177. end;
  1178. if assigned(fd) then
  1179. begin
  1180. { the forward of the child must be resolved to get
  1181. correct field addresses
  1182. }
  1183. if (childof^.options and oo_isforward)<>0 then
  1184. Message1(parser_e_forward_declaration_must_be_resolved,childof^.objname^);
  1185. aktclass:=fd;
  1186. { we must inherit several options !!
  1187. this was missing !!
  1188. all is now done in set_parent
  1189. including symtable datasize setting PM }
  1190. fd^.set_parent(childof);
  1191. end
  1192. else
  1193. aktclass:=new(pobjectdef,init(n,childof));
  1194. consume(RKLAMMER);
  1195. end
  1196. { if no parent class, then a class get tobject as parent }
  1197. else if is_a_class then
  1198. begin
  1199. { is the current class tobject? }
  1200. { so you could define your own tobject }
  1201. if n='TOBJECT' then
  1202. begin
  1203. if assigned(fd) then
  1204. aktclass:=fd
  1205. else
  1206. aktclass:=new(pobjectdef,init(n,nil));
  1207. class_tobject:=aktclass;
  1208. end
  1209. else
  1210. begin
  1211. childof:=class_tobject;
  1212. if assigned(fd) then
  1213. begin
  1214. { the forward of the child must be resolved to get
  1215. correct field addresses
  1216. }
  1217. if (childof^.options and oo_isforward)<>0 then
  1218. Message1(parser_e_forward_declaration_must_be_resolved,childof^.objname^);
  1219. aktclass:=fd;
  1220. aktclass^.set_parent(childof);
  1221. end
  1222. else
  1223. begin
  1224. aktclass:=new(pobjectdef,init(n,childof));
  1225. aktclass^.set_parent(childof);
  1226. end;
  1227. end;
  1228. end
  1229. else
  1230. aktclass:=new(pobjectdef,init(n,nil));
  1231. { set the class attribute }
  1232. if is_a_class then
  1233. begin
  1234. aktclass^.options:=aktclass^.options or oo_is_class;
  1235. if (cs_generate_rtti in aktlocalswitches) or
  1236. (assigned(aktclass^.childof) and
  1237. ((aktclass^.childof^.options and oo_can_have_published)<>0)
  1238. ) then
  1239. aktclass^.options:=aktclass^.options or oo_can_have_published;
  1240. end;
  1241. aktobjectdef:=aktclass;
  1242. { default access is public }
  1243. actmembertype:=sp_public;
  1244. aktclass^.publicsyms^.next:=symtablestack;
  1245. symtablestack:=aktclass^.publicsyms;
  1246. procinfo._class:=aktclass;
  1247. testcurobject:=1;
  1248. curobjectname:=n;
  1249. { short class declaration ? }
  1250. if (not is_a_class) or (token<>SEMICOLON) then
  1251. begin
  1252. { Parse componenten }
  1253. repeat
  1254. if actmembertype=sp_private then
  1255. aktclass^.options:=aktclass^.options or oo_hasprivate;
  1256. if actmembertype=sp_protected then
  1257. aktclass^.options:=aktclass^.options or oo_hasprotected;
  1258. case token of
  1259. ID : begin
  1260. case idtoken of
  1261. _PRIVATE : begin
  1262. consume(_PRIVATE);
  1263. actmembertype:=sp_private;
  1264. current_object_option:=sp_private;
  1265. end;
  1266. _PROTECTED : begin
  1267. consume(_PROTECTED);
  1268. current_object_option:=sp_protected;
  1269. actmembertype:=sp_protected;
  1270. end;
  1271. _PUBLIC : begin
  1272. consume(_PUBLIC);
  1273. current_object_option:=sp_public;
  1274. actmembertype:=sp_public;
  1275. end;
  1276. _PUBLISHED : begin
  1277. if (aktclass^.options and oo_can_have_published)=0 then
  1278. Message(parser_e_cant_have_published);
  1279. consume(_PUBLISHED);
  1280. current_object_option:=sp_published;
  1281. actmembertype:=sp_published;
  1282. end;
  1283. else
  1284. read_var_decs(false,true,false);
  1285. end;
  1286. end;
  1287. _PROPERTY : property_dec;
  1288. _PROCEDURE,
  1289. _FUNCTION,
  1290. _CLASS : begin
  1291. oldparse_only:=parse_only;
  1292. parse_only:=true;
  1293. parse_proc_dec;
  1294. if idtoken=_MESSAGE then
  1295. begin
  1296. { check parameter type }
  1297. if ((aktprocsym^.definition^.options and pocontainsself)=0) and
  1298. (assigned(aktprocsym^.definition^.para1^.next) or
  1299. (aktprocsym^.definition^.para1^.paratyp<>vs_var)) then
  1300. Message(parser_e_ill_msg_param);
  1301. consume(idtoken);
  1302. pt:=comp_expr(true);
  1303. do_firstpass(pt);
  1304. if pt^.treetype=stringconstn then
  1305. begin
  1306. aktclass^.options:=aktclass^.options or oo_hasmsgstr;
  1307. aktprocsym^.definition^.options:=
  1308. aktprocsym^.definition^.options or pomsgstr;
  1309. aktprocsym^.definition^.messageinf.str:=strnew(pt^.value_str);
  1310. end
  1311. else if is_constintnode(pt) then
  1312. begin
  1313. aktclass^.options:=aktclass^.options or oo_hasmsgint;
  1314. aktprocsym^.definition^.options:=
  1315. aktprocsym^.definition^.options or pomsgint;
  1316. aktprocsym^.definition^.messageinf.i:=pt^.value;
  1317. end
  1318. else
  1319. Message(parser_e_ill_msg_expr);
  1320. disposetree(pt);
  1321. consume(SEMICOLON);
  1322. end
  1323. else
  1324. begin
  1325. {$ifdef OLDOBJECTOPTIONS}
  1326. case idtoken of
  1327. _DYNAMIC,
  1328. _VIRTUAL : begin
  1329. if actmembertype=sp_private then
  1330. Message(parser_w_priv_meth_not_virtual);
  1331. consume(idtoken);
  1332. consume(SEMICOLON);
  1333. aktprocsym^.definition^.options:=aktprocsym^.definition^.options or povirtualmethod;
  1334. aktclass^.options:=aktclass^.options or oo_hasvirtual;
  1335. end;
  1336. _OVERRIDE : begin
  1337. consume(_OVERRIDE);
  1338. consume(SEMICOLON);
  1339. aktprocsym^.definition^.options:=aktprocsym^.definition^.options or
  1340. pooverridingmethod or povirtualmethod;
  1341. end;
  1342. end;
  1343. if idtoken=_ABSTRACT then
  1344. begin
  1345. if (aktprocsym^.definition^.options and povirtualmethod)<>0 then
  1346. aktprocsym^.definition^.options:=aktprocsym^.definition^.options or poabstractmethod
  1347. else
  1348. Message(parser_e_only_virtual_methods_abstract);
  1349. consume(_ABSTRACT);
  1350. consume(SEMICOLON);
  1351. { the method is defined }
  1352. aktprocsym^.definition^.forwarddef:=false;
  1353. end;
  1354. if (cs_static_keyword in aktglobalswitches) and (idtoken=_STATIC) then
  1355. begin
  1356. consume(_STATIC);
  1357. consume(SEMICOLON);
  1358. aktprocsym^.properties:=aktprocsym^.properties or sp_static;
  1359. aktprocsym^.definition^.options:=aktprocsym^.definition^.options or postaticmethod;
  1360. end;
  1361. {$else OLDOBJECTOPTIONS}
  1362. parse_object_proc_directives(aktprocsym);
  1363. {$endif def OLDOBJECTOPTIONS}
  1364. end;
  1365. parse_only:=oldparse_only;
  1366. end;
  1367. _CONSTRUCTOR : begin
  1368. if actmembertype<>sp_public then
  1369. Message(parser_w_constructor_should_be_public);
  1370. oldparse_only:=parse_only;
  1371. parse_only:=true;
  1372. constructor_head;
  1373. {$ifdef OLDOBJECTOPTIONS}
  1374. case idtoken of
  1375. _DYNAMIC,
  1376. _VIRTUAL : begin
  1377. if not(aktclass^.isclass) then
  1378. Message(parser_e_constructor_cannot_be_not_virtual)
  1379. else
  1380. begin
  1381. aktprocsym^.definition^.options:=aktprocsym^.definition^.options or povirtualmethod;
  1382. aktclass^.options:=aktclass^.options or oo_hasvirtual;
  1383. end;
  1384. consume(idtoken);
  1385. consume(SEMICOLON);
  1386. end;
  1387. _OVERRIDE : begin
  1388. if (aktclass^.options and oo_is_class=0) then
  1389. Message(parser_e_constructor_cannot_be_not_virtual)
  1390. else
  1391. aktprocsym^.definition^.options:=aktprocsym^.definition^.options or
  1392. pooverridingmethod or povirtualmethod;
  1393. consume(_OVERRIDE);
  1394. consume(SEMICOLON);
  1395. end;
  1396. end;
  1397. {$else OLDOBJECTOPTIONS}
  1398. parse_object_proc_directives(aktprocsym);
  1399. {$endif def OLDOBJECTOPTIONS}
  1400. parse_only:=oldparse_only;
  1401. end;
  1402. _DESTRUCTOR : begin
  1403. if there_is_a_destructor then
  1404. Message(parser_n_only_one_destructor);
  1405. there_is_a_destructor:=true;
  1406. if actmembertype<>sp_public then
  1407. Message(parser_w_destructor_should_be_public);
  1408. oldparse_only:=parse_only;
  1409. parse_only:=true;
  1410. destructor_head;
  1411. {$ifdef OLDOBJECTOPTIONS}
  1412. case idtoken of
  1413. _DYNAMIC,
  1414. _VIRTUAL : begin
  1415. consume(idtoken);
  1416. consume(SEMICOLON);
  1417. aktprocsym^.definition^.options:=aktprocsym^.definition^.options or povirtualmethod;
  1418. aktclass^.options:=aktclass^.options or oo_hasvirtual;
  1419. end;
  1420. _OVERRIDE : begin
  1421. consume(_OVERRIDE);
  1422. consume(SEMICOLON);
  1423. aktprocsym^.definition^.options:=aktprocsym^.definition^.options or
  1424. pooverridingmethod or povirtualmethod;
  1425. end;
  1426. end;
  1427. {$else OLDOBJECTOPTIONS}
  1428. parse_object_proc_directives(aktprocsym);
  1429. {$endif def OLDOBJECTOPTIONS}
  1430. parse_only:=oldparse_only;
  1431. end;
  1432. _END : begin
  1433. consume(_END);
  1434. break;
  1435. end;
  1436. else
  1437. consume(ID); { Give a ident expected message, like tp7 }
  1438. end;
  1439. until false;
  1440. current_object_option:=sp_public;
  1441. end;
  1442. testcurobject:=0;
  1443. curobjectname:='';
  1444. typecanbeforward:=storetypeforwardsallowed;
  1445. { generate vmt space if needed }
  1446. if ((aktclass^.options and
  1447. (oo_hasvirtual or oo_hasconstructor or
  1448. oo_hasdestructor or oo_is_class))<>0) and
  1449. ((aktclass^.options and
  1450. oo_hasvmt)=0) then
  1451. aktclass^.insertvmt;
  1452. if (cs_smartlink in aktmoduleswitches) then
  1453. datasegment^.concat(new(pai_cut,init));
  1454. { write extended info for classes }
  1455. if is_a_class then
  1456. begin
  1457. if (aktclass^.options and oo_can_have_published)<>0 then
  1458. aktclass^.generate_rtti;
  1459. { write class name }
  1460. getdatalabel(classnamelabel);
  1461. datasegment^.concat(new(pai_label,init(classnamelabel)));
  1462. datasegment^.concat(new(pai_const,init_8bit(length(aktclass^.objname^))));
  1463. datasegment^.concat(new(pai_string,init(aktclass^.objname^)));
  1464. { generate message and dynamic tables }
  1465. { why generate those if empty ??? }
  1466. if (aktclass^.options and oo_hasmsgstr)<>0 then
  1467. strmessagetable:=genstrmsgtab(aktclass);
  1468. if (aktclass^.options and oo_hasmsgint)<>0 then
  1469. intmessagetable:=genintmsgtab(aktclass);
  1470. { table for string messages }
  1471. if (aktclass^.options and oo_hasmsgstr)<>0 then
  1472. datasegment^.concat(new(pai_const_symbol,init(strmessagetable)))
  1473. else
  1474. datasegment^.concat(new(pai_const,init_32bit(0)));
  1475. { interface table }
  1476. datasegment^.concat(new(pai_const,init_32bit(0)));
  1477. { auto table }
  1478. datasegment^.concat(new(pai_const,init_32bit(0)));
  1479. { inittable for con-/destruction }
  1480. if aktclass^.needs_inittable then
  1481. datasegment^.concat(new(pai_const_symbol,init(aktclass^.get_inittable_label)))
  1482. else
  1483. datasegment^.concat(new(pai_const,init_32bit(0)));
  1484. { pointer to type info of published section }
  1485. if (aktclass^.options and oo_can_have_published)<>0 then
  1486. datasegment^.concat(new(pai_const_symbol,initname(aktclass^.rtti_name)))
  1487. else
  1488. datasegment^.concat(new(pai_const,init_32bit(0)));
  1489. { pointer to field table }
  1490. datasegment^.concat(new(pai_const,init_32bit(0)));
  1491. { pointer to method table }
  1492. datasegment^.concat(new(pai_const,init_32bit(0)));
  1493. { pointer to dynamic table }
  1494. if (aktclass^.options and oo_hasmsgint)<>0 then
  1495. datasegment^.concat(new(pai_const_symbol,init(intmessagetable)))
  1496. else
  1497. datasegment^.concat(new(pai_const,init_32bit(0)));
  1498. { pointer to class name string }
  1499. datasegment^.concat(new(pai_const_symbol,init(classnamelabel)));
  1500. end;
  1501. {$ifdef GDB}
  1502. { generate the VMT }
  1503. if (cs_debuginfo in aktmoduleswitches) and
  1504. ((aktclass^.options and oo_hasvmt)<>0) then
  1505. begin
  1506. do_count_dbx:=true;
  1507. if assigned(aktclass^.owner) and assigned(aktclass^.owner^.name) then
  1508. datasegment^.concat(new(pai_stabs,init(strpnew('"vmt_'+aktclass^.owner^.name^+n+':S'+
  1509. typeglobalnumber('__vtbl_ptr_type')+'",'+tostr(N_STSYM)+',0,0,'+aktclass^.vmt_mangledname))));
  1510. end;
  1511. {$endif GDB}
  1512. if ((aktclass^.options and oo_hasvmt)<>0) then
  1513. begin
  1514. datasegment^.concat(new(pai_symbol,initname_global(aktclass^.vmt_mangledname)));
  1515. { determine the size with publicsyms^.datasize, because }
  1516. { size gives back 4 for classes }
  1517. datasegment^.concat(new(pai_const,init_32bit(aktclass^.publicsyms^.datasize)));
  1518. datasegment^.concat(new(pai_const,init_32bit(-aktclass^.publicsyms^.datasize)));
  1519. { write pointer to parent VMT, this isn't implemented in TP }
  1520. { but this is not used in FPC ? (PM) }
  1521. { it's not used yet, but the delphi-operators as and is need it (FK) }
  1522. { it is not written for parents that don't have any vmt !! }
  1523. if assigned(aktclass^.childof) and
  1524. ((aktclass^.childof^.options and oo_hasvmt)<>0) then
  1525. begin
  1526. datasegment^.concat(new(pai_const_symbol,initname(aktclass^.childof^.vmt_mangledname)));
  1527. end
  1528. else
  1529. datasegment^.concat(new(pai_const,init_32bit(0)));
  1530. { this generates the entries }
  1531. genvmt(aktclass);
  1532. end;
  1533. { restore old state }
  1534. symtablestack:=symtablestack^.next;
  1535. procinfo._class:=nil;
  1536. aktobjectdef:=nil;
  1537. {Restore the aktprocsym.}
  1538. aktprocsym:=oldprocsym;
  1539. object_dec:=aktclass;
  1540. end;
  1541. { reads a record declaration }
  1542. function record_dec : pdef;
  1543. var
  1544. symtable : psymtable;
  1545. storetypeforwardsallowed : boolean;
  1546. begin
  1547. symtable:=new(psymtable,init(recordsymtable));
  1548. symtable^.next:=symtablestack;
  1549. symtablestack:=symtable;
  1550. consume(_RECORD);
  1551. storetypeforwardsallowed:=typecanbeforward;
  1552. if m_tp in aktmodeswitches then
  1553. typecanbeforward:=false;
  1554. read_var_decs(true,false,false);
  1555. { may be scale record size to a size of n*4 ? }
  1556. if ((symtablestack^.datasize mod aktpackrecords)<>0) then
  1557. inc(symtablestack^.datasize,aktpackrecords-(symtablestack^.datasize mod aktpackrecords));
  1558. consume(_END);
  1559. typecanbeforward:=storetypeforwardsallowed;
  1560. symtablestack:=symtable^.next;
  1561. record_dec:=new(precdef,init(symtable));
  1562. end;
  1563. { reads a type definition and returns a pointer to it }
  1564. function read_type(const name : stringid) : pdef;
  1565. function handle_procvar:Pprocvardef;
  1566. var
  1567. sc : pstringcontainer;
  1568. hs1,s : string;
  1569. p : pdef;
  1570. varspez : tvarspez;
  1571. procvardef : pprocvardef;
  1572. begin
  1573. procvardef:=new(pprocvardef,init);
  1574. if token=LKLAMMER then
  1575. begin
  1576. consume(LKLAMMER);
  1577. inc(testcurobject);
  1578. repeat
  1579. if try_to_consume(_VAR) then
  1580. varspez:=vs_var
  1581. else
  1582. if try_to_consume(_CONST) then
  1583. varspez:=vs_const
  1584. else
  1585. varspez:=vs_value;
  1586. { self method ? }
  1587. if idtoken=_SELF then
  1588. begin
  1589. procvardef^.options:=procvardef^.options or pocontainsself;
  1590. consume(idtoken);
  1591. consume(COLON);
  1592. p:=single_type(hs1);
  1593. procvardef^.concatdef(p,vs_value);
  1594. end
  1595. else
  1596. begin
  1597. sc:=idlist;
  1598. if (token=COLON) or (varspez=vs_value) then
  1599. begin
  1600. consume(COLON);
  1601. if token=_ARRAY then
  1602. begin
  1603. consume(_ARRAY);
  1604. consume(_OF);
  1605. { define range and type of range }
  1606. p:=new(Parraydef,init(0,-1,s32bitdef));
  1607. { array of const ? }
  1608. if (token=_CONST) and (m_objpas in aktmodeswitches) then
  1609. begin
  1610. consume(_CONST);
  1611. srsym:=nil;
  1612. if assigned(objpasunit) then
  1613. getsymonlyin(objpasunit,'TVARREC');
  1614. if not assigned(srsym) then
  1615. InternalError(1234124);
  1616. Parraydef(p)^.definition:=ptypesym(srsym)^.definition;
  1617. Parraydef(p)^.IsArrayOfConst:=true;
  1618. end
  1619. else
  1620. begin
  1621. { define field type }
  1622. Parraydef(p)^.definition:=single_type(s);
  1623. end;
  1624. end
  1625. else
  1626. p:=single_type(s);
  1627. end
  1628. else
  1629. p:=cformaldef;
  1630. while not sc^.empty do
  1631. begin
  1632. s:=sc^.get;
  1633. procvardef^.concatdef(p,varspez);
  1634. end;
  1635. dispose(sc,done);
  1636. end;
  1637. until not try_to_consume(SEMICOLON);
  1638. dec(testcurobject);
  1639. consume(RKLAMMER);
  1640. end;
  1641. handle_procvar:=procvardef;
  1642. end;
  1643. var
  1644. hp1,p : pdef;
  1645. aufdef : penumdef;
  1646. aufsym : penumsym;
  1647. ap : parraydef;
  1648. s : stringid;
  1649. l,v,oldaktpackrecords : longint;
  1650. hs : string;
  1651. procedure expr_type;
  1652. var
  1653. pt1,pt2 : ptree;
  1654. begin
  1655. { use of current parsed object ? }
  1656. if (token=ID) and (testcurobject=2) and (curobjectname=pattern) then
  1657. begin
  1658. consume(ID);
  1659. p:=aktobjectdef;
  1660. exit;
  1661. end;
  1662. { we can't accept a equal in type }
  1663. pt1:=comp_expr(not(ignore_equal));
  1664. do_firstpass(pt1);
  1665. if (token=POINTPOINT) then
  1666. begin
  1667. consume(POINTPOINT);
  1668. { get high value of range }
  1669. pt2:=comp_expr(not(ignore_equal));
  1670. do_firstpass(pt2);
  1671. { both must be evaluated to constants now }
  1672. if (pt1^.treetype<>ordconstn) or (pt2^.treetype<>ordconstn) then
  1673. Message(sym_e_error_in_type_def)
  1674. else
  1675. begin
  1676. { check types }
  1677. if CheckTypes(pt1^.resulttype,pt2^.resulttype) then
  1678. begin
  1679. { Check bounds }
  1680. if pt2^.value<pt1^.value then
  1681. Message(cg_e_upper_lower_than_lower)
  1682. else
  1683. begin
  1684. { All checks passed, create the new def }
  1685. case pt1^.resulttype^.deftype of
  1686. enumdef : p:=new(penumdef,init_subrange(penumdef(pt1^.resulttype),pt1^.value,pt2^.value));
  1687. orddef : begin
  1688. if is_char(pt1^.resulttype) then
  1689. p:=new(porddef,init(uchar,pt1^.value,pt2^.value))
  1690. else
  1691. if is_boolean(pt1^.resulttype) then
  1692. p:=new(porddef,init(bool8bit,pt1^.value,pt2^.value))
  1693. else
  1694. p:=new(porddef,init(uauto,pt1^.value,pt2^.value));
  1695. end;
  1696. end;
  1697. end;
  1698. end;
  1699. end;
  1700. disposetree(pt2);
  1701. end
  1702. else
  1703. begin
  1704. { a simple type renaming }
  1705. if (pt1^.treetype=typen) then
  1706. p:=pt1^.resulttype
  1707. else
  1708. Message(sym_e_error_in_type_def);
  1709. end;
  1710. disposetree(pt1);
  1711. end;
  1712. var
  1713. pt : ptree;
  1714. procedure array_dec;
  1715. var
  1716. lowval,
  1717. highval : longint;
  1718. arraytype : pdef;
  1719. begin
  1720. consume(_ARRAY);
  1721. consume(LECKKLAMMER);
  1722. { defaults }
  1723. arraytype:=generrordef;
  1724. lowval:=$80000000;
  1725. highval:=$7fffffff;
  1726. p:=nil;
  1727. repeat
  1728. { read the expression and check it }
  1729. pt:=expr;
  1730. if pt^.treetype=typen then
  1731. begin
  1732. case pt^.resulttype^.deftype of
  1733. enumdef :
  1734. begin
  1735. lowval:=penumdef(pt^.resulttype)^.min;
  1736. highval:=penumdef(pt^.resulttype)^.max;
  1737. arraytype:=pt^.resulttype;
  1738. end;
  1739. orddef :
  1740. begin
  1741. lowval:=porddef(pt^.resulttype)^.low;
  1742. highval:=porddef(pt^.resulttype)^.high;
  1743. arraytype:=pt^.resulttype;
  1744. end;
  1745. else
  1746. Message(sym_e_error_in_type_def);
  1747. end;
  1748. end
  1749. else
  1750. begin
  1751. do_firstpass(pt);
  1752. if (pt^.treetype=rangen) then
  1753. begin
  1754. if (pt^.left^.treetype=ordconstn) and
  1755. (pt^.right^.treetype=ordconstn) then
  1756. begin
  1757. lowval:=pt^.left^.value;
  1758. highval:=pt^.right^.value;
  1759. if highval<lowval then
  1760. begin
  1761. Message(parser_e_array_lower_less_than_upper_bound);
  1762. highval:=lowval;
  1763. end;
  1764. arraytype:=pt^.right^.resulttype;
  1765. end
  1766. else
  1767. Message(type_e_cant_eval_constant_expr);
  1768. end
  1769. else
  1770. Message(sym_e_error_in_type_def)
  1771. end;
  1772. disposetree(pt);
  1773. { create arraydef }
  1774. if p=nil then
  1775. begin
  1776. ap:=new(parraydef,init(lowval,highval,arraytype));
  1777. p:=ap;
  1778. end
  1779. else
  1780. begin
  1781. ap^.definition:=new(parraydef,init(lowval,highval,arraytype));
  1782. ap:=parraydef(ap^.definition);
  1783. end;
  1784. if token=COMMA then
  1785. consume(COMMA)
  1786. else
  1787. break;
  1788. until false;
  1789. consume(RECKKLAMMER);
  1790. consume(_OF);
  1791. hp1:=read_type('');
  1792. { if no error, set element type }
  1793. if assigned(ap) then
  1794. ap^.definition:=hp1;
  1795. end;
  1796. begin
  1797. p:=nil;
  1798. case token of
  1799. _STRING,_FILE:
  1800. p:=single_type(hs);
  1801. LKLAMMER:
  1802. begin
  1803. consume(LKLAMMER);
  1804. { allow negativ value_str }
  1805. l:=-1;
  1806. aufsym := Nil;
  1807. aufdef:=new(penumdef,init);
  1808. repeat
  1809. s:=pattern;
  1810. consume(ID);
  1811. if token=ASSIGNMENT then
  1812. begin
  1813. consume(ASSIGNMENT);
  1814. v:=get_intconst;
  1815. { please leave that a note, allows type save }
  1816. { declarations in the win32 units ! }
  1817. if v<=l then
  1818. Message(parser_n_duplicate_enum);
  1819. l:=v;
  1820. end
  1821. else
  1822. inc(l);
  1823. constsymtable^.insert(new(penumsym,init(s,aufdef,l)));
  1824. if token=COMMA then
  1825. consume(COMMA)
  1826. else
  1827. break;
  1828. until false;
  1829. {aufdef^.max:=l;
  1830. if we allow unordered enums
  1831. this can be wrong
  1832. min and max are now set in tenumsym.init PM }
  1833. p:=aufdef;
  1834. consume(RKLAMMER);
  1835. end;
  1836. _ARRAY:
  1837. array_dec;
  1838. _SET:
  1839. begin
  1840. consume(_SET);
  1841. consume(_OF);
  1842. hp1:=read_type('');
  1843. if assigned(hp1) then
  1844. begin
  1845. case hp1^.deftype of
  1846. { don't forget that min can be negativ PM }
  1847. enumdef : if penumdef(hp1)^.min>=0 then
  1848. p:=new(psetdef,init(hp1,penumdef(hp1)^.max))
  1849. else
  1850. Message(sym_e_ill_type_decl_set);
  1851. orddef : begin
  1852. case porddef(hp1)^.typ of
  1853. uchar : p:=new(psetdef,init(hp1,255));
  1854. u8bit,s8bit,u16bit,s16bit,s32bit :
  1855. begin
  1856. if (porddef(hp1)^.low>=0) then
  1857. p:=new(psetdef,init(hp1,porddef(hp1)^.high))
  1858. else Message(sym_e_ill_type_decl_set);
  1859. end;
  1860. else Message(sym_e_ill_type_decl_set);
  1861. end;
  1862. end;
  1863. else Message(sym_e_ill_type_decl_set);
  1864. end;
  1865. end
  1866. else
  1867. p:=generrordef;
  1868. end;
  1869. CARET:
  1870. begin
  1871. consume(CARET);
  1872. { forwards allowed only inside TYPE statements }
  1873. if typecanbeforward then
  1874. forwardsallowed:=true;
  1875. hp1:=single_type(hs);
  1876. p:=new(ppointerdef,init(hp1));
  1877. if (lasttypesym<>nil) and ((lasttypesym^.properties and sp_forwarddef)<>0) then
  1878. lasttypesym^.addforwardpointer(ppointerdef(p));
  1879. forwardsallowed:=false;
  1880. end;
  1881. _RECORD:
  1882. p:=record_dec;
  1883. _PACKED:
  1884. begin
  1885. consume(_PACKED);
  1886. if token=_ARRAY then
  1887. array_dec
  1888. else
  1889. begin
  1890. oldaktpackrecords:=aktpackrecords;
  1891. aktpackrecords:=1;
  1892. if token in [_CLASS,_OBJECT] then
  1893. p:=object_dec(name,nil)
  1894. else
  1895. p:=record_dec;
  1896. aktpackrecords:=oldaktpackrecords;
  1897. end;
  1898. end;
  1899. _CLASS,
  1900. _OBJECT:
  1901. p:=object_dec(name,nil);
  1902. _PROCEDURE:
  1903. begin
  1904. consume(_PROCEDURE);
  1905. p:=handle_procvar;
  1906. if token=_OF then
  1907. begin
  1908. consume(_OF);
  1909. consume(_OBJECT);
  1910. pprocvardef(p)^.options:=pprocvardef(p)^.options or pomethodpointer;
  1911. end;
  1912. end;
  1913. _FUNCTION:
  1914. begin
  1915. consume(_FUNCTION);
  1916. p:=handle_procvar;
  1917. consume(COLON);
  1918. pprocvardef(p)^.retdef:=single_type(hs);
  1919. if token=_OF then
  1920. begin
  1921. consume(_OF);
  1922. consume(_OBJECT);
  1923. pprocvardef(p)^.options:=pprocvardef(p)^.options or pomethodpointer;
  1924. end;
  1925. end;
  1926. else
  1927. expr_type;
  1928. end;
  1929. if p=nil then
  1930. p:=generrordef;
  1931. read_type:=p;
  1932. end;
  1933. { reads a type declaration to the symbol table }
  1934. procedure type_dec;
  1935. var
  1936. typename : stringid;
  1937. newtype : ptypesym;
  1938. sym : psym;
  1939. begin
  1940. block_type:=bt_type;
  1941. consume(_TYPE);
  1942. typecanbeforward:=true;
  1943. repeat
  1944. typename:=pattern;
  1945. consume(ID);
  1946. consume(EQUAL);
  1947. { here you loose the strictness of pascal
  1948. for which a redefinition like
  1949. childtype = parenttype;
  1950. child2type = parenttype;
  1951. does not make the two child types equal !!
  1952. here all vars from childtype and child2type
  1953. get the definition of parenttype !! }
  1954. {$ifdef testequaltype}
  1955. if (token = ID) or (token=_FILE) or (token=_STRING) then
  1956. begin
  1957. olddef := single_type(s);
  1958. { make a clone of olddef }
  1959. { is that ok ??? }
  1960. getmem(newdef,SizeOf(olddef));
  1961. move(olddef^,newdef^,SizeOf(olddef));
  1962. newtype:=new(ptypesym,init(typename,newdef));
  1963. symtablestack^.insert(newtype);
  1964. end
  1965. else
  1966. {$endif testequaltype}
  1967. begin
  1968. getsym(typename,false);
  1969. sym:=srsym;
  1970. newtype:=nil;
  1971. { found a symbol with this name? }
  1972. if assigned(sym) then
  1973. begin
  1974. if (sym^.typ=typesym) then
  1975. begin
  1976. if (token=_CLASS) and
  1977. (assigned(ptypesym(sym)^.definition)) and
  1978. (ptypesym(sym)^.definition^.deftype=objectdef) and
  1979. ((pobjectdef(ptypesym(sym)^.definition)^.options and oo_isforward)<>0) and
  1980. ((pobjectdef(ptypesym(sym)^.definition)^.options and oo_is_class)<>0) then
  1981. begin
  1982. { we can ignore the result }
  1983. { the definition is modified }
  1984. object_dec(typename,pobjectdef(ptypesym(sym)^.definition));
  1985. newtype:=ptypesym(sym);
  1986. end
  1987. else
  1988. if sym^.properties=sp_forwarddef then
  1989. begin
  1990. ptypesym(sym)^.updateforwarddef(read_type(typename));
  1991. newtype:=ptypesym(sym);
  1992. end;
  1993. end;
  1994. end;
  1995. { no old type reused ? Then insert this new type }
  1996. if not assigned(newtype) then
  1997. begin
  1998. newtype:=new(ptypesym,init(typename,read_type(typename)));
  1999. newtype:=ptypesym(symtablestack^.insert(newtype));
  2000. end;
  2001. end;
  2002. consume(SEMICOLON);
  2003. if assigned(newtype^.definition) and (newtype^.definition^.deftype=procvardef) then
  2004. parse_var_proc_directives(newtype);
  2005. until token<>ID;
  2006. typecanbeforward:=false;
  2007. {$ifdef tp}
  2008. symtablestack^.foreach(testforward_type);
  2009. {$else}
  2010. symtablestack^.foreach(@testforward_type);
  2011. {$endif}
  2012. resolve_forwards;
  2013. block_type:=bt_general;
  2014. end;
  2015. procedure var_dec;
  2016. { parses varaible declarations and inserts them in }
  2017. { the top symbol table of symtablestack }
  2018. begin
  2019. consume(_VAR);
  2020. read_var_decs(false,false,false);
  2021. end;
  2022. procedure threadvar_dec;
  2023. { parses thread variable declarations and inserts them in }
  2024. { the top symbol table of symtablestack }
  2025. begin
  2026. consume(_THREADVAR);
  2027. if not(symtablestack^.symtabletype in [staticsymtable,globalsymtable]) then
  2028. message(parser_e_threadvars_only_sg);
  2029. read_var_decs(false,false,true);
  2030. end;
  2031. procedure Not_supported_for_inline(t : ttoken);
  2032. begin
  2033. if assigned(aktprocsym) and
  2034. ((aktprocsym^.definition^.options and poinline)<>0) then
  2035. Begin
  2036. Message1(parser_w_not_supported_for_inline,tokenstring(t));
  2037. Message(parser_w_inlining_disabled);
  2038. aktprocsym^.definition^.options:= aktprocsym^.definition^.options and not poinline;
  2039. End;
  2040. end;
  2041. procedure read_declarations(islibrary : boolean);
  2042. begin
  2043. repeat
  2044. case token of
  2045. _LABEL:
  2046. begin
  2047. Not_supported_for_inline(token);
  2048. label_dec;
  2049. end;
  2050. _CONST:
  2051. begin
  2052. Not_supported_for_inline(token);
  2053. const_dec;
  2054. end;
  2055. _TYPE:
  2056. begin
  2057. Not_supported_for_inline(token);
  2058. type_dec;
  2059. end;
  2060. _VAR:
  2061. var_dec;
  2062. _THREADVAR:
  2063. threadvar_dec;
  2064. _CONSTRUCTOR,_DESTRUCTOR,
  2065. _FUNCTION,_PROCEDURE,_OPERATOR,_CLASS:
  2066. begin
  2067. Not_supported_for_inline(token);
  2068. read_proc;
  2069. end;
  2070. _EXPORTS:
  2071. begin
  2072. Not_supported_for_inline(token);
  2073. { here we should be at lexlevel 1, no ? PM }
  2074. if (lexlevel<>main_program_level) or
  2075. (not islibrary and not DLLsource) then
  2076. begin
  2077. Message(parser_e_syntax_error);
  2078. consume_all_until(SEMICOLON);
  2079. end
  2080. else if islibrary then
  2081. read_exports;
  2082. end
  2083. else break;
  2084. end;
  2085. until false;
  2086. end;
  2087. procedure read_interface_declarations;
  2088. begin
  2089. {Since the body is now parsed at lexlevel 1, and the declarations
  2090. must be parsed at the same lexlevel we increase the lexlevel.}
  2091. inc(lexlevel);
  2092. repeat
  2093. case token of
  2094. _CONST : const_dec;
  2095. _TYPE : type_dec;
  2096. _VAR : var_dec;
  2097. _THREADVAR : threadvar_dec;
  2098. _FUNCTION,
  2099. _PROCEDURE,
  2100. _OPERATOR : read_proc;
  2101. else
  2102. break;
  2103. end;
  2104. until false;
  2105. dec(lexlevel);
  2106. end;
  2107. end.
  2108. {
  2109. $Log$
  2110. Revision 1.123 1999-05-27 19:44:45 peter
  2111. * removed oldasm
  2112. * plabel -> pasmlabel
  2113. * -a switches to source writing automaticly
  2114. * assembler readers OOPed
  2115. * asmsymbol automaticly external
  2116. * jumptables and other label fixes for asm readers
  2117. Revision 1.122 1999/05/21 20:08:22 florian
  2118. * hopefully the default property bug fixed
  2119. Revision 1.121 1999/05/21 13:55:04 peter
  2120. * NEWLAB for label as symbol
  2121. Revision 1.120 1999/05/20 22:19:52 pierre
  2122. * better stabs line info for vars
  2123. Revision 1.119 1999/05/19 12:41:56 florian
  2124. * made source compilable with TP (too long line)
  2125. * default values for set properties fixed
  2126. Revision 1.118 1999/05/18 14:15:51 peter
  2127. * containsself fixes
  2128. * checktypes()
  2129. Revision 1.117 1999/05/17 21:57:12 florian
  2130. * new temporary ansistring handling
  2131. Revision 1.116 1999/05/13 21:59:34 peter
  2132. * removed oldppu code
  2133. * warning if objpas is loaded from uses
  2134. * first things for new deref writing
  2135. Revision 1.115 1999/05/07 10:36:09 peter
  2136. * fixed crash
  2137. Revision 1.114 1999/05/04 21:44:54 florian
  2138. * changes to compile it with Delphi 4.0
  2139. Revision 1.113 1999/05/01 13:24:30 peter
  2140. * merged nasm compiler
  2141. * old asm moved to oldasm/
  2142. Revision 1.112 1999/04/28 06:02:07 florian
  2143. * changes of Bruessel:
  2144. + message handler can now take an explicit self
  2145. * typinfo fixed: sometimes the type names weren't written
  2146. * the type checking for pointer comparisations and subtraction
  2147. and are now more strict (was also buggy)
  2148. * small bug fix to link.pas to support compiling on another
  2149. drive
  2150. * probable bug in popt386 fixed: call/jmp => push/jmp
  2151. transformation didn't count correctly the jmp references
  2152. + threadvar support
  2153. * warning if ln/sqrt gets an invalid constant argument
  2154. Revision 1.111 1999/04/26 13:31:37 peter
  2155. * release storenumber,double_checksum
  2156. Revision 1.110 1999/04/25 22:42:16 pierre
  2157. + code for initialized vars in Delphi mode
  2158. Revision 1.109 1999/04/21 09:43:45 peter
  2159. * storenumber works
  2160. * fixed some typos in double_checksum
  2161. + incompatible types type1 and type2 message (with storenumber)
  2162. Revision 1.108 1999/04/17 13:16:19 peter
  2163. * fixes for storenumber
  2164. Revision 1.107 1999/04/14 09:14:50 peter
  2165. * first things to store the symbol/def number in the ppu
  2166. Revision 1.106 1999/04/07 15:31:15 pierre
  2167. * all formaldefs are now a sinlge definition
  2168. cformaldef (this was necessary for double_checksum)
  2169. + small part of double_checksum code
  2170. Revision 1.105 1999/03/26 00:05:34 peter
  2171. * released valintern
  2172. + deffile is now removed when compiling is finished
  2173. * ^( compiles now correct
  2174. + static directive
  2175. * shrd fixed
  2176. Revision 1.104 1999/03/24 23:17:13 peter
  2177. * fixed bugs 212,222,225,227,229,231,233
  2178. Revision 1.103 1999/03/22 22:10:25 florian
  2179. * typecanbeforward wasn't always restored in object_dec which
  2180. sometimes caused strange effects
  2181. Revision 1.102 1999/03/05 01:14:26 pierre
  2182. * bug0198 : call conventions for methods
  2183. not yet implemented is the control of same calling convention
  2184. for virtual and child's virtual
  2185. * msgstr and msgint only created if message was found
  2186. who implemented this by the way ?
  2187. it leaks lots of plabels !!!! (check with heaptrc !)
  2188. Revision 1.101 1999/02/25 21:02:41 peter
  2189. * ag386bin updates
  2190. + coff writer
  2191. Revision 1.100 1999/02/24 00:59:14 peter
  2192. * small updates for ag386bin
  2193. Revision 1.99 1999/02/22 23:33:29 florian
  2194. + message directive for integers added
  2195. Revision 1.98 1999/02/22 20:13:36 florian
  2196. + first implementation of message keyword
  2197. Revision 1.97 1999/02/22 02:44:10 peter
  2198. * ag386bin doesn't use i386.pas anymore
  2199. Revision 1.96 1999/02/17 14:20:40 pierre
  2200. * Reference specific bug in recompiling unit solved
  2201. Revision 1.95 1999/01/25 20:13:48 peter
  2202. * fixed crash with forward declared class of ...
  2203. Revision 1.94 1999/01/19 12:17:00 peter
  2204. * fixed constant strings > 255 chars
  2205. Revision 1.93 1999/01/15 13:08:23 peter
  2206. * error if upper<lower in array decl
  2207. Revision 1.92 1999/01/14 21:49:58 peter
  2208. * fixed forwardpointer problem with multiple forwards for the same
  2209. typesym. It now uses a linkedlist instead of a single pointer
  2210. Revision 1.91 1998/12/30 22:15:46 peter
  2211. + farpointer type
  2212. * absolutesym now also stores if its far
  2213. Revision 1.90 1998/12/15 17:16:00 peter
  2214. * fixed const s : ^string
  2215. * first things for const pchar : @string[1]
  2216. Revision 1.89 1998/12/11 00:03:30 peter
  2217. + globtype,tokens,version unit splitted from globals
  2218. Revision 1.88 1998/11/30 09:43:20 pierre
  2219. * some range check bugs fixed (still not working !)
  2220. + added DLL writing support for win32 (also accepts variables)
  2221. + TempAnsi for code that could be used for Temporary ansi strings
  2222. handling
  2223. Revision 1.87 1998/11/29 12:42:24 peter
  2224. * check for constants with array decl
  2225. Revision 1.86 1998/11/28 16:20:52 peter
  2226. + support for dll variables
  2227. Revision 1.85 1998/11/27 14:34:43 peter
  2228. * give error when string[0] decl is found
  2229. Revision 1.84 1998/11/17 10:40:15 peter
  2230. * H+ fixes
  2231. Revision 1.83 1998/11/16 11:28:59 pierre
  2232. * stackcheck removed for i386_win32
  2233. * exportlist does not crash at least !!
  2234. (was need for tests dir !)z
  2235. Revision 1.82 1998/11/16 10:18:07 peter
  2236. * fixes for ansistrings
  2237. Revision 1.81 1998/11/13 15:40:22 pierre
  2238. + added -Se in Makefile cvstest target
  2239. + lexlevel cleanup
  2240. normal_function_level main_program_level and unit_init_level defined
  2241. * tins_cache grown to A_EMMS (gave range check error in asm readers)
  2242. (test added in code !)
  2243. * -Un option was wrong
  2244. * _FAIL and _SELF only keyword inside
  2245. constructors and methods respectively
  2246. Revision 1.80 1998/11/13 10:18:09 peter
  2247. + nil constants
  2248. Revision 1.79 1998/11/05 12:02:51 peter
  2249. * released useansistring
  2250. * removed -Sv, its now available in fpc modes
  2251. Revision 1.78 1998/10/27 13:45:33 pierre
  2252. * classes get a vmt allways
  2253. * better error info (tried to remove
  2254. several error strings introduced by the tpexcept handling)
  2255. Revision 1.77 1998/10/26 22:58:20 florian
  2256. * new introduded problem with classes fix, the parent class wasn't set
  2257. correct, if the class was defined forward before
  2258. Revision 1.76 1998/10/25 23:31:18 peter
  2259. * procvar parsing updated just like psub.pas routine
  2260. Revision 1.75 1998/10/21 08:39:59 florian
  2261. + ansistring operator +
  2262. + $h and string[n] for n>255 added
  2263. * small problem with TP fixed
  2264. Revision 1.74 1998/10/20 13:09:13 peter
  2265. * fixed object(unknown) crash
  2266. Revision 1.73 1998/10/19 08:54:56 pierre
  2267. * wrong stabs info corrected once again !!
  2268. + variable vmt offset with vmt field only if required
  2269. implemented now !!!
  2270. Revision 1.72 1998/10/16 13:12:51 pierre
  2271. * added vmt_offsets in destructors code also !!!
  2272. * vmt_offset code for m68k
  2273. Revision 1.71 1998/10/15 15:13:25 pierre
  2274. + added oo_hasconstructor and oo_hasdestructor
  2275. for objects options
  2276. Revision 1.70 1998/10/13 13:10:22 peter
  2277. * new style for m68k/i386 infos and enums
  2278. Revision 1.69 1998/10/09 12:07:49 pierre
  2279. * typo error for propertyparas dispose corrected
  2280. Revision 1.68 1998/10/09 11:47:54 pierre
  2281. * still more memory leaks fixes !!
  2282. Revision 1.67 1998/10/08 13:48:46 peter
  2283. * fixed memory leaks for do nothing source
  2284. * fixed unit interdependency
  2285. Revision 1.66 1998/10/06 20:43:31 peter
  2286. * fixed set of bugs. like set of false..true set of #1..#255 and
  2287. set of #1..true which was allowed
  2288. Revision 1.65 1998/10/05 22:43:35 peter
  2289. * commited the wrong file :(
  2290. Revision 1.64 1998/10/05 21:33:24 peter
  2291. * fixed 161,165,166,167,168
  2292. Revision 1.63 1998/10/05 13:57:13 peter
  2293. * crash preventions
  2294. Revision 1.62 1998/10/02 17:06:02 peter
  2295. * better error message for unresolved forward types
  2296. Revision 1.61 1998/10/02 09:23:24 peter
  2297. * fixed error msg with type l=<var>
  2298. * block_type bt_const is now set in read_const_dec
  2299. Revision 1.60 1998/09/30 07:40:33 florian
  2300. * better error recovering
  2301. Revision 1.59 1998/09/26 17:45:33 peter
  2302. + idtoken and only one token table
  2303. Revision 1.58 1998/09/25 00:04:01 florian
  2304. * problems when calling class methods fixed
  2305. Revision 1.57 1998/09/24 23:49:09 peter
  2306. + aktmodeswitches
  2307. Revision 1.56 1998/09/23 15:39:09 pierre
  2308. * browser bugfixes
  2309. was adding a reference when looking for the symbol
  2310. if -bSYM_NAME was used
  2311. Revision 1.55 1998/09/21 13:24:44 daniel
  2312. * Memory leak fixed.
  2313. Revision 1.54 1998/09/17 13:41:16 pierre
  2314. sizeof(TPOINT) problem
  2315. Revision 1.53.2.1 1998/09/17 13:12:09 pierre
  2316. * virtual destructor did not set oo_hasvirtual
  2317. (detected with the sizeof(TPoint) problem
  2318. * genloadcallnode was missing
  2319. Revision 1.53 1998/09/09 11:50:52 pierre
  2320. * forward def are not put in record or objects
  2321. + added check for forwards also in record and objects
  2322. * dummy parasymtable for unit initialization removed from
  2323. symtable stack
  2324. Revision 1.52 1998/09/07 23:10:22 florian
  2325. * a lot of stuff fixed regarding rtti and publishing of properties,
  2326. basics should now work
  2327. Revision 1.51 1998/09/07 19:33:22 florian
  2328. + some stuff for property rtti added:
  2329. - NameIndex of the TPropInfo record is now written correctly
  2330. - the DEFAULT/NODEFAULT keyword is supported now
  2331. - the default value and the storedsym/def are now written to
  2332. the PPU fiel
  2333. Revision 1.50 1998/09/07 18:46:08 peter
  2334. * update smartlinking, uses getdatalabel
  2335. * renamed ptree.value vars to value_str,value_real,value_set
  2336. Revision 1.49 1998/09/07 17:37:00 florian
  2337. * first fixes for published properties
  2338. Revision 1.48 1998/09/04 08:42:02 peter
  2339. * updated some error messages
  2340. Revision 1.47 1998/09/03 16:03:18 florian
  2341. + rtti generation
  2342. * init table generation changed
  2343. Revision 1.46 1998/09/01 17:39:48 peter
  2344. + internal constant functions
  2345. Revision 1.45 1998/08/31 12:20:28 peter
  2346. * fixed array_dec when unknown type was used
  2347. Revision 1.44 1998/08/28 10:57:01 peter
  2348. * removed warnings
  2349. Revision 1.43 1998/08/25 13:09:25 pierre
  2350. * corrected mangling sheme :
  2351. cvar add Cprefix to the mixed case name whereas
  2352. export or public use direct name
  2353. Revision 1.42 1998/08/25 12:42:41 pierre
  2354. * CDECL changed to CVAR for variables
  2355. specifications are read in structures also
  2356. + started adding GPC compatibility mode ( option -Sp)
  2357. * names changed to lowercase
  2358. Revision 1.41 1998/08/23 21:04:36 florian
  2359. + rtti generation for classes added
  2360. + new/dispose do now also a call to INITIALIZE/FINALIZE, if necessaray
  2361. Revision 1.40 1998/08/21 15:48:58 pierre
  2362. * more cdecl chagnes
  2363. - better line info
  2364. - changes the definition options of a procvar
  2365. if it is a unnamed type
  2366. Revision 1.39 1998/08/19 00:42:40 peter
  2367. + subrange types for enums
  2368. + checking for bounds type with ranges
  2369. Revision 1.38 1998/08/12 19:20:39 peter
  2370. + public is the same as export for c_vars
  2371. * a exported/public c_var incs now the refcount
  2372. Revision 1.37 1998/08/11 15:31:38 peter
  2373. * write extended to ppu file
  2374. * new version 0.99.7
  2375. Revision 1.36 1998/08/10 14:50:09 peter
  2376. + localswitches, moduleswitches, globalswitches splitting
  2377. Revision 1.35 1998/07/26 21:59:00 florian
  2378. + better support for switch $H
  2379. + index access to ansi strings added
  2380. + assigment of data (records/arrays) containing ansi strings
  2381. Revision 1.34 1998/07/20 22:17:15 florian
  2382. * hex constants in numeric char (#$54#$43 ...) are now allowed
  2383. * there was a bug in record_var_dec which prevents the used
  2384. of nested variant records (for example drivers.tevent of tv)
  2385. Revision 1.33 1998/07/18 17:11:11 florian
  2386. + ansi string constants fixed
  2387. + switch $H partial implemented
  2388. Revision 1.32 1998/07/14 21:46:50 peter
  2389. * updated messages file
  2390. Revision 1.31 1998/07/14 14:46:53 peter
  2391. * released NEWINPUT
  2392. Revision 1.30 1998/07/10 00:00:00 peter
  2393. * fixed ttypesym bug finally
  2394. * fileinfo in the symtable and better using for unused vars
  2395. Revision 1.29 1998/06/25 14:04:21 peter
  2396. + internal inc/dec
  2397. Revision 1.28 1998/06/24 12:26:45 peter
  2398. * stricter var parsing like tp7 and some optimizes with directive
  2399. parsing
  2400. Revision 1.27 1998/06/12 16:15:34 pierre
  2401. * external name 'C_var';
  2402. export name 'intern_C_var';
  2403. cdecl;
  2404. cdecl;external;
  2405. are now supported only with -Sv switch
  2406. Revision 1.25 1998/06/09 16:01:45 pierre
  2407. + added procedure directive parsing for procvars
  2408. (accepted are popstack cdecl and pascal)
  2409. + added C vars with the following syntax
  2410. var C calias 'true_c_name';(can be followed by external)
  2411. reason is that you must add the Cprefix
  2412. which is target dependent
  2413. Revision 1.24 1998/06/05 14:37:32 pierre
  2414. * fixes for inline for operators
  2415. * inline procedure more correctly restricted
  2416. Revision 1.23 1998/06/04 23:51:50 peter
  2417. * m68k compiles
  2418. + .def file creation moved to gendef.pas so it could also be used
  2419. for win32
  2420. Revision 1.22 1998/06/03 22:48:59 peter
  2421. + wordbool,longbool
  2422. * rename bis,von -> high,low
  2423. * moved some systemunit loading/creating to psystem.pas
  2424. Revision 1.21 1998/06/03 22:14:19 florian
  2425. * problem with sizes of classes fixed (if the anchestor was declared
  2426. forward, the compiler doesn't update the child classes size)
  2427. Revision 1.20 1998/05/28 14:35:54 peter
  2428. * nicer error message when no id is used after var
  2429. Revision 1.19 1998/05/23 01:21:19 peter
  2430. + aktasmmode, aktoptprocessor, aktoutputformat
  2431. + smartlink per module $SMARTLINK-/+ (like MMX) and moved to aktswitches
  2432. + $LIBNAME to set the library name where the unit will be put in
  2433. * splitted cgi386 a bit (codeseg to large for bp7)
  2434. * nasm, tasm works again. nasm moved to ag386nsm.pas
  2435. Revision 1.18 1998/05/20 09:42:35 pierre
  2436. + UseTokenInfo now default
  2437. * unit in interface uses and implementation uses gives error now
  2438. * only one error for unknown symbol (uses lastsymknown boolean)
  2439. the problem came from the label code !
  2440. + first inlined procedures and function work
  2441. (warning there might be allowed cases were the result is still wrong !!)
  2442. * UseBrower updated gives a global list of all position of all used symbols
  2443. with switch -gb
  2444. Revision 1.17 1998/05/11 13:07:55 peter
  2445. + $ifdef NEWPPU for the new ppuformat
  2446. + $define GDB not longer required
  2447. * removed all warnings and stripped some log comments
  2448. * no findfirst/findnext anymore to remove smartlink *.o files
  2449. Revision 1.16 1998/05/05 12:05:42 florian
  2450. * problems with properties fixed
  2451. * crash fixed: i:=l when i and l are undefined, was a problem with
  2452. implementation of private/protected
  2453. Revision 1.15 1998/05/01 09:01:23 florian
  2454. + correct semantics of private and protected
  2455. * small fix in variable scope:
  2456. a id can be used in a parameter list of a method, even it is used in
  2457. an anchestor class as field id
  2458. Revision 1.14 1998/05/01 07:43:56 florian
  2459. + basics for rtti implemented
  2460. + switch $m (generate rtti for published sections)
  2461. Revision 1.13 1998/04/30 15:59:41 pierre
  2462. * GDB works again better :
  2463. correct type info in one pass
  2464. + UseTokenInfo for better source position
  2465. * fixed one remaining bug in scanner for line counts
  2466. * several little fixes
  2467. Revision 1.12 1998/04/29 10:33:57 pierre
  2468. + added some code for ansistring (not complete nor working yet)
  2469. * corrected operator overloading
  2470. * corrected nasm output
  2471. + started inline procedures
  2472. + added starstarn : use ** for exponentiation (^ gave problems)
  2473. + started UseTokenInfo cond to get accurate positions
  2474. Revision 1.11 1998/04/28 11:45:52 florian
  2475. * make it compilable with TP
  2476. + small COM problems solved to compile classes.pp
  2477. Revision 1.10 1998/04/27 23:10:28 peter
  2478. + new scanner
  2479. * $makelib -> if smartlink
  2480. * small filename fixes pmodule.setfilename
  2481. * moved import from files.pas -> import.pas
  2482. Revision 1.9 1998/04/10 21:36:56 florian
  2483. + some stuff to support method pointers (procedure of object) added
  2484. (declaration, parameter handling)
  2485. Revision 1.8 1998/04/10 15:39:48 florian
  2486. * more fixes to get classes.pas compiled
  2487. Revision 1.7 1998/04/09 23:02:15 florian
  2488. * small problems solved to get remake3 work
  2489. Revision 1.6 1998/04/09 22:16:35 florian
  2490. * problem with previous REGALLOC solved
  2491. * improved property support
  2492. Revision 1.5 1998/04/08 14:59:20 florian
  2493. * problem with new expr_type solved
  2494. Revision 1.4 1998/04/08 10:26:09 florian
  2495. * correct error handling of virtual constructors
  2496. * problem with new type declaration handling fixed
  2497. Revision 1.3 1998/04/07 22:45:05 florian
  2498. * bug0092, bug0115 and bug0121 fixed
  2499. + packed object/class/array
  2500. Revision 1.2 1998/04/05 13:58:35 peter
  2501. * fixed the -Ss bug
  2502. + warning for Virtual constructors
  2503. * helppages updated with -TGO32V1
  2504. }