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

[svn:parrot] r33611 - in trunk: . languages/perl6 languages/perl6/build languages/perl6/config/makefiles languages/perl6/src/builtins languages/perl6/src/parser

From:
pmichaud
Date:
December 7, 2008 07:40
Subject:
[svn:parrot] r33611 - in trunk: . languages/perl6 languages/perl6/build languages/perl6/config/makefiles languages/perl6/src/builtins languages/perl6/src/parser
Message ID:
20081207154010.B2952CB9AF@x12.develooper.com
Author: pmichaud
Date: Sun Dec  7 07:40:09 2008
New Revision: 33611

Added:
   trunk/languages/perl6/build/gen_metaop_pir.pl   (contents, props changed)
Modified:
   trunk/MANIFEST
   trunk/languages/perl6/config/makefiles/root.in
   trunk/languages/perl6/perl6.pir
   trunk/languages/perl6/src/builtins/assign.pir
   trunk/languages/perl6/src/builtins/op.pir
   trunk/languages/perl6/src/parser/grammar-oper.pg
   trunk/languages/perl6/src/parser/grammar.pg

Log:
[rakudo]:  Fix assignment metaoperators, add reduction operators (e.g., [+]).


Modified: trunk/MANIFEST
==============================================================================
--- trunk/MANIFEST	(original)
+++ trunk/MANIFEST	Sun Dec  7 07:40:09 2008
@@ -1,7 +1,7 @@
 # ex: set ro:
 # $Id$
 #
-# generated by tools/dev/mk_manifest_and_skip.pl Sat Dec  6 05:46:39 2008 UT
+# generated by tools/dev/mk_manifest_and_skip.pl Sun Dec  7 15:38:53 2008 UT
 #
 # See tools/dev/install_files.pl for documentation on the
 # format of this file.
@@ -2098,6 +2098,7 @@
 languages/perl6/Test.pm                                     [perl6]
 languages/perl6/build/gen_builtins_pir.pl                   [perl6]
 languages/perl6/build/gen_junction_pir.pl                   [perl6]
+languages/perl6/build/gen_metaop_pir.pl                     [perl6]
 languages/perl6/build/gen_objectref_pmc.pl                  [perl6]
 languages/perl6/config/makefiles/root.in                    [perl6]
 languages/perl6/config/makefiles/utils.in                   [perl6]

Added: trunk/languages/perl6/build/gen_metaop_pir.pl
==============================================================================
--- (empty file)
+++ trunk/languages/perl6/build/gen_metaop_pir.pl	Sun Dec  7 07:40:09 2008
@@ -0,0 +1,81 @@
+#!/usr/bin/perl
+# Copyright (C) 2008, The Perl Foundation.
+# $Id$
+
+use strict;
+use warnings;
+
+my @ops = qw(
+  **        1
+  *         1
+  /         'fail'
+  %         'fail'
+  x         'fail'
+  xx        'fail'
+  +&        -1
+  +<        'fail'
+  +>        'fail'
+  ~&        'fail'
+  ~<        'fail'
+  ~>        'fail'
+  ?&        1
+  +         0
+  -         0
+  ~         ''
+  +|        0
+  +^        0
+  ~|        ''
+  ~^        ''
+  ?|        0
+  ?^        0
+);
+
+
+my $output = $ARGV[0] || '-';
+
+
+my $assignfmt = 
+    "    optable.'newtok'('infix:%s=', 'equiv'=>'infix::=', 'lvalue'=>1)\n";
+my $reducefmt =
+    "    optable.'newtok'('prefix:[%s]', 'equiv'=>'infix:=')\n";
+
+my @gtokens = ();
+my @code = ();
+
+while (@ops) {
+    my $opname   = shift @ops;
+    my $identity = shift @ops;
+
+    push @gtokens, sprintf( $assignfmt, $opname );
+    push @gtokens, sprintf( $reducefmt, $opname );
+
+    push @code, qq(
+        .sub 'infix:$opname='
+            .param pmc a
+            .param pmc b
+            .tailcall '!ASSIGNMETAOP'('$opname', a, b)
+        .end
+
+        .sub 'prefix:[$opname]'
+            .param pmc args    :slurpy
+            .tailcall '!REDUCEMETAOP'('$opname', $identity, args)
+        .end\n);
+}
+
+my $gtokens = join('', @gtokens);
+  
+open my $fh, "> $output" or die "Could not write $output: $!";
+print $fh qq(
+.namespace []
+.sub '' :init :load
+    .local pmc optable
+    optable = get_hll_global ['Perl6';'Grammar'], '\$optable'
+$gtokens
+.end
+
+);
+
+print $fh @code;
+
+close $fh;
+0;

