verbose.pas 43 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372
  1. {
  2. Copyright (c) 1998-2002 by Peter Vreman
  3. This unit handles the verbose management
  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 verbose;
  18. {$i fpcdefs.inc}
  19. interface
  20. uses
  21. {$IFNDEF USE_FAKE_SYSUTILS}
  22. sysutils,
  23. {$ELSE}
  24. fksysutl,
  25. {$ENDIF}
  26. cutils,
  27. globtype,finput,
  28. cmsgs;
  29. {$ifndef EXTERN_MSG}
  30. {$i msgtxt.inc}
  31. {$endif}
  32. {$i msgidx.inc}
  33. Const
  34. { Levels }
  35. V_None = $0;
  36. V_Fatal = $1;
  37. V_Error = $2;
  38. V_Normal = $4; { doesn't show a text like Error: }
  39. V_Warning = $8;
  40. V_Note = $10;
  41. V_Hint = $20;
  42. V_LineInfoMask = $fff;
  43. { From here by default no line info }
  44. V_Info = $1000;
  45. V_Status = $2000;
  46. V_Used = $4000;
  47. V_Tried = $8000;
  48. V_Conditional = $10000;
  49. V_Debug = $20000;
  50. V_Executable = $40000;
  51. V_LevelMask = $fffffff;
  52. V_All = V_LevelMask;
  53. V_Default = V_Fatal + V_Error + V_Normal;
  54. { Flags }
  55. V_LineInfo = $10000000;
  56. var
  57. msg : pmessage;
  58. paraprintnodetree : byte;
  59. type
  60. tmsgqueueevent = procedure(const s:TMsgStr;v,w:longint) of object;
  61. const
  62. msgfilename : string = '';
  63. procedure SetRedirectFile(const fn:string);
  64. function SetVerbosity(const s:string):boolean;
  65. procedure PrepareReport;
  66. function CheckVerbosity(v:longint):boolean;
  67. function SetMessageVerbosity(v:longint;state:tmsgstate):boolean;
  68. procedure RestoreLocalVerbosity(pstate : pmessagestaterecord);
  69. procedure FreeLocalVerbosity(var fstate : pmessagestaterecord);
  70. function ChangeMessageVerbosity(s: string; var i: integer;state:tmsgstate): boolean;
  71. procedure ShowStatus;
  72. function ErrorCount:longint;
  73. procedure SetErrorFlags(const s:string);
  74. procedure GenerateError;
  75. procedure Internalerror(i:longint);{$ifndef VER2_6}noreturn;{$endif VER2_6}
  76. procedure Comment(l:longint;s:ansistring);
  77. function MessageStr(w:longint):TMsgStr;
  78. procedure Message(w:longint;onqueue:tmsgqueueevent=nil);
  79. procedure Message1(w:longint;const s1:TMsgStr;onqueue:tmsgqueueevent=nil);
  80. procedure Message2(w:longint;const s1,s2:TMsgStr;onqueue:tmsgqueueevent=nil);
  81. procedure Message3(w:longint;const s1,s2,s3:TMsgStr;onqueue:tmsgqueueevent=nil);
  82. procedure Message4(w:longint;const s1,s2,s3,s4:TMsgStr;onqueue:tmsgqueueevent=nil);
  83. procedure MessagePos(const pos:tfileposinfo;w:longint;onqueue:tmsgqueueevent=nil);
  84. procedure MessagePos1(const pos:tfileposinfo;w:longint;const s1:TMsgStr;onqueue:tmsgqueueevent=nil);
  85. procedure MessagePos2(const pos:tfileposinfo;w:longint;const s1,s2:TMsgStr;onqueue:tmsgqueueevent=nil);
  86. procedure MessagePos3(const pos:tfileposinfo;w:longint;const s1,s2,s3:TMsgStr;onqueue:tmsgqueueevent=nil);
  87. procedure MessagePos4(const pos:tfileposinfo;w:longint;const s1,s2,s3,s4:TMsgStr;onqueue:tmsgqueueevent=nil);
  88. { message calls with codegenerror support }
  89. procedure cgmessage(t : longint);
  90. procedure cgmessage1(t : longint;const s : TMsgStr);
  91. procedure cgmessage2(t : longint;const s1,s2 : TMsgStr);
  92. procedure cgmessage3(t : longint;const s1,s2,s3 : TMsgStr);
  93. procedure CGMessagePos(const pos:tfileposinfo;t:longint);
  94. procedure CGMessagePos1(const pos:tfileposinfo;t:longint;const s1:TMsgStr);
  95. procedure CGMessagePos2(const pos:tfileposinfo;t:longint;const s1,s2:TMsgStr);
  96. procedure CGMessagePos3(const pos:tfileposinfo;t:longint;const s1,s2,s3:TMsgStr);
  97. procedure FlushOutput;
  98. procedure InitVerbose;
  99. procedure DoneVerbose;
  100. const
  101. printnodespacing = ' ';
  102. var
  103. { indention used when writing a node tree to the screen }
  104. printnodeindention : string;
  105. { Node dumping support functions }
  106. procedure printnodeindent; inline;
  107. procedure printnodeunindent; inline;
  108. {$ifdef DEBUG_NODE_XML}
  109. function SanitiseXMLString(const S: ansistring): ansistring;
  110. function WritePointer(const P: Pointer): ansistring;
  111. function WriteGUID(const GUID: TGUID): ansistring;
  112. {$endif DEBUG_NODE_XML}
  113. implementation
  114. uses
  115. comphook,fmodule,constexp,globals,cfileutl,switches;
  116. {****************************************************************************
  117. Extra Handlers for default compiler
  118. ****************************************************************************}
  119. procedure DoneRedirectFile;
  120. begin
  121. if status.use_redir then
  122. begin
  123. close(status.redirfile);
  124. status.use_redir:=false;
  125. end;
  126. if status.use_bugreport then
  127. begin
  128. close(status.reportbugfile);
  129. status.use_bugreport:=false;
  130. end;
  131. end;
  132. procedure SetRedirectFile(const fn:string);
  133. begin
  134. { close old redirection file because FileRedirection is handled in both passes }
  135. if status.use_redir then
  136. close(status.redirfile);
  137. assign(status.redirfile,fn);
  138. {$push}{$I-}
  139. append(status.redirfile);
  140. if ioresult <> 0 then
  141. begin
  142. assign(status.redirfile,fn);
  143. rewrite(status.redirfile);
  144. end;
  145. {$pop}
  146. status.use_redir:=(ioresult=0);
  147. end;
  148. procedure PrepareReport;
  149. var
  150. fn : string;
  151. begin
  152. if status.use_bugreport then
  153. exit;
  154. fn:='fpcdebug.txt';
  155. assign(status.reportbugfile,fn);
  156. {$push}{$I-}
  157. append(status.reportbugfile);
  158. if ioresult <> 0 then
  159. rewrite(status.reportbugfile);
  160. {$pop}
  161. status.use_bugreport:=(ioresult=0);
  162. if status.use_bugreport then
  163. writeln(status.reportbugfile,'FPC bug report file');
  164. end;
  165. procedure RestoreLocalVerbosity(pstate : pmessagestaterecord);
  166. begin
  167. msg^.ResetStates;
  168. while assigned(pstate) do
  169. begin
  170. SetMessageVerbosity(pstate^.value,pstate^.state);
  171. pstate:=pstate^.next;
  172. end;
  173. end;
  174. procedure FreeLocalVerbosity(var fstate : pmessagestaterecord);
  175. var pstate : pmessagestaterecord;
  176. begin
  177. pstate:=unaligned(fstate);
  178. while assigned(pstate) do
  179. begin
  180. unaligned(fstate):=pstate^.next;
  181. freemem(pstate);
  182. pstate:=unaligned(fstate);
  183. end;
  184. end;
  185. function ChangeMessageVerbosity(s: string; var i : integer;state:tmsgstate): boolean;
  186. var
  187. tok : string;
  188. msgnr, code : longint;
  189. begin
  190. { delete everything up to and including 'm' }
  191. delete(s,1,i);
  192. { the rest of the string must be message numbers }
  193. inc(i,length(s)+1);
  194. result:=false;
  195. repeat
  196. tok:=GetToken(s,',');
  197. if (tok='') then
  198. break;
  199. val(tok, msgnr, code);
  200. if (code<>0) then
  201. exit;
  202. if not msg^.setverbosity(msgnr,state) then
  203. exit
  204. else
  205. recordpendingmessagestate(msgnr, state);
  206. until false;
  207. result:=true;
  208. end;
  209. function SetMessageVerbosity(v:longint;state:tmsgstate):boolean;
  210. begin
  211. result:=msg^.setverbosity(v,state);
  212. end;
  213. function CheckVerbosity(v:longint):boolean;
  214. begin
  215. result:=do_checkverbosity(v);
  216. end;
  217. function SetVerbosity(const s:string):boolean;
  218. const
  219. message_verbosity:array[boolean] of tmsgstate=(ms_off_global,ms_on_global);
  220. var
  221. m : Longint;
  222. i : Integer;
  223. inverse : boolean;
  224. c : char;
  225. begin
  226. Setverbosity:=false;
  227. val(s,m,i);
  228. if (i=0) and (s<>'') then
  229. status.verbosity:=m
  230. else
  231. begin
  232. i:=1;
  233. while i<=length(s) do
  234. begin
  235. c:=upcase(s[i]);
  236. inverse:=false;
  237. { on/off ? }
  238. if (i<length(s)) then
  239. case s[i+1] of
  240. '-' : begin
  241. inc(i);
  242. inverse:=true;
  243. end;
  244. '+' : inc(i);
  245. end;
  246. { handle switch }
  247. case c of
  248. { Special cases }
  249. '0' : status.verbosity:=V_Default;
  250. 'A' : status.verbosity:=V_All;
  251. 'B' : begin
  252. if inverse then
  253. status.print_source_path:=false
  254. else
  255. status.print_source_path:=true;
  256. end;
  257. 'M' : if not ChangeMessageVerbosity(s,i,message_verbosity[inverse]) then
  258. begin
  259. result:=false;
  260. exit
  261. end;
  262. 'P' : begin
  263. if inverse then
  264. paraprintnodetree:=0
  265. else
  266. paraprintnodetree:=1;
  267. end;
  268. 'Q' : begin
  269. if inverse then
  270. status.showmsgnrs:=false
  271. else
  272. status.showmsgnrs:=true;
  273. end;
  274. 'R' : begin
  275. if inverse then
  276. begin
  277. status.use_gccoutput:=false;
  278. status.use_stderr:=false;
  279. end
  280. else
  281. begin
  282. status.use_gccoutput:=true;
  283. status.use_stderr:=true;
  284. end;
  285. end;
  286. 'V' : PrepareReport;
  287. 'Z' : begin
  288. if inverse then
  289. status.use_stderr:=false
  290. else
  291. status.use_stderr:=true;
  292. end;
  293. { Normal cases - do an or }
  294. 'C' : if inverse then
  295. status.verbosity:=status.verbosity and (not V_Conditional)
  296. else
  297. status.verbosity:=status.verbosity or V_Conditional;
  298. 'D' : if inverse then
  299. status.verbosity:=status.verbosity and (not V_Debug)
  300. else
  301. status.verbosity:=status.verbosity or V_Debug;
  302. 'E' : if inverse then
  303. status.verbosity:=status.verbosity and (not V_Error)
  304. else
  305. status.verbosity:=status.verbosity or V_Error;
  306. 'H' : if inverse then
  307. status.verbosity:=status.verbosity and (not V_Hint)
  308. else
  309. status.verbosity:=status.verbosity or V_Hint;
  310. 'I' : if inverse then
  311. status.verbosity:=status.verbosity and (not V_Info)
  312. else
  313. status.verbosity:=status.verbosity or V_Info;
  314. 'L' : if inverse then
  315. status.verbosity:=status.verbosity and (not V_Status)
  316. else
  317. status.verbosity:=status.verbosity or V_Status;
  318. 'N' : if inverse then
  319. status.verbosity:=status.verbosity and (not V_Note)
  320. else
  321. status.verbosity:=status.verbosity or V_Note;
  322. 'S' : if inverse then
  323. status.verbosity:=status.verbosity and (not V_TimeStamps)
  324. else
  325. status.verbosity:=status.verbosity or V_TimeStamps;
  326. 'T' : if inverse then
  327. status.verbosity:=status.verbosity and (not V_Tried)
  328. else
  329. status.verbosity:=status.verbosity or V_Tried;
  330. 'U' : if inverse then
  331. status.verbosity:=status.verbosity and (not V_Used)
  332. else
  333. status.verbosity:=status.verbosity or V_Used;
  334. 'W' : if inverse then
  335. status.verbosity:=status.verbosity and (not V_Warning)
  336. else
  337. status.verbosity:=status.verbosity or V_Warning;
  338. 'X' : if inverse then
  339. status.verbosity:=status.verbosity and (not V_Executable)
  340. else
  341. status.verbosity:=status.verbosity or V_Executable;
  342. end;
  343. inc(i);
  344. end;
  345. end;
  346. if status.verbosity=0 then
  347. status.verbosity:=V_Default;
  348. setverbosity:=true;
  349. end;
  350. procedure Loadprefixes;
  351. function loadprefix(w:longint):string;
  352. var
  353. s : string;
  354. idx : longint;
  355. begin
  356. s:=msg^.get(w,[]);
  357. idx:=pos('_',s);
  358. if idx>0 then
  359. Loadprefix:=Copy(s,idx+1,255)
  360. else
  361. Loadprefix:=s;
  362. end;
  363. begin
  364. { Load the prefixes }
  365. fatalstr:=Loadprefix(general_i_fatal);
  366. errorstr:=Loadprefix(general_i_error);
  367. warningstr:=Loadprefix(general_i_warning);
  368. notestr:=Loadprefix(general_i_note);
  369. hintstr:=Loadprefix(general_i_hint);
  370. end;
  371. procedure LoadMsgFile(const fn:string);
  372. begin
  373. { reload the internal messages if not already loaded }
  374. {$ifndef EXTERN_MSG}
  375. if not msg^.msgintern then
  376. msg^.LoadIntern(@msgtxt,msgtxtsize,msgtxt_codepage);
  377. {$endif}
  378. if not msg^.LoadExtern(fn) then
  379. begin
  380. {$ifdef EXTERN_MSG}
  381. writeln('Fatal: Cannot find error message file.');
  382. halt(3);
  383. {$else}
  384. msg^.LoadIntern(@msgtxt,msgtxtsize,msgtxt_codepage);
  385. {$endif}
  386. end;
  387. { reload the prefixes using the new messages }
  388. Loadprefixes;
  389. end;
  390. procedure MaybeLoadMessageFile;
  391. begin
  392. { Load new message file }
  393. if (msgfilename<>'') then
  394. begin
  395. LoadMsgFile(msgfilename);
  396. msgfilename:='';
  397. end;
  398. end;
  399. var
  400. lastfileidx,
  401. lastmoduleidx : longint;
  402. Procedure UpdateStatus;
  403. var
  404. module : tmodule;
  405. begin
  406. { fix status }
  407. status.currentline:=current_filepos.line;
  408. status.currentcolumn:=current_filepos.column;
  409. if (current_filepos.moduleindex <> lastmoduleidx) or
  410. (current_filepos.fileindex <> lastfileidx) then
  411. begin
  412. module:=get_module(current_filepos.moduleindex);
  413. if assigned(module) and assigned(module.sourcefiles) then
  414. begin
  415. { update status record }
  416. status.currentmodule:=module.modulename^;
  417. status.currentsourceppufilename:=module.ppufilename;
  418. status.currentmodulestate:=ModuleStateStr[module.state];
  419. status.currentsource:=module.sourcefiles.get_file_name(current_filepos.fileindex);
  420. status.currentsourcepath:=module.sourcefiles.get_file_path(current_filepos.fileindex);
  421. status.sources_avail:=module.sources_avail;
  422. { if currentsourcepath is relative, make it absolute }
  423. if not path_absolute(status.currentsourcepath) then
  424. status.currentsourcepath:=GetCurrentDir+status.currentsourcepath;
  425. { update lastfileidx only if name known PM }
  426. if status.currentsource<>'' then
  427. lastfileidx:=current_filepos.fileindex
  428. else
  429. lastfileidx:=0;
  430. lastmoduleidx:=module.unit_index;
  431. end;
  432. end;
  433. end;
  434. procedure ShowStatus;
  435. begin
  436. UpdateStatus;
  437. if do_status() then
  438. raise ECompilerAbort.Create;
  439. end;
  440. function ErrorCount:longint;
  441. begin
  442. ErrorCount:=status.errorcount;
  443. end;
  444. procedure SetErrorFlags(const s:string);
  445. var
  446. code : integer;
  447. i,j,l : longint;
  448. begin
  449. { empty string means error count = 1 for backward compatibility (PFV) }
  450. if s='' then
  451. begin
  452. status.maxerrorcount:=1;
  453. exit;
  454. end;
  455. i:=0;
  456. while (i<length(s)) do
  457. begin
  458. inc(i);
  459. case s[i] of
  460. '0'..'9' :
  461. begin
  462. j:=i;
  463. while (j<=length(s)) and (s[j] in ['0'..'9']) do
  464. inc(j);
  465. val(copy(s,i,j-i),l,code);
  466. if code<>0 then
  467. l:=1;
  468. status.maxerrorcount:=l;
  469. i:=j-1;
  470. end;
  471. 'w','W' :
  472. begin
  473. if (i<length(s)) and (s[i+1]='-') then
  474. begin
  475. inc(i);
  476. status.errorwarning:=false;
  477. end
  478. else
  479. begin
  480. status.errorwarning:=true;
  481. { Enable writing of warnings, to avoid getting errors without any message }
  482. status.verbosity:=status.verbosity or V_Warning;
  483. end;
  484. end;
  485. 'n','N' :
  486. begin
  487. if (i<length(s)) and (s[i+1]='-') then
  488. begin
  489. inc(i);
  490. status.errornote:=false;
  491. end
  492. else
  493. begin
  494. status.errornote:=true;
  495. { Enable writing of notes, to avoid getting errors without any message }
  496. status.verbosity:=status.verbosity or V_Note;
  497. end;
  498. end;
  499. 'h','H' :
  500. begin
  501. if (i<length(s)) and (s[i+1]='-') then
  502. begin
  503. inc(i);
  504. status.errorhint:=false;
  505. end
  506. else
  507. begin
  508. status.errorhint:=true;
  509. { Enable writing of hints, to avoid getting errors without any message }
  510. status.verbosity:=status.verbosity or V_Hint;
  511. end;
  512. end;
  513. end;
  514. end;
  515. end;
  516. procedure GenerateError;
  517. begin
  518. inc(status.errorcount);
  519. end;
  520. procedure internalerror(i : longint);{$ifndef VER2_6}noreturn;{$endif VER2_6}
  521. begin
  522. UpdateStatus;
  523. do_internalerror(i);
  524. GenerateError;
  525. raise ECompilerAbort.Create;
  526. end;
  527. procedure Comment(l:longint;s:ansistring);
  528. var
  529. dostop : boolean;
  530. begin
  531. dostop:=((l and V_Fatal)<>0);
  532. if ((l and V_Error)<>0) or
  533. ((l and V_Fatal)<>0) or
  534. (status.errorwarning and ((l and V_Warning)<>0)) or
  535. (status.errornote and ((l and V_Note)<>0)) or
  536. (status.errorhint and ((l and V_Hint)<>0)) then
  537. GenerateError
  538. else
  539. if l and V_Warning <> 0 then
  540. inc(status.countWarnings)
  541. else
  542. if l and V_Note <> 0 then
  543. inc(status.countNotes)
  544. else
  545. if l and V_Hint <> 0 then
  546. inc(status.countHints);
  547. { check verbosity level }
  548. if not CheckVerbosity(l) then
  549. exit;
  550. if (l and V_LineInfoMask)<>0 then
  551. l:=l or V_LineInfo;
  552. { Create status info }
  553. UpdateStatus;
  554. { Fix replacements }
  555. DefaultReplacements(s);
  556. { show comment }
  557. if do_comment(l,s) or dostop then
  558. raise ECompilerAbort.Create;
  559. if (status.errorcount>=status.maxerrorcount) and not status.skip_error then
  560. begin
  561. Message1(unit_f_errors_in_unit,tostr(status.errorcount));
  562. status.skip_error:=true;
  563. raise ECompilerAbort.Create;
  564. end;
  565. end;
  566. function GetMessageState(m:longint):tmsgstate;
  567. var
  568. i: integer;
  569. begin
  570. i:=m div 1000;
  571. { get the default state }
  572. Result:=msg^.msgstates[i]^[m mod 1000];
  573. { and search at the current unit settings }
  574. { todo }
  575. end;
  576. Procedure Msg2Comment(s:ansistring;w:longint;onqueue:tmsgqueueevent);
  577. var
  578. idx,i,v : longint;
  579. dostop : boolean;
  580. doqueue : boolean;
  581. st : tmsgstate;
  582. ch : char;
  583. begin
  584. {Reset}
  585. dostop:=false;
  586. doqueue:=false;
  587. v:=0;
  588. {Parse options}
  589. idx:=pos('_',s);
  590. if idx=0 then
  591. v:=V_None
  592. else
  593. if (idx >= 1) And (idx <= 5) then
  594. begin
  595. for i:=1 to idx do
  596. begin
  597. ch:=upcase(s[i]);
  598. case ch of
  599. 'F' :
  600. begin
  601. v:=v or V_Fatal;
  602. GenerateError;
  603. dostop:=true;
  604. end;
  605. 'E','W','N','H':
  606. begin
  607. if ch='E' then
  608. st:=ms_error
  609. else
  610. st:=GetMessageState(w);
  611. { We only want to know about local value }
  612. st:= tmsgstate(ord(st) and ms_local_mask);
  613. if st=ms_error then
  614. begin
  615. v:=v or V_Error;
  616. GenerateError;
  617. end
  618. else if st<>ms_off then
  619. case ch of
  620. 'W':
  621. begin
  622. v:=v or V_Warning;
  623. if CheckVerbosity(V_Warning) then
  624. if status.errorwarning then
  625. GenerateError
  626. else
  627. inc(status.countWarnings);
  628. end;
  629. 'N' :
  630. begin
  631. v:=v or V_Note;
  632. if CheckVerbosity(V_Note) then
  633. if status.errornote then
  634. GenerateError
  635. else
  636. inc(status.countNotes);
  637. end;
  638. 'H' :
  639. begin
  640. v:=v or V_Hint;
  641. if CheckVerbosity(V_Hint) then
  642. if status.errorhint then
  643. GenerateError
  644. else
  645. inc(status.countHints);
  646. end;
  647. end;
  648. end;
  649. 'O' :
  650. v:=v or V_Normal;
  651. 'I' :
  652. v:=v or V_Info;
  653. 'L' :
  654. v:=v or V_LineInfo;
  655. 'U' :
  656. v:=v or V_Used;
  657. 'T' :
  658. v:=v or V_Tried;
  659. 'C' :
  660. v:=v or V_Conditional;
  661. 'D' :
  662. v:=v or V_Debug;
  663. 'X' :
  664. v:=v or V_Executable;
  665. 'S' :
  666. dostop:=true;
  667. '_' : ;
  668. end;
  669. end;
  670. end;
  671. Delete(s,1,idx);
  672. { check verbosity level }
  673. if not CheckVerbosity(v) then
  674. begin
  675. doqueue := onqueue <> nil;
  676. if not doqueue then
  677. exit;
  678. end;
  679. if (v and V_LineInfoMask)<>0 then
  680. v:=v or V_LineInfo;
  681. { fix status }
  682. UpdateStatus;
  683. { Fix replacements }
  684. DefaultReplacements(s);
  685. if status.showmsgnrs then
  686. s:='('+tostr(w)+') '+s;
  687. if doqueue then
  688. begin
  689. onqueue(s,v,w);
  690. exit;
  691. end;
  692. { show comment }
  693. if do_comment(v,s) or dostop then
  694. raise ECompilerAbort.Create;
  695. if (status.errorcount>=status.maxerrorcount) and not status.skip_error then
  696. begin
  697. Message1(unit_f_errors_in_unit,tostr(status.errorcount));
  698. status.skip_error:=true;
  699. raise ECompilerAbort.Create;
  700. end;
  701. end;
  702. function MessageStr(w:longint):TMsgStr;
  703. begin
  704. MaybeLoadMessageFile;
  705. MessageStr:=msg^.Get(w,[]);
  706. end;
  707. procedure Message(w:longint;onqueue:tmsgqueueevent=nil);
  708. begin
  709. MaybeLoadMessageFile;
  710. Msg2Comment(msg^.Get(w,[]),w,onqueue);
  711. end;
  712. procedure Message1(w:longint;const s1:TMsgStr;onqueue:tmsgqueueevent=nil);
  713. begin
  714. MaybeLoadMessageFile;
  715. Msg2Comment(msg^.Get(w,[s1]),w,onqueue);
  716. end;
  717. procedure Message2(w:longint;const s1,s2:TMsgStr;onqueue:tmsgqueueevent=nil);
  718. begin
  719. MaybeLoadMessageFile;
  720. Msg2Comment(msg^.Get(w,[s1,s2]),w,onqueue);
  721. end;
  722. procedure Message3(w:longint;const s1,s2,s3:TMsgStr;onqueue:tmsgqueueevent=nil);
  723. begin
  724. MaybeLoadMessageFile;
  725. Msg2Comment(msg^.Get(w,[s1,s2,s3]),w,onqueue);
  726. end;
  727. procedure Message4(w:longint;const s1,s2,s3,s4:TMsgStr;onqueue:tmsgqueueevent=nil);
  728. begin
  729. MaybeLoadMessageFile;
  730. Msg2Comment(msg^.Get(w,[s1,s2,s3,s4]),w,onqueue);
  731. end;
  732. procedure MessagePos(const pos:tfileposinfo;w:longint;onqueue:tmsgqueueevent=nil);
  733. var
  734. oldpos : tfileposinfo;
  735. begin
  736. oldpos:=current_filepos;
  737. current_filepos:=pos;
  738. MaybeLoadMessageFile;
  739. Msg2Comment(msg^.Get(w,[]),w,onqueue);
  740. current_filepos:=oldpos;
  741. end;
  742. procedure MessagePos1(const pos:tfileposinfo;w:longint;const s1:TMsgStr;onqueue:tmsgqueueevent=nil);
  743. var
  744. oldpos : tfileposinfo;
  745. begin
  746. oldpos:=current_filepos;
  747. current_filepos:=pos;
  748. MaybeLoadMessageFile;
  749. Msg2Comment(msg^.Get(w,[s1]),w,onqueue);
  750. current_filepos:=oldpos;
  751. end;
  752. procedure MessagePos2(const pos:tfileposinfo;w:longint;const s1,s2:TMsgStr;onqueue:tmsgqueueevent=nil);
  753. var
  754. oldpos : tfileposinfo;
  755. begin
  756. oldpos:=current_filepos;
  757. current_filepos:=pos;
  758. MaybeLoadMessageFile;
  759. Msg2Comment(msg^.Get(w,[s1,s2]),w,onqueue);
  760. current_filepos:=oldpos;
  761. end;
  762. procedure MessagePos3(const pos:tfileposinfo;w:longint;const s1,s2,s3:TMsgStr;onqueue:tmsgqueueevent=nil);
  763. var
  764. oldpos : tfileposinfo;
  765. begin
  766. oldpos:=current_filepos;
  767. current_filepos:=pos;
  768. MaybeLoadMessageFile;
  769. Msg2Comment(msg^.Get(w,[s1,s2,s3]),w,onqueue);
  770. current_filepos:=oldpos;
  771. end;
  772. procedure MessagePos4(const pos:tfileposinfo;w:longint;const s1,s2,s3,s4:TMsgStr;onqueue:tmsgqueueevent=nil);
  773. var
  774. oldpos : tfileposinfo;
  775. begin
  776. oldpos:=current_filepos;
  777. current_filepos:=pos;
  778. MaybeLoadMessageFile;
  779. Msg2Comment(msg^.Get(w,[s1,s2,s3,s4]),w,onqueue);
  780. current_filepos:=oldpos;
  781. end;
  782. {*****************************************************************************
  783. override the message calls to set codegenerror
  784. *****************************************************************************}
  785. procedure cgmessage(t : longint);
  786. var
  787. olderrorcount : longint;
  788. begin
  789. if not(codegenerror) then
  790. begin
  791. olderrorcount:=Errorcount;
  792. verbose.Message(t);
  793. codegenerror:=olderrorcount<>Errorcount;
  794. end;
  795. end;
  796. procedure cgmessage1(t : longint;const s : TMsgStr);
  797. var
  798. olderrorcount : longint;
  799. begin
  800. if not(codegenerror) then
  801. begin
  802. olderrorcount:=Errorcount;
  803. verbose.Message1(t,s);
  804. codegenerror:=olderrorcount<>Errorcount;
  805. end;
  806. end;
  807. procedure cgmessage2(t : longint;const s1,s2 : TMsgStr);
  808. var
  809. olderrorcount : longint;
  810. begin
  811. if not(codegenerror) then
  812. begin
  813. olderrorcount:=Errorcount;
  814. verbose.Message2(t,s1,s2);
  815. codegenerror:=olderrorcount<>Errorcount;
  816. end;
  817. end;
  818. procedure cgmessage3(t : longint;const s1,s2,s3 : TMsgStr);
  819. var
  820. olderrorcount : longint;
  821. begin
  822. if not(codegenerror) then
  823. begin
  824. olderrorcount:=Errorcount;
  825. verbose.Message3(t,s1,s2,s3);
  826. codegenerror:=olderrorcount<>Errorcount;
  827. end;
  828. end;
  829. procedure cgmessagepos(const pos:tfileposinfo;t : longint);
  830. var
  831. olderrorcount : longint;
  832. begin
  833. if not(codegenerror) then
  834. begin
  835. olderrorcount:=Errorcount;
  836. verbose.MessagePos(pos,t);
  837. codegenerror:=olderrorcount<>Errorcount;
  838. end;
  839. end;
  840. procedure cgmessagepos1(const pos:tfileposinfo;t : longint;const s1 : TMsgStr);
  841. var
  842. olderrorcount : longint;
  843. begin
  844. if not(codegenerror) then
  845. begin
  846. olderrorcount:=Errorcount;
  847. verbose.MessagePos1(pos,t,s1);
  848. codegenerror:=olderrorcount<>Errorcount;
  849. end;
  850. end;
  851. procedure cgmessagepos2(const pos:tfileposinfo;t : longint;const s1,s2 : TMsgStr);
  852. var
  853. olderrorcount : longint;
  854. begin
  855. if not(codegenerror) then
  856. begin
  857. olderrorcount:=Errorcount;
  858. verbose.MessagePos2(pos,t,s1,s2);
  859. codegenerror:=olderrorcount<>Errorcount;
  860. end;
  861. end;
  862. procedure cgmessagepos3(const pos:tfileposinfo;t : longint;const s1,s2,s3 : TMsgStr);
  863. var
  864. olderrorcount : longint;
  865. begin
  866. if not(codegenerror) then
  867. begin
  868. olderrorcount:=Errorcount;
  869. verbose.MessagePos3(pos,t,s1,s2,s3);
  870. codegenerror:=olderrorcount<>Errorcount;
  871. end;
  872. end;
  873. procedure FlushOutput;
  874. begin
  875. if not (Status.Use_StdErr) then (* StdErr is flushed after every line *)
  876. begin
  877. if Status.Use_Redir then
  878. Flush(Status.RedirFile)
  879. else
  880. Flush(Output);
  881. end;
  882. end;
  883. {*****************************************************************************
  884. Initialization
  885. *****************************************************************************}
  886. procedure InitVerbose;
  887. begin
  888. { Init }
  889. msg:=new(pmessage,Init(20,msgidxmax));
  890. if msg=nil then
  891. begin
  892. writeln('Fatal: MsgIdx Wrong');
  893. halt(3);
  894. end;
  895. {$ifndef EXTERN_MSG}
  896. msg^.LoadIntern(@msgtxt,msgtxtsize,msgtxt_codepage);
  897. {$else EXTERN_MSG}
  898. LoadMsgFile(exepath+'errore.msg');
  899. {$endif EXTERN_MSG}
  900. FillChar(Status,sizeof(TCompilerStatus),0);
  901. status.verbosity:=V_Default;
  902. Status.MaxErrorCount:=50;
  903. Status.codesize:=aword(-1);
  904. Status.datasize:=aword(-1);
  905. Loadprefixes;
  906. lastfileidx:=-1;
  907. lastmoduleidx:=-1;
  908. status.currentmodule:='';
  909. status.currentsourceppufilename:='';
  910. status.currentsource:='';
  911. status.currentsourcepath:='';
  912. { Register internalerrorproc for cutils/cclasses }
  913. internalerrorproc:=@internalerror;
  914. end;
  915. procedure DoneVerbose;
  916. begin
  917. if assigned(msg) then
  918. begin
  919. dispose(msg,Done);
  920. msg:=nil;
  921. end;
  922. DoneRedirectFile;
  923. end;
  924. procedure printnodeindent; inline;
  925. begin
  926. printnodeindention:=printnodeindention+printnodespacing;
  927. end;
  928. procedure printnodeunindent; inline;
  929. begin
  930. delete(printnodeindention,1,length(printnodespacing));
  931. end;
  932. {$ifdef DEBUG_NODE_XML}
  933. function WritePointer(const P: Pointer): ansistring;
  934. begin
  935. case PtrUInt(P) of
  936. 0:
  937. WritePointer := 'nil';
  938. 1..$FFFF:
  939. WritePointer := '$' + hexstr(PtrUInt(P), 4);
  940. $10000..$FFFFFFFF:
  941. WritePointer := '$' + hexstr(PtrUInt(P), 8);
  942. {$ifdef CPU64}
  943. else
  944. WritePointer := '$' + hexstr(PtrUInt(P), 16);
  945. {$endif CPU64}
  946. end;
  947. end;
  948. function WriteGUID(const GUID: TGUID): ansistring;
  949. var
  950. i: Integer;
  951. begin
  952. Result := '{' + hexstr(GUID.D1, 8) + '-' + hexstr(GUID.D2, 4) + '-' + hexstr(GUID.D3, 4) + '-';
  953. for i := 0 to 7 do
  954. Result := Result + hexstr(GUID.D4[i], 2);
  955. Result := Result + '}';
  956. end;
  957. function SanitiseXMLString(const S: ansistring): ansistring;
  958. var
  959. X, UTF8Len, UTF8Char, CurrentChar: Integer;
  960. needs_quoting, in_quotes, add_end_quote: Boolean;
  961. DoASCII: Boolean;
  962. { Write the given byte as #xxx }
  963. procedure EncodeControlChar(Value: Byte);
  964. begin
  965. if X = Length(Result) then
  966. add_end_quote := False;
  967. Delete(Result, X, 1);
  968. if in_quotes then
  969. begin
  970. Insert('#' + tostr(Value) + '''', Result, X);
  971. { If the entire string consists of control characters, it
  972. doesn't need quoting, so only set the flag here }
  973. needs_quoting := True;
  974. in_quotes := False;
  975. end
  976. else
  977. Insert('#' + tostr(Value), Result, X);
  978. end;
  979. { Write the given byte as either a plain character or an XML keyword }
  980. procedure EncodeStandardChar(Value: Byte);
  981. begin
  982. if not in_quotes then
  983. begin
  984. in_quotes := True;
  985. if (X < Length(Result)) then
  986. begin
  987. needs_quoting := True;
  988. Insert('''', Result, X + 1)
  989. end;
  990. end;
  991. { Check the character for anything that could be mistaken for an XML element }
  992. case CurrentChar of
  993. Ord('#'):
  994. { Required to differentiate '#27' from the escape code #27, for example }
  995. needs_quoting:=true;
  996. Ord('<'):
  997. begin
  998. Delete(Result, X, 1);
  999. Insert('&lt;', Result, X);
  1000. end;
  1001. Ord('>'):
  1002. begin
  1003. Delete(Result, X, 1);
  1004. Insert('&gt;', Result, X);
  1005. end;
  1006. Ord('&'):
  1007. begin
  1008. Delete(Result, X, 1);
  1009. Insert('&amp;', Result, X);
  1010. end;
  1011. Ord('"'):
  1012. begin
  1013. needs_quoting := True;
  1014. Delete(Result, X, 1);
  1015. Insert('&quot;', Result, X);
  1016. end;
  1017. Ord(''''):
  1018. begin
  1019. needs_quoting:=true;
  1020. { Simply double it like in pascal strings }
  1021. Insert('''', Result, X);
  1022. end;
  1023. else
  1024. { Do nothing };
  1025. end;
  1026. end;
  1027. { Convert character between $80 and $FF to UTF-8 }
  1028. procedure EncodeExtendedChar(Value: Byte);
  1029. begin
  1030. if not in_quotes then
  1031. begin
  1032. in_quotes := True;
  1033. if (X < Length(Result)) then
  1034. begin
  1035. needs_quoting := True;
  1036. Insert('''', Result, X + 1)
  1037. end;
  1038. end;
  1039. case Value of
  1040. $80..$BF: { Add $C2 before the value }
  1041. Insert(#$C2, Result, X);
  1042. $C0..$FF: { Zero the $40 bit and add $C3 before the value }
  1043. begin
  1044. Result[X] := Char(Byte(Result[X]) and $BF);
  1045. Insert(#$C3, Result, X);
  1046. end;
  1047. else
  1048. { Previous conditions should prevent this procedure from being
  1049. called if Value < $80 }
  1050. InternalError(2019061901);
  1051. end;
  1052. end;
  1053. begin
  1054. needs_quoting := False;
  1055. Result := S;
  1056. { Gets set to True if an invalid UTF-8 sequence is found }
  1057. DoASCII := False;
  1058. { By setting in_quotes to false here, we can exclude the single
  1059. quotation marks surrounding the string if it doesn't contain any
  1060. control characters, or consists entirely of control characters. }
  1061. in_quotes := False;
  1062. add_end_quote := True;
  1063. X := Length(Result);
  1064. while X > 0 do
  1065. begin
  1066. CurrentChar := Ord(Result[X]);
  1067. { Control characters and extended characters need special handling }
  1068. case CurrentChar of
  1069. $00..$1F, $7F:
  1070. EncodeControlChar(CurrentChar);
  1071. $20..$7E:
  1072. EncodeStandardChar(CurrentChar);
  1073. { UTF-8 continuation byte }
  1074. $80..$BF:
  1075. begin
  1076. if not in_quotes then
  1077. begin
  1078. in_quotes := True;
  1079. if (X < Length(Result)) then
  1080. begin
  1081. needs_quoting := True;
  1082. Insert('''', Result, X + 1)
  1083. end;
  1084. end;
  1085. UTF8Char := CurrentChar and $3F; { The data bits of the continuation byte }
  1086. UTF8Len := 1; { This variable actually holds 1 less than the length }
  1087. { By setting DoASCII to true, it marks the string as 'invalid UTF-8'
  1088. automatically if it reaches the beginning of the string unexpectedly }
  1089. DoASCII := True;
  1090. Dec(X);
  1091. while X > 0 do
  1092. begin
  1093. CurrentChar := Ord(Result[X]);
  1094. case CurrentChar of
  1095. { A standard character here is invalid UTF-8 }
  1096. $00..$7F:
  1097. Break;
  1098. { Another continuation byte }
  1099. $80..$BF:
  1100. begin
  1101. UTF8Char := UTF8Char or ((CurrentChar and $3F) shl (6 * UTF8Len));
  1102. Inc(UTF8Len);
  1103. if UTF8Len >= 4 then
  1104. { Sequence too long }
  1105. Break;
  1106. end;
  1107. { Lead byte for 2-byte sequences }
  1108. $C2..$DF:
  1109. begin
  1110. if UTF8Len <> 1 then Break;
  1111. UTF8Char := UTF8Char or ((CurrentChar and $1F) shl 6);
  1112. { Check to see if the code is in range and not part of an 'overlong' sequence }
  1113. case UTF8Char of
  1114. $0080..$07FF:
  1115. DoASCII := False;
  1116. else
  1117. { Do nothing - DoASCII is already true }
  1118. end;
  1119. Break;
  1120. end;
  1121. { Lead byte for 3-byte sequences }
  1122. $E0..$EF:
  1123. begin
  1124. if UTF8Len <> 2 then Break;
  1125. UTF8Char := UTF8Char or ((CurrentChar and $0F) shl 12);
  1126. { Check to see if the code is in range and not part of an 'overlong' sequence }
  1127. case UTF8Char of
  1128. $0800..$D7FF, $E000..$FFFF: { $D800..$DFFF is reserved and hence invalid }
  1129. DoASCII := False;
  1130. else
  1131. { Do nothing - DoASCII is already true }
  1132. end;
  1133. Break;
  1134. end;
  1135. { Lead byte for 4-byte sequences }
  1136. $F0..$F4:
  1137. begin
  1138. if UTF8Len <> 3 then Break;
  1139. UTF8Char := UTF8Char or ((CurrentChar and $07) shl 18);
  1140. { Check to see if the code is in range and not part of an 'overlong' sequence }
  1141. case UTF8Char of
  1142. $010000..$10FFFF:
  1143. DoASCII := False;
  1144. else
  1145. { Do nothing - DoASCII is already true }
  1146. end;
  1147. Break;
  1148. end;
  1149. { Invalid character }
  1150. else
  1151. Break;
  1152. end;
  1153. end;
  1154. if DoASCII then
  1155. Break;
  1156. { If all is fine, we don't need to encode any more characters }
  1157. end;
  1158. { Invalid UTF-8 bytes and lead bytes without continuation bytes }
  1159. $C0..$FF:
  1160. begin
  1161. DoASCII := True;
  1162. Break;
  1163. end;
  1164. end;
  1165. Dec(X);
  1166. end;
  1167. { UTF-8 failed, so encode the string as plain ASCII }
  1168. if DoASCII then
  1169. begin
  1170. { Reset the flags and Result }
  1171. needs_quoting := False;
  1172. Result := S;
  1173. in_quotes := False;
  1174. add_end_quote := True;
  1175. for X := Length(Result) downto 1 do
  1176. begin
  1177. CurrentChar := Ord(Result[X]);
  1178. { Control characters and extended characters need special handling }
  1179. case CurrentChar of
  1180. $00..$1F, $7F:
  1181. EncodeControlChar(CurrentChar);
  1182. $20..$7E:
  1183. EncodeStandardChar(CurrentChar);
  1184. { Extended characters }
  1185. else
  1186. EncodeExtendedChar(CurrentChar);
  1187. end;
  1188. end;
  1189. end;
  1190. if needs_quoting then
  1191. begin
  1192. if in_quotes then
  1193. Result := '''' + Result;
  1194. if add_end_quote then
  1195. Result := Result + '''';
  1196. end;
  1197. end;
  1198. {$endif DEBUG_NODE_XML}
  1199. initialization
  1200. constexp.internalerrorproc:=@internalerror;
  1201. finalization
  1202. { Be sure to close the redirect files to flush all data }
  1203. DoneRedirectFile;
  1204. end.