pdecsub.pas 100 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268226922702271227222732274227522762277227822792280228122822283228422852286228722882289229022912292229322942295229622972298229923002301230223032304230523062307230823092310231123122313231423152316231723182319232023212322232323242325232623272328232923302331233223332334233523362337233823392340234123422343234423452346234723482349235023512352235323542355235623572358235923602361236223632364236523662367236823692370237123722373237423752376237723782379238023812382238323842385238623872388238923902391239223932394239523962397239823992400240124022403240424052406240724082409241024112412241324142415241624172418241924202421242224232424242524262427242824292430243124322433243424352436243724382439244024412442244324442445244624472448244924502451245224532454245524562457245824592460246124622463246424652466246724682469247024712472247324742475247624772478247924802481248224832484248524862487248824892490249124922493249424952496249724982499250025012502250325042505250625072508250925102511251225132514251525162517251825192520252125222523252425252526252725282529253025312532253325342535253625372538253925402541254225432544254525462547254825492550255125522553255425552556255725582559256025612562256325642565256625672568256925702571257225732574257525762577257825792580258125822583258425852586258725882589259025912592259325942595259625972598259926002601260226032604260526062607260826092610261126122613261426152616261726182619262026212622262326242625262626272628262926302631263226332634263526362637263826392640264126422643264426452646264726482649265026512652265326542655265626572658265926602661266226632664266526662667266826692670267126722673267426752676267726782679268026812682268326842685268626872688268926902691269226932694269526962697269826992700270127022703270427052706270727082709271027112712271327142715271627172718271927202721272227232724272527262727272827292730273127322733273427352736273727382739274027412742274327442745274627472748274927502751275227532754275527562757275827592760276127622763276427652766276727682769277027712772277327742775277627772778
  1. {
  2. Copyright (c) 1998-2002 by Florian Klaempfl, Daniel Mantione
  3. Does the parsing of the procedures/functions
  4. This program is free software; you can redistribute it and/or modify
  5. it under the terms of the GNU General Public License as published by
  6. the Free Software Foundation; either version 2 of the License, or
  7. (at your option) any later version.
  8. This program is distributed in the hope that it will be useful,
  9. but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  11. GNU General Public License for more details.
  12. You should have received a copy of the GNU General Public License
  13. along with this program; if not, write to the Free Software
  14. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  15. ****************************************************************************
  16. }
  17. unit pdecsub;
  18. {$i fpcdefs.inc}
  19. interface
  20. uses
  21. tokens,symconst,symtype,symdef,symsym;
  22. type
  23. tpdflag=(
  24. pd_body, { directive needs a body }
  25. pd_implemen, { directive can be used implementation section }
  26. pd_interface, { directive can be used interface section }
  27. pd_object, { directive can be used object declaration }
  28. pd_procvar, { directive can be used procvar declaration }
  29. pd_notobject, { directive can not be used object declaration }
  30. pd_notobjintf, { directive can not be used interface declaration }
  31. pd_notprocvar, { directive can not be used procvar declaration }
  32. pd_dispinterface,{ directive can be used with dispinterface methods }
  33. pd_cppobject { directive can be used with cppclass }
  34. );
  35. tpdflags=set of tpdflag;
  36. function check_proc_directive(isprocvar:boolean):boolean;
  37. procedure insert_funcret_local(pd:tprocdef);
  38. function proc_add_definition(var currpd:tprocdef):boolean;
  39. function proc_get_importname(pd:tprocdef):string;
  40. procedure proc_set_mangledname(pd:tprocdef);
  41. procedure handle_calling_convention(pd:tabstractprocdef);
  42. procedure parse_parameter_dec(pd:tabstractprocdef);
  43. procedure parse_proc_directives(pd:tabstractprocdef;var pdflags:tpdflags);
  44. procedure parse_var_proc_directives(sym:tsym);
  45. procedure parse_object_proc_directives(pd:tabstractprocdef);
  46. function parse_proc_head(aclass:tobjectdef;potype:tproctypeoption;var pd:tprocdef):boolean;
  47. function parse_proc_dec(aclass:tobjectdef):tprocdef;
  48. implementation
  49. uses
  50. SysUtils,
  51. { common }
  52. cutils,cclasses,
  53. { global }
  54. globtype,globals,verbose,constexp,
  55. systems,
  56. cpuinfo,
  57. { symtable }
  58. symbase,symtable,defutil,defcmp,paramgr,cpupara,
  59. { pass 1 }
  60. fmodule,node,htypechk,
  61. nmat,nadd,ncal,nset,ncnv,ninl,ncon,nld,nflw,
  62. { parser }
  63. scanner,
  64. pbase,pexpr,ptype,pdecl
  65. ;
  66. const
  67. { Please leave this here, this module should NOT use
  68. these variables.
  69. Declaring it as string here results in an error when compiling (PFV) }
  70. current_procinfo = 'error';
  71. procedure insert_funcret_para(pd:tabstractprocdef);
  72. var
  73. storepos : tfileposinfo;
  74. vs : tparavarsym;
  75. paranr : word;
  76. begin
  77. if not(pd.proctypeoption in [potype_constructor,potype_destructor]) and
  78. not is_void(pd.returndef) and
  79. paramanager.ret_in_param(pd.returndef,pd.proccalloption) then
  80. begin
  81. storepos:=current_tokenpos;
  82. if pd.typ=procdef then
  83. current_tokenpos:=tprocdef(pd).fileinfo;
  84. { For left to right add it at the end to be delphi compatible }
  85. if pd.proccalloption in (pushleftright_pocalls+[pocall_safecall]) then
  86. paranr:=paranr_result_leftright
  87. else
  88. paranr:=paranr_result;
  89. { Generate result variable accessing function result }
  90. vs:=tparavarsym.create('$result',paranr,vs_var,pd.returndef,[vo_is_funcret,vo_is_hidden_para]);
  91. vs.symoptions:=[sp_public];
  92. pd.parast.insert(vs);
  93. { Store the this symbol as funcretsym for procedures }
  94. if pd.typ=procdef then
  95. tprocdef(pd).funcretsym:=vs;
  96. current_tokenpos:=storepos;
  97. end;
  98. end;
  99. procedure insert_parentfp_para(pd:tabstractprocdef);
  100. var
  101. storepos : tfileposinfo;
  102. vs : tparavarsym;
  103. begin
  104. if pd.parast.symtablelevel>normal_function_level then
  105. begin
  106. storepos:=current_tokenpos;
  107. if pd.typ=procdef then
  108. current_tokenpos:=tprocdef(pd).fileinfo;
  109. { Generate result variable accessing function result, it
  110. can't be put in a register since it must be accessable
  111. from the framepointer }
  112. vs:=tparavarsym.create('$parentfp',paranr_parentfp,vs_value
  113. ,voidpointertype,[vo_is_parentfp,vo_is_hidden_para]);
  114. vs.varregable:=vr_none;
  115. vs.symoptions:=[sp_public];
  116. pd.parast.insert(vs);
  117. current_tokenpos:=storepos;
  118. end;
  119. end;
  120. procedure insert_self_and_vmt_para(pd:tabstractprocdef);
  121. var
  122. storepos : tfileposinfo;
  123. vs : tparavarsym;
  124. hdef : tdef;
  125. vsp : tvarspez;
  126. begin
  127. if (pd.typ=procvardef) and
  128. pd.is_methodpointer then
  129. begin
  130. { Generate self variable }
  131. vs:=tparavarsym.create('$self',paranr_self,vs_value,voidpointertype,[vo_is_self,vo_is_hidden_para]);
  132. vs.symoptions:=[sp_public];
  133. pd.parast.insert(vs);
  134. end
  135. else
  136. begin
  137. if (pd.typ=procdef) and
  138. assigned(tprocdef(pd)._class) and
  139. (pd.parast.symtablelevel=normal_function_level) then
  140. begin
  141. storepos:=current_tokenpos;
  142. current_tokenpos:=tprocdef(pd).fileinfo;
  143. { Generate VMT variable for constructor/destructor }
  144. if (pd.proctypeoption in [potype_constructor,potype_destructor]) and not(is_cppclass(tprocdef(pd)._class)) then
  145. begin
  146. { can't use classrefdef as type because inheriting
  147. will then always file because of a type mismatch }
  148. vs:=tparavarsym.create('$vmt',paranr_vmt,vs_value,voidpointertype,[vo_is_vmt,vo_is_hidden_para]);
  149. vs.symoptions:=[sp_public];
  150. pd.parast.insert(vs);
  151. end;
  152. { Generate self variable, for classes we need
  153. to use the generic voidpointer to be compatible with
  154. methodpointers }
  155. vsp:=vs_value;
  156. if (po_staticmethod in pd.procoptions) or
  157. (po_classmethod in pd.procoptions) then
  158. hdef:=tclassrefdef.create(tprocdef(pd)._class)
  159. else
  160. begin
  161. if is_object(tprocdef(pd)._class) then
  162. vsp:=vs_var;
  163. hdef:=tprocdef(pd)._class;
  164. end;
  165. vs:=tparavarsym.create('$self',paranr_self,vsp,hdef,[vo_is_self,vo_is_hidden_para]);
  166. vs.symoptions:=[sp_public];
  167. pd.parast.insert(vs);
  168. current_tokenpos:=storepos;
  169. end;
  170. end;
  171. end;
  172. procedure insert_funcret_local(pd:tprocdef);
  173. var
  174. storepos : tfileposinfo;
  175. vs : tlocalvarsym;
  176. aliasvs : tabsolutevarsym;
  177. sl : tpropaccesslist;
  178. hs : string;
  179. begin
  180. { The result from constructors and destructors can't be accessed directly }
  181. if not(pd.proctypeoption in [potype_constructor,potype_destructor]) and
  182. not is_void(pd.returndef) then
  183. begin
  184. storepos:=current_tokenpos;
  185. current_tokenpos:=pd.fileinfo;
  186. { We need to insert a varsym for the result in the localst
  187. when it is returning in a register }
  188. if not paramanager.ret_in_param(pd.returndef,pd.proccalloption) then
  189. begin
  190. vs:=tlocalvarsym.create('$result',vs_value,pd.returndef,[vo_is_funcret]);
  191. pd.localst.insert(vs);
  192. pd.funcretsym:=vs;
  193. end;
  194. { insert the name of the procedure as alias for the function result,
  195. we can't use realname because that will not work for compilerprocs
  196. as the name is lowercase and unreachable from the code }
  197. if assigned(pd.resultname) then
  198. hs:=pd.resultname^
  199. else
  200. hs:=pd.procsym.name;
  201. sl:=tpropaccesslist.create;
  202. sl.addsym(sl_load,pd.funcretsym);
  203. aliasvs:=tabsolutevarsym.create_ref(hs,pd.returndef,sl);
  204. include(aliasvs.varoptions,vo_is_funcret);
  205. tlocalsymtable(pd.localst).insert(aliasvs);
  206. { insert result also if support is on }
  207. if (m_result in current_settings.modeswitches) then
  208. begin
  209. sl:=tpropaccesslist.create;
  210. sl.addsym(sl_load,pd.funcretsym);
  211. aliasvs:=tabsolutevarsym.create_ref('RESULT',pd.returndef,sl);
  212. include(aliasvs.varoptions,vo_is_funcret);
  213. include(aliasvs.varoptions,vo_is_result);
  214. tlocalsymtable(pd.localst).insert(aliasvs);
  215. end;
  216. current_tokenpos:=storepos;
  217. end;
  218. end;
  219. procedure insert_hidden_para(p:TObject;arg:pointer);
  220. var
  221. hvs : tparavarsym;
  222. pd : tabstractprocdef absolute arg;
  223. begin
  224. if (tsym(p).typ<>paravarsym) then
  225. exit;
  226. with tparavarsym(p) do
  227. begin
  228. { We need a local copy for a value parameter when only the
  229. address is pushed. Open arrays and Array of Const are
  230. an exception because they are allocated at runtime and the
  231. address that is pushed is patched }
  232. if (varspez=vs_value) and
  233. paramanager.push_addr_param(varspez,vardef,pd.proccalloption) and
  234. not(is_open_array(vardef) or
  235. is_array_of_const(vardef)) then
  236. include(varoptions,vo_has_local_copy);
  237. { needs high parameter ? }
  238. if paramanager.push_high_param(varspez,vardef,pd.proccalloption) then
  239. begin
  240. hvs:=tparavarsym.create('$high'+name,paranr+1,vs_const,sinttype,[vo_is_high_para,vo_is_hidden_para]);
  241. hvs.symoptions:=[sp_public];
  242. owner.insert(hvs);
  243. end
  244. else
  245. begin
  246. { Give a warning that cdecl routines does not include high()
  247. support }
  248. if (pd.proccalloption in [pocall_cdecl,pocall_cppdecl]) and
  249. paramanager.push_high_param(varspez,vardef,pocall_default) then
  250. begin
  251. if is_open_string(vardef) then
  252. Message(parser_w_cdecl_no_openstring);
  253. if not (po_external in pd.procoptions) then
  254. Message(parser_w_cdecl_has_no_high);
  255. end;
  256. if (vardef.typ=formaldef) and (Tformaldef(vardef).typed) then
  257. begin
  258. hvs:=tparavarsym.create('$typinfo'+name,paranr+1,vs_const,voidpointertype,
  259. [vo_is_typinfo_para,vo_is_hidden_para]);
  260. owner.insert(hvs);
  261. end;
  262. end;
  263. end;
  264. end;
  265. procedure check_c_para(pd:Tabstractprocdef);
  266. var
  267. i,
  268. lastparaidx : longint;
  269. sym : TSym;
  270. begin
  271. lastparaidx:=pd.parast.SymList.Count-1;
  272. for i:=0 to pd.parast.SymList.Count-1 do
  273. begin
  274. sym:=tsym(pd.parast.SymList[i]);
  275. if (sym.typ=paravarsym) and
  276. (tparavarsym(sym).vardef.typ=arraydef) then
  277. begin
  278. if not is_variant_array(tparavarsym(sym).vardef) and
  279. not is_array_of_const(tparavarsym(sym).vardef) and
  280. (tparavarsym(sym).varspez<>vs_var) then
  281. Message(parser_h_c_arrays_are_references);
  282. if is_array_of_const(tparavarsym(sym).vardef) and
  283. (i<lastparaidx) and
  284. (tsym(pd.parast.SymList[i+1]).typ=paravarsym) and
  285. not(vo_is_high_para in tparavarsym(pd.parast.SymList[i+1]).varoptions) then
  286. Message(parser_e_C_array_of_const_must_be_last);
  287. end;
  288. end;
  289. end;
  290. procedure check_msg_para(p:TObject;arg:pointer);
  291. begin
  292. if (tsym(p).typ<>paravarsym) then
  293. exit;
  294. with tparavarsym(p) do
  295. begin
  296. { Count parameters }
  297. if (paranr>=10) then
  298. inc(plongint(arg)^);
  299. { First parameter must be var }
  300. if (paranr=10) and
  301. (varspez<>vs_var) then
  302. Message(parser_e_ill_msg_param);
  303. end;
  304. end;
  305. procedure check_inline_para(p:TObject;arg:pointer);
  306. var
  307. pd : tabstractprocdef absolute arg;
  308. begin
  309. if not(po_inline in pd.procoptions) or
  310. (tsym(p).typ<>paravarsym) then
  311. exit;
  312. with tparavarsym(p) do
  313. begin
  314. case vardef.typ of
  315. arraydef :
  316. begin
  317. if is_array_constructor(vardef) or
  318. is_variant_array(vardef) then
  319. begin
  320. Message1(parser_w_not_supported_for_inline,'array of const');
  321. Message(parser_w_inlining_disabled);
  322. pd.proccalloption:=pocall_default;
  323. end;
  324. end;
  325. end;
  326. end;
  327. end;
  328. procedure set_addr_param_regable(p:TObject;arg:pointer);
  329. begin
  330. if (tsym(p).typ<>paravarsym) then
  331. exit;
  332. with tparavarsym(p) do
  333. begin
  334. if not vardef.needs_inittable and
  335. paramanager.push_addr_param(varspez,vardef,tprocdef(arg).proccalloption) then
  336. varregable:=vr_intreg;
  337. end;
  338. end;
  339. procedure parse_parameter_dec(pd:tabstractprocdef);
  340. {
  341. handle_procvar needs the same changes
  342. }
  343. type
  344. tppv = (pv_none,pv_proc,pv_func);
  345. var
  346. sc : TFPObjectList;
  347. hdef : tdef;
  348. arrayelementdef : tdef;
  349. vs : tparavarsym;
  350. i : longint;
  351. srsym : tsym;
  352. pv : tprocvardef;
  353. varspez : Tvarspez;
  354. defaultvalue : tconstsym;
  355. defaultrequired : boolean;
  356. old_object_option : tsymoptions;
  357. old_block_type : tblock_type;
  358. currparast : tparasymtable;
  359. parseprocvar : tppv;
  360. explicit_paraloc : boolean;
  361. locationstr : string;
  362. paranr : integer;
  363. dummytype : ttypesym;
  364. begin
  365. old_object_option:=current_object_option;
  366. old_block_type:=block_type;
  367. explicit_paraloc:=false;
  368. consume(_LKLAMMER);
  369. { Delphi/Kylix supports nonsense like }
  370. { procedure p(); }
  371. if try_to_consume(_RKLAMMER) and
  372. not(m_tp7 in current_settings.modeswitches) then
  373. exit;
  374. { parsing a proc or procvar ? }
  375. currparast:=tparasymtable(pd.parast);
  376. { reset }
  377. sc:=TFPObjectList.create(false);
  378. defaultrequired:=false;
  379. paranr:=0;
  380. { the variables are always public }
  381. current_object_option:=[sp_public];
  382. inc(testcurobject);
  383. block_type:=bt_type;
  384. repeat
  385. parseprocvar:=pv_none;
  386. if try_to_consume(_VAR) then
  387. varspez:=vs_var
  388. else
  389. if try_to_consume(_CONST) then
  390. varspez:=vs_const
  391. else
  392. if (m_out in current_settings.modeswitches) and
  393. try_to_consume(_OUT) then
  394. varspez:=vs_out
  395. else
  396. if (m_mac in current_settings.modeswitches) and
  397. try_to_consume(_POINTPOINTPOINT) then
  398. begin
  399. include(pd.procoptions,po_varargs);
  400. break;
  401. end
  402. else
  403. if (m_mac in current_settings.modeswitches) and
  404. try_to_consume(_PROCEDURE) then
  405. begin
  406. parseprocvar:=pv_proc;
  407. varspez:=vs_const;
  408. end
  409. else
  410. if (m_mac in current_settings.modeswitches) and
  411. try_to_consume(_FUNCTION) then
  412. begin
  413. parseprocvar:=pv_func;
  414. varspez:=vs_const;
  415. end
  416. else
  417. varspez:=vs_value;
  418. defaultvalue:=nil;
  419. hdef:=nil;
  420. { read identifiers and insert with error type }
  421. sc.clear;
  422. repeat
  423. inc(paranr);
  424. vs:=tparavarsym.create(orgpattern,paranr*10,varspez,generrordef,[]);
  425. currparast.insert(vs);
  426. if assigned(vs.owner) then
  427. sc.add(vs)
  428. else
  429. vs.free;
  430. consume(_ID);
  431. until not try_to_consume(_COMMA);
  432. locationstr:='';
  433. { macpas anonymous procvar }
  434. if parseprocvar<>pv_none then
  435. begin
  436. pv:=tprocvardef.create(normal_function_level);
  437. if token=_LKLAMMER then
  438. parse_parameter_dec(pv);
  439. if parseprocvar=pv_func then
  440. begin
  441. consume(_COLON);
  442. single_type(pv.returndef,false);
  443. end;
  444. hdef:=pv;
  445. { possible proc directives }
  446. if check_proc_directive(true) then
  447. begin
  448. dummytype:=ttypesym.create('unnamed',hdef);
  449. parse_var_proc_directives(tsym(dummytype));
  450. dummytype.typedef:=nil;
  451. hdef.typesym:=nil;
  452. dummytype.free;
  453. end;
  454. { Add implicit hidden parameters and function result }
  455. handle_calling_convention(pv);
  456. end
  457. else
  458. { read type declaration, force reading for value and const paras }
  459. if (token=_COLON) or (varspez=vs_value) then
  460. begin
  461. consume(_COLON);
  462. { check for an open array }
  463. if token=_ARRAY then
  464. begin
  465. consume(_ARRAY);
  466. consume(_OF);
  467. { define range and type of range }
  468. hdef:=tarraydef.create(0,-1,s32inttype);
  469. { array of const ? }
  470. if (token=_CONST) and (m_objpas in current_settings.modeswitches) then
  471. begin
  472. consume(_CONST);
  473. srsym:=search_system_type('TVARREC');
  474. tarraydef(hdef).elementdef:=ttypesym(srsym).typedef;
  475. include(tarraydef(hdef).arrayoptions,ado_IsArrayOfConst);
  476. end
  477. else
  478. begin
  479. { define field type }
  480. single_type(arrayelementdef,false);
  481. tarraydef(hdef).elementdef:=arrayelementdef;
  482. end;
  483. end
  484. else
  485. begin
  486. if (m_mac in current_settings.modeswitches) then
  487. try_to_consume(_UNIV); {currently does nothing}
  488. if try_to_consume(_TYPE) then
  489. hdef:=ctypedformaltype
  490. else
  491. single_type(hdef,false);
  492. { open string ? }
  493. if (varspez in [vs_out,vs_var]) and
  494. (cs_openstring in current_settings.moduleswitches) and
  495. is_shortstring(hdef) then
  496. hdef:=openshortstringtype;
  497. if (target_info.system in [system_powerpc_morphos,system_m68k_amiga]) then
  498. begin
  499. if (idtoken=_LOCATION) then
  500. begin
  501. consume(_LOCATION);
  502. locationstr:=pattern;
  503. consume(_CSTRING);
  504. end
  505. else
  506. begin
  507. if explicit_paraloc then
  508. Message(parser_e_paraloc_all_paras);
  509. locationstr:='';
  510. end;
  511. end
  512. else
  513. locationstr:='';
  514. { default parameter }
  515. if (m_default_para in current_settings.modeswitches) then
  516. begin
  517. if try_to_consume(_EQUAL) then
  518. begin
  519. vs:=tparavarsym(sc[0]);
  520. if sc.count>1 then
  521. Message(parser_e_default_value_only_one_para);
  522. { prefix 'def' to the parameter name }
  523. defaultvalue:=ReadConstant('$def'+vs.name,vs.fileinfo);
  524. if assigned(defaultvalue) then
  525. begin
  526. include(defaultvalue.symoptions,sp_internal);
  527. pd.parast.insert(defaultvalue);
  528. end;
  529. defaultrequired:=true;
  530. end
  531. else
  532. begin
  533. if defaultrequired then
  534. Message1(parser_e_default_value_expected_for_para,vs.name);
  535. end;
  536. end;
  537. end;
  538. end
  539. else
  540. hdef:=cformaltype;
  541. { File types are only allowed for var and out parameters }
  542. if (hdef.typ=filedef) and
  543. not(varspez in [vs_out,vs_var]) then
  544. CGMessage(cg_e_file_must_call_by_reference);
  545. for i:=0 to sc.count-1 do
  546. begin
  547. vs:=tparavarsym(sc[i]);
  548. { update varsym }
  549. vs.vardef:=hdef;
  550. vs.defaultconstsym:=defaultvalue;
  551. if (target_info.system in [system_powerpc_morphos,system_m68k_amiga]) then
  552. begin
  553. if locationstr<>'' then
  554. begin
  555. if sc.count>1 then
  556. Message(parser_e_paraloc_only_one_para);
  557. if (paranr>1) and not(explicit_paraloc) then
  558. Message(parser_e_paraloc_all_paras);
  559. explicit_paraloc:=true;
  560. include(vs.varoptions,vo_has_explicit_paraloc);
  561. if not(paramanager.parseparaloc(vs,upper(locationstr))) then
  562. message(parser_e_illegal_explicit_paraloc);
  563. end
  564. else
  565. if explicit_paraloc then
  566. Message(parser_e_paraloc_all_paras);
  567. end;
  568. end;
  569. until not try_to_consume(_SEMICOLON);
  570. if explicit_paraloc then
  571. begin
  572. pd.has_paraloc_info:=true;
  573. include(pd.procoptions,po_explicitparaloc);
  574. end;
  575. { remove parasymtable from stack }
  576. sc.free;
  577. { reset object options }
  578. dec(testcurobject);
  579. current_object_option:=old_object_option;
  580. block_type:=old_block_type;
  581. consume(_RKLAMMER);
  582. end;
  583. function parse_proc_head(aclass:tobjectdef;potype:tproctypeoption;var pd:tprocdef):boolean;
  584. var
  585. hs : string;
  586. orgsp,sp : TIDString;
  587. srsym : tsym;
  588. srsymtable : TSymtable;
  589. checkstack : psymtablestackitem;
  590. storepos,
  591. procstartfilepos : tfileposinfo;
  592. searchagain : boolean;
  593. st,
  594. genericst : TSymtable;
  595. aprocsym : tprocsym;
  596. popclass : boolean;
  597. ImplIntf : TImplementedInterface;
  598. old_parse_generic : boolean;
  599. begin
  600. { Save the position where this procedure really starts }
  601. procstartfilepos:=current_tokenpos;
  602. old_parse_generic:=parse_generic;
  603. result:=false;
  604. pd:=nil;
  605. aprocsym:=nil;
  606. if (potype=potype_operator) then
  607. begin
  608. sp:=overloaded_names[optoken];
  609. orgsp:=sp;
  610. end
  611. else
  612. begin
  613. sp:=pattern;
  614. orgsp:=orgpattern;
  615. consume(_ID);
  616. end;
  617. { examine interface map: function/procedure iname.functionname=locfuncname }
  618. if assigned(aclass) and
  619. assigned(aclass.ImplementedInterfaces) and
  620. (aclass.ImplementedInterfaces.count>0) and
  621. try_to_consume(_POINT) then
  622. begin
  623. storepos:=current_tokenpos;
  624. current_tokenpos:=procstartfilepos;
  625. { get interface syms}
  626. searchsym(sp,srsym,srsymtable);
  627. if not assigned(srsym) then
  628. begin
  629. identifier_not_found(orgsp);
  630. srsym:=generrorsym;
  631. end;
  632. current_tokenpos:=storepos;
  633. { qualifier is interface? }
  634. ImplIntf:=nil;
  635. if (srsym.typ=typesym) and
  636. (ttypesym(srsym).typedef.typ=objectdef) then
  637. ImplIntf:=aclass.find_implemented_interface(tobjectdef(ttypesym(srsym).typedef));
  638. if ImplIntf=nil then
  639. Message(parser_e_interface_id_expected);
  640. consume(_ID);
  641. { Create unique name <interface>.<method> }
  642. hs:=sp+'.'+pattern;
  643. consume(_EQUAL);
  644. if assigned(ImplIntf) and
  645. (token=_ID) then
  646. ImplIntf.AddMapping(hs,pattern);
  647. consume(_ID);
  648. result:=true;
  649. exit;
  650. end;
  651. { method ? }
  652. if not assigned(aclass) and
  653. (potype<>potype_operator) and
  654. (symtablestack.top.symtablelevel=main_program_level) and
  655. try_to_consume(_POINT) then
  656. begin
  657. { search for object name }
  658. storepos:=current_tokenpos;
  659. current_tokenpos:=procstartfilepos;
  660. searchsym(sp,srsym,srsymtable);
  661. if not assigned(srsym) then
  662. begin
  663. identifier_not_found(orgsp);
  664. srsym:=generrorsym;
  665. end;
  666. current_tokenpos:=storepos;
  667. { consume proc name }
  668. sp:=pattern;
  669. orgsp:=orgpattern;
  670. procstartfilepos:=current_tokenpos;
  671. consume(_ID);
  672. { qualifier is class name ? }
  673. if (srsym.typ=typesym) and
  674. (ttypesym(srsym).typedef.typ=objectdef) then
  675. begin
  676. aclass:=tobjectdef(ttypesym(srsym).typedef);
  677. srsym:=tsym(aclass.symtable.Find(sp));
  678. if assigned(srsym) then
  679. begin
  680. if srsym.typ=procsym then
  681. aprocsym:=tprocsym(srsym)
  682. else
  683. begin
  684. { we use a different error message for tp7 so it looks more compatible }
  685. if (m_fpc in current_settings.modeswitches) then
  686. Message1(parser_e_overloaded_no_procedure,srsym.realname)
  687. else
  688. Message(parser_e_methode_id_expected);
  689. { rename the name to an unique name to avoid an
  690. error when inserting the symbol in the symtable }
  691. orgsp:=orgsp+'$'+tostr(current_filepos.line);
  692. end;
  693. end
  694. else
  695. begin
  696. Message(parser_e_methode_id_expected);
  697. { recover by making it a normal procedure instead of method }
  698. aclass:=nil;
  699. end;
  700. end
  701. else
  702. Message(parser_e_class_id_expected);
  703. end
  704. else
  705. begin
  706. { check for constructor/destructor which is not allowed here }
  707. if (not parse_only) and
  708. (potype in [potype_constructor,potype_destructor]) then
  709. Message(parser_e_constructors_always_objects);
  710. repeat
  711. searchagain:=false;
  712. current_tokenpos:=procstartfilepos;
  713. srsymtable:=symtablestack.top;
  714. srsym:=tsym(srsymtable.Find(sp));
  715. { Also look in the globalsymtable if we didn't found
  716. the symbol in the localsymtable }
  717. if not assigned(srsym) and
  718. not(parse_only) and
  719. (srsymtable=current_module.localsymtable) and
  720. assigned(current_module.globalsymtable) then
  721. srsym:=tsym(current_module.globalsymtable.Find(sp));
  722. { Check if overloaded is a procsym }
  723. if assigned(srsym) then
  724. begin
  725. if srsym.typ=procsym then
  726. aprocsym:=tprocsym(srsym)
  727. else
  728. begin
  729. { when the other symbol is a unit symbol then hide the unit
  730. symbol, this is not supported in tp7 }
  731. if not(m_tp7 in current_settings.modeswitches) and
  732. (srsym.typ=unitsym) then
  733. begin
  734. HideSym(srsym);
  735. searchagain:=true;
  736. end
  737. else
  738. begin
  739. { we use a different error message for tp7 so it looks more compatible }
  740. if (m_fpc in current_settings.modeswitches) then
  741. Message1(parser_e_overloaded_no_procedure,srsym.realname)
  742. else
  743. Message1(sym_e_duplicate_id,srsym.realname);
  744. { rename the name to an unique name to avoid an
  745. error when inserting the symbol in the symtable }
  746. orgsp:=orgsp+'$'+tostr(current_filepos.line);
  747. end;
  748. end;
  749. end;
  750. until not searchagain;
  751. end;
  752. { test again if assigned, it can be reset to recover }
  753. if not assigned(aprocsym) then
  754. begin
  755. { create a new procsym and set the real filepos }
  756. current_tokenpos:=procstartfilepos;
  757. { for operator we have only one procsym for each overloaded
  758. operation }
  759. if (potype=potype_operator) then
  760. begin
  761. Aprocsym:=Tprocsym(symtablestack.top.Find(sp));
  762. if Aprocsym=nil then
  763. Aprocsym:=tprocsym.create('$'+sp);
  764. end
  765. else
  766. aprocsym:=tprocsym.create(orgsp);
  767. symtablestack.top.insert(aprocsym);
  768. end;
  769. { to get the correct symtablelevel we must ignore ObjectSymtables }
  770. st:=nil;
  771. checkstack:=symtablestack.stack;
  772. while assigned(checkstack) do
  773. begin
  774. st:=checkstack^.symtable;
  775. if st.symtabletype in [staticsymtable,globalsymtable,localsymtable] then
  776. break;
  777. checkstack:=checkstack^.next;
  778. end;
  779. pd:=tprocdef.create(st.symtablelevel+1);
  780. pd._class:=aclass;
  781. pd.procsym:=aprocsym;
  782. pd.proctypeoption:=potype;
  783. { methods inherit df_generic or df_specialization from the objectdef }
  784. if assigned(pd._class) and
  785. (pd.parast.symtablelevel=normal_function_level) then
  786. begin
  787. if (df_generic in pd._class.defoptions) then
  788. begin
  789. include(pd.defoptions,df_generic);
  790. parse_generic:=true;
  791. end;
  792. if (df_specialization in pd._class.defoptions) then
  793. begin
  794. include(pd.defoptions,df_specialization);
  795. { Find corresponding genericdef, we need it later to
  796. replay the tokens to generate the body }
  797. if not assigned(pd._class.genericdef) then
  798. internalerror(200512113);
  799. genericst:=pd._class.genericdef.GetSymtable(gs_record);
  800. if not assigned(genericst) then
  801. internalerror(200512114);
  802. { We are parsing the same objectdef, the def index numbers
  803. are the same }
  804. pd.genericdef:=tstoreddef(genericst.DefList[pd.owner.DefList.IndexOf(pd)]);
  805. if not assigned(pd.genericdef) or
  806. (pd.genericdef.typ<>procdef) then
  807. internalerror(200512115);
  808. end;
  809. end;
  810. { methods need to be exported }
  811. if assigned(aclass) and
  812. (
  813. (symtablestack.top.symtabletype=ObjectSymtable) or
  814. (symtablestack.top.symtablelevel=main_program_level)
  815. ) then
  816. include(pd.procoptions,po_global);
  817. { symbol options that need to be kept per procdef }
  818. pd.fileinfo:=procstartfilepos;
  819. pd.symoptions:=current_object_option;
  820. { parse parameters }
  821. if token=_LKLAMMER then
  822. begin
  823. { Add ObjectSymtable to be able to find generic type definitions }
  824. popclass:=false;
  825. if assigned(pd._class) and
  826. (pd.parast.symtablelevel=normal_function_level) and
  827. (symtablestack.top.symtabletype<>ObjectSymtable) then
  828. begin
  829. symtablestack.push(pd._class.symtable);
  830. popclass:=true;
  831. end;
  832. { Add parameter symtable }
  833. if pd.parast.symtabletype<>staticsymtable then
  834. symtablestack.push(pd.parast);
  835. parse_parameter_dec(pd);
  836. if pd.parast.symtabletype<>staticsymtable then
  837. symtablestack.pop(pd.parast);
  838. if popclass then
  839. symtablestack.pop(pd._class.symtable);
  840. end;
  841. parse_generic:=old_parse_generic;
  842. result:=true;
  843. end;
  844. function parse_proc_dec(aclass:tobjectdef):tprocdef;
  845. var
  846. pd : tprocdef;
  847. isclassmethod : boolean;
  848. locationstr: string;
  849. popclass : boolean;
  850. begin
  851. locationstr:='';
  852. pd:=nil;
  853. isclassmethod:=false;
  854. { read class method }
  855. if try_to_consume(_CLASS) then
  856. begin
  857. { class method only allowed for procedures and functions }
  858. if not(token in [_FUNCTION,_PROCEDURE]) then
  859. Message(parser_e_procedure_or_function_expected);
  860. if is_interface(aclass) then
  861. Message(parser_e_no_static_method_in_interfaces)
  862. else
  863. isclassmethod:=true;
  864. end;
  865. case token of
  866. _FUNCTION :
  867. begin
  868. consume(_FUNCTION);
  869. if parse_proc_head(aclass,potype_function,pd) then
  870. begin
  871. { pd=nil when it is a interface mapping }
  872. if assigned(pd) then
  873. begin
  874. if try_to_consume(_COLON) then
  875. begin
  876. inc(testcurobject);
  877. { Add ObjectSymtable to be able to find generic type definitions }
  878. popclass:=false;
  879. if assigned(pd._class) and
  880. (pd.parast.symtablelevel=normal_function_level) and
  881. (symtablestack.top.symtabletype<>ObjectSymtable) then
  882. begin
  883. symtablestack.push(pd._class.symtable);
  884. popclass:=true;
  885. end;
  886. single_type(pd.returndef,false);
  887. if popclass then
  888. symtablestack.pop(pd._class.symtable);
  889. dec(testcurobject);
  890. if (target_info.system in [system_m68k_amiga]) then
  891. begin
  892. if (idtoken=_LOCATION) then
  893. begin
  894. if po_explicitparaloc in pd.procoptions then
  895. begin
  896. consume(_LOCATION);
  897. locationstr:=pattern;
  898. consume(_CSTRING);
  899. end
  900. else
  901. { I guess this needs a new message... (KB) }
  902. Message(parser_e_paraloc_all_paras);
  903. end
  904. else
  905. begin
  906. if po_explicitparaloc in pd.procoptions then
  907. { assign default locationstr, if none specified }
  908. { and we've arguments with explicit paraloc }
  909. locationstr:='D0';
  910. end;
  911. end;
  912. end
  913. else
  914. begin
  915. if (
  916. parse_only and
  917. not(is_interface(pd._class))
  918. ) or
  919. (m_repeat_forward in current_settings.modeswitches) then
  920. begin
  921. consume(_COLON);
  922. consume_all_until(_SEMICOLON);
  923. end;
  924. end;
  925. if isclassmethod then
  926. include(pd.procoptions,po_classmethod);
  927. end;
  928. end
  929. else
  930. begin
  931. { recover }
  932. consume(_COLON);
  933. consume_all_until(_SEMICOLON);
  934. end;
  935. end;
  936. _PROCEDURE :
  937. begin
  938. consume(_PROCEDURE);
  939. if parse_proc_head(aclass,potype_procedure,pd) then
  940. begin
  941. { pd=nil when it is a interface mapping }
  942. if assigned(pd) then
  943. begin
  944. pd.returndef:=voidtype;
  945. if isclassmethod then
  946. include(pd.procoptions,po_classmethod);
  947. end;
  948. end;
  949. end;
  950. _CONSTRUCTOR :
  951. begin
  952. consume(_CONSTRUCTOR);
  953. parse_proc_head(aclass,potype_constructor,pd);
  954. if assigned(pd) and
  955. assigned(pd._class) then
  956. begin
  957. { Set return type, class constructors return the
  958. created instance, object constructors return boolean }
  959. if is_class(pd._class) then
  960. pd.returndef:=pd._class
  961. else
  962. {$ifdef CPU64bitaddr}
  963. pd.returndef:=bool64type;
  964. {$else CPU64bitaddr}
  965. pd.returndef:=bool32type;
  966. {$endif CPU64bitaddr}
  967. end;
  968. end;
  969. _DESTRUCTOR :
  970. begin
  971. consume(_DESTRUCTOR);
  972. parse_proc_head(aclass,potype_destructor,pd);
  973. if assigned(pd) then
  974. pd.returndef:=voidtype;
  975. end;
  976. _OPERATOR :
  977. begin
  978. consume(_OPERATOR);
  979. if (token in [first_overloaded..last_overloaded]) then
  980. begin
  981. optoken:=token;
  982. end
  983. else
  984. begin
  985. case token of
  986. _CARET:
  987. Message1(parser_e_overload_operator_failed,'**');
  988. _UNEQUAL:
  989. Message1(parser_e_overload_operator_failed,'=');
  990. else
  991. Message1(parser_e_overload_operator_failed,'');
  992. end;
  993. { Use the dummy NOTOKEN that is also declared
  994. for the overloaded_operator[] }
  995. optoken:=NOTOKEN;
  996. end;
  997. consume(token);
  998. parse_proc_head(aclass,potype_operator,pd);
  999. if assigned(pd) then
  1000. begin
  1001. if pd.parast.symtablelevel>normal_function_level then
  1002. Message(parser_e_no_local_operator);
  1003. if token<>_ID then
  1004. begin
  1005. if not(m_result in current_settings.modeswitches) then
  1006. consume(_ID);
  1007. end
  1008. else
  1009. begin
  1010. pd.resultname:=stringdup(orgpattern);
  1011. consume(_ID);
  1012. end;
  1013. if not try_to_consume(_COLON) then
  1014. begin
  1015. consume(_COLON);
  1016. pd.returndef:=generrordef;
  1017. consume_all_until(_SEMICOLON);
  1018. end
  1019. else
  1020. begin
  1021. single_type(pd.returndef,false);
  1022. if (optoken in [_EQUAL,_GT,_LT,_GTE,_LTE]) and
  1023. ((pd.returndef.typ<>orddef) or
  1024. (torddef(pd.returndef).ordtype<>pasbool)) then
  1025. Message(parser_e_comparative_operator_return_boolean);
  1026. if (optoken=_ASSIGNMENT) and
  1027. equal_defs(pd.returndef,tparavarsym(pd.parast.SymList[0]).vardef) then
  1028. message(parser_e_no_such_assignment)
  1029. else if not isoperatoracceptable(pd,optoken) then
  1030. Message(parser_e_overload_impossible);
  1031. end;
  1032. end
  1033. else
  1034. begin
  1035. { recover }
  1036. try_to_consume(_ID);
  1037. consume(_COLON);
  1038. consume_all_until(_SEMICOLON);
  1039. end;
  1040. end;
  1041. end;
  1042. { file types can't be function results }
  1043. if assigned(pd) and
  1044. (pd.returndef.typ=filedef) then
  1045. message(parser_e_illegal_function_result);
  1046. { support procedure proc stdcall export; }
  1047. if not(check_proc_directive(false)) then
  1048. consume(_SEMICOLON);
  1049. result:=pd;
  1050. if locationstr<>'' then
  1051. begin
  1052. if not(paramanager.parsefuncretloc(pd,upper(locationstr))) then
  1053. { I guess this needs a new message... (KB) }
  1054. message(parser_e_illegal_explicit_paraloc);
  1055. end;
  1056. end;
  1057. {****************************************************************************
  1058. Procedure directive handlers
  1059. ****************************************************************************}
  1060. procedure pd_far(pd:tabstractprocdef);
  1061. begin
  1062. Message1(parser_w_proc_directive_ignored,'FAR');
  1063. end;
  1064. procedure pd_near(pd:tabstractprocdef);
  1065. begin
  1066. Message1(parser_w_proc_directive_ignored,'NEAR');
  1067. end;
  1068. procedure pd_export(pd:tabstractprocdef);
  1069. begin
  1070. if pd.typ<>procdef then
  1071. internalerror(200304264);
  1072. if assigned(tprocdef(pd)._class) then
  1073. Message(parser_e_methods_dont_be_export);
  1074. if pd.parast.symtablelevel>normal_function_level then
  1075. Message(parser_e_dont_nest_export);
  1076. end;
  1077. procedure pd_forward(pd:tabstractprocdef);
  1078. begin
  1079. if pd.typ<>procdef then
  1080. internalerror(200304265);
  1081. tprocdef(pd).forwarddef:=true;
  1082. end;
  1083. procedure pd_alias(pd:tabstractprocdef);
  1084. begin
  1085. if pd.typ<>procdef then
  1086. internalerror(200304266);
  1087. consume(_COLON);
  1088. tprocdef(pd).aliasnames.insert(get_stringconst);
  1089. include(pd.procoptions,po_has_public_name);
  1090. end;
  1091. procedure pd_public(pd:tabstractprocdef);
  1092. begin
  1093. if pd.typ<>procdef then
  1094. internalerror(200304266);
  1095. if try_to_consume(_NAME) then
  1096. begin
  1097. tprocdef(pd).aliasnames.insert(get_stringconst);
  1098. include(pd.procoptions,po_has_public_name);
  1099. end;
  1100. end;
  1101. procedure pd_asmname(pd:tabstractprocdef);
  1102. begin
  1103. if pd.typ<>procdef then
  1104. internalerror(200304267);
  1105. tprocdef(pd).aliasnames.insert(target_info.Cprefix+pattern);
  1106. if token=_CCHAR then
  1107. consume(_CCHAR)
  1108. else
  1109. consume(_CSTRING);
  1110. { we don't need anything else }
  1111. tprocdef(pd).forwarddef:=false;
  1112. end;
  1113. procedure pd_inline(pd:tabstractprocdef);
  1114. begin
  1115. { Check if there are parameters that can't be inlined }
  1116. pd.parast.SymList.ForEachCall(@check_inline_para,pd);
  1117. end;
  1118. procedure pd_internconst(pd:tabstractprocdef);
  1119. var v:Tconstexprint;
  1120. begin
  1121. if pd.typ<>procdef then
  1122. internalerror(200304268);
  1123. consume(_COLON);
  1124. v:=get_intconst;
  1125. if (v<int64(low(longint))) or (v>int64(high(longint))) then
  1126. message(parser_e_range_check_error)
  1127. else
  1128. Tprocdef(pd).extnumber:=longint(v.svalue);
  1129. end;
  1130. procedure pd_internproc(pd:tabstractprocdef);
  1131. var v:Tconstexprint;
  1132. begin
  1133. if pd.typ<>procdef then
  1134. internalerror(200304268);
  1135. consume(_COLON);
  1136. v:=get_intconst;
  1137. if (v<int64(low(longint))) or (v>int64(high(longint))) then
  1138. message(parser_e_range_check_error)
  1139. else
  1140. Tprocdef(pd).extnumber:=longint(v.svalue);
  1141. { the proc is defined }
  1142. tprocdef(pd).forwarddef:=false;
  1143. end;
  1144. procedure pd_interrupt(pd:tabstractprocdef);
  1145. begin
  1146. if pd.parast.symtablelevel>normal_function_level then
  1147. Message(parser_e_dont_nest_interrupt);
  1148. end;
  1149. procedure pd_abstract(pd:tabstractprocdef);
  1150. begin
  1151. if pd.typ<>procdef then
  1152. internalerror(200304269);
  1153. if (po_virtualmethod in pd.procoptions) then
  1154. include(pd.procoptions,po_abstractmethod)
  1155. else
  1156. Message(parser_e_only_virtual_methods_abstract);
  1157. { the method is defined }
  1158. tprocdef(pd).forwarddef:=false;
  1159. end;
  1160. procedure pd_virtual(pd:tabstractprocdef);
  1161. {$ifdef WITHDMT}
  1162. var
  1163. pt : tnode;
  1164. {$endif WITHDMT}
  1165. begin
  1166. if pd.typ<>procdef then
  1167. internalerror(2003042610);
  1168. if (pd.proctypeoption=potype_constructor) and
  1169. is_object(tprocdef(pd)._class) then
  1170. Message(parser_e_constructor_cannot_be_not_virtual);
  1171. {$ifdef WITHDMT}
  1172. if is_object(tprocdef(pd)._class) and
  1173. (token<>_SEMICOLON) then
  1174. begin
  1175. { any type of parameter is allowed here! }
  1176. pt:=comp_expr(true);
  1177. if is_constintnode(pt) then
  1178. begin
  1179. include(pd.procoptions,po_msgint);
  1180. pd.messageinf.i:=pt.value;
  1181. end
  1182. else
  1183. Message(parser_e_ill_msg_expr);
  1184. disposetree(pt);
  1185. end;
  1186. {$endif WITHDMT}
  1187. end;
  1188. procedure pd_dispid(pd:tabstractprocdef);
  1189. var pt:Tnode;
  1190. begin
  1191. if pd.typ<>procdef then
  1192. internalerror(200604301);
  1193. pt:=comp_expr(true);
  1194. if is_constintnode(pt) then
  1195. if (Tordconstnode(pt).value<int64(low(longint))) or (Tordconstnode(pt).value>int64(high(longint))) then
  1196. message(parser_e_range_check_error)
  1197. else
  1198. Tprocdef(pd).dispid:=Tordconstnode(pt).value.svalue
  1199. else
  1200. message(parser_e_dispid_must_be_ord_const);
  1201. pt.free;
  1202. end;
  1203. procedure pd_static(pd:tabstractprocdef);
  1204. begin
  1205. if (cs_static_keyword in current_settings.moduleswitches) then
  1206. begin
  1207. if pd.typ=procdef then
  1208. include(tprocdef(pd).procsym.symoptions,sp_static);
  1209. include(pd.procoptions,po_staticmethod);
  1210. end;
  1211. end;
  1212. procedure pd_override(pd:tabstractprocdef);
  1213. begin
  1214. if pd.typ<>procdef then
  1215. internalerror(2003042611);
  1216. if not(is_class_or_interface(tprocdef(pd)._class)) then
  1217. Message(parser_e_no_object_override);
  1218. end;
  1219. procedure pd_overload(pd:tabstractprocdef);
  1220. begin
  1221. if pd.typ<>procdef then
  1222. internalerror(2003042612);
  1223. include(tprocdef(pd).procsym.symoptions,sp_has_overloaded);
  1224. end;
  1225. procedure pd_message(pd:tabstractprocdef);
  1226. var
  1227. pt : tnode;
  1228. paracnt : longint;
  1229. begin
  1230. if pd.typ<>procdef then
  1231. internalerror(2003042613);
  1232. if not is_class(tprocdef(pd)._class) then
  1233. Message(parser_e_msg_only_for_classes);
  1234. { check parameter type }
  1235. paracnt:=0;
  1236. pd.parast.SymList.ForEachCall(@check_msg_para,@paracnt);
  1237. if paracnt<>1 then
  1238. Message(parser_e_ill_msg_param);
  1239. pt:=comp_expr(true);
  1240. if pt.nodetype=stringconstn then
  1241. begin
  1242. include(pd.procoptions,po_msgstr);
  1243. tprocdef(pd).messageinf.str:=stringdup(tstringconstnode(pt).value_str);
  1244. end
  1245. else
  1246. if is_constintnode(pt) then
  1247. begin
  1248. include(pd.procoptions,po_msgint);
  1249. if (Tordconstnode(pt).value<int64(low(Tprocdef(pd).messageinf.i))) or
  1250. (Tordconstnode(pt).value>int64(high(Tprocdef(pd).messageinf.i))) then
  1251. message(parser_e_range_check_error)
  1252. else
  1253. Tprocdef(pd).messageinf.i:=tordconstnode(pt).value.svalue;
  1254. end
  1255. else
  1256. Message(parser_e_ill_msg_expr);
  1257. pt.free;
  1258. end;
  1259. procedure pd_reintroduce(pd:tabstractprocdef);
  1260. begin
  1261. if pd.typ<>procdef then
  1262. internalerror(200401211);
  1263. if not(is_class_or_interface(tprocdef(pd)._class)) then
  1264. Message(parser_e_no_object_reintroduce);
  1265. end;
  1266. procedure pd_syscall(pd:tabstractprocdef);
  1267. {$if defined(powerpc) or defined(m68k)}
  1268. var
  1269. vs : tparavarsym;
  1270. sym : tsym;
  1271. symtable : TSymtable;
  1272. v: Tconstexprint;
  1273. {$endif defined(powerpc) or defined(m68k)}
  1274. begin
  1275. if (pd.typ<>procdef) and (target_info.system <> system_powerpc_amiga) then
  1276. internalerror(2003042614);
  1277. tprocdef(pd).forwarddef:=false;
  1278. {$ifdef m68k}
  1279. if target_info.system in [system_m68k_amiga] then
  1280. begin
  1281. include(pd.procoptions,po_syscall_legacy);
  1282. if consume_sym(sym,symtable) then
  1283. begin
  1284. if (sym.typ=staticvarsym) and
  1285. (
  1286. (tabstractvarsym(sym).vardef.typ=pointerdef) or
  1287. is_32bitint(tabstractvarsym(sym).vardef)
  1288. ) then
  1289. begin
  1290. tprocdef(pd).libsym:=sym;
  1291. if po_syscall_legacy in tprocdef(pd).procoptions then
  1292. begin
  1293. vs:=tparavarsym.create('$syscalllib',paranr_syscall_legacy,vs_value,tabstractvarsym(sym).vardef,[vo_is_syscall_lib,vo_is_hidden_para,vo_has_explicit_paraloc]);
  1294. paramanager.parseparaloc(vs,'A6');
  1295. pd.parast.insert(vs);
  1296. end
  1297. end
  1298. else
  1299. Message(parser_e_32bitint_or_pointer_variable_expected);
  1300. end;
  1301. (paramanager as tm68kparamanager).create_funcretloc_info(pd,calleeside);
  1302. (paramanager as tm68kparamanager).create_funcretloc_info(pd,callerside);
  1303. v:=get_intconst;
  1304. if (v<low(Tprocdef(pd).extnumber)) or (v>high(Tprocdef(pd).extnumber)) then
  1305. message(parser_e_range_check_error)
  1306. else
  1307. Tprocdef(pd).extnumber:=v.uvalue;
  1308. end;
  1309. {$endif m68k}
  1310. {$ifdef powerpc}
  1311. if target_info.system = system_powerpc_amiga then
  1312. begin
  1313. include(pd.procoptions,po_syscall_basesysv);
  1314. if consume_sym(sym,symtable) then
  1315. begin
  1316. if (sym.typ=staticvarsym) and
  1317. (
  1318. (tabstractvarsym(sym).vardef.typ=pointerdef) or
  1319. is_32bitint(tabstractvarsym(sym).vardef)
  1320. ) then
  1321. begin
  1322. tprocdef(pd).libsym:=sym;
  1323. vs:=tparavarsym.create('$syscalllib',paranr_syscall_basesysv,vs_value,tabstractvarsym(sym).vardef,[vo_is_syscall_lib,vo_is_hidden_para]);
  1324. pd.parast.insert(vs);
  1325. end
  1326. else
  1327. Message(parser_e_32bitint_or_pointer_variable_expected);
  1328. end;
  1329. (paramanager as tppcparamanager).create_funcretloc_info(pd,calleeside);
  1330. (paramanager as tppcparamanager).create_funcretloc_info(pd,callerside);
  1331. v:=get_intconst;
  1332. if (v<low(Tprocdef(pd).extnumber)) or (v>high(Tprocdef(pd).extnumber)) then
  1333. message(parser_e_range_check_error)
  1334. else
  1335. Tprocdef(pd).extnumber:=v.uvalue;
  1336. end else
  1337. if target_info.system = system_powerpc_morphos then
  1338. begin
  1339. if idtoken=_LEGACY then
  1340. begin
  1341. consume(_LEGACY);
  1342. include(pd.procoptions,po_syscall_legacy);
  1343. end
  1344. else if idtoken=_SYSV then
  1345. begin
  1346. consume(_SYSV);
  1347. include(pd.procoptions,po_syscall_sysv);
  1348. end
  1349. else if idtoken=_BASESYSV then
  1350. begin
  1351. consume(_BASESYSV);
  1352. include(pd.procoptions,po_syscall_basesysv);
  1353. end
  1354. else if idtoken=_SYSVBASE then
  1355. begin
  1356. consume(_SYSVBASE);
  1357. include(pd.procoptions,po_syscall_sysvbase);
  1358. end
  1359. else if idtoken=_R12BASE then
  1360. begin
  1361. consume(_R12BASE);
  1362. include(pd.procoptions,po_syscall_r12base);
  1363. end
  1364. else
  1365. if syscall_convention='LEGACY' then
  1366. include(pd.procoptions,po_syscall_legacy)
  1367. else if syscall_convention='SYSV' then
  1368. include(pd.procoptions,po_syscall_sysv)
  1369. else if syscall_convention='BASESYSV' then
  1370. include(pd.procoptions,po_syscall_basesysv)
  1371. else if syscall_convention='SYSVBASE' then
  1372. include(pd.procoptions,po_syscall_sysvbase)
  1373. else if syscall_convention='R12BASE' then
  1374. include(pd.procoptions,po_syscall_r12base)
  1375. else
  1376. internalerror(2005010404);
  1377. if consume_sym(sym,symtable) then
  1378. begin
  1379. if (sym.typ=staticvarsym) and
  1380. (
  1381. (tabstractvarsym(sym).vardef.typ=pointerdef) or
  1382. is_32bitint(tabstractvarsym(sym).vardef)
  1383. ) then
  1384. begin
  1385. tprocdef(pd).libsym:=sym;
  1386. if po_syscall_legacy in tprocdef(pd).procoptions then
  1387. begin
  1388. vs:=tparavarsym.create('$syscalllib',paranr_syscall_legacy,vs_value,tabstractvarsym(sym).vardef,[vo_is_syscall_lib,vo_is_hidden_para,vo_has_explicit_paraloc]);
  1389. paramanager.parseparaloc(vs,'A6');
  1390. pd.parast.insert(vs);
  1391. end
  1392. else if po_syscall_sysv in tprocdef(pd).procoptions then
  1393. begin
  1394. { Nothing to be done for sysv here for now, but this might change }
  1395. end
  1396. else if po_syscall_basesysv in tprocdef(pd).procoptions then
  1397. begin
  1398. vs:=tparavarsym.create('$syscalllib',paranr_syscall_basesysv,vs_value,tabstractvarsym(sym).vardef,[vo_is_syscall_lib,vo_is_hidden_para]);
  1399. pd.parast.insert(vs);
  1400. end
  1401. else if po_syscall_sysvbase in tprocdef(pd).procoptions then
  1402. begin
  1403. vs:=tparavarsym.create('$syscalllib',paranr_syscall_sysvbase,vs_value,tabstractvarsym(sym).vardef,[vo_is_syscall_lib,vo_is_hidden_para]);
  1404. pd.parast.insert(vs);
  1405. end
  1406. else if po_syscall_r12base in tprocdef(pd).procoptions then
  1407. begin
  1408. vs:=tparavarsym.create('$syscalllib',paranr_syscall_r12base,vs_value,tabstractvarsym(sym).vardef,[vo_is_syscall_lib,vo_is_hidden_para,vo_has_explicit_paraloc]);
  1409. paramanager.parseparaloc(vs,'R12');
  1410. pd.parast.insert(vs);
  1411. end
  1412. else
  1413. internalerror(2005010501);
  1414. end
  1415. else
  1416. Message(parser_e_32bitint_or_pointer_variable_expected);
  1417. end;
  1418. (paramanager as tppcparamanager).create_funcretloc_info(pd,calleeside);
  1419. (paramanager as tppcparamanager).create_funcretloc_info(pd,callerside);
  1420. v:=get_intconst;
  1421. if (v<low(Tprocdef(pd).extnumber)) or (v>high(Tprocdef(pd).extnumber)) then
  1422. message(parser_e_range_check_error)
  1423. else
  1424. Tprocdef(pd).extnumber:=v.uvalue;
  1425. end;
  1426. {$endif powerpc}
  1427. end;
  1428. procedure pd_external(pd:tabstractprocdef);
  1429. {
  1430. If import_dll=nil the procedure is assumed to be in another
  1431. object file. In that object file it should have the name to
  1432. which import_name is pointing to. Otherwise, the procedure is
  1433. assumed to be in the DLL to which import_dll is pointing to. In
  1434. that case either import_nr<>0 or import_name<>nil is true, so
  1435. the procedure is either imported by number or by name. (DM)
  1436. }
  1437. var
  1438. hs : string;
  1439. v:Tconstexprint;
  1440. begin
  1441. if pd.typ<>procdef then
  1442. internalerror(2003042615);
  1443. with tprocdef(pd) do
  1444. begin
  1445. forwarddef:=false;
  1446. { forbid local external procedures }
  1447. if parast.symtablelevel>normal_function_level then
  1448. Message(parser_e_no_local_proc_external);
  1449. { If the procedure should be imported from a DLL, a constant string follows.
  1450. This isn't really correct, an contant string expression follows
  1451. so we check if an semicolon follows, else a string constant have to
  1452. follow (FK) }
  1453. if not(token=_SEMICOLON) and not(idtoken=_NAME) then
  1454. begin
  1455. { Always add library prefix and suffix to create an uniform name }
  1456. hs:=get_stringconst;
  1457. if ExtractFileExt(hs)='' then
  1458. hs:=ChangeFileExt(hs,target_info.sharedlibext);
  1459. if Copy(hs,1,length(target_info.sharedlibprefix))<>target_info.sharedlibprefix then
  1460. hs:=target_info.sharedlibprefix+hs;
  1461. import_dll:=stringdup(hs);
  1462. include(procoptions,po_has_importdll);
  1463. if (idtoken=_NAME) then
  1464. begin
  1465. consume(_NAME);
  1466. import_name:=stringdup(get_stringconst);
  1467. include(procoptions,po_has_importname);
  1468. if import_name^='' then
  1469. message(parser_e_empty_import_name);
  1470. end;
  1471. if (idtoken=_INDEX) then
  1472. begin
  1473. {After the word index follows the index number in the DLL.}
  1474. consume(_INDEX);
  1475. v:=get_intconst;
  1476. if (v<int64(low(import_nr))) or (v>int64(high(import_nr))) then
  1477. message(parser_e_range_check_error)
  1478. else
  1479. import_nr:=longint(v.svalue);
  1480. end;
  1481. { default is to used the realname of the procedure }
  1482. if (import_nr=0) and not assigned(import_name) then
  1483. begin
  1484. import_name:=stringdup(procsym.realname);
  1485. include(procoptions,po_has_importname);
  1486. end;
  1487. end
  1488. else
  1489. begin
  1490. if (idtoken=_NAME) then
  1491. begin
  1492. consume(_NAME);
  1493. import_name:=stringdup(get_stringconst);
  1494. include(procoptions,po_has_importname);
  1495. if import_name^='' then
  1496. message(parser_e_empty_import_name);
  1497. end;
  1498. end;
  1499. end;
  1500. end;
  1501. type
  1502. pd_handler=procedure(pd:tabstractprocdef);
  1503. proc_dir_rec=record
  1504. idtok : ttoken;
  1505. pd_flags : tpdflags;
  1506. handler : pd_handler;
  1507. pocall : tproccalloption;
  1508. pooption : tprocoptions;
  1509. mutexclpocall : tproccalloptions;
  1510. mutexclpotype : tproctypeoptions;
  1511. mutexclpo : tprocoptions;
  1512. end;
  1513. const
  1514. {Should contain the number of procedure directives we support.}
  1515. num_proc_directives=39;
  1516. proc_direcdata:array[1..num_proc_directives] of proc_dir_rec=
  1517. (
  1518. (
  1519. idtok:_ABSTRACT;
  1520. pd_flags : [pd_interface,pd_object,pd_notobjintf];
  1521. handler : @pd_abstract;
  1522. pocall : pocall_none;
  1523. pooption : [po_abstractmethod];
  1524. mutexclpocall : [pocall_internproc];
  1525. mutexclpotype : [];
  1526. mutexclpo : [po_exports,po_interrupt,po_external,po_inline]
  1527. ),(
  1528. idtok:_ALIAS;
  1529. pd_flags : [pd_implemen,pd_body,pd_notobjintf];
  1530. handler : @pd_alias;
  1531. pocall : pocall_none;
  1532. pooption : [];
  1533. mutexclpocall : [];
  1534. mutexclpotype : [];
  1535. mutexclpo : [po_external,po_inline]
  1536. ),(
  1537. idtok:_ASMNAME;
  1538. pd_flags : [pd_interface,pd_implemen,pd_notobjintf];
  1539. handler : @pd_asmname;
  1540. pocall : pocall_cdecl;
  1541. pooption : [po_external];
  1542. mutexclpocall : [pocall_internproc];
  1543. mutexclpotype : [];
  1544. mutexclpo : [po_external,po_inline]
  1545. ),(
  1546. idtok:_ASSEMBLER;
  1547. pd_flags : [pd_interface,pd_implemen,pd_body,pd_notobjintf];
  1548. handler : nil;
  1549. pocall : pocall_none;
  1550. pooption : [po_assembler];
  1551. mutexclpocall : [];
  1552. mutexclpotype : [];
  1553. mutexclpo : [po_external]
  1554. ),(
  1555. idtok:_C; {same as cdecl for mode mac}
  1556. pd_flags : [pd_interface,pd_implemen,pd_body,pd_procvar];
  1557. handler : nil;
  1558. pocall : pocall_cdecl;
  1559. pooption : [];
  1560. mutexclpocall : [];
  1561. mutexclpotype : [potype_constructor,potype_destructor];
  1562. mutexclpo : [po_assembler,po_external]
  1563. ),(
  1564. idtok:_CDECL;
  1565. pd_flags : [pd_interface,pd_implemen,pd_body,pd_procvar];
  1566. handler : nil;
  1567. pocall : pocall_cdecl;
  1568. pooption : [];
  1569. mutexclpocall : [];
  1570. mutexclpotype : [potype_constructor,potype_destructor];
  1571. mutexclpo : [po_assembler,po_external]
  1572. ),(
  1573. idtok:_DISPID;
  1574. pd_flags : [pd_dispinterface];
  1575. handler : @pd_dispid;
  1576. pocall : pocall_none;
  1577. pooption : [po_dispid];
  1578. mutexclpocall : [pocall_internproc];
  1579. mutexclpotype : [potype_constructor,potype_destructor,potype_operator];
  1580. mutexclpo : [po_interrupt,po_external,po_inline]
  1581. ),(
  1582. idtok:_DYNAMIC;
  1583. pd_flags : [pd_interface,pd_object,pd_notobjintf];
  1584. handler : @pd_virtual;
  1585. pocall : pocall_none;
  1586. pooption : [po_virtualmethod];
  1587. mutexclpocall : [pocall_internproc];
  1588. mutexclpotype : [];
  1589. mutexclpo : [po_exports,po_interrupt,po_external,po_overridingmethod,po_inline]
  1590. ),(
  1591. idtok:_EXPORT;
  1592. pd_flags : [pd_body,pd_interface,pd_implemen,pd_notobjintf];
  1593. handler : @pd_export;
  1594. pocall : pocall_none;
  1595. pooption : [po_exports,po_global];
  1596. mutexclpocall : [pocall_internproc];
  1597. mutexclpotype : [potype_constructor,potype_destructor];
  1598. mutexclpo : [po_external,po_interrupt,po_inline]
  1599. ),(
  1600. idtok:_EXTERNAL;
  1601. pd_flags : [pd_implemen,pd_interface,pd_notobject,pd_notobjintf,pd_cppobject];
  1602. handler : @pd_external;
  1603. pocall : pocall_none;
  1604. pooption : [po_external];
  1605. mutexclpocall : [pocall_internproc,pocall_syscall];
  1606. { allowed for external cpp classes }
  1607. mutexclpotype : [{potype_constructor,potype_destructor}];
  1608. mutexclpo : [po_public,po_exports,po_interrupt,po_assembler,po_inline]
  1609. ),(
  1610. idtok:_FAR;
  1611. pd_flags : [pd_implemen,pd_body,pd_interface,pd_procvar,pd_notobject,pd_notobjintf];
  1612. handler : @pd_far;
  1613. pocall : pocall_none;
  1614. pooption : [];
  1615. mutexclpocall : [pocall_internproc];
  1616. mutexclpotype : [];
  1617. mutexclpo : [po_inline]
  1618. ),(
  1619. idtok:_FAR16;
  1620. pd_flags : [pd_interface,pd_implemen,pd_body,pd_procvar,pd_notobject];
  1621. handler : nil;
  1622. pocall : pocall_far16;
  1623. pooption : [];
  1624. mutexclpocall : [];
  1625. mutexclpotype : [];
  1626. mutexclpo : [po_external]
  1627. ),(
  1628. idtok:_FORWARD;
  1629. pd_flags : [pd_implemen,pd_notobject,pd_notobjintf];
  1630. handler : @pd_forward;
  1631. pocall : pocall_none;
  1632. pooption : [];
  1633. mutexclpocall : [pocall_internproc];
  1634. mutexclpotype : [];
  1635. mutexclpo : [po_external,po_inline]
  1636. ),(
  1637. idtok:_OLDFPCCALL;
  1638. pd_flags : [pd_interface,pd_implemen,pd_body,pd_procvar];
  1639. handler : nil;
  1640. pocall : pocall_oldfpccall;
  1641. pooption : [];
  1642. mutexclpocall : [];
  1643. mutexclpotype : [];
  1644. mutexclpo : []
  1645. ),(
  1646. idtok:_INLINE;
  1647. pd_flags : [pd_interface,pd_implemen,pd_body,pd_notobjintf];
  1648. handler : @pd_inline;
  1649. pocall : pocall_none;
  1650. pooption : [po_inline];
  1651. mutexclpocall : [];
  1652. mutexclpotype : [potype_constructor,potype_destructor];
  1653. mutexclpo : [po_exports,po_external,po_interrupt,po_virtualmethod]
  1654. ),(
  1655. idtok:_INTERNCONST;
  1656. pd_flags : [pd_interface,pd_body,pd_notobject,pd_notobjintf];
  1657. handler : @pd_internconst;
  1658. pocall : pocall_none;
  1659. pooption : [po_internconst];
  1660. mutexclpocall : [];
  1661. mutexclpotype : [potype_operator];
  1662. mutexclpo : []
  1663. ),(
  1664. idtok:_INTERNPROC;
  1665. pd_flags : [pd_interface,pd_notobject,pd_notobjintf];
  1666. handler : @pd_internproc;
  1667. pocall : pocall_internproc;
  1668. pooption : [];
  1669. mutexclpocall : [];
  1670. mutexclpotype : [potype_constructor,potype_destructor,potype_operator];
  1671. mutexclpo : [po_exports,po_external,po_interrupt,po_assembler,po_iocheck,po_virtualmethod]
  1672. ),(
  1673. idtok:_INTERRUPT;
  1674. pd_flags : [pd_implemen,pd_body,pd_notobject,pd_notobjintf];
  1675. handler : @pd_interrupt;
  1676. pocall : pocall_oldfpccall;
  1677. pooption : [po_interrupt];
  1678. mutexclpocall : [pocall_internproc,pocall_cdecl,pocall_cppdecl,pocall_stdcall,
  1679. pocall_pascal,pocall_far16,pocall_oldfpccall];
  1680. mutexclpotype : [potype_constructor,potype_destructor,potype_operator];
  1681. mutexclpo : [po_external,po_inline]
  1682. ),(
  1683. idtok:_IOCHECK;
  1684. pd_flags : [pd_implemen,pd_body,pd_notobjintf];
  1685. handler : nil;
  1686. pocall : pocall_none;
  1687. pooption : [po_iocheck];
  1688. mutexclpocall : [pocall_internproc];
  1689. mutexclpotype : [];
  1690. mutexclpo : [po_external]
  1691. ),(
  1692. idtok:_LOCAL;
  1693. pd_flags : [pd_implemen,pd_body];
  1694. handler : nil;
  1695. pocall : pocall_none;
  1696. pooption : [po_kylixlocal];
  1697. mutexclpocall : [pocall_internproc,pocall_far16];
  1698. mutexclpotype : [];
  1699. mutexclpo : [po_external,po_exports]
  1700. ),(
  1701. idtok:_MESSAGE;
  1702. pd_flags : [pd_interface,pd_object,pd_notobjintf];
  1703. handler : @pd_message;
  1704. pocall : pocall_none;
  1705. pooption : []; { can be po_msgstr or po_msgint }
  1706. mutexclpocall : [pocall_internproc];
  1707. mutexclpotype : [potype_constructor,potype_destructor,potype_operator];
  1708. mutexclpo : [po_interrupt,po_external,po_inline]
  1709. ),(
  1710. idtok:_MWPASCAL;
  1711. pd_flags : [pd_interface,pd_implemen,pd_body,pd_procvar];
  1712. handler : nil;
  1713. pocall : pocall_mwpascal;
  1714. pooption : [];
  1715. mutexclpocall : [];
  1716. mutexclpotype : [];
  1717. mutexclpo : []
  1718. ),(
  1719. idtok:_NEAR;
  1720. pd_flags : [pd_implemen,pd_body,pd_procvar,pd_notobjintf];
  1721. handler : @pd_near;
  1722. pocall : pocall_none;
  1723. pooption : [];
  1724. mutexclpocall : [pocall_internproc];
  1725. mutexclpotype : [];
  1726. mutexclpo : []
  1727. ),(
  1728. idtok:_NOSTACKFRAME;
  1729. pd_flags : [pd_implemen,pd_body,pd_procvar,pd_notobjintf];
  1730. handler : nil;
  1731. pocall : pocall_none;
  1732. pooption : [po_nostackframe];
  1733. mutexclpocall : [pocall_internproc];
  1734. mutexclpotype : [];
  1735. mutexclpo : []
  1736. ),(
  1737. idtok:_OVERLOAD;
  1738. pd_flags : [pd_implemen,pd_interface,pd_body];
  1739. handler : @pd_overload;
  1740. pocall : pocall_none;
  1741. pooption : [po_overload];
  1742. mutexclpocall : [pocall_internproc];
  1743. mutexclpotype : [];
  1744. mutexclpo : []
  1745. ),(
  1746. idtok:_OVERRIDE;
  1747. pd_flags : [pd_interface,pd_object,pd_notobjintf];
  1748. handler : @pd_override;
  1749. pocall : pocall_none;
  1750. pooption : [po_overridingmethod,po_virtualmethod];
  1751. mutexclpocall : [pocall_internproc];
  1752. mutexclpotype : [];
  1753. mutexclpo : [po_exports,po_external,po_interrupt,po_virtualmethod,po_inline]
  1754. ),(
  1755. idtok:_PASCAL;
  1756. pd_flags : [pd_interface,pd_implemen,pd_body,pd_procvar];
  1757. handler : nil;
  1758. pocall : pocall_pascal;
  1759. pooption : [];
  1760. mutexclpocall : [];
  1761. mutexclpotype : [potype_constructor,potype_destructor];
  1762. mutexclpo : [po_external]
  1763. ),(
  1764. idtok:_PUBLIC;
  1765. pd_flags : [pd_interface,pd_implemen,pd_body,pd_notobject,pd_notobjintf];
  1766. handler : @pd_public;
  1767. pocall : pocall_none;
  1768. pooption : [po_public,po_global];
  1769. mutexclpocall : [pocall_internproc];
  1770. mutexclpotype : [];
  1771. mutexclpo : [po_external,po_inline]
  1772. ),(
  1773. idtok:_REGISTER;
  1774. pd_flags : [pd_interface,pd_implemen,pd_body,pd_procvar];
  1775. handler : nil;
  1776. pocall : pocall_register;
  1777. pooption : [];
  1778. mutexclpocall : [];
  1779. mutexclpotype : [potype_constructor,potype_destructor];
  1780. mutexclpo : [po_external]
  1781. ),(
  1782. idtok:_REINTRODUCE;
  1783. pd_flags : [pd_interface,pd_object,pd_notobjintf];
  1784. handler : @pd_reintroduce;
  1785. pocall : pocall_none;
  1786. pooption : [po_reintroduce];
  1787. mutexclpocall : [pocall_internproc];
  1788. mutexclpotype : [];
  1789. mutexclpo : [po_external,po_interrupt,po_exports,po_overridingmethod,po_inline]
  1790. ),(
  1791. idtok:_SAFECALL;
  1792. pd_flags : [pd_interface,pd_implemen,pd_body,pd_procvar];
  1793. handler : nil;
  1794. pocall : pocall_safecall;
  1795. pooption : [];
  1796. mutexclpocall : [];
  1797. mutexclpotype : [potype_constructor,potype_destructor];
  1798. mutexclpo : [po_external]
  1799. ),(
  1800. idtok:_SOFTFLOAT;
  1801. pd_flags : [pd_interface,pd_implemen,pd_body,pd_procvar];
  1802. handler : nil;
  1803. pocall : pocall_softfloat;
  1804. pooption : [];
  1805. mutexclpocall : [];
  1806. mutexclpotype : [potype_constructor,potype_destructor];
  1807. { it's available with po_external because the libgcc floating point routines on the arm
  1808. uses this calling convention }
  1809. mutexclpo : []
  1810. ),(
  1811. idtok:_STATIC;
  1812. pd_flags : [pd_interface,pd_object,pd_notobjintf];
  1813. handler : @pd_static;
  1814. pocall : pocall_none;
  1815. pooption : [po_staticmethod];
  1816. mutexclpocall : [pocall_internproc];
  1817. mutexclpotype : [potype_constructor,potype_destructor];
  1818. mutexclpo : [po_external,po_interrupt,po_exports,po_inline]
  1819. ),(
  1820. idtok:_STDCALL;
  1821. pd_flags : [pd_interface,pd_implemen,pd_body,pd_procvar];
  1822. handler : nil;
  1823. pocall : pocall_stdcall;
  1824. pooption : [];
  1825. mutexclpocall : [];
  1826. mutexclpotype : [potype_constructor,potype_destructor];
  1827. mutexclpo : [po_external]
  1828. ),(
  1829. idtok:_SYSCALL;
  1830. { Different kind of syscalls are valid for AOS68k, AOSPPC and MOS. }
  1831. { FIX ME!!! MorphOS/AOS68k pd_flags should be:
  1832. pd_interface, pd_implemen, pd_notobject, pd_notobjintf (KB) }
  1833. pd_flags : [pd_interface,pd_implemen,pd_procvar];
  1834. handler : @pd_syscall;
  1835. pocall : pocall_syscall;
  1836. pooption : [];
  1837. mutexclpocall : [];
  1838. mutexclpotype : [potype_constructor,potype_destructor];
  1839. mutexclpo : [po_external,po_assembler,po_interrupt,po_exports]
  1840. ),(
  1841. idtok:_VIRTUAL;
  1842. pd_flags : [pd_interface,pd_object,pd_notobjintf];
  1843. handler : @pd_virtual;
  1844. pocall : pocall_none;
  1845. pooption : [po_virtualmethod];
  1846. mutexclpocall : [pocall_internproc];
  1847. mutexclpotype : [];
  1848. mutexclpo : [po_external,po_interrupt,po_exports,po_overridingmethod,po_inline]
  1849. ),(
  1850. idtok:_CPPDECL;
  1851. pd_flags : [pd_interface,pd_implemen,pd_body,pd_procvar];
  1852. handler : nil;
  1853. pocall : pocall_cppdecl;
  1854. pooption : [];
  1855. mutexclpocall : [];
  1856. mutexclpotype : [potype_constructor,potype_destructor];
  1857. mutexclpo : [po_assembler,po_external,po_virtualmethod]
  1858. ),(
  1859. idtok:_VARARGS;
  1860. pd_flags : [pd_interface,pd_implemen,pd_procvar];
  1861. handler : nil;
  1862. pocall : pocall_none;
  1863. pooption : [po_varargs];
  1864. mutexclpocall : [pocall_internproc,pocall_stdcall,pocall_register,
  1865. pocall_far16,pocall_oldfpccall,pocall_mwpascal];
  1866. mutexclpotype : [];
  1867. mutexclpo : [po_assembler,po_interrupt,po_inline]
  1868. ),(
  1869. idtok:_COMPILERPROC;
  1870. pd_flags : [pd_interface,pd_implemen,pd_body,pd_notobjintf];
  1871. handler : nil;
  1872. pocall : pocall_none;
  1873. pooption : [po_compilerproc];
  1874. mutexclpocall : [];
  1875. mutexclpotype : [potype_constructor,potype_destructor];
  1876. mutexclpo : [po_interrupt]
  1877. )
  1878. );
  1879. function check_proc_directive(isprocvar:boolean):boolean;
  1880. var
  1881. i : longint;
  1882. begin
  1883. result:=false;
  1884. for i:=1 to num_proc_directives do
  1885. if proc_direcdata[i].idtok=idtoken then
  1886. begin
  1887. if ((not isprocvar) or
  1888. (pd_procvar in proc_direcdata[i].pd_flags)) and
  1889. { don't eat a public directive in classes }
  1890. not((idtoken=_PUBLIC) and (symtablestack.top.symtabletype=ObjectSymtable)) then
  1891. result:=true;
  1892. exit;
  1893. end;
  1894. end;
  1895. function parse_proc_direc(pd:tabstractprocdef;var pdflags:tpdflags):boolean;
  1896. {
  1897. Parse the procedure directive, returns true if a correct directive is found
  1898. }
  1899. var
  1900. p : longint;
  1901. found : boolean;
  1902. name : TIDString;
  1903. begin
  1904. parse_proc_direc:=false;
  1905. name:=tokeninfo^[idtoken].str;
  1906. found:=false;
  1907. { Hint directive? Then exit immediatly }
  1908. if (m_hintdirective in current_settings.modeswitches) then
  1909. begin
  1910. case idtoken of
  1911. _LIBRARY,
  1912. _PLATFORM,
  1913. _UNIMPLEMENTED,
  1914. _EXPERIMENTAL,
  1915. _DEPRECATED :
  1916. exit;
  1917. end;
  1918. end;
  1919. { C directive is MAC only, because it breaks too much existing code
  1920. on other platforms (PFV) }
  1921. if (idtoken=_C) and
  1922. not(m_mac in current_settings.modeswitches) then
  1923. exit;
  1924. { retrieve data for directive if found }
  1925. for p:=1 to num_proc_directives do
  1926. if proc_direcdata[p].idtok=idtoken then
  1927. begin
  1928. found:=true;
  1929. break;
  1930. end;
  1931. { Check if the procedure directive is known }
  1932. if not found then
  1933. begin
  1934. { parsing a procvar type the name can be any
  1935. next variable !! }
  1936. if ((pdflags * [pd_procvar,pd_object])=[]) and
  1937. not(idtoken=_PROPERTY) then
  1938. Message1(parser_w_unknown_proc_directive_ignored,name);
  1939. exit;
  1940. end;
  1941. { static needs a special treatment }
  1942. if (idtoken=_STATIC) and not (cs_static_keyword in current_settings.moduleswitches) then
  1943. exit;
  1944. { check if method and directive not for object, like public.
  1945. This needs to be checked also for procvars }
  1946. if (pd_notobject in proc_direcdata[p].pd_flags) and
  1947. (symtablestack.top.symtabletype=ObjectSymtable) and
  1948. { directive allowed for cpp classes? }
  1949. not(is_cppclass(tdef(symtablestack.top.defowner)) and (pd_cppobject in proc_direcdata[p].pd_flags)) then
  1950. exit;
  1951. { Conflicts between directives ? }
  1952. if (pd.proctypeoption in proc_direcdata[p].mutexclpotype) or
  1953. (pd.proccalloption in proc_direcdata[p].mutexclpocall) or
  1954. ((pd.procoptions*proc_direcdata[p].mutexclpo)<>[]) then
  1955. begin
  1956. Message1(parser_e_proc_dir_conflict,name);
  1957. exit;
  1958. end;
  1959. { set calling convention }
  1960. if proc_direcdata[p].pocall<>pocall_none then
  1961. begin
  1962. if (po_hascallingconvention in pd.procoptions) then
  1963. begin
  1964. Message2(parser_w_proc_overriding_calling,
  1965. proccalloptionStr[pd.proccalloption],
  1966. proccalloptionStr[proc_direcdata[p].pocall]);
  1967. end;
  1968. { check if the target processor supports this calling convention }
  1969. if not(proc_direcdata[p].pocall in supported_calling_conventions) then
  1970. begin
  1971. Message1(parser_e_illegal_calling_convention,proccalloptionStr[proc_direcdata[p].pocall]);
  1972. { recover }
  1973. proc_direcdata[p].pocall:=pocall_stdcall;
  1974. end;
  1975. pd.proccalloption:=proc_direcdata[p].pocall;
  1976. include(pd.procoptions,po_hascallingconvention);
  1977. end;
  1978. if pd.typ=procdef then
  1979. begin
  1980. { Check if the directive is only for objects }
  1981. if (pd_object in proc_direcdata[p].pd_flags) and
  1982. not assigned(tprocdef(pd)._class) then
  1983. exit;
  1984. { check if method and directive not for interface }
  1985. if (pd_notobjintf in proc_direcdata[p].pd_flags) and
  1986. is_interface(tprocdef(pd)._class) then
  1987. exit;
  1988. { check if method and directive not for interface }
  1989. if is_dispinterface(tprocdef(pd)._class) and
  1990. not(pd_dispinterface in proc_direcdata[p].pd_flags) then
  1991. exit;
  1992. end;
  1993. { consume directive, and turn flag on }
  1994. consume(token);
  1995. parse_proc_direc:=true;
  1996. { Check the pd_flags if the directive should be allowed }
  1997. if (pd_interface in pdflags) and
  1998. not(pd_interface in proc_direcdata[p].pd_flags) then
  1999. begin
  2000. Message1(parser_e_proc_dir_not_allowed_in_interface,name);
  2001. exit;
  2002. end;
  2003. if (pd_implemen in pdflags) and
  2004. not(pd_implemen in proc_direcdata[p].pd_flags) then
  2005. begin
  2006. Message1(parser_e_proc_dir_not_allowed_in_implementation,name);
  2007. exit;
  2008. end;
  2009. if (pd_procvar in pdflags) and
  2010. not(pd_procvar in proc_direcdata[p].pd_flags) then
  2011. begin
  2012. Message1(parser_e_proc_dir_not_allowed_in_procvar,name);
  2013. exit;
  2014. end;
  2015. { Return the new pd_flags }
  2016. if not(pd_body in proc_direcdata[p].pd_flags) then
  2017. exclude(pdflags,pd_body);
  2018. { Add the correct flag }
  2019. pd.procoptions:=pd.procoptions+proc_direcdata[p].pooption;
  2020. { Call the handler }
  2021. if pointer(proc_direcdata[p].handler)<>nil then
  2022. proc_direcdata[p].handler(pd);
  2023. end;
  2024. function proc_get_importname(pd:tprocdef):string;
  2025. function maybe_cprefix(const s:string):string;
  2026. begin
  2027. if not(pd.proccalloption in [pocall_cdecl,pocall_cppdecl]) then
  2028. result:=s
  2029. else
  2030. result:=target_info.Cprefix+s;
  2031. end;
  2032. begin
  2033. result:='';
  2034. if not(po_external in pd.procoptions) then
  2035. internalerror(200412151);
  2036. { external name or number is specified }
  2037. if assigned(pd.import_name) or (pd.import_nr<>0) then
  2038. begin
  2039. if assigned(pd.import_dll) then
  2040. begin
  2041. { If we are not using direct dll linking under win32 then imports
  2042. need to use the normal name since two functions can refer to the
  2043. same DLL function. This is also needed for compatability
  2044. with Delphi and TP7 }
  2045. (*
  2046. case target_info.system of
  2047. system_i386_emx,
  2048. system_i386_os2 :
  2049. begin
  2050. { keep normal mangledname }
  2051. if not (Assigned (PD.Import_Name)) then
  2052. Result := PD.MangledName;
  2053. end;
  2054. else
  2055. *)
  2056. if assigned(pd.import_name) then
  2057. begin
  2058. if target_info.system in (system_all_windows +
  2059. [system_i386_emx, system_i386_os2]) then
  2060. { cprefix is not used in DLL imports under Windows or OS/2 }
  2061. result:=pd.import_name^
  2062. else
  2063. result:=maybe_cprefix(pd.import_name^);
  2064. end
  2065. else
  2066. result:=ExtractFileName(pd.import_dll^)+'_index_'+tostr(pd.import_nr);
  2067. end
  2068. else
  2069. result:=maybe_cprefix(pd.import_name^);
  2070. end
  2071. else
  2072. begin
  2073. { Default names when importing variables }
  2074. case pd.proccalloption of
  2075. pocall_cdecl :
  2076. begin
  2077. if assigned(pd._class) then
  2078. result:=target_info.Cprefix+pd._class.objrealname^+'_'+pd.procsym.realname
  2079. else
  2080. result:=target_info.Cprefix+pd.procsym.realname;
  2081. end;
  2082. pocall_cppdecl :
  2083. begin
  2084. result:=target_info.Cprefix+pd.cplusplusmangledname;
  2085. end;
  2086. else
  2087. begin
  2088. {In MacPas a single "external" has the same effect as "external name 'xxx'" }
  2089. if (m_mac in current_settings.modeswitches) then
  2090. result:=tprocdef(pd).procsym.realname;
  2091. end;
  2092. end;
  2093. end;
  2094. end;
  2095. procedure proc_set_mangledname(pd:tprocdef);
  2096. var
  2097. s : string;
  2098. begin
  2099. { When the mangledname is already set we aren't allowed to change
  2100. it because it can already be used somewhere (PFV) }
  2101. if not(po_has_mangledname in pd.procoptions) then
  2102. begin
  2103. if (po_external in pd.procoptions) then
  2104. begin
  2105. { External Procedures are only allowed to change the mangledname
  2106. in their first declaration }
  2107. if (pd.forwarddef or (not pd.hasforward)) then
  2108. begin
  2109. s:=proc_get_importname(pd);
  2110. if s<>'' then
  2111. begin
  2112. { Replace ? and @ in import name }
  2113. Replace(s,'?','__q$$');
  2114. Replace(s,'@','__a$$');
  2115. pd.setmangledname(s);
  2116. end;
  2117. end;
  2118. end
  2119. else
  2120. { Normal procedures }
  2121. begin
  2122. if (po_compilerproc in pd.procoptions) then
  2123. begin
  2124. pd.setmangledname(lower(pd.procsym.name));
  2125. end;
  2126. end;
  2127. end;
  2128. { Public/exported alias names }
  2129. if (([po_public,po_exports]*pd.procoptions)<>[]) and
  2130. not(po_has_public_name in pd.procoptions) then
  2131. begin
  2132. case pd.proccalloption of
  2133. pocall_cdecl :
  2134. begin
  2135. if assigned(pd._class) then
  2136. pd.aliasnames.insert(target_info.Cprefix+pd._class.objrealname^+'_'+pd.procsym.realname)
  2137. else
  2138. pd.aliasnames.insert(target_info.Cprefix+pd.procsym.realname);
  2139. end;
  2140. pocall_cppdecl :
  2141. begin
  2142. pd.aliasnames.insert(target_info.Cprefix+pd.cplusplusmangledname);
  2143. end;
  2144. end;
  2145. { prevent adding the alias a second time }
  2146. include(pd.procoptions,po_has_public_name);
  2147. end;
  2148. end;
  2149. procedure handle_calling_convention(pd:tabstractprocdef);
  2150. begin
  2151. { set the default calling convention if none provided }
  2152. if not(po_hascallingconvention in pd.procoptions) then
  2153. pd.proccalloption:=current_settings.defproccall
  2154. else
  2155. begin
  2156. if pd.proccalloption=pocall_none then
  2157. internalerror(200309081);
  2158. end;
  2159. { handle proccall specific settings }
  2160. case pd.proccalloption of
  2161. pocall_cdecl,
  2162. pocall_cppdecl :
  2163. begin
  2164. { check C cdecl para types }
  2165. check_c_para(pd);
  2166. end;
  2167. pocall_far16 :
  2168. begin
  2169. { Temporary stub, must be rewritten to support OS/2 far16 }
  2170. Message1(parser_w_proc_directive_ignored,'FAR16');
  2171. end;
  2172. end;
  2173. { Inlining is enabled and supported? }
  2174. if (po_inline in pd.procoptions) and
  2175. not(cs_do_inline in current_settings.localswitches) then
  2176. begin
  2177. { Give an error if inline is not supported by the compiler mode,
  2178. otherwise only give a warning that this procedure will not be inlined }
  2179. if not(m_default_inline in current_settings.modeswitches) then
  2180. Message(parser_e_proc_inline_not_supported)
  2181. else
  2182. Message(parser_w_inlining_disabled);
  2183. exclude(pd.procoptions,po_inline);
  2184. end;
  2185. { For varargs directive also cdecl and external must be defined }
  2186. if (po_varargs in pd.procoptions) then
  2187. begin
  2188. { check first for external in the interface, if available there
  2189. then the cdecl must also be there since there is no implementation
  2190. available to contain it }
  2191. if parse_only then
  2192. begin
  2193. { if external is available, then cdecl must also be available,
  2194. procvars don't need external }
  2195. if not((po_external in pd.procoptions) or
  2196. (pd.typ=procvardef)) and
  2197. not(pd.proccalloption in [pocall_cdecl,pocall_cppdecl,pocall_mwpascal]) then
  2198. Message(parser_e_varargs_need_cdecl_and_external);
  2199. end
  2200. else
  2201. begin
  2202. { both must be defined now }
  2203. if not((po_external in pd.procoptions) or
  2204. (pd.typ=procvardef)) or
  2205. not(pd.proccalloption in [pocall_cdecl,pocall_cppdecl,pocall_mwpascal]) then
  2206. Message(parser_e_varargs_need_cdecl_and_external);
  2207. end;
  2208. end;
  2209. { insert hidden high parameters }
  2210. pd.parast.SymList.ForEachCall(@insert_hidden_para,pd);
  2211. { insert hidden self parameter }
  2212. insert_self_and_vmt_para(pd);
  2213. { insert funcret parameter if required }
  2214. insert_funcret_para(pd);
  2215. { Make var parameters regable, this must be done after the calling
  2216. convention is set. }
  2217. { this must be done before parentfp is insert, because getting all cases
  2218. where parentfp must be in a memory location isn't catched properly so
  2219. we put parentfp never in a register }
  2220. pd.parast.SymList.ForEachCall(@set_addr_param_regable,pd);
  2221. { insert parentfp parameter if required }
  2222. insert_parentfp_para(pd);
  2223. { Calculate parameter tlist }
  2224. pd.calcparas;
  2225. end;
  2226. procedure parse_proc_directives(pd:tabstractprocdef;var pdflags:tpdflags);
  2227. {
  2228. Parse the procedure directives. It does not matter if procedure directives
  2229. are written using ;procdir; or ['procdir'] syntax.
  2230. }
  2231. var
  2232. res : boolean;
  2233. begin
  2234. if (m_mac in current_settings.modeswitches) and (cs_externally_visible in current_settings.localswitches) then
  2235. begin
  2236. tprocdef(pd).aliasnames.insert(tprocdef(pd).procsym.realname);
  2237. include(pd.procoptions,po_public);
  2238. include(pd.procoptions,po_has_public_name);
  2239. include(pd.procoptions,po_global);
  2240. end;
  2241. while token in [_ID,_LECKKLAMMER] do
  2242. begin
  2243. if try_to_consume(_LECKKLAMMER) then
  2244. begin
  2245. repeat
  2246. parse_proc_direc(pd,pdflags);
  2247. until not try_to_consume(_COMMA);
  2248. consume(_RECKKLAMMER);
  2249. { we always expect at least '[];' }
  2250. res:=true;
  2251. end
  2252. else
  2253. begin
  2254. res:=parse_proc_direc(pd,pdflags);
  2255. end;
  2256. { A procedure directive normally followed by a semicolon, but in
  2257. a const section or reading a type we should stop when _EQUAL is found,
  2258. because a constant/default value follows }
  2259. if res then
  2260. begin
  2261. if (block_type in [bt_const,bt_type]) and
  2262. (token=_EQUAL) then
  2263. break;
  2264. { support procedure proc;stdcall export; }
  2265. if not(check_proc_directive((pd.typ=procvardef))) then
  2266. begin
  2267. { support "record p : procedure stdcall end;" and
  2268. "var p : procedure stdcall = nil;" }
  2269. if (pd_procvar in pdflags) and
  2270. (token in [_END,_RKLAMMER,_EQUAL]) then
  2271. break
  2272. else
  2273. consume(_SEMICOLON);
  2274. end;
  2275. end
  2276. else
  2277. break;
  2278. end;
  2279. end;
  2280. procedure parse_var_proc_directives(sym:tsym);
  2281. var
  2282. pdflags : tpdflags;
  2283. pd : tabstractprocdef;
  2284. begin
  2285. pdflags:=[pd_procvar];
  2286. pd:=nil;
  2287. case sym.typ of
  2288. fieldvarsym,
  2289. staticvarsym,
  2290. localvarsym,
  2291. paravarsym :
  2292. pd:=tabstractprocdef(tabstractvarsym(sym).vardef);
  2293. typesym :
  2294. pd:=tabstractprocdef(ttypesym(sym).typedef);
  2295. else
  2296. internalerror(2003042617);
  2297. end;
  2298. if pd.typ<>procvardef then
  2299. internalerror(2003042618);
  2300. { names should never be used anyway }
  2301. parse_proc_directives(pd,pdflags);
  2302. end;
  2303. procedure parse_object_proc_directives(pd:tabstractprocdef);
  2304. var
  2305. pdflags : tpdflags;
  2306. begin
  2307. pdflags:=[pd_object];
  2308. parse_proc_directives(pd,pdflags);
  2309. end;
  2310. function proc_add_definition(var currpd:tprocdef):boolean;
  2311. {
  2312. Add definition aprocdef to the overloaded definitions of aprocsym. If a
  2313. forwarddef is found and reused it returns true
  2314. }
  2315. var
  2316. fwpd : tprocdef;
  2317. currparasym,
  2318. fwparasym : tsym;
  2319. currparacnt,
  2320. fwparacnt,
  2321. curridx,
  2322. fwidx,
  2323. i : longint;
  2324. po_comp : tprocoptions;
  2325. paracompopt: tcompare_paras_options;
  2326. forwardfound : boolean;
  2327. begin
  2328. forwardfound:=false;
  2329. { check overloaded functions if the same function already exists }
  2330. for i:=0 to tprocsym(currpd.procsym).ProcdefList.Count-1 do
  2331. begin
  2332. fwpd:=tprocdef(tprocsym(currpd.procsym).ProcdefList[i]);
  2333. { Skip overloaded definitions that are declared in other units }
  2334. if fwpd.procsym<>currpd.procsym then
  2335. continue;
  2336. { check the parameters, for delphi/tp it is possible to
  2337. leave the parameters away in the implementation (forwarddef=false).
  2338. But for an overload declared function this is not allowed }
  2339. if { check if empty implementation arguments match is allowed }
  2340. (
  2341. not(m_repeat_forward in current_settings.modeswitches) and
  2342. not(currpd.forwarddef) and
  2343. is_bareprocdef(currpd) and
  2344. not(po_overload in fwpd.procoptions)
  2345. ) or
  2346. { check arguments, we need to check only the user visible parameters. The hidden parameters
  2347. can be in a different location because of the calling convention, eg. L-R vs. R-L order (PFV) }
  2348. (
  2349. (compare_paras(currpd.paras,fwpd.paras,cp_none,[cpo_comparedefaultvalue,cpo_ignorehidden,cpo_openequalisexact])=te_exact) and
  2350. (fwpd.returndef=currpd.returndef)
  2351. ) then
  2352. begin
  2353. { Check if we've found the forwarddef, if found then
  2354. we need to update the forward def with the current
  2355. implementation settings }
  2356. if fwpd.forwarddef then
  2357. begin
  2358. forwardfound:=true;
  2359. if not(m_repeat_forward in current_settings.modeswitches) and
  2360. (fwpd.proccalloption<>currpd.proccalloption) then
  2361. paracompopt:=[cpo_ignorehidden,cpo_comparedefaultvalue,cpo_openequalisexact]
  2362. else
  2363. paracompopt:=[cpo_comparedefaultvalue,cpo_openequalisexact];
  2364. { Check calling convention }
  2365. if (fwpd.proccalloption<>currpd.proccalloption) then
  2366. begin
  2367. { In delphi it is possible to specify the calling
  2368. convention in the interface or implementation if
  2369. there was no convention specified in the other
  2370. part }
  2371. if (m_delphi in current_settings.modeswitches) then
  2372. begin
  2373. if not(po_hascallingconvention in currpd.procoptions) then
  2374. currpd.proccalloption:=fwpd.proccalloption
  2375. else
  2376. if not(po_hascallingconvention in fwpd.procoptions) then
  2377. fwpd.proccalloption:=currpd.proccalloption
  2378. else
  2379. begin
  2380. MessagePos(currpd.fileinfo,parser_e_call_convention_dont_match_forward);
  2381. tprocsym(currpd.procsym).write_parameter_lists(currpd);
  2382. { restore interface settings }
  2383. currpd.proccalloption:=fwpd.proccalloption;
  2384. end;
  2385. end
  2386. else
  2387. begin
  2388. MessagePos(currpd.fileinfo,parser_e_call_convention_dont_match_forward);
  2389. tprocsym(currpd.procsym).write_parameter_lists(currpd);
  2390. { restore interface settings }
  2391. currpd.proccalloption:=fwpd.proccalloption;
  2392. end;
  2393. end;
  2394. { Check if the procedure type and return type are correct,
  2395. also the parameters must match also with the type }
  2396. if ((m_repeat_forward in current_settings.modeswitches) or
  2397. not is_bareprocdef(currpd)) and
  2398. ((compare_paras(currpd.paras,fwpd.paras,cp_all,paracompopt)<>te_exact) or
  2399. (fwpd.returndef<>currpd.returndef)) then
  2400. begin
  2401. MessagePos1(currpd.fileinfo,parser_e_header_dont_match_forward,
  2402. fwpd.fullprocname(false));
  2403. tprocsym(currpd.procsym).write_parameter_lists(currpd);
  2404. break;
  2405. end;
  2406. { Check if both are declared forward }
  2407. if fwpd.forwarddef and currpd.forwarddef then
  2408. begin
  2409. MessagePos1(currpd.fileinfo,parser_e_function_already_declared_public_forward,
  2410. currpd.fullprocname(false));
  2411. end;
  2412. { internconst or internproc only need to be defined once }
  2413. if (fwpd.proccalloption=pocall_internproc) then
  2414. currpd.proccalloption:=fwpd.proccalloption
  2415. else
  2416. if (currpd.proccalloption=pocall_internproc) then
  2417. fwpd.proccalloption:=currpd.proccalloption;
  2418. { Check procedure options, Delphi requires that class is
  2419. repeated in the implementation for class methods }
  2420. if (m_fpc in current_settings.modeswitches) then
  2421. po_comp:=[po_classmethod,po_varargs,po_methodpointer,po_interrupt]
  2422. else
  2423. po_comp:=[po_classmethod,po_methodpointer];
  2424. if ((po_comp * fwpd.procoptions)<>(po_comp * currpd.procoptions)) or
  2425. (fwpd.proctypeoption <> currpd.proctypeoption) then
  2426. begin
  2427. MessagePos1(currpd.fileinfo,parser_e_header_dont_match_forward,
  2428. fwpd.fullprocname(false));
  2429. tprocsym(fwpd.procsym).write_parameter_lists(fwpd);
  2430. { This error is non-fatal, we can recover }
  2431. end;
  2432. { Forward declaration is external? }
  2433. if (po_external in fwpd.procoptions) then
  2434. MessagePos(currpd.fileinfo,parser_e_proc_already_external);
  2435. { Check parameters }
  2436. if (m_repeat_forward in current_settings.modeswitches) or
  2437. (currpd.minparacount>0) then
  2438. begin
  2439. { If mangled names are equal then they have the same amount of arguments }
  2440. { We can check the names of the arguments }
  2441. { both symtables are in the same order from left to right }
  2442. curridx:=0;
  2443. fwidx:=0;
  2444. currparacnt:=currpd.parast.SymList.Count;
  2445. fwparacnt:=fwpd.parast.SymList.Count;
  2446. repeat
  2447. { skip default parameter constsyms }
  2448. while (curridx<currparacnt) and
  2449. (tsym(currpd.parast.SymList[curridx]).typ<>paravarsym) do
  2450. inc(curridx);
  2451. while (fwidx<fwparacnt) and
  2452. (tsym(fwpd.parast.SymList[fwidx]).typ<>paravarsym) do
  2453. inc(fwidx);
  2454. { stop when one of the two lists is at the end }
  2455. if (fwidx>=fwparacnt) or (curridx>=currparacnt) then
  2456. break;
  2457. { compare names of parameters, ignore implictly
  2458. renamed parameters }
  2459. currparasym:=tsym(currpd.parast.SymList[curridx]);
  2460. fwparasym:=tsym(fwpd.parast.SymList[fwidx]);
  2461. if not(sp_implicitrename in currparasym.symoptions) and
  2462. not(sp_implicitrename in fwparasym.symoptions) then
  2463. begin
  2464. if (currparasym.name<>fwparasym.name) then
  2465. begin
  2466. MessagePos3(currpd.fileinfo,parser_e_header_different_var_names,
  2467. tprocsym(currpd.procsym).realname,fwparasym.realname,currparasym.realname);
  2468. break;
  2469. end;
  2470. end;
  2471. { next parameter }
  2472. inc(curridx);
  2473. inc(fwidx);
  2474. until false;
  2475. end;
  2476. { Everything is checked, now we can update the forward declaration
  2477. with the new data from the implementation }
  2478. fwpd.forwarddef:=currpd.forwarddef;
  2479. fwpd.hasforward:=true;
  2480. fwpd.procoptions:=fwpd.procoptions+currpd.procoptions;
  2481. { marked as local but exported from unit? }
  2482. if (po_kylixlocal in fwpd.procoptions) and (fwpd.owner.symtabletype=globalsymtable) then
  2483. MessagePos(fwpd.fileinfo,type_e_cant_export_local);
  2484. if fwpd.extnumber=$ffff then
  2485. fwpd.extnumber:=currpd.extnumber;
  2486. while not currpd.aliasnames.empty do
  2487. fwpd.aliasnames.insert(currpd.aliasnames.getfirst);
  2488. { update fileinfo so position references the implementation,
  2489. also update funcretsym if it is already generated }
  2490. fwpd.fileinfo:=currpd.fileinfo;
  2491. if assigned(fwpd.funcretsym) then
  2492. fwpd.funcretsym.fileinfo:=currpd.fileinfo;
  2493. { import names }
  2494. if assigned(currpd.import_dll) then
  2495. begin
  2496. stringdispose(fwpd.import_dll);
  2497. fwpd.import_dll:=stringdup(currpd.import_dll^);
  2498. end;
  2499. if assigned(currpd.import_name) then
  2500. begin
  2501. stringdispose(fwpd.import_name);
  2502. fwpd.import_name:=stringdup(currpd.import_name^);
  2503. end;
  2504. fwpd.import_nr:=currpd.import_nr;
  2505. { for compilerproc defines we need to rename and update the
  2506. symbolname to lowercase }
  2507. if (po_compilerproc in fwpd.procoptions) then
  2508. begin
  2509. { rename to lowercase so users can't access it }
  2510. fwpd.procsym.realname:='$'+lower(fwpd.procsym.name);
  2511. { the mangeled name is already changed by the pd_compilerproc }
  2512. { handler. It must be done immediately because if we have a }
  2513. { call to a compilerproc before it's implementation is }
  2514. { encountered, it must already use the new mangled name (JM) }
  2515. end;
  2516. { Release current procdef }
  2517. currpd.owner.deletedef(currpd);
  2518. currpd:=fwpd;
  2519. end
  2520. else
  2521. begin
  2522. { abstract methods aren't forward defined, but this }
  2523. { needs another error message }
  2524. if (po_abstractmethod in fwpd.procoptions) then
  2525. MessagePos(currpd.fileinfo,parser_e_abstract_no_definition)
  2526. else
  2527. begin
  2528. MessagePos(currpd.fileinfo,parser_e_overloaded_have_same_parameters);
  2529. tprocsym(currpd.procsym).write_parameter_lists(currpd);
  2530. end;
  2531. end;
  2532. { we found one proc with the same arguments, there are no others
  2533. so we can stop }
  2534. break;
  2535. end;
  2536. { check for allowing overload directive }
  2537. if not(m_fpc in current_settings.modeswitches) then
  2538. begin
  2539. { overload directive turns on overloading }
  2540. if ((po_overload in currpd.procoptions) or
  2541. (po_overload in fwpd.procoptions)) then
  2542. begin
  2543. { check if all procs have overloading, but not if the proc is a method or
  2544. already declared forward, then the check is already done }
  2545. if not(fwpd.hasforward or
  2546. assigned(currpd._class) or
  2547. (currpd.forwarddef<>fwpd.forwarddef) or
  2548. ((po_overload in currpd.procoptions) and
  2549. (po_overload in fwpd.procoptions))) then
  2550. begin
  2551. MessagePos1(currpd.fileinfo,parser_e_no_overload_for_all_procs,currpd.procsym.realname);
  2552. break;
  2553. end;
  2554. end
  2555. else
  2556. begin
  2557. if not(fwpd.forwarddef) then
  2558. begin
  2559. MessagePos(currpd.fileinfo,parser_e_procedure_overloading_is_off);
  2560. break;
  2561. end;
  2562. end;
  2563. end; { equal arguments }
  2564. end;
  2565. { if we didn't reuse a forwarddef then we add the procdef to the overloaded
  2566. list }
  2567. if not forwardfound then
  2568. begin
  2569. { can happen in Delphi mode }
  2570. if (currpd.proctypeoption = potype_function) and
  2571. is_void(currpd.returndef) then
  2572. MessagePos1(currpd.fileinfo,parser_e_no_funcret_specified,currpd.procsym.realname);
  2573. tprocsym(currpd.procsym).ProcdefList.Add(currpd);
  2574. end;
  2575. proc_add_definition:=forwardfound;
  2576. end;
  2577. end.