psub.pas 32 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891
  1. {
  2. $Id$
  3. Copyright (c) 1998-2002 by Florian Klaempfl, Daniel Mantione
  4. Does the parsing and codegeneration at subroutine level
  5. This program is free software; you can redistribute it and/or modify
  6. it under the terms of the GNU General Public License as published by
  7. the Free Software Foundation; either version 2 of the License, or
  8. (at your option) any later version.
  9. This program is distributed in the hope that it will be useful,
  10. but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  12. GNU General Public License for more details.
  13. You should have received a copy of the GNU General Public License
  14. along with this program; if not, write to the Free Software
  15. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  16. ****************************************************************************
  17. }
  18. unit psub;
  19. {$i fpcdefs.inc}
  20. interface
  21. procedure compile_proc_body(make_global,parent_has_class:boolean);
  22. { reads the declaration blocks }
  23. procedure read_declarations(islibrary : boolean);
  24. { reads declarations in the interface part of a unit }
  25. procedure read_interface_declarations;
  26. implementation
  27. uses
  28. { common }
  29. cutils,cclasses,
  30. { global }
  31. globtype,globals,tokens,verbose,comphook,
  32. systems,
  33. { aasm }
  34. cpubase,cpuinfo,aasmbase,aasmtai,
  35. { symtable }
  36. symconst,symbase,symdef,symsym,symtype,symtable,defbase,paramgr,
  37. ppu,fmodule,
  38. { pass 1 }
  39. node,
  40. nbas,
  41. pass_1,
  42. {$ifdef state_tracking}
  43. nstate,
  44. {$endif state_tracking}
  45. { pass 2 }
  46. {$ifndef NOPASS2}
  47. pass_2,
  48. {$endif}
  49. { parser }
  50. scanner,
  51. pbase,pstatmnt,pdecl,pdecsub,pexports,
  52. { codegen }
  53. tgobj,cgbase,rgobj,rgcpu,
  54. ncgutil
  55. {$ifndef NOOPT}
  56. {$ifdef i386}
  57. ,aopt386
  58. {$else i386}
  59. ,aoptcpu
  60. {$endif i386}
  61. {$endif}
  62. ;
  63. {****************************************************************************
  64. PROCEDURE/FUNCTION BODY PARSING
  65. ****************************************************************************}
  66. function block(islibrary : boolean) : tnode;
  67. var
  68. storepos : tfileposinfo;
  69. begin
  70. { do we have an assembler block without the po_assembler?
  71. we should allow this for Delphi compatibility (PFV) }
  72. if (token=_ASM) and (m_delphi in aktmodeswitches) then
  73. include(aktprocdef.procoptions,po_assembler);
  74. { Handle assembler block different }
  75. if (po_assembler in aktprocdef.procoptions) then
  76. begin
  77. read_declarations(false);
  78. block:=assembler_block;
  79. exit;
  80. end;
  81. if not is_void(aktprocdef.rettype.def) then
  82. begin
  83. { if the current is a function aktprocsym is non nil }
  84. { and there is a local symtable set }
  85. storepos:=akttokenpos;
  86. akttokenpos:=aktprocsym.fileinfo;
  87. aktprocdef.funcretsym:=tfuncretsym.create(aktprocsym.name,aktprocdef.rettype);
  88. { insert in local symtable }
  89. symtablestack.insert(aktprocdef.funcretsym);
  90. symtablestack.insertvardata(aktprocdef.funcretsym);
  91. akttokenpos:=storepos;
  92. procinfo.set_result_offset;
  93. { insert result also if support is on }
  94. if (m_result in aktmodeswitches) then
  95. begin
  96. aktprocdef.resultfuncretsym:=tfuncretsym.create('RESULT',aktprocdef.rettype);
  97. symtablestack.insert(aktprocdef.resultfuncretsym);
  98. end;
  99. end;
  100. read_declarations(islibrary);
  101. procinfo.handle_body_start;
  102. {Unit initialization?.}
  103. if (lexlevel=unit_init_level) and (current_module.is_unit)
  104. or islibrary then
  105. begin
  106. if (token=_END) then
  107. begin
  108. consume(_END);
  109. { We need at least a node, else the entry/exit code is not
  110. generated and thus no PASCALMAIN symbol which we need (PFV) }
  111. if islibrary then
  112. block:=cnothingnode.create
  113. else
  114. block:=nil;
  115. end
  116. else
  117. begin
  118. if token=_INITIALIZATION then
  119. begin
  120. current_module.flags:=current_module.flags or uf_init;
  121. block:=statement_block(_INITIALIZATION);
  122. end
  123. else if (token=_FINALIZATION) then
  124. begin
  125. if (current_module.flags and uf_finalize)<>0 then
  126. block:=statement_block(_FINALIZATION)
  127. else
  128. begin
  129. { can we allow no INITIALIZATION for DLL ??
  130. I think it should work PM }
  131. block:=nil;
  132. exit;
  133. end;
  134. end
  135. else
  136. begin
  137. current_module.flags:=current_module.flags or uf_init;
  138. block:=statement_block(_BEGIN);
  139. end;
  140. end;
  141. end
  142. else
  143. block:=statement_block(_BEGIN);
  144. end;
  145. {****************************************************************************
  146. PROCEDURE/FUNCTION COMPILING
  147. ****************************************************************************}
  148. procedure compile_proc_body(make_global,parent_has_class:boolean);
  149. {
  150. Compile the body of a procedure
  151. }
  152. var
  153. oldexitlabel,oldexit2label : tasmlabel;
  154. oldfaillabel,oldquickexitlabel:tasmlabel;
  155. _class,hp:tobjectdef;
  156. { switches can change inside the procedure }
  157. entryswitches, exitswitches : tlocalswitches;
  158. oldaktmaxfpuregisters,localmaxfpuregisters : longint;
  159. { code for the subroutine as tree }
  160. code:tnode;
  161. { true when no stackframe is required }
  162. nostackframe:boolean;
  163. { number of bytes which have to be cleared by RET }
  164. parasize:longint;
  165. { filepositions }
  166. entrypos,
  167. savepos,
  168. exitpos : tfileposinfo;
  169. begin
  170. { calculate the lexical level }
  171. inc(lexlevel);
  172. if lexlevel>32 then
  173. Message(parser_e_too_much_lexlevel);
  174. { static is also important for local procedures !! }
  175. if (po_staticmethod in aktprocdef.procoptions) then
  176. allow_only_static:=true
  177. else if (lexlevel=normal_function_level) then
  178. allow_only_static:=false;
  179. { save old labels }
  180. oldexitlabel:=aktexitlabel;
  181. oldexit2label:=aktexit2label;
  182. oldquickexitlabel:=quickexitlabel;
  183. oldfaillabel:=faillabel;
  184. { get new labels }
  185. objectlibrary.getlabel(aktexitlabel);
  186. objectlibrary.getlabel(aktexit2label);
  187. { exit for fail in constructors }
  188. if (aktprocdef.proctypeoption=potype_constructor) then
  189. begin
  190. objectlibrary.getlabel(faillabel);
  191. objectlibrary.getlabel(quickexitlabel);
  192. end;
  193. { reset break and continue labels }
  194. block_type:=bt_general;
  195. aktbreaklabel:=nil;
  196. aktcontinuelabel:=nil;
  197. {$ifdef state_tracking}
  198. { aktstate:=Tstate_storage.create;}
  199. {$endif state_tracking}
  200. { insert symtables for the class, by only if it is no nested function }
  201. if assigned(procinfo._class) and not(parent_has_class) then
  202. begin
  203. { insert them in the reverse order ! }
  204. hp:=nil;
  205. repeat
  206. _class:=procinfo._class;
  207. while _class.childof<>hp do
  208. _class:=_class.childof;
  209. hp:=_class;
  210. _class.symtable.next:=symtablestack;
  211. symtablestack:=_class.symtable;
  212. until hp=procinfo._class;
  213. end;
  214. { insert parasymtable in symtablestack}
  215. { only if lexlevel > 1 !!! global symtable should be right after staticsymtazble
  216. for checking of same names used in interface and implementation !! }
  217. if lexlevel>=normal_function_level then
  218. begin
  219. aktprocdef.parast.next:=symtablestack;
  220. symtablestack:=aktprocdef.parast;
  221. symtablestack.symtablelevel:=lexlevel;
  222. end;
  223. { insert localsymtable in symtablestack}
  224. aktprocdef.localst.next:=symtablestack;
  225. symtablestack:=aktprocdef.localst;
  226. symtablestack.symtablelevel:=lexlevel;
  227. { constant symbols are inserted in this symboltable }
  228. constsymtable:=symtablestack;
  229. { reset the temporary memory }
  230. rg.cleartempgen;
  231. rg.usedinproc:=[];
  232. rg.usedbyproc:=[];
  233. { save entry info }
  234. entrypos:=aktfilepos;
  235. entryswitches:=aktlocalswitches;
  236. localmaxfpuregisters:=aktmaxfpuregisters;
  237. { parse the code ... }
  238. code:=block(current_module.islibrary);
  239. { get a better entry point }
  240. if assigned(code) then
  241. entrypos:=code.fileinfo;
  242. { save exit info }
  243. exitswitches:=aktlocalswitches;
  244. exitpos:=last_endtoken_filepos;
  245. { save current filepos }
  246. savepos:=aktfilepos;
  247. {When we are called to compile the body of a unit, aktprocsym should
  248. point to the unit initialization. If the unit has no initialization,
  249. aktprocsym=nil. But in that case code=nil. hus we should check for
  250. code=nil, when we use aktprocsym.}
  251. { set the start offset to the start of the temp area in the stack }
  252. tg.setfirsttemp(procinfo.firsttemp_offset);
  253. { ... and generate assembler }
  254. { but set the right switches for entry !! }
  255. aktlocalswitches:=entryswitches;
  256. oldaktmaxfpuregisters:=aktmaxfpuregisters;
  257. aktmaxfpuregisters:=localmaxfpuregisters;
  258. if assigned(code) then
  259. begin
  260. { the procedure is now defined }
  261. aktprocdef.forwarddef:=false;
  262. {$ifdef state_tracking}
  263. { writenode(code);
  264. do_track_state_pass(code);
  265. writenode(code);}
  266. {$endif}
  267. { only generate the code if no type errors are found, else
  268. finish at least the type checking pass }
  269. {$ifndef NOPASS2}
  270. if (status.errorcount=0) then
  271. begin
  272. generatecode(code);
  273. aktprocdef.code:=code;
  274. { first generate entry code with the correct position and switches }
  275. aktfilepos:=entrypos;
  276. aktlocalswitches:=entryswitches;
  277. genentrycode(procinfo.aktentrycode,make_global,0,parasize,nostackframe,false);
  278. { FPC_POPADDRSTACK destroys all registers (JM) }
  279. if (procinfo.flags and (pi_needs_implicit_finally or pi_uses_exceptions)) <> 0 then
  280. begin
  281. rg.usedinproc := ALL_REGISTERS;
  282. end;
  283. { now generate exit code with the correct position and switches }
  284. aktfilepos:=exitpos;
  285. aktlocalswitches:=exitswitches;
  286. genexitcode(procinfo.aktexitcode,parasize,nostackframe,false);
  287. { now all the registers used are known }
  288. aktprocdef.usedregisters:=rg.usedinproc;
  289. procinfo.aktproccode.insertlist(procinfo.aktentrycode);
  290. procinfo.aktproccode.concatlist(procinfo.aktexitcode);
  291. {$ifdef i386}
  292. {$ifndef NoOpt}
  293. if (cs_optimize in aktglobalswitches) and
  294. { do not optimize pure assembler procedures }
  295. ((procinfo.flags and pi_is_assembler)=0) then
  296. Optimize(procinfo.aktproccode);
  297. {$endif NoOpt}
  298. {$endif i386}
  299. { save local data (casetable) also in the same file }
  300. if assigned(procinfo.aktlocaldata) and
  301. (not procinfo.aktlocaldata.empty) then
  302. begin
  303. procinfo.aktproccode.concat(Tai_section.Create(sec_data));
  304. procinfo.aktproccode.concatlist(procinfo.aktlocaldata);
  305. procinfo.aktproccode.concat(Tai_section.Create(sec_code));
  306. end;
  307. { add the procedure to the codesegment }
  308. if (cs_create_smart in aktmoduleswitches) then
  309. codeSegment.concat(Tai_cut.Create);
  310. codeSegment.concatlist(procinfo.aktproccode);
  311. end
  312. else
  313. do_resulttypepass(code);
  314. {$else NOPASS2}
  315. do_resulttypepass(code);
  316. {$endif NOPASS2}
  317. end;
  318. { ... remove symbol tables }
  319. if lexlevel>=normal_function_level then
  320. symtablestack:=symtablestack.next.next
  321. else
  322. symtablestack:=symtablestack.next;
  323. { ... check for unused symbols }
  324. { but only if there is no asm block }
  325. if assigned(code) then
  326. begin
  327. if (Errorcount=0) then
  328. begin
  329. { check if forwards are resolved }
  330. tstoredsymtable(aktprocdef.localst).check_forwards;
  331. { check if all labels are used }
  332. tstoredsymtable(aktprocdef.localst).checklabels;
  333. { remove cross unit overloads }
  334. tstoredsymtable(aktprocdef.localst).unchain_overloaded;
  335. end;
  336. if (procinfo.flags and pi_uses_asm)=0 then
  337. begin
  338. { not for unit init, becuase the var can be used in finalize,
  339. it will be done in proc_unit }
  340. if not(aktprocdef.proctypeoption
  341. in [potype_proginit,potype_unitinit,potype_unitfinalize]) then
  342. tstoredsymtable(aktprocdef.localst).allsymbolsused;
  343. tstoredsymtable(aktprocdef.parast).allsymbolsused;
  344. end;
  345. end;
  346. { the local symtables can be deleted, but the parast }
  347. { doesn't, (checking definitons when calling a }
  348. { function }
  349. { not for a inline procedure !! (PM) }
  350. { at lexlevel = 1 localst is the staticsymtable itself }
  351. { so no dispose here !! }
  352. if assigned(code) and
  353. not(cs_browser in aktmoduleswitches) and
  354. (aktprocdef.proccalloption<>pocall_inline) then
  355. begin
  356. if lexlevel>=normal_function_level then
  357. aktprocdef.localst.free;
  358. aktprocdef.localst:=nil;
  359. end;
  360. { all registers can be used again }
  361. rg.resetusableregisters;
  362. { only now we can remove the temps }
  363. tg.resettempgen;
  364. { remove code tree, if not inline procedure }
  365. if assigned(code) and (aktprocdef.proccalloption<>pocall_inline) then
  366. code.free;
  367. { remove class member symbol tables }
  368. while symtablestack.symtabletype=objectsymtable do
  369. symtablestack:=symtablestack.next;
  370. aktmaxfpuregisters:=oldaktmaxfpuregisters;
  371. {$ifdef state_tracking}
  372. { aktstate.destroy;}
  373. {$endif state_tracking}
  374. { restore filepos, the switches are already set }
  375. aktfilepos:=savepos;
  376. { restore labels }
  377. aktexitlabel:=oldexitlabel;
  378. aktexit2label:=oldexit2label;
  379. quickexitlabel:=oldquickexitlabel;
  380. faillabel:=oldfaillabel;
  381. { reset to normal non static function }
  382. if (lexlevel=normal_function_level) then
  383. allow_only_static:=false;
  384. { previous lexlevel }
  385. dec(lexlevel);
  386. end;
  387. {****************************************************************************
  388. PROCEDURE/FUNCTION PARSING
  389. ****************************************************************************}
  390. procedure checkvaluepara(p:tnamedindexitem;arg:pointer);
  391. var
  392. vs : tvarsym;
  393. s : string;
  394. begin
  395. if tsym(p).typ<>varsym then
  396. exit;
  397. with tvarsym(p) do
  398. begin
  399. if copy(name,1,3)='val' then
  400. begin
  401. s:=Copy(name,4,255);
  402. if not(po_assembler in aktprocdef.procoptions) then
  403. begin
  404. vs:=tvarsym.create(s,vartype);
  405. vs.fileinfo:=fileinfo;
  406. vs.varspez:=varspez;
  407. aktprocdef.localst.insert(vs);
  408. aktprocdef.localst.insertvardata(vs);
  409. include(vs.varoptions,vo_is_local_copy);
  410. vs.varstate:=vs_assigned;
  411. localvarsym:=vs;
  412. inc(refs); { the para was used to set the local copy ! }
  413. { warnings only on local copy ! }
  414. varstate:=vs_used;
  415. end
  416. else
  417. begin
  418. aktprocdef.parast.rename(name,s);
  419. end;
  420. end;
  421. end;
  422. end;
  423. procedure read_proc;
  424. {
  425. Parses the procedure directives, then parses the procedure body, then
  426. generates the code for it
  427. }
  428. var
  429. oldprocsym : tprocsym;
  430. oldprocdef : tprocdef;
  431. oldprocinfo : tprocinfo;
  432. oldconstsymtable : tsymtable;
  433. oldfilepos : tfileposinfo;
  434. pdflags : word;
  435. begin
  436. { save old state }
  437. oldprocdef:=aktprocdef;
  438. oldprocsym:=aktprocsym;
  439. oldconstsymtable:=constsymtable;
  440. oldprocinfo:=procinfo;
  441. { create a new procedure }
  442. codegen_newprocedure;
  443. with procinfo do
  444. begin
  445. parent:=oldprocinfo;
  446. { clear flags }
  447. flags:=0;
  448. { standard frame pointer }
  449. framepointer:=frame_pointer_reg;
  450. { is this a nested function of a method ? }
  451. if assigned(oldprocinfo) then
  452. _class:=oldprocinfo._class;
  453. end;
  454. parse_proc_dec;
  455. procinfo.procdef:=aktprocdef;
  456. { set the default function options }
  457. if parse_only then
  458. begin
  459. aktprocdef.forwarddef:=true;
  460. { set also the interface flag, for better error message when the
  461. implementation doesn't much this header }
  462. aktprocdef.interfacedef:=true;
  463. pdflags:=pd_interface;
  464. end
  465. else
  466. begin
  467. pdflags:=pd_body;
  468. if current_module.in_implementation then
  469. pdflags:=pdflags or pd_implemen;
  470. if (not current_module.is_unit) or (cs_create_smart in aktmoduleswitches) then
  471. pdflags:=pdflags or pd_global;
  472. procinfo.exported:=false;
  473. aktprocdef.forwarddef:=false;
  474. end;
  475. { parse the directives that may follow }
  476. inc(lexlevel);
  477. parse_proc_directives(pdflags);
  478. dec(lexlevel);
  479. { hint directives, these can be separated by semicolons here,
  480. that need to be handled here with a loop (PFV) }
  481. while try_consume_hintdirective(aktprocsym.symoptions) do
  482. Consume(_SEMICOLON);
  483. { set aktfilepos to the beginning of the function declaration }
  484. oldfilepos:=aktfilepos;
  485. aktfilepos:=aktprocdef.fileinfo;
  486. { For varargs directive also cdecl and external must be defined }
  487. if (po_varargs in aktprocdef.procoptions) then
  488. begin
  489. { check first for external in the interface, if available there
  490. then the cdecl must also be there since there is no implementation
  491. available to contain it }
  492. if parse_only then
  493. begin
  494. { if external is available, then cdecl must also be available }
  495. if (po_external in aktprocdef.procoptions) and
  496. not(aktprocdef.proccalloption in [pocall_cdecl,pocall_cppdecl]) then
  497. Message(parser_e_varargs_need_cdecl_and_external);
  498. end
  499. else
  500. begin
  501. { both must be defined now }
  502. if not(po_external in aktprocdef.procoptions) or
  503. not(aktprocdef.proccalloption in [pocall_cdecl,pocall_cppdecl]) then
  504. Message(parser_e_varargs_need_cdecl_and_external);
  505. end;
  506. end;
  507. { search for forward declarations }
  508. if not proc_add_definition(aktprocsym,aktprocdef) then
  509. begin
  510. { A method must be forward defined (in the object declaration) }
  511. if assigned(procinfo._class) and
  512. (not assigned(oldprocinfo._class)) then
  513. begin
  514. Message1(parser_e_header_dont_match_any_member,aktprocdef.fullprocname);
  515. aktprocsym.write_parameter_lists(aktprocdef);
  516. end
  517. else
  518. begin
  519. { Give a better error if there is a forward def in the interface and only
  520. a single implementation }
  521. if (not aktprocdef.forwarddef) and
  522. (aktprocsym.procdef_count>1) and
  523. aktprocsym.first_procdef.forwarddef and
  524. aktprocsym.first_procdef.interfacedef and
  525. not(aktprocsym.procdef_count>2) then
  526. begin
  527. Message1(parser_e_header_dont_match_forward,aktprocdef.fullprocname);
  528. aktprocsym.write_parameter_lists(aktprocdef);
  529. end
  530. else
  531. begin
  532. { check the global flag, for delphi this is not
  533. required }
  534. if not(m_delphi in aktmodeswitches) and
  535. ((procinfo.flags and pi_is_global)<>0) then
  536. Message(parser_e_overloaded_must_be_all_global);
  537. end;
  538. end;
  539. end;
  540. { update procinfo, because the aktprocdef can be
  541. changed by check_identical_proc (PFV) }
  542. procinfo.procdef:=aktprocdef;
  543. {$ifdef i386}
  544. { add implicit pushes for interrupt routines }
  545. if (po_interrupt in aktprocdef.procoptions) then
  546. procinfo.allocate_interrupt_stackframe;
  547. {$endif i386}
  548. { pointer to the return value ? }
  549. if paramanager.ret_in_param(aktprocdef.rettype.def) then
  550. begin
  551. procinfo.return_offset:=procinfo.para_offset;
  552. inc(procinfo.para_offset,pointer_size);
  553. end;
  554. { allows to access the parameters of main functions in nested functions }
  555. aktprocdef.parast.address_fixup:=procinfo.para_offset;
  556. { when it is a value para and it needs a local copy then rename
  557. the parameter and insert a copy in the localst. This is not done
  558. for assembler procedures }
  559. if (not parse_only) and (not aktprocdef.forwarddef) then
  560. aktprocdef.parast.foreach_static({$ifdef FPCPROCVAR}@{$endif}checkvaluepara,nil);
  561. procinfo.after_header;
  562. { restore file pos }
  563. aktfilepos:=oldfilepos;
  564. { compile procedure when a body is needed }
  565. if (pdflags and pd_body)<>0 then
  566. begin
  567. Message1(parser_p_procedure_start,
  568. aktprocdef.fullprocname);
  569. aktprocdef.aliasnames.insert(aktprocdef.mangledname);
  570. { set _FAIL as keyword if constructor }
  571. if (aktprocdef.proctypeoption=potype_constructor) then
  572. tokeninfo^[_FAIL].keyword:=m_all;
  573. if assigned(aktprocdef._class) then
  574. tokeninfo^[_SELF].keyword:=m_all;
  575. compile_proc_body(((pdflags and pd_global)<>0),assigned(oldprocinfo._class));
  576. { reset _FAIL as normal }
  577. if (aktprocdef.proctypeoption=potype_constructor) then
  578. tokeninfo^[_FAIL].keyword:=m_none;
  579. if assigned(aktprocdef._class) and (lexlevel=main_program_level) then
  580. tokeninfo^[_SELF].keyword:=m_none;
  581. consume(_SEMICOLON);
  582. end;
  583. { close }
  584. codegen_doneprocedure;
  585. { Restore old state }
  586. constsymtable:=oldconstsymtable;
  587. {$ifdef notused}
  588. { restore the interface order to maintain CRC values PM }
  589. if assigned(prevdef) and assigned(aktprocdef.nextoverloaded) then
  590. begin
  591. stdef:=aktprocdef;
  592. aktprocdef:=stdef.nextoverloaded;
  593. stdef.nextoverloaded:=prevdef.nextoverloaded;
  594. prevdef.nextoverloaded:=stdef;
  595. end;
  596. {$endif notused}
  597. aktprocsym:=oldprocsym;
  598. aktprocdef:=oldprocdef;
  599. procinfo:=oldprocinfo;
  600. otsym:=nil;
  601. end;
  602. {****************************************************************************
  603. DECLARATION PARSING
  604. ****************************************************************************}
  605. { search in symtablestack for not complete classes }
  606. procedure check_forward_class(p : tnamedindexitem;arg:pointer);
  607. begin
  608. if (tsym(p).typ=typesym) and
  609. (ttypesym(p).restype.def.deftype=objectdef) and
  610. (oo_is_forward in tobjectdef(ttypesym(p).restype.def).objectoptions) then
  611. MessagePos1(tsym(p).fileinfo,sym_e_forward_type_not_resolved,tsym(p).realname);
  612. end;
  613. procedure read_declarations(islibrary : boolean);
  614. procedure Not_supported_for_inline(t : ttoken);
  615. begin
  616. if assigned(aktprocsym) and
  617. (aktprocdef.proccalloption=pocall_inline) then
  618. Begin
  619. Message1(parser_w_not_supported_for_inline,tokenstring(t));
  620. Message(parser_w_inlining_disabled);
  621. aktprocdef.proccalloption:=pocall_fpccall;
  622. End;
  623. end;
  624. begin
  625. repeat
  626. case token of
  627. _LABEL:
  628. begin
  629. Not_supported_for_inline(token);
  630. label_dec;
  631. end;
  632. _CONST:
  633. begin
  634. Not_supported_for_inline(token);
  635. const_dec;
  636. end;
  637. _TYPE:
  638. begin
  639. Not_supported_for_inline(token);
  640. type_dec;
  641. end;
  642. _VAR:
  643. var_dec;
  644. _THREADVAR:
  645. threadvar_dec;
  646. _CONSTRUCTOR,_DESTRUCTOR,
  647. _FUNCTION,_PROCEDURE,_OPERATOR,_CLASS:
  648. begin
  649. Not_supported_for_inline(token);
  650. read_proc;
  651. end;
  652. _RESOURCESTRING:
  653. resourcestring_dec;
  654. _EXPORTS:
  655. begin
  656. Not_supported_for_inline(token);
  657. { here we should be at lexlevel 1, no ? PM }
  658. if (lexlevel<>main_program_level) or
  659. (current_module.is_unit) then
  660. begin
  661. Message(parser_e_syntax_error);
  662. consume_all_until(_SEMICOLON);
  663. end
  664. else if islibrary or (target_info.system in [system_i386_WIN32,system_i386_wdosx,system_i386_Netware])
  665. then // AD
  666. read_exports;
  667. end
  668. else break;
  669. end;
  670. until false;
  671. { check for incomplete class definitions, this is only required
  672. for fpc modes }
  673. if (m_fpc in aktmodeswitches) then
  674. symtablestack.foreach_static({$ifdef FPCPROCVAR}@{$endif}check_forward_class,nil);
  675. end;
  676. procedure read_interface_declarations;
  677. begin
  678. {Since the body is now parsed at lexlevel 1, and the declarations
  679. must be parsed at the same lexlevel we increase the lexlevel.}
  680. inc(lexlevel);
  681. repeat
  682. case token of
  683. _CONST :
  684. const_dec;
  685. _TYPE :
  686. type_dec;
  687. _VAR :
  688. var_dec;
  689. _THREADVAR :
  690. threadvar_dec;
  691. _RESOURCESTRING:
  692. resourcestring_dec;
  693. _FUNCTION,
  694. _PROCEDURE,
  695. _OPERATOR :
  696. read_proc;
  697. else
  698. break;
  699. end;
  700. until false;
  701. dec(lexlevel);
  702. { check for incomplete class definitions, this is only required
  703. for fpc modes }
  704. if (m_fpc in aktmodeswitches) then
  705. symtablestack.foreach_static({$ifdef FPCPROCVAR}@{$endif}check_forward_class,nil);
  706. end;
  707. end.
  708. {
  709. $Log$
  710. Revision 1.72 2002-09-10 20:31:48 florian
  711. * call to procinfo.after_header added
  712. Revision 1.71 2002/09/07 15:25:07 peter
  713. * old logs removed and tabs fixed
  714. Revision 1.70 2002/09/03 16:26:27 daniel
  715. * Make Tprocdef.defs protected
  716. Revision 1.69 2002/08/25 19:25:20 peter
  717. * sym.insert_in_data removed
  718. * symtable.insertvardata/insertconstdata added
  719. * removed insert_in_data call from symtable.insert, it needs to be
  720. called separatly. This allows to deref the address calculation
  721. * procedures now calculate the parast addresses after the procedure
  722. directives are parsed. This fixes the cdecl parast problem
  723. * push_addr_param has an extra argument that specifies if cdecl is used
  724. or not
  725. Revision 1.68 2002/08/17 09:23:41 florian
  726. * first part of procinfo rewrite
  727. Revision 1.67 2002/08/16 14:24:59 carl
  728. * issameref() to test if two references are the same (then emit no opcodes)
  729. + ret_in_reg to replace ret_in_acc
  730. (fix some register allocation bugs at the same time)
  731. + save_std_register now has an extra parameter which is the
  732. usedinproc registers
  733. Revision 1.66 2002/08/11 14:32:27 peter
  734. * renamed current_library to objectlibrary
  735. Revision 1.65 2002/08/11 13:24:13 peter
  736. * saving of asmsymbols in ppu supported
  737. * asmsymbollist global is removed and moved into a new class
  738. tasmlibrarydata that will hold the info of a .a file which
  739. corresponds with a single module. Added librarydata to tmodule
  740. to keep the library info stored for the module. In the future the
  741. objectfiles will also be stored to the tasmlibrarydata class
  742. * all getlabel/newasmsymbol and friends are moved to the new class
  743. Revision 1.64 2002/08/09 19:14:28 carl
  744. * fixed stackframe parameter (should only contain local size),
  745. set to zero currently
  746. Revision 1.63 2002/08/06 20:55:22 florian
  747. * first part of ppc calling conventions fix
  748. Revision 1.62 2002/07/26 21:15:41 florian
  749. * rewrote the system handling
  750. Revision 1.61 2002/07/20 11:57:56 florian
  751. * types.pas renamed to defbase.pas because D6 contains a types
  752. unit so this would conflicts if D6 programms are compiled
  753. + Willamette/SSE2 instructions to assembler added
  754. Revision 1.60 2002/07/19 11:41:36 daniel
  755. * State tracker work
  756. * The whilen and repeatn are now completely unified into whilerepeatn. This
  757. allows the state tracker to change while nodes automatically into
  758. repeat nodes.
  759. * Resulttypepass improvements to the notn. 'not not a' is optimized away and
  760. 'not(a>b)' is optimized into 'a<=b'.
  761. * Resulttypepass improvements to the whilerepeatn. 'while not a' is optimized
  762. by removing the notn and later switchting the true and falselabels. The
  763. same is done with 'repeat until not a'.
  764. Revision 1.59 2002/07/15 18:03:15 florian
  765. * readded removed changes
  766. Revision 1.57 2002/07/11 14:41:28 florian
  767. * start of the new generic parameter handling
  768. Revision 1.58 2002/07/14 18:00:44 daniel
  769. + Added the beginning of a state tracker. This will track the values of
  770. variables through procedures and optimize things away.
  771. Revision 1.56 2002/07/07 09:52:32 florian
  772. * powerpc target fixed, very simple units can be compiled
  773. * some basic stuff for better callparanode handling, far from being finished
  774. Revision 1.55 2002/07/04 20:43:01 florian
  775. * first x86-64 patches
  776. Revision 1.54 2002/07/01 18:46:25 peter
  777. * internal linker
  778. * reorganized aasm layer
  779. Revision 1.53 2002/05/18 13:34:14 peter
  780. * readded missing revisions
  781. Revision 1.52 2002/05/16 19:46:44 carl
  782. + defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
  783. + try to fix temp allocation (still in ifdef)
  784. + generic constructor calls
  785. + start of tassembler / tmodulebase class cleanup
  786. Revision 1.51 2002/05/14 19:34:49 peter
  787. * removed old logs and updated copyright year
  788. }