pdecsub.pas 74 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038
  1. {
  2. $Id$
  3. Copyright (c) 1998-2000 by Florian Klaempfl, Daniel Mantione
  4. Does the parsing of the procedures/functions
  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 pdecsub;
  19. {$i defines.inc}
  20. interface
  21. uses
  22. tokens,symconst,symtype,symdef,symsym;
  23. const
  24. pd_global = $1; { directive must be global }
  25. pd_body = $2; { directive needs a body }
  26. pd_implemen = $4; { directive can be used implementation section }
  27. pd_interface = $8; { directive can be used interface section }
  28. pd_object = $10; { directive can be used object declaration }
  29. pd_procvar = $20; { directive can be used procvar declaration }
  30. pd_notobject = $40; { directive can not be used object declaration }
  31. pd_notobjintf= $80; { directive can not be used interface declaration }
  32. function is_proc_directive(tok:ttoken):boolean;
  33. function check_identical_proc(var p : tprocdef) : boolean;
  34. procedure parameter_dec(aktprocdef:tabstractprocdef);
  35. procedure parse_proc_directives(var pdflags:word);
  36. procedure parse_proc_head(options:tproctypeoption);
  37. procedure parse_proc_dec;
  38. procedure parse_var_proc_directives(var sym : tsym);
  39. procedure parse_object_proc_directives(var sym : tprocsym);
  40. implementation
  41. uses
  42. {$ifdef delphi}
  43. sysutils,
  44. {$else delphi}
  45. strings,
  46. {$endif delphi}
  47. { common }
  48. cutils,cclasses,
  49. { global }
  50. globtype,globals,verbose,
  51. systems,
  52. { aasm }
  53. aasm,
  54. { symtable }
  55. symbase,symtable,types,
  56. { pass 1 }
  57. node,htypechk,
  58. nmat,nadd,ncal,nset,ncnv,ninl,ncon,nld,nflw,
  59. { parser }
  60. fmodule,scanner,
  61. pbase,pexpr,ptype,pdecl,
  62. { linking }
  63. import,gendef,
  64. { codegen }
  65. {$ifdef newcg}
  66. cgbase
  67. {$else}
  68. hcodegen
  69. {$endif}
  70. ;
  71. procedure parameter_dec(aktprocdef:tabstractprocdef);
  72. {
  73. handle_procvar needs the same changes
  74. }
  75. var
  76. is_procvar : boolean;
  77. sc : tidstringlist;
  78. s : string;
  79. hpos,
  80. storetokenpos : tfileposinfo;
  81. htype,
  82. tt : ttype;
  83. hvs,
  84. vs : tvarsym;
  85. srsym : tsym;
  86. hs1,hs2 : string;
  87. varspez : Tvarspez;
  88. inserthigh : boolean;
  89. tdefaultvalue : tconstsym;
  90. defaultrequired : boolean;
  91. begin
  92. { reset }
  93. defaultrequired:=false;
  94. { parsing a proc or procvar ? }
  95. is_procvar:=(aktprocdef.deftype=procvardef);
  96. consume(_LKLAMMER);
  97. { Delphi/Kylix supports nonsense like }
  98. { procedure p(); }
  99. if try_to_consume(_RKLAMMER) and
  100. not(m_tp7 in aktmodeswitches) then
  101. exit;
  102. inc(testcurobject);
  103. repeat
  104. if try_to_consume(_VAR) then
  105. varspez:=vs_var
  106. else
  107. if try_to_consume(_CONST) then
  108. varspez:=vs_const
  109. else
  110. if (idtoken=_OUT) and (m_out in aktmodeswitches) then
  111. begin
  112. consume(_OUT);
  113. varspez:=vs_out
  114. end
  115. else
  116. varspez:=vs_value;
  117. inserthigh:=false;
  118. tdefaultvalue:=nil;
  119. tt.reset;
  120. { self is only allowed in procvars and class methods }
  121. if (idtoken=_SELF) and
  122. (is_procvar or
  123. (assigned(procinfo^._class) and is_class(procinfo^._class))) then
  124. begin
  125. if not is_procvar then
  126. begin
  127. {$ifndef UseNiceNames}
  128. hs2:=hs2+'$'+'self';
  129. {$else UseNiceNames}
  130. hs2:=hs2+tostr(length('self'))+'self';
  131. {$endif UseNiceNames}
  132. htype.setdef(procinfo^._class);
  133. vs:=tvarsym.create('@',htype);
  134. vs.varspez:=vs_var;
  135. { insert the sym in the parasymtable }
  136. tprocdef(aktprocdef).parast.insert(vs);
  137. include(aktprocdef.procoptions,po_containsself);
  138. inc(procinfo^.selfpointer_offset,vs.address);
  139. end;
  140. consume(idtoken);
  141. consume(_COLON);
  142. single_type(tt,hs1,false);
  143. aktprocdef.concatpara(tt,vs_value,nil);
  144. { check the types for procedures only }
  145. if not is_procvar then
  146. CheckTypes(tt.def,procinfo^._class);
  147. end
  148. else
  149. begin
  150. { read identifiers }
  151. sc:=consume_idlist;
  152. {$ifdef fixLeaksOnError}
  153. strContStack.push(sc);
  154. {$endif fixLeaksOnError}
  155. { read type declaration, force reading for value and const paras }
  156. if (token=_COLON) or (varspez=vs_value) then
  157. begin
  158. consume(_COLON);
  159. { check for an open array }
  160. if token=_ARRAY then
  161. begin
  162. consume(_ARRAY);
  163. consume(_OF);
  164. { define range and type of range }
  165. tt.setdef(tarraydef.create(0,-1,s32bittype));
  166. { array of const ? }
  167. if (token=_CONST) and (m_objpas in aktmodeswitches) then
  168. begin
  169. consume(_CONST);
  170. srsym:=searchsymonlyin(systemunit,'TVARREC');
  171. if not assigned(srsym) then
  172. InternalError(1234124);
  173. tarraydef(tt.def).elementtype:=ttypesym(srsym).restype;
  174. tarraydef(tt.def).IsArrayOfConst:=true;
  175. hs1:='array_of_const';
  176. end
  177. else
  178. begin
  179. { define field type }
  180. single_type(tarraydef(tt.def).elementtype,hs1,false);
  181. hs1:='array_of_'+hs1;
  182. end;
  183. inserthigh:=true;
  184. end
  185. else
  186. begin
  187. { open string ? }
  188. if (varspez=vs_var) and
  189. (
  190. (
  191. ((token=_STRING) or (idtoken=_SHORTSTRING)) and
  192. (cs_openstring in aktmoduleswitches) and
  193. not(cs_ansistrings in aktlocalswitches)
  194. ) or
  195. (idtoken=_OPENSTRING)) then
  196. begin
  197. consume(token);
  198. tt:=openshortstringtype;
  199. hs1:='openstring';
  200. inserthigh:=true;
  201. end
  202. else
  203. begin
  204. { everything else }
  205. single_type(tt,hs1,false);
  206. end;
  207. { default parameter }
  208. if (m_default_para in aktmodeswitches) then
  209. begin
  210. if try_to_consume(_EQUAL) then
  211. begin
  212. s:=sc.get(hpos);
  213. if not sc.empty then
  214. Comment(V_Error,'default value only allowed for one parameter');
  215. sc.add(s,hpos);
  216. { prefix 'def' to the parameter name }
  217. tdefaultvalue:=ReadConstant('$def'+Upper(s),hpos);
  218. if assigned(tdefaultvalue) then
  219. tprocdef(aktprocdef).parast.insert(tdefaultvalue);
  220. defaultrequired:=true;
  221. end
  222. else
  223. begin
  224. if defaultrequired then
  225. Comment(V_Error,'default parameter required');
  226. end;
  227. end;
  228. end;
  229. end
  230. else
  231. begin
  232. {$ifndef UseNiceNames}
  233. hs1:='$$$';
  234. {$else UseNiceNames}
  235. hs1:='var';
  236. {$endif UseNiceNames}
  237. tt:=cformaltype;
  238. end;
  239. if not is_procvar then
  240. hs2:=tprocdef(aktprocdef).mangledname;
  241. storetokenpos:=akttokenpos;
  242. while not sc.empty do
  243. begin
  244. s:=sc.get(akttokenpos);
  245. aktprocdef.concatpara(tt,varspez,tdefaultvalue);
  246. { For proc vars we only need the definitions }
  247. if not is_procvar then
  248. begin
  249. {$ifndef UseNiceNames}
  250. hs2:=hs2+'$'+hs1;
  251. {$else UseNiceNames}
  252. hs2:=hs2+tostr(length(hs1))+hs1;
  253. {$endif UseNiceNames}
  254. vs:=tvarsym.create(s,tt);
  255. vs.varspez:=varspez;
  256. { we have to add this to avoid var param to be in registers !!!}
  257. { I don't understand the comment above, }
  258. { but I suppose the comment is wrong and }
  259. { it means that the address of var parameters can be placed }
  260. { in a register (FK) }
  261. if (varspez in [vs_var,vs_const,vs_out]) and push_addr_param(tt.def) then
  262. include(vs.varoptions,vo_regable);
  263. { insert the sym in the parasymtable }
  264. tprocdef(aktprocdef).parast.insert(vs);
  265. { do we need a local copy? Then rename the varsym, do this after the
  266. insert so the dup id checking is done correctly }
  267. if (varspez=vs_value) and
  268. push_addr_param(tt.def) and
  269. not(is_open_array(tt.def) or is_array_of_const(tt.def)) then
  270. tprocdef(aktprocdef).parast.rename(vs.name,'val'+vs.name);
  271. { also need to push a high value? }
  272. if inserthigh then
  273. begin
  274. hvs:=tvarsym.create('$high'+Upper(s),s32bittype);
  275. hvs.varspez:=vs_const;
  276. tprocdef(aktprocdef).parast.insert(hvs);
  277. end;
  278. end;
  279. end;
  280. {$ifdef fixLeaksOnError}
  281. if PStringContainer(strContStack.pop) <> sc then
  282. writeln('problem with strContStack in pdecl (1)');
  283. {$endif fixLeaksOnError}
  284. sc.free;
  285. akttokenpos:=storetokenpos;
  286. end;
  287. { set the new mangled name }
  288. if not is_procvar then
  289. tprocdef(aktprocdef).setmangledname(hs2);
  290. until not try_to_consume(_SEMICOLON);
  291. dec(testcurobject);
  292. consume(_RKLAMMER);
  293. end;
  294. procedure parse_proc_head(options:tproctypeoption);
  295. var orgsp,sp:stringid;
  296. pd:tprocdef;
  297. paramoffset:longint;
  298. sym:tsym;
  299. hs:string;
  300. doinsert : boolean;
  301. st : tsymtable;
  302. srsymtable : tsymtable;
  303. overloaded_level:word;
  304. storepos,procstartfilepos : tfileposinfo;
  305. i: longint;
  306. begin
  307. { Save the position where this procedure really starts and set col to 1 which
  308. looks nicer }
  309. procstartfilepos:=akttokenpos;
  310. { procstartfilepos.column:=1; I do not agree here !!
  311. lets keep excat position PM }
  312. if (options=potype_operator) then
  313. begin
  314. sp:=overloaded_names[optoken];
  315. orgsp:=sp;
  316. end
  317. else
  318. begin
  319. sp:=pattern;
  320. orgsp:=orgpattern;
  321. consume(_ID);
  322. end;
  323. { examine interface map: function/procedure iname.functionname=locfuncname }
  324. if parse_only and
  325. assigned(procinfo^._class) and
  326. assigned(procinfo^._class.implementedinterfaces) and
  327. (procinfo^._class.implementedinterfaces.count>0) and
  328. try_to_consume(_POINT) then
  329. begin
  330. storepos:=akttokenpos;
  331. akttokenpos:=procstartfilepos;
  332. { get interface syms}
  333. searchsym(sp,sym,srsymtable);
  334. if not assigned(sym) then
  335. begin
  336. identifier_not_found(orgsp);
  337. sym:=generrorsym;
  338. end;
  339. akttokenpos:=storepos;
  340. { load proc name }
  341. if sym.typ=typesym then
  342. i:=procinfo^._class.implementedinterfaces.searchintf(ttypesym(sym).restype.def);
  343. { qualifier is interface name? }
  344. if (sym.typ<>typesym) or (ttypesym(sym).restype.def.deftype<>objectdef) or
  345. (i=-1) then
  346. begin
  347. Message(parser_e_interface_id_expected);
  348. aktprocsym:=nil;
  349. end
  350. else
  351. begin
  352. aktprocsym:=tprocsym(procinfo^._class.implementedinterfaces.interfaces(i).symtable.search(sp));
  353. if not(assigned(aktprocsym)) then
  354. Message(parser_e_methode_id_expected);
  355. end;
  356. consume(_ID);
  357. consume(_EQUAL);
  358. if (token=_ID) and assigned(aktprocsym) then
  359. procinfo^._class.implementedinterfaces.addmappings(i,sp,pattern);
  360. consume(_ID);
  361. exit;
  362. end;
  363. { method ? }
  364. if not(parse_only) and
  365. (lexlevel=normal_function_level) and
  366. try_to_consume(_POINT) then
  367. begin
  368. { search for object name }
  369. storepos:=akttokenpos;
  370. akttokenpos:=procstartfilepos;
  371. searchsym(sp,sym,srsymtable);
  372. if not assigned(sym) then
  373. begin
  374. identifier_not_found(orgsp);
  375. sym:=generrorsym;
  376. end;
  377. akttokenpos:=storepos;
  378. { consume proc name }
  379. sp:=pattern;
  380. orgsp:=orgpattern;
  381. procstartfilepos:=akttokenpos;
  382. consume(_ID);
  383. { qualifier is class name ? }
  384. if (sym.typ<>typesym) or
  385. (ttypesym(sym).restype.def.deftype<>objectdef) then
  386. begin
  387. Message(parser_e_class_id_expected);
  388. aktprocsym:=nil;
  389. end
  390. else
  391. begin
  392. { used to allow private syms to be seen }
  393. aktobjectdef:=tobjectdef(ttypesym(sym).restype.def);
  394. procinfo^._class:=tobjectdef(ttypesym(sym).restype.def);
  395. aktprocsym:=tprocsym(procinfo^._class.symtable.search(sp));
  396. {The procedure has been found. So it is
  397. a global one. Set the flags to mark this.}
  398. procinfo^.flags:=procinfo^.flags or pi_is_global;
  399. aktobjectdef:=nil;
  400. { we solve this below }
  401. if not(assigned(aktprocsym)) then
  402. Message(parser_e_methode_id_expected);
  403. end;
  404. end
  405. else
  406. begin
  407. { check for constructor/destructor which is not allowed here }
  408. if (not parse_only) and
  409. (options in [potype_constructor,potype_destructor]) then
  410. Message(parser_e_constructors_always_objects);
  411. akttokenpos:=procstartfilepos;
  412. aktprocsym:=tprocsym(symtablestack.search(sp));
  413. if not(parse_only) then
  414. begin
  415. {The procedure we prepare for is in the implementation
  416. part of the unit we compile. It is also possible that we
  417. are compiling a program, which is also some kind of
  418. implementaion part.
  419. We need to find out if the procedure is global. If it is
  420. global, it is in the global symtable.}
  421. if not assigned(aktprocsym) and
  422. (symtablestack.symtabletype=staticsymtable) and
  423. assigned(symtablestack.next) and
  424. (symtablestack.next.unitid=0) then
  425. begin
  426. {Search the procedure in the global symtable.}
  427. aktprocsym:=tprocsym(symtablestack.next.search(sp));
  428. if assigned(aktprocsym) then
  429. begin
  430. {Check if it is a procedure.}
  431. if aktprocsym.typ<>procsym then
  432. DuplicateSym(aktprocsym);
  433. {The procedure has been found. So it is
  434. a global one. Set the flags to mark this.}
  435. procinfo^.flags:=procinfo^.flags or pi_is_global;
  436. end;
  437. end;
  438. end;
  439. end;
  440. { Create the mangledname }
  441. {$ifndef UseNiceNames}
  442. if assigned(procinfo^._class) then
  443. begin
  444. if (pos('_$$_',procprefix)=0) then
  445. hs:=procprefix+'_$$_'+upper(procinfo^._class.objname^)+'_$$_'+sp
  446. else
  447. hs:=procprefix+'_$'+sp;
  448. end
  449. else
  450. begin
  451. if lexlevel=normal_function_level then
  452. hs:=procprefix+'_'+sp
  453. else
  454. hs:=procprefix+'_$'+sp;
  455. end;
  456. {$else UseNiceNames}
  457. if assigned(procinfo^._class) then
  458. begin
  459. if (pos('_5Class_',procprefix)=0) then
  460. hs:=procprefix+'_5Class_'+procinfo^._class.name^+'_'+tostr(length(sp))+sp
  461. else
  462. hs:=procprefix+'_'+tostr(length(sp))+sp;
  463. end
  464. else
  465. begin
  466. if lexlevel=normal_function_level then
  467. hs:=procprefix+'_'+tostr(length(sp))+sp
  468. else
  469. hs:=lowercase(procprefix)+'_'+tostr(length(sp))+sp;
  470. end;
  471. {$endif UseNiceNames}
  472. doinsert:=true;
  473. if assigned(aktprocsym) then
  474. begin
  475. { Check if overloaded is a procsym }
  476. if aktprocsym.typ<>procsym then
  477. begin
  478. { when the other symbol is a unit symbol then hide the unit
  479. symbol. Only in tp mode because it's bad programming }
  480. if (m_tp in aktmodeswitches) and
  481. (aktprocsym.typ=unitsym) then
  482. begin
  483. aktprocsym.owner.rename(aktprocsym.name,'hidden'+aktprocsym.name);
  484. end
  485. else
  486. begin
  487. { we use a different error message for tp7 so it looks more compatible }
  488. if (m_fpc in aktmodeswitches) then
  489. Message1(parser_e_overloaded_no_procedure,aktprocsym.realname)
  490. else
  491. DuplicateSym(aktprocsym);
  492. { don't reinsert as that will generated another error }
  493. doinsert:=false;
  494. end;
  495. { generate a new aktprocsym }
  496. aktprocsym:=nil;
  497. end;
  498. end;
  499. { test again if assigned, it can be reset to recover }
  500. if not assigned(aktprocsym) then
  501. begin
  502. { create a new procsym and set the real filepos }
  503. akttokenpos:=procstartfilepos;
  504. { for operator we have only one definition for each overloaded
  505. operation }
  506. if (options=potype_operator) then
  507. begin
  508. { create the procsym with saving the original case }
  509. aktprocsym:=tprocsym.create('$'+sp);
  510. { the only problem is that nextoverloaded might not be in a unit
  511. known for the unit itself }
  512. { not anymore PM }
  513. if assigned(overloaded_operators[optoken]) then
  514. aktprocsym.definition:=overloaded_operators[optoken].definition;
  515. overloaded_operators[optoken]:=aktprocsym;
  516. end
  517. else
  518. aktprocsym:=tprocsym.create(orgsp);
  519. if doinsert then
  520. symtablestack.insert(aktprocsym);
  521. end;
  522. st:=symtablestack;
  523. pd:=tprocdef.create;
  524. pd.symtablelevel:=symtablestack.symtablelevel;
  525. if assigned(procinfo^._class) then
  526. pd._class := procinfo^._class;
  527. { set the options from the caller (podestructor or poconstructor) }
  528. pd.proctypeoption:=options;
  529. { calculate the offset of the parameters }
  530. paramoffset:=8;
  531. { calculate frame pointer offset }
  532. if lexlevel>normal_function_level then
  533. begin
  534. procinfo^.framepointer_offset:=paramoffset;
  535. inc(paramoffset,target_info.size_of_pointer);
  536. { this is needed to get correct framepointer push for local
  537. forward functions !! }
  538. pd.parast.symtablelevel:=lexlevel;
  539. end;
  540. if assigned (procinfo^._Class) and
  541. is_object(procinfo^._Class) and
  542. (pd.proctypeoption in [potype_constructor,potype_destructor]) then
  543. inc(paramoffset,target_info.size_of_pointer);
  544. { self pointer offset }
  545. { self isn't pushed in nested procedure of methods }
  546. if assigned(procinfo^._class) and (lexlevel=normal_function_level) then
  547. begin
  548. procinfo^.selfpointer_offset:=paramoffset;
  549. if assigned(aktprocsym.definition) and
  550. not(po_containsself in aktprocsym.definition.procoptions) then
  551. inc(paramoffset,target_info.size_of_pointer);
  552. end;
  553. { con/-destructor flag ? }
  554. if assigned (procinfo^._Class) and
  555. is_class(procinfo^._class) and
  556. (pd.proctypeoption in [potype_destructor,potype_constructor]) then
  557. inc(paramoffset,target_info.size_of_pointer);
  558. procinfo^.para_offset:=paramoffset;
  559. pd.parast.datasize:=0;
  560. pd.nextoverloaded:=aktprocsym.definition;
  561. aktprocsym.definition:=pd;
  562. { this is probably obsolete now PM }
  563. aktprocsym.definition.fileinfo:=procstartfilepos;
  564. aktprocsym.definition.setmangledname(hs);
  565. aktprocsym.definition.procsym:=aktprocsym;
  566. if not parse_only then
  567. begin
  568. overloaded_level:=0;
  569. { we need another procprefix !!! }
  570. { count, but only those in the same unit !!}
  571. while assigned(pd) and
  572. (pd.owner.symtabletype in [globalsymtable,staticsymtable]) do
  573. begin
  574. { only count already implemented functions }
  575. if not(pd.forwarddef) then
  576. inc(overloaded_level);
  577. pd:=pd.nextoverloaded;
  578. end;
  579. if overloaded_level>0 then
  580. procprefix:=hs+'$'+tostr(overloaded_level)+'$'
  581. else
  582. procprefix:=hs+'$';
  583. end;
  584. { this must also be inserted in the right symtable !! PM }
  585. { otherwise we get subbtle problems with
  586. definitions of args defs in staticsymtable for
  587. implementation of a global method }
  588. if token=_LKLAMMER then
  589. parameter_dec(aktprocsym.definition);
  590. { so we only restore the symtable now }
  591. symtablestack:=st;
  592. if (options=potype_operator) then
  593. overloaded_operators[optoken]:=aktprocsym;
  594. end;
  595. procedure parse_proc_dec;
  596. var
  597. hs : string;
  598. isclassmethod : boolean;
  599. begin
  600. inc(lexlevel);
  601. { read class method }
  602. if token=_CLASS then
  603. begin
  604. consume(_CLASS);
  605. isclassmethod:=true;
  606. end
  607. else
  608. isclassmethod:=false;
  609. case token of
  610. _FUNCTION : begin
  611. consume(_FUNCTION);
  612. parse_proc_head(potype_none);
  613. if token<>_COLON then
  614. begin
  615. if not(is_interface(aktprocsym.definition._class)) and
  616. not(aktprocsym.definition.forwarddef) or
  617. (m_repeat_forward in aktmodeswitches) then
  618. begin
  619. consume(_COLON);
  620. consume_all_until(_SEMICOLON);
  621. end;
  622. end
  623. else
  624. begin
  625. consume(_COLON);
  626. inc(testcurobject);
  627. single_type(aktprocsym.definition.rettype,hs,false);
  628. aktprocsym.definition.test_if_fpu_result;
  629. dec(testcurobject);
  630. end;
  631. end;
  632. _PROCEDURE : begin
  633. consume(_PROCEDURE);
  634. parse_proc_head(potype_none);
  635. aktprocsym.definition.rettype:=voidtype;
  636. end;
  637. _CONSTRUCTOR : begin
  638. consume(_CONSTRUCTOR);
  639. parse_proc_head(potype_constructor);
  640. if assigned(procinfo^._class) and
  641. is_class(procinfo^._class) then
  642. begin
  643. { CLASS constructors return the created instance }
  644. aktprocsym.definition.rettype.setdef(procinfo^._class);
  645. end
  646. else
  647. begin
  648. { OBJECT constructors return a boolean }
  649. aktprocsym.definition.rettype:=booltype;
  650. end;
  651. end;
  652. _DESTRUCTOR : begin
  653. consume(_DESTRUCTOR);
  654. parse_proc_head(potype_destructor);
  655. aktprocsym.definition.rettype:=voidtype;
  656. end;
  657. _OPERATOR : begin
  658. if lexlevel>normal_function_level then
  659. Message(parser_e_no_local_operator);
  660. consume(_OPERATOR);
  661. if (token in [first_overloaded..last_overloaded]) then
  662. begin
  663. procinfo^.flags:=procinfo^.flags or pi_operator;
  664. optoken:=token;
  665. end
  666. else
  667. begin
  668. Message(parser_e_overload_operator_failed);
  669. { Use the dummy NOTOKEN that is also declared
  670. for the overloaded_operator[] }
  671. optoken:=NOTOKEN;
  672. end;
  673. consume(Token);
  674. parse_proc_head(potype_operator);
  675. if token<>_ID then
  676. begin
  677. otsym:=nil;
  678. if not(m_result in aktmodeswitches) then
  679. consume(_ID);
  680. end
  681. else
  682. begin
  683. otsym:=tvarsym.create(pattern,voidtype);
  684. consume(_ID);
  685. end;
  686. if not try_to_consume(_COLON) then
  687. begin
  688. consume(_COLON);
  689. aktprocsym.definition.rettype:=generrortype;
  690. consume_all_until(_SEMICOLON);
  691. end
  692. else
  693. begin
  694. single_type(aktprocsym.definition.rettype,hs,false);
  695. aktprocsym.definition.test_if_fpu_result;
  696. if (optoken in [_EQUAL,_GT,_LT,_GTE,_LTE]) and
  697. ((aktprocsym.definition.rettype.def.deftype<>
  698. orddef) or (torddef(aktprocsym.definition.
  699. rettype.def).typ<>bool8bit)) then
  700. Message(parser_e_comparative_operator_return_boolean);
  701. if assigned(otsym) then
  702. otsym.vartype.def:=aktprocsym.definition.rettype.def;
  703. { We need to add the return type in the mangledname
  704. to allow overloading with just different results !! (PM) }
  705. aktprocsym.definition.setmangledname(
  706. aktprocsym.definition.mangledname+'$$'+hs);
  707. if (optoken=_ASSIGNMENT) and
  708. is_equal(aktprocsym.definition.rettype.def,
  709. tvarsym(aktprocsym.definition.parast.symindex.first).vartype.def) then
  710. message(parser_e_no_such_assignment)
  711. else if not isoperatoracceptable(aktprocsym.definition,optoken) then
  712. Message(parser_e_overload_impossible);
  713. end;
  714. end;
  715. end;
  716. if isclassmethod and
  717. assigned(aktprocsym) then
  718. include(aktprocsym.definition.procoptions,po_classmethod);
  719. { support procedure proc;stdcall export; in Delphi mode only }
  720. if not((m_delphi in aktmodeswitches) and
  721. is_proc_directive(token)) then
  722. consume(_SEMICOLON);
  723. dec(lexlevel);
  724. end;
  725. {****************************************************************************
  726. Procedure directive handlers
  727. ****************************************************************************}
  728. procedure pd_far;
  729. begin
  730. Message(parser_w_proc_far_ignored);
  731. end;
  732. procedure pd_near;
  733. begin
  734. Message(parser_w_proc_near_ignored);
  735. end;
  736. procedure pd_export;
  737. begin
  738. if assigned(procinfo^._class) then
  739. Message(parser_e_methods_dont_be_export);
  740. if lexlevel<>normal_function_level then
  741. Message(parser_e_dont_nest_export);
  742. { only os/2 needs this }
  743. if target_info.target=target_i386_os2 then
  744. begin
  745. aktprocsym.definition.aliasnames.insert(aktprocsym.realname);
  746. procinfo^.exported:=true;
  747. if cs_link_deffile in aktglobalswitches then
  748. deffile.AddExport(aktprocsym.definition.mangledname);
  749. end;
  750. end;
  751. procedure pd_inline;
  752. begin
  753. if not(cs_support_inline in aktmoduleswitches) then
  754. Message(parser_e_proc_inline_not_supported);
  755. end;
  756. procedure pd_forward;
  757. begin
  758. aktprocsym.definition.forwarddef:=true;
  759. end;
  760. procedure pd_stdcall;
  761. begin
  762. end;
  763. procedure pd_safecall;
  764. begin
  765. end;
  766. procedure pd_alias;
  767. begin
  768. consume(_COLON);
  769. aktprocsym.definition.aliasnames.insert(get_stringconst);
  770. end;
  771. procedure pd_asmname;
  772. begin
  773. aktprocsym.definition.setmangledname(target_info.Cprefix+pattern);
  774. if token=_CCHAR then
  775. consume(_CCHAR)
  776. else
  777. consume(_CSTRING);
  778. { we don't need anything else }
  779. aktprocsym.definition.forwarddef:=false;
  780. end;
  781. procedure pd_intern;
  782. begin
  783. consume(_COLON);
  784. aktprocsym.definition.extnumber:=get_intconst;
  785. end;
  786. procedure pd_interrupt;
  787. begin
  788. {$ifndef i386}
  789. Message(parser_w_proc_interrupt_ignored);
  790. {$else i386}
  791. if lexlevel<>normal_function_level then
  792. Message(parser_e_dont_nest_interrupt);
  793. {$endif i386}
  794. end;
  795. procedure pd_system;
  796. begin
  797. aktprocsym.definition.setmangledname(aktprocsym.realname);
  798. end;
  799. procedure pd_abstract;
  800. begin
  801. if (po_virtualmethod in aktprocsym.definition.procoptions) then
  802. include(aktprocsym.definition.procoptions,po_abstractmethod)
  803. else
  804. Message(parser_e_only_virtual_methods_abstract);
  805. { the method is defined }
  806. aktprocsym.definition.forwarddef:=false;
  807. end;
  808. procedure pd_virtual;
  809. {$ifdef WITHDMT}
  810. var
  811. pt : tnode;
  812. {$endif WITHDMT}
  813. begin
  814. if (aktprocsym.definition.proctypeoption=potype_constructor) and
  815. is_object(aktprocsym.definition._class) then
  816. Message(parser_e_constructor_cannot_be_not_virtual);
  817. {$ifdef WITHDMT}
  818. if is_object(aktprocsym.definition._class) and
  819. (token<>_SEMICOLON) then
  820. begin
  821. { any type of parameter is allowed here! }
  822. pt:=comp_expr(true);
  823. if is_constintnode(pt) then
  824. begin
  825. include(aktprocsym.definition.procoptions,po_msgint);
  826. aktprocsym.definition.messageinf.i:=pt^.value;
  827. end
  828. else
  829. Message(parser_e_ill_msg_expr);
  830. disposetree(pt);
  831. end;
  832. {$endif WITHDMT}
  833. end;
  834. procedure pd_static;
  835. begin
  836. if (cs_static_keyword in aktmoduleswitches) then
  837. begin
  838. include(aktprocsym.symoptions,sp_static);
  839. include(aktprocsym.definition.procoptions,po_staticmethod);
  840. end;
  841. end;
  842. procedure pd_override;
  843. begin
  844. if not(is_class_or_interface(aktprocsym.definition._class)) then
  845. Message(parser_e_no_object_override);
  846. end;
  847. procedure pd_overload;
  848. begin
  849. end;
  850. procedure pd_message;
  851. var
  852. pt : tnode;
  853. begin
  854. { check parameter type }
  855. if not(po_containsself in aktprocsym.definition.procoptions) and
  856. ((aktprocsym.definition.minparacount<>1) or
  857. (aktprocsym.definition.maxparacount<>1) or
  858. (TParaItem(aktprocsym.definition.Para.first).paratyp<>vs_var)) then
  859. Message(parser_e_ill_msg_param);
  860. pt:=comp_expr(true);
  861. if pt.nodetype=stringconstn then
  862. begin
  863. include(aktprocsym.definition.procoptions,po_msgstr);
  864. aktprocsym.definition.messageinf.str:=strnew(tstringconstnode(pt).value_str);
  865. end
  866. else
  867. if is_constintnode(pt) then
  868. begin
  869. include(aktprocsym.definition.procoptions,po_msgint);
  870. aktprocsym.definition.messageinf.i:=tordconstnode(pt).value;
  871. end
  872. else
  873. Message(parser_e_ill_msg_expr);
  874. pt.free;
  875. end;
  876. procedure resetvaluepara(p:tnamedindexitem);
  877. begin
  878. if tsym(p).typ=varsym then
  879. with tvarsym(p) do
  880. if copy(name,1,3)='val' then
  881. aktprocsym.definition.parast.symsearch.rename(name,copy(name,4,length(name)));
  882. end;
  883. procedure pd_cdecl;
  884. begin
  885. if aktprocsym.definition.deftype<>procvardef then
  886. aktprocsym.definition.setmangledname(target_info.Cprefix+aktprocsym.realname);
  887. { do not copy on local !! }
  888. if (aktprocsym.definition.deftype=procdef) and
  889. assigned(aktprocsym.definition.parast) then
  890. aktprocsym.definition.parast.foreach_static({$ifdef FPCPROCVAR}@{$endif}resetvaluepara);
  891. end;
  892. procedure pd_cppdecl;
  893. begin
  894. if aktprocsym.definition.deftype<>procvardef then
  895. aktprocsym.definition.setmangledname(
  896. target_info.Cprefix+aktprocsym.definition.cplusplusmangledname);
  897. { do not copy on local !! }
  898. if (aktprocsym.definition.deftype=procdef) and
  899. assigned(aktprocsym.definition.parast) then
  900. aktprocsym.definition.parast.foreach_static({$ifdef FPCPROCVAR}@{$endif}resetvaluepara);
  901. end;
  902. procedure pd_pascal;
  903. var st,parast : tsymtable;
  904. lastps,ps : tsym;
  905. begin
  906. st:=tparasymtable.create;
  907. parast:=aktprocsym.definition.parast;
  908. lastps:=nil;
  909. while assigned(parast.symindex.first) and (lastps<>tsym(parast.symindex.first)) do
  910. begin
  911. ps:=tsym(parast.symindex.first);
  912. while assigned(ps.indexnext) and (tsym(ps.indexnext)<>lastps) do
  913. ps:=tsym(ps.indexnext);
  914. ps.owner:=st;
  915. { recalculate the corrected offset }
  916. { the really_insert_in_data procedure
  917. for parasymtable should only calculateoffset PM }
  918. tstoredsym(ps).insert_in_data;
  919. { reset the owner correctly }
  920. ps.owner:=parast;
  921. lastps:=ps;
  922. end;
  923. end;
  924. procedure pd_register;
  925. begin
  926. Message1(parser_w_proc_directive_ignored,'REGISTER');
  927. end;
  928. procedure pd_reintroduce;
  929. begin
  930. Message1(parser_w_proc_directive_ignored,'REINTRODUCE');
  931. end;
  932. procedure pd_syscall;
  933. begin
  934. aktprocsym.definition.forwarddef:=false;
  935. aktprocsym.definition.extnumber:=get_intconst;
  936. end;
  937. procedure pd_external;
  938. {
  939. If import_dll=nil the procedure is assumed to be in another
  940. object file. In that object file it should have the name to
  941. which import_name is pointing to. Otherwise, the procedure is
  942. assumed to be in the DLL to which import_dll is pointing to. In
  943. that case either import_nr<>0 or import_name<>nil is true, so
  944. the procedure is either imported by number or by name. (DM)
  945. }
  946. var
  947. import_dll,
  948. import_name : string;
  949. import_nr : word;
  950. begin
  951. aktprocsym.definition.forwarddef:=false;
  952. { forbid local external procedures }
  953. if lexlevel>normal_function_level then
  954. Message(parser_e_no_local_external);
  955. { If the procedure should be imported from a DLL, a constant string follows.
  956. This isn't really correct, an contant string expression follows
  957. so we check if an semicolon follows, else a string constant have to
  958. follow (FK) }
  959. import_nr:=0;
  960. import_name:='';
  961. if not(token=_SEMICOLON) and not(idtoken=_NAME) then
  962. begin
  963. import_dll:=get_stringconst;
  964. if (idtoken=_NAME) then
  965. begin
  966. consume(_NAME);
  967. import_name:=get_stringconst;
  968. end;
  969. if (idtoken=_INDEX) then
  970. begin
  971. {After the word index follows the index number in the DLL.}
  972. consume(_INDEX);
  973. import_nr:=get_intconst;
  974. end;
  975. if (import_nr=0) and (import_name='') then
  976. {if (aktprocsym.definition.options and pocdecl)<>0 then
  977. import_name:=aktprocsym.definition.mangledname
  978. else
  979. Message(parser_w_empty_import_name);}
  980. { this should work both for win32 and Linux !! PM }
  981. import_name:=aktprocsym.realname;
  982. if not(current_module.uses_imports) then
  983. begin
  984. current_module.uses_imports:=true;
  985. importlib.preparelib(current_module.modulename^);
  986. end;
  987. if not(m_repeat_forward in aktmodeswitches) then
  988. begin
  989. { we can only have one overloaded here ! }
  990. if assigned(aktprocsym.definition.nextoverloaded) then
  991. importlib.importprocedure(aktprocsym.definition.nextoverloaded.mangledname,
  992. import_dll,import_nr,import_name)
  993. else
  994. importlib.importprocedure(aktprocsym.mangledname,import_dll,import_nr,import_name);
  995. end
  996. else
  997. importlib.importprocedure(aktprocsym.mangledname,import_dll,import_nr,import_name);
  998. end
  999. else
  1000. begin
  1001. if (idtoken=_NAME) then
  1002. begin
  1003. consume(_NAME);
  1004. import_name:=get_stringconst;
  1005. aktprocsym.definition.setmangledname(import_name);
  1006. if target_info.DllScanSupported then
  1007. current_module.externals.insert(tExternalsItem.create(import_name));
  1008. end
  1009. else
  1010. begin
  1011. { external shouldn't override the cdecl/system name }
  1012. if not (pocall_clearstack in aktprocsym.definition.proccalloptions) then
  1013. begin
  1014. aktprocsym.definition.setmangledname(aktprocsym.realname);
  1015. if target_info.DllScanSupported then
  1016. current_module.externals.insert(tExternalsItem.create(aktprocsym.realname));
  1017. end;
  1018. end;
  1019. end;
  1020. end;
  1021. type
  1022. pd_handler=procedure;
  1023. proc_dir_rec=record
  1024. idtok : ttoken;
  1025. pd_flags : longint;
  1026. handler : pd_handler;
  1027. pocall : tproccalloptions;
  1028. pooption : tprocoptions;
  1029. mutexclpocall : tproccalloptions;
  1030. mutexclpotype : tproctypeoptions;
  1031. mutexclpo : tprocoptions;
  1032. end;
  1033. const
  1034. {Should contain the number of procedure directives we support.}
  1035. num_proc_directives=34;
  1036. proc_direcdata:array[1..num_proc_directives] of proc_dir_rec=
  1037. (
  1038. (
  1039. idtok:_ABSTRACT;
  1040. pd_flags : pd_interface+pd_object+pd_notobjintf;
  1041. handler : {$ifdef FPCPROCVAR}@{$endif}pd_abstract;
  1042. pocall : [];
  1043. pooption : [po_abstractmethod];
  1044. mutexclpocall : [pocall_internproc,pocall_inline];
  1045. mutexclpotype : [potype_constructor,potype_destructor];
  1046. mutexclpo : [po_exports,po_interrupt,po_external]
  1047. ),(
  1048. idtok:_ALIAS;
  1049. pd_flags : pd_implemen+pd_body+pd_notobjintf;
  1050. handler : {$ifdef FPCPROCVAR}@{$endif}pd_alias;
  1051. pocall : [];
  1052. pooption : [];
  1053. mutexclpocall : [pocall_inline];
  1054. mutexclpotype : [];
  1055. mutexclpo : [po_external]
  1056. ),(
  1057. idtok:_ASMNAME;
  1058. pd_flags : pd_interface+pd_implemen+pd_notobjintf;
  1059. handler : {$ifdef FPCPROCVAR}@{$endif}pd_asmname;
  1060. pocall : [pocall_cdecl,pocall_clearstack];
  1061. pooption : [po_external];
  1062. mutexclpocall : [pocall_internproc];
  1063. mutexclpotype : [];
  1064. mutexclpo : [po_external]
  1065. ),(
  1066. idtok:_ASSEMBLER;
  1067. pd_flags : pd_implemen+pd_body+pd_notobjintf;
  1068. handler : nil;
  1069. pocall : [];
  1070. pooption : [po_assembler];
  1071. mutexclpocall : [];
  1072. mutexclpotype : [];
  1073. mutexclpo : [po_external]
  1074. ),(
  1075. idtok:_CDECL;
  1076. pd_flags : pd_interface+pd_implemen+pd_body+pd_procvar;
  1077. handler : {$ifdef FPCPROCVAR}@{$endif}pd_cdecl;
  1078. pocall : [pocall_cdecl,pocall_clearstack];
  1079. pooption : [po_savestdregs];
  1080. mutexclpocall : [pocall_cppdecl,pocall_internproc,
  1081. pocall_leftright,pocall_inline];
  1082. mutexclpotype : [];
  1083. mutexclpo : [po_assembler,po_external]
  1084. ),(
  1085. idtok:_DYNAMIC;
  1086. pd_flags : pd_interface+pd_object+pd_notobjintf;
  1087. handler : {$ifdef FPCPROCVAR}@{$endif}pd_virtual;
  1088. pocall : [];
  1089. pooption : [po_virtualmethod];
  1090. mutexclpocall : [pocall_internproc,pocall_inline];
  1091. mutexclpotype : [];
  1092. mutexclpo : [po_exports,po_interrupt,po_external]
  1093. ),(
  1094. idtok:_EXPORT;
  1095. pd_flags : pd_body+pd_global+pd_interface+pd_implemen{??}+pd_notobjintf;
  1096. handler : {$ifdef FPCPROCVAR}@{$endif}pd_export;
  1097. pocall : [];
  1098. pooption : [po_exports];
  1099. mutexclpocall : [pocall_internproc,pocall_inline];
  1100. mutexclpotype : [];
  1101. mutexclpo : [po_external,po_interrupt]
  1102. ),(
  1103. idtok:_EXTERNAL;
  1104. pd_flags : pd_implemen+pd_interface+pd_notobjintf;
  1105. handler : {$ifdef FPCPROCVAR}@{$endif}pd_external;
  1106. pocall : [];
  1107. pooption : [po_external];
  1108. mutexclpocall : [pocall_internproc,pocall_inline,pocall_palmossyscall];
  1109. mutexclpotype : [];
  1110. mutexclpo : [po_exports,po_interrupt,po_assembler]
  1111. ),(
  1112. idtok:_FAR;
  1113. pd_flags : pd_implemen+pd_body+pd_interface+pd_procvar+pd_notobjintf;
  1114. handler : {$ifdef FPCPROCVAR}@{$endif}pd_far;
  1115. pocall : [];
  1116. pooption : [];
  1117. mutexclpocall : [pocall_internproc,pocall_inline];
  1118. mutexclpotype : [];
  1119. mutexclpo : []
  1120. ),(
  1121. idtok:_FORWARD;
  1122. pd_flags : pd_implemen+pd_notobjintf;
  1123. handler : {$ifdef FPCPROCVAR}@{$endif}pd_forward;
  1124. pocall : [];
  1125. pooption : [];
  1126. mutexclpocall : [pocall_internproc,pocall_inline];
  1127. mutexclpotype : [];
  1128. mutexclpo : [po_external]
  1129. ),(
  1130. idtok:_INLINE;
  1131. pd_flags : pd_implemen+pd_body+pd_notobjintf;
  1132. handler : {$ifdef FPCPROCVAR}@{$endif}pd_inline;
  1133. pocall : [pocall_inline];
  1134. pooption : [];
  1135. mutexclpocall : [pocall_internproc];
  1136. mutexclpotype : [potype_constructor,potype_destructor];
  1137. mutexclpo : [po_exports,po_external,po_interrupt]
  1138. ),(
  1139. idtok:_INTERNCONST;
  1140. pd_flags : pd_implemen+pd_body+pd_notobjintf;
  1141. handler : {$ifdef FPCPROCVAR}@{$endif}pd_intern;
  1142. pocall : [pocall_internconst];
  1143. pooption : [];
  1144. mutexclpocall : [];
  1145. mutexclpotype : [potype_operator];
  1146. mutexclpo : []
  1147. ),(
  1148. idtok:_INTERNPROC;
  1149. pd_flags : pd_implemen+pd_notobjintf;
  1150. handler : {$ifdef FPCPROCVAR}@{$endif}pd_intern;
  1151. pocall : [pocall_internproc];
  1152. pooption : [];
  1153. mutexclpocall : [pocall_inline,pocall_clearstack,pocall_leftright,pocall_cdecl,pocall_cppdecl];
  1154. mutexclpotype : [potype_constructor,potype_destructor,potype_operator];
  1155. mutexclpo : [po_exports,po_external,po_interrupt,po_assembler,po_iocheck]
  1156. ),(
  1157. idtok:_INTERRUPT;
  1158. pd_flags : pd_implemen+pd_body+pd_notobjintf;
  1159. handler : {$ifdef FPCPROCVAR}@{$endif}pd_interrupt;
  1160. pocall : [];
  1161. pooption : [po_interrupt];
  1162. mutexclpocall : [pocall_internproc,pocall_cdecl,pocall_cppdecl,
  1163. pocall_clearstack,pocall_leftright,pocall_inline];
  1164. mutexclpotype : [potype_constructor,potype_destructor,potype_operator];
  1165. mutexclpo : [po_external]
  1166. ),(
  1167. idtok:_IOCHECK;
  1168. pd_flags : pd_implemen+pd_body+pd_notobjintf;
  1169. handler : nil;
  1170. pocall : [];
  1171. pooption : [po_iocheck];
  1172. mutexclpocall : [pocall_internproc];
  1173. mutexclpotype : [];
  1174. mutexclpo : [po_external]
  1175. ),(
  1176. idtok:_MESSAGE;
  1177. pd_flags : pd_interface+pd_object+pd_notobjintf;
  1178. handler : {$ifdef FPCPROCVAR}@{$endif}pd_message;
  1179. pocall : [];
  1180. pooption : []; { can be po_msgstr or po_msgint }
  1181. mutexclpocall : [pocall_inline,pocall_internproc];
  1182. mutexclpotype : [potype_constructor,potype_destructor,potype_operator];
  1183. mutexclpo : [po_interrupt,po_external]
  1184. ),(
  1185. idtok:_NEAR;
  1186. pd_flags : pd_implemen+pd_body+pd_procvar+pd_notobjintf;
  1187. handler : {$ifdef FPCPROCVAR}@{$endif}pd_near;
  1188. pocall : [];
  1189. pooption : [];
  1190. mutexclpocall : [pocall_internproc];
  1191. mutexclpotype : [];
  1192. mutexclpo : []
  1193. ),(
  1194. idtok:_OVERLOAD;
  1195. pd_flags : pd_implemen+pd_interface+pd_body;
  1196. handler : {$ifdef FPCPROCVAR}@{$endif}pd_overload;
  1197. pocall : [];
  1198. pooption : [po_overload];
  1199. mutexclpocall : [pocall_internproc];
  1200. mutexclpotype : [];
  1201. mutexclpo : []
  1202. ),(
  1203. idtok:_OVERRIDE;
  1204. pd_flags : pd_interface+pd_object+pd_notobjintf;
  1205. handler : {$ifdef FPCPROCVAR}@{$endif}pd_override;
  1206. pocall : [];
  1207. pooption : [po_overridingmethod,po_virtualmethod];
  1208. mutexclpocall : [pocall_inline,pocall_internproc];
  1209. mutexclpotype : [];
  1210. mutexclpo : [po_exports,po_external,po_interrupt]
  1211. ),(
  1212. idtok:_PASCAL;
  1213. pd_flags : pd_interface+pd_implemen+pd_body+pd_procvar;
  1214. handler : {$ifdef FPCPROCVAR}@{$endif}pd_pascal;
  1215. pocall : [pocall_leftright];
  1216. pooption : [];
  1217. mutexclpocall : [pocall_internproc,pocall_cdecl,pocall_cppdecl,
  1218. pocall_clearstack,pocall_leftright,pocall_inline,
  1219. pocall_safecall];
  1220. mutexclpotype : [];
  1221. mutexclpo : [po_external]
  1222. ),(
  1223. idtok:_POPSTACK;
  1224. pd_flags : pd_interface+pd_implemen+pd_body+pd_procvar;
  1225. handler : nil;
  1226. pocall : [pocall_clearstack];
  1227. pooption : [];
  1228. mutexclpocall : [pocall_inline,pocall_internproc];
  1229. mutexclpotype : [];
  1230. mutexclpo : [po_assembler,po_external]
  1231. ),(
  1232. idtok:_PUBLIC;
  1233. pd_flags : pd_implemen+pd_body+pd_global+pd_notobject+pd_notobjintf;
  1234. handler : nil;
  1235. pocall : [];
  1236. pooption : [];
  1237. mutexclpocall : [pocall_internproc,pocall_inline];
  1238. mutexclpotype : [];
  1239. mutexclpo : [po_external]
  1240. ),(
  1241. idtok:_REGISTER;
  1242. pd_flags : pd_interface+pd_implemen+pd_body+pd_procvar;
  1243. handler : {$ifdef FPCPROCVAR}@{$endif}pd_register;
  1244. pocall : [pocall_register];
  1245. pooption : [];
  1246. mutexclpocall : [pocall_leftright,pocall_cdecl,pocall_internproc,pocall_cppdecl];
  1247. mutexclpotype : [];
  1248. mutexclpo : [po_external]
  1249. ),(
  1250. idtok:_REINTRODUCE;
  1251. pd_flags : pd_interface+pd_object;
  1252. handler : {$ifdef FPCPROCVAR}@{$endif}pd_reintroduce;
  1253. pocall : [];
  1254. pooption : [];
  1255. mutexclpocall : [];
  1256. mutexclpotype : [];
  1257. mutexclpo : []
  1258. ),(
  1259. idtok:_SAFECALL;
  1260. pd_flags : pd_interface+pd_implemen+pd_body+pd_procvar;
  1261. handler : {$ifdef FPCPROCVAR}@{$endif}pd_safecall;
  1262. pocall : [pocall_safecall];
  1263. pooption : [po_savestdregs];
  1264. mutexclpocall : [pocall_leftright,pocall_cdecl,pocall_cppdecl,
  1265. pocall_internproc,pocall_inline];
  1266. mutexclpotype : [];
  1267. mutexclpo : [po_external]
  1268. ),(
  1269. idtok:_SAVEREGISTERS;
  1270. pd_flags : pd_interface+pd_implemen+pd_body+pd_procvar+pd_notobjintf;
  1271. handler : nil;
  1272. pocall : [];
  1273. pooption : [po_saveregisters];
  1274. mutexclpocall : [pocall_internproc];
  1275. mutexclpotype : [];
  1276. mutexclpo : [po_external]
  1277. ),(
  1278. idtok:_STATIC;
  1279. pd_flags : pd_interface+pd_object+pd_notobjintf;
  1280. handler : {$ifdef FPCPROCVAR}@{$endif}pd_static;
  1281. pocall : [];
  1282. pooption : [po_staticmethod];
  1283. mutexclpocall : [pocall_inline,pocall_internproc];
  1284. mutexclpotype : [potype_constructor,potype_destructor];
  1285. mutexclpo : [po_external,po_interrupt,po_exports]
  1286. ),(
  1287. idtok:_STDCALL;
  1288. pd_flags : pd_interface+pd_implemen+pd_body+pd_procvar;
  1289. handler : {$ifdef FPCPROCVAR}@{$endif}pd_stdcall;
  1290. pocall : [pocall_stdcall];
  1291. pooption : [po_savestdregs];
  1292. mutexclpocall : [pocall_leftright,pocall_cdecl,pocall_cppdecl,
  1293. pocall_inline,pocall_internproc,pocall_safecall];
  1294. mutexclpotype : [];
  1295. mutexclpo : [po_external]
  1296. ),(
  1297. idtok:_SYSCALL;
  1298. pd_flags : pd_interface+pd_notobjintf;
  1299. handler : {$ifdef FPCPROCVAR}@{$endif}pd_syscall;
  1300. pocall : [pocall_palmossyscall];
  1301. pooption : [];
  1302. mutexclpocall : [pocall_cdecl,pocall_cppdecl,pocall_inline,
  1303. pocall_internproc,pocall_leftright];
  1304. mutexclpotype : [];
  1305. mutexclpo : [po_external,po_assembler,po_interrupt,po_exports]
  1306. ),(
  1307. idtok:_SYSTEM;
  1308. pd_flags : pd_implemen+pd_notobjintf;
  1309. handler : {$ifdef FPCPROCVAR}@{$endif}pd_system;
  1310. pocall : [pocall_clearstack];
  1311. pooption : [];
  1312. mutexclpocall : [pocall_leftright,pocall_inline,pocall_cdecl,
  1313. pocall_internproc,pocall_cppdecl];
  1314. mutexclpotype : [];
  1315. mutexclpo : [po_external,po_assembler,po_interrupt]
  1316. ),(
  1317. idtok:_VIRTUAL;
  1318. pd_flags : pd_interface+pd_object+pd_notobjintf;
  1319. handler : {$ifdef FPCPROCVAR}@{$endif}pd_virtual;
  1320. pocall : [];
  1321. pooption : [po_virtualmethod];
  1322. mutexclpocall : [pocall_inline,pocall_internproc];
  1323. mutexclpotype : [];
  1324. mutexclpo : [po_external,po_interrupt,po_exports]
  1325. ),(
  1326. idtok:_CPPDECL;
  1327. pd_flags : pd_interface+pd_implemen+pd_body+pd_procvar;
  1328. handler : {$ifdef FPCPROCVAR}@{$endif}pd_cppdecl;
  1329. pocall : [pocall_cppdecl,pocall_clearstack];
  1330. pooption : [po_savestdregs];
  1331. mutexclpocall : [pocall_cdecl,pocall_internproc,pocall_leftright,pocall_inline];
  1332. mutexclpotype : [];
  1333. mutexclpo : [po_assembler,po_external]
  1334. ),(
  1335. idtok:_VARARGS;
  1336. pd_flags : pd_interface+pd_implemen+pd_procvar;
  1337. handler : nil;
  1338. pocall : [];
  1339. pooption : [po_varargs];
  1340. mutexclpocall : [pocall_internproc,pocall_stdcall,pocall_register,
  1341. pocall_leftright,pocall_inline];
  1342. mutexclpotype : [];
  1343. mutexclpo : [po_assembler,po_interrupt]
  1344. ),(
  1345. idtok:_COMPILERPROC;
  1346. pd_flags : pd_interface+pd_implemen+pd_body+pd_notobjintf;
  1347. handler : nil;
  1348. pocall : [pocall_compilerproc];
  1349. pooption : [];
  1350. mutexclpocall : [];
  1351. mutexclpotype : [];
  1352. mutexclpo : [po_interrupt]
  1353. )
  1354. );
  1355. function is_proc_directive(tok:ttoken):boolean;
  1356. var
  1357. i : longint;
  1358. begin
  1359. is_proc_directive:=false;
  1360. for i:=1 to num_proc_directives do
  1361. if proc_direcdata[i].idtok=idtoken then
  1362. begin
  1363. is_proc_directive:=true;
  1364. exit;
  1365. end;
  1366. end;
  1367. function parse_proc_direc(var pdflags:word):boolean;
  1368. {
  1369. Parse the procedure directive, returns true if a correct directive is found
  1370. }
  1371. var
  1372. p : longint;
  1373. found : boolean;
  1374. name : string;
  1375. begin
  1376. parse_proc_direc:=false;
  1377. name:=pattern;
  1378. found:=false;
  1379. { Hint directive? Then exit immediatly }
  1380. if (m_hintdirective in aktmodeswitches) then
  1381. begin
  1382. case idtoken of
  1383. _LIBRARY,
  1384. _PLATFORM,
  1385. _DEPRECATED :
  1386. exit;
  1387. end;
  1388. end;
  1389. { retrieve data for directive if found }
  1390. for p:=1 to num_proc_directives do
  1391. if proc_direcdata[p].idtok=idtoken then
  1392. begin
  1393. found:=true;
  1394. break;
  1395. end;
  1396. { Check if the procedure directive is known }
  1397. if not found then
  1398. begin
  1399. { parsing a procvar type the name can be any
  1400. next variable !! }
  1401. if (pdflags and (pd_procvar or pd_object))=0 then
  1402. Message1(parser_w_unknown_proc_directive_ignored,name);
  1403. exit;
  1404. end;
  1405. { static needs a special treatment }
  1406. if (idtoken=_STATIC) and not (cs_static_keyword in aktmoduleswitches) then
  1407. exit;
  1408. { Conflicts between directives ? }
  1409. if (aktprocsym.definition.proctypeoption in proc_direcdata[p].mutexclpotype) or
  1410. ((aktprocsym.definition.proccalloptions*proc_direcdata[p].mutexclpocall)<>[]) or
  1411. ((aktprocsym.definition.procoptions*proc_direcdata[p].mutexclpo)<>[]) then
  1412. begin
  1413. Message1(parser_e_proc_dir_conflict,name);
  1414. exit;
  1415. end;
  1416. if aktprocsym.definition.deftype=procdef then
  1417. begin
  1418. { Check if the directive is only for objects }
  1419. if ((proc_direcdata[p].pd_flags and pd_object)<>0) and
  1420. not assigned(aktprocsym.definition._class) then
  1421. exit;
  1422. { check if method and directive not for object public }
  1423. if ((proc_direcdata[p].pd_flags and pd_notobject)<>0) and
  1424. assigned(aktprocsym.definition._class) then
  1425. exit;
  1426. { check if method and directive not for interface }
  1427. if ((proc_direcdata[p].pd_flags and pd_notobjintf)<>0) and
  1428. is_interface(aktprocsym.definition._class) then
  1429. exit;
  1430. end;
  1431. { consume directive, and turn flag on }
  1432. consume(token);
  1433. parse_proc_direc:=true;
  1434. { Check the pd_flags if the directive should be allowed }
  1435. if ((pdflags and pd_interface)<>0) and
  1436. ((proc_direcdata[p].pd_flags and pd_interface)=0) then
  1437. begin
  1438. Message1(parser_e_proc_dir_not_allowed_in_interface,name);
  1439. exit;
  1440. end;
  1441. if ((pdflags and pd_implemen)<>0) and
  1442. ((proc_direcdata[p].pd_flags and pd_implemen)=0) then
  1443. begin
  1444. Message1(parser_e_proc_dir_not_allowed_in_implementation,name);
  1445. exit;
  1446. end;
  1447. if ((pdflags and pd_procvar)<>0) and
  1448. ((proc_direcdata[p].pd_flags and pd_procvar)=0) then
  1449. begin
  1450. Message1(parser_e_proc_dir_not_allowed_in_procvar,name);
  1451. exit;
  1452. end;
  1453. { Return the new pd_flags }
  1454. if (proc_direcdata[p].pd_flags and pd_body)=0 then
  1455. pdflags:=pdflags and (not pd_body);
  1456. if (proc_direcdata[p].pd_flags and pd_global)<>0 then
  1457. pdflags:=pdflags or pd_global;
  1458. { Add the correct flag }
  1459. aktprocsym.definition.proccalloptions:=aktprocsym.definition.proccalloptions+proc_direcdata[p].pocall;
  1460. aktprocsym.definition.procoptions:=aktprocsym.definition.procoptions+proc_direcdata[p].pooption;
  1461. { Adjust positions of args for cdecl or stdcall }
  1462. if (aktprocsym.definition.deftype=procdef) and
  1463. (([pocall_cdecl,pocall_cppdecl,pocall_stdcall]*aktprocsym.definition.proccalloptions)<>[]) then
  1464. tparasymtable(aktprocsym.definition.parast).set_alignment(target_info.size_of_longint);
  1465. { Call the handler }
  1466. if pointer({$ifndef FPCPROCVAR}@{$endif}proc_direcdata[p].handler)<>nil then
  1467. proc_direcdata[p].handler{$ifdef FPCPROCVAR}(){$endif};
  1468. end;
  1469. procedure parse_proc_directives(var pdflags:word);
  1470. {
  1471. Parse the procedure directives. It does not matter if procedure directives
  1472. are written using ;procdir; or ['procdir'] syntax.
  1473. }
  1474. var
  1475. res : boolean;
  1476. begin
  1477. while token in [_ID,_LECKKLAMMER] do
  1478. begin
  1479. if try_to_consume(_LECKKLAMMER) then
  1480. begin
  1481. repeat
  1482. parse_proc_direc(pdflags);
  1483. until not try_to_consume(_COMMA);
  1484. consume(_RECKKLAMMER);
  1485. { we always expect at least '[];' }
  1486. res:=true;
  1487. end
  1488. else
  1489. res:=parse_proc_direc(pdflags);
  1490. { A procedure directive normally followed by a semicolon, but in
  1491. a const section we should stop when _EQUAL is found }
  1492. if res then
  1493. begin
  1494. if (block_type=bt_const) and
  1495. (token=_EQUAL) then
  1496. break;
  1497. { support procedure proc;stdcall export; in Delphi mode only }
  1498. if not((m_delphi in aktmodeswitches) and
  1499. is_proc_directive(token)) then
  1500. consume(_SEMICOLON);
  1501. end
  1502. else
  1503. break;
  1504. end;
  1505. end;
  1506. procedure parse_var_proc_directives(var sym : tsym);
  1507. var
  1508. pdflags : word;
  1509. oldsym : tprocsym;
  1510. pd : tabstractprocdef;
  1511. begin
  1512. oldsym:=aktprocsym;
  1513. pdflags:=pd_procvar;
  1514. { we create a temporary aktprocsym to read the directives }
  1515. aktprocsym:=tprocsym.create(sym.name);
  1516. case sym.typ of
  1517. varsym :
  1518. pd:=tabstractprocdef(tvarsym(sym).vartype.def);
  1519. typedconstsym :
  1520. pd:=tabstractprocdef(ttypedconstsym(sym).typedconsttype.def);
  1521. typesym :
  1522. pd:=tabstractprocdef(ttypesym(sym).restype.def);
  1523. else
  1524. internalerror(994932432);
  1525. end;
  1526. if pd.deftype<>procvardef then
  1527. internalerror(994932433);
  1528. tabstractprocdef(aktprocsym.definition):=pd;
  1529. { names should never be used anyway }
  1530. inc(lexlevel);
  1531. parse_proc_directives(pdflags);
  1532. dec(lexlevel);
  1533. aktprocsym.definition:=nil;
  1534. aktprocsym.free;
  1535. aktprocsym:=oldsym;
  1536. end;
  1537. procedure parse_object_proc_directives(var sym : tprocsym);
  1538. var
  1539. pdflags : word;
  1540. begin
  1541. pdflags:=pd_object;
  1542. inc(lexlevel);
  1543. parse_proc_directives(pdflags);
  1544. dec(lexlevel);
  1545. if (po_containsself in aktprocsym.definition.procoptions) and
  1546. (([po_msgstr,po_msgint]*aktprocsym.definition.procoptions)=[]) then
  1547. Message(parser_e_self_in_non_message_handler);
  1548. end;
  1549. function check_identical_proc(var p : tprocdef) : boolean;
  1550. {
  1551. Search for idendical definitions,
  1552. if there is a forward, then kill this.
  1553. Returns the result of the forward check.
  1554. Removed from unter_dec to keep the source readable
  1555. }
  1556. var
  1557. hd,pd : tprocdef;
  1558. ad,fd : tsym;
  1559. begin
  1560. check_identical_proc:=false;
  1561. p:=nil;
  1562. pd:=aktprocsym.definition;
  1563. if assigned(pd) then
  1564. begin
  1565. { Is there an overload/forward ? }
  1566. if assigned(pd.nextoverloaded) then
  1567. begin
  1568. { walk the procdef list }
  1569. while (assigned(pd)) and (assigned(pd.nextoverloaded)) do
  1570. begin
  1571. hd:=pd.nextoverloaded;
  1572. { check the parameters, for delphi/tp it is possible to
  1573. leave the parameters away in the implementation (forwarddef=false).
  1574. But for an overload declared function this is not allowed }
  1575. if { check if empty implementation arguments match is allowed }
  1576. (
  1577. not(m_repeat_forward in aktmodeswitches) and
  1578. (aktprocsym.definition.maxparacount=0) and
  1579. not(aktprocsym.definition.forwarddef) and
  1580. not(po_overload in hd.procoptions)
  1581. ) or
  1582. { check arguments }
  1583. (
  1584. equal_paras(aktprocsym.definition.para,hd.para,cp_none) and
  1585. { for operators equal_paras is not enough !! }
  1586. ((aktprocsym.definition.proctypeoption<>potype_operator) or (optoken<>_ASSIGNMENT) or
  1587. is_equal(hd.rettype.def,aktprocsym.definition.rettype.def))
  1588. ) then
  1589. begin
  1590. if not equal_paras(aktprocsym.definition.para,hd.para,cp_all) and
  1591. ((m_repeat_forward in aktmodeswitches) or
  1592. (aktprocsym.definition.maxparacount>0)) then
  1593. begin
  1594. MessagePos1(aktprocsym.definition.fileinfo,parser_e_header_dont_match_forward,
  1595. aktprocsym.definition.fullprocname);
  1596. exit;
  1597. end;
  1598. if hd.forwarddef then
  1599. { remove the forward definition but don't delete it, }
  1600. { the symtable is the owner !! }
  1601. begin
  1602. { Check if the procedure type and return type are correct }
  1603. if (hd.proctypeoption<>aktprocsym.definition.proctypeoption) or
  1604. (not(is_equal(hd.rettype.def,aktprocsym.definition.rettype.def)) and
  1605. (m_repeat_forward in aktmodeswitches)) then
  1606. begin
  1607. MessagePos1(aktprocsym.definition.fileinfo,parser_e_header_dont_match_forward,
  1608. aktprocsym.definition.fullprocname);
  1609. exit;
  1610. end;
  1611. { Check calling convention, no check for internconst,internproc which
  1612. are only defined in interface or implementation }
  1613. if (hd.proccalloptions-[pocall_internconst,pocall_internproc]<>
  1614. aktprocsym.definition.proccalloptions-[pocall_internconst,pocall_internproc]) then
  1615. begin
  1616. { only trigger an error, becuase it doesn't hurt, for delphi check
  1617. if the current implementation has no proccalloptions, then
  1618. take the options from the interface }
  1619. if (m_delphi in aktmodeswitches) then
  1620. begin
  1621. if (aktprocsym.definition.proccalloptions=[]) then
  1622. aktprocsym.definition.proccalloptions:=hd.proccalloptions
  1623. else
  1624. MessagePos(aktprocsym.definition.fileinfo,parser_e_call_convention_dont_match_forward);
  1625. end
  1626. else
  1627. MessagePos(aktprocsym.definition.fileinfo,parser_e_call_convention_dont_match_forward);
  1628. { set the mangledname to the interface name so it doesn't trigger
  1629. the Note about different manglednames (PFV) }
  1630. aktprocsym.definition.setmangledname(hd.mangledname);
  1631. end;
  1632. { manglednames are equal? }
  1633. hd.count:=false;
  1634. if (m_repeat_forward in aktmodeswitches) or
  1635. aktprocsym.definition.haspara then
  1636. begin
  1637. if (hd.mangledname<>aktprocsym.definition.mangledname) then
  1638. begin
  1639. if not(po_external in aktprocsym.definition.procoptions) then
  1640. MessagePos2(aktprocsym.definition.fileinfo,parser_n_interface_name_diff_implementation_name,hd.mangledname,
  1641. aktprocsym.definition.mangledname);
  1642. { reset the mangledname of the interface part to be sure }
  1643. { this is wrong because the mangled name might have been used already !! }
  1644. if hd.is_used then
  1645. renameasmsymbol(hd.mangledname,aktprocsym.definition.mangledname);
  1646. hd.setmangledname(aktprocsym.definition.mangledname);
  1647. end
  1648. else
  1649. begin
  1650. { If mangled names are equal, therefore }
  1651. { they have the same number of parameters }
  1652. { Therefore we can check the name of these }
  1653. { parameters... }
  1654. if hd.forwarddef and aktprocsym.definition.forwarddef then
  1655. begin
  1656. MessagePos1(aktprocsym.definition.fileinfo,
  1657. parser_e_function_already_declared_public_forward,
  1658. aktprocsym.definition.fullprocname);
  1659. check_identical_proc:=true;
  1660. { Remove other forward from the list to reduce errors }
  1661. pd.nextoverloaded:=pd.nextoverloaded.nextoverloaded;
  1662. exit;
  1663. end;
  1664. { both symtables are in the same order from left to right }
  1665. ad:=tsym(hd.parast.symindex.first);
  1666. fd:=tsym(aktprocsym.definition.parast.symindex.first);
  1667. while assigned(ad) and assigned(fd) do
  1668. begin
  1669. if ad.name<>fd.name then
  1670. begin
  1671. MessagePos3(aktprocsym.definition.fileinfo,parser_e_header_different_var_names,
  1672. aktprocsym.name,ad.name,fd.name);
  1673. break;
  1674. end;
  1675. ad:=tsym(ad.indexnext);
  1676. fd:=tsym(fd.indexnext);
  1677. end;
  1678. end;
  1679. end;
  1680. { also the para_offset }
  1681. hd.parast.address_fixup:=aktprocsym.definition.parast.address_fixup;
  1682. hd.count:=true;
  1683. { remove pd.nextoverloaded from the list }
  1684. { and add aktprocsym.definition }
  1685. pd.nextoverloaded:=pd.nextoverloaded.nextoverloaded;
  1686. hd.nextoverloaded:=aktprocsym.definition.nextoverloaded;
  1687. { Alert! All fields of aktprocsym.definition that are modified
  1688. by the procdir handlers must be copied here!.}
  1689. hd.forwarddef:=false;
  1690. hd.hasforward:=true;
  1691. hd.proccalloptions:=hd.proccalloptions + aktprocsym.definition.proccalloptions;
  1692. hd.procoptions:=hd.procoptions + aktprocsym.definition.procoptions;
  1693. if aktprocsym.definition.extnumber=-1 then
  1694. aktprocsym.definition.extnumber:=hd.extnumber
  1695. else
  1696. if hd.extnumber=-1 then
  1697. hd.extnumber:=aktprocsym.definition.extnumber;
  1698. { copy all aliasnames }
  1699. while not aktprocsym.definition.aliasnames.empty do
  1700. hd.aliasnames.insert(aktprocsym.definition.aliasnames.getfirst);
  1701. if pd=aktprocsym.definition then
  1702. p:=nil
  1703. else
  1704. p:=pd;
  1705. aktprocsym.definition:=hd;
  1706. { for compilerproc defines we need to rename and update the
  1707. mangledname }
  1708. if (pocall_compilerproc in aktprocsym.definition.proccalloptions) then
  1709. begin
  1710. { rename to lowercase so users can't access it }
  1711. aktprocsym.owner.rename(aktprocsym.name,lower(aktprocsym.name));
  1712. { also update the realname that is stored in the ppu }
  1713. stringdispose(aktprocsym._realname);
  1714. aktprocsym._realname:=stringdup('$'+aktprocsym.name);
  1715. aktprocsym.definition.setmangledname(aktprocsym.name);
  1716. end;
  1717. check_identical_proc:=true;
  1718. break;
  1719. end
  1720. else
  1721. { abstract methods aren't forward defined, but this }
  1722. { needs another error message }
  1723. if (po_abstractmethod in pd.nextoverloaded.procoptions) then
  1724. MessagePos(aktprocsym.definition.fileinfo,parser_e_abstract_no_definition)
  1725. else
  1726. MessagePos(aktprocsym.definition.fileinfo,parser_e_overloaded_have_same_parameters);
  1727. break;
  1728. end;
  1729. { check for allowing overload directive }
  1730. if not(m_fpc in aktmodeswitches) then
  1731. begin
  1732. { overload directive turns on overloading }
  1733. if ((po_overload in aktprocsym.definition.procoptions) or
  1734. (po_overload in hd.procoptions)) then
  1735. begin
  1736. { check if all procs have overloading, but not if the proc was
  1737. already declared forward, then the check is already done }
  1738. if not(hd.hasforward or
  1739. (aktprocsym.definition.forwarddef<>hd.forwarddef) or
  1740. ((po_overload in aktprocsym.definition.procoptions) and
  1741. (po_overload in hd.procoptions))) then
  1742. begin
  1743. MessagePos1(aktprocsym.definition.fileinfo,parser_e_no_overload_for_all_procs,aktprocsym.realname);
  1744. break;
  1745. end;
  1746. end
  1747. else
  1748. begin
  1749. if not(hd.forwarddef) then
  1750. begin
  1751. MessagePos(aktprocsym.definition.fileinfo,parser_e_procedure_overloading_is_off);
  1752. break;
  1753. end;
  1754. end;
  1755. end;
  1756. { try next overloaded }
  1757. pd:=pd.nextoverloaded;
  1758. end;
  1759. end
  1760. else
  1761. begin
  1762. { there is no overloaded, so its always identical with itself }
  1763. check_identical_proc:=true;
  1764. end;
  1765. end;
  1766. { insert otsym only in the right symtable }
  1767. if ((procinfo^.flags and pi_operator)<>0) and assigned(otsym)
  1768. and not parse_only then
  1769. begin
  1770. if ret_in_param(aktprocsym.definition.rettype.def) then
  1771. begin
  1772. tprocdef(aktprocsym.definition).parast.insert(otsym);
  1773. { this increases the data size }
  1774. { correct this to get the right ret $value }
  1775. dec(tprocdef(aktprocsym.definition).parast.datasize,
  1776. align(otsym.getpushsize,tprocdef(aktprocsym.definition).parast.dataalignment));
  1777. { this allows to read the funcretoffset }
  1778. otsym.address:=-4;
  1779. otsym.varspez:=vs_var;
  1780. end
  1781. else
  1782. tprocdef(aktprocsym.definition).localst.insert(otsym);
  1783. end;
  1784. end;
  1785. end.
  1786. {
  1787. $Log$
  1788. Revision 1.30 2001-08-01 15:07:29 jonas
  1789. + "compilerproc" directive support, which turns both the public and mangled
  1790. name to lowercase(declaration_name). This prevents a normal user from
  1791. accessing the routine, but they can still be easily looked up within
  1792. the compiler. This is used for helper procedures and should facilitate
  1793. the writing of more processor independent code in the code generator
  1794. itself (mostly written by Peter)
  1795. + new "createintern" constructor for tcal nodes to create a call to
  1796. helper exported using the "compilerproc" directive
  1797. + support for high(dynamic_array) using the the above new things
  1798. + definition of 'HASCOMPILERPROC' symbol (to be able to check in the
  1799. compiler and rtl whether the "compilerproc" directive is supported)
  1800. Revision 1.29 2001/07/09 21:11:14 peter
  1801. * fixed overload checking for delphi. Empty parameters are only
  1802. allowed in implementation and not when the forward declaration
  1803. contains overload directive
  1804. Revision 1.28 2001/07/01 20:16:16 peter
  1805. * alignmentinfo record added
  1806. * -Oa argument supports more alignment settings that can be specified
  1807. per type: PROC,LOOP,VARMIN,VARMAX,CONSTMIN,CONSTMAX,RECORDMIN
  1808. RECORDMAX,LOCALMIN,LOCALMAX. It is possible to set the mimimum
  1809. required alignment and the maximum usefull alignment. The final
  1810. alignment will be choosen per variable size dependent on these
  1811. settings
  1812. Revision 1.27 2001/06/04 18:12:26 peter
  1813. * fixed crash with procvar directive parsing. Be carefull as the procvar
  1814. directive parsing uses aktprocsym.definition that is a tprocdef, but
  1815. for procvar the type is tprocvardef. So some fields are not available
  1816. Revision 1.26 2001/06/04 11:53:13 peter
  1817. + varargs directive
  1818. Revision 1.25 2001/06/03 21:57:36 peter
  1819. + hint directive parsing support
  1820. Revision 1.24 2001/05/08 21:06:31 florian
  1821. * some more support for widechars commited especially
  1822. regarding type casting and constants
  1823. Revision 1.23 2001/05/08 14:32:58 jonas
  1824. * fixed bug for overloaded operators with a return type that has a size
  1825. which isn't a multiple of the target_os.stackalignment (main branch
  1826. patch from Peter)
  1827. Revision 1.22 2001/05/04 15:52:03 florian
  1828. * some Delphi incompatibilities fixed:
  1829. - out, dispose and new can be used as idenfiers now
  1830. - const p = apointerype(nil); is supported now
  1831. + support for const p = apointertype(pointer(1234)); added
  1832. Revision 1.21 2001/04/18 22:01:57 peter
  1833. * registration of targets and assemblers
  1834. Revision 1.20 2001/04/13 20:05:16 peter
  1835. * better check for globalsymtable
  1836. Revision 1.19 2001/04/13 18:03:16 peter
  1837. * give error with local external procedure
  1838. Revision 1.18 2001/04/13 01:22:11 peter
  1839. * symtable change to classes
  1840. * range check generation and errors fixed, make cycle DEBUG=1 works
  1841. * memory leaks fixed
  1842. Revision 1.17 2001/04/04 22:43:52 peter
  1843. * remove unnecessary calls to firstpass
  1844. Revision 1.16 2001/04/02 21:20:33 peter
  1845. * resulttype rewrite
  1846. Revision 1.15 2001/03/24 12:18:11 florian
  1847. * procedure p(); is now allowed in all modes except TP
  1848. Revision 1.14 2001/03/22 22:35:42 florian
  1849. + support for type a = (a=1); in Delphi mode added
  1850. + procedure p(); in Delphi mode supported
  1851. + on isn't keyword anymore, it can be used as
  1852. id etc. now
  1853. Revision 1.13 2001/03/11 22:58:50 peter
  1854. * getsym redesign, removed the globals srsym,srsymtable
  1855. Revision 1.12 2001/03/06 18:28:02 peter
  1856. * patch from Pavel with a new and much faster DLL Scanner for
  1857. automatic importing so $linklib works for DLLs. Thanks Pavel!
  1858. Revision 1.11 2001/01/08 21:40:26 peter
  1859. * fixed crash with unsupported token overloading
  1860. Revision 1.10 2000/12/25 00:07:27 peter
  1861. + new tlinkedlist class (merge of old tstringqueue,tcontainer and
  1862. tlinkedlist objects)
  1863. Revision 1.9 2000/11/29 00:30:35 florian
  1864. * unused units removed from uses clause
  1865. * some changes for widestrings
  1866. Revision 1.8 2000/11/26 23:45:34 florian
  1867. * pascal modifier in interfaces of units works now
  1868. Revision 1.7 2000/11/06 20:30:55 peter
  1869. * more fixes to get make cycle working
  1870. Revision 1.6 2000/11/04 14:25:20 florian
  1871. + merged Attila's changes for interfaces, not tested yet
  1872. Revision 1.5 2000/11/01 23:04:37 peter
  1873. * tprocdef.fullprocname added for better casesensitve writing of
  1874. procedures
  1875. Revision 1.4 2000/10/31 22:02:49 peter
  1876. * symtable splitted, no real code changes
  1877. Revision 1.3 2000/10/21 18:16:11 florian
  1878. * a lot of changes:
  1879. - basic dyn. array support
  1880. - basic C++ support
  1881. - some work for interfaces done
  1882. ....
  1883. Revision 1.2 2000/10/15 07:47:51 peter
  1884. * unit names and procedure names are stored mixed case
  1885. Revision 1.1 2000/10/14 10:14:51 peter
  1886. * moehrendorf oct 2000 rewrite
  1887. }