paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-07 13:28:05 +02: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/tb0609.pp svneol=native#text/plain
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/tb610.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,
{ This is needed for tcputype }
cpuinfo,
fmodule
fmodule,
{ this is needed for $I %CURRENTROUTINE%}
procinfo
{$if FPC_FULLVERSION<20700}
,ccharset
{$endif}
@ -2372,40 +2374,35 @@ type
path:=hs;
{ first check for internal macros }
macroIsString:=true;
if hs='TIME' then
hs:=gettimestr
else
if hs='DATE' then
hs:=getdatestr
else
if hs='FILE' then
hs:=current_module.sourcefiles.get_file_name(current_filepos.fileindex)
else
if hs='LINE' then
hs:=tostr(current_filepos.line)
else
if hs='LINENUM' then
begin
hs:=tostr(current_filepos.line);
macroIsString:=false;
end
else
if hs='FPCVERSION' then
hs:=version_string
else
if hs='FPCDATE' then
hs:=date_string
else
if hs='FPCTARGET' then
hs:=target_cpu_string
else
if hs='FPCTARGETCPU' then
hs:=target_cpu_string
else
if hs='FPCTARGETOS' then
hs:=target_info.shortname
else
hs:=GetEnvironmentVariable(hs);
case hs of
'TIME':
hs:=gettimestr;
'DATE':
hs:=getdatestr;
'FILE':
hs:=current_module.sourcefiles.get_file_name(current_filepos.fileindex);
'LINE':
hs:=tostr(current_filepos.line);
'LINENUM':
begin
hs:=tostr(current_filepos.line);
macroIsString:=false;
end;
'FPCVERSION':
hs:=version_string;
'FPCDATE':
hs:=date_string;
'FPCTARGET':
hs:=target_cpu_string;
'FPCTARGETCPU':
hs:=target_cpu_string;
'FPCTARGETOS':
hs:=target_info.shortname;
'CURRENTROUTINE':
hs:=current_procinfo.procdef.procsym.RealName;
else
hs:=GetEnvironmentVariable(hs);
end;
if hs='' then
Message1(scan_w_include_env_not_found,path);
{ 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.