Modified: trunk/languages/perl6/config/makefiles/root.in
==============================================================================
--- trunk/languages/perl6/config/makefiles/root.in	(original)
+++ trunk/languages/perl6/config/makefiles/root.in	Sun Dec  7 07:40:09 2008
@@ -42,6 +42,7 @@
   src/gen_grammar.pir \
   src/gen_actions.pir \
   src/gen_builtins.pir \
+  src/gen_metaop.pir \
   src/gen_junction.pir \
   src/parser/expression.pir \
   src/parser/quote_expression.pir \
@@ -134,6 +135,9 @@
 src/gen_builtins.pir: build/gen_builtins_pir.pl
 	$(PERL) build/gen_builtins_pir.pl $(BUILTINS_PIR) > src/gen_builtins.pir
 
+src/gen_metaop.pir: build/gen_metaop_pir.pl
+	$(PERL) build/gen_metaop_pir.pl > src/gen_metaop.pir
+
 src/gen_junction.pir: build/gen_junction_pir.pl
 	$(PERL) build/gen_junction_pir.pl src/gen_junction.pir
 
@@ -243,9 +247,7 @@
   perl6$(EXE) \
   installable_perl6$(EXE) \
   Test.pir \
-  src/gen_grammar.pir \
-  src/gen_actions.pir \
-  src/gen_builtins.pir \
+  src/gen_*.pir \
   $(PMC_DIR)/*.h \
   $(PMC_DIR)/*.c \
   $(PMC_DIR)/*.dump \

Modified: trunk/languages/perl6/perl6.pir
==============================================================================
--- trunk/languages/perl6/perl6.pir	(original)
+++ trunk/languages/perl6/perl6.pir	Sun Dec  7 07:40:09 2008
@@ -222,6 +222,7 @@
 .include 'src/parser/expression.pir'
 .include 'src/parser/quote_expression.pir'
 .include 'src/gen_actions.pir'
+.include 'src/gen_metaop.pir'
 .include 'src/gen_junction.pir'
 
 

Modified: trunk/languages/perl6/src/builtins/assign.pir
==============================================================================
--- trunk/languages/perl6/src/builtins/assign.pir	(original)
+++ trunk/languages/perl6/src/builtins/assign.pir	Sun Dec  7 07:40:09 2008
@@ -74,185 +74,56 @@
 .end
 
 
-.sub '!INIT_IF_PROTO'
-    .param pmc var
-    .param pmc val
-    $I0 = defined var
-    if $I0 goto done
-    'infix:='(var, val)
-  done:
-    .return ()
+.sub '!REDUCEMETAOP'
+    .param string opname
+    .param pmc identity
+    .param pmc args                # already :slurpy array by caller
+
+    args.'!flatten'()
+    if args goto reduce
+    if identity == 'fail' goto fail
+    .return (identity)
+
+  fail:
+    .tailcall '!FAIL'()
+
+  reduce:
+    opname = concat 'infix:', opname
+    .local pmc opfunc
+    opfunc = find_name opname
+    .local pmc result
+    result = shift args
+  reduce_loop:
+    unless args goto reduce_done
+    $P0 = shift args
+    result = opfunc(result, $P0)
+    goto reduce_loop
+  reduce_done:
+    .return (result)
 .end
 
 
-.sub 'infix:~='
+.sub '!ASSIGNMETAOP'
+    .param string opname
     .param pmc a
     .param pmc b
-    '!INIT_IF_PROTO'(a, '')
-    concat a, b
-    .return (a)
-.end
-
-
-.sub 'infix:+='
-    .param pmc a
-    .param pmc b
-    '!INIT_IF_PROTO'(a, 0)
-    a += b
-    .return (a)
-.end
-
-
-.sub 'infix:-='
-    .param pmc a
-    .param pmc b
-    '!INIT_IF_PROTO'(a, 0)
-    a -= b
-    .return (a)
-.end
 
-
-.sub 'infix:*='
-    .param pmc a
-    .param pmc b
-    '!INIT_IF_PROTO'(a, 1)
-    a *= b
-    .return (a)
-.end
-
-
-.sub 'infix:/='
-    .param pmc a
-    .param pmc b
-    a /= b
-    .return (a)
-.end
-
-
-.sub 'infix:%='
-    .param pmc a
-    .param pmc b
-    a %= b
-    .return (a)
-.end
-
-
-.sub 'infix:x='
-    .param pmc a
-    .param pmc b
-    repeat a, b
-    .return (a)
-.end
-
-
-## TODO: infix:Y=
-.sub 'infix:**='
-    .param pmc a
-    .param pmc b
-    '!INIT_IF_PROTO'(a, 1)
-    pow $P0, a, b
+    $I0 = defined a
+    if $I0 goto have_a
+    $S0 = concat 'prefix:[', opname
+    concat $S0, ']'
+    $P1 = find_name $S0
+    $P0 = $P1()
     'infix:='(a, $P0)
-    .return (a)
-.end
-
-
-## TODO: infix:xx= infix:||= infix:&&= infix://= infix:^^=
-
-
-.sub 'infix:+<='
-    .param pmc a
-    .param pmc b
-    a <<= b
-    .return (a)
-.end
-
-
-.sub 'infix:+>='
-    .param pmc a
-    .param pmc b
-    a >>= b
-    .return (a)
-.end
-
-
-.sub 'infix:+&='
-    .param pmc a
-    .param pmc b
-    band a, b
-    .return (a)
-.end
-
-
-.sub 'infix:+|='
-    .param pmc a
-    .param pmc b
-    bor a, b
-    .return (a)
-.end
+  have_a:
 
-
-.sub 'infix:+^='
-    .param pmc a
-    .param pmc b
-    bxor a, b
-    .return (a)
-.end
-
-
-.sub 'infix:~&='
-    .param pmc a
-    .param pmc b
-    a = bands a, b
-    .return (a)
-.end
-
-
-.sub 'infix:~|='
-    .param pmc a
-    .param pmc b
-    bors a, b
-    .return (a)
-.end
-
-
-.sub 'infix:~^='
-    .param pmc a
-    .param pmc b
-    bxors a, b
-    .return (a)
-.end
-
-
-.sub 'infix:?&='
-    .param pmc a
-    .param pmc b
-    band a, b
-    $I0 = istrue a
-    a = $I0
-    .return (a)
-.end
-
-
-.sub 'infix:?|='
-    .param pmc a
-    .param pmc b
-    bor a, b
-    $I0 = istrue a
-    a = $I0
-    .return (a)
-.end
-
-
-.sub 'infix:?^='
-    .param pmc a
-    .param pmc b
-    bxor a, b
-    $I0 = istrue a
-    a = $I0
+    opname = concat 'infix:', opname
+    $P1 = find_name opname
+    $P0 = $P1(a, b)
+    'infix:='(a, $P0)
     .return (a)
 .end
 
-
 =back
 
 =cut

Modified: trunk/languages/perl6/src/builtins/op.pir
==============================================================================
--- trunk/languages/perl6/src/builtins/op.pir	(original)
+++ trunk/languages/perl6/src/builtins/op.pir	Sun Dec  7 07:40:09 2008
@@ -31,7 +31,10 @@
 .sub 'postfix:++' :multi(_)
     .param pmc a
     $P0 = clone a
-    '!INIT_IF_PROTO'(a, 0)
+    $I0 = defined a
+    if $I0 goto have_a
+    'infix:='(a, 0)
+  have_a:
     inc a
     .return ($P0)
 .end
@@ -39,7 +42,10 @@
 .sub 'postfix:--' :multi(_)
     .param pmc a
     $P0 = clone a
-    '!INIT_IF_PROTO'(a, 0)
+    $I0 = defined a
+    if $I0 goto have_a
+    'infix:='(a, 0)
+  have_a:
     dec a
     .return ($P0)
 .end
@@ -47,7 +53,10 @@
 
 .sub 'prefix:++' :multi(_)
     .param pmc a
-    '!INIT_IF_PROTO'(a, 0)
+    $I0 = defined a
+    if $I0 goto have_a
+    'infix:='(a, 0)
+  have_a:
     inc a
     .return (a)
 .end
@@ -55,7 +64,10 @@
 
 .sub 'prefix:--' :multi(_)
     .param pmc a
-    '!INIT_IF_PROTO'(a, 0)
+    $I0 = defined a
+    if $I0 goto have_a
+    'infix:='(a, 0)
+  have_a:
     dec a
     .return (a)
 .end

Modified: trunk/languages/perl6/src/parser/grammar-oper.pg
==============================================================================
--- trunk/languages/perl6/src/parser/grammar-oper.pg	(original)
+++ trunk/languages/perl6/src/parser/grammar-oper.pg	Sun Dec  7 07:40:09 2008
@@ -142,34 +142,6 @@
 proto infix:<:=> is precedence('i=') is pasttype('bind') { ... }
 proto infix:<::=> is equiv(infix:<:=>) { ... }
 proto infix:<.=> is equiv(infix:<:=>) { ... }
-proto infix:<~=> is equiv(infix:<:=>) is lvalue(1) { ... }
-proto infix:<+=> is equiv(infix:<:=>) is lvalue(1) { ... }
-proto infix:<-=> is equiv(infix:<:=>) is lvalue(1) { ... }
-proto infix:<*=> is equiv(infix:<:=>) is lvalue(1) { ... }
-proto infix:</=> is equiv(infix:<:=>) is lvalue(1) { ... }
-proto infix:<%=> is equiv(infix:<:=>) is lvalue(1) { ... }
-proto infix:<x=> is equiv(infix:<:=>) is lvalue(1) { ... }
-proto infix:<Y=> is equiv(infix:<:=>) is lvalue(1) { ... }
-proto infix:<**=> is equiv(infix:<:=>) is lvalue(1) { ... }
-proto infix:<xx=> is equiv(infix:<:=>) is lvalue(1) { ... }
-proto infix:<||=> is equiv(infix:<:=>) is lvalue(1) { ... }
-proto infix:<&&=> is equiv(infix:<:=>) is lvalue(1) { ... }
-proto infix:<//=> is equiv(infix:<:=>) is lvalue(1) { ... }
-proto infix:<^^=> is equiv(infix:<:=>) is lvalue(1) { ... }
-proto infix:«+<=» is equiv(infix:<:=>) is lvalue(1) { ... }
-proto infix:«+>=» is equiv(infix:<:=>) is lvalue(1) { ... }
-proto infix:<+|=> is equiv(infix:<:=>) is lvalue(1) { ... }
-proto infix:<+&=> is equiv(infix:<:=>) is lvalue(1) { ... }
-proto infix:<+^=> is equiv(infix:<:=>) is lvalue(1) { ... }
-proto infix:<~|=> is equiv(infix:<:=>) is lvalue(1) { ... }
-proto infix:<~&=> is equiv(infix:<:=>) is lvalue(1) { ... }
-proto infix:<~^=> is equiv(infix:<:=>) is lvalue(1) { ... }
-proto infix:<?|=> is equiv(infix:<:=>) is lvalue(1) { ... }
-proto infix:<?&=> is equiv(infix:<:=>) is lvalue(1) { ... }
-proto infix:<?^=> is equiv(infix:<:=>) is lvalue(1) { ... }
-proto infix:<|=> is equiv(infix:<:=>) is lvalue(1) { ... }
-proto infix:<&=> is equiv(infix:<:=>) is lvalue(1) { ... }
-proto infix:<^=> is equiv(infix:<:=>) is lvalue(1) { ... }
 proto infix:«=>» is equiv(infix:<:=>) { ... }
 
 ## loose unary

Modified: trunk/languages/perl6/src/parser/grammar.pg
==============================================================================
--- trunk/languages/perl6/src/parser/grammar.pg	(original)
+++ trunk/languages/perl6/src/parser/grammar.pg	Sun Dec  7 07:40:09 2008
@@ -842,7 +842,7 @@
 token arglist {
     [
     | <?terminator>
-    | <EXPR: 'e='>                                 # EXPR(%list_assignment)
+    | <EXPR: 'd='>                                 # EXPR(%list_assignment)
     ]
     {*}
 }



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