Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Mergeback and factor out OpHelpers/GetOptLong

  • Loading branch information...
commit a06dd3c568203740194db1dd935fd9b470e22812 1 parent 79b8cea
@sorear authored
View
6 Makefile
@@ -11,11 +11,11 @@ csbackend=CLRBackend.cs
# keep this in dependency order
libunits=SAFE CORE JSYNC
-srcunits=CClass Body Unit CgOp Op Sig RxOp NAME Stash STD NieczaGrammar \
- Metamodel OptRxSimple NAMOutput Operator NieczaActions \
+srcunits=CClass Body Unit CgOp Op OpHelpers Sig RxOp NAME Stash STD \
+ NieczaGrammar Metamodel OptRxSimple NAMOutput Operator NieczaActions \
NieczaFrontendSTD NieczaPassBegin NieczaPassBeta NieczaPassSimplifier \
NieczaPathSearch NieczaBackendNAM NieczaBackendDotnet \
- NieczaBackendClisp NieczaCompiler
+ NieczaBackendClisp NieczaCompiler GetOptLong
all: run/Niecza.exe obj/Kernel.dll obj/CLRBackend.exe
git describe --tags > VERSION
View
11 src/CgOp.pm6
@@ -98,7 +98,6 @@ method cursor_reduced ($c) { self._cgop("cursor_reduced", $c) }
method default_new (*@_) { self._cgop("default_new", @_) }
method die (*@_) { self._cgop("die", @_) }
method do_require (*@_) { self._cgop("do_require", @_) }
-method double (*@_) { self._cgop("double", @_) }
method ehspan (*@_) { self._cgop("ehspan", @_) }
method exit (*@_) { self._cgop("exit", @_) }
method fcclist_new (*@_) { self._cgop("fcclist_new", @_) }
@@ -278,6 +277,16 @@ method bif_hash($i) { self._cgop("bif_hash", $i) }
method bif_grep(*@a) { self._cgop("bif_grep", @a) }
method bif_map(*@a) { self._cgop("bif_map", @a) }
method bif_array_constructor($i) { self._cgop("bif_array_constructor", $i) }
+method callnext($cap) { self._cgop("callnext",$cap) }
+method bif_zip($fcn,$pcl) { self._cgop("bif_zip",$fcn,$pcl) }
+method bif_cross($fcn,$pcl) { self._cgop("bif_cross",$fcn,$pcl) }
+
+method double($x) {
+ # Hack - prevent JSON syntax errors
+ my $str = ~$x;
+ self._cgop('double', ($str eq 'Infinity' || $str eq 'NaN' ||
+ $str eq '-Infinity') ?? $str !! $x);
+}
sub _str($x) { ($x ~~ List) ?? $x !! CgOp.str($x) }
sub _int($x) { ($x ~~ List) ?? $x !! CgOp.int($x) }
View
91 src/GetOptLong.pm6
@@ -0,0 +1,91 @@
+# GNU getopt_long compatible options parser
+
+module GetOptLong;
+
+sub GetOptions(*@pairs, :$permute = True, :onerror($onerror_), :onarg($onarg_)) is export {
+ my @nonopt;
+ my $onerror = $onerror_ // sub ($message) {
+ note $message;
+ exit 1;
+ };
+ my $onarg = $onarg_ // sub ($arg) {
+ push @nonopt, $arg;
+ if !$permute {
+ push @nonopt, @*ARGS;
+ @*ARGS = ();
+ }
+ };
+ my @unpk;
+ sub pick_long_option($st) {
+ my @cand = grep { chars($_[0]) > 1 &&
+ substr($_[0],0,chars($st)) eq $st }, @unpk;
+ $onerror.("Ambiguous long option --$st; could be any of {map *[0], @cand}") if @cand > 1;
+ $onerror.("No match for long option --$st") if !@cand;
+ @cand[0];
+ }
+ sub pick_short_option($st) {
+ my @cand = grep { $_[0] eq $st }, @unpk;
+ $onerror.("No match for short option -$st") if !@cand;
+ @cand[0];
+ }
+ for @pairs -> $p {
+ my $key = $p.key;
+ my $type = '';
+ if $key ~~ /<[:=]>s$/ {
+ $type = ~$/;
+ $key = substr($key, 0, $/.from);
+ }
+ for $key.split('|') {
+ push @unpk, [ $_, $type, $p.value ];
+ }
+ }
+
+ while @*ARGS {
+ my $opt = shift @*ARGS;
+ if $opt eq '--' {
+ $onarg.(shift @*ARGS) while @*ARGS;
+ last;
+ }
+ elsif substr($opt, 0, 2) eq '--' {
+ if $opt ~~ /'='/ {
+ my $obl = pick_long_option(substr($opt, 2, $/.from - 2));
+ $onerror.("Long option --$obl[0] does not accept an argument")
+ if $obl[1] eq '';
+ $obl[2].(substr($opt, $/.to));
+ } else {
+ my $obl = pick_long_option(substr($opt, 2));
+ if $obl[1] eq '=s' {
+ $onerror.("Argument required for long option --$obl[0]")
+ unless @*ARGS;
+ $obl[2].(shift @*ARGS);
+ } else {
+ $obl[2].(Str);
+ }
+ }
+ }
+ elsif chars($opt) > 1 && substr($opt, 0, 1) eq '-' {
+ $opt = substr($opt, 1);
+ while $opt ne '' {
+ my $obl = pick_short_option(substr($opt, 0, 1));
+ $opt = substr($opt, 1);
+ if $obl[1] eq '' || $obl[1] eq ':s' && $opt eq '' {
+ $obl[2].(Str);
+ }
+ elsif $opt ne '' {
+ $obl[2].($opt);
+ $opt = '';
+ }
+ else {
+ $onerror.("Argument required for short option -$obl[0]")
+ unless @*ARGS;
+ $obl[2].(shift @*ARGS);
+ }
+ }
+ }
+ else {
+ $onarg.($opt);
+ }
+ }
+
+ @*ARGS = @nonopt;
+}
View
112 src/NieczaActions.pm6
@@ -9,23 +9,9 @@ use Unit;
use Sig;
use CClass;
use OptRxSimple;
+use OpHelpers;
use Operator;
-sub node($M) { { line => $M.cursor.lineof($M.to) } }
-
-sub mklet($value, $body) {
- my $var = NieczaActions.gensym;
- ::Op::Let.new(var => $var, to => $value,
- in => $body(::Op::LetVar.new(name => $var)));
-}
-
-sub mkcall($/, $name, *@positionals) {
- ::Op::CallSub.new(|node($/),
- invocant => ::Op::Lexical.new(|node($/), :$name), :@positionals);
-}
-
-sub mkbool($i) { ::Op::Lexical.new(name => $i ?? 'True' !! 'False') }
-
method get_op_sym($M) {
if $M.reduced eq '::($name)' { # XXX STD miscompilation
return ~$M;
@@ -79,6 +65,7 @@ method comment:sym<#>($ ) { }
method comment:sym<#`(...)>($ ) { }
method opener($ ) { }
method starter($ ) { }
+method keyspace($ ) { }
method spacey($ ) { }
method unspacey($ ) { }
method unsp($ ) { }
@@ -174,6 +161,7 @@ method value:quote ($/) { make $<quote>.ast }
# make ~$/ is default
method ident($ ) { }
+method label($ ) { }
method identifier($ ) { }
# Either String Op
@@ -265,6 +253,7 @@ method quote:sym<' '> ($/) { make $<nibble>.ast }
method quote:qq ($/) { make $<quibble>.ast }
method quote:q ($/) { make $<quibble>.ast }
method quote:Q ($/) { make $<quibble>.ast }
+method quote:s ($/) { make $<pat>.ast }
method transparent($/, $op, :$once = False, :$ltm, :$class = 'Sub',
:$type = 'sub', :$sig = Sig.simple) {
@@ -887,7 +876,7 @@ method escape:sym<..> ($/) { make RangeSymbol }
# XXX I probably shouldn't have used "Str" for this action method name
method Str($match?) { "NieczaActions" } #OK not used
-method process_nibble($/, @bits) {
+method process_nibble($/, @bits, $prefix?) {
my @acc;
for @bits -> $n {
my $ast = $n.ast;
@@ -897,7 +886,11 @@ method process_nibble($/, @bits) {
$ast = "";
}
- $ast = ::Op::StringLiteral.new(|node($/), text => $ast) if $ast !~~ Op;
+ if $ast !~~ Op {
+ my $str = $ast;
+ $str = $str.split(/^^<before \s>[ $prefix || \s* ]/).join("") if defined $prefix;
+ $ast = ::Op::StringLiteral.new(|node($/), text => $str);
+ }
# this *might* belong in an optimization pass
if @acc && @acc[*-1] ~~ ::Op::StringLiteral &&
@@ -909,7 +902,8 @@ method process_nibble($/, @bits) {
}
}
make do @acc == 0 ?? ::Op::StringLiteral.new(|node($/), text => "") !!
- @acc == 1 ?? @acc[0] !!
+ @acc == 1 ?? (@acc[0] ~~ ::Op::StringLiteral ?? @acc[0] !!
+ mkcall($/, '&prefix:<~>', @acc[0])) !!
mkcall($/, '&infix:<~>', @acc);
}
@@ -951,7 +945,7 @@ method process_tribble(@bits) {
$ret;
}
-method nibbler($/) {
+method nibbler($/, $prefix?) {
sub iscclass($cur) {
my $*CCSTATE = '';
my $ok = False;
@@ -971,7 +965,7 @@ method nibbler($/) {
} elsif iscclass($/.CURSOR) {
make self.process_tribble($<nibbles>);
} else {
- make self.process_nibble($/, $<nibbles>);
+ make self.process_nibble($/, $<nibbles>, $prefix);
}
}
@@ -1112,6 +1106,7 @@ my %loose2tight = (
'orelse' => '//', 'and' => '&&', 'or' => '||',
);
+method infix:sym<~~> ($/) { make ::Operator::SmartMatch.new }
method infix:sym<,>($/) { make ::Operator::Comma.new }
method infix:sym<:=>($/) { make ::Operator::Binding.new(:!readonly) }
method infix:sym<::=>($/) { make ::Operator::Binding.new(:readonly) }
@@ -1147,7 +1142,12 @@ method INFIX($/) {
make $lhs;
}
elsif $lhs.^isa(::Op::ConstantDecl) && !$lhs.init {
- $lhs.init = $rhs;
+ my $sig = substr($lhs.name, 0, 1);
+ if defined '$@&%'.index($sig) {
+ $lhs.init = self.docontext($/, $sig, $rhs)
+ } else {
+ $lhs.init = $rhs;
+ }
make $lhs;
}
}
@@ -1493,8 +1493,9 @@ method do_variable_reference($M, $v) {
}
if $tw eq '!' {
- ::Op::CallMethod.new(|node($M), name => $v<name>, private => True,
- receiver => ::Op::Lexical.new(name => 'self'), ppath => $v<rest>);
+ self.docontext($M, $v<sigil>, ::Op::CallMethod.new(|node($M),
+ name => $v<name>, private => True, receiver => mklex($M, 'self'),
+ ppath => $v<rest>));
}
elsif $tw eq '.' {
if defined $v<rest> {
@@ -1502,8 +1503,8 @@ method do_variable_reference($M, $v) {
return ::Op::StatementList.new;
}
- ::Op::CallMethod.new(|node($M), name => $v<name>,
- receiver => ::Op::Lexical.new(name => 'self'));
+ self.docontext($M, $v<sigil>, ::Op::CallMethod.new(|node($M),
+ name => $v<name>, receiver => mklex($M, 'self')));
}
# no twigil in lex name for these
elsif $tw eq '^' || $tw eq ':' {
@@ -1782,11 +1783,39 @@ method cgexp:op ($/) {
method apostrophe($/) {}
method quibble($/) {
if ($<babble><B>[0].hereinfo) {
- make ::Op::HereStub.new(node => $<babble><B>[0].hereinfo.[1]);
+ my $stub = ::Op::HereStub.new(node => Any);
+ make $stub;
+ $<babble><B>[0].hereinfo.[1][0] = sub ($delim, $lang, $/) { #OK
+ my $nws = (~$<stopper>).index($delim);
+ my $prefix = (~$<stopper>).substr(0, $nws);
+
+ self.nibbler($<nibbler>, $prefix);
+ $stub.node = $<nibbler>.ast;
+ };
} else {
make $<nibble>.ast;
}
}
+method sibble($/) {
+ my $regex = self.op_for_regex($/, $<left>.ast);
+ my $repl;
+ if $<infixish> {
+ if $<infixish> eq '=' {
+ $repl = $<right>.ast;
+ } elsif $<infixish>.ast ~~ ::Operator::CompoundAssign {
+ $repl = $<infixish>.ast.base.with_args($/,
+ mkcall($/, '&prefix:<~>', ::Op::ContextVar.new(name => '$*/')),
+ $<right>.ast);
+ } else {
+ $/.CURSOR.sorry("Unhandled operator in substitution");
+ $repl = mklex($/, 'Any');
+ }
+ } else {
+ $repl = $<right>.ast;
+ }
+ $repl = self.transparent($/, $repl);
+ make mkcall($/, '&_substitute', mklex($/, '$_'), $regex, $repl);
+}
method tribble($/) {}
method babble($/) {}
method quotepair($/) {}
@@ -1836,6 +1865,9 @@ method terminator:sym<again> ($/) {}
method terminator:sym<repeat> ($/) {}
method terminator:sym<while> ($/) {}
method terminator:sym<else> ($/) {}
+method terminator:sym<given> ($/) {}
+method terminator:sym<when> ($/) {}
+method terminator:sym« --> » ($/) {}
method terminator:sym<!!> ($/) {}
method stdstopper($/) {}
@@ -2027,8 +2059,8 @@ method args($/) {
method statement($/) {
if $<label> {
- $/.CURSOR.sorry("Labels are NYI");
- make ::Op::StatementList.new;
+ make ::Op::Labelled.new(|node($/), name => ~$<label><identifier>,
+ stmt => $<statement>.ast);
return Nil;
}
@@ -2044,6 +2076,11 @@ method statement($/) {
} elsif $sym eq 'unless' {
make ::Op::Conditional.new(|node($/), check => $exp,
false => $/.ast, true => Any);
+ } elsif $sym eq 'when' {
+ make ::Op::Conditional.new(|node($/),
+ check => ::Op::CallMethod.new(name => 'ACCEPTS',
+ receiver => $exp, positionals => [ mklex($/, '$_') ]),
+ true => $/.ast, false => Any);
} else {
$/.CURSOR.sorry("Unhandled statement modifier $sym");
make ::Op::StatementList.new;
@@ -2060,6 +2097,13 @@ method statement($/) {
} elsif $sym eq 'until' {
make ::Op::WhileLoop.new(|node($/), check => $exp,
body => $/.ast, until => True, once => False);
+ } elsif $sym eq 'given' {
+ make mktemptopic($/, $exp, $/.ast);
+ } elsif $sym eq 'for' {
+ # XXX laziness, comprehensions
+ my $var = self.gensym;
+ make ::Op::ImmedForLoop.new(|node($/), :$var, source => $exp,
+ sink => mktemptopic($/, ::Op::LetVar.new(name => $var), $/.ast));
} else {
$/.CURSOR.sorry("Unhandled statement modifier $sym");
make ::Op::StatementList.new;
@@ -2141,6 +2185,18 @@ method statement_control:for ($/) {
sink => self.block_to_closure($/, $<xblock>.ast[1]));
}
+method statement_control:given ($/) {
+ $<xblock>.ast[1].type = 'immed';
+ make ::Op::CallSub.new(|node($/), positionals => [ $<xblock>.ast[0] ],
+ invocant => self.block_to_closure($/, $<xblock>.ast[1], :once));
+}
+
+method statement_control:when ($/) {
+ $<xblock>.ast[1].type = 'cond';
+ make ::Op::When.new(|node($/), match => $<xblock>.ast[0],
+ body => self.block_to_immediate($/, 'loop', $<xblock>.ast[1]));
+}
+
method statement_control:use ($/) {
make ::Op::StatementList.new;
if $<version> {
View
7 src/NieczaPassBegin.pm6
@@ -174,6 +174,13 @@ augment class Op::CallMethod { #OK exist
}
}
+augment class Op::Labelled { #OK exist
+ method begin() {
+ @*opensubs[*-1].add_label($.name);
+ for self.zyg { $_.begin } # XXX callsame
+ }
+}
+
augment class Op::ConstantDecl { #OK exist
method begin() {
if $.path {
View
115 src/Op.pm6
@@ -21,6 +21,17 @@ method cgop($body) {
}
}
+# ick
+method cgop_labelled($body, $label) {
+ if (defined $.line) {
+ CgOp.ann("", $.line, self.code_labelled($body, $label));
+ } else {
+ self.code_labelled($body, $label);
+ }
+}
+
+method code_labelled($body, $label) { self.code($body) }
+
# A few words on the nature of bvalues
# A bvalue cannot escape a sub; the return would always extract the
# Variable. Most ops don't return bvalues, nor expect them. To avoid
@@ -131,16 +142,6 @@ class CallSub is CallLike {
}
}
-class YouAreHere is Op {
- has $.unitname; # Str
-
- method code($ ) {
- # this should be a little fancier so closure can work
- CgOp.subcall(CgOp.fetch(CgOp.context_get(CgOp.str(
- '*resume_' ~ $.unitname), CgOp.int(0))));
- }
-}
-
class CallMethod is CallLike {
has $.receiver = die "CallMethod.receiver required"; # Op
has $.name = die "CallMethod.name required"; # Op | Str
@@ -249,10 +250,7 @@ class HereStub is Op {
has $.node = die "HereStub.node required";
method zyg() {
- if defined($.node.[0]) && $.node.[0] ~~ Match {
- $.node.[0] = $.node.[0]<nibbler>.ast
- }
- $.node.[0] // die "Here document used before body defined";
+ $.node // die "Here document used before body defined";
}
method code($body) { self.zyg.cgop($body) }
@@ -364,7 +362,8 @@ class WhileLoop is Op {
method zyg() { $.check, $.body }
method ctxzyg($) { $.check, 1, $.body, 0 }
- method code($body) {
+ method code($body) { self.code_labelled($body,'') }
+ method code_labelled($body, $l) {
my $id = ::GLOBAL::NieczaActions.genid;
CgOp.prog(
@@ -374,9 +373,9 @@ class WhileLoop is Op {
CgOp.label("redo$id"),
CgOp.sink($.body.cgop($body)),
CgOp.label("next$id"),
- CgOp.ehspan(1, '', 0, "redo$id", "next$id", "next$id"),
- CgOp.ehspan(2, '', 0, "redo$id", "next$id", "last$id"),
- CgOp.ehspan(3, '', 0, "redo$id", "next$id", "redo$id"))),
+ CgOp.ehspan(1, $l, 0, "redo$id", "next$id", "next$id"),
+ CgOp.ehspan(2, $l, 0, "redo$id", "next$id", "last$id"),
+ CgOp.ehspan(3, $l, 0, "redo$id", "next$id", "redo$id"))),
CgOp.label("last$id"),
CgOp.corelex('Nil'));
}
@@ -414,7 +413,8 @@ class ImmedForLoop is Op {
method zyg() { $.source, $.sink }
method ctxzyg($) { $.source, 1, $.sink, 0 }
- method code($body) {
+ method code($body) { self.code_labelled($body, '') }
+ method code_labelled($body, $l) {
my $id = ::GLOBAL::NieczaActions.genid;
CgOp.rnull(CgOp.letn(
@@ -430,13 +430,43 @@ class ImmedForLoop is Op {
CgOp.label("redo$id"),
CgOp.sink($.sink.cgop($body)),
CgOp.label("next$id"),
- CgOp.ehspan(1, '', 0, "redo$id", "next$id", "next$id"),
- CgOp.ehspan(2, '', 0, "redo$id", "next$id", "last$id"),
- CgOp.ehspan(3, '', 0, "redo$id", "next$id", "redo$id"))),
+ CgOp.ehspan(1, $l, 0, "redo$id", "next$id", "next$id"),
+ CgOp.ehspan(2, $l, 0, "redo$id", "next$id", "last$id"),
+ CgOp.ehspan(3, $l, 0, "redo$id", "next$id", "redo$id"))),
CgOp.label("last$id")));
}
}
+class Labelled is Op {
+ has $.stmt;
+ has $.name;
+ method zyg() { $.stmt }
+
+ method code($body) {
+ CgOp.prog(CgOp.label("goto_$.name"),$.stmt.cgop_labelled($body,$.name));
+ }
+}
+
+class When is Op {
+ has $.match;
+ has $.body;
+ method zyg() { $.match, $.body }
+
+ method code($body) {
+ my $id = ::GLOBAL::NieczaActions.genid;
+
+ CgOp.ternary(CgOp.obj_getbool(CgOp.methodcall(
+ $.match.cgop($body), 'ACCEPTS', CgOp.scopedlex('$_'))),
+ CgOp.prog(
+ CgOp.ehspan(7, '', 0, "start$id", "end$id", "end$id"),
+ CgOp.span("start$id", "end$id", 0, CgOp.prog(
+ CgOp.sink($.body.cgop($body)),
+ CgOp.control(6, CgOp.null('frame'), CgOp.int(-1),
+ CgOp.null('str'), CgOp.corelex('Nil'))))),
+ CgOp.corelex('Nil'));
+ }
+}
+
# only for state $x will start and START{} in void context, yet
class Start is Op {
# possibly should use a raw boolean somehow
@@ -734,6 +764,18 @@ class RegexBody is Op {
}
}
+class YouAreHere is Op {
+ has $.unitname; # Str
+
+ method code($ ) {
+ # this should be a little fancier so closure can work
+ CgOp.subcall(CgOp.fetch(CgOp.context_get(CgOp.str(
+ '*resume_' ~ $.unitname), CgOp.int(0))));
+ }
+}
+
+
+
### BEGIN DESUGARING OPS
# These don't appear in source code, but are used by other ops to preserve
# useful structure.
@@ -795,3 +837,32 @@ class Let is Op {
$.in.cgop($body));
}
}
+
+# These two are created to codegen wrappers in NAMOutput... bad factor
+class TopicalHook is Op {
+ has $.inner;
+ method zyg() { $.inner }
+
+ method code($body) {
+ my $id = ::GLOBAL::NieczaActions.genid;
+
+ CgOp.prog(
+ CgOp.ehspan(6, '', 0, "start$id", "end$id", "end$id"),
+ CgOp.span("start$id", "end$id", 0, $.inner.cgop($body)));
+ }
+}
+
+class LabelHook is Op {
+ has $.inner;
+ has $.labels;
+ method zyg() { $.inner }
+
+ method code($body) {
+ my $id = ::GLOBAL::NieczaActions.genid;
+
+ CgOp.prog(
+ map({ CgOp.ehspan(8, $_, 0, "start$id", "end$id", "goto_$_") },
+ @$.labels),
+ CgOp.span("start$id", "end$id", 0, $.inner.cgop($body)));
+ }
+}
View
32 src/OpHelpers.pm6
@@ -0,0 +1,32 @@
+module OpHelpers;
+
+sub node($M) is export { { line => $M.cursor.lineof($M.to) } }
+
+sub mklet($value, $body) is export {
+ my $var = ::GLOBAL::NieczaActions.gensym;
+ ::Op::Let.new(var => $var, to => $value,
+ in => $body(::Op::LetVar.new(name => $var)));
+}
+
+sub mkcall($/, $name, *@positionals) is export {
+ ::Op::CallSub.new(|node($/),
+ invocant => ::Op::Lexical.new(|node($/), :$name), :@positionals);
+}
+
+sub mklex($/, $name) is export { ::Op::Lexical.new(|node($/), :$name); }
+
+sub mkbool($i) is export { ::Op::Lexical.new(name => $i ?? 'True' !! 'False') }
+
+sub mktemptopic($/, $item, $expr) is export {
+ mklet(mklex($/, '$_'), -> $old_ {
+ ::Op::StatementList.new(|node($/), children => [
+ # XXX should be a raw bind
+ ::Op::Bind.new(:!readonly, lhs => mklex($/, '$_'), rhs => $item),
+ mklet($expr, -> $result {
+ ::Op::StatementList.new(children => [
+ # XXX should be a raw bind
+ ::Op::Bind.new(:!readonly, lhs => mklex($/, '$_'),
+ rhs => $old_),
+ $result]) }) ]) });
+}
+
View
24 src/Operator.pm6
@@ -6,27 +6,13 @@ class Operator;
use Body;
use Sig;
+use OpHelpers;
has $.whatever_curry;
has $.assignish;
method with_args ($/, *@_) { !!! }
-sub node($M) { { line => $M.cursor.lineof($M.to) } }
-
-sub mklet($value, $body) {
- my $var = ::GLOBAL::NieczaActions.gensym;
- ::Op::Let.new(var => $var, to => $value,
- in => $body(::Op::LetVar.new(name => $var)));
-}
-
-sub mklex($/, $name) { ::Op::Lexical.new(|node($/), :$name); }
-
-sub mkcall($/, $name, *@positionals) {
- ::Op::CallSub.new(|node($/),
- invocant => ::Op::Lexical.new(|node($/), :$name), :@positionals);
-}
-
method as_function($/) {
$/.CURSOR.sorry("This macro cannot be used as a function");
mklex($/, '&die');
@@ -224,3 +210,11 @@ class Temp is Operator {
::Op::ContextVar.new(name => $rarg.name, uplevel => 1));
}
}
+
+class SmartMatch is Operator {
+ method as_function($/) { mklex($/, '&infix:<~~>') }
+ method with_args($/, *@args) {
+ mktemptopic($/, @args[0], ::Op::CallMethod.new(receiver => @args[1],
+ name => 'ACCEPTS', args => [ mklex($/, '$_') ]));
+ }
+}
View
16 src/STD.pm6
@@ -527,18 +527,22 @@ method heredoc () {
my $here = self;
while my $herestub = shift @herestub_queue {
my $*DELIM = $herestub.delim;
- my $lang = $herestub.lang.mixin( herestop );
- my $doc;
- if defined($doc = first /:r :lang($lang) <nibbler> <stopper>/.($here)) {
- $herestub.writeback.[0] = $doc;
+ my $lang = $herestub.lang.mixin( herestop );
+ my $doc = first /:r :lang($lang) <nibbler> <stopper>/.($here);
+
+ if defined $doc {
+ if $herestub.writeback.[0] ~~ Sub {
+ $herestub.writeback.[0].($*DELIM, $lang, $doc)
+ } else {
+ $herestub.writeback.[0] = $doc;
+ }
$here = $here.cursor($doc.to);
- # $herestub.orignode<doc> = $doc; NIECZA immutable matches
}
else {
self.panic("Ending delimiter $*DELIM not found");
}
}
- return self.cursor($here.pos); # return to initial type
+ $here;
}
method hereinfo () { [] }
View
548 src/niecza
@@ -16,553 +16,7 @@ use NieczaCompiler;
use MONKEY_TYPING;
-use NieczaActions;
-use Operator;
-use CgOp;
-use STD;
-use CClass;
-
-augment class STD {
-our @herestub_queue;
-method heredoc () {
- my $here = self;
- while my $herestub = shift @herestub_queue {
- my $*DELIM = $herestub.delim;
- my $lang = $herestub.lang.mixin( ::STD::herestop );
- my $doc = first /:r :lang($lang) <nibbler> <stopper>/.($here);
-
- if defined $doc {
- if $herestub.writeback.[0] ~~ Sub {
- $herestub.writeback.[0].($*DELIM, $lang, $doc)
- } else {
- $herestub.writeback.[0] = $doc;
- }
- $here = $here.cursor($doc.to);
- }
- else {
- self.panic("Ending delimiter $*DELIM not found");
- }
- }
- $here;
-}
-}
-
-sub node($M) { { line => $M.cursor.lineof($M.to) } }
-
-sub mklet($value, $body) {
- my $var = ::GLOBAL::NieczaActions.gensym;
- ::Op::Let.new(var => $var, to => $value,
- in => $body(::Op::LetVar.new(name => $var)));
-}
-
-sub mklex($/, $name) { ::Op::Lexical.new(|node($/), :$name); }
-
-sub mkcall($/, $name, *@positionals) {
- ::Op::CallSub.new(|node($/),
- invocant => ::Op::Lexical.new(|node($/), :$name), :@positionals);
-}
-
-sub mktemptopic($/, $item, $expr) {
- mklet(mklex($/, '$_'), -> $old_ {
- ::Op::StatementList.new(|node($/), children => [
- # XXX should be a raw bind
- ::Op::Bind.new(:!readonly, lhs => mklex($/, '$_'), rhs => $item),
- mklet($expr, -> $result {
- ::Op::StatementList.new(children => [
- # XXX should be a raw bind
- ::Op::Bind.new(:!readonly, lhs => mklex($/, '$_'),
- rhs => $old_),
- $result]) }) ]) });
-}
-
-augment class NieczaActions {
-method do_variable_reference($M, $v) {
- if $v<term> {
- return $v<term>;
- }
-
- my $tw = $v<twigil>;
- my $sl = $v<sigil> ~ $tw ~ $v<name>;
-
- if defined($v<rest>) && $tw ~~ /<[*=~?^:]>/ {
- $M.CURSOR.sorry("Twigil $tw cannot be used with qualified names");
- return ::Op::StatementList.new;
- }
-
- if $tw eq '!' {
- self.docontext($M, $v<sigil>, ::Op::CallMethod.new(|node($M),
- name => $v<name>, private => True, receiver => mklex($M, 'self'),
- ppath => $v<rest>));
- }
- elsif $tw eq '.' {
- if defined $v<rest> {
- $M.CURSOR.sorry('$.Foo::bar syntax NYI');
- return ::Op::StatementList.new;
- }
-
- self.docontext($M, $v<sigil>, ::Op::CallMethod.new(|node($M),
- name => $v<name>, receiver => mklex($M, 'self')));
- }
- # no twigil in lex name for these
- elsif $tw eq '^' || $tw eq ':' {
- ::Op::Lexical.new(|node($M), name => $v<sigil> ~ $v<name>);
- }
- elsif $tw eq '*' {
- ::Op::ContextVar.new(|node($M), name => $sl);
- }
- elsif $tw eq '' || $tw eq '?' {
- if defined($v<rest>) {
- ::Op::PackageVar.new(path => $v<rest>, name => $sl,
- slot => self.gensym, |node($M));
- } else {
- ::Op::Lexical.new(|node($M), name => $sl);
- }
- }
- else {
- $M.CURSOR.sorry("Unhandled reference twigil $tw");
- }
-}
-method INFIX($/) {
- my $fn = $<infix>.ast;
- my ($st,$lhs,$rhs) = self.whatever_precheck($fn, $<left>.ast, $<right>.ast);
-
- make $fn.with_args($/, $lhs, $rhs);
-
- if $fn.assignish {
- # Assignments to has and state declarators are rewritten into
- # an appropriate phaser
- if $lhs.^isa(::Op::Lexical) && $lhs.state_decl {
- my $cv = self.gensym;
- make ::Op::StatementList.new(|node($/), children => [
- ::Op::Start.new(condvar => $cv, body => $/.ast),
- ::Op::Lexical.new(name => $lhs.name)]);
- }
- elsif $lhs.^isa(::Op::Attribute) && !$lhs.initializer {
- $lhs.initializer = self.sl_to_block('bare', $rhs,
- subname => $lhs.name ~ " init");
- make $lhs;
- }
- elsif $lhs.^isa(::Op::ConstantDecl) && !$lhs.init {
- my $sig = substr($lhs.name, 0, 1);
- if defined '$@&%'.index($sig) {
- $lhs.init = self.docontext($/, $sig, $rhs)
- } else {
- $lhs.init = $rhs;
- }
- make $lhs;
- }
- }
- make self.whatever_postcheck($/, $st, $/.ast);
-}
-
-method quibble($/) {
- if ($<babble><B>[0].hereinfo) {
- my $stub = ::Op::HereStub.new(node => Any);
- make $stub;
- $<babble><B>[0].hereinfo.[1][0] = sub ($delim, $lang, $/) { #OK
- my $nws = (~$<stopper>).index($delim);
- my $prefix = (~$<stopper>).substr(0, $nws);
-
- self.nibbler($<nibbler>, $prefix);
- $stub.node = $<nibbler>.ast;
- };
- } else {
- make $<nibble>.ast;
- }
-}
-
-method nibbler($/, $prefix?) {
- sub iscclass($cur) {
- my $*CCSTATE = '';
- my $ok = False;
- # XXX XXX
- try { $cur.ccstate(".."); $ok = True };
- $ok
- }
- if $/.CURSOR.^isa(::STD::Regex) {
- make $<EXPR>.ast;
- } elsif $/.CURSOR.^isa(::NieczaGrammar::CgOp) {
- if $*SAFEMODE {
- $/.CURSOR.sorry('Q:CgOp not allowed in safe mode');
- make ::Op::StatementList.new;
- return Nil;
- }
- make ::Op::CgOp.new(|node($/), optree => $<cgexp>.ast);
- } elsif iscclass($/.CURSOR) {
- make self.process_tribble($<nibbles>);
- } else {
- make self.process_nibble($/, $<nibbles>, $prefix);
- }
-}
-
-method process_nibble($/, @bits, $prefix?) {
- my @acc;
- for @bits -> $n {
- my $ast = $n.ast;
-
- if $ast ~~ CClass {
- $n.CURSOR.sorry("Cannot use a character class in a string");
- $ast = "";
- }
-
- if $ast !~~ Op {
- my $str = $ast;
- $str = $str.split(/^^<before \s>[ $prefix || \s* ]/).join("") if defined $prefix;
- $ast = ::Op::StringLiteral.new(|node($/), text => $str);
- }
-
- # this *might* belong in an optimization pass
- if @acc && @acc[*-1] ~~ ::Op::StringLiteral &&
- $ast ~~ ::Op::StringLiteral {
- @acc[*-1] = ::Op::StringLiteral.new(|node($/),
- text => (@acc[*-1].text ~ $ast.text));
- } else {
- push @acc, $ast;
- }
- }
- make do @acc == 0 ?? ::Op::StringLiteral.new(|node($/), text => "") !!
- @acc == 1 ?? (@acc[0] ~~ ::Op::StringLiteral ?? @acc[0] !!
- mkcall($/, '&prefix:<~>', @acc[0])) !!
- mkcall($/, '&infix:<~>', @acc);
-}
-
-method keyspace($/) { }
-method terminator:sym<given> ($/) {}
-method terminator:sym<when> ($/) {}
-method terminator:sym« --> » ($/) {}
-
-method infix:sym<~~> ($/) { make ::Operator::SmartMatch.new }
-
-method sibble($/) {
- my $regex = self.op_for_regex($/, $<left>.ast);
- my $repl;
- if $<infixish> {
- if $<infixish> eq '=' {
- $repl = $<right>.ast;
- } elsif $<infixish>.ast ~~ ::Operator::CompoundAssign {
- $repl = $<infixish>.ast.base.with_args($/,
- mkcall($/, '&prefix:<~>', ::Op::ContextVar.new(name => '$*/')),
- $<right>.ast);
- } else {
- $/.CURSOR.sorry("Unhandled operator in substitution");
- $repl = mklex($/, 'Any');
- }
- } else {
- $repl = $<right>.ast;
- }
- $repl = self.transparent($/, $repl);
- make mkcall($/, '&_substitute', mklex($/, '$_'), $regex, $repl);
-}
-
-method quote:s ($/) { make $<pat>.ast }
-
-method statement_control:given ($/) {
- $<xblock>.ast[1].type = 'immed';
- make ::Op::CallSub.new(|node($/), positionals => [ $<xblock>.ast[0] ],
- invocant => self.block_to_closure($/, $<xblock>.ast[1], :once));
-}
-
-method statement_control:when ($/) {
- $<xblock>.ast[1].type = 'cond';
- make ::Op::When.new(|node($/), match => $<xblock>.ast[0],
- body => self.block_to_immediate($/, 'loop', $<xblock>.ast[1]));
-}
-
-method label($/) { }
-method statement($/) {
- if $<label> {
- make ::Op::Labelled.new(|node($/), name => ~$<label><identifier>,
- stmt => $<statement>.ast);
- return Nil;
- }
-
- make ($<statement_control> ?? $<statement_control>.ast !!
- $<EXPR> ?? $<EXPR>.ast !! ::Op::StatementList.new);
-
- if $<statement_mod_cond> {
- my ($sym, $exp) = @( $<statement_mod_cond>[0].ast );
-
- if $sym eq 'if' {
- make ::Op::Conditional.new(|node($/), check => $exp,
- true => $/.ast, false => Any);
- } elsif $sym eq 'unless' {
- make ::Op::Conditional.new(|node($/), check => $exp,
- false => $/.ast, true => Any);
- } elsif $sym eq 'when' {
- make ::Op::Conditional.new(|node($/),
- check => ::Op::CallMethod.new(name => 'ACCEPTS',
- receiver => $exp, positionals => [ mklex($/, '$_') ]),
- true => $/.ast, false => Any);
- } else {
- $/.CURSOR.sorry("Unhandled statement modifier $sym");
- make ::Op::StatementList.new;
- return Nil;
- }
- }
-
- if $<statement_mod_loop> {
- my ($sym, $exp) = @( $<statement_mod_loop>[0].ast );
-
- if $sym eq 'while' {
- make ::Op::WhileLoop.new(|node($/), check => $exp,
- body => $/.ast, until => False, once => False);
- } elsif $sym eq 'until' {
- make ::Op::WhileLoop.new(|node($/), check => $exp,
- body => $/.ast, until => True, once => False);
- } elsif $sym eq 'given' {
- make mktemptopic($/, $exp, $/.ast);
- } elsif $sym eq 'for' {
- # XXX laziness, comprehensions
- my $var = self.gensym;
- make ::Op::ImmedForLoop.new(|node($/), :$var, source => $exp,
- sink => mktemptopic($/, ::Op::LetVar.new(name => $var), $/.ast));
- } else {
- $/.CURSOR.sorry("Unhandled statement modifier $sym");
- make ::Op::StatementList.new;
- return Nil;
- }
- }
-}
-}
-
-augment class Op {
-method cgop_labelled($body, $label) {
- if (defined $.line) {
- CgOp.ann("", $.line, self.code_labelled($body, $label));
- } else {
- self.code_labelled($body, $label);
- }
-}
-
-method code_labelled($body, $label) { self.code($body) }
-
-class When is Op {
- has $.match;
- has $.body;
- method zyg() { $.match, $.body }
-
- method code($body) {
- my $id = ::GLOBAL::NieczaActions.genid;
-
- CgOp.ternary(CgOp.obj_getbool(CgOp.methodcall(
- $.match.cgop($body), 'ACCEPTS', CgOp.scopedlex('$_'))),
- CgOp.prog(
- CgOp.ehspan(7, '', 0, "start$id", "end$id", "end$id"),
- CgOp.span("start$id", "end$id", 0, CgOp.prog(
- CgOp.sink($.body.cgop($body)),
- CgOp.control(6, CgOp.null('frame'), CgOp.int(-1),
- CgOp.null('str'), CgOp.corelex('Nil'))))),
- CgOp.corelex('Nil'));
- }
-}
-
-# These two are created to codegen wrappers in NAMOutput... bad factor
-class TopicalHook is Op {
- has $.inner;
- method zyg() { $.inner }
-
- method code($body) {
- my $id = ::GLOBAL::NieczaActions.genid;
-
- CgOp.prog(
- CgOp.ehspan(6, '', 0, "start$id", "end$id", "end$id"),
- CgOp.span("start$id", "end$id", 0, $.inner.cgop($body)));
- }
-}
-
-class LabelHook is Op {
- has $.inner;
- has $.labels;
- method zyg() { $.inner }
-
- method code($body) {
- my $id = ::GLOBAL::NieczaActions.genid;
-
- CgOp.prog(
- map({ CgOp.ehspan(8, $_, 0, "start$id", "end$id", "goto_$_") },
- @$.labels),
- CgOp.span("start$id", "end$id", 0, $.inner.cgop($body)));
- }
-}
-
-class Labelled is Op {
- has $.stmt;
- has $.name;
- method zyg() { $.stmt }
-
- method code($body) {
- CgOp.prog(CgOp.label("goto_$.name"),$.stmt.cgop_labelled($body,$.name));
- }
-}
-}
-
-augment class CgOp { #OK exist
- method callnext($cap) { self._cgop("callnext",$cap) }
- method bif_zip($fcn,$pcl) { self._cgop("bif_zip",$fcn,$pcl) }
- method bif_cross($fcn,$pcl) { self._cgop("bif_cross",$fcn,$pcl) }
- method double($x) {
- # Hack - prevent JSON syntax errors
- my $str = ~$x;
- ($str eq 'Infinity' || $str eq 'NaN' || $str eq '-Infinity') ??
- CgOp._cgop('double', $str) !! CgOp._cgop('double', $x);
- }
-}
-
-augment class Op::HereStub { #OK exist
- method zyg() {
- $.node // die "Here document used before body defined";
- }
-}
-
-augment class Op::WhileLoop { #OK exist
- method code($body) { self.code_labelled($body,'') }
- method code_labelled($body, $l) {
- my $id = ::GLOBAL::NieczaActions.genid;
-
- CgOp.prog(
- CgOp.whileloop(+$.until, +$.once,
- CgOp.obj_getbool($.check.cgop($body)),
- CgOp.prog(
- CgOp.label("redo$id"),
- CgOp.sink($.body.cgop($body)),
- CgOp.label("next$id"),
- CgOp.ehspan(1, $l, 0, "redo$id", "next$id", "next$id"),
- CgOp.ehspan(2, $l, 0, "redo$id", "next$id", "last$id"),
- CgOp.ehspan(3, $l, 0, "redo$id", "next$id", "redo$id"))),
- CgOp.label("last$id"),
- CgOp.corelex('Nil'));
- }
-}
-
-augment class Op::ImmedForLoop { #OK exist
- method code($body) { self.code_labelled($body, '') }
- method code_labelled($body, $l) {
- my $id = ::GLOBAL::NieczaActions.genid;
-
- CgOp.rnull(CgOp.letn(
- "!iter$id", CgOp.vvarlist_new_empty,
- $.var, CgOp.null('var'),
- CgOp.vvarlist_push(CgOp.letvar("!iter$id"),
- $.source.cgop($body)),
- CgOp.whileloop(0, 0,
- CgOp.iter_hasflat(CgOp.letvar("!iter$id")),
- CgOp.prog(
- CgOp.letvar($.var,
- CgOp.vvarlist_shift(CgOp.letvar("!iter$id"))),
- CgOp.label("redo$id"),
- CgOp.sink($.sink.cgop($body)),
- CgOp.label("next$id"),
- CgOp.ehspan(1, $l, 0, "redo$id", "next$id", "next$id"),
- CgOp.ehspan(2, $l, 0, "redo$id", "next$id", "last$id"),
- CgOp.ehspan(3, $l, 0, "redo$id", "next$id", "redo$id"))),
- CgOp.label("last$id")));
- }
-}
-
-augment class Op::Labelled { #OK exist
- method begin() {
- @*opensubs[*-1].add_label($.name);
- for self.zyg { $_.begin } # XXX callsame
- }
-}
-
-augment class Operator {
-class SmartMatch is Operator {
- method as_function($/) { mklex($/, '&infix:<~~>') }
- method with_args($/, *@args) {
- mktemptopic($/, @args[0], ::Op::CallMethod.new(receiver => @args[1],
- name => 'ACCEPTS', args => [ mklex($/, '$_') ]));
- }
-}
-}
-
-sub GetOptions(*@pairs, :$permute = True, :onerror($onerror_), :onarg($onarg_)) {
- my @nonopt;
- my $onerror = $onerror_ // sub ($message) {
- note $message;
- exit 1;
- };
- my $onarg = $onarg_ // sub ($arg) {
- push @nonopt, $arg;
- if !$permute {
- push @nonopt, @*ARGS;
- @*ARGS = ();
- }
- };
- my @unpk;
- sub pick_long_option($st) {
- my @cand = grep { chars($_[0]) > 1 &&
- substr($_[0],0,chars($st)) eq $st }, @unpk;
- $onerror.("Ambiguous long option --$st; could be any of {map *[0], @cand}") if @cand > 1;
- $onerror.("No match for long option --$st") if !@cand;
- @cand[0];
- }
- sub pick_short_option($st) {
- my @cand = grep { $_[0] eq $st }, @unpk;
- $onerror.("No match for short option -$st") if !@cand;
- @cand[0];
- }
- for @pairs -> $p {
- my $key = $p.key;
- my $type = '';
- if $key ~~ /<[:=]>s$/ {
- $type = ~$/;
- $key = substr($key, 0, $/.from);
- }
- for $key.split('|') {
- push @unpk, [ $_, $type, $p.value ];
- }
- }
-
- while @*ARGS {
- my $opt = shift @*ARGS;
- if $opt eq '--' {
- $onarg.(shift @*ARGS) while @*ARGS;
- last;
- }
- elsif substr($opt, 0, 2) eq '--' {
- if $opt ~~ /'='/ {
- my $obl = pick_long_option(substr($opt, 2, $/.from - 2));
- $onerror.("Long option --$obl[0] does not accept an argument")
- if $obl[1] eq '';
- $obl[2].(substr($opt, $/.to));
- } else {
- my $obl = pick_long_option(substr($opt, 2));
- if $obl[1] eq '=s' {
- $onerror.("Argument required for long option --$obl[0]")
- unless @*ARGS;
- $obl[2].(shift @*ARGS);
- } else {
- $obl[2].(Str);
- }
- }
- }
- elsif chars($opt) > 1 && substr($opt, 0, 1) eq '-' {
- $opt = substr($opt, 1);
- while $opt ne '' {
- my $obl = pick_short_option(substr($opt, 0, 1));
- $opt = substr($opt, 1);
- if $obl[1] eq '' || $obl[1] eq ':s' && $opt eq '' {
- $obl[2].(Str);
- }
- elsif $opt ne '' {
- $obl[2].($opt);
- $opt = '';
- }
- else {
- $onerror.("Argument required for short option -$obl[0]")
- unless @*ARGS;
- $obl[2].(shift @*ARGS);
- }
- }
- }
- else {
- $onarg.($opt);
- }
- }
-
- @*ARGS = @nonopt;
-}
+use GetOptLong;
my $usage = q:to/EOM/;
niecza -- a command line wrapper for Niecza
Please sign in to comment.
Something went wrong with that request. Please try again.