basic proof of concept aspect implementation using token replayaspect

git-svn-id: http://svn.freepascal.org/svn/fpc/branches/aspect@6250 3ad0048d-3df7-0310-abae-a5850022a9f2

15 files changed, 534 insertions, 99 deletions

diff --git a/compiler/cclasses.pas b/compiler/cclasses.pas
index af21120d9c..22883055a2 100644
--- a/compiler/cclasses.pas
+++ b/compiler/cclasses.pas
@@ -122,6 +122,7 @@ type
   TObjectListCallback = procedure(data:TObject;arg:pointer) of object;
   TObjectListStaticCallback = procedure(data:TObject;arg:pointer);
 
+  PFPObjectList = ^TFPObjectList;
   TFPObjectList = class(TObject)
   private
     FFreeObjects : Boolean;
diff --git a/compiler/dbgdwarf.pas b/compiler/dbgdwarf.pas
index cfc42c93eb..6c0048f94b 100644
--- a/compiler/dbgdwarf.pas
+++ b/compiler/dbgdwarf.pas
@@ -1396,6 +1396,13 @@ implementation
             exit;
           end;
 
+        { never write aspect template defs }
+        if df_aspect in def.defoptions then
+          begin
+            def.dbg_state:=dbg_state_written;
+            exit;
+          end;
+
         { to avoid infinite loops }
         def.dbg_state := dbg_state_writing;
 
diff --git a/compiler/dbgstabs.pas b/compiler/dbgstabs.pas
index 5ef3574c0e..c366cc18d1 100644
--- a/compiler/dbgstabs.pas
+++ b/compiler/dbgstabs.pas
@@ -810,6 +810,12 @@ implementation
             def.dbg_state:=dbg_state_written;
             exit;
           end;
+        { never write aspect template defs }
+        if df_aspect in def.defoptions then
+          begin
+            def.dbg_state:=dbg_state_written;
+            exit;
+          end;
         { to avoid infinite loops }
         def.dbg_state := dbg_state_writing;
         { write dependencies first }
diff --git a/compiler/globtype.pas b/compiler/globtype.pas
index 90368a0333..bea2f4e437 100644
--- a/compiler/globtype.pas
+++ b/compiler/globtype.pas
@@ -203,7 +203,8 @@ interface
          m_duplicate_names,     { allow locals/paras to have duplicate names of globals }
          m_property,            { allow properties }
          m_default_inline,      { allow inline proc directive }
-         m_except               { allow exception-related keywords }
+         m_except,              { allow exception-related keywords }
+         m_aspect               { allow aspects }
        );
        tmodeswitches = set of tmodeswitch;
 
diff --git a/compiler/pdecl.pas b/compiler/pdecl.pas
index 27424f36e6..975a18312f 100644
--- a/compiler/pdecl.pas
+++ b/compiler/pdecl.pas
@@ -546,7 +546,7 @@ implementation
                     { Build VMT indexes, skip for type renaming and forward classes }
                     if (hdef.typesym=newtype) and
                        not(oo_is_forward in tobjectdef(hdef).objectoptions) and
-                       not(df_generic in hdef.defoptions) then
+                       not([df_generic, df_aspect] * hdef.defoptions <> []) then
                       begin
                         vmtbuilder:=TVMTBuilder.Create(tobjectdef(hdef));
                         vmtbuilder.generate_vmt;
diff --git a/compiler/pdecsub.pas b/compiler/pdecsub.pas
index 3b9304671a..f4c12250b5 100644
--- a/compiler/pdecsub.pas
+++ b/compiler/pdecsub.pas
@@ -825,6 +825,8 @@ implementation
         pd._class:=aclass;
         pd.procsym:=aprocsym;
         pd.proctypeoption:=potype;
+        if potype = potype_aspect then
+          include(pd.defoptions,df_aspect);
 
         { methods inherit df_generic or df_specialization from the objectdef }
         if assigned(pd._class) then
@@ -850,6 +852,13 @@ implementation
               end;
           end;
 
