psub.pas 32 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888
  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. begin
  548. end;
  549. {$endif i386}
  550. { pointer to the return value ? }
  551. if paramanager.ret_in_param(aktprocdef.rettype.def) then
  552. begin
  553. procinfo.return_offset:=procinfo.para_offset;
  554. inc(procinfo.para_offset,pointer_size);
  555. end;
  556. { allows to access the parameters of main functions in nested functions }
  557. aktprocdef.parast.address_fixup:=procinfo.para_offset;
  558. { when it is a value para and it needs a local copy then rename
  559. the parameter and insert a copy in the localst. This is not done
  560. for assembler procedures }
  561. if (not parse_only) and (not aktprocdef.forwarddef) then
  562. aktprocdef.parast.foreach_static({$ifdef FPCPROCVAR}@{$endif}checkvaluepara,nil);
  563. { restore file pos }
  564. aktfilepos:=oldfilepos;
  565. { compile procedure when a body is needed }
  566. if (pdflags and pd_body)<>0 then
  567. begin
  568. Message1(parser_p_procedure_start,
  569. aktprocdef.fullprocname);
  570. aktprocdef.aliasnames.insert(aktprocdef.mangledname);
  571. { set _FAIL as keyword if constructor }
  572. if (aktprocdef.proctypeoption=potype_constructor) then
  573. tokeninfo^[_FAIL].keyword:=m_all;
  574. if assigned(aktprocdef._class) then
  575. tokeninfo^[_SELF].keyword:=m_all;
  576. compile_proc_body(((pdflags and pd_global)<>0),assigned(oldprocinfo._class));
  577. { reset _FAIL as normal }
  578. if (aktprocdef.proctypeoption=potype_constructor) then
  579. tokeninfo^[_FAIL].keyword:=m_none;
  580. if assigned(aktprocdef._class) and (lexlevel=main_program_level) then
  581. tokeninfo^[_SELF].keyword:=m_none;
  582. consume(_SEMICOLON);
  583. end;
  584. { close }
  585. codegen_doneprocedure;
  586. { Restore old state }
  587. constsymtable:=oldconstsymtable;
  588. {$ifdef notused}
  589. { restore the interface order to maintain CRC values PM }
  590. if assigned(prevdef) and assigned(aktprocdef.nextoverloaded) then
  591. begin
  592. stdef:=aktprocdef;
  593. aktprocdef:=stdef.nextoverloaded;
  594. stdef.nextoverloaded:=prevdef.nextoverloaded;
  595. prevdef.nextoverloaded:=stdef;
  596. end;
  597. {$endif notused}
  598. aktprocsym:=oldprocsym;
  599. aktprocdef:=oldprocdef;
  600. procinfo:=oldprocinfo;
  601. otsym:=nil;
  602. end;
  603. {****************************************************************************
  604. DECLARATION PARSING
  605. ****************************************************************************}
  606. { search in symtablestack for not complete classes }
  607. procedure check_forward_class(p : tnamedindexitem;arg:pointer);
  608. begin
  609. if (tsym(p).typ=typesym) and
  610. (ttypesym(p).restype.def.deftype=objectdef) and
  611. (oo_is_forward in tobjectdef(ttypesym(p).restype.def).objectoptions) then
  612. MessagePos1(tsym(p).fileinfo,sym_e_forward_type_not_resolved,tsym(p).realname);
  613. end;
  614. procedure read_declarations(islibrary : boolean);
  615. procedure Not_supported_for_inline(t : ttoken);
  616. begin
  617. if assigned(aktprocsym) and
  618. (aktprocdef.proccalloption=pocall_inline) then
  619. Begin
  620. Message1(parser_w_not_supported_for_inline,tokenstring(t));
  621. Message(parser_w_inlining_disabled);
  622. aktprocdef.proccalloption:=pocall_fpccall;
  623. End;
  624. end;
  625. begin
  626. repeat
  627. case token of
  628. _LABEL:
  629. begin
  630. Not_supported_for_inline(token);
  631. label_dec;
  632. end;
  633. _CONST:
  634. begin
  635. Not_supported_for_inline(token);
  636. const_dec;
  637. end;
  638. _TYPE:
  639. begin
  640. Not_supported_for_inline(token);
  641. type_dec;
  642. end;
  643. _VAR:
  644. var_dec;
  645. _THREADVAR:
  646. threadvar_dec;
  647. _CONSTRUCTOR,_DESTRUCTOR,
  648. _FUNCTION,_PROCEDURE,_OPERATOR,_CLASS:
  649. begin
  650. Not_supported_for_inline(token);
  651. read_proc;
  652. end;
  653. _RESOURCESTRING:
  654. resourcestring_dec;
  655. _EXPORTS:
  656. begin
  657. Not_supported_for_inline(token);
  658. { here we should be at lexlevel 1, no ? PM }
  659. if (lexlevel<>main_program_level) or
  660. (current_module.is_unit) then
  661. begin
  662. Message(parser_e_syntax_error);
  663. consume_all_until(_SEMICOLON);
  664. end
  665. else if islibrary or (target_info.system in [system_i386_WIN32,system_i386_wdosx,system_i386_Netware])
  666. then // AD
  667. read_exports;
  668. end
  669. else break;
  670. end;
  671. until false;
  672. { check for incomplete class definitions, this is only required
  673. for fpc modes }
  674. if (m_fpc in aktmodeswitches) then
  675. symtablestack.foreach_static({$ifdef FPCPROCVAR}@{$endif}check_forward_class,nil);
  676. end;
  677. procedure read_interface_declarations;
  678. begin
  679. {Since the body is now parsed at lexlevel 1, and the declarations
  680. must be parsed at the same lexlevel we increase the lexlevel.}
  681. inc(lexlevel);
  682. repeat
  683. case token of
  684. _CONST :
  685. const_dec;
  686. _TYPE :
  687. type_dec;
  688. _VAR :
  689. var_dec;
  690. _THREADVAR :
  691. threadvar_dec;
  692. _RESOURCESTRING:
  693. resourcestring_dec;
  694. _FUNCTION,
  695. _PROCEDURE,
  696. _OPERATOR :
  697. read_proc;
  698. else
  699. break;
  700. end;
  701. until false;
  702. dec(lexlevel);
  703. { check for incomplete class definitions, this is only required
  704. for fpc modes }
  705. if (m_fpc in aktmodeswitches) then
  706. symtablestack.foreach_static({$ifdef FPCPROCVAR}@{$endif}check_forward_class,nil);
  707. end;
  708. end.
  709. {
  710. $Log$
  711. Revision 1.71 2002-09-07 15:25:07 peter
  712. * old logs removed and tabs fixed
  713. Revision 1.70 2002/09/03 16:26:27 daniel
  714. * Make Tprocdef.defs protected
  715. Revision 1.69 2002/08/25 19:25:20 peter
  716. * sym.insert_in_data removed
  717. * symtable.insertvardata/insertconstdata added
  718. * removed insert_in_data call from symtable.insert, it needs to be
  719. called separatly. This allows to deref the address calculation
  720. * procedures now calculate the parast addresses after the procedure
  721. directives are parsed. This fixes the cdecl parast problem
  722. * push_addr_param has an extra argument that specifies if cdecl is used
  723. or not
  724. Revision 1.68 2002/08/17 09:23:41 florian
  725. * first part of procinfo rewrite
  726. Revision 1.67 2002/08/16 14:24:59 carl
  727. * issameref() to test if two references are the same (then emit no opcodes)
  728. + ret_in_reg to replace ret_in_acc
  729. (fix some register allocation bugs at the same time)
  730. + save_std_register now has an extra parameter which is the
  731. usedinproc registers
  732. Revision 1.66 2002/08/11 14:32:27 peter
  733. * renamed current_library to objectlibrary
  734. Revision 1.65 2002/08/11 13:24:13 peter
  735. * saving of asmsymbols in ppu supported
  736. * asmsymbollist global is removed and moved into a new class
  737. tasmlibrarydata that will hold the info of a .a file which
  738. corresponds with a single module. Added librarydata to tmodule
  739. to keep the library info stored for the module. In the future the
  740. objectfiles will also be stored to the tasmlibrarydata class
  741. * all getlabel/newasmsymbol and friends are moved to the new class
  742. Revision 1.64 2002/08/09 19:14:28 carl
  743. * fixed stackframe parameter (should only contain local size),
  744. set to zero currently
  745. Revision 1.63 2002/08/06 20:55:22 florian
  746. * first part of ppc calling conventions fix
  747. Revision 1.62 2002/07/26 21:15:41 florian
  748. * rewrote the system handling
  749. Revision 1.61 2002/07/20 11:57:56 florian
  750. * types.pas renamed to defbase.pas because D6 contains a types
  751. unit so this would conflicts if D6 programms are compiled
  752. + Willamette/SSE2 instructions to assembler added
  753. Revision 1.60 2002/07/19 11:41:36 daniel
  754. * State tracker work
  755. * The whilen and repeatn are now completely unified into whilerepeatn. This
  756. allows the state tracker to change while nodes automatically into
  757. repeat nodes.
  758. * Resulttypepass improvements to the notn. 'not not a' is optimized away and
  759. 'not(a>b)' is optimized into 'a<=b'.
  760. * Resulttypepass improvements to the whilerepeatn. 'while not a' is optimized
  761. by removing the notn and later switchting the true and falselabels. The
  762. same is done with 'repeat until not a'.
  763. Revision 1.59 2002/07/15 18:03:15 florian
  764. * readded removed changes
  765. Revision 1.57 2002/07/11 14:41:28 florian
  766. * start of the new generic parameter handling
  767. Revision 1.58 2002/07/14 18:00:44 daniel
  768. + Added the beginning of a state tracker. This will track the values of
  769. variables through procedures and optimize things away.
  770. Revision 1.56 2002/07/07 09:52:32 florian
  771. * powerpc target fixed, very simple units can be compiled
  772. * some basic stuff for better callparanode handling, far from being finished
  773. Revision 1.55 2002/07/04 20:43:01 florian
  774. * first x86-64 patches
  775. Revision 1.54 2002/07/01 18:46:25 peter
  776. * internal linker
  777. * reorganized aasm layer
  778. Revision 1.53 2002/05/18 13:34:14 peter
  779. * readded missing revisions
  780. Revision 1.52 2002/05/16 19:46:44 carl
  781. + defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
  782. + try to fix temp allocation (still in ifdef)
  783. + generic constructor calls
  784. + start of tassembler / tmodulebase class cleanup
  785. Revision 1.51 2002/05/14 19:34:49 peter
  786. * removed old logs and updated copyright year
  787. }