paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-11-12 22:24:19 +01:00
Code Issues Packages Projects Releases Wiki Activity

+ support for {$I %CURRENTROUTINE%}

Browse Source 
* if chain changed into case statements

git-svn-id: trunk@30873 -
This commit is contained in:
florian 2015-05-16 22:22:26 +00:00
parent afa5546ff8
commit b61fd60b9d
3 changed files with 64 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -10541,6 +10541,7 @@ tests/tbs/tb0607.pp svneol=native#text/plain
tests/tbs/tb0608.pp svneol=native#text/pascal tests/tbs/tb0608.pp svneol=native#text/pascal
tests/tbs/tb0609.pp svneol=native#text/plain tests/tbs/tb0609.pp svneol=native#text/plain
tests/tbs/tb0610.pp svneol=native#text/pascal tests/tbs/tb0610.pp svneol=native#text/pascal
tests/tbs/tb0611.pp svneol=native#text/pascal
tests/tbs/tb205.pp svneol=native#text/plain tests/tbs/tb205.pp svneol=native#text/plain
tests/tbs/tb610.pp svneol=native#text/pascal tests/tbs/tb610.pp svneol=native#text/pascal
tests/tbs/tbs0594.pp svneol=native#text/pascal tests/tbs/tbs0594.pp svneol=native#text/pascal

67
compiler/scanner.pas
View File

@ -273,7 +273,9 @@ implementation
symbase,symtable,symtype,symsym,symconst,symdef,defutil, symbase,symtable,symtype,symsym,symconst,symdef,defutil,
{ This is needed for tcputype } { This is needed for tcputype }
cpuinfo, cpuinfo,
fmodule fmodule,
{ this is needed for $I %CURRENTROUTINE%}
procinfo
{$if FPC_FULLVERSION<20700} {$if FPC_FULLVERSION<20700}
,ccharset ,ccharset
{$endif} {$endif}
@ -2372,40 +2374,35 @@ type
path:=hs; path:=hs;
{ first check for internal macros } { first check for internal macros }
macroIsString:=true; macroIsString:=true;
if hs='TIME' then case hs of
hs:=gettimestr 'TIME':
else hs:=gettimestr;
if hs='DATE' then 'DATE':
hs:=getdatestr hs:=getdatestr;
else 'FILE':
if hs='FILE' then hs:=current_module.sourcefiles.get_file_name(current_filepos.fileindex);
hs:=current_module.sourcefiles.get_file_name(current_filepos.fileindex) 'LINE':
else hs:=tostr(current_filepos.line);
if hs='LINE' then 'LINENUM':
hs:=tostr(current_filepos.line) begin
else hs:=tostr(current_filepos.line);
if hs='LINENUM' then macroIsString:=false;
begin end;
hs:=tostr(current_filepos.line); 'FPCVERSION':
macroIsString:=false; hs:=version_string;
end 'FPCDATE':
else hs:=date_string;
if hs='FPCVERSION' then 'FPCTARGET':
hs:=version_string hs:=target_cpu_string;
else 'FPCTARGETCPU':
if hs='FPCDATE' then hs:=target_cpu_string;
hs:=date_string 'FPCTARGETOS':
else hs:=target_info.shortname;
if hs='FPCTARGET' then 'CURRENTROUTINE':
hs:=target_cpu_string hs:=current_procinfo.procdef.procsym.RealName;
else else
if hs='FPCTARGETCPU' then hs:=GetEnvironmentVariable(hs);
hs:=target_cpu_string end;
else
if hs='FPCTARGETOS' then
hs:=target_info.shortname
else
hs:=GetEnvironmentVariable(hs);
if hs='' then if hs='' then
Message1(scan_w_include_env_not_found,path); Message1(scan_w_include_env_not_found,path);
{ make it a stringconst } { make it a stringconst }

31
tests/tbs/tb0611.pp Normal file
View File

@ -0,0 +1,31 @@
{$mode objfpc}
{$warn 6018 off}
type
tmyclass = class
procedure HelloMethod(i : longint);
end;
procedure Hello(i : longint);
begin
writeln({$I %CURRENTROUTINE%});
if {$I %CURRENTROUTINE%}<>'Hello' then
halt(i);
end;
procedure tmyclass.HelloMethod(i : longint);
begin
writeln({$I %CURRENTROUTINE%});
if {$I %CURRENTROUTINE%}<>'HelloMethod' then
halt(i);
end;
var
myclass : tmyclass;
begin
Hello(1);
myclass:=tmyclass.create;
myclass.HelloMethod(1);
myclass.Free;
writeln('Ok');
end.