develooper Front page | perl.cvs.parrot | Postings from December 2008

[svn:parrot] r34523 - in branches/rvar/languages/perl6/src: classes parser

From:
pmichaud
Date:
December 28, 2008 14:21
Subject:
[svn:parrot] r34523 - in branches/rvar/languages/perl6/src: classes parser
Message ID:
20081228222149.01C63CB9FA@x12.develooper.com
Author: pmichaud
Date: Sun Dec 28 14:21:48 2008
New Revision: 34523

Modified:
   branches/rvar/languages/perl6/src/classes/Signature.pir
   branches/rvar/languages/perl6/src/parser/actions.pm
   branches/rvar/languages/perl6/src/parser/grammar.pg

Log:
[rakudo]:  Add type checking to scalar parameters.


Modified: branches/rvar/languages/perl6/src/classes/Signature.pir
==============================================================================
--- branches/rvar/languages/perl6/src/classes/Signature.pir	(original)
+++ branches/rvar/languages/perl6/src/classes/Signature.pir	Sun Dec 28 14:21:48 2008
@@ -179,7 +179,6 @@
 
 .namespace []
 .sub '!SIGNATURE_BIND'
-    .include 'interpinfo.pasm'
     .local pmc callersub, callerlex, callersig
     $P0 = getinterp
     callersub = $P0['sub';1]
@@ -197,18 +196,35 @@
     .local string name, sigil
     name = param['name']
     sigil = substr name, 0, 1
-    .local pmc var
+    .local pmc type, var
+    type = param['type']
     var = callerlex[name]
     if sigil == '@' goto param_array
     var = 'Scalar'(var)
-    callerlex[name] = var
-    goto param_loop
+    ##  typecheck the argument
+    if null type goto param_val_done
+    .lex '$/', $P99
+    $P0 = type.'ACCEPTS'(var)
+    unless $P0 goto err_param_type
+    goto param_val_done
   param_array:
     var = 'Array'(var)
+    goto param_val_done
+  param_val_done:
+    ## place the updated variable back into lex
     callerlex[name] = var
+    ## set any type properties
+    setprop var, 'type', type
     goto param_loop
   param_done:
   end:
+    .return ()
+  err_param_type:
+    $S0 = callersub
+    if $S0 goto have_callersub_name
+    $S0 = '<anon>'
+  have_callersub_name:
+    'die'('Parameter type check failed in call to ', $S0)
 .end
 
 
@@ -217,7 +233,6 @@
 =cut
 
 
-
 # Local Variables:
 #   mode: pir
 #   fill-column: 100

Modified: branches/rvar/languages/perl6/src/parser/actions.pm
==============================================================================
--- branches/rvar/languages/perl6/src/parser/actions.pm	(original)
+++ branches/rvar/languages/perl6/src/parser/actions.pm	Sun Dec 28 14:21:48 2008
@@ -892,32 +892,43 @@
     else {
         my $loadinit := $?SIGNATURE_BLOCK.loadinit();
         my $sigobj   := PAST::Var.new( :scope('register') );
+
+        ##  create a Signature object and attach to the block
         $loadinit.push(
-            PAST::Op.new( :inline('    %0 = new "Signature"'), $sigobj)
+            PAST::Op.new( :inline('    %0 = new "Signature"',
+                                  '    setprop block, "$!signature", %0'), 
+                           $sigobj)
         );
 
+        ##  loop through parameters of signature
         my $i   := 0;
         my $n   := $<parameter> ?? +@($<parameter>) !! 0;
         while $i < $n {
             my $param_past := $( $<parameter>[$i] );
             my $name       := $param_past.name();
             my $symbol     := $?SIGNATURE_BLOCK.symbol($name);
+
+            ##  set the default value of the param and add var node to block
             $param_past.viviself( $symbol<viviself> );
             $?SIGNATURE.push( $param_past );
 
+            ##  add parameter to the signature object
             my $sigparam := PAST::Op.new( :pasttype('callmethod'), 
                                 :name('!add_param'), $sigobj, $name );
+
+            ##  add any typechecks
+            if +$symbol<type> == 1 {
+                my $type := $symbol<type>[0];
+                $type.named('type');
+                $sigparam.push($type);
+            }
+
             $loadinit.push($sigparam);
             $i++;
         }
-        $loadinit.push( 
-            PAST::Op.new( 
-                :inline('    setprop block, "$!signature", %0'),
-                $sigobj 
-            )
-        );
+
+        ##  restore block stack and return signature ast
         @?BLOCK.shift();
-        ##  return signature ast node
         make $?SIGNATURE;
     }
 
@@ -925,6 +936,15 @@
 }
 
 
+method type_constraint($/) {
+    my $past;
+    if $<fulltypename> {
+        $past := $( $<fulltypename> );
+    }
+    make $past;
+}
+
+
 method parameter($/) {
     our $?SIGNATURE_BLOCK;
     my $past   := $( $<param_var> );
@@ -958,6 +978,12 @@
         $symbol<viviself> := $( $<default_value>[0]<EXPR> );
     }
 
+    my $type := List.new();
+    $symbol<type> := $type;
+    if $<type_constraint> {
+        for @($<type_constraint>) { $type.push( $( $_ ) ); }
+    }
+
     make $past;
 }
 

Modified: branches/rvar/languages/perl6/src/parser/grammar.pg
==============================================================================
--- branches/rvar/languages/perl6/src/parser/grammar.pg	(original)
+++ branches/rvar/languages/perl6/src/parser/grammar.pg	Sun Dec 28 14:21:48 2008
@@ -451,6 +451,7 @@
     | <fulltypename>
     | where <EXPR: 'm='>               # XXX <EXPR(item %chaining)>
     ]
+    {*}
 }
 
 rule post_constraint {



nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About