psub.pas 34 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936
  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. akttokenpos:=storepos;
  91. procinfo.set_result_offset;
  92. { insert result also if support is on }
  93. if (m_result in aktmodeswitches) then
  94. begin
  95. aktprocdef.resultfuncretsym:=tfuncretsym.create('RESULT',aktprocdef.rettype);
  96. symtablestack.insert(aktprocdef.resultfuncretsym);
  97. end;
  98. end;
  99. read_declarations(islibrary);
  100. procinfo.handle_body_start;
  101. {Unit initialization?.}
  102. if (lexlevel=unit_init_level) and (current_module.is_unit)
  103. or islibrary then
  104. begin
  105. if (token=_END) then
  106. begin
  107. consume(_END);
  108. { We need at least a node, else the entry/exit code is not
  109. generated and thus no PASCALMAIN symbol which we need (PFV) }
  110. if islibrary then
  111. block:=cnothingnode.create
  112. else
  113. block:=nil;
  114. end
  115. else
  116. begin
  117. if token=_INITIALIZATION then
  118. begin
  119. current_module.flags:=current_module.flags or uf_init;
  120. block:=statement_block(_INITIALIZATION);
  121. end
  122. else if (token=_FINALIZATION) then
  123. begin
  124. if (current_module.flags and uf_finalize)<>0 then
  125. block:=statement_block(_FINALIZATION)
  126. else
  127. begin
  128. { can we allow no INITIALIZATION for DLL ??
  129. I think it should work PM }
  130. block:=nil;
  131. exit;
  132. end;
  133. end
  134. else
  135. begin
  136. current_module.flags:=current_module.flags or uf_init;
  137. block:=statement_block(_BEGIN);
  138. end;
  139. end;
  140. end
  141. else
  142. block:=statement_block(_BEGIN);
  143. end;
  144. {****************************************************************************
  145. PROCEDURE/FUNCTION COMPILING
  146. ****************************************************************************}
  147. procedure compile_proc_body(make_global,parent_has_class:boolean);
  148. {
  149. Compile the body of a procedure
  150. }
  151. var
  152. oldexitlabel,oldexit2label : tasmlabel;
  153. oldfaillabel,oldquickexitlabel:tasmlabel;
  154. _class,hp:tobjectdef;
  155. { switches can change inside the procedure }
  156. entryswitches, exitswitches : tlocalswitches;
  157. oldaktmaxfpuregisters,localmaxfpuregisters : longint;
  158. { code for the subroutine as tree }
  159. code:tnode;
  160. { true when no stackframe is required }
  161. nostackframe:boolean;
  162. { number of bytes which have to be cleared by RET }
  163. parasize:longint;
  164. { filepositions }
  165. entrypos,
  166. savepos,
  167. exitpos : tfileposinfo;
  168. begin
  169. { calculate the lexical level }
  170. inc(lexlevel);
  171. if lexlevel>32 then
  172. Message(parser_e_too_much_lexlevel);
  173. { static is also important for local procedures !! }
  174. if (po_staticmethod in aktprocdef.procoptions) then
  175. allow_only_static:=true
  176. else if (lexlevel=normal_function_level) then
  177. allow_only_static:=false;
  178. { save old labels }
  179. oldexitlabel:=aktexitlabel;
  180. oldexit2label:=aktexit2label;
  181. oldquickexitlabel:=quickexitlabel;
  182. oldfaillabel:=faillabel;
  183. { get new labels }
  184. objectlibrary.getlabel(aktexitlabel);
  185. objectlibrary.getlabel(aktexit2label);
  186. { exit for fail in constructors }
  187. if (aktprocdef.proctypeoption=potype_constructor) then
  188. begin
  189. objectlibrary.getlabel(faillabel);
  190. objectlibrary.getlabel(quickexitlabel);
  191. end;
  192. { reset break and continue labels }
  193. block_type:=bt_general;
  194. aktbreaklabel:=nil;
  195. aktcontinuelabel:=nil;
  196. {$ifdef state_tracking}
  197. { aktstate:=Tstate_storage.create;}
  198. {$endif state_tracking}
  199. { insert symtables for the class, by only if it is no nested function }
  200. if assigned(procinfo._class) and not(parent_has_class) then
  201. begin
  202. { insert them in the reverse order ! }
  203. hp:=nil;
  204. repeat
  205. _class:=procinfo._class;
  206. while _class.childof<>hp do
  207. _class:=_class.childof;
  208. hp:=_class;
  209. _class.symtable.next:=symtablestack;
  210. symtablestack:=_class.symtable;
  211. until hp=procinfo._class;
  212. end;
  213. { insert parasymtable in symtablestack}
  214. { only if lexlevel > 1 !!! global symtable should be right after staticsymtazble
  215. for checking of same names used in interface and implementation !! }
  216. if lexlevel>=normal_function_level then
  217. begin
  218. aktprocdef.parast.next:=symtablestack;
  219. symtablestack:=aktprocdef.parast;
  220. symtablestack.symtablelevel:=lexlevel;
  221. end;
  222. { insert localsymtable in symtablestack}
  223. aktprocdef.localst.next:=symtablestack;
  224. symtablestack:=aktprocdef.localst;
  225. symtablestack.symtablelevel:=lexlevel;
  226. { constant symbols are inserted in this symboltable }
  227. constsymtable:=symtablestack;
  228. { reset the temporary memory }
  229. rg.cleartempgen;
  230. rg.usedinproc:=[];
  231. rg.usedbyproc:=[];
  232. { save entry info }
  233. entrypos:=aktfilepos;
  234. entryswitches:=aktlocalswitches;
  235. localmaxfpuregisters:=aktmaxfpuregisters;
  236. { parse the code ... }
  237. code:=block(current_module.islibrary);
  238. { get a better entry point }
  239. if assigned(code) then
  240. entrypos:=code.fileinfo;
  241. { save exit info }
  242. exitswitches:=aktlocalswitches;
  243. exitpos:=last_endtoken_filepos;
  244. { save current filepos }
  245. savepos:=aktfilepos;
  246. {When we are called to compile the body of a unit, aktprocsym should
  247. point to the unit initialization. If the unit has no initialization,
  248. aktprocsym=nil. But in that case code=nil. hus we should check for
  249. code=nil, when we use aktprocsym.}
  250. { set the start offset to the start of the temp area in the stack }
  251. tg.setfirsttemp(procinfo.firsttemp_offset);
  252. { ... and generate assembler }
  253. { but set the right switches for entry !! }
  254. aktlocalswitches:=entryswitches;
  255. oldaktmaxfpuregisters:=aktmaxfpuregisters;
  256. aktmaxfpuregisters:=localmaxfpuregisters;
  257. if assigned(code) then
  258. begin
  259. { the procedure is now defined }
  260. aktprocdef.forwarddef:=false;
  261. {$ifdef state_tracking}
  262. { writenode(code);
  263. do_track_state_pass(code);
  264. writenode(code);}
  265. {$endif}
  266. { only generate the code if no type errors are found, else
  267. finish at least the type checking pass }
  268. {$ifndef NOPASS2}
  269. if (status.errorcount=0) then
  270. begin
  271. generatecode(code);
  272. aktprocdef.code:=code;
  273. { first generate entry code with the correct position and switches }
  274. aktfilepos:=entrypos;
  275. aktlocalswitches:=entryswitches;
  276. genentrycode(procinfo.aktentrycode,make_global,0,parasize,nostackframe,false);
  277. { FPC_POPADDRSTACK destroys all registers (JM) }
  278. if (procinfo.flags and (pi_needs_implicit_finally or pi_uses_exceptions)) <> 0 then
  279. begin
  280. rg.usedinproc := ALL_REGISTERS;
  281. end;
  282. { now generate exit code with the correct position and switches }
  283. aktfilepos:=exitpos;
  284. aktlocalswitches:=exitswitches;
  285. genexitcode(procinfo.aktexitcode,parasize,nostackframe,false);
  286. { now all the registers used are known }
  287. aktprocdef.usedregisters:=rg.usedinproc;
  288. procinfo.aktproccode.insertlist(procinfo.aktentrycode);
  289. procinfo.aktproccode.concatlist(procinfo.aktexitcode);
  290. {$ifdef i386}
  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. {$endif i386}
  298. { save local data (casetable) also in the same file }
  299. if assigned(procinfo.aktlocaldata) and
  300. (not procinfo.aktlocaldata.empty) then
  301. begin
  302. procinfo.aktproccode.concat(Tai_section.Create(sec_data));
  303. procinfo.aktproccode.concatlist(procinfo.aktlocaldata);
  304. procinfo.aktproccode.concat(Tai_section.Create(sec_code));
  305. end;
  306. { add the procedure to the codesegment }
  307. if (cs_create_smart in aktmoduleswitches) then
  308. codeSegment.concat(Tai_cut.Create);
  309. codeSegment.concatlist(procinfo.aktproccode);
  310. end
  311. else
  312. do_resulttypepass(code);
  313. {$else NOPASS2}
  314. do_resulttypepass(code);
  315. {$endif NOPASS2}
  316. end;
  317. { ... remove symbol tables }
  318. if lexlevel>=normal_function_level then
  319. symtablestack:=symtablestack.next.next
  320. else
  321. symtablestack:=symtablestack.next;
  322. { ... check for unused symbols }
  323. { but only if there is no asm block }
  324. if assigned(code) then
  325. begin
  326. if (Errorcount=0) then
  327. begin
  328. { check if forwards are resolved }
  329. tstoredsymtable(aktprocdef.localst).check_forwards;
  330. { check if all labels are used }
  331. tstoredsymtable(aktprocdef.localst).checklabels;
  332. { remove cross unit overloads }
  333. tstoredsymtable(aktprocdef.localst).unchain_overloaded;
  334. end;
  335. if (procinfo.flags and pi_uses_asm)=0 then
  336. begin
  337. { not for unit init, becuase the var can be used in finalize,
  338. it will be done in proc_unit }
  339. if not(aktprocdef.proctypeoption
  340. in [potype_proginit,potype_unitinit,potype_unitfinalize]) then
  341. tstoredsymtable(aktprocdef.localst).allsymbolsused;
  342. tstoredsymtable(aktprocdef.parast).allsymbolsused;
  343. end;
  344. end;
  345. { the local symtables can be deleted, but the parast }
  346. { doesn't, (checking definitons when calling a }
  347. { function }
  348. { not for a inline procedure !! (PM) }
  349. { at lexlevel = 1 localst is the staticsymtable itself }
  350. { so no dispose here !! }
  351. if assigned(code) and
  352. not(cs_browser in aktmoduleswitches) and
  353. (aktprocdef.proccalloption<>pocall_inline) then
  354. begin
  355. if lexlevel>=normal_function_level then
  356. aktprocdef.localst.free;
  357. aktprocdef.localst:=nil;
  358. end;
  359. { all registers can be used again }
  360. rg.resetusableregisters;
  361. { only now we can remove the temps }
  362. tg.resettempgen;
  363. { remove code tree, if not inline procedure }
  364. if assigned(code) and (aktprocdef.proccalloption<>pocall_inline) then
  365. code.free;
  366. { remove class member symbol tables }
  367. while symtablestack.symtabletype=objectsymtable do
  368. symtablestack:=symtablestack.next;
  369. aktmaxfpuregisters:=oldaktmaxfpuregisters;
  370. {$ifdef state_tracking}
  371. { aktstate.destroy;}
  372. {$endif state_tracking}
  373. { restore filepos, the switches are already set }
  374. aktfilepos:=savepos;
  375. { restore labels }
  376. aktexitlabel:=oldexitlabel;
  377. aktexit2label:=oldexit2label;
  378. quickexitlabel:=oldquickexitlabel;
  379. faillabel:=oldfaillabel;
  380. { reset to normal non static function }
  381. if (lexlevel=normal_function_level) then
  382. allow_only_static:=false;
  383. { previous lexlevel }
  384. dec(lexlevel);
  385. end;
  386. {****************************************************************************
  387. PROCEDURE/FUNCTION PARSING
  388. ****************************************************************************}
  389. procedure checkvaluepara(p:tnamedindexitem;arg:pointer);
  390. var
  391. vs : tvarsym;
  392. s : string;
  393. begin
  394. if tsym(p).typ<>varsym then
  395. exit;
  396. with tvarsym(p) do
  397. begin
  398. if copy(name,1,3)='val' then
  399. begin
  400. s:=Copy(name,4,255);
  401. if not(po_assembler in aktprocdef.procoptions) then
  402. begin
  403. vs:=tvarsym.create(s,vartype);
  404. vs.fileinfo:=fileinfo;
  405. vs.varspez:=varspez;
  406. aktprocdef.localst.insert(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. assigned(aktprocsym.defs^.next) and
  521. aktprocsym.defs^.def.forwarddef and
  522. aktprocsym.defs^.def.interfacedef and
  523. not(assigned(aktprocsym.defs^.next^.next)) 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. begin
  546. end;
  547. {$endif i386}
  548. { pointer to the return value ? }
  549. if paramanager.ret_in_param(aktprocdef.rettype.def) then
  550. begin
  551. procinfo.return_offset:=procinfo.para_offset;
  552. inc(procinfo.para_offset,pointer_size);
  553. end;
  554. { allows to access the parameters of main functions in nested functions }
  555. aktprocdef.parast.address_fixup:=procinfo.para_offset;
  556. { when it is a value para and it needs a local copy then rename
  557. the parameter and insert a copy in the localst. This is not done
  558. for assembler procedures }
  559. if (not parse_only) and (not aktprocdef.forwarddef) then
  560. aktprocdef.parast.foreach_static({$ifdef FPCPROCVAR}@{$endif}checkvaluepara,nil);
  561. { restore file pos }
  562. aktfilepos:=oldfilepos;
  563. { compile procedure when a body is needed }
  564. if (pdflags and pd_body)<>0 then
  565. begin
  566. Message1(parser_p_procedure_start,
  567. aktprocdef.fullprocname);
  568. aktprocdef.aliasnames.insert(aktprocdef.mangledname);
  569. { set _FAIL as keyword if constructor }
  570. if (aktprocdef.proctypeoption=potype_constructor) then
  571. tokeninfo^[_FAIL].keyword:=m_all;
  572. if assigned(aktprocdef._class) then
  573. tokeninfo^[_SELF].keyword:=m_all;
  574. compile_proc_body(((pdflags and pd_global)<>0),assigned(oldprocinfo._class));
  575. { reset _FAIL as normal }
  576. if (aktprocdef.proctypeoption=potype_constructor) then
  577. tokeninfo^[_FAIL].keyword:=m_none;
  578. if assigned(aktprocdef._class) and (lexlevel=main_program_level) then
  579. tokeninfo^[_SELF].keyword:=m_none;
  580. consume(_SEMICOLON);
  581. end;
  582. { close }
  583. codegen_doneprocedure;
  584. { Restore old state }
  585. constsymtable:=oldconstsymtable;
  586. {$ifdef notused}
  587. { restore the interface order to maintain CRC values PM }
  588. if assigned(prevdef) and assigned(aktprocdef.nextoverloaded) then
  589. begin
  590. stdef:=aktprocdef;
  591. aktprocdef:=stdef.nextoverloaded;
  592. stdef.nextoverloaded:=prevdef.nextoverloaded;
  593. prevdef.nextoverloaded:=stdef;
  594. end;
  595. {$endif notused}
  596. aktprocsym:=oldprocsym;
  597. aktprocdef:=oldprocdef;
  598. procinfo:=oldprocinfo;
  599. otsym:=nil;
  600. end;
  601. {****************************************************************************
  602. DECLARATION PARSING
  603. ****************************************************************************}
  604. { search in symtablestack for not complete classes }
  605. procedure check_forward_class(p : tnamedindexitem;arg:pointer);
  606. begin
  607. if (tsym(p).typ=typesym) and
  608. (ttypesym(p).restype.def.deftype=objectdef) and
  609. (oo_is_forward in tobjectdef(ttypesym(p).restype.def).objectoptions) then
  610. MessagePos1(tsym(p).fileinfo,sym_e_forward_type_not_resolved,tsym(p).realname);
  611. end;
  612. procedure read_declarations(islibrary : boolean);
  613. procedure Not_supported_for_inline(t : ttoken);
  614. begin
  615. if assigned(aktprocsym) and
  616. (aktprocdef.proccalloption=pocall_inline) then
  617. Begin
  618. Message1(parser_w_not_supported_for_inline,tokenstring(t));
  619. Message(parser_w_inlining_disabled);
  620. aktprocdef.proccalloption:=pocall_fpccall;
  621. End;
  622. end;
  623. begin
  624. repeat
  625. case token of
  626. _LABEL:
  627. begin
  628. Not_supported_for_inline(token);
  629. label_dec;
  630. end;
  631. _CONST:
  632. begin
  633. Not_supported_for_inline(token);
  634. const_dec;
  635. end;
  636. _TYPE:
  637. begin
  638. Not_supported_for_inline(token);
  639. type_dec;
  640. end;
  641. _VAR:
  642. var_dec;
  643. _THREADVAR:
  644. threadvar_dec;
  645. _CONSTRUCTOR,_DESTRUCTOR,
  646. _FUNCTION,_PROCEDURE,_OPERATOR,_CLASS:
  647. begin
  648. Not_supported_for_inline(token);
  649. read_proc;
  650. end;
  651. _RESOURCESTRING:
  652. resourcestring_dec;
  653. _EXPORTS:
  654. begin
  655. Not_supported_for_inline(token);
  656. { here we should be at lexlevel 1, no ? PM }
  657. if (lexlevel<>main_program_level) or
  658. (current_module.is_unit) then
  659. begin
  660. Message(parser_e_syntax_error);
  661. consume_all_until(_SEMICOLON);
  662. end
  663. else if islibrary or (target_info.system in [system_i386_WIN32,system_i386_wdosx,system_i386_Netware])
  664. then // AD
  665. read_exports;
  666. end
  667. else break;
  668. end;
  669. until false;
  670. { check for incomplete class definitions, this is only required
  671. for fpc modes }
  672. if (m_fpc in aktmodeswitches) then
  673. symtablestack.foreach_static({$ifdef FPCPROCVAR}@{$endif}check_forward_class,nil);
  674. end;
  675. procedure read_interface_declarations;
  676. begin
  677. {Since the body is now parsed at lexlevel 1, and the declarations
  678. must be parsed at the same lexlevel we increase the lexlevel.}
  679. inc(lexlevel);
  680. repeat
  681. case token of
  682. _CONST :
  683. const_dec;
  684. _TYPE :
  685. type_dec;
  686. _VAR :
  687. var_dec;
  688. _THREADVAR :
  689. threadvar_dec;
  690. _RESOURCESTRING:
  691. resourcestring_dec;
  692. _FUNCTION,
  693. _PROCEDURE,
  694. _OPERATOR :
  695. read_proc;
  696. else
  697. break;
  698. end;
  699. until false;
  700. dec(lexlevel);
  701. { check for incomplete class definitions, this is only required
  702. for fpc modes }
  703. if (m_fpc in aktmodeswitches) then
  704. symtablestack.foreach_static({$ifdef FPCPROCVAR}@{$endif}check_forward_class,nil);
  705. end;
  706. end.
  707. {
  708. $Log$
  709. Revision 1.68 2002-08-17 09:23:41 florian
  710. * first part of procinfo rewrite
  711. Revision 1.67 2002/08/16 14:24:59 carl
  712. * issameref() to test if two references are the same (then emit no opcodes)
  713. + ret_in_reg to replace ret_in_acc
  714. (fix some register allocation bugs at the same time)
  715. + save_std_register now has an extra parameter which is the
  716. usedinproc registers
  717. Revision 1.66 2002/08/11 14:32:27 peter
  718. * renamed current_library to objectlibrary
  719. Revision 1.65 2002/08/11 13:24:13 peter
  720. * saving of asmsymbols in ppu supported
  721. * asmsymbollist global is removed and moved into a new class
  722. tasmlibrarydata that will hold the info of a .a file which
  723. corresponds with a single module. Added librarydata to tmodule
  724. to keep the library info stored for the module. In the future the
  725. objectfiles will also be stored to the tasmlibrarydata class
  726. * all getlabel/newasmsymbol and friends are moved to the new class
  727. Revision 1.64 2002/08/09 19:14:28 carl
  728. * fixed stackframe parameter (should only contain local size),
  729. set to zero currently
  730. Revision 1.63 2002/08/06 20:55:22 florian
  731. * first part of ppc calling conventions fix
  732. Revision 1.62 2002/07/26 21:15:41 florian
  733. * rewrote the system handling
  734. Revision 1.61 2002/07/20 11:57:56 florian
  735. * types.pas renamed to defbase.pas because D6 contains a types
  736. unit so this would conflicts if D6 programms are compiled
  737. + Willamette/SSE2 instructions to assembler added
  738. Revision 1.60 2002/07/19 11:41:36 daniel
  739. * State tracker work
  740. * The whilen and repeatn are now completely unified into whilerepeatn. This
  741. allows the state tracker to change while nodes automatically into
  742. repeat nodes.
  743. * Resulttypepass improvements to the notn. 'not not a' is optimized away and
  744. 'not(a>b)' is optimized into 'a<=b'.
  745. * Resulttypepass improvements to the whilerepeatn. 'while not a' is optimized
  746. by removing the notn and later switchting the true and falselabels. The
  747. same is done with 'repeat until not a'.
  748. Revision 1.59 2002/07/15 18:03:15 florian
  749. * readded removed changes
  750. Revision 1.57 2002/07/11 14:41:28 florian
  751. * start of the new generic parameter handling
  752. Revision 1.58 2002/07/14 18:00:44 daniel
  753. + Added the beginning of a state tracker. This will track the values of
  754. variables through procedures and optimize things away.
  755. Revision 1.56 2002/07/07 09:52:32 florian
  756. * powerpc target fixed, very simple units can be compiled
  757. * some basic stuff for better callparanode handling, far from being finished
  758. Revision 1.55 2002/07/04 20:43:01 florian
  759. * first x86-64 patches
  760. Revision 1.54 2002/07/01 18:46:25 peter
  761. * internal linker
  762. * reorganized aasm layer
  763. Revision 1.53 2002/05/18 13:34:14 peter
  764. * readded missing revisions
  765. Revision 1.52 2002/05/16 19:46:44 carl
  766. + defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
  767. + try to fix temp allocation (still in ifdef)
  768. + generic constructor calls
  769. + start of tassembler / tmodulebase class cleanup
  770. Revision 1.51 2002/05/14 19:34:49 peter
  771. * removed old logs and updated copyright year
  772. Revision 1.50 2002/05/12 16:53:09 peter
  773. * moved entry and exitcode to ncgutil and cgobj
  774. * foreach gets extra argument for passing local data to the
  775. iterator function
  776. * -CR checks also class typecasts at runtime by changing them
  777. into as
  778. * fixed compiler to cycle with the -CR option
  779. * fixed stabs with elf writer, finally the global variables can
  780. be watched
  781. * removed a lot of routines from cga unit and replaced them by
  782. calls to cgobj
  783. * u32bit-s32bit updates for and,or,xor nodes. When one element is
  784. u32bit then the other is typecasted also to u32bit without giving
  785. a rangecheck warning/error.
  786. * fixed pascal calling method with reversing also the high tree in
  787. the parast, detected by tcalcst3 test
  788. Revision 1.49 2002/04/20 21:32:24 carl
  789. + generic FPC_CHECKPOINTER
  790. + first parameter offset in stack now portable
  791. * rename some constants
  792. + move some cpu stuff to other units
  793. - remove unused constents
  794. * fix stacksize for some targets
  795. * fix generic size problems which depend now on EXTEND_SIZE constant
  796. Revision 1.48 2002/04/19 15:46:02 peter
  797. * mangledname rewrite, tprocdef.mangledname is now created dynamicly
  798. in most cases and not written to the ppu
  799. * add mangeledname_prefix() routine to generate the prefix of
  800. manglednames depending on the current procedure, object and module
  801. * removed static procprefix since the mangledname is now build only
  802. on demand from tprocdef.mangledname
  803. Revision 1.47 2002/04/15 19:01:28 carl
  804. + target_info.size_of_pointer -> pointer_Size
  805. Revision 1.46 2002/04/04 18:45:19 carl
  806. + added wdosx support (patch from Pavel)
  807. Revision 1.45 2002/03/31 20:26:36 jonas
  808. + a_loadfpu_* and a_loadmm_* methods in tcg
  809. * register allocation is now handled by a class and is mostly processor
  810. independent (+rgobj.pas and i386/rgcpu.pas)
  811. * temp allocation is now handled by a class (+tgobj.pas, -i386\tgcpu.pas)
  812. * some small improvements and fixes to the optimizer
  813. * some register allocation fixes
  814. * some fpuvaroffset fixes in the unary minus node
  815. * push/popusedregisters is now called rg.save/restoreusedregisters and
  816. (for i386) uses temps instead of push/pop's when using -Op3 (that code is
  817. also better optimizable)
  818. * fixed and optimized register saving/restoring for new/dispose nodes
  819. * LOC_FPU locations now also require their "register" field to be set to
  820. R_ST, not R_ST0 (the latter is used for LOC_CFPUREGISTER locations only)
  821. - list field removed of the tnode class because it's not used currently
  822. and can cause hard-to-find bugs
  823. Revision 1.44 2002/01/19 15:37:24 peter
  824. * commited the wrong file :(
  825. Revision 1.43 2002/01/19 15:20:09 peter
  826. * also check at the end of the implementation for incomplete classes
  827. Revision 1.42 2002/01/19 15:12:34 peter
  828. * check for unresolved forward classes in the interface
  829. }