From 06cf3efee0bb0804b891a19d3a5244076735f8c9 Mon Sep 17 00:00:00 2001 From: Stefan O'Rear Date: Sat, 9 Oct 2010 18:50:09 -0700 Subject: [PATCH] Add \$foo and \|$foo parameters --- lib/SAFE.setting | 26 ++++++++++++-------------- src/CgOp.pm | 1 + src/Niecza/Actions.pm | 11 +++++++---- src/Sig.pm | 23 +++++++++++++++++++---- 4 files changed, 39 insertions(+), 22 deletions(-) diff --git a/lib/SAFE.setting b/lib/SAFE.setting index 90b43637..35556388 100644 --- a/lib/SAFE.setting +++ b/lib/SAFE.setting @@ -18,14 +18,15 @@ my class Mu { } method so() { self.Bool } method not() { ! self.Bool } - method RAWCREATE is rawcall { Q:CgOp { - (letn max (poscount) + method RAWCREATE(\|$vars) { Q:CgOp { + (letn ar (unbox fvarlist (@ {$vars})) + max (fvarlist_length (l ar)) i (int 1) - obj (obj_newblank (obj_llhow (@ (pos 0)))) + obj (obj_newblank (obj_llhow (@ (fvarlist_item (i 0) (l ar))))) [whileloop 0 0 (< (l i) (l max)) (prog [setslot - (unbox str (@ (pos (l i)))) (l obj) - (nsw (@ (pos (+ (l i) (int 1)))))] + (unbox str (@ (fvarlist_item (l i) (l ar)))) (l obj) + (nsw (@ (fvarlist_item (+ (l i) (int 1)) (l ar))))] [l i (+ (l i) (int 2))])] [ns (l obj)]) } } @@ -146,15 +147,14 @@ constant True = Q:CgOp { (box Bool (bool 1)) }; constant False = Q:CgOp { (box Bool (bool 0)) }; # }}} # Fundamental scalar operators {{{ -# taking a slurpy is wrong for this due to flattening. I'm not sure what is -# right, maybe **@foo -sub infix:<~> is rawcall { Q:CgOp { +sub infix:<~>(\|$bits) { Q:CgOp { (letn buf (strbuf_new) i (int 0) - max (poscount) + ar (unbox fvarlist (@ {$bits})) + max (fvarlist_length (l ar)) [whileloop 0 0 (< (l i) (l max)) (prog [strbuf_append (l buf) - (unbox str (@ (methodcall (pos (l i)) Str)))] + (unbox str (@ (methodcall (fvarlist_item (l i) (l ar)) Str)))] [l i (+ (l i) (int 1))])] [box Str (strbuf_seal (l buf))]) } } @@ -251,9 +251,7 @@ sub infix:<~~>($t,$m) { ($m.defined) ?? ($m.ACCEPTS($t)) !! ($t.^does($m)) } # coercion makes the elements of a List read-only and maybe fetches them too. # Array: mutable list of read-write scalar boxes -sub unitem is rawcall { - Q:CgOp { (newrwlistvar (@ (pos 0))) } -} +sub unitem is rawcall { Q:CgOp { (newrwlistvar (@ (pos 0))) } } my class Iterator { # subclasses must provide .reify, return parcel @@ -290,7 +288,7 @@ my class Parcel is Cool { # Maybe this should be a constant, but constants are currently forced to # scalar-nature (TODO) -sub Nil is rawcall { Q:CgOp { (newrwlistvar (@ (box Parcel (fvarlist_new)))) } } +sub Nil() { Q:CgOp { (newrwlistvar (@ (box Parcel (fvarlist_new)))) } } my class List is Cool { has @!items; diff --git a/src/CgOp.pm b/src/CgOp.pm index 38fb95da..c7ae6874 100644 --- a/src/CgOp.pm +++ b/src/CgOp.pm @@ -175,6 +175,7 @@ use warnings; sub fvarlist_length { getfield('Length', $_[0]) } sub fvarlist_new { rawnewarr('var', @_) } + sub fvarlist_item { getindex($_[0], $_[1]) } sub vvarlist_from_fvarlist { rawnew('vvarlist', $_[0]) } sub vvarlist_new_empty { rawnew('vvarlist') } diff --git a/src/Niecza/Actions.pm b/src/Niecza/Actions.pm index fe658534..eb8c48c1 100644 --- a/src/Niecza/Actions.pm +++ b/src/Niecza/Actions.pm @@ -1611,12 +1611,13 @@ sub parameter { my ($cl, $M) = @_; my $sorry; my $slurpy; my $optional; + my $rwt; given ($M->{quant} . ':' . $M->{kind}) { when ('**:*') { $sorry = "Slice parameters NYI" } when ('*:*') { $slurpy = 1 } when ('|:*') { $sorry = "Captures NYI" } - when ('\\:!') { $sorry = "Simple parcel parameters NYI" } - when ('\\:?') { $sorry = "Simple parcel parameters NYI" } + when ('\\:!') { $rwt = 1 } + when ('\\:?') { $rwt = 1; $optional = 1 } when (':!') { } when (':*') { $optional = 1 } when (':?') { $optional = 1 } @@ -1631,7 +1632,7 @@ sub parameter { my ($cl, $M) = @_; $M->{_ast} = Sig::Parameter->new(name => $M->Str, default => $default, optional => $optional, slurpy => $slurpy, readonly => !$rw, - %{ $p->{_ast} }); + rwtrans => $rwt, %{ $p->{_ast} }); } # signatures exist in several syntactic contexts so just make an object for now @@ -1642,7 +1643,9 @@ sub signature { my ($cl, $M) = @_; } if ($M->{param_var}) { - $M->sorry('\| signatures NYI'); + $M->{_ast} = Sig->new(params => [ Sig::Parameter->new( + name => $M->{param_var}->Str, %{ $M->{param_var}{_ast} }, + full_parcel => 1) ]); return; } diff --git a/src/Sig.pm b/src/Sig.pm index 15c6be25..c96112bc 100644 --- a/src/Sig.pm +++ b/src/Sig.pm @@ -9,6 +9,9 @@ use 5.010; has slot => (is => 'ro', isa => 'Maybe[Str]', required => 1); has slurpy => (is => 'ro', isa => 'Bool', default => 0); + # rw binding to Mu that does not viv + has rwtrans => (is => 'ro', isa => 'Bool', default => 0); + has full_parcel => (is => 'ro', isa => 'Bool', default => 0); has optional => (is => 'ro', isa => 'Bool', default => 0); has default => (is => 'ro', isa => 'Maybe[Op]', default => undef); has positional => (is => 'ro', isa => 'Bool', default => 1); @@ -38,6 +41,14 @@ use 5.010; CgOp::newscalar($do))}); } + sub parcel_get { + my ($self) = @_; + CgOp::prog( + CgOp::scopedlex('!ix', CgOp::poscount), + CgOp::box('Parcel', CgOp::getfield('pos', + CgOp::callframe))); + } + sub _default_get { my ($self, $body) = @_; @@ -107,12 +118,14 @@ use 5.010; sub binder { my ($self, $body) = @_; - my $get = $self->slurpy ? $self->slurpy_get : + my $get = $self->full_parcel ? $self->parcel_get : + $self->slurpy ? $self->slurpy_get : $self->single_get($body); if (defined $self->slot) { return CgOp::scopedlex($self->slot, - CgOp::newboundvar($self->readonly, $self->list, $get)); + CgOp::newboundvar($self->readonly && !$self->rwtrans, + $self->list, $get)); } else { return CgOp::sink($get); } @@ -121,12 +134,14 @@ use 5.010; sub bind_inline { my ($self, $body, $posr) = @_; - my $get = $self->slurpy ? $self->slurpy_get_inline($posr) : + my $get = $self->full_parcel ? $self->parcel_get_inline($posr) : + $self->slurpy ? $self->slurpy_get_inline($posr) : $self->single_get_inline($body, $posr); if (defined $self->slot) { return CgOp::scopedlex($self->slot, - CgOp::newboundvar($self->readonly, $self->list, $get)); + CgOp::newboundvar($self->readonly && !$self->rwtrans, + $self->list, $get)); } else { return CgOp::sink($get); }