psub.pas 34 KB

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