First cut implementation of state variables in Rakudo. Not perfect, b…

…ut passes at half of state.t (and 5/7ths of what in state.t we can pass without implementing extra unrelated features). Needs makefile re-generated to build.
rakudo · Mar 17, 2009 · 4ff1b17 · 4ff1b17
1 parent 5b1ff9c
commit 4ff1b17
Show file tree

Hide file tree

Showing 4 changed files with 151 additions and 3 deletions.
diff --git a/build/Makefile.in b/build/Makefile.in
@@ -42,6 +42,7 @@ SOURCES = perl6.pir \
   src/parser/expression.pir \
   src/parser/methods.pir \
   src/parser/quote_expression.pir \
+  src/pctextensions/state.pir \
   $(PERL6_GROUP) \
   src/ops/perl6_ops$(LOAD_EXT)
 

diff --git a/src/builtins/guts.pir b/src/builtins/guts.pir
@@ -1140,6 +1140,42 @@ Reblesses a sub into a new type.
     rebless_subclass sub, $P0
 .end
 
+
+=item !state_var_init
+
+Takes a list of state variables to initialize. Returns wether we need to run
+the initial setting of values for them.
+
+=cut
+
+.sub '!state_var_init'
+    .param pmc names :slurpy
+    
+    .local pmc lexpad, state_store, names_it
+    $P0 = new 'ParrotInterpreter'
+    lexpad = $P0['lexpad'; 1]
+    $P0 = $P0['sub'; 1]
+    state_store = getprop '$!state_store', $P0
+    unless null state_store goto have_state_store
+    state_store = new 'Hash'
+    setprop $P0, '$!state_store', state_store
+  have_state_store:
+
+    names_it = iter names
+  names_loop:
+    unless names_it goto names_loop_end
+    $S0 = shift names_it
+    $P0 = state_store[$S0]
+    if null $P0 goto need_init
+    lexpad[$S0] = $P0
+    goto names_loop
+  names_loop_end:
+    .return (0)
+
+  need_init:
+    .return (1)
+.end
+
 =back
 
 =cut

diff --git a/src/parser/actions.pm b/src/parser/actions.pm
@@ -1767,8 +1767,9 @@ method scope_declarator($/) {
     my $sym   := ~$<sym>;
     my $past  := $( $<scoped> );
     my $scope := 'lexical';
-    if    $sym eq 'our' { $scope := 'package'; }
-    elsif $sym eq 'has' { $scope := 'attribute'; }
+    if    $sym eq 'our'   { $scope := 'package'; }
+    elsif $sym eq 'has'   { $scope := 'attribute'; }
+    elsif $sym eq 'state' { $scope := 'state'; }
 
     #  Private methods get a leading !.
     if $scope eq 'lexical' && $past.isa(PAST::Block)
@@ -1869,11 +1870,14 @@ method scope_declarator($/) {
             $i++;
         }
         if $scope eq 'attribute' {
-            $past.pasttype('null');
             $past<scopedecl> := $scope;
+            $past.pasttype('null');
         }
         elsif +@($past) == 1 { $past := $past[0]; }
         else { $past.name('infix:,'); $past.pasttype('call'); }
+        if $scope eq 'state' {
+            $past<scopedecl> := $scope;
+        }
     }
     make $past;
 }
@@ -2471,6 +2475,34 @@ method EXPR($/, $key) {
             @?BLOCK[0][0].push($past);
             $past := PAST::Stmts.new();
         }
+        elsif $lhs<scopedecl> eq 'state' {
+            # State variables - only want to actually do an assignment if
+            # there is no value. This calls !state_var_init, which does the
+            # initialization of state vars to their previous values and then
+            # returns a false value. In the event that there are not any
+            # existing values, however, it does the assignment.
+            $past := PAST::Op.new(
+                :pasttype('if'),
+                :node($/),
+                PAST::Op.new(
+                    :pasttype('call'),
+                    :name('!state_var_init'),
+                ),
+                PAST::Op.new(
+                    :pasttype('call'),
+                    :name('infix:='),
+                    :lvalue(1),
+                    $lhs,
+                    $rhs
+                )
+            );
+            if $lhs.isa(PAST::Op) {
+                for @($lhs) { $past[0].push($_.name()); }
+            }
+            else {
+                $past[0].push($lhs.name());
+            }
+        }
         else {
             # Just a normal assignment.
             $past := PAST::Op.new(

diff --git a/src/pctextensions/state.pir b/src/pctextensions/state.pir
@@ -0,0 +1,79 @@
+# Copyright (C) 2007-2009, The Perl Foundation.
+
+=head1 NAME
+
+state.pir - supports the state scope type
+
+=head1 DESCRIPTION
+
+This is a kind of "plug-in" to PAST::Compiler that adds the state scope type.
+This may or may not get folded back into PCT some day.
+
+XXX TODO: Doesn't yet handle binding beyond the initial one.
+
+=cut
+
+.include "interpinfo.pasm"
+.namespace [ 'PAST';'Compiler' ]
+.sub 'state' :method :multi(_, ['PAST';'Var'])
+    .param pmc node
+    .param pmc bindpost
+
+    .local string name
+    $P0 = get_hll_global ['POST'], 'Ops'
+    name = node.'name'()
+    name = self.'escape'(name)
+
+    .local int isdecl
+    isdecl = node.'isdecl'()
+
+    if bindpost goto lexical_bind
+
+  lexical_post:
+    if isdecl goto lexical_decl
+    .local pmc ops, fetchop, storeop
+    ops = $P0.'new'('node'=>node)
+    $P0 = get_hll_global ['POST'], 'Op'
+    fetchop = $P0.'new'(ops, name, 'pirop'=>'find_lex')
+    storeop = $P0.'new'(name, ops, 'pirop'=>'store_lex')
+    .tailcall self.'vivify'(node, ops, fetchop, storeop)
+
+  lexical_decl:
+    ops = $P0.'new'('node'=>node)
+    
+    # Do a call to restore any previous values. We can skip the rest
+    # if it returns a false value.
+    $P0 = self.'uniquereg'('I')
+    ops.'push_pirop'('call', '"!state_var_init"', name, 'result'=>$P0)
+    $P1 = get_hll_global ['POST'], 'Label'
+    $S0 = self.'unique'('state')
+    $P1 = $P1.'new'('result'=>$S0)
+    ops.'push_pirop'('unless', $P0, $P1)
+    
+    # Vivify and store vivification.
+    .local pmc viviself, vivipost
+    viviself = node.'viviself'()
+    vivipost = self.'as_vivipost'(viviself, 'rtype'=>'P')
+    ops.'push'(vivipost)
+    ops.'push_pirop'('.lex', name, vivipost)
+    $P0 = self.'uniquereg'('P')
+    ops.'push_pirop'('interpinfo', $P0, .INTERPINFO_CURRENT_SUB)
+    ops.'push_pirop'('getprop', $P0, '"$!state_store"', $P0)
+    $S0 = $P0
+    concat $S0, "["
+    concat $S0, name
+    concat $S0, "]"
+    ops.'push_pirop'('set', $S0, vivipost)
+    ops.'result'(vivipost)
+
+    # Finally, label we go to if we don't need to init.
+    ops.'push'($P1)
+    .return (ops)
+
+  lexical_bind:
+    $P0 = get_hll_global ['POST'], 'Op'
+    if isdecl goto lexical_bind_decl
+    .tailcall $P0.'new'(name, bindpost, 'pirop'=>'store_lex', 'result'=>bindpost)
+  lexical_bind_decl:
+    .tailcall $P0.'new'(name, bindpost, 'pirop'=>'.lex', 'result'=>bindpost)
+.end