psub.pas 32 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892
  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. {$ifndef NoOpt}
  292. if (cs_optimize in aktglobalswitches) and
  293. { do not optimize pure assembler procedures }
  294. ((procinfo.flags and pi_is_assembler)=0) then
  295. Optimize(procinfo.aktproccode);
  296. {$endif NoOpt}
  297. { save local data (casetable) also in the same file }
  298. if assigned(procinfo.aktlocaldata) and
  299. (not procinfo.aktlocaldata.empty) then
  300. begin
  301. procinfo.aktproccode.concat(Tai_section.Create(sec_data));
  302. procinfo.aktproccode.concatlist(procinfo.aktlocaldata);
  303. procinfo.aktproccode.concat(Tai_section.Create(sec_code));
  304. end;
  305. { add the procedure to the codesegment }
  306. if (cs_create_smart in aktmoduleswitches) then
  307. codeSegment.concat(Tai_cut.Create);
  308. codeSegment.concatlist(procinfo.aktproccode);
  309. end
  310. else
  311. do_resulttypepass(code);
  312. {$else NOPASS2}
  313. do_resulttypepass(code);
  314. {$endif NOPASS2}
  315. end;
  316. { ... remove symbol tables }
  317. if lexlevel>=normal_function_level then
  318. symtablestack:=symtablestack.next.next
  319. else
  320. symtablestack:=symtablestack.next;
  321. { ... check for unused symbols }
  322. { but only if there is no asm block }
  323. if assigned(code) then
  324. begin
  325. if (Errorcount=0) then
  326. begin
  327. { check if forwards are resolved }
  328. tstoredsymtable(aktprocdef.localst).check_forwards;
  329. { check if all labels are used }
  330. tstoredsymtable(aktprocdef.localst).checklabels;
  331. { remove cross unit overloads }
  332. tstoredsymtable(aktprocdef.localst).unchain_overloaded;
  333. end;
  334. if (procinfo.flags and pi_uses_asm)=0 then
  335. begin
  336. { not for unit init, becuase the var can be used in finalize,
  337. it will be done in proc_unit }
  338. if not(aktprocdef.proctypeoption
  339. in [potype_proginit,potype_unitinit,potype_unitfinalize]) then
  340. tstoredsymtable(aktprocdef.localst).allsymbolsused;
  341. tstoredsymtable(aktprocdef.parast).allsymbolsused;
  342. end;
  343. end;
  344. { the local symtables can be deleted, but the parast }
  345. { doesn't, (checking definitons when calling a }
  346. { function }
  347. { not for a inline procedure !! (PM) }
  348. { at lexlevel = 1 localst is the staticsymtable itself }
  349. { so no dispose here !! }
  350. if assigned(code) and
  351. not(cs_browser in aktmoduleswitches) and
  352. (aktprocdef.proccalloption<>pocall_inline) then
  353. begin
  354. if lexlevel>=normal_function_level then
  355. aktprocdef.localst.free;
  356. aktprocdef.localst:=nil;
  357. end;
  358. { all registers can be used again }
  359. rg.resetusableregisters;
  360. { only now we can remove the temps }
  361. tg.resettempgen;
  362. { remove code tree, if not inline procedure }
  363. if assigned(code) and (aktprocdef.proccalloption<>pocall_inline) then
  364. code.free;
  365. { remove class member symbol tables }
  366. while symtablestack.symtabletype=objectsymtable do
  367. symtablestack:=symtablestack.next;
  368. aktmaxfpuregisters:=oldaktmaxfpuregisters;
  369. {$ifdef state_tracking}
  370. { aktstate.destroy;}
  371. {$endif state_tracking}
  372. { restore filepos, the switches are already set }
  373. aktfilepos:=savepos;
  374. { restore labels }
  375. aktexitlabel:=oldexitlabel;
  376. aktexit2label:=oldexit2label;
  377. quickexitlabel:=oldquickexitlabel;
  378. faillabel:=oldfaillabel;
  379. { reset to normal non static function }
  380. if (lexlevel=normal_function_level) then
  381. allow_only_static:=false;
  382. { previous lexlevel }
  383. dec(lexlevel);
  384. end;
  385. {****************************************************************************
  386. PROCEDURE/FUNCTION PARSING
  387. ****************************************************************************}
  388. procedure checkvaluepara(p:tnamedindexitem;arg:pointer);
  389. var
  390. vs : tvarsym;
  391. s : string;
  392. begin
  393. if tsym(p).typ<>varsym then
  394. exit;
  395. with tvarsym(p) do
  396. begin
  397. if copy(name,1,3)='val' then
  398. begin
  399. s:=Copy(name,4,255);
  400. if not(po_assembler in aktprocdef.procoptions) then
  401. begin
  402. vs:=tvarsym.create(s,vartype);
  403. vs.fileinfo:=fileinfo;
  404. vs.varspez:=varspez;
  405. aktprocdef.localst.insert(vs);
  406. aktprocdef.localst.insertvardata(vs);
  407. include(vs.varoptions,vo_is_local_copy);
  408. vs.varstate:=vs_assigned;
  409. localvarsym:=vs;
  410. inc(refs); { the para was used to set the local copy ! }
  411. { warnings only on local copy ! }
  412. varstate:=vs_used;
  413. end
  414. else
  415. begin
  416. aktprocdef.parast.rename(name,s);
  417. end;
  418. end;
  419. end;
  420. end;
  421. procedure read_proc;
  422. {
  423. Parses the procedure directives, then parses the procedure body, then
  424. generates the code for it
  425. }
  426. var
  427. oldprocsym : tprocsym;
  428. oldprocdef : tprocdef;
  429. oldprocinfo : tprocinfo;
  430. oldconstsymtable : tsymtable;
  431. oldfilepos : tfileposinfo;
  432. pdflags : word;
  433. begin
  434. { save old state }
  435. oldprocdef:=aktprocdef;
  436. oldprocsym:=aktprocsym;
  437. oldconstsymtable:=constsymtable;
  438. oldprocinfo:=procinfo;
  439. { create a new procedure }
  440. codegen_newprocedure;
  441. with procinfo do
  442. begin
  443. parent:=oldprocinfo;
  444. { clear flags }
  445. flags:=0;
  446. { standard frame pointer }
  447. framepointer:=frame_pointer_reg;
  448. { is this a nested function of a method ? }
  449. if assigned(oldprocinfo) then
  450. _class:=oldprocinfo._class;
  451. end;
  452. parse_proc_dec;
  453. procinfo.procdef:=aktprocdef;
  454. { set the default function options }
  455. if parse_only then
  456. begin
  457. aktprocdef.forwarddef:=true;
  458. { set also the interface flag, for better error message when the
  459. implementation doesn't much this header }
  460. aktprocdef.interfacedef:=true;
  461. pdflags:=pd_interface;
  462. end
  463. else
  464. begin
  465. pdflags:=pd_body;
  466. if current_module.in_implementation then
  467. pdflags:=pdflags or pd_implemen;
  468. if (not current_module.is_unit) or (cs_create_smart in aktmoduleswitches) then
  469. pdflags:=pdflags or pd_global;
  470. procinfo.exported:=false;
  471. aktprocdef.forwarddef:=false;
  472. end;
  473. { parse the directives that may follow }
  474. inc(lexlevel);
  475. parse_proc_directives(pdflags);
  476. dec(lexlevel);
  477. { hint directives, these can be separated by semicolons here,
  478. that need to be handled here with a loop (PFV) }
  479. while try_consume_hintdirective(aktprocsym.symoptions) do
  480. Consume(_SEMICOLON);
  481. { set aktfilepos to the beginning of the function declaration }
  482. oldfilepos:=aktfilepos;
  483. aktfilepos:=aktprocdef.fileinfo;
  484. { For varargs directive also cdecl and external must be defined }
  485. if (po_varargs in aktprocdef.procoptions) then
  486. begin
  487. { check first for external in the interface, if available there
  488. then the cdecl must also be there since there is no implementation
  489. available to contain it }
  490. if parse_only then
  491. begin
  492. { if external is available, then cdecl must also be available }
  493. if (po_external in aktprocdef.procoptions) and
  494. not(aktprocdef.proccalloption in [pocall_cdecl,pocall_cppdecl]) then
  495. Message(parser_e_varargs_need_cdecl_and_external);
  496. end
  497. else
  498. begin
  499. { both must be defined now }
  500. if not(po_external in aktprocdef.procoptions) or
  501. not(aktprocdef.proccalloption in [pocall_cdecl,pocall_cppdecl]) then
  502. Message(parser_e_varargs_need_cdecl_and_external);
  503. end;
  504. end;
  505. { search for forward declarations }
  506. if not proc_add_definition(aktprocsym,aktprocdef) then
  507. begin
  508. { A method must be forward defined (in the object declaration) }
  509. if assigned(procinfo._class) and
  510. (not assigned(oldprocinfo._class)) then
  511. begin
  512. Message1(parser_e_header_dont_match_any_member,aktprocdef.fullprocname);
  513. aktprocsym.write_parameter_lists(aktprocdef);
  514. end
  515. else
  516. begin
  517. { Give a better error if there is a forward def in the interface and only
  518. a single implementation }
  519. if (not aktprocdef.forwarddef) and
  520. (aktprocsym.procdef_count>1) and
  521. aktprocsym.first_procdef.forwarddef and
  522. aktprocsym.first_procdef.interfacedef and
  523. not(aktprocsym.procdef_count>2) then
  524. begin
  525. Message1(parser_e_header_dont_match_forward,aktprocdef.fullprocname);
  526. aktprocsym.write_parameter_lists(aktprocdef);
  527. end
  528. else
  529. begin
  530. { check the global flag, for delphi this is not
  531. required }
  532. if not(m_delphi in aktmodeswitches) and
  533. ((procinfo.flags and pi_is_global)<>0) then
  534. Message(parser_e_overloaded_must_be_all_global);
  535. end;
  536. end;
  537. end;
  538. { update procinfo, because the aktprocdef can be
  539. changed by check_identical_proc (PFV) }
  540. procinfo.procdef:=aktprocdef;
  541. {$ifdef i386}
  542. { add implicit pushes for interrupt routines }
  543. if (po_interrupt in aktprocdef.procoptions) then
  544. procinfo.allocate_interrupt_stackframe;
  545. {$endif i386}
  546. { pointer to the return value ? }
  547. if paramanager.ret_in_param(aktprocdef.rettype.def) then
  548. begin
  549. procinfo.return_offset:=procinfo.para_offset;
  550. inc(procinfo.para_offset,pointer_size);
  551. end;
  552. { allows to access the parameters of main functions in nested functions }
  553. aktprocdef.parast.address_fixup:=procinfo.para_offset;
  554. { when it is a value para and it needs a local copy then rename
  555. the parameter and insert a copy in the localst. This is not done
  556. for assembler procedures }
  557. if (not parse_only) and (not aktprocdef.forwarddef) then
  558. aktprocdef.parast.foreach_static({$ifdef FPCPROCVAR}@{$endif}checkvaluepara,nil);
  559. procinfo.after_header;
  560. { restore file pos }
  561. aktfilepos:=oldfilepos;
  562. { compile procedure when a body is needed }
  563. if (pdflags and pd_body)<>0 then
  564. begin
  565. Message1(parser_p_procedure_start,
  566. aktprocdef.fullprocname);
  567. aktprocdef.aliasnames.insert(aktprocdef.mangledname);
  568. { set _FAIL as keyword if constructor }
  569. if (aktprocdef.proctypeoption=potype_constructor) then
  570. tokeninfo^[_FAIL].keyword:=m_all;
  571. if assigned(aktprocdef._class) then
  572. tokeninfo^[_SELF].keyword:=m_all;
  573. compile_proc_body(((pdflags and pd_global)<>0),assigned(oldprocinfo._class));
  574. { reset _FAIL as normal }
  575. if (aktprocdef.proctypeoption=potype_constructor) then
  576. tokeninfo^[_FAIL].keyword:=m_none;
  577. if assigned(aktprocdef._class) and (lexlevel=main_program_level) then
  578. tokeninfo^[_SELF].keyword:=m_none;
  579. consume(_SEMICOLON);
  580. end;
  581. { close }
  582. codegen_doneprocedure;
  583. { Restore old state }
  584. constsymtable:=oldconstsymtable;
  585. {$ifdef notused}
  586. { restore the interface order to maintain CRC values PM }
  587. if assigned(prevdef) and assigned(aktprocdef.nextoverloaded) then
  588. begin
  589. stdef:=aktprocdef;
  590. aktprocdef:=stdef.nextoverloaded;
  591. stdef.nextoverloaded:=prevdef.nextoverloaded;
  592. prevdef.nextoverloaded:=stdef;
  593. end;
  594. {$endif notused}
  595. aktprocsym:=oldprocsym;
  596. aktprocdef:=oldprocdef;
  597. procinfo:=oldprocinfo;
  598. otsym:=nil;
  599. end;
  600. {****************************************************************************
  601. DECLARATION PARSING
  602. ****************************************************************************}
  603. { search in symtablestack for not complete classes }
  604. procedure check_forward_class(p : tnamedindexitem;arg:pointer);
  605. begin
  606. if (tsym(p).typ=typesym) and
  607. (ttypesym(p).restype.def.deftype=objectdef) and
  608. (oo_is_forward in tobjectdef(ttypesym(p).restype.def).objectoptions) then
  609. MessagePos1(tsym(p).fileinfo,sym_e_forward_type_not_resolved,tsym(p).realname);
  610. end;
  611. procedure read_declarations(islibrary : boolean);
  612. procedure Not_supported_for_inline(t : ttoken);
  613. begin
  614. if assigned(aktprocsym) and
  615. (aktprocdef.proccalloption=pocall_inline) then
  616. Begin
  617. Message1(parser_w_not_supported_for_inline,tokenstring(t));
  618. Message(parser_w_inlining_disabled);
  619. aktprocdef.proccalloption:=pocall_fpccall;
  620. End;
  621. end;
  622. begin
  623. repeat
  624. case token of
  625. _LABEL:
  626. begin
  627. Not_supported_for_inline(token);
  628. label_dec;
  629. end;
  630. _CONST:
  631. begin
  632. Not_supported_for_inline(token);
  633. const_dec;
  634. end;
  635. _TYPE:
  636. begin
  637. Not_supported_for_inline(token);
  638. type_dec;
  639. end;
  640. _VAR:
  641. var_dec;
  642. _THREADVAR:
  643. threadvar_dec;
  644. _CONSTRUCTOR,_DESTRUCTOR,
  645. _FUNCTION,_PROCEDURE,_OPERATOR,_CLASS:
  646. begin
  647. Not_supported_for_inline(token);
  648. read_proc;
  649. end;
  650. _RESOURCESTRING:
  651. resourcestring_dec;
  652. _EXPORTS:
  653. begin
  654. Not_supported_for_inline(token);
  655. { here we should be at lexlevel 1, no ? PM }
  656. if (lexlevel<>main_program_level) or
  657. (current_module.is_unit) then
  658. begin
  659. Message(parser_e_syntax_error);
  660. consume_all_until(_SEMICOLON);
  661. end
  662. else if islibrary or (target_info.system in [system_i386_WIN32,system_i386_wdosx,system_i386_Netware])
  663. then // AD
  664. read_exports;
  665. end
  666. else break;
  667. end;
  668. until false;
  669. { check for incomplete class definitions, this is only required
  670. for fpc modes }
  671. if (m_fpc in aktmodeswitches) then
  672. symtablestack.foreach_static({$ifdef FPCPROCVAR}@{$endif}check_forward_class,nil);
  673. end;
  674. procedure read_interface_declarations;
  675. begin
  676. {Since the body is now parsed at lexlevel 1, and the declarations
  677. must be parsed at the same lexlevel we increase the lexlevel.}
  678. inc(lexlevel);
  679. repeat
  680. case token of
  681. _CONST :
  682. const_dec;
  683. _TYPE :
  684. type_dec;
  685. _VAR :
  686. var_dec;
  687. _THREADVAR :
  688. threadvar_dec;
  689. _RESOURCESTRING:
  690. resourcestring_dec;
  691. _FUNCTION,
  692. _PROCEDURE,
  693. _OPERATOR :
  694. read_proc;
  695. else
  696. break;
  697. end;
  698. until false;
  699. dec(lexlevel);
  700. { check for incomplete class definitions, this is only required
  701. for fpc modes }
  702. if (m_fpc in aktmodeswitches) then
  703. symtablestack.foreach_static({$ifdef FPCPROCVAR}@{$endif}check_forward_class,nil);
  704. end;
  705. end.
  706. {
  707. $Log$
  708. Revision 1.73 2002-11-09 15:32:30 carl
  709. * noopt for non-i386 targets
  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. }