Skip to content
Browse files

Initial revision

git-svn-id: https://svn.parrot.org/parrot/trunk@1852 d31e2699-5ff4-0310-a27c-f18f2fbe73fe
  • Loading branch information...
1 parent 928ec7a commit 9b3438cb93460118fef0de8adb6d97fa1d6eadb1 Dan Sugalski committed Jul 17, 2002
View
24 languages/perl6/MANIFEST
@@ -0,0 +1,24 @@
+mkdistro.sh
+README
+MANIFEST
+Makefile
+t/parser/exe2.t
+t/parser/P6CTest.pm
+t/parser/exe4.t
+t/parser/exe3.t
+t/parser/README
+t/parser/basic.t
+t/parser/similar.t
+t/compiler/1.t
+t/compiler/2.t
+t/compiler/3.t
+t/compiler/4.t
+prd-perl6.pl
+P6C/Builtins.pm
+P6C/IMCC.pm
+P6C/Nodes.pm
+P6C/Tree.pm
+P6C/Util.pm
+P6C/Parser.pm
+P6C/Addcontext.pm
+P6C/Context.pm
View
21 languages/perl6/Makefile
@@ -0,0 +1,21 @@
+compile=perl prd-perl6.pl --batch --imc
+imcc=../languages/imcc/imcc
+asm=perl ../assemble.pl
+
+all:
+
+test:
+ perl t/*/*.t
+
+%.pasm: %.imc
+ $(imcc) $< $@
+
+%.imc: %.p6
+ $(compile) < $< > $@
+
+%.pbc: %.pasm
+ $(asm) $< > $@
+
+.PRECIOUS: %.imc %.pasm
+
+.PHONY: all test
View
589 languages/perl6/P6C/Addcontext.pm
@@ -0,0 +1,589 @@
+=head1 Addcontext
+
+This file contains the code to propagate context, using the following
+node functions:
+
+=over
+
+=item B<ctx_right($node, $ctx)>
+
+Called when C<$node> appears in right-hand context C<$ctx>.
+C<ctx_right> should propagate the appropriate context to child nodes.
+
+=item B<ctx_left($node, $other, $ctx)>
+
+Called when C<$node> appears as the lvalue in an expression whose
+rvalue is C<$other>, and whose context is C<$ctx>. C<$other> may be
+C<undef> if the rvalue is not known, such as when C<$node> is a member
+of a tuple to which an array is being assigned (e.g. C<($a, $node) =
+@some_things>). If C<$other> is defined, C<ctx_left> should call its
+C<ctx_right> method with the appropriate context. Otherwise, it
+should return the desired right context.
+
+=back
+
+This file also defines the contexts for built-in increment, binary,
+and unary operators, and for "magic" things like guards and C<loop>.
+
+=cut
+
+use P6C::Context;
+use P6C::Nodes;
+use P6C::Util qw(:all);
+use strict;
+
+BEGIN { # Add types for builtin binary operators.
+ # types for symmetric operators:
+ # type => [list-of-ops].
+ my %opmap =
+ ( # Ops that work differently for different scalar types:
+ PerlUndef => [ qw(| & ~ // ..),
+ # Unfortunately, these work differently on ints and nums:
+ qw(+ - * / % **)],
+
+ PerlInt => [ qw(<< >>) ],
+
+ PerlString => [ qw(_) ],
+
+ # NOTE: Actually, according to apo 3, boolean operators
+ # propagate values in their surrounding context (even though
+ # they may evaluate in boolean context?). So we can't quite
+ # do this.
+# bool => [ qw(&& ~~ ||) ],
+ );
+
+ while (my ($t, $ops) = each %opmap) {
+ my $ctx = new P6C::Context type => [$t, $t];
+ my @opnames = map { "infix $_" } @$ops;
+ @P6C::Context::CONTEXT{@opnames} = ($ctx) x @opnames;
+ }
+
+ # Ill-behaved operators.
+ $P6C::Context::CONTEXT{'infix x'} = new P6C::Context
+ type => [undef, 'PerlInt'];
+}
+
+sub P6C::Binop::ctx_left {
+ # comma expression as lvalue => tuple context. Gather types from
+ # constituent expressions, then propagate this context to the
+ # right.
+ my ($x, $other, $ctx) = @_;
+ unless ($x->op eq ',') {
+ die "Operator ".$x->op." can't appear in left context.";
+ }
+
+ # NOTE: we can't split whatever's on the other side into a tuple,
+ # so we just pass undef to subparts. Some things, like the
+ # ternary, lose at this point.
+ my @subctx = map { $_->ctx_left(undef, $ctx) } $x->flatten_leftop(',');
+ my $right_ctx = new P6C::Context type => [@subctx];
+ if (defined $other) {
+ $other->ctx_right($right_ctx);
+ } else {
+ return $right_ctx;
+ }
+}
+
+sub P6C::Binop::ctx_right {
+ my ($x, $ctx) = @_;
+ my $op = $x->op;
+ if (ref($op) && $op->isa('P6C::hype')) {
+ # XXX: do we need to propagate hyper context? This might be
+ # useful for coalescing sequences of hyper-ops. For now, just
+ # ignore it.
+ my $newctx = new P6C::Context;
+ $x->l->ctx_right($newctx);
+ $x->r->ctx_right($newctx);
+
+ } elsif ($op eq '=') {
+ # Special-case assignment operator to enforce context l -> r
+ # XXX: not sure what to do with +=, etc.
+
+ # Propagate context:
+ $x->l->ctx_left($x->r, $ctx);
+ # give incoming context to left side
+ $x->l->ctx_right($ctx);
+
+ } elsif ($op eq ',') {
+ # List of items.
+ # XXX: this is gross.
+ my @things = $x->flatten_leftop(',');
+ my $vl = P6C::ValueList->new(vals => \@things);
+ $vl->ctx_right($ctx);
+
+ } elsif (exists $P6C::Context::CONTEXT{"infix $op"}) {
+ # This operator determines context for its operands.
+ my ($ltype, $rtype) = @{$P6C::Context::CONTEXT{"infix $op"}->type};
+ my $opctx = $ctx->copy;
+ $opctx->type($ltype);
+ $x->l->ctx_right($opctx);
+ $opctx->type($rtype);
+ $x->r->ctx_right($opctx);
+
+ } else {
+ # We know nothing about the context. Say so, and propagate
+ # the surrounding context.
+ diag "No context information for `infix $op'";
+ my $opctx = new P6C::Context;
+ $x->l->ctx_right($opctx);
+ $x->r->ctx_right($opctx);
+ }
+
+ # Store away our context.
+ $x->{ctx} = $ctx->copy;
+}
+
+##############################
+sub P6C::sv_literal::ctx_right {
+ my ($x, $ctx) = @_;
+ $x->{ctx} = $ctx->copy;
+}
+
+##############################
+sub P6C::variable::ctx_right {
+ my ($x, $ctx) = @_;
+ $x->{ctx} = $ctx->copy;
+}
+
+sub P6C::variable::ctx_left {
+ # XXX: not sure what to do about left-side '*' operator, so we
+ # just ignore it.
+ my ($x, $other, $ctx) = @_;
+
+ my $newctx = new P6C::Context type => $x->type,
+ flatten => ($x->type eq 'PerlArray');
+
+ if (defined $other) {
+ $other->ctx_right($newctx);
+ } else {
+ return $newctx;
+ }
+}
+
+##############################
+sub P6C::indices::ctx_right {
+ my ($x, $ctx) = @_;
+
+# Indices take their context's arity from the outer context, but its
+# type from the index type. For example, in C<(str $a, num $b) =
+# @x[1,2]>, the outer context is C<[str, int]>, the index type is
+# C<PerlArray>, and the resulting indexing context is C<[int, int]>.
+
+# Arrays are always integer-indexed. Hashes are currently
+# string-indexed. If that changes to PMC's change this.
+ my %indextype = qw(PerlHash str
+ PerlArray int);
+ my $index_ctx;
+ if ($ctx->is_tuple) {
+
+ $index_ctx = new P6C::Context
+ type => [($indextype{$x->type}) x @{$ctx->type}];
+
+ } elsif ($ctx->is_scalar || $ctx->type eq 'void') {
+ # XXX: this causes problems with things like C<$x = @a[@i]>.
+ # I don't know what that should do.
+ $index_ctx = new P6C::Context type => [$indextype{$x->type}];
+
+ } elsif ($ctx->is_array) {
+ $index_ctx = new P6C::Context type => 'PerlArray';
+
+ } else {
+ use Data::Dumper;
+ use Carp 'confess';
+ confess "index contest: ", Dumper($ctx);
+ }
+
+ $x->indices->ctx_right($index_ctx);
+
+ # unused for now. This could be used to fix the scalar indexing
+ # problem above.
+ $x->{ctx} = $ctx->copy;
+}
+
+sub P6C::indices::ctx_left {
+ my ($x, $other, $ctx) = @_;
+
+ die "indices::ctx_left called with other" if $other;
+
+ # Now figure out context for RHS.
+ my $rctx = new P6C::Context;
+
+ if ($x->indices->isa('P6C::sv_literal')
+ || ($x->indices->isa('P6C::variable')
+ && is_scalar($x->indices->type))) {
+ # Scalar expression. Note that this misses a lot of things.
+ $rctx->type('PerlUndef');
+ $x->indices->ctx_right(new P6C::Context type => $x->type);
+
+ } elsif ($x->indices->isa('P6C::Binop') && $x->op eq ',') {
+ # tuple => propagate arity to other side.
+ my @things = $x->indices->flatten_leftop(',');
+ $rctx->type([('PerlUndef') x @things]);
+ $x->indices->ctx_right(new P6C::Context
+ type => [($x->type) x @things]);
+
+ } else {
+ # Indexing by something else => fallback to array.
+ $rctx->type('PerlArray');
+ $x->indices->ctx_right(new P6C::Context type => 'PerlArray');
+ }
+
+ return $rctx;
+}
+
+##############################
+sub P6C::subscript_exp::ctx_right {
+ my ($x, $ctx) = @_;
+ if (@{$x->subscripts} > 1) {
+ # XXX: shouldn't be too hard -- just evaluate subscripts right
+ # to left. I think all the intermediates will be indexed in
+ # scalar context, but I'm not quite sure.
+ unimp "multi-level subscripting";
+ }
+ my $index = $x->subscripts(0);
+ # The base variable is indexed as a $index->type, so give it that
+ # context.
+ $x->thing->ctx_right(new P6C::Context type => $index->type);
+
+ # Propagate context to indices as well. For the moment, they just
+ # use the index arity.
+ $index->ctx_right($ctx);
+
+ $x->{ctx} = $ctx->copy;
+}
+
+sub P6C::subscript_exp::ctx_left {
+ my ($x, $other, $ctx) = @_;
+ if (@{$x->subscripts} > 1) {
+ # XXX: shouldn't be too hard -- just evaluate subscripts
+ # recursively on temporaries. Not sure how context would work.
+ unimp "multi-level subscripting";
+ }
+ my $index = $x->subscripts(0);
+
+ # XXX: what's the context for the base variable? There should be
+ # some way to indicate that it's in lvalue context. For now,
+ # evaluate it in right context with a type corresponding to the
+ # kind of indices we're using.
+ $x->thing->ctx_right(new P6C::Context type => $index->type);
+
+
+ my $rctx = $index->ctx_left(undef, $ctx);
+
+ $x->{ctx} = $ctx;
+
+ if (defined $other) {
+ $other->ctx_right($rctx);
+ } else {
+ return $rctx;
+ }
+}
+
+##############################
+BEGIN {
+ # Context here is somewhat bogus, partly because the variable is
+ # in lvalue context, and partly because ++ and -- are overloaded
+ # like mad.
+ my $ctx = new P6C::Context type => 'PerlUndef';
+ $P6C::Context::CONTEXT{'++'}
+ = $P6C::Context::CONTEXT{'suffix ++'}
+ = $P6C::Context::CONTEXT{'--'}
+ = $P6C::Context::CONTEXT{'suffix --'}
+ = $ctx;
+}
+
+sub P6C::incr::ctx_right {
+ my ($x, $ctx) = @_;
+ if (ref($x->op)) {
+ die;
+ } else {
+ my $name = $x->post ? 'suffix '.$x->op : $x->op;
+ my $subcontext = $P6C::Context::CONTEXT{$name};
+ if ($subcontext) {
+ $x->thing->ctx_right($subcontext);
+ } else {
+ diag "No context for operator `$name'";
+ }
+ }
+ $x->{ctx} = $ctx->copy;
+}
+
+##############################
+sub ifunless_context {
+ my ($x, $ctx) = @_;
+ my $boolctx = new P6C::Context type => 'bool';
+ foreach (@{$x->args}) {
+ my ($sense, $test, $block) = @$_;
+ $sense ||= $x->name;
+ if (ref $test) {
+ $test->ctx_right($boolctx);
+ }
+ $block->ctx_right($ctx);
+ }
+}
+
+sub for_context {
+ use P6C::Util 'flatten_leftop';
+ my ($x, $ctx) = @_;
+ my ($ary, $body) = @{$x->args->vals};
+ my @streams = flatten_leftop($ary, ';');
+ my @bindings;
+ if ($body->params) {
+ @bindings = flatten_leftop($body->params, ';');
+ if (@bindings > 1 && @bindings != @streams) {
+ die <<'END';
+"for" requires equal number of bindings and streams. e.g.
+ for @a; @b -> $a, $b ; $c { ... }
+not
+ for @a -> $a, $b ; $c { ... }
+END
+
+ }
+ # XXX: what do we do to someone who does "for @xs -> () { ... }"?
+ } else {
+ push @bindings, new P6C::variable(name => '$_',
+ type => 'PerlUndef');
+ $body->params($bindings[0]);
+ }
+ my $streamctx = new P6C::Context type => 'PerlArray', flatten => 1;
+ my @stream_result;
+ for (@streams) {
+ my @things = flatten_leftop($_, ',');
+ my $l = new P6C::ValueList vals => [@things];
+ $l->ctx_right($streamctx);
+ push @stream_result, $l;
+ }
+ $x->args->vals(0, [@stream_result]);
+ # Get the body:
+ $body->ctx_right($ctx);
+}
+
+BEGIN {
+ $P6C::Context::CONTEXT{'-'} = new P6C::Context type => ['PerlUndef'];
+ $P6C::Context::CONTEXT{if}
+ = $P6C::Context::CONTEXT{unless} = \&ifunless_context;
+ $P6C::Context::CONTEXT{'for'} = \&for_context;
+ $P6C::Context::CONTEXT{while}
+ = $P6C::Context::CONTEXT{until} # = \&while_context;
+ = new P6C::Context type => ['bool', 'void'];
+ $P6C::Context::CONTEXT{print1} = new P6C::Context type => ['PerlUndef'];
+# $P6C::Context::CONTEXT{for}
+# = new P6C::Context type => ['PerlArray', 'void'];
+}
+
+# Lookup context for a prefix operator. If the sub hasn't been
+# declared yet, none will be found, so we should treat it as taking
+# C<@_>.
+sub arg_context {
+ my ($name, $ctx) = @_;
+ if (exists $P6C::Context::CONTEXT{$name}) {
+ return $P6C::Context::CONTEXT{$name};
+ }
+ diag 'no context found for ', $name;
+ return $P6C::Context::DEFAULT_ARGUMENT_CONTEXT;
+}
+
+sub P6C::prefix::ctx_right {
+ my ($x, $ctx) = @_;
+ my $proto = arg_context($x->name, $ctx);
+
+ if (ref($proto) eq 'CODE') {
+ # blech.
+ $proto->($x, $ctx);
+ } else {
+ $x->args->ctx_right($proto);
+ }
+
+ $x->{ctx} = $ctx->copy;
+}
+
+##############################
+sub P6C::compare::ctx_right {
+ my ($x, $ctx) = @_;
+ my $lasttype;
+ my $anyscalar = new P6C::Context type => 'PerlUndef';
+ my $seq = $x->seq;
+
+ # If two adjacent ops have the same type, we can be more specific
+ # about the type of the item in between. Otherwise, it's scalar.
+ # The first and last items only participate in one comparison, so
+ # we know their types. This information is not used at the
+ # moment, but it's not too hard to gather, and might be useful in
+ # the future.
+
+ for (my $i = 1; $i < $#{$seq}; $i += 2) {
+ my $op = $seq->[$i];
+ my $type = $P6C::compare::type{$op} or die "No such op: $op";
+ if ($lasttype && $lasttype ne $type) {
+ $seq->[$i - 1]->ctx_right($anyscalar);
+ } else {
+ $seq->[$i - 1]->ctx_right(new P6C::Context type => $type);
+ }
+ $lasttype = $type;
+ }
+ $seq->[-1]->ctx_right(new P6C::Context type => $lasttype);
+ $x->{ctx} = $ctx->copy;
+}
+
+##############################
+sub P6C::ternary::ctx_right {
+ my ($x, $ctx) = @_;
+ $x->if->ctx_right(new P6C::Context type => 'bool');
+ $x->then->ctx_right($ctx);
+ $x->else->ctx_right($ctx);
+ $x->{ctx} = $ctx->copy;
+}
+
+sub P6C::ternary::ctx_left {
+ my ($x, $other, $ctx) = @_;
+
+ # Evaluate test in boolean right context.
+ $x->if->ctx_right(new P6C::Context type => 'bool');
+
+ # The ternary operator can actually have different contexts on
+ # different sides. Need to duplcate $other's op-tree, then
+ # propagate context to each side. Once we have a run-time system
+ # for context, we will be able to do better.
+
+ my $thenctx = $x->then->ctx_left(undef, $ctx);
+ my $elsectx = $x->else->ctx_left(undef, $ctx);
+
+ if (!$thenctx->same($elsectx)) {
+ if (!defined $other) {
+ unimp "Assignment to ternary in too hairy a context.";
+ }
+ my $treecopy;
+ {
+ use Data::Dumper;
+ local $Data::Dumper::Purity = 1;
+ local $Data::Dumper::Terse = 1;
+ local $Data::Dumper::Deepcopy = 1;
+ $treecopy = eval Dumper($other);
+ die "Can't duplicate op-tree: $@" if $@;
+ }
+
+ $x->then->ctx_left($other, $ctx);
+ $x->{then_right} = $other;
+
+ $x->else->ctx_left($treecopy, $ctx);
+ $x->{else_right} = $treecopy;
+ } elsif (defined $other) {
+ # XXX: ctx gets propagated twice to $other, which may cause problems.
+ $x->then->ctx_left($other, $ctx);
+ $x->else->ctx_left($other, $ctx);
+ } else {
+ # No other, and we've already propagated context above.
+ return $thenctx;
+ }
+}
+
+##############################
+sub P6C::decl::ctx_right { }
+
+sub P6C::decl::ctx_left {
+ # XXX: this may not be quite right. If we're declaring a single
+ # item, we create a one-item context. If more, a tuple context.
+ # Problem is, we may have thrown away the parens around the single
+ # item by this point.
+ my ($x, $other, $ctx) = @_;
+ my @ctx = map { $_->type } @{$x->vars};
+ if (@ctx == 1) {
+ my $ctx = new P6C::Context type => $ctx[0];
+ if ($ctx[0] eq 'PerlArray') {
+ $ctx->flatten(1);
+ }
+ $other->ctx_right($ctx);
+ } else {
+ # Tuple.
+ $other->ctx_right(new P6C::Context type => \@ctx);
+ }
+}
+
+##############################
+sub P6C::sub_def::ctx_right {
+ my ($x, $ctx) = @_;
+ if ($ctx->type ne 'void') {
+ unimp 'sub def in non-void context';
+ }
+
+ my $argctx;
+ if (!defined $x->closure->params
+ || !defined $x->closure->params->max) {
+ $argctx = $P6C::Context::DEFAULT_ARGUMENT_CONTEXT;
+ } elsif ($x->closure->params->min != $x->closure->params->max) {
+ # Only support variable number of params if it's zero - Inf.
+ unimp "Unsupported parameter arity: ",
+ $x->closure->params->min . ' - ' . $x->closure->params->max;
+ } else {
+ my @types = map { $_->var->type } @{$x->closure->params->req};
+ $argctx = new P6C::Context type => [@types];
+ }
+ $P6C::Context::CONTEXT{$x->name} = $argctx;
+ $x->closure->ctx_right($ctx);
+}
+
+##############################
+sub P6C::closure::ctx_right {
+ my ($x, $ctx) = @_;
+ if ($ctx->type ne 'void') {
+ unimp 'closure in non-void context';
+ }
+
+ # NOTE: once we get return values in, we're in for serious pain
+ # here, since we have to evaluate the last statement in the
+ # _caller_'s context, which we don't know now.
+ if (defined $x->block) { # real def.
+ my $voidctx = new P6C::Context type => 'void';
+ foreach my $stmt (@{$x->block}) {
+ $stmt->ctx_right($voidctx);
+ }
+ }
+}
+
+##############################
+sub P6C::ValueList::ctx_right {
+ my ($x, $ctx) = @_;
+
+ if ($ctx->is_tuple) {
+ my $min = @{$ctx->type} < @{$x->vals} ? @{$ctx->type} : @{$x->vals};
+ for my $i (0 .. $min - 1) {
+ $x->vals($i)->ctx_right(new P6C::Context type => $ctx->type->[$i]);
+ }
+ my $voidctx = new P6C::Context type => 'void';
+ for my $i ($min .. $#{$x->vals}) {
+ $x->vals($i)->ctx_right($voidctx);
+ }
+
+ } elsif ($ctx->is_array) {
+ my $actx = new P6C::Context;
+ if ($ctx->flatten) {
+ $actx->type('PerlArray');
+ } else {
+ $actx->type('PerlUndef');
+ }
+ for (@{$x->vals}) {
+ $_->ctx_right($actx);
+ }
+
+ } elsif ($ctx->is_scalar || $ctx->type eq 'void') {
+ my $voidctx = new P6C::Context type => 'void';
+ for my $i (0 .. $#{$x->vals} - 1) {
+ $x->vals($i)->ctx_right($voidctx);
+ }
+ $x->vals->[-1]->ctx_right($ctx);
+
+ } else {
+ use Data::Dumper;
+ unimp "Unrecognized context: ".Dumper($ctx);
+ }
+ $x->{ctx} = $ctx->copy;
+}
+
+##############################
+sub P6C::guard::ctx_right {
+ my ($x, $ctx) = @_;
+ $x->test->ctx_right(new P6C::Context type => 'bool');
+ $x->expr->ctx_right(new P6C::Context type => 'void');
+}
+
+1;
View
48 languages/perl6/P6C/Builtins.pm
@@ -0,0 +1,48 @@
+package P6C::Builtins;
+
+=head1 B<P6C::Builtins>
+
+XXX: Pre-declare functions the hard way. Once IMCC supports more
+opcodes, this (and emit) will become unnecessary, as we can use a
+"header file" to declare builtins in Perl 6 syntax, and add_code to
+supply their function bodies.
+
+=cut
+
+use P6C::Context;
+use P6C::Parser;
+
+sub declare {
+ my $hash = shift;
+ $hash->{print1} = new P6C::IMCC::Sub args => [['PerlUndef', 'a']];
+
+ # XXX: might as well add ourselves to a few other things while
+ # we're at it:
+ $P6C::Context::CONTEXT{print1} = new P6C::Context type => 'PerlUndef';
+ $P6C::Parser::WANT{print1} = 'scalar_expr';
+}
+
+sub add_code {
+ my $funcs = shift;
+ # (see docs above)
+}
+
+sub emit {
+
+print <<'END';
+.emit
+
+print1:
+pushp
+restore P31
+print P31
+print "\n"
+popp
+ret
+
+.eom
+
+END
+
+}
+1;
View
162 languages/perl6/P6C/Context.pm
@@ -0,0 +1,162 @@
+package P6C::Context;
+
+=head1 B<P6C::Context>
+
+Represents a semantic context.
+
+A C<Context> object supports the following operations:
+
+=over
+
+=item B<$x = type($ctx)>
+
+=item B<type($ctx, $x)>
+
+Get or set the context type, which may be either:
+
+=over
+
+=item * a typename (e.g. PerlString or PerlArray)
+
+=item * an array of typenames representing a tuple.
+
+=item * undef, in cases where an operator is overloaded.
+
+It might be useful to allow multidimensional tuples by making the
+definition recursive, i.e. allowing the type to be an array of
+C<Context>s rather than typenames. It would also be good to get rid
+of the third by handling overloading.
+
+An item evaluate in C<PerlArray> context B<must> return an array --
+doing otherwise leads to a propagation of ugly special cases, and
+breaks flattening horribly.
+
+=back
+
+=item B<$x = flatten($ctx)>
+
+=item B<flatten($ctx, $x)>
+
+Get or set the flattening property, corresponding to the C<*> prefix
+operator. Flattening contexts are also created implicitly in a number
+of places, such as when passing parameters to a sub with no parameter
+list, and when assigning to an array.
+
+When a context is "flattening", its elements are evaluated in
+PerlArray context, and the results are concatenated. This is
+wasteful, as it builds up a temporary array for each item. It would
+be more efficient to have each element just append its results to the
+final array, but this is harder.
+
+=item B<$x = hype($ctx)>
+
+=item B<hype($ctx, $x)>
+
+Get or set hyper-operating context property, corresponding to a C<^>
+on an adjacent operator. Currently unused, as it's easier to just
+brute-force hyper-operation during code generation.
+
+=item B<nelem($ctx)>
+
+Return the number of items wanted in $ctx. For scalars, one, for
+arrays, C<undef>, for lists/tuples, the number of elements in the
+tuple.
+
+=item B<is_scalar($ctx)>
+
+=item B<is_tuple($ctx)>
+
+=item B<is_array($ctx)>
+
+True if the type($ctx) is some kind of scalar, tuple, or array.
+
+=item B<copy($ctx)>
+
+Return a copy of C<$ctx>.
+
+=item B<same($ctx, $ctx2)>
+
+Return true if C<$ctx> and C<$ctx> are "the same".
+
+=back
+
+C<P6C::Context> also defines the following variables:
+
+=over
+
+=item B<$DEFAULT_ARGUMENT_CONTEXT>
+
+Flattening array context corresponding to C<@_> arguments to subs with
+no parameter declaration.
+
+=item B<%CONTEXT>
+
+The hash C<%P6C::Context::CONTEXT> maps operator names to C<Context>s
+or, in a few messy cases, code refs. Infix and suffix operators are
+named "infix X" and "suffix X" where C<X> is the operator symbol. The
+messy cases include things like C<if>, which don't play well with our
+current notion of context. I'm not sure C<if> can ever really be
+handled in a standard way, since it takes an arbitrary number of
+parameters of particular types.
+
+=back
+
+=cut
+
+use strict;
+use P6C::Util qw(diag unimp same_type);
+use Class::Struct P6C::Context => { qw(type $ flatten $ hype $) };
+
+our %CONTEXT;
+
+our $DEFAULT_ARGUMENT_CONTEXT;
+
+BEGIN {
+ $DEFAULT_ARGUMENT_CONTEXT
+ = new P6C::Context type => 'PerlArray', flatten => 1;
+}
+
+sub nelem {
+ my $ctx = shift->type;
+ if (!ref($ctx)) {
+ return scalar_type($ctx) ? 1 : undef;
+ }
+ return @$ctx;
+}
+
+sub is_scalar {
+ my $ctx = shift;
+ my $type = $ctx->type;
+ use P6C::Util;
+ return !ref($type) && !$ctx->flatten && P6C::Util::is_scalar($type);
+}
+
+sub is_tuple {
+ my $type = shift->type;
+ return ref($type) eq 'ARRAY';
+}
+
+sub is_array {
+ my $type = shift->type;
+ return $type eq 'PerlArray';
+}
+
+sub copy {
+ my $x = shift;
+ return bless { %$x }, ref $x;
+}
+
+sub same {
+ my ($x, $y) = @_;
+ # XXX: not very good, but conservative.
+
+ # XXX: we may want another function to find the most specific
+ # supertype of $x and $y.
+ if ($x->flatten != $y->flatten
+ || $x->hype != $y->hype) {
+ return undef;
+ }
+ return same_type($x->type, $y->type);
+}
+
+1;
View
1,978 languages/perl6/P6C/IMCC.pm
1,978 additions, 0 deletions not shown because the diff is too large. Please use a local Git client to view these changes.
View
626 languages/perl6/P6C/Nodes.pm
@@ -0,0 +1,626 @@
+=head1 B<Nodes>
+
+This file declares the different node-types that occur in the parse
+tree. These types may be generated from the parser output (see
+C<Tree.pm>), or by the compiler itself during a pass.
+
+=cut
+
+=pod
+
+=over
+
+=item B<sv_literal>
+
+Represents a scalar literal value.
+
+=over
+
+=item B<type>
+
+The literal's type, either one of the scalar types, C<PerlHash> for an
+anonymous hash reference, or C<PerlArray> for an anonymous array
+reference.
+
+=item B<lval>
+
+The thing's value. This is B<not> the same as the code-generating
+C<val> method. For scalar types, C<lval> is a string; for reference
+types, a reference to the contents' parse tree.
+
+=back
+
+=item B<variable>
+
+A variable.
+
+=over
+
+=item B<type>
+
+Either one of the scalar types, C<PerlHash>, or C<PerlArray>.
+
+=item B<global>
+
+True if the variable is global (currently unimplemented).
+
+=item B<implicit>
+
+True for implicit block parameters, e.g. C<$^a>.
+
+=item B<topical>
+
+True for members of the current topic, e.g. C<$.foo>.
+
+=item B<name>
+
+The variable's name. For simple variables, this is the literal name,
+including sigil (e.g. C<$foo>). For "complicated" variables, this is
+a reference to their parse tree (currently unimplemented).
+
+=back
+
+=cut
+
+use Class::Struct P6C::sv_literal => { qw(type $ lval $) };
+use Class::Struct P6C::variable => { qw(type $
+ global $
+ implicit $
+ topical $
+ name $) };
+
+=item B<Binop>
+
+A node type representing a binary infix operation. Note that
+comparison operators are not binary, since they can be chained. Both
+comma and semicolon are binary.
+
+=over
+
+=item B<op>
+
+For simple operators, the operator name as a string. For hyper
+operators, a reference to a C<hype> node.
+
+=item B<l>, B<r>
+
+The left and right operands of the operator.
+
+=back
+
+=item B<hype>
+
+A "hyped" operator. Its single member, C<op> is the normal operator
+that has been lifted. If it turns out that other things besides
+operators can be hyped, op may refer to more complex nodes.
+
+=item B<apply_rhs>
+
+The right-hand side of an apply operation (e.g. the "foo()" in "$a.foo()").
+
+=over
+
+=item B<prop>
+
+The function- or property-name being accessed (e.g. "foo").
+
+=item B<subscripts>
+
+A reference to a list of subscripts, or an empty array if none are
+present. Subscripts may be either an C<indices> node, as for variable
+subscripts, or "something else" representing a parameter list. This
+is kind of ugly, and may change once these things actually get
+implemented.
+
+=back
+
+=cut
+
+use Class::Struct P6C::Binop => { qw(op $ l $ r $) };
+use Class::Struct P6C::hype => { qw(op $) };
+use Class::Struct P6C::apply_rhs => { qw(prop $ subscripts @) };
+
+=item B<indices>
+
+A single subscript, e.g. C<[@xs]>.
+
+=over
+
+=item B<type>
+
+The type of thing on which the subscript operates, either C<PerlHash>
+or C<PerlArray>.
+
+=item B<indices>
+
+The parse tree for the subscript contents.
+
+=back
+
+=item B<subscript_exp>
+
+An item and one or more indices.
+
+=over
+
+=item B<thing>
+
+The expression or variable to be subscripted.
+
+=item B<subscripts>
+
+A reference to an array of indices.
+
+=back
+
+=cut
+
+use Class::Struct P6C::indices => { qw(type $ indices $) };
+use Class::Struct P6C::subscript_exp => { qw(thing $ subscripts @) };
+
+=item B<incr>
+
+An increment or decrement operator.
+
+=over
+
+=item B<post>
+
+True if the operator is a postincrement.
+
+=item B<op>
+
+The operator.
+
+=item B<thing>
+
+The incremented expression.
+
+=back
+
+=item B<prefix>
+
+A prefix operator. Many things are prefix operators: filetests
+(possibly combined), declared functions, and unary C<->, C<~>, C<\\>,
+and C<!>.
+
+=over
+
+=item B<name>
+
+The operator name.
+
+=item B<args>
+
+The argument tree.
+
+=back
+
+=item B<context>
+
+A single context operator.
+
+=over
+
+=item B<ctx>
+
+The operator.
+
+=item B<thing>
+
+The operand.
+
+=back
+
+=cut
+
+use Class::Struct P6C::incr => { qw(post $ op $ thing $) };
+use Class::Struct P6C::prefix => { qw(name $ args $) };
+use Class::Struct P6C::context => { qw(ctx $ thing $) };
+
+=item B<pair>
+
+A pair (e.g. C<a =E<gt> "pair">).
+
+=over
+
+=item B<l>, B<r>
+
+The left and right operands of the pair constructor.
+
+=back
+
+=item B<compare>
+
+A comparison sequence. Its single member, C<seq>, is a reference to a
+list of operators and operands in left-to-right order. For example,
+C<1 lt 3 lt "three"> becomes C<[1, "lt", 3, "lt", "three"]>
+
+=item B<ternary>
+
+A ternary operation.
+
+=over
+
+=item B<if>
+
+The test.
+
+=item B<then>
+
+The "true" branch.
+
+=item B<else>
+
+The "false" branch.
+
+=back
+
+=cut
+
+use Class::Struct P6C::pair => { qw(l $ r $) };
+use Class::Struct P6C::compare => { qw(seq @) };
+use Class::Struct P6C::ternary => { qw(if $ then $ else $) };
+
+=item B<scope_class>
+
+Qualifiers that occur before the variables in a declaration.
+
+=over
+
+=item B<scope>
+
+The variable scope, e.g. "my", "our", "temp".
+
+=item B<class>
+
+The variable class, e.g. "int".
+
+=back
+
+=item B<decl>
+
+A declaration of one or more variables, not including initializers.
+
+=over
+
+=item B<qual>
+
+The variables' scope/class.
+
+=item B<vars>
+
+The variables' names.
+
+=item B<props>
+
+A list of properties (e.g. "is foo(42)").
+
+=back
+
+=item B<property>
+
+A single variable, class, or function property.
+
+=over
+
+=item B<name>
+
+The property name.
+
+=item B<args>
+
+The argument list (for e.g. C<something(1, 2)>).
+
+=back
+
+=cut
+
+use Class::Struct P6C::scope_class => { qw(scope $ class $) };
+use Class::Struct P6C::decl => { qw(qual $ vars @ props @) };
+use Class::Struct P6C::property => { qw(name $ args $) };
+
+=item
+
+=item B<but>
+
+A node representing a "but" clause, e.g. C<$foo = 23 but false but Inf>.
+
+=over
+
+=item B<thing>
+
+The exceptional thing.
+
+=item B<buts>
+
+A reference to an array of exception clauses.
+
+=back
+
+=item B<adverb>
+
+An adverbial modifier (i.e. ':').
+
+=over
+
+=item B<thing>
+
+The left-hand side of the colon.
+
+=item B<adv>
+
+The right-hand side.
+
+=back
+
+=cut
+
+use Class::Struct P6C::but => { qw(buts @ thing $) };
+use Class::Struct P6C::adverb => { qw(adv $ thing $) };
+
+=item B<params>
+
+A sub parameter list (not argument list).
+
+=over
+
+=item B<req>
+
+A reference to an array of required parameters, or an empty array if
+none.
+
+=item B<opt>
+
+A reference to an array of optional parameters, i.e. those occuring
+after the ';', or an empty array if none.
+
+=item B<rest>
+
+The name of the final "slurping" parameter, or C<undef> if none
+present.
+
+=back
+
+=item B<param>
+
+A subroutine parameter.
+
+=over
+
+=item B<qual>
+
+Variable scope/class.
+
+=item B<var>
+
+The variable.
+
+=item B<props>
+
+Its properties.
+
+=item B<init>
+
+An initializer expression, or C<undef> if none.
+
+=back
+
+=item B<initializer>
+
+A parameter initializer (B<not> an initializer in a variable declaration).
+
+=over
+
+=item B<op>
+
+The initializing operator, probably C<=>.
+
+=item B<expr>
+
+The initialization expression.
+
+=back
+
+=cut
+
+use Class::Struct P6C::params => { qw(req @ opt @ rest $) };
+use Class::Struct P6C::param => { qw(qual $ var $ props @ init $) };
+use Class::Struct P6C::initializer => { qw(op $ expr $) };
+
+=item B<sub_def>
+
+A subroutine definition or declaration.
+
+=over
+
+=item B<qual>
+
+Sub scope.
+
+=item B<name>
+
+=item B<props>
+
+An array of subroutine properties, or an empty array if none.
+
+=item B<closure>
+
+The closure associated with this name.
+
+=back
+
+=item B<closure>
+
+A closure, which may be either an anonymous function or the parameters
+and body of a named subroutine.
+
+=over
+
+=item B<params>
+
+The subroutine parameter list, or C<undef> if no parameter list was
+given. The appropriate implicit parameter list then depends on context.
+
+=item B<block>
+
+The sequence of statements making up the closure body. This is a
+reference to an array of statements, or a single C<yadda> node for
+C<...> definitions, or undef for a declaration.
+
+=back
+
+=item B<yadda>
+
+A node representing a C<...> statement. Its single member, C<msg>, is
+either undef or an appropriate error message to be generated if the
+statement is reached.
+
+=cut
+
+use Class::Struct P6C::sub_def => { qw(qual $ name $ props @ closure $) };
+use Class::Struct P6C::closure => { qw(params $ block $) };
+use Class::Struct P6C::yadda => { qw(msg $) }; # i.e. "..."
+
+=item B<guard>
+
+A guard (statement modifier?), e.g. the C<unless> in C<die unless $foo>.
+
+=over
+
+=item B<name>
+
+The modifier name, either "if", "unless", "while", "until", or "for".
+
+=item B<expr>
+
+=item B<test>
+
+=back
+
+=item B<directive>
+
+A "use", "package", or "module" directive
+
+=over
+
+=item B<name>
+
+The directive name (e.g. "use").
+
+=item B<thing>
+
+The directive's object (e.g. "perl" in "use perl").
+
+=item B<args>
+
+Whatever else is on the directive line.
+
+=back
+
+=item B<label>
+
+A statement label. It will appear before the labeled statement in a
+statement sequence.
+
+=item B<loop>
+
+A C<loop(;;) { ... }> statement.
+
+=over
+
+=item B<init>
+
+=item B<test>
+
+=item B<incr>
+
+The initialization, test, and increment expressions in the loop header.
+
+=item B<block>
+
+The block (sequence of statements, not closure) controlled by the
+loop.
+
+=back
+
+=cut
+
+use Class::Struct P6C::guard => { qw(name $ test $ expr $) };
+use Class::Struct P6C::directive => { qw(name $ thing $ args $) };
+use Class::Struct P6C::loop => { qw(init $ test $ incr $ block $) };
+use Class::Struct P6C::label => { qw(name $) };
+
+=item B<class_def>
+
+A class definition
+
+=over
+
+=item B<qual>
+
+Class scope.
+
+=item B<name>
+
+=item B<props>
+
+=item B<block>
+
+=back
+
+=cut
+
+use Class::Struct P6C::class_def => { qw(qual $ name $ props @ block $) };
+
+# These pseudo-types are introduced by the tree manipulation functions:
+
+=item B<P6C::ValueList>
+
+List operators and functions with named parameters currently receive
+their arguments in different formats -- the former as a tree of binary
+',' ops, the latter as an array. This is a common class to do context
+handling for both.
+
+=cut
+
+use Class::Struct P6C::ValueList => { qw(vals @) };
+
+=item B<P6C::Register>
+
+Gratuitous object? Not quite... It's a way of passing a temporary
+register in place of an unexpanded rvalue. Useful for
+e.g. autoincrement, where we have the register lying around.
+
+NOTE: this would be a good place to take care of conversions between
+register types. Right now things are always passed in P regs, but we
+could do better by passing back a wrapped S, I, or N register, which
+would be promoted if necessary. On the other hand, we might do better
+using context to do this. Hopefully all will be clear once things get
+a bit more developed.
+
+=cut
+
+use Class::Struct P6C::Register => { qw(reg $) };
+
+######################################################################
+# Misc per-node-class utility functions:
+
+sub P6C::params::min {
+ my $x = shift;
+ scalar @{$x->req};
+}
+
+sub P6C::params::max {
+ my $x = shift;
+ if ($x->rest) {
+ return undef;
+ }
+ return @{$x->req()} + @{$x->opt()};
+}
+
+sub P6C::compare::size {
+ (@{shift->seq()} - 1) / 2
+}
+
+"Yep.";
View
672 languages/perl6/P6C/Parser.pm
@@ -0,0 +1,672 @@
+package P6C::Parser;
+
+=head1 B<P6C::Parser>
+
+The parser. It provides the following methods:
+
+=over
+
+=item B<new>
+
+Create a new parser object from scratch. This is slow.
+
+=item B<Precompile($name)>
+
+Call B<Parse::RecDescent>'s B<Precompile> method to compile the
+grammar to the file $name.pm. The resulting parser can then be loaded
+as a module, and instantiated with its B<new> method. This is much
+faster than re-building the grammar.
+
+=back
+
+It's been tweaked for speed in a number of ways. First, the infix
+operators have been turned into regexes. Second, B<%item> is not
+used, and the grammar can be built without B<%item> support for more
+speed. Third, a number of logically distinct rules have been inlined,
+making the job of postprocessing the parse tree somewhat more
+involved.
+
+=cut
+
+use Parse::RecDescent;
+use strict;
+
+=head2 Internals
+
+=over
+
+=item B<%WANT>
+
+Maps function (prefix operator) names to their corresponding argument
+context rules. The entries serve the dual purpose of recognizing a
+prefix operator, and of telling the parser what to parse next.
+
+=item B<$FUNCTION_ARGS>
+
+The default argument context rule; a comma-separated list of values.
+
+=item B<%CLASSES>
+
+Has an entry for each class. This allows bare class-names to be
+recognized. The hash values are currently unimportant.
+
+=cut
+
+use vars qw(%WANT %CLASSES $FUNCTION_ARGS $grammar);
+
+%WANT = ();
+%CLASSES = ();
+
+sub Precompile {
+ shift;
+ return Parse::RecDescent->Precompile($grammar, @_);
+}
+
+sub new {
+ shift;
+ return Parse::RecDescent->new($grammar, @_);
+}
+
+=item B<add_function($function, $params, $parser)>
+
+Called in function declarations and definitions to add a function to
+the parser.
+
+=item B<add_class($class)>
+
+Add a class.
+
+=cut
+
+sub add_function {
+ my ($fname, $params, $parser) = @_;
+ # We're already deciphering the tree in Tree.pm, why not use it?
+ $fname = $fname->tree;
+ $params = P6C::Tree::maybe_tree($params);
+ if (!defined($params)) {
+ # Easy case -- no params, so we assume it's a list operator
+ $WANT{$fname} = $FUNCTION_ARGS;
+ return 1;
+ }
+ argument_context($fname, $params, $parser);
+ return 1;
+}
+
+sub add_class { # seen class.
+ my $c = shift->[1];
+ $CLASSES{$c} = $c;
+ 1;
+}
+
+##############################
+# Functions (list operators):
+
+INIT {
+$FUNCTION_ARGS = 'maybe_comma';
+
+# XXX: many of these need their own special want_* rules. This is
+# just a hack to make the parser swallow the examples from the
+# exegeses. The compiler will promptly die if you actually use any of
+# these.
+my @builtin_funcs = qw(crypt index pack rindex sprintf substr
+ join unpack split
+ push unshift splice
+ warn die print printf read select syscall sysread
+ seek sysseek syswrite truncate write
+ vec
+ chmod chown fcntl ioctl link open opendir
+ rename symlink readlink sysopen unlink system
+ return fail
+ puts
+ not);
+@WANT{@builtin_funcs} = ($FUNCTION_ARGS) x @builtin_funcs;
+
+##############################
+# Loop control
+my @loop_control = qw(redo last next continue);
+@WANT{@loop_control} = ('maybe_label') x @loop_control;
+
+##############################
+# Unary operators
+# XXX: does not handle default $_
+my @unary_ops = qw(chop chomp chr hex lc lcfirst length
+ ord reverse uc ucfirst
+ abs atan2 cos exp hex int log oct rand sin sqrt srand
+ pop shift
+ delete each exists keys values
+ defined undef
+ chdir chroot glob mkdir rmdir stat umask
+ close);
+@WANT{@unary_ops} = ('prefix') x @unary_ops;
+
+##############################
+# Control operators
+
+# XXX: as with the builtin functions above, most of these will not
+# compile, but are useful for testing the parser.
+
+my @control = qw(for foreach if given while when default sort grep map);
+@WANT{@control} = map { "want_for_$_" } @control;
+$WANT{unless} = 'want_for_if';
+$WANT{until} = 'want_for_while';
+
+##############################
+# Named blocks
+
+# XXX: Will not compile.
+my @special_blocks = qw(CATCH BEGIN END INIT AUTOLOAD
+ PRE POST NEXT LAST FIRST
+ try do);
+@WANT{@special_blocks} = ('closure') x @special_blocks;
+
+##############################
+# Classes (builtin and otherwise)
+
+# XXX: Will not compile.
+my @builtin_types = qw(int num str HASH ARRAY SCALAR Inf NaN
+ true false); # XXX: these are really constants
+@CLASSES{@builtin_types} = @builtin_types;
+
+BEGIN {
+# Handle comments:
+ $Parse::RecDescent::skip = '(\s*(#[^\n]*?(\n|\Z))?)+';
+ $::RD_AUTOACTION = q { bless [@item], 'P6C::'.$item[0] };
+}
+
+$grammar = <<'ENDSUPPORT';
+#!perl
+######################################################################
+# Support functions and variables
+{
+ use vars '$no_comma';
+ use vars qw(%KEYWORDS %CLASSES %WANT);
+ use vars qw($NAMEPART $COMPARE $CONTEXT $MULDIV $PREFIX $ADDSUB $INCR
+ $LOG_OR $LOGOR $FILETEST $ASSIGN $HYPE $MATCH $BITSHIFT
+ $SOB);
+
+# Things from P6C::* used during the parse:
+BEGIN {
+ no strict 'refs';
+ for (qw(add_class add_function CLASSES WANT)) {
+ *$_ = *{'P6C::Parser::'.$_};
+ }
+}
+
+# Regexen used in the parser:
+BEGIN {
+ $SOB = qr|$Parse::RecDescent::skip(?<![^\n\s]){|o;
+ $HYPE = qr/\^?/;
+ $NAMEPART = qr/[a-zA-Z_][\w_]*/;
+ $COMPARE = qr{cmp | eq | [gnl]e | [gl]t
+ | <=> | [<>=!]= | < | > }x;
+ $CONTEXT = qr{[\%\@\$\&*_?] | \+(?!\+)}x;
+ $MULDIV = qr{[\%*x] | /(?!/)}x;
+ $MATCH = qr{[=!]~};
+ $INCR = qr{\+\+ | --}x;
+ $PREFIX = qr{[!~\\] | -(?![->])}x;
+ $ADDSUB = qr{[-+_]};
+ $BITSHIFT = qr{<< | >>}x;
+ $LOG_OR = qr{x?or | err}x;
+ $LOGOR = qr{\|\| | ~~ | //}x;
+ $FILETEST = qr{-[rwxoRWXOezsfdlpSbctugkTBMAC]+};
+ $ASSIGN = qr{(?:
+ ! | : # != and :=
+ | //
+ | &&? | \|\|? | ~~?
+ | << | >>
+ | $ADDSUB
+ | $MULDIV
+ | \*\*
+ )? =}x;
+}
+
+# HACK to distinguish between "my ($a, $b) ..." and "foo ($a, $b)".
+# Don't need all keywords in here, but only the ones that cause
+# problems.
+BEGIN {
+ my @kw = qw(my our temp if unless until while for and or xor err);
+ @KEYWORDS{@kw} = (1) x @kw;
+}
+
+# (see Parse::RecDescent::Consumer)
+sub consumer {
+ my $t = shift;
+ my $old_len = length $t;
+ return sub {
+ my $len = length($_[0]);
+ return substr($t, 0, ($old_len - $len));
+ };
+}
+
+# Labels and statements ending in a '}' with no trailing semicolon are
+# recognized by looking backwards when we expect a statement end.
+# Entries in B<%since> are closures that make sure nothing significant
+# has been seen since they were created.
+
+my %since;
+
+sub check_end {
+ my ($type, $text) = @_;
+ if ($since{$type}) {
+ local $_ = $since{$type}->($text);
+ return m/\A$Parse::RecDescent::skip\z/o || undef;
+ }
+ return undef;
+}
+
+sub mark_end {
+ my ($type, $text) = @_;
+ $since{$type} = consumer($text);
+}
+
+}
+
+ENDSUPPORT
+
+$grammar .= <<'ENDGRAMMAR';
+##############################
+# Literals:
+
+sv_literal: /(?:\d+(?:\.\d+)?|\.\d+)(?:[Ee]-?\d+)?/
+ | '{' <commit> hv_seq '}'
+ | '[' <commit> av_seq(?) ']'
+ | <perl_quotelike>
+
+av_seq: semi /[;,]?/
+
+hv_seq: <leftop: pair ',' pair> /,?/
+
+##############################
+# Variables:
+variable: sigil <skip:''> varname
+
+sigil: /[\@\%\$\&]/
+
+varname: name
+ | /\d+/
+ | /[\!_]/
+ | '^' <commit> namepart
+ | ('*')(?) '{' <skip:'\s*'> (scalar_expr | name) '}'
+
+name: /(?:::|\.|\*)?$NAMEPART(::$NAMEPART)*/o
+
+namepart: /$NAMEPART/o
+
+maybe_namepart: namepart |
+
+##############################
+# Expressions
+
+# hype: '^' <commit> <skip:''> <matchrule:$arg[0]>
+# | <matchrule:$arg[0]>
+
+hv_indices: /[\w_]+(?=\s*})/ | comma
+
+arglist: '(' comma(?) ')'
+
+subscript: <skip:''> '{' <commit> <skip:$item[1]> hv_indices '}'
+ | <skip:''> '[' <commit> <skip:$item[1]> av_seq ']'
+ | '(' comma(?) ')'
+
+subscriptable: name <commit>
+ { exists($KEYWORDS{$item[1][1]}) ? undef : 1 }
+ arglist
+ | '.' <commit> <skip:''> namepart(?)
+ | '(' <commit> av_seq(?) ')'
+ | variable
+
+context: /$CONTEXT/o
+# context: '%' | '@' | '$' | '&' | '*' | '_' | '?'
+# | /\+(?!\+)/ # numeric context...
+
+term: '<' <commit> expr(?) '>'
+ | subscriptable <commit> subscript(s?)
+ | /$CONTEXT/o <commit> term
+ | sv_literal
+ | class
+ | closure
+
+apply_rhs: namepart <commit> subscript(s?)
+ | subscript(s)
+
+apply: <leftop: term apply_op apply_rhs>
+apply_op: /$HYPE \./xo
+
+incr: incr_op <commit> apply
+ | apply incr_op(?)
+incr_op: /$HYPE $INCR/xo
+
+pow: <leftop: incr pow_op prefix>
+pow_op: /$HYPE \*\*/ox
+
+prefix: filetest_op <commit> prefix
+ | prefix_op <commit> prefix
+ | name { $WANT{$item[1][1]} } <matchrule:$item[2]>
+ | pow
+
+# prefix_op: '!' | '~' | '\\' | /-(?![->])/
+prefix_op: /$HYPE $PREFIX/ox
+filetest_op: /$FILETEST/o
+
+pair: namepart '=>' <commit> prefix
+ | prefix '=>' prefix
+maybe_pair: namepart '=>' <commit> prefix
+ | prefix ('=>' prefix)(?)
+
+match: <leftop: maybe_pair match_op maybe_pair>
+match_op: /$HYPE $MATCH/xo
+
+muldiv: <leftop: match muldiv_op match>
+# muldiv_op: '*' | '/' | '%' | 'x'
+muldiv_op: /$HYPE $MULDIV/ox
+
+addsub: <leftop: muldiv addsub_op muldiv>
+# addsub_op: '+' | '-' | '_'
+addsub_op: /$HYPE $ADDSUB/ox
+
+bitshift: <leftop: addsub bitshift_op addsub>
+bitshift_op: /$HYPE $BITSHIFT/xo
+
+compare: <leftop: bitshift compare_op bitshift>
+compare_op: /$HYPE $COMPARE/ox
+# compare_op: '<=>' | '<=' | '==' | '>=' | '<' | '>' | '!='
+# | 'eq' | 'ge' | 'ne' | 'le' | 'lt' | 'gt' | 'cmp'
+
+bitand: <leftop: compare bitand_op compare>
+bitand_op: /$HYPE &(?!&)/ox
+
+bitor: <leftop: bitand bitor_op bitand>
+bitor_op: /$HYPE ([|~])(?!\1)/ox
+
+logand: <leftop: bitor logand_op bitor>
+logand_op: /$HYPE &&/ox
+
+logor: <leftop: logand logor_op logand>
+# logor_op: '||' | '~~' | '//'
+logor_op: /$HYPE $LOGOR/ox
+
+range: logor (range_op logor)(?)
+range_op: '..'
+
+ternary: range ('??' ternary '::' ternary)(?)
+
+scope: /my|temp|our/
+class: name { $CLASSES{$item[1][1]} }
+ { bless ['class', $item[1]], 'P6C::class' }
+
+scope_class: scope <commit> class(?)
+ | class
+
+property: name { ($item[1][1] ne $arg[0]) || undef }
+ arglist(?)
+
+and_prop: "$arg[0]" <commit> property[$arg[0]]
+ | property[$arg[0]]
+props: "$arg[0]" <commit> property[$arg[0]] and_prop[$arg[0]](s?)
+ | # nothing
+decl: '(' <commit> <leftop: variable ',' variable> ')' props['are']
+ | variable props['is']
+
+assign: assign_lhs assign_rhs(s?)
+
+assign_lhs: scope_class decl
+ | ternary
+assign_rhs: assign_op scalar_expr
+
+assign_op: /$HYPE $ASSIGN/ox
+# assign_op: /[!:]?=/ <commit>
+# | assignable_op <skip:''> '='
+# assignable_op: '//'
+# | logand_op | logor_op
+# | bitand_op | bitor_op | bitshift_op
+# | addsub_op | muldiv_op | pow_op
+
+scalar_expr: assign but(s?)
+but: 'but' assign
+
+comma: <leftop: <matchrule:@{[@arg ? $arg[0] : 'scalar_expr']}>
+ comma_op <matchrule:@{[@arg?$arg[0]:'scalar_expr']}> >
+comma_op: ','
+maybe_comma: ...!'(' comma[@{@arg ? $arg[0] : ()}]
+ | ...!'('
+
+semi: <leftop: expr semi_op expr>
+semi_op: ';'
+
+adverb: comma adv_clause(?)
+adv_clause: /:(?!:)/ comma['scalar_expr']
+
+log_AND: <leftop: adverb log_AND_op adverb>
+log_AND_op: /$HYPE and/xo
+
+log_OR: <leftop: log_AND log_OR_op log_AND>
+# log_OR_op: 'or' | 'xor' | 'err'
+log_OR_op: /$HYPE $LOG_OR/ox
+
+expr: log_OR
+
+##############################
+# Parameters
+params: <rulevar: local $no_comma>
+params: '(' <commit> { $no_comma = 1 }
+ maybe_params opt_params rest_param ')'
+ | # nothing
+
+maybe_params: _params { $no_comma = undef;
+ bless([@item[0,1]], 'P6C::maybe_params') }
+ | # nothing
+
+opt_params: ';' <commit> { $no_comma = 1 } maybe_params
+ | # nothing
+
+rest_param: { $no_comma } '*' <commit> '@' namepart
+ | ',' <commit> '*' '@' namepart
+ | # nothing
+
+_params: <leftop: param ',' param>
+param: scope_class(?) variable props['is'] initializer(?)
+initializer: assign_op scalar_expr
+
+##############################
+# Statements
+
+prog: /\A/ stmts /\z/
+ | <error>
+
+stmts: <leftop: stmt stmt_sep stmt> stmt_sep(?)
+ | # nothing
+
+stmt_sep: ';'
+ | { check_end('block', $text) }
+ | { check_end('label', $text) }
+
+stmt: label ':' { mark_end('label', $text);1 } ''
+ | directive <commit> name comma(?)
+ | 'method' <commit> name params props['is'] block
+ | 'loop' <commit>
+ '(' scalar_expr(?)
+ ';' scalar_expr(?)
+ ';' scalar_expr(?) ')'
+ block
+ | scope(?) 'sub' <commit> name params
+ { add_function(@item[4,5], $thisparser);1 }
+ props['is'] (';' | block)
+ | scope(?) 'class' <commit> name { add_class($item[4]);1 }
+ props['is'] block
+ | expr guard(?)
+
+directive: /package|module|use/
+guard: { check_end('block', $text) ? undef : 1 } _guard
+_guard: /if|unless|while|until/ <commit> scalar_expr
+ | 'for' expr
+
+maybe_label: label(?)
+label: namepart { exists($KEYWORDS{$item[1][1]}) ? undef
+ : bless(['label', $item[1]], 'P6C::label') }
+
+block: start_block '...' <commit> '}'
+ { mark_end('block', $text);1; } ''
+ | start_block stmts '}'
+ { mark_end('block', $text);1; } ''
+
+start_block: <skip:''> /$SOB/o
+
+closure: '->' '(' <commit> _closure_args(?) ')' block
+ | '->' <commit> _closure_args(?) block
+ | block
+
+_closure_args: <leftop: comma['variable'] semi_op comma['variable']>
+
+want_for_for: av_seq closure
+want_for_foreach: maybe_decl '(' expr ')' block
+want_for_given: scalar_expr closure
+want_for_while: scalar_expr closure
+want_for_when: comma closure
+want_for_default: closure
+
+want_for_if: scalar_expr closure elsif(s?) else(?)
+elsif: /els(?:if|unless)/ scalar_expr closure
+else: 'else' closure
+
+want_for_grep: scalar_expr comma
+want_for_map: scalar_expr comma
+want_for_sort: scalar_expr comma
+
+maybe_decl: scope_class <commit> variable props['is']
+ | variable <commit> props['is']
+ | # nada
+
+ENDGRAMMAR
+
+} # END INIT
+
+######################################################################
+# Context handling
+######################################################################
+
+=item B<argument_context($name, $params, $parser)>
+
+Abandon hope, all ye who enter here. Given the first part of a sub
+definition, this code adds a rule to the parser to handle its argument
+context, then creates and eval's a function to handle objects of the
+resulting type. Yes, it's ugly. No, I don't see a less ugly way to
+do it.
+
+=item B<argtype($thing)>
+
+Given a B<P6C::variable>, return the appropriate syntax rule to
+recognize an argument of that time. Currently always returns
+"scalar_expr".
+
+=item B<optional_last($n)>
+
+Create code to extract arguments from a (',' thing)(s?) element at
+position $n and flatten it.
+
+=cut
+
+sub argtype($) {
+ # Return the type of argument the parser should look for given
+ # that the function wants a particular type. For now, we're
+ # conservative and allow any scalar expression.
+ return 'scalar_expr';
+# my %things = ('PerlSub' => 'closure');
+# my $x = shift;
+# return $things{$x} || 'scalar_expr';
+}
+
+sub optional_last($) {
+ # Build code for an optional last parameter at $n.
+ my $n = shift;
+ return '
+ if (ref($x->['.$n.']) && @{$x->['.$n.']} > 0) {
+ use P6C::Util;
+ my $commatree = $x->['.$n.'][0][2]->tree;
+ push @param, flatten_leftop($commatree, ",");
+ }';
+}
+
+# Build an argument context from a parameter spec.
+sub argument_context {
+ my ($name, $params, $parser) = @_;
+ if ($params->min == 0 && !defined($params->max)) {
+ # List operator.
+ $WANT{$name} = $FUNCTION_ARGS;
+ return 1;
+ }
+ my $rule;
+ my $rulename = "want_for_$name";
+ my $lastparam = 1;
+ my $code = '
+sub P6C::'.$rulename.'::tree {
+ my $x = shift;
+ my @param;';
+
+ # add required things
+ my @req;
+ foreach (@{$params->req}) {
+ push @req, argtype($_->var->type);
+ }
+ # XXX: we require commas even around closure args for the moment.
+ $rule .= join(" ',' ", @req);
+ for (0 .. $params->min - 1) {
+ $code .= '
+ push @param, $x->['.$lastparam.']->tree;';
+ $lastparam += 2; # to skip comma
+ }
+ $lastparam -= 1; # no trailing comma.
+ # If there's a splat parameter, just slurp in everything. XXX:
+ # can probably be more intelligent with optional arguments. Not
+ # now, though.
+
+ # XXX: can this be cleaner?
+ if ($params->rest) {
+ $rule .= " (',' comma)(?)";
+ $code .= optional_last($lastparam);
+ } elsif (@{$params->opt}) {
+ # at least one optional.
+ if (@{$params->req}) {
+ # XXX: doesn't do argtypes.
+ $rule .= " (',' scalar_expr)(0..".@{$params->opt}.')';
+ $code .= optional_last($lastparam);
+ } elsif (@{$params->opt} == 1) {
+ # No required, only one optional.
+ $rule .= argtype($params->opt(0)->var->type).'(?)';
+ $code .= '
+ if (ref($x->[1]) && @{$x->[1]} > 0) {
+ push @param, $x->[1][0]->tree;
+ }';
+
+ } else {
+ # No required, multiple optional.
+ $rule .= argtype($params->opt(0)->var->type);
+ $rule .= " (',' scalar_expr)(0..".(@{$params->opt} - 1).')';
+ $rule .= '
+ | # nothing';
+ $code .= '
+ die "Internal error" unless @$x == 1 || @$x == 3;
+ if (@$x == 3) {
+ push @param, $x->[1]->tree;
+';
+ $code .= optional_last(2);
+ $code .= '
+ }';
+ }
+ }
+ $code .= '
+ return new P6C::ValueList vals => [@param];
+}
+';
+ eval $code;
+ die join("\n", 'Error creating argument context:', $@, $rule, $code)
+ if $@;
+
+ # The docs say reconfiguring a parser is expensive. However,
+ # since we're adding new rules rather than modifying existing
+ # ones, it's remarkably fast.
+
+ $parser->Replace("$rulename: $rule\n");
+ $WANT{$name} = $rulename;
+}
+
+1;
View
44 languages/perl6/P6C/TestCompiler.pm
@@ -0,0 +1,44 @@
+package P6C::TestCompiler;
+
+sub import {
+ my $pkg = caller;
+ for (qw(output_is)) {
+ no strict 'refs';
+ *{$pkg.'::'.$_} = \&$_;
+ }
+ my $class = shift;
+ eval "use Test::Simple qw(@_)";
+}
+
+sub mysystem($$) {
+ my ($cmd, $desc) = @_;
+ if (system $cmd) {
+ my ($subcmd) = split ' ', $cmd;
+ ok(0, "$desc: $subcmd: ".($? >> 8));
+ return 0;
+ }
+ return 1;
+}
+
+sub output_is {
+ my ($code, $out, $desc) = @_;
+ unless ($desc) {
+ (undef, my $file, my $line) = caller;
+ $desc = "($file line $line)";
+ }
+ open(O, "| perl prd-perl6.pl --batch --imc > a.imc 2>/dev/null") or die $!;
+ print O $code;
+ unless (close O) {
+ ok(0, "$desc: parse: $!");
+ return;
+ }
+ (mysystem("../languages/imcc/imcc a.imc a.pasm 2>/dev/null", $desc)
+ && mysystem("perl ../assemble.pl a.pasm > a.pbc", $desc)
+ && mysystem("../parrot a.pbc > a.output", $desc))
+ or return 0;
+ open(I, 'a.output');
+ my $result = join '', <I>;
+ ok($out eq $result, $desc);
+}
+
+1;
View
781 languages/perl6/P6C/Tree.pm
@@ -0,0 +1,781 @@
+package P6C::Tree;
+
+=head1 B<P6C::Tree>
+
+Post-process the parse tree into the form used by the rest of the
+compiler. This is faster than making a neat parse tree directly.
+Each parse tree node class (i.e. grammar rule) should define a C<tree>
+function that takes a raw parse tree node, and returns a processed
+one. Both of these objects are blessed into the same class (don't
+call tree on a processed node, or val on a raw one, or bad things will
+happen). See Nodes.pm for descriptions of the various nodes --
+there's mostly a one-to-one correspondence between them and the
+grammar rules, but a few of the rules that got inlined away reappear
+as node types, while some of the lower-level rules are not preserved.
+
+Remember to update the appropriate tree function here if you change
+the grammar. The functions here appear in roughly the same order as
+the grammar rules in Parser.pm.
+
+=cut
+
+use strict;
+use P6C::Nodes;
+
+######################################################################
+
+=head2 Parse tree handling utilities
+
+=over
+
+=item B<infix_right_seq($seq)>
+
+Turn the list output from a rightop directive into a binary tree in the
+proper order.
+
+=item B<infix_left_seq($seq)>
+
+Same for a leftop directive
+
+=item B<flatten_list($node)>
+
+Turn a leftop or rightop list into a list of parse tree nodes by
+calling C<tree> on each of its elements.
+
+=item B<maybe_tree($node)>
+
+Call tree on C<$node> if appropriate. Useful for handling optional
+items and rules with empty altnerations.
+
+=cut
+
+sub infix_right_seq {
+ my $x = shift;
+ if (@$x == 1) {
+ return $x->[0]->tree;
+ }
+ my $r = $x->[$#{$x}]->tree;
+ for (my $i = $#{$x} - 1; $i > 0; $i -= 2) {
+ my $op = ref($x->[$i]) ? $x->[$i]->tree : $x->[$i];
+ my $l = $x->[$i - 1]->tree;
+ $r = new P6C::Binop l => $l, r => $r, op => $op;
+ }
+ return $r;
+}
+
+sub infix_left_seq {
+ my $x = shift;
+ my @x = @$x;
+ if (@x == 1) {
+ return $x[0]->tree;
+ }
+ my $l = $x[0]->tree;
+ for (my $i = 1; $i < $#{$x}; $i += 2) {
+ my $op = ref($x[$i]) ? $x[$i]->tree : $x[$i];
+ unless (ref($x[$i + 1])) {
+ use Data::Dumper;
+ die Dumper(\@x);
+ }
+ my $r = $x[$i + 1]->tree;
+ $l = new P6C::Binop l => $l, r => $r, op => $op;
+ }
+ return $l;
+}
+
+##############################
+# Define handlers for the simple right- and left-associative operators
+# here.
+BEGIN {
+ for (qw(apply match muldiv addsub bitshift bitand
+ bitor logand logor log_AND log_OR comma semi
+ _closure_args)) {
+ no strict 'refs';
+ *{'P6C::'.$_.'::tree'} = sub {
+ my $x = shift;
+ my $ret = infix_left_seq($x->[1]);
+ return $ret;
+ };
+ }
+ for (qw(pow)) {
+ no strict 'refs';
+ *{'P6C::'.$_.'::tree'} = sub {
+ my $x = shift;
+ return infix_right_seq($x->[1]);
+ };
+ }
+}
+
+##############################
+# Things that are strings
+sub scalar_tree {
+ shift->[1];
+}
+
+for (qw(name namepart sigil scope directive)) {
+ no strict 'refs';
+ *{"P6C\::$_\::tree"} = \&scalar_tree;
+}
+
+##############################
+# Having a separate rule for hyping is too expensive.
+sub operator_tree {
+ local $_ = shift->[1];
+ if (/^\^(.+)/) {
+ return new P6C::hype op => $1;
+ }
+ return $_;
+}
+
+for (qw(apply_op incr_op pow_op prefix_op filetest_op match_op
+ muldiv_op addsub_op bitshift_op compare_op bitand_op bitor_op
+ logand_op logor_op range_op assign_op comma_op semi_op
+ log_AND_op log_OR_op)) {
+ no strict 'refs';
+ *{"P6C\::$_\::tree"} = \&operator_tree;
+}
+
+##############################
+# _simple_ optional items:
+
+sub maybe_tree {
+ my $x = shift;
+ my $t = ref($x);
+ if (!$t || @$x == 0) {
+ return undef;
+ } elsif (ref($x) eq 'ARRAY' && @$x == 1) {
+ return $x->[0]->tree;
+ } elsif (ref($x) =~ /^P6C::/) {
+ return $x->tree;
+ } else {
+ die "maybe_tree: can't handle $t ($x)";
+ }
+}
+
+sub flatten_list { # flatten a comma-list
+ my $x = shift;
+ my @x = map { $_->tree } @$x;
+ return [@x];
+}
+
+##############################
+# Control constructs:
+
+sub want_two_things {
+ my $x = shift;
+ return new P6C::ValueList vals => [$x->[1]->tree,
+ $x->[2]->tree];
+}
+
+for (qw(for given when while grep map sort)) {
+ no strict 'refs';
+ *{'P6C::want_for_'.$_.'::tree'} = \&want_two_things;
+}
+
+sub P6C::want_for_foreach::tree {
+ my $x = shift;
+ return new P6C::ValueList vals => [maybe_tree($x->[1]),
+ $x->[3]->tree,
+ $x->[5]->tree];
+}
+
+sub P6C::want_for_default::tree {
+ my $x = shift;
+ return $x->[1]->tree;
+}
+
+sub P6C::want_for_if::tree {
+ my $x = shift;
+ my @conditions = ([undef, $x->[1]->tree, $x->[2]->tree]);
+ foreach (@{$x->[3]}) {
+ push @conditions, [$_->[1], $_->[2]->tree, $_->[3]->tree];
+ }
+ if (ref($x->[4]) && @{$x->[4]} > 0) {
+ push @conditions, ['else', 1, $x->[4][0][2]->tree];
+ }
+ return [@conditions];
+}
+
+##############################
+# Literals
+sub P6C::sv_literal::tree {
+ my $x = shift;
+ my ($type, $val);
+ if ($x->[1] eq '{') {
+ $type = 'PerlHash';
+ $val = $x->[3]->tree;
+ } elsif ($x->[1] eq '[') {
+ $type = 'PerlArray';
+ if (@{$x->[3]} > 0) {
+ $val = $x->[3][0]->tree;
+ } else {
+ $val = undef;
+ }
+ } elsif (!ref($x->[1])) {
+ if ($x->[1] =~ /\./) {
+ $type = 'PerlNum';
+ } else {
+ $type = 'PerlInt';
+ }
+ $val = $x->[1];
+ } else {
+ $type = 'PerlString';
+ $val = qq{"$x->[1][2]"}; # XXX: they're all just strings.
+ }
+ return new P6C::sv_literal type => $type, lval => $val;
+}
+
+sub P6C::av_seq::tree {
+ shift->[1]->tree;
+}
+
+sub P6C::hv_seq::tree {
+ my $x = shift;
+ return [map { $_->tree } @{$x->[1]} ];
+}
+
+##############################
+# Variables
+sub varname {
+ my $x = shift;
+ if (@$x == 2) { # plain Jane or punctuation
+ if (ref $x->[1]) {
+ local $_ = $x->[1]->tree;
+ return (scalar(/^\*/), 0, scalar(/^\./), $_);
+ }
+ return (0, 0, 0, $x->[1]);
+ } elsif (@$x == 4) { # $^a and friends
+ return (0, 1, 0, $x->[3]->tree);
+ } else { # ugly.
+ return (@{$x->[1]} > 0, 0, 0, $x->[4][1]->tree);
+ }
+}
+
+sub P6C::variable::tree {
+ my %sigil_types = qw($ PerlUndef % PerlHash @ PerlArray & PerlSub);
+ my $x = shift;
+ my ($global, $implicit, $topical, $name) = varname($x->[3]);
+ unless (ref($name)) {
+ $name = $x->[1][1].$name; # tack sigil back on.
+ }
+ return P6C::variable->new(type => $sigil_types{$x->[1][1]},
+ name => $name,
+ global => $global,
+ topical => $topical,
+ implicit => $implicit);
+}
+
+######################################################################
+# Operators
+# sub P6C::hype::tree {
+# my $x = shift;
+# if (@$x == 5) {
+# return new P6C::hype op => $x->[4]->tree;
+# }
+# return $x->[1]->tree;
+# }
+
+##############################
+sub P6C::hv_indices::tree {
+ my $x = shift;
+ if (!ref($x->[1])) {
+ # stringify this.
+ return new P6C::sv_literal type => 'PerlString',
+ lval => qq{"$x->[1]"};
+ }
+ return $x->[1]->tree;
+}
+
+##############################