Start to get attribute declaration in place.

rakudo · May 24, 2011 · 590e586 · 590e586
1 parent ca8a1d2
commit 590e586
Show file tree

Hide file tree

Showing 3 changed files with 50 additions and 28 deletions.
diff --git a/src/Perl6/Actions.pm b/src/Perl6/Actions.pm
@@ -964,40 +964,30 @@ class Perl6::Actions is HLL::Actions {
         my $BLOCK := $*ST.cur_lexpad();
 
         if $*SCOPE eq 'has' {
-            # Find the current package and add the attribute.
-            my $attrname := ~$sigil ~ '!' ~ $desigilname;
-            our @PACKAGE;
-            unless +@PACKAGE {
-                $/.CURSOR.panic("Cannot declare an attribute outside of a package");
-            }
-            if @PACKAGE[0].has_attribute($attrname) {
-                $/.CURSOR.panic("Cannot re-declare attribute " ~ $attrname);
-            }
-            my %attr_info;
-            %attr_info<name>      := $attrname;
-            %attr_info<type>      := $*TYPENAME;
-            %attr_info<accessor>  := $twigil eq '.' ?? 1 !! 0;
-            if $trait_list && has_compiler_trait_with_val($trait_list, '&trait_mod:<is>', 'rw') {
-                %attr_info<rw> := 1;
-            }
-            if $trait_list && has_compiler_trait_with_val($trait_list, '&trait_mod:<is>', 'readonly') {
-                %attr_info<rw> := 0;
-            }
-            my $has_handles := has_compiler_trait($trait_list, '&trait_mod:<handles>');
-            if $has_handles {
-                %attr_info<handles> := $has_handles[0];
+            # Ensure current package can take attributes.
+            unless pir::can($*PACKAGE.HOW, 'add_attribute') {
+                $/.CURSOR.panic("A $*PKGDECL cannot have attributes");
             }
-            @PACKAGE[0].attributes.push(%attr_info);
-
+
+            # Create meta-attribute and add it.
+            my $attrname := ~$sigil ~ '!' ~ $desigilname;
+            my $metaattr := %*HOW{$*PKGDECL ~ '-attr'};
+            $*ST.pkg_add_attribute($*PACKAGE, $metaattr, 
+                hash(
+                    name => $attrname,
+                    has_accessor => $twigil eq '.'
+                ),
+                hash( 
+                    type => $*TYPENAME ?? $*TYPENAME[0].ast !! $*ST.find_symbol(['Mu'])
+                ));
+
             # If no twigil, note $foo is an alias to $!foo.
             if $twigil eq '' {
                 $BLOCK.symbol($name, :attr_alias($attrname));
             }
 
-            # Nothing to emit here; just hand  back an empty node, but also
-            # annotate it with the attribute table.
+            # Nothing to emit here; just hand  back an empty node.
             $past := PAST::Op.new( :pasttype('null') );
-            $past<attribute_data> := %attr_info;
         }
         else {
             # Not an attribute - need to emit delcaration here.

diff --git a/src/Perl6/Grammar.pm b/src/Perl6/Grammar.pm
@@ -1046,7 +1046,7 @@ grammar Perl6::Grammar is HLL::Grammar {
             if +$<typename> > 1 {
                 $/.CURSOR.panic("Multiple prefix constraints not yet supported");
             }
-            $*TYPENAME := $<typename>[0].ast;
+            $*TYPENAME := $<typename>;
           }
           <DECL=multi_declarator>
         | <DECL=multi_declarator>

diff --git a/src/Perl6/SymbolTable.pm b/src/Perl6/SymbolTable.pm
@@ -338,6 +338,38 @@ class Perl6::SymbolTable is HLL::Compiler::SerializationContextBuilder {
         return $mo;
     }
 
+    # Constructs a meta-attribute and adds it to a meta-object. Expects to
+    # be passed the meta-attribute type object, a set of literal named
+    # arguments to pass and a set of name to object mappings to pass also
+    # as named arguments, but where these passed objects also live in a
+    # serialization context. The type would be passed in this way.
+    method pkg_add_attribute($obj, $meta_attr, %lit_args, %obj_args) {
+        # Create and add right away.
+        my $attr := $meta_attr.new(|%lit_args, |%obj_args);
+        $obj.HOW.add_attribute($obj, $attr);
+
+        # Emit code to create and add it when deserializing.
+        my $create_call := PAST::Op.new(
+            :pasttype('callmethod'), :name('new'),
+            self.get_object_sc_ref_past($meta_attr)
+        );
+        for %lit_args {
+            $create_call.push(PAST::Val.new( :value($_.value), :named($_.key) ));
+        }
+        for %obj_args {
+            my $lookup := self.get_object_sc_ref_past($_.value);
+            $lookup.named($_.key);
+            $create_call.push($lookup);
+        }
+        my $obj_slot_past := self.get_slot_past_for_object($obj);
+        self.add_event(:deserialize_past(PAST::Op.new(
+            :pasttype('callmethod'), :name('add_attribute'),
+            PAST::Op.new( :pirop('get_how PP'), $obj_slot_past ),
+            $obj_slot_past,
+            $create_call
+        )));
+    }
+
     # Composes the package, and stores an event for this action.
     method pkg_compose($obj) {
         # Compose.