+        { methods inherit df_aspect from the objectdef }
+        if assigned(pd._class) then
+          begin
+            if (df_aspect in pd._class.defoptions) then
+              include(pd.defoptions,df_aspect);
+          end;
+
         { methods need to be exported }
         if assigned(aclass) and
            (
@@ -863,7 +872,7 @@ implementation
         pd.symoptions:=current_object_option;
 
         { parse parameters }
-        if token=_LKLAMMER then
+        if (potype <> potype_aspect) and (token=_LKLAMMER) then
           begin
             { Add ObjectSymtable to be able to find generic type definitions }
             popclass:=false;
@@ -1087,6 +1096,19 @@ implementation
                   consume_all_until(_SEMICOLON);
                 end;
             end;
+          _ASPECT:
+            begin
+              if isclassmethod then
+                internalerror(2007012602);
+              consume(_ASPECT);
+              if parse_proc_head(aclass,potype_aspect,pd) then
+                begin
+                  if assigned(pd) then
+                    begin
+                      pd.returndef:=voidtype;
+                    end;
+                end;
+            end;
         end;
         { support procedure proc stdcall export; }
         if not(check_proc_directive(false)) then
diff --git a/compiler/procinfo.pas b/compiler/procinfo.pas
index 3243e1cc08..221199cf13 100644
--- a/compiler/procinfo.pas
+++ b/compiler/procinfo.pas
@@ -102,6 +102,10 @@ unit procinfo;
           { max. of space need for parameters }
           maxpushedparasize : aint;
 
+          { aspects }
+          aspects        : TFPObjectList;
+          current_aspect : Integer;
+
           constructor create(aparent:tprocinfo);virtual;
           destructor destroy;override;
 
@@ -139,6 +143,7 @@ implementation
 
     constructor tprocinfo.create(aparent:tprocinfo);
       begin
+        current_aspect := -1;
         parent:=aparent;
         procdef:=nil;
         para_stack_size:=0;
@@ -164,6 +169,7 @@ implementation
       begin
          aktproccode.free;
          aktlocaldata.free;
+         aspects.free;
       end;
 
 
diff --git a/compiler/pstatmnt.pas b/compiler/pstatmnt.pas
index 8ff0b512e2..76cc494c3c 100644
--- a/compiler/pstatmnt.pas
+++ b/compiler/pstatmnt.pas
@@ -1018,70 +1018,97 @@ implementation
              Message(scan_f_end_of_file);
          else
            begin
-             p:=expr;
-             { save the pattern here for latter usage, the label could be "000",
-               even if we read an expression, the pattern is still valid if it's really
-               a label (FK)
-               if you want to mess here, take care of
-               tests/webtbs/tw3546.pp
-             }
-             s:=pattern;
+             p := nil;
 
-             { When a colon follows a intconst then transform it into a label }
-             if (p.nodetype=ordconstn) and
-                try_to_consume(_COLON) then
-              begin
-                p.free;
-                searchsym(s,srsym,srsymtable);
-                if assigned(srsym) and
-                   (srsym.typ=labelsym) then
-                 begin
-                   if tlabelsym(srsym).defined then
-                    Message(sym_e_label_already_defined);
-                   tlabelsym(srsym).defined:=true;
-                   p:=clabelnode.create(nil);
-                   tlabelsym(srsym).code:=p;
-                 end
-                else
-                 begin
-                   Message1(sym_e_label_used_and_not_defined,s);
-                   p:=cnothingnode.create;
-                 end;
-              end;
+             if (token = _INHERITED) then with current_procinfo do begin
+               if df_aspect in procdef.defoptions then begin
+                 consume(_INHERITED);
+                 consume(_SEMICOLON);
 
-             if p.nodetype=labeln then
-               begin
-                 { the pointer to the following instruction }
-                 { isn't a very clean way                   }
-                 if token in endtokens then
-                   tlabelnode(p).left:=cnothingnode.create
+                 if po_contains_joinpoint in procdef.procoptions then
+                   internalerror(2007012701)
                  else
-                   tlabelnode(p).left:=statement();
-                 { be sure to have left also typecheckpass }
-                 typecheckpass(tlabelnode(p).left);
-               end
-             else
+                   Include(procdef.procoptions, po_contains_joinpoint);
+
+                 code:=cnothingnode.create;
+               end else if (df_aspecttarget in procdef.defoptions) and (current_aspect >= 0) then begin
+                 current_scanner.pausereplaytokens;
+                 Dec(current_aspect);
+                 code:=statement_block(_BEGIN);
+                 Inc(current_aspect);
+                 current_scanner.resumereplaytokens;
+                 consume(_INHERITED);
+                 consume(_SEMICOLON);
+               end else
+                 p:=expr;
+             end else
+               p:=expr;
+
+             if Assigned(p) then begin
+               { save the pattern here for latter usage, the label could be "000",
+                 even if we read an expression, the pattern is still valid if it's really
+                 a label (FK)
+                 if you want to mess here, take care of
+                 tests/webtbs/tw3546.pp
+               }
+               s:=pattern;
+
+               { When a colon follows a intconst then transform it into a label }
+               if (p.nodetype=ordconstn) and
+                  try_to_consume(_COLON) then
+                begin
+                  p.free;
+                  searchsym(s,srsym,srsymtable);
+                  if assigned(srsym) and
+                     (srsym.typ=labelsym) then
+                   begin
+                     if tlabelsym(srsym).defined then
+                      Message(sym_e_label_already_defined);
+                     tlabelsym(srsym).defined:=true;
+                     p:=clabelnode.create(nil);
+                     tlabelsym(srsym).code:=p;
+                   end
+                  else
+                   begin
+                     Message1(sym_e_label_used_and_not_defined,s);
+                     p:=cnothingnode.create;
+                   end;
+                end;
+
+               if p.nodetype=labeln then
+                 begin
+                   { the pointer to the following instruction }
+                   { isn't a very clean way                   }
+                   if token in endtokens then
+                     tlabelnode(p).left:=cnothingnode.create
+                   else
+                     tlabelnode(p).left:=statement();
+                   { be sure to have left also typecheckpass }
+                   typecheckpass(tlabelnode(p).left);
+                 end
+               else
 
-             { change a load of a procvar to a call. this is also
-               supported in fpc mode }
-             if p.nodetype in [vecn,derefn,typeconvn,subscriptn,loadn] then
-               maybe_call_procvar(p,false);
-
-             { blockn support because a read/write is changed into a blocknode }
-             { with a separate statement for each read/write operation (JM)    }
-             { the same is true for val() if the third parameter is not 32 bit }
-             if not(p.nodetype in [nothingn,calln,ifn,assignn,breakn,inlinen,
-                                   continuen,labeln,blockn,exitn]) then
-               Message(parser_e_illegal_expression);
-
-             { Specify that we don't use the value returned by the call.
-               This is used for :
-                - dispose of temp stack space
-                - dispose on FPU stack }
-             if (p.nodetype=calln) then
-               exclude(tcallnode(p).callnodeflags,cnf_return_value_used);
-
-             code:=p;
+               { change a load of a procvar to a call. this is also
+                 supported in fpc mode }
+               if p.nodetype in [vecn,derefn,typeconvn,subscriptn,loadn] then
+                 maybe_call_procvar(p,false);
+
+               { blockn support because a read/write is changed into a blocknode }
+               { with a separate statement for each read/write operation (JM)    }
+               { the same is true for val() if the third parameter is not 32 bit }
+               if not(p.nodetype in [nothingn,calln,ifn,assignn,breakn,inlinen,
+                                     continuen,labeln,blockn,exitn]) then
+                 Message(parser_e_illegal_expression);
+
+               { Specify that we don't use the value returned by the call.
+                 This is used for :
+                  - dispose of temp stack space
+                  - dispose on FPU stack }
+               if (p.nodetype=calln) then
+                 exclude(tcallnode(p).callnodeflags,cnf_return_value_used);
+
+               code:=p;
+             end;
            end;
          end;
          if assigned(code) then
diff --git a/compiler/psub.pas b/compiler/psub.pas
index 87d276877b..2d906a6a05 100644
--- a/compiler/psub.pas
+++ b/compiler/psub.pas
@@ -54,6 +54,7 @@ interface
         procedure add_to_symtablestack;
         procedure remove_from_symtablestack;
         procedure parse_body;
+        procedure resolve_aspects;
 
         function stack_tainting_parameter : boolean;
         function has_assembler_child : boolean;
@@ -162,6 +163,11 @@ implementation
 
 
     function block(islibrary : boolean) : tnode;
+
+      var
+        s: string;
+        p: pChar;
+        i: Integer;
       begin
          { parse const,types and vars }
          read_declarations(islibrary);
@@ -174,10 +180,34 @@ implementation
          { Handle assembler block different }
          if (po_assembler in current_procinfo.procdef.procoptions) then
           begin
+            with current_procinfo do begin
+              Exclude(procdef.defoptions, df_aspecttarget);
+              FreeAndNil(aspects);
+            end;
             block:=assembler_block;
             exit;
           end;
 
+         with current_procinfo do begin
+           current_aspect := -1;
+
+           if (df_aspecttarget in procdef.defoptions) then
+             for i := 0 to Pred(aspects.Count) do begin
+               current_scanner.startreplaytokens(
+                 TProcDef(aspects.Items[i]).aspecttokenbuf);
+               read_declarations(islibrary);
+               Inc(current_aspect);
+             end;
+
+           if ([df_aspect, df_aspecttarget] * procdef.defoptions) <> [] then begin
+             s := procdef.fullprocname(false);
+             getmem(p, Length(s)+1);
+             move(s[1], p[0], Length(s)+1);
+             procdef.localst.insert(tconstsym.create_string
+               ('_PROCNAME_',conststring,p,Length(s)));
+           end;
+         end;
+
          {Unit initialization?.}
          if (
              assigned(current_procinfo.procdef.localst) and
@@ -705,6 +735,10 @@ implementation
         if (df_generic in procdef.defoptions) then
           internalerror(200511152);
 
+        { No code can be generated for aspect template }
+        if (df_aspect in procdef.defoptions) then
+          internalerror(2007012604);
+
         { The RA and Tempgen shall not be available yet }
         if assigned(tg) then
           internalerror(200309201);
@@ -1129,6 +1163,8 @@ implementation
             code.free;
             code:=nil;
           end;
+          aspects.Free;
+          aspects:=nil;
        end;
 
 
@@ -1186,6 +1222,11 @@ implementation
          { allocate the symbol for this procedure }
          alloc_proc_symbol(procdef);
 
+         if (m_aspect in current_settings.modeswitches) and
+           not (df_aspect in procdef.defoptions) and
+           not (df_generic in procdef.defoptions) then
+           resolve_aspects;
+
          { add parast/localst to symtablestack }
          add_to_symtablestack;
 
@@ -1200,10 +1241,21 @@ implementation
              current_scanner.startrecordtokens(procdef.generictokenbuf);
            end;
 
+         if (df_aspect in procdef.defoptions) then
+           begin
+             { start token recorder for aspect template }
+             procdef.initaspect;
+             current_scanner.startrecordtokens(procdef.aspecttokenbuf);
+           end;
+
          { parse the code ... }
          code:=block(current_module.islibrary);
 
-         if (df_generic in procdef.defoptions) then
+         if (df_aspect in procdef.defoptions) and
+           not (po_contains_joinpoint in procdef.procoptions) then
+           internalerror(2007012702);
+
+         if ([df_generic, df_aspect] * procdef.defoptions <> []) then
            begin
              { stop token recorder for generic template }
              current_scanner.stoprecordtokens;
@@ -1215,7 +1267,10 @@ implementation
                st:=st.defowner.owner;
              if (pi_uses_static_symtable in flags) and
                 (st.symtabletype<>staticsymtable) then
-               Comment(V_Warning,'Global Generic template references static symtable');
+               if (df_generic in procdef.defoptions) then
+                 Comment(V_Warning,'Global Generic template references static symtable')
+               else
+                 Comment(V_Warning,'Global Aspect template references static symtable')
            end;
 
          { save exit info }
@@ -1289,6 +1344,28 @@ implementation
          block_type:=oldblock_type;
       end;
 
+    procedure tcgprocinfo.resolve_aspects;
+      begin
+        if (current_procinfo.procdef.parast.symtablelevel>normal_function_level) then
+          Exit;
+
+        if not (current_procinfo.procdef.proctypeoption in
+         [potype_constructor, potype_destructor, potype_procedure, potype_function]) then
+         Exit;
+
+        searchsym_aspects(aspects);
+
+        { FIXME: remove non matching aspects }
+
+        if Assigned(aspects) then begin
+          if aspects.Count = 0 then begin
+            aspects.Free;
+            aspects := nil;
+          end else begin
+            include(procdef.defoptions, df_aspecttarget);
+          end;
+        end;
+      end;
 
 {****************************************************************************
                         PROCEDURE/FUNCTION PARSING
@@ -1386,6 +1463,9 @@ implementation
                 if (df_generic in current_procinfo.procdef.defoptions) then
 {$warning TODO Add error message for nested procs in generics}
                   internalerror(200511151)
+                else if (df_aspect in current_procinfo.procdef.defoptions) then
+{$warning TODO Add error message for nested procs in aspects}
+                  internalerror(2007012605)
                 else if (po_inline in current_procinfo.procdef.procoptions) then
                   begin
                     Message1(parser_w_not_supported_for_inline,'nested procedures');
@@ -1393,7 +1473,7 @@ implementation
                     current_procinfo.procdef.proccalloption:=pocall_default;
                   end;
               end;
-            if not(df_generic in current_procinfo.procdef.defoptions) then
+            if ([df_generic, df_aspect] * current_procinfo.procdef.defoptions) = [] then
               do_generate_code(tcgprocinfo(current_procinfo));
           end;
 
@@ -1587,6 +1667,7 @@ implementation
       end;
 
 
+
 {****************************************************************************
                              DECLARATION PARSING
 ****************************************************************************}
@@ -1622,6 +1703,7 @@ implementation
               _FUNCTION,
               _PROCEDURE,
               _OPERATOR,
+              _ASPECT,
               _CLASS:
                 read_proc;
               _EXPORTS:
@@ -1687,7 +1769,8 @@ implementation
                threadvar_dec;
              _FUNCTION,
              _PROCEDURE,
-             _OPERATOR :
+             _OPERATOR,
+             _ASPECT:
                read_proc;
              else
                begin
diff --git a/compiler/scanner.pas b/compiler/scanner.pas
index 76651f98a9..5f7ee77a1a 100644
--- a/compiler/scanner.pas
+++ b/compiler/scanner.pas
@@ -69,6 +69,20 @@ interface
 
        tspecialgenerictoken = (ST_LOADSETTINGS,ST_LINE,ST_COLUMN,ST_FILEINDEX);
 
+       treplaystackentry = record
+          replaytokenbuf  : tdynamicarray;
+          replaysavetoken : ttoken;
+          { old settings, i.e. settings specialization was started }
+          old_settings    : tsettings;
+          old_c           : char;
+
+          pausesavetoken  : ttoken;
+          pause_settings  : tsettings;
+          pause_c         : char;
+       end;
+
+       treplaystack = array of treplaystackentry;
+
        tscannerfile = class
        public
           inputfile    : tinputfile;  { current inputfile list }
@@ -85,12 +99,10 @@ interface
           lasttoken,
           nexttoken    : ttoken;
 
-          replaysavetoken : ttoken;
-          replaytokenbuf,
           recordtokenbuf : tdynamicarray;
+          replaystack    : treplaystack;
+          replaystackpos : Integer;
 
-          { old settings, i.e. settings specialization was started }
-          old_settings,
           { last settings we stored }
           last_settings : tsettings;
 
@@ -140,6 +152,8 @@ interface
           procedure stoprecordtokens;
           procedure replaytoken;
           procedure startreplaytokens(buf:tdynamicarray);
+          procedure pausereplaytokens;
+          procedure resumereplaytokens;
           procedure readchar;
           procedure readstring;
           procedure readnumber;
@@ -270,6 +284,9 @@ implementation
          if s='DELPHI' then
           current_settings.modeswitches:=delphimodeswitches
         else
+         if s='ASPECT' then
+          current_settings.modeswitches:=delphimodeswitches + [m_aspect]
+        else
          if s='TP' then
           current_settings.modeswitches:=tpmodeswitches
         else
@@ -1680,6 +1697,7 @@ In case not, the value returned can be arbitrary.
 
     constructor tscannerfile.create(const fn:string);
       begin
+        replaystackpos := -1;
         inputfile:=do_openinputfile(fn);
         if assigned(current_module) then
           current_module.sourcefiles.register_file(inputfile);
@@ -1915,38 +1933,94 @@ In case not, the value returned can be arbitrary.
         { save current token }
         if token in [_CWCHAR,_CWSTRING,_CCHAR,_CSTRING,_INTCONST,_REALNUMBER,_ID] then
           internalerror(200511178);
-        replaysavetoken:=token;
-        old_settings:=current_settings;
-        if assigned(inputpointer) then
-          dec(inputpointer);
-        { install buffer }
-        replaytokenbuf:=buf;
+
+        if replaystackpos <> High(replaystack) then
+          internalerror(2007012703);
+
+        SetLength(replaystack, Succ(Length(replaystack)));
+        replaystackpos := High(replaystack);
+        with replaystack[replaystackpos] do begin
+          replaysavetoken := token;
+          old_settings := current_settings;
+          old_c := c;
+          { install buffer }
+          replaytokenbuf := buf;
+          replaytokenbuf.seek(0);
+        end;
 
         { reload next token }
-        replaytokenbuf.seek(0);
         replaytoken;
       end;
 
+    procedure tscannerfile.pausereplaytokens;
+    begin
+      if replaystackpos < 0 then
+        internalerror(2007012706);
+
+      if token in [_CWCHAR,_CWSTRING,_CCHAR,_CSTRING,_INTCONST,_REALNUMBER,_ID] then
+        internalerror(2007012708);
+
+      with replaystack[replaystackpos] do begin
+        pausesavetoken := token;
+        pause_settings := current_settings;
+        pause_c := c;
+          
+        token := replaysavetoken;
+        current_settings := old_settings;
+        c := old_c;
+      end;
+
+      Dec(replaystackpos);
+    end;
+    
+    procedure tscannerfile.resumereplaytokens;
+    begin
+      if replaystackpos >= High(replaystack) then
+        internalerror(2007012707);
+        
+      if token in [_CWCHAR,_CWSTRING,_CCHAR,_CSTRING,_INTCONST,_REALNUMBER,_ID] then
+        internalerror(2007012709);
+
+      Inc(replaystackpos);
+
+      with replaystack[replaystackpos] do begin
+        replaysavetoken := token;
+        old_settings := current_settings;
+        old_c := c;
+
+        token := pausesavetoken;
+        current_settings := pause_settings;;
+        c := pause_c;         
+      end;
+    end;
 
     procedure tscannerfile.replaytoken;
       var
-        wlen : sizeint;
-        specialtoken : tspecialgenerictoken;
+        wlen           : sizeint;
+        specialtoken   : tspecialgenerictoken;
+        replaytokenbuf : tdynamicarray;
       begin
+        if replaystackpos < 0 then
+          internalerror(2007012704);
+        replaytokenbuf := replaystack[replaystackpos].replaytokenbuf;
+
         if not assigned(replaytokenbuf) then
           internalerror(200511177);
+
         { End of replay buffer? Then load the next char from the file again }
         if replaytokenbuf.pos>=replaytokenbuf.size then
           begin
-            replaytokenbuf:=nil;
-            if assigned(inputpointer) then
-              begin
-                c:=inputpointer^;
-                inc(inputpointer);
-              end;
-            token:=replaysavetoken;
-            { restore compiler settings }
-            current_settings:=old_settings;
+            if replaystackpos < High(replaystack) then
+              internalerror(2007012705);
+
+            with replaystack[replaystackpos] do begin
+              token := replaysavetoken;
+              current_settings := old_settings;
+              c := old_c;
+              replaytokenbuf:=nil;
+            end;
+            Dec(replaystackpos);
+            SetLength(replaystack, Succ(replaystackpos));
             exit;
           end;
         repeat
@@ -3076,7 +3150,7 @@ In case not, the value returned can be arbitrary.
           recordtoken;
 
         { replay tokens? }
-        if assigned(replaytokenbuf) then
+        if replaystackpos >= 0 then
           begin
             replaytoken;
             goto exit_label;
diff --git a/compiler/symconst.pas b/compiler/symconst.pas
index 33869284c4..c9cd3c0a25 100644
--- a/compiler/symconst.pas
+++ b/compiler/symconst.pas
@@ -147,7 +147,11 @@ type
     { type is a generic }
     df_generic,
     { type is a specialization of a generic type }
-    df_specialization
+    df_specialization,
+    { type is an aspect }
+    df_aspect,
+    { type has an aspect applied }
+    df_aspecttarget
   );
   tdefoptions=set of tdefoption;
 
@@ -215,7 +219,8 @@ type
     potype_destructor,   { Procedure is a destructor }
     potype_operator,     { Procedure defines an operator }
     potype_procedure,
-    potype_function
+    potype_function,
+    potype_aspect
   );
   tproctypeoptions=set of tproctypeoption;
 
@@ -270,7 +275,9 @@ type
     po_has_importdll,
     po_has_importname,
     po_kylixlocal,
-    po_dispid
+    po_dispid,
+    { aspects }
+    po_contains_joinpoint
   );
   tprocoptions=set of tprocoption;
 
diff --git a/compiler/symdef.pas b/compiler/symdef.pas
index cece4edf36..1f19f9dc85 100644
--- a/compiler/symdef.pas
+++ b/compiler/symdef.pas
@@ -61,6 +61,8 @@ interface
           genericdef      : tstoreddef;
           genericdefderef : tderef;
           generictokenbuf : tdynamicarray;
+          { aspect support }
+          aspecttokenbuf : tdynamicarray;
           constructor create(dt:tdeftyp);
           constructor ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
           destructor  destroy;override;
@@ -82,6 +84,8 @@ interface
           function is_fpuregable : boolean;
           { generics }
           procedure initgeneric;
+          { aspects }
+          procedure initaspect;
        private
           savesize  : aint;
        end;
@@ -834,6 +838,9 @@ implementation
 {$endif}
          generictokenbuf:=nil;
          genericdef:=nil;
+
+         aspecttokenbuf:=nil;
+
          { Don't register forwarddefs, they are disposed at the
            end of an type block }
          if (dt=forwarddef) then
@@ -868,6 +875,11 @@ implementation
             generictokenbuf.free;
             generictokenbuf:=nil;
           end;
+        if assigned(aspecttokenbuf) then
+          begin
+            aspecttokenbuf.free;
+            aspecttokenbuf:=nil;
+          end;
         inherited destroy;
       end;
 
@@ -901,6 +913,21 @@ implementation
                  dec(sizeleft,i);
                end;
            end;
+         if df_aspect in defoptions then
+           begin
+             sizeleft:=ppufile.getlongint;
+             initaspect;
+             while sizeleft>0 do
+               begin
+                 if sizeleft>sizeof(buf) then
+                   i:=sizeof(buf)
+                 else
+                   i:=sizeleft;
+                 ppufile.getdata(buf,i);
+                 aspecttokenbuf.write(buf,i);
+                 dec(sizeleft,i);
+               end;
+           end;
         if df_specialization in defoptions then
           ppufile.getderef(genericdefderef);
       end;
@@ -973,8 +1000,32 @@ implementation
               end;
             ppufile.do_interface_crc:=oldintfcrc;
           end;
-        if df_specialization in defoptions then
-          ppufile.putderef(genericdefderef);
+          if df_aspect in defoptions then
+          begin
+            oldintfcrc:=ppufile.do_interface_crc;
+            ppufile.do_interface_crc:=false;
+            if assigned(aspecttokenbuf) then
+              begin
+                sizeleft:=aspecttokenbuf.size;
+                aspecttokenbuf.seek(0);
+              end
+            else
+              sizeleft:=0;
+            ppufile.putlongint(sizeleft);
+            while sizeleft>0 do
+              begin
+                if sizeleft>sizeof(buf) then
+                  i:=sizeof(buf)
+                else
+                  i:=sizeleft;
+                aspecttokenbuf.read(buf,i);
+                ppufile.putdata(buf,i);
+                dec(sizeleft,i);
+              end;
+            ppufile.do_interface_crc:=oldintfcrc;
+          end;
+          if df_specialization in defoptions then
+            ppufile.putderef(genericdefderef);
       end;
 
 
@@ -1081,6 +1132,12 @@ implementation
        generictokenbuf:=tdynamicarray.create(256);
      end;
 
+   procedure tstoreddef.initaspect;
+     begin
+       if assigned(aspecttokenbuf) then
+         internalerror(2007012603);
+       aspecttokenbuf:=tdynamicarray.create(256);
+     end;
 
 {****************************************************************************
                                Tstringdef
diff --git a/compiler/symtable.pas b/compiler/symtable.pas
index 55a56ad68e..787b776508 100644
--- a/compiler/symtable.pas
+++ b/compiler/symtable.pas
@@ -196,6 +196,7 @@ interface
     function  searchsym_in_class(classh,contextclassh:tobjectdef;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean;
     function  searchsym_in_class_by_msgint(classh:tobjectdef;msgid:longint;out srdef : tdef;out srsym:tsym;out srsymtable:TSymtable):boolean;
     function  searchsym_in_class_by_msgstr(classh:tobjectdef;const s:string;out srsym:tsym;out srsymtable:TSymtable):boolean;
+    procedure searchsym_aspects(var aList : TFPObjectList);
     function  search_system_type(const s: TIDString): ttypesym;
     function  search_class_member(pd : tobjectdef;const s : string):tsym;
     function  search_assignment_operator(from_def,to_def:Tdef):Tprocdef;
@@ -1699,6 +1700,41 @@ implementation
         srsymtable:=nil;
       end;
 
+    procedure find_aspects_callback(data:TObject;arg:pointer);
+    var
+      ps   : tprocsym;
+      pd   : tprocdef;
+      List : PFPObjectList;
+    begin
+      if data is tprocsym then begin
+        ps := tprocsym(data);
+        if ps.ProcdefList.Count > 0 then begin
+          pd := tprocdef(ps.ProcdefList.Items[0]);
+          if df_aspect in pd.defoptions then begin
+            List := PFPObjectList(arg);
+            if not Assigned(List^) then begin
+              List^ := TFPObjectList.Create(False);
+            end;
+            if List^.IndexOf(pd) < 0 then
+              List^.Add(pd);
+          end;
+        end;
+      end;
+    end;
+
+    procedure  searchsym_aspects(var aList : TFPObjectList);
+      var
+        stackitem  : psymtablestackitem;
+        srsymtable : TSymtable;
+       begin
+        stackitem:=symtablestack.stack;
+        while assigned(stackitem) do
+          begin
+            srsymtable:=stackitem^.symtable;
+            srsymtable.SymList.ForEachCall(@find_aspects_callback, @aList);
+            stackitem:=stackitem^.next;
+          end;
+      end;
 
     function search_assignment_operator(from_def,to_def:Tdef):Tprocdef;
       var
diff --git a/compiler/tokens.pas b/compiler/tokens.pas
index 52e8b28625..925aa6b850 100644
--- a/compiler/tokens.pas
+++ b/compiler/tokens.pas
@@ -156,6 +156,7 @@ type
     _UNTIL,
     _WHILE,
     _WRITE,
+    _ASPECT,
     _DISPID,
     _DOWNTO,
     _EXCEPT,
@@ -406,6 +407,7 @@ const
       (str:'UNTIL'         ;special:false;keyword:m_all;op:NOTOKEN),
       (str:'WHILE'         ;special:false;keyword:m_all;op:NOTOKEN),
       (str:'WRITE'         ;special:false;keyword:m_none;op:NOTOKEN),
+      (str:'ASPECT'        ;special:false;keyword:m_aspect;op:NOTOKEN),
       (str:'DISPID'        ;special:false;keyword:m_none;op:NOTOKEN),
       (str:'DOWNTO'        ;special:false;keyword:m_all;op:NOTOKEN),
       (str:'EXCEPT'        ;special:false;keyword:m_except;op:NOTOKEN),
diff --git a/compiler/utils/ppudump.pp b/compiler/utils/ppudump.pp
index fdd6692744..41da1924cc 100644
--- a/compiler/utils/ppudump.pp
+++ b/compiler/utils/ppudump.pp
@@ -748,7 +748,11 @@ type
     { type is a generic }
     df_generic,
     { type is a specialization of a generic type }
-    df_specialization
+    df_specialization,
+    { type is a aspect }
+    df_aspect,
+    { type has an aspect applied }
+    df_aspecttarget
   );
   tdefoptions=set of tdefoption;
 
@@ -771,11 +775,13 @@ type
     str  : string[30];
   end;
 const
-  defopts=3;
+  defopts=5;
   defopt : array[1..defopts] of tdefopt=(
      (mask:df_unique;         str:'Unique Type'),
      (mask:df_generic;        str:'Generic'),
-     (mask:df_specialization; str:'Specialization')
+     (mask:df_specialization; str:'Specialization'),
+     (mask:df_aspect;         str:'Aspect'),
+     (mask:df_aspecttarget;   str:'Aspect Target')
   );
   defstateinfos=7;
   defstate : array[1..defstateinfos] of tdefstateinfo=(
@@ -918,7 +924,107 @@ begin
       writeln;
       freemem(tokenbuf);
     end;
-  if df_specialization in defoptions then
+    if df_aspect in defoptions then
+    begin
+      tokenbufsize:=ppufile.getlongint;
+      writeln(space,' Tokenbuffer size : ',tokenbufsize);
+      tokenbuf:=allocmem(tokenbufsize);
+      ppufile.getdata(tokenbuf^,tokenbufsize);
+      i:=0;
+      write(space,' Tokens: ');
+      while i<tokenbufsize do
+        begin
+          if ttoken(tokenbuf[i])<>_GENERICSPECIALTOKEN then
+            write(arraytokeninfo[ttoken(tokenbuf[i])].str);
+          case ttoken(tokenbuf[i]) of
+            _CWCHAR,
+            _CWSTRING :
+              begin
+                inc(i);
+              {
+                replaytokenbuf.read(wlen,sizeof(SizeInt));
+                setlengthwidestring(patternw,wlen);
+                replaytokenbuf.read(patternw^.data^,patternw^.len*sizeof(tcompilerwidechar));
+                pattern:='';
+              }
+              end;
+            _CCHAR,
+            _CSTRING,
+            _INTCONST,
+            _REALNUMBER :
+              begin
+                inc(i);
+              {
+                replaytokenbuf.read(pattern[0],1);
+                replaytokenbuf.read(pattern[1],length(pattern));
+                orgpattern:='';
+              }
+              end;
+            _ID :
+              begin
+                inc(i);
+                inc(i);
+                write(' ',pshortstring(@tokenbuf[i])^);
+                inc(i,tokenbuf[i]+1);
+              {
+                replaytokenbuf.read(orgpattern[0],1);
+                replaytokenbuf.read(orgpattern[1],length(orgpattern));
+                pattern:=upper(orgpattern);
+              }
+              end;
+            _GENERICSPECIALTOKEN:
+              begin
+                inc(i);
+                case tspecialgenerictoken(tokenbuf[i]) of
+                  ST_LOADSETTINGS:
+                    begin
+                      inc(i);
+                      write('Settings');
+                      inc(i,sizeof(tsettings));
+                    end;
+                  ST_LINE:
+                    begin
+                      inc(i);
+                      write('Line: ',pdword(@tokenbuf[i])^);
+                      inc(i,4);
+                    end;
+                  ST_COLUMN:
+                    begin
+                      inc(i);
+                      write('Col: ',pword(@tokenbuf[i])^);
+                      inc(i,2);
+                    end;
+                  ST_FILEINDEX:
+                    begin
+                      inc(i);
+                      write('File: ',pword(@tokenbuf[i])^);
+                      inc(i,2);
+                    end;
+                end;
+              {
+                replaytokenbuf.read(specialtoken,1);
+                case specialtoken of
+                  ST_LOADSETTINGS:
+                    begin
+                      replaytokenbuf.read(current_settings,sizeof(current_settings));
+                    end
+                  else
+                    internalerror(2006103010);
+                end;
+                continue;
+              }
+              end;
+            else
+              inc(i);
+          end;
+
+          if i<tokenbufsize then
+            write(',');
+        end;
+      writeln;
+      freemem(tokenbuf);
+    end;
+    if df_specialization in defoptions then
     begin
       write  (space,' Orig. GenericDef : ');
       readderef;