move HAS scope implementation from NativeCall to src/Perl6/

See http://irclog.perlgeek.de/perl6/2016-06-14#i_12661602
rakudo · Jun 14, 2016 · ac0dcdd · ac0dcdd
1 parent d927228
commit ac0dcdd
Show file tree

Hide file tree

Showing 4 changed files with 31 additions and 39 deletions.
diff --git a/lib/NativeCall.pm6 b/lib/NativeCall.pm6
@@ -416,43 +416,4 @@ sub cglobal($libname, $symbol, $target-type) is export is rw {
 
 }
 
-sub EXPORT(|) {
-    use NQPHLL:from<NQP>;
-    my role HAS-decl-grammar {
-        # This is a direct copy of scope_declarator:sym<has>, besides the uppercase spelling.
-        token scope_declarator:sym<HAS> {
-            :my $*LINE_NO := HLL::Compiler.lineof(self.orig(), self.from(), :cache(1));
-            <sym>
-            :my $*HAS_SELF := 'partial';
-            :my $*ATTR_INIT_BLOCK;
-            <scoped('has')>
-        }
-    }
-    my role HAS-decl-actions {
-        method scope_declarator:sym<HAS>(Mu $/) {
-            # my $scoped := $<scoped>.ast;
-            my Mu $scoped := nqp::atkey(nqp::findmethod($/, 'hash')($/), 'scoped').ast;
-            my Mu $attr   := $scoped.ann('metaattr');
-            if $attr.package.REPR ne 'CStruct'
-            && $attr.package.REPR ne 'CPPStruct'
-            && $attr.package.REPR ne 'CUnion' {
-                die "Can only use HAS-scoped attributes in classes with repr CStruct, CPPStruct and CUnion, not " ~ $attr.package.REPR;
-            }
-            if nqp::objprimspec($attr.type) != 0 {
-                warn "Useless use of HAS scope on an attribute with type { $attr.type.^name }.";
-            }
-            # Mark $attr as inlined, that's why we do all this.
-            nqp::bindattr_i(nqp::decont($attr), $attr.WHAT, '$!inlined', 1);
-            # make $scoped
-            nqp::bindattr(nqp::decont($/), $/.WHAT, '$!made', $scoped);
-        }
-    }
-    my Mu $MAIN-grammar := nqp::atkey(%*LANG, 'MAIN');
-    my Mu $MAIN-actions := nqp::atkey(%*LANG, 'MAIN-actions');
-    nqp::bindkey(%*LANG, 'MAIN',         $MAIN-grammar.HOW.mixin($MAIN-grammar, HAS-decl-grammar));
-    nqp::bindkey(%*LANG, 'MAIN-actions', $MAIN-actions.HOW.mixin($MAIN-actions, HAS-decl-actions));
-
-    {}
-}
-
 # vim:ft=perl6
diff --git a/src/Perl6/Actions.nqp b/src/Perl6/Actions.nqp
@@ -2758,6 +2758,23 @@ class Perl6::Actions is HLL::Actions does STDActions {
     method scope_declarator:sym<augment>($/) { make $<scoped>.ast; }
     method scope_declarator:sym<state>($/)   { make $<scoped>.ast; }
     method scope_declarator:sym<unit>($/)    { make $<scoped>.ast; }
+    method scope_declarator:sym<HAS>($/)     {
+        my $scoped := $<scoped>.ast;
+        my $attr   := $scoped.ann('metaattr');
+        if $attr.package.REPR ne 'CStruct'
+        && $attr.package.REPR ne 'CPPStruct'
+        && $attr.package.REPR ne 'CUnion' {
+            $*W.throw($/, ['X', 'Attribute', 'Scope', 'Package'], :scope<HAS>,
+                :allowed('classes with CStruct, CPPStruct and CUnion representation are supported'),
+                :disallowed('package with ' ~ $attr.package.REPR ~ ' representation'));
+        }
+        if nqp::objprimspec($attr.type) != 0 {
+            $/.CURSOR.worry('Useless use of HAS scope on ' ~ $attr.type.HOW.name($attr.type) ~ ' typed attribute.');
+        }
+        # Mark $attr as inlined, that's why we do all this.
+        nqp::bindattr_i($attr, $attr.WHAT, '$!inlined', 1);
+        make $scoped;
+    }
 
     method declarator($/) {
         if    $<routine_declarator>  { make $<routine_declarator>.ast  }

diff --git a/src/Perl6/Grammar.nqp b/src/Perl6/Grammar.nqp
@@ -2412,6 +2412,13 @@ grammar Perl6::Grammar is HLL::Grammar does STD {
         :my $*ATTR_INIT_BLOCK;
         <scoped('has')>
     }
+    token scope_declarator:sym<HAS>       {
+        :my $*LINE_NO := HLL::Compiler.lineof(self.orig(), self.from(), :cache(1));
+        <sym>
+        :my $*HAS_SELF := 'partial';
+        :my $*ATTR_INIT_BLOCK;
+        <scoped('has')>
+    }
     token scope_declarator:sym<augment>   { <sym> <scoped('augment')> }
     token scope_declarator:sym<anon>      { <sym> <scoped('anon')> }
     token scope_declarator:sym<state>     { <sym> <scoped('state')> }

diff --git a/src/core/Exception.pm b/src/core/Exception.pm
@@ -1620,6 +1620,13 @@ my class X::Attribute::Required does X::MOP {
     has $.name;
     method message() { "The attribute '$.name' is required, but you did not provide a value for it." }
 }
+my class X::Attribute::Scope::Package does X::Comp {
+    has $.scope;
+    has $.allowed;
+    has $.disallowed;
+    method message() { "Cannot use {$.scope}-scoped attribute in $.disallowed"
+        ~ ($.allowed ?? ", only $.allowed." !! ".") }
+}
 my class X::Declaration::Scope does X::Comp {
     has $.scope;
     has $.declaration;