paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-21 01:29:29 +02:00
Code Issues Packages Projects Releases Wiki Activity

* instead of declaring another type with a 'attribute' suffix, *search* for another type with a 'ATTRIBUTE' suffix (Delphi allows declaring both a TFoo and TFooAttribute in the same unit)

Browse Source 
+ added test

git-svn-id: trunk@42362 -
This commit is contained in:
svenbarth 2019-07-12 22:05:18 +00:00
parent 869664c6da
commit 24c4b90343
6 changed files with 116 additions and 58 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -13207,6 +13207,7 @@ tests/test/tcstring1.pp svneol=native#text/pascal
tests/test/tcstring2.pp svneol=native#text/pascal
tests/test/tcustomattr1.pp svneol=native#text/pascal
tests/test/tcustomattr10.pp svneol=native#text/pascal
tests/test/tcustomattr11.pp svneol=native#text/pascal
tests/test/tcustomattr2.pp svneol=native#text/pascal
tests/test/tcustomattr3.pp svneol=native#text/pascal
tests/test/tcustomattr4.pp svneol=native#text/pascal

2
compiler/globals.pas
View File

@ -399,6 +399,8 @@ interface
defaultmainaliasname = 'main';
mainaliasname : string = defaultmainaliasname;
custom_attribute_suffix = 'ATTRIBUTE';
LTOExt: TCmdStr = '';
const

49
compiler/pbase.pas
View File

@ -92,7 +92,8 @@ interface
type
tconsume_unitsym_flag = (
cuf_consume_id,
cuf_allow_specialize
cuf_allow_specialize,
cuf_check_attr_suffix
);
tconsume_unitsym_flags = set of tconsume_unitsym_flag;
@ -361,26 +362,38 @@ implementation
end;
case token of
_ID:
{ system.char? (char=widechar comes from the implicit
uuchar unit -> override) }
if (pattern='CHAR') and
(tmodule(tunitsym(srsym).module).globalsymtable=systemunit) then
begin
if m_default_unicodestring in current_settings.modeswitches then
searchsym_in_module(tunitsym(srsym).module,'WIDECHAR',srsym,srsymtable)
else
searchsym_in_module(tunitsym(srsym).module,'ANSICHAR',srsym,srsymtable)
end
else
if (cuf_allow_specialize in flags) and (idtoken=_SPECIALIZE) then
begin
if cuf_check_attr_suffix in flags then
begin
consume(_ID);
is_specialize:=true;
if token=_ID then
searchsym_in_module(tunitsym(srsym).module,pattern,srsym,srsymtable);
if searchsym_in_module(tunitsym(srsym).module,pattern+custom_attribute_suffix,srsym,srsymtable) then
exit(true);
end;
{ system.char? (char=widechar comes from the implicit
uuchar unit -> override) }
if (pattern='CHAR') and
(tmodule(tunitsym(srsym).module).globalsymtable=systemunit) then
begin
if m_default_unicodestring in current_settings.modeswitches then
searchsym_in_module(tunitsym(srsym).module,'WIDECHAR',srsym,srsymtable)
else
searchsym_in_module(tunitsym(srsym).module,'ANSICHAR',srsym,srsymtable)
end
else
searchsym_in_module(tunitsym(srsym).module,pattern,srsym,srsymtable);
if (cuf_allow_specialize in flags) and (idtoken=_SPECIALIZE) then
begin
consume(_ID);
is_specialize:=true;
if token=_ID then
begin
if (cuf_check_attr_suffix in flags) and
searchsym_in_module(tunitsym(srsym).module,pattern+custom_attribute_suffix,srsym,srsymtable) then
exit(true);
searchsym_in_module(tunitsym(srsym).module,pattern,srsym,srsymtable);
end;
end
else
searchsym_in_module(tunitsym(srsym).module,pattern,srsym,srsymtable);
end;
_STRING:
begin
{ system.string? }

29
compiler/pdecl.pas
View File

@ -82,30 +82,6 @@ implementation
Result := def_is_related(def, system_custom_attribute_def);
end;
procedure create_renamed_attr_type_if_needed(hdef: tobjectdef);
const
attrconst = 'attribute';
var
newname : TIDString;
newtypeattr : ttypesym;
i: integer;
begin
if not is_system_custom_attribute_descendant(hdef) then
Exit;
{ Check if the name ends with 'attribute'. }
i := Pos(attrconst, lower(hdef.typename), max(0, length(hdef.typename) - length(attrconst)));
newname:=Copy(hdef.typename, 0, i-1);
if (i > 0) and (length(newname) > 0) then
begin
{ Create a new typesym with 'attribute' removed. }
newtypeattr:=ctypesym.create(newname,hdef,true);
newtypeattr.visibility:=symtablestack.top.currentvisibility;
include(newtypeattr.symoptions,sp_implicitrename);
symtablestack.top.insert(newtypeattr);
end;
end;
function readconstant(const orgname:string;const filepos:tfileposinfo; out nodetype: tnodetype):tconstsym;
var
hp : tconstsym;
@ -448,7 +424,7 @@ implementation
consume(_LECKKLAMMER);
{ Parse attribute type }
p := factor(false,[ef_type_only]);
p := factor(false,[ef_type_only,ef_check_attr_suffix]);
if p.nodetype<> errorn then
begin
typeSym := ttypesym(ttypenode(p).typesym);
@ -1046,9 +1022,6 @@ implementation
if is_cppclass(hdef) then
tobjectdef(hdef).finish_cpp_data;
if (m_prefixed_attributes in current_settings.modeswitches) then
create_renamed_attr_type_if_needed(tobjectdef(hdef));
end;
recorddef :
begin

53
compiler/pexpr.pas
View File

@ -35,7 +35,8 @@ interface
texprflag = (
ef_accept_equal,
ef_type_only,
ef_had_specialize
ef_had_specialize,
ef_check_attr_suffix
);
texprflags = set of texprflag;
@ -2826,6 +2827,7 @@ implementation
storedpattern: string;
callflags: tcallnodeflags;
t : ttoken;
consumeid,
wasgenericdummy,
allowspecialize,
isspecialize,
@ -2867,28 +2869,55 @@ implementation
end
else
begin
if ef_type_only in flags then
searchsym_type(pattern,srsym,srsymtable)
else
searchsym(pattern,srsym,srsymtable);
storedpattern:=pattern;
orgstoredpattern:=orgpattern;
{ store the position of the token before consuming it }
tokenpos:=current_filepos;
consumeid:=true;
srsym:=nil;
if ef_check_attr_suffix in flags then
begin
if not (ef_type_only in flags) then
internalerror(2019063001);
consume(_ID);
consumeid:=false;
if token<>_POINT then
searchsym_type(storedpattern+custom_attribute_suffix,srsym,srsymtable);
end;
if not assigned(srsym) then
begin
if ef_type_only in flags then
searchsym_type(storedpattern,srsym,srsymtable)
else
searchsym(storedpattern,srsym,srsymtable);
end;
{ handle unit specification like System.Writeln }
if not isspecialize then
begin
cufflags:=[cuf_consume_id];
cufflags:=[];
if consumeid then
include(cufflags,cuf_consume_id);
if allowspecialize then
include(cufflags,cuf_allow_specialize);
unit_found:=try_consume_unitsym(srsym,srsymtable,t,cufflags,isspecialize,pattern)
if ef_check_attr_suffix in flags then
include(cufflags,cuf_check_attr_suffix);
unit_found:=try_consume_unitsym(srsym,srsymtable,t,cufflags,isspecialize,pattern);
if unit_found then
consumeid:=true;
end
else
begin
unit_found:=false;
t:=_ID;
end;
storedpattern:=pattern;
orgstoredpattern:=orgpattern;
{ store the position of the token before consuming it }
tokenpos:=current_filepos;
consume(t);
if consumeid then
begin
storedpattern:=pattern;
orgstoredpattern:=orgpattern;
{ store the position of the token before consuming it }
tokenpos:=current_filepos;
consume(t);
end;
{ named parameter support }
found_arg_name:=false;

40
tests/test/tcustomattr11.pp Normal file
View File

@ -0,0 +1,40 @@
program tcustomattr11;
{$mode objfpc}
{$modeswitch prefixedattributes}
uses
TypInfo;
type
TTest = class(TCustomAttribute)
end;
TTestAttribute = class(TCustomAttribute)
end;
{ the attribute with the Attribute suffix is preferred }
[TTest]
TTestObj = class
end;
var
ad: PAttributeData;
attr: TCustomAttribute;
begin
ad := GetAttributeData(TypeInfo(TTestObj));
if not Assigned(ad) then
Halt(1);
if ad^.AttributeCount <> 1 then
Halt(2);
attr := GetAttribute(ad, 0);
if not Assigned(attr) then
Halt(3);
if not (attr is TTestAttribute) then
Halt(4);
Writeln('ok');
end.