pass_1.pas 7.9 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254
  1. {
  2. Copyright (c) 1998-2002 by Florian Klaempfl
  3. This unit handles the pass_typecheck and node conversion pass
  4. This program is free software; you can redistribute it and/or modify
  5. it under the terms of the GNU General Public License as published by
  6. the Free Software Foundation; either version 2 of the License, or
  7. (at your option) any later version.
  8. This program is distributed in the hope that it will be useful,
  9. but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  11. GNU General Public License for more details.
  12. You should have received a copy of the GNU General Public License
  13. along with this program; if not, write to the Free Software
  14. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  15. ****************************************************************************
  16. }
  17. unit pass_1;
  18. {$i fpcdefs.inc}
  19. interface
  20. uses
  21. node;
  22. procedure typecheckpass(var p : tnode);
  23. function do_typecheckpass(var p : tnode) : boolean;
  24. function do_typecheckpass_changed(var p : tnode; out nodechanged: boolean) : boolean;
  25. procedure firstpass(var p : tnode);
  26. function do_firstpass(var p : tnode) : boolean;
  27. {$ifdef state_tracking}
  28. procedure do_track_state_pass(p:Tnode);
  29. {$endif}
  30. implementation
  31. uses
  32. globtype,comphook,
  33. globals,
  34. procinfo,
  35. symdef
  36. {$ifdef extdebug}
  37. ,verbose,htypechk
  38. ,cgbase
  39. {$endif extdebug}
  40. {$ifdef state_tracking}
  41. ,nstate
  42. {$endif}
  43. ;
  44. {*****************************************************************************
  45. Global procedures
  46. *****************************************************************************}
  47. procedure typecheckpass_internal(var p : tnode; out node_changed: boolean);
  48. var
  49. oldcodegenerror : boolean;
  50. oldlocalswitches : tlocalswitches;
  51. oldverbosity : longint;
  52. oldpos : tfileposinfo;
  53. hp : tnode;
  54. begin
  55. node_changed:=false;
  56. if (p.resultdef=nil) then
  57. begin
  58. oldcodegenerror:=codegenerror;
  59. oldpos:=current_filepos;
  60. oldlocalswitches:=current_settings.localswitches;
  61. oldverbosity:=status.verbosity;
  62. codegenerror:=false;
  63. current_filepos:=p.fileinfo;
  64. current_settings.localswitches:=p.localswitches;
  65. status.verbosity:=p.verbosity;
  66. hp:=p.pass_typecheck;
  67. { should the node be replaced? }
  68. if assigned(hp) then
  69. begin
  70. node_changed:=true;
  71. p.free;
  72. { switch to new node }
  73. p:=hp;
  74. { run typecheckpass }
  75. typecheckpass(p);
  76. end;
  77. current_settings.localswitches:=oldlocalswitches;
  78. current_filepos:=oldpos;
  79. status.verbosity:=oldverbosity;
  80. if codegenerror then
  81. begin
  82. include(p.flags,nf_error);
  83. { default to errortype if no type is set yet }
  84. if p.resultdef=nil then
  85. p.resultdef:=generrordef;
  86. end;
  87. codegenerror:=codegenerror or oldcodegenerror;
  88. end
  89. else
  90. begin
  91. { update the codegenerror boolean with the previous result of this node }
  92. if (nf_error in p.flags) then
  93. codegenerror:=true;
  94. end;
  95. end;
  96. procedure typecheckpass(var p : tnode);
  97. var
  98. node_changed: boolean;
  99. begin
  100. typecheckpass_internal(p,node_changed);
  101. end;
  102. function do_typecheckpass_changed(var p : tnode; out nodechanged: boolean) : boolean;
  103. begin
  104. codegenerror:=false;
  105. typecheckpass_internal(p,nodechanged);
  106. do_typecheckpass_changed:=codegenerror;
  107. end;
  108. function do_typecheckpass(var p : tnode) : boolean;
  109. var
  110. nodechanged: boolean;
  111. begin
  112. result:=do_typecheckpass_changed(p,nodechanged);
  113. end;
  114. procedure firstpass(var p : tnode);
  115. var
  116. oldcodegenerror : boolean;
  117. oldlocalswitches : tlocalswitches;
  118. oldpos : tfileposinfo;
  119. oldverbosity: longint;
  120. hp : tnode;
  121. begin
  122. if (nf_pass1_done in p.flags) then
  123. exit;
  124. if not(nf_error in p.flags) then
  125. begin
  126. oldcodegenerror:=codegenerror;
  127. oldpos:=current_filepos;
  128. oldlocalswitches:=current_settings.localswitches;
  129. oldverbosity:=status.verbosity;
  130. codegenerror:=false;
  131. current_filepos:=p.fileinfo;
  132. current_settings.localswitches:=p.localswitches;
  133. status.verbosity:=p.verbosity;
  134. { checks make always a call }
  135. if ([cs_check_range,cs_check_overflow,cs_check_stack] * current_settings.localswitches <> []) then
  136. include(current_procinfo.flags,pi_do_call);
  137. { determine the resultdef if not done }
  138. if (p.resultdef=nil) then
  139. begin
  140. hp:=p.pass_typecheck;
  141. { should the node be replaced? }
  142. if assigned(hp) then
  143. begin
  144. p.free;
  145. { switch to new node }
  146. p:=hp;
  147. { run typecheckpass }
  148. typecheckpass(p);
  149. end;
  150. if codegenerror then
  151. begin
  152. include(p.flags,nf_error);
  153. { default to errortype if no type is set yet }
  154. if p.resultdef=nil then
  155. p.resultdef:=generrordef;
  156. end;
  157. codegenerror:=codegenerror or oldcodegenerror;
  158. end;
  159. if not(nf_error in p.flags) then
  160. begin
  161. { first pass }
  162. hp:=p.pass_1;
  163. { should the node be replaced? }
  164. if assigned(hp) then
  165. begin
  166. p.free;
  167. { switch to new node }
  168. p := hp;
  169. { run firstpass }
  170. firstpass(p);
  171. end
  172. else
  173. begin
  174. { inlining happens in pass_1 and can cause new }
  175. { simplify opportunities }
  176. hp:=p.simplify(true);
  177. if assigned(hp) then
  178. begin
  179. p.free;
  180. p := hp;
  181. firstpass(p);
  182. end;
  183. end;
  184. if codegenerror then
  185. include(p.flags,nf_error)
  186. else
  187. begin
  188. {$ifdef EXTDEBUG}
  189. if (p.expectloc=LOC_INVALID) then
  190. Comment(V_Warning,'Expectloc is not set in firstpass: '+nodetype2str[p.nodetype]);
  191. {$endif EXTDEBUG}
  192. end;
  193. end;
  194. include(p.flags,nf_pass1_done);
  195. codegenerror:=codegenerror or oldcodegenerror;
  196. current_settings.localswitches:=oldlocalswitches;
  197. current_filepos:=oldpos;
  198. status.verbosity:=oldverbosity;
  199. end
  200. else
  201. codegenerror:=true;
  202. end;
  203. function do_firstpass(var p : tnode) : boolean;
  204. begin
  205. codegenerror:=false;
  206. firstpass(p);
  207. {$ifdef state_tracking}
  208. writeln('TRACKSTART');
  209. writeln('before');
  210. writenode(p);
  211. do_track_state_pass(p);
  212. writeln('after');
  213. writenode(p);
  214. writeln('TRACKDONE');
  215. {$endif}
  216. do_firstpass:=codegenerror;
  217. end;
  218. {$ifdef state_tracking}
  219. procedure do_track_state_pass(p:Tnode);
  220. begin
  221. aktstate:=Tstate_storage.create;
  222. p.track_state_pass(true);
  223. aktstate.destroy;
  224. end;
  225. {$endif}
  226. end.