comphook.pas 12 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428
  1. {
  2. $Id$
  3. Copyright (c) 1998-2002 by Peter Vreman
  4. This unit handles the compilerhooks for output to external programs
  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 comphook;
  19. {$i fpcdefs.inc}
  20. interface
  21. uses
  22. finput;
  23. Const
  24. { Levels }
  25. V_None = $0;
  26. V_Fatal = $1;
  27. V_Error = $2;
  28. V_Normal = $4; { doesn't show a text like Error: }
  29. V_Warning = $8;
  30. V_Note = $10;
  31. V_Hint = $20;
  32. V_LineInfoMask = $fff;
  33. { From here by default no line info }
  34. V_Info = $1000;
  35. V_Status = $2000;
  36. V_Used = $4000;
  37. V_Tried = $8000;
  38. V_Conditional = $10000;
  39. V_Debug = $20000;
  40. V_Executable = $40000;
  41. V_LevelMask = $fffffff;
  42. V_All = V_LevelMask;
  43. V_Default = V_Fatal + V_Error + V_Normal;
  44. { Flags }
  45. V_LineInfo = $10000000;
  46. const
  47. { RHIDE expect gcc like error output }
  48. fatalstr : string[20] = 'Fatal:';
  49. errorstr : string[20] = 'Error:';
  50. warningstr : string[20] = 'Warning:';
  51. notestr : string[20] = 'Note:';
  52. hintstr : string[20] = 'Hint:';
  53. type
  54. PCompilerStatus = ^TCompilerStatus;
  55. TCompilerStatus = record
  56. { Current status }
  57. currentmodule,
  58. currentsourcepath,
  59. currentsource : string; { filename }
  60. currentline,
  61. currentcolumn : longint; { current line and column }
  62. { Total Status }
  63. compiledlines : longint; { the number of lines which are compiled }
  64. errorcount : longint; { number of generated errors }
  65. { program info }
  66. isexe,
  67. islibrary : boolean;
  68. { Settings for the output }
  69. verbosity : longint;
  70. maxerrorcount : longint;
  71. errorwarning,
  72. errornote,
  73. errorhint,
  74. skip_error,
  75. use_stderr,
  76. use_redir,
  77. use_bugreport,
  78. use_gccoutput,
  79. compiling_current : boolean;
  80. { Redirection support }
  81. redirfile : text;
  82. { Special file for bug report }
  83. reportbugfile : text;
  84. end;
  85. var
  86. status : tcompilerstatus;
  87. { Default Functions }
  88. procedure def_stop;
  89. procedure def_halt(i : longint);
  90. Function def_status:boolean;
  91. Function def_comment(Level:Longint;const s:string):boolean;
  92. function def_internalerror(i:longint):boolean;
  93. procedure def_initsymbolinfo;
  94. procedure def_donesymbolinfo;
  95. procedure def_extractsymbolinfo;
  96. function def_openinputfile(const filename: string): tinputfile;
  97. Function def_getnamedfiletime(Const F : String) : Longint;
  98. {$ifdef DEBUG}
  99. { allow easy stopping in GDB
  100. using
  101. b DEF_GDB_STOP
  102. cond 1 LEVEL <= 8 }
  103. procedure def_gdb_stop(level : longint);
  104. {$endif DEBUG}
  105. { Function redirecting for IDE support }
  106. type
  107. tstopprocedure = procedure;
  108. thaltprocedure = procedure(i : longint);
  109. tstatusfunction = function:boolean;
  110. tcommentfunction = function(Level:Longint;const s:string):boolean;
  111. tinternalerrorfunction = function(i:longint):boolean;
  112. tinitsymbolinfoproc = procedure;
  113. tdonesymbolinfoproc = procedure;
  114. textractsymbolinfoproc = procedure;
  115. topeninputfilefunc = function(const filename: string): tinputfile;
  116. tgetnamedfiletimefunc = function(const filename: string): longint;
  117. const
  118. do_stop : tstopprocedure = {$ifdef FPCPROCVAR}@{$endif}def_stop;
  119. do_halt : thaltprocedure = {$ifdef FPCPROCVAR}@{$endif}def_halt;
  120. do_status : tstatusfunction = {$ifdef FPCPROCVAR}@{$endif}def_status;
  121. do_comment : tcommentfunction = {$ifdef FPCPROCVAR}@{$endif}def_comment;
  122. do_internalerror : tinternalerrorfunction = {$ifdef FPCPROCVAR}@{$endif}def_internalerror;
  123. do_initsymbolinfo : tinitsymbolinfoproc = {$ifdef FPCPROCVAR}@{$endif}def_initsymbolinfo;
  124. do_donesymbolinfo : tdonesymbolinfoproc = {$ifdef FPCPROCVAR}@{$endif}def_donesymbolinfo;
  125. do_extractsymbolinfo : textractsymbolinfoproc = {$ifdef FPCPROCVAR}@{$endif}def_extractsymbolinfo;
  126. do_openinputfile : topeninputfilefunc = {$ifdef FPCPROCVAR}@{$endif}def_openinputfile;
  127. do_getnamedfiletime : tgetnamedfiletimefunc = {$ifdef FPCPROCVAR}@{$endif}def_getnamedfiletime;
  128. implementation
  129. uses
  130. {$ifdef delphi}
  131. dmisc,
  132. {$else}
  133. dos,
  134. {$endif}
  135. cutils
  136. ;
  137. {****************************************************************************
  138. Helper Routines
  139. ****************************************************************************}
  140. function gccfilename(const s : string) : string;
  141. var
  142. i : longint;
  143. begin
  144. for i:=1to length(s) do
  145. begin
  146. case s[i] of
  147. '\' : gccfilename[i]:='/';
  148. 'A'..'Z' : gccfilename[i]:=chr(ord(s[i])+32);
  149. else
  150. gccfilename[i]:=s[i];
  151. end;
  152. end;
  153. gccfilename[0]:=s[0];
  154. end;
  155. function tostr(i : longint) : string;
  156. var
  157. hs : string;
  158. begin
  159. str(i,hs);
  160. tostr:=hs;
  161. end;
  162. {****************************************************************************
  163. Predefined default Handlers
  164. ****************************************************************************}
  165. { predefined handler when then compiler stops }
  166. procedure def_stop;
  167. begin
  168. Halt(1);
  169. end;
  170. {$ifdef DEBUG}
  171. { allow easy stopping in GDB
  172. using
  173. b DEF_GDB_STOP
  174. cond 1 LEVEL <= 8 }
  175. procedure def_gdb_stop(level : longint);
  176. begin
  177. { Its only a dummy for GDB }
  178. end;
  179. {$endif DEBUG}
  180. procedure def_halt(i : longint);
  181. begin
  182. halt(i);
  183. end;
  184. function def_status:boolean;
  185. begin
  186. def_status:=false; { never stop }
  187. { Status info?, Called every line }
  188. if ((status.verbosity and V_Status)<>0) then
  189. begin
  190. {$ifndef Delphi}
  191. if (status.compiledlines=1) then
  192. WriteLn(memavail shr 10,' Kb Free');
  193. {$endif Delphi}
  194. if (status.currentline>0) and (status.currentline mod 100=0) then
  195. {$ifdef FPC}
  196. WriteLn(status.currentline,' ',DStr(memavail shr 10),'/',DStr(system.heapsize shr 10),' Kb Free');
  197. {$else}
  198. {$ifndef Delphi}
  199. WriteLn(status.currentline,' ',DStr(memavail shr 10),' Kb Free');
  200. {$endif Delphi}
  201. {$endif}
  202. end
  203. end;
  204. Function def_comment(Level:Longint;const s:string):boolean;
  205. const
  206. rh_errorstr = 'error:';
  207. rh_warningstr = 'warning:';
  208. var
  209. hs : string;
  210. begin
  211. def_comment:=false; { never stop }
  212. hs:='';
  213. if not(status.use_gccoutput) then
  214. begin
  215. if (status.verbosity and Level)=V_Hint then
  216. hs:=hintstr;
  217. if (status.verbosity and Level)=V_Note then
  218. hs:=notestr;
  219. if (status.verbosity and Level)=V_Warning then
  220. hs:=warningstr;
  221. if (status.verbosity and Level)=V_Error then
  222. hs:=errorstr;
  223. if (status.verbosity and Level)=V_Fatal then
  224. hs:=fatalstr;
  225. if (status.verbosity and Level)=V_Used then
  226. hs:=PadSpace('('+status.currentmodule+')',10);
  227. end
  228. else
  229. begin
  230. if (status.verbosity and Level)=V_Hint then
  231. hs:=rh_warningstr;
  232. if (status.verbosity and Level)=V_Note then
  233. hs:=rh_warningstr;
  234. if (status.verbosity and Level)=V_Warning then
  235. hs:=rh_warningstr;
  236. if (status.verbosity and Level)=V_Error then
  237. hs:=rh_errorstr;
  238. if (status.verbosity and Level)=V_Fatal then
  239. hs:=rh_errorstr;
  240. end;
  241. { Generate line prefix }
  242. if ((Level and V_LineInfo)=V_LineInfo) and
  243. (status.currentsource<>'') and
  244. (status.currentline>0) then
  245. begin
  246. { Adding the column should not confuse RHIDE,
  247. even if it does not yet use it PM
  248. but only if it is after error or warning !! PM }
  249. if status.currentcolumn>0 then
  250. begin
  251. if status.use_gccoutput then
  252. hs:=gccfilename(status.currentsource)+':'+tostr(status.currentline)+': '+hs+' '+
  253. tostr(status.currentcolumn)+': '+s
  254. else
  255. hs:=status.currentsource+'('+tostr(status.currentline)+
  256. ','+tostr(status.currentcolumn)+') '+hs+' '+s;
  257. end
  258. else
  259. begin
  260. if status.use_gccoutput then
  261. hs:=gccfilename(status.currentsource)+': '+hs+' '+tostr(status.currentline)+': '+s
  262. else
  263. hs:=status.currentsource+'('+tostr(status.currentline)+') '+hs+' '+s;
  264. end;
  265. end
  266. else
  267. begin
  268. if hs<>'' then
  269. hs:=hs+' '+s
  270. else
  271. hs:=s;
  272. end;
  273. { Display line }
  274. if ((status.verbosity and (Level and V_LevelMask))=(Level and V_LevelMask)) then
  275. begin
  276. {$ifdef FPC}
  277. if status.use_stderr then
  278. begin
  279. writeln(stderr,hs);
  280. flush(stderr);
  281. end
  282. else
  283. {$endif}
  284. begin
  285. if status.use_redir then
  286. writeln(status.redirfile,hs)
  287. else
  288. writeln(hs);
  289. end;
  290. end;
  291. { include everything in the bugreport file }
  292. if status.use_bugreport then
  293. begin
  294. {$ifdef FPC}
  295. Write(status.reportbugfile,hexstr(level,8)+':');
  296. Writeln(status.reportbugfile,hs);
  297. {$endif}
  298. end;
  299. {$ifdef DEBUG}
  300. def_gdb_stop(level);
  301. {$endif DEBUG}
  302. end;
  303. function def_internalerror(i : longint) : boolean;
  304. begin
  305. do_comment(V_Fatal+V_LineInfo,'Internal error '+tostr(i));
  306. {$ifdef EXTDEBUG}
  307. {$ifdef FPC}
  308. { Internalerror() and def_internalerror() do not
  309. have a stackframe }
  310. dump_stack(stdout,get_caller_frame(get_frame));
  311. {$endif FPC}
  312. {$endif EXTDEBUG}
  313. def_internalerror:=true;
  314. end;
  315. procedure def_initsymbolinfo;
  316. begin
  317. end;
  318. procedure def_donesymbolinfo;
  319. begin
  320. end;
  321. procedure def_extractsymbolinfo;
  322. begin
  323. end;
  324. function def_openinputfile(const filename: string): tinputfile;
  325. begin
  326. def_openinputfile:=tdosinputfile.create(filename);
  327. end;
  328. Function def_GetNamedFileTime (Const F : String) : Longint;
  329. var
  330. L : Longint;
  331. info : SearchRec;
  332. begin
  333. l:=-1;
  334. {$ifdef delphi}
  335. dmisc.FindFirst (F,archive+readonly+hidden,info);
  336. {$else delphi}
  337. FindFirst (F,archive+readonly+hidden,info);
  338. {$endif delphi}
  339. if DosError=0 then
  340. l:=info.time;
  341. FindClose(info);
  342. def_GetNamedFileTime:=l;
  343. end;
  344. end.
  345. {
  346. $Log$
  347. Revision 1.26 2003-04-26 19:32:31 peter
  348. * print lineinfo for internalerror
  349. Revision 1.25 2003/02/15 22:20:43 carl
  350. + give line number of internal error
  351. Revision 1.24 2003/01/09 21:52:37 peter
  352. * merged some verbosity options.
  353. * V_LineInfo is a verbosity flag to include line info
  354. Revision 1.23 2002/12/29 14:57:50 peter
  355. * unit loading changed to first register units and load them
  356. afterwards. This is needed to support uses xxx in yyy correctly
  357. * unit dependency check fixed
  358. Revision 1.22 2002/12/20 18:14:23 peter
  359. * traceback added in EXTDEBUG mode for internalerror
  360. Revision 1.21 2002/11/15 01:58:46 peter
  361. * merged changes from 1.0.7 up to 04-11
  362. - -V option for generating bug report tracing
  363. - more tracing for option parsing
  364. - errors for cdecl and high()
  365. - win32 import stabs
  366. - win32 records<=8 are returned in eax:edx (turned off by default)
  367. - heaptrc update
  368. - more info for temp management in .s file with EXTDEBUG
  369. Revision 1.20 2002/09/05 19:29:42 peter
  370. * memdebug enhancements
  371. Revision 1.19 2002/05/18 13:34:06 peter
  372. * readded missing revisions
  373. Revision 1.18 2002/05/16 19:46:35 carl
  374. + defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
  375. + try to fix temp allocation (still in ifdef)
  376. + generic constructor calls
  377. + start of tassembler / tmodulebase class cleanup
  378. }