From 2d7691ac84611b09cb924f368918518392ffb607 Mon Sep 17 00:00:00 2001 From: Stefan O'Rear Date: Tue, 3 Aug 2010 02:37:00 -0700 Subject: [PATCH] Refactor signature handling to better support named parameters &c --- Body.pm | 2 +- CgOp.pm | 9 +++ CodeGen.pm | 15 +++-- Decl.pm | 3 + Kernel.cs | 43 ++++++++++++- Niecza/Actions.pm | 24 ++++---- RxOp.pm | 4 +- Sig.pm | 150 +++++++++++++++++++++++++++++----------------- 8 files changed, 173 insertions(+), 77 deletions(-) diff --git a/Body.pm b/Body.pm index 0b93e903..710d0192 100644 --- a/Body.pm +++ b/Body.pm @@ -69,7 +69,7 @@ use CgOp (); my ($self) = @_; my @enter; push @enter, map { $_->enter_code($self) } @{ $self->decls }; - push @enter, $self->signature->binder if $self->signature; + push @enter, $self->signature->binder($self->name) if $self->signature; # TODO: Bind a return value here to catch non-ro sub use $self->cgoptree(CgOp::prog(@enter, CgOp::return($self->do->cgop($self)))); diff --git a/CgOp.pm b/CgOp.pm index ba967bbd..deffed13 100644 --- a/CgOp.pm +++ b/CgOp.pm @@ -564,11 +564,20 @@ use warnings; zyg => [$stuff]); } + sub die { + my ($msg) = @_; + $msg = fetch(string_var($msg)) unless blessed($msg); + rawccall(rawnew('Niecza.FatalException', $msg), 'SearchForHandler'); + } + sub letn { my (@stuff) = @_; if (blessed($stuff[0])) { @stuff; } else { + if (!@stuff) { + Carp::confess "Invalid letn protocol"; + } my ($name, $value) = splice @stuff, 0, 2; CgOp::Let->new(name => $name, zyg => [ $value, letn(@stuff) ]); } diff --git a/CodeGen.pm b/CodeGen.pm index c4b9faa9..3f8c8025 100644 --- a/CodeGen.pm +++ b/CodeGen.pm @@ -59,6 +59,10 @@ use 5.010; ExecutingLine=> [m => 'Int32'], ExecutingFile=> [m => 'String'], LexicalFind => [m => 'Variable'] }, + 'Niecza.FatalException' => + { SearchForHandler => [c => 'Void'] }, + 'Niecza.LexoticControlException' => + { SearchForHandler => [c => 'Void'] }, 'Kernel.ContextHelper' => [m => 'Variable'], 'Kernel.StrP' => [f => 'IP6'], @@ -68,6 +72,8 @@ use 5.010; 'Kernel.PackageLookup' => [m => 'Variable'], 'Kernel.SlurpyHelper' => [m => 'List'], 'Kernel.Bind' => [c => 'Void'], + 'Kernel.BindNewScalar' => [c => 'Variable'], + 'Kernel.BindNewList' => [c => 'Variable'], 'Kernel.Assign' => [c => 'Void'], 'Kernel.Fetch' => [c => 'IP6'], 'Kernel.DefaultNew' => [m => 'Variable'], @@ -189,6 +195,7 @@ use 5.010; $self->lineinfo->[$n] = $line; $self->fileinfo->[$n] = $file; push @{ $self->buffer }, "case $n:\n"; + die "Broken call $expr" if !defined($rt); $self->resulttype($rt); } @@ -348,7 +355,7 @@ use 5.010; my @args = reverse map { ($self->_popn(1))[0] } (1 .. $numargs + 1); # invocant LV my ($inv) = $self->_popn(1); - $self->_cpscall(($nv ? 'Variable' : undef), + $self->_cpscall(($nv ? 'Variable' : 'Void'), "$inv.InvokeMethod(th, " . qm($name) . ", new LValue[" . scalar(@args) . "] { " . join(", ", map { "$_.lv" } @args) . " }, null)"); @@ -358,7 +365,7 @@ use 5.010; my ($self, $nv, $numargs) = @_; my @args = reverse map { ($self->_popn(1))[0] } (1 .. $numargs); my ($inv) = $self->_popn(1); - $self->_cpscall(($nv ? 'Variable' : undef), + $self->_cpscall(($nv ? 'Variable' : 'Void'), "$inv.Invoke(th, new LValue[" . scalar(@args) . "] { " . join(", ", map { "$_.lv" } @args) . " }, null)"); } @@ -476,7 +483,7 @@ use 5.010; my ($cl, $rt) = $self->_typedata('cm', $name); my @args = reverse map { ($self->_popn(1))[0] } 1 .. $nargs; if ($cl eq 'c') { - $self->_cpscall(($rt eq 'Void' ? undef : $rt), + $self->_cpscall($rt, "$name(" . join(", ", "th", @args) . ")"); } elsif ($rt ne 'Void') { $self->_push($rt, "$name(" . join(", ", @args) . ")"); @@ -491,7 +498,7 @@ use 5.010; my ($cl, $rt) = $self->_typedata('cm', $self->stacktype->[-1], $name); my ($inv) = $self->_popn(1); if ($cl eq 'c') { - $self->_cpscall(($rt eq 'Void' ? undef : $rt), + $self->_cpscall($rt, "$inv.$name(" . join(", ", "th", @args) . ")"); } elsif ($rt ne 'Void') { $self->_push($rt, "$inv.$name(" . join(", ", @args) . ")"); diff --git a/Decl.pm b/Decl.pm index c28a3f0c..ccb1a83b 100644 --- a/Decl.pm +++ b/Decl.pm @@ -93,6 +93,7 @@ use CgOp; has list => (isa => 'Bool', is => 'ro', default => 0); has shared => (isa => 'Bool', is => 'ro', default => 0); has zeroinit => (isa => 'Bool', is => 'ro', default => 0); + has noenter => (isa => 'Bool', is => 'ro', default => 0); sub used_slots { $_[0]->slot, 'Variable'; @@ -115,6 +116,8 @@ use CgOp; sub enter_code { my ($self, $body) = @_; + return CgOp::noop if $self->noenter; + ($body->mainline || $self->shared) ? CgOp::share_lex($self->slot) : CgOp::scopedlex($self->slot, $self->list ? diff --git a/Kernel.cs b/Kernel.cs index 92b98713..c8bf5992 100644 --- a/Kernel.cs +++ b/Kernel.cs @@ -380,8 +380,12 @@ public class CLRImportObject : IP6 { public class Kernel { public static DynBlockDelegate MainlineContinuation; + private static object UnboxDO(DynObject o) { + return o.slots["value"]; + } + private static Frame SCFetch(DynObject th, Frame caller) { - caller.resultSlot = th.slots["value"]; + caller.resultSlot = UnboxDO(th); return caller; } @@ -472,7 +476,7 @@ public class Kernel { public static object UnboxAny(IP6 o) { // TODO: Check for compatibility? - return ((DynObject)o).slots["value"]; + return UnboxDO((DynObject)o); } public static IP6 MakeSC(IP6 inside) { @@ -496,6 +500,41 @@ public class Kernel { } } + public static Frame BindNewScalar(Frame th, Variable rhs, bool ro, + bool forcerw) { + IP6 cont; + bool contrw; + if (rhs.lv.islist) { + cont = MakeSC(rhs.lv.container); + contrw = false; + } else { + cont = rhs.lv.container; + contrw = rhs.lv.rw; + } + th.resultSlot = new Variable(false, Variable.Context.Scalar, + new LValue(!ro && contrw, false, cont)); // TODO forcerw + return th; + } + + public static Frame BindNewList(Frame th, Variable rhs, + bool ro, bool forcerw) { + Frame n; + Variable lhs = new Variable(false, Variable.Context.List, + new LValue(true, true, null)); + th.resultSlot = lhs; + if (rhs.lv.islist) { + lhs.lv = rhs.lv; + if (ro) { lhs.lv.rw = false; } + return th; + } else { + n = new Frame(th, null, + new DynBlockDelegate(BindListizeC)); + n.lex["o"] = rhs.lv; + n.lex["c"] = lhs; + return n; + } + } + public static Frame Bind(Frame th, Variable lhs, LValue rhs, bool ro, bool forcerw) { // TODO: need exceptions for forcerw to be used diff --git a/Niecza/Actions.pm b/Niecza/Actions.pm index 46791fb5..46f7c577 100644 --- a/Niecza/Actions.pm +++ b/Niecza/Actions.pm @@ -852,7 +852,7 @@ sub variable { my ($cl, $M) = @_; sub param_sep {} -# :: Sig::Target +# :: { list : Bool, slot : Maybe[Str] } sub param_var { my ($cl, $M) = @_; if ($M->{signature}) { $M->sorry('Sub-signatures NYI'); @@ -864,8 +864,8 @@ sub param_var { my ($cl, $M) = @_; $M->sorry('Non bare scalar targets NYI'); return; } - $M->{_ast} = Sig::Target->new(list => ($sigil eq '@'), slot => - $M->{name}[0] ? ($sigil . $M->{name}[0]->Str) : undef); + $M->{_ast} = { list => ($sigil eq '@'), slot => + $M->{name}[0] ? ($sigil . $M->{name}[0]->Str) : undef }; } # :: Sig::Parameter @@ -900,8 +900,8 @@ sub parameter { my ($cl, $M) = @_; return; } - $M->{_ast} = Sig::Parameter->new(target => $M->{param_var}{_ast}, - slurpy => ($M->{quant} eq '*')); + $M->{_ast} = Sig::Parameter->new(name => $M->Str, + slurpy => ($M->{quant} eq '*'), %{ $M->{param_var}{_ast} }); } # signatures exist in several syntactic contexts so just make an object for now @@ -1497,13 +1497,13 @@ sub get_placeholder_sig { my ($cl, $M) = @_; for (@things) { if ($_ =~ /^\$_ is ref/) { push @parms, Sig::Parameter->new(optional => 1, - target => Sig::Target->new(slot => '$_')); + slot => '$_', name => '$_'); } elsif ($_ eq '*@_') { - push @parms, Sig::Parameter->new(slurpy => 1, - target => Sig::Target->new(slot => '@_', list => 1)); + push @parms, Sig::Parameter->new(slurpy => 1, slot => '@_', + list => 1, name => '*@_'); } elsif ($_ =~ /^([@\$])/) { - push @parms, Sig::Parameter->new( - target => Sig::Target->new(slot => $_), list => ($1 eq '@')); + push @parms, Sig::Parameter->new(slot => $_, name => $_, + list => ($1 eq '@')); } else { $M->sorry('Named placeholder parameters NYI'); return; @@ -1667,8 +1667,8 @@ sub comp_unit { my ($cl, $M) = @_; type => 'mainline', name => 'install', signature => Sig->new(params => [ - Sig::Parameter->new(target => Sig::Target->new( - slot => '!mainline', zeroinit => 1))]), + Sig::Parameter->new(name => '!mainline', + slot => '!mainline', zeroinit => 1)]), do => Op::CallSub->new(node($M), invocant => Op::CgOp->new(op => CgOp::newscalar( CgOp::rawsget($::SETTINGNAME . ".Installer"))), diff --git a/RxOp.pm b/RxOp.pm index 7fbf7511..e74db1a2 100644 --- a/RxOp.pm +++ b/RxOp.pm @@ -1,6 +1,7 @@ use strict; use warnings; use 5.010; +use utf8; use CgOp; @@ -16,8 +17,7 @@ use CgOp; Op::SubDef->new(var => 'rx!' . ($i++), body => Body->new( type => 'regex', - signature => Sig->new(params => [ Sig::Parameter->new( - target => Sig::Target->new(slot => '$¢'))]), + signature => Sig->simple('$¢'), do => $op)); } diff --git a/Sig.pm b/Sig.pm index ea592c1a..31417587 100644 --- a/Sig.pm +++ b/Sig.pm @@ -3,73 +3,114 @@ use warnings; use 5.010; { - package Sig::Target; + package Sig::Parameter; use Moose; has slot => (is => 'ro', isa => 'Maybe[Str]', required => 1); + has slurpy => (is => 'ro', isa => 'Bool', default => 0); + has optional => (is => 'ro', isa => 'Bool', default => 0); + has default => (is => 'ro', isa => 'Maybe[Body]', default => undef); + has positional => (is => 'ro', isa => 'Bool', default => 1); + has readonly => (is => 'ro', isa => 'Bool', default => 0); + has names => (is => 'ro', isa => 'ArrayRef[Str]', default => sub { [] }); + has name => (is => 'ro', isa => 'Str', required => 1); has list => (is => 'ro', isa => 'Bool', default => 0); has zeroinit => (is => 'ro', isa => 'Bool', default => 0); + has type => (is => 'ro', isa => 'Str', default => 'Any'); sub local_decls { - my $self = shift; - if ($self->slot) { - Decl::SimpleVar->new(slot => $self->slot, list => $self->list, - zeroinit => $self->zeroinit) + my ($self) = @_; + if (defined $self->slot) { + return (Decl::SimpleVar->new(slot => $self->slot, + list => $self->list, zeroinit => $self->zeroinit)); } else { - () + return (); } } - sub binder { - my ($self, $get) = @_; - if ($self->slot) { - # TODO: implement ro, etc - CgOp::bind(0, CgOp::scopedlex($self->slot), $get); + sub slurpy_get { + my ($self) = @_; + CgOp::let(CgOp::rawnew('DynObject', CgOp::getfield('klass', + CgOp::cast('DynObject', CgOp::fetch(CgOp::scopedlex('List'))))), sub { + my $do = shift; + CgOp::prog( + CgOp::setindex('flat', CgOp::getfield('slots', $do), + CgOp::box('Bool', CgOp::bool(1))), + CgOp::setindex('items', CgOp::getfield('slots', $do), + CgOp::box('LLArray', CgOp::rawnew('List'))), + CgOp::setindex('rest', CgOp::getfield('slots', $do), + CgOp::box('LLArray', + CgOp::rawscall('Kernel.SlurpyHelper', + CgOp::callframe, CgOp::letvar('!ix')))), + CgOp::newscalar($do))}); + } + + sub _default_get { + my ($self, $subname) = @_; + + if (defined $self->default) { + # the default code itself was generated in decls + return CgOp::prog( + CgOp::clone_lex($self->default_sym), + CgOp::subcall(CgOp::fetch( + CgOp::scopedlex($self->default_sym)))); + } elsif ($self->optional) { + if ($self->type eq 'Any') { + return CgOp::newscalar(CgOp::rawsget('Kernel.AnyP')); + } else { + return CgOp::scopedlex($self->type); + } } else { - CgOp::noop; + return CgOp::prog( + CgOp::die("No value in $subname available for parameter " . + $self->name), + CgOp::null('Variable')); } } - __PACKAGE__->meta->make_immutable; - no Moose; -} + sub _positional_get { + my ($self, $fb) = @_; + + CgOp::ternary( + CgOp::compare('>', + CgOp::getfield('Length', CgOp::getfield('pos', + CgOp::callframe)), CgOp::letvar('!ix')), + CgOp::letn('!ixp', CgOp::letvar('!ix'), + CgOp::scopedlex('!ix', CgOp::arith('+', CgOp::letvar('!ixp'), + CgOp::int(1))), + CgOp::pos(CgOp::letvar('!ixp'))), + $fb); + } -{ - package Sig::Parameter; - use Moose; + sub _named_get { + my ($self, $name, $fb) = @_; + # TODO: implement named parameters - has target => (is => 'ro', isa => 'Sig::Target', required => 1, - handles => [ 'local_decls' ]); - has slurpy => (is => 'ro', isa => 'Bool', default => 0); - has optional => (is => 'ro', isa => 'Bool', default => 0); + $fb; + } + + sub single_get { + my ($self, $subname) = @_; + + my $cg = $self->_default_get($subname); + $cg = $self->_positional_get($cg) if $self->positional; + for (reverse @{ $self->names }) { + $cg = $self->_named_get($_, $cg); + } + $cg; + } sub binder { - my ($self, $ixp) = @_; - - if ($self->slurpy) { - $self->target->binder( - CgOp::let(CgOp::rawnew('DynObject', CgOp::getfield('klass', - CgOp::cast('DynObject', CgOp::fetch(CgOp::scopedlex('List'))))), sub { - my $do = shift; - CgOp::prog( - CgOp::setindex('flat', CgOp::getfield('slots', $do), - CgOp::box('Bool', CgOp::bool(1))), - CgOp::setindex('items', CgOp::getfield('slots', $do), - CgOp::box('LLArray', CgOp::rawnew('List'))), - CgOp::setindex('rest', CgOp::getfield('slots', $do), - CgOp::box('LLArray', - CgOp::rawscall('Kernel.SlurpyHelper', - CgOp::callframe, CgOp::int($$ixp)))), - CgOp::newscalar($do))})); - } elsif ($self->optional) { - $self->target->binder(CgOp::ternary( - CgOp::compare('>', - CgOp::getfield('Length', CgOp::getfield('pos', - CgOp::callframe)), CgOp::int($$ixp)), - CgOp::pos($$ixp++), - CgOp::scopedlex('Any'))); + my ($self, $subname) = @_; + + my $get = $self->slurpy ? $self->slurpy_get : + $self->single_get($subname); + + if (defined $self->slot) { + return CgOp::bind($self->readonly, CgOp::scopedlex($self->slot), + $get); } else { - $self->target->binder(CgOp::pos($$ixp++)); + return CgOp::sink($get); } } @@ -85,15 +126,14 @@ use 5.010; sub for_method { my $self = shift; - my $sp = Sig::Parameter->new(target => - Sig::Target->new(slot => 'self')); + my $sp = Sig::Parameter->new(slot => 'self', name => 'self'); Sig->new(params => [ $sp, @{ $self->params } ]); } sub simple { my ($class, @names) = @_; - Sig->new(params => [map { Sig::Parameter->new(target => - Sig::Target->new(slot => $_)) } @names]); + Sig->new(params => [map { Sig::Parameter->new(slot => $_, name => $_) + } @names]); } sub local_decls { @@ -102,15 +142,13 @@ use 5.010; } sub binder { - my ($self) = @_; + my ($self, $subname) = @_; - # TODO: Error checking. - my $ix = 0; my @p; for (@{ $self->params }) { - push @p, $_->binder(\$ix); + push @p, $_->binder($subname); } - CgOp::prog(@p); + CgOp::letn('!ix', CgOp::int(0), CgOp::prog(@p)); } __PACKAGE__->meta->make_immutable;