* 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)

+ added test

git-svn-id: trunk@42362 -

.gitattributes

@@ -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

compiler/globals.pas

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

compiler/pbase.pas

@@ -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
+                          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
-                          consume(_ID);
-                          is_specialize:=true;
-                          if token=_ID then
-                            searchsym_in_module(tunitsym(srsym).module,pattern,srsym,srsymtable);
+                          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? }

compiler/pdecl.pas

@@ -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

compiler/pexpr.pas

@@ -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;
 

tests/test/tcustomattr11.pp

@@ -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.