Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: 2df976dd48
Fetching contributors…

Cannot retrieve contributors at this time

531 lines (477 sloc) 15.663 kb
use Metamodel;
use Op;
use RxOp;
use CClass;
use CgOp;
use Body;
use Unit;
use JSYNC;
use NAMOutput;
use NieczaFrontendSTD;
use NieczaPassBegin;
use NieczaPassBeta;
use NieczaPassSimplifier;
use NieczaBackendNAM;
use NieczaBackendDotnet;
use NieczaBackendClisp;
use NieczaPathSearch;
use NieczaCompiler;
use MONKEY_TYPING;
use GetOptLong;
use NieczaActions;
use OpHelpers;
use Operator;
use OptRxSimple;
use Sig;
use STD;
augment class STD::P6 { #OK exist
token param_var($named = 0) {
:dba('formal parameter')
[
| '[' ~ ']' <signature>
| '(' ~ ')' <signature>
| <sigil> <twigil>?
[
# Is it a longname declaration?
|| <?{ $<sigil>.Str eq '&' }> <?ident> {}
<name=.sublongname>
|| # Is it a shaped array or hash declaration?
<?{ $<sigil>.Str eq '@' || $<sigil>.Str eq '%' }>
<name=.identifier>?
<?before <[ \< \( \[ \{ ]> >
<postcircumfix>
# ordinary parameter name
|| <name=.identifier>
|| <name=.decint> <.panic: "Can't declare a numeric parameter">
|| $<name> = [<[/!]>]
# bare sigil?
]?
{
my $vname = $<sigil>.Str;
my $t = $<twigil>;
my $twigil = '';
$twigil = $t.Str if $t;
$vname ~= $twigil;
my $n = ($<name> // '').Str;
$vname ~= $n;
if $twigil eq '' {
self.add_my_name($vname) if $n ne '';
# :$param is often used as a multi matcher without $param used in body
# so don't count as "declared but not used"
$*CURLEX{$vname}<used> = 1 if $named and $n;
}
elsif $twigil eq '.' { }
elsif $twigil eq '!' { }
elsif $twigil eq '*' { }
else {
self.panic("You may not use the $twigil twigil in a signature");
}
}
]
}
}
augment class RxOp::Sym { #OK exist
method lad() {
my $m = [ ($!igcase ?? 'StrNoCase' !! 'Str'), $!text ];
defined($!endsym) ?? [ 'Sequence', [$m, [ 'Method', $!endsym ]] ] !! $m;
}
}
augment class NieczaActions {
method mod_internal:p6adv ($/) {
my ($k, $v) = $<quotepair><k v>;
if !$v.^isa(Match) {
$/.CURSOR.sorry(":$k requires an expression argument");
make ::RxOp::None.new;
return Nil;
}
$v = $v.ast;
if $k eq 'lang' {
make ::RxOp::SetLang.new(expr => self.rxembed($/, $v, True));
} elsif $k eq 'dba' {
while True {
if $v.^isa(::Op::Paren) { $v = $v.inside; redo }
if $v.^isa(::Op::StatementList) && +$v.children == 1
{ $v = $v.children.[0]; redo }
last;
}
if !$v.^isa(::Op::StringLiteral) {
$/.CURSOR.sorry(":dba requires a literal string");
make ::RxOp::None.new;
return Nil;
}
%*RX<dba> = $v.text;
}
}
method quantifier:sym<**> ($/) {
# XXX can't handle normspace well since it's not labelled 1*/2*
my $h = $<embeddedblock> ?? { min => 0, cond => $<embeddedblock>.ast } !!
$<quantified_atom> ?? { min => 1, sep => $<quantified_atom>.ast } !!
{ min => +~$0, max => ($1 ?? +~$1 !!
defined($/.index('..')) ?? Any !! +~$0) };
$h<mod> = $<quantmod>.ast;
make $h;
}
method quantified_atom($/) { # :: RxOp
my $atom = $<atom>.ast;
my $q = $<quantifier> ?? $<quantifier>.ast !! Any;
return Nil unless $atom;
if %*RX<r> {
# no quantifier at all? treat it as :
$q //= { mod => '' };
# quantifier without explicit :? / :! gets :
$q<mod> //= '';
}
if defined $q<min> {
my @z = $atom;
push @z, $q<sep> if defined $q<sep>;
$atom = ::RxOp::Quantifier.new(min => $q<min>, max => $q<max>,
nonlisty => $q<nonlisty>,
zyg => [@z], minimal => ($q<mod> && $q<mod> eq '?'));
}
if defined($q<mod>) && $q<mod> eq '' {
$atom = ::RxOp::Cut.new(zyg => [$atom]);
}
if defined $q<tilde> {
my ($closer, $inner) = @( $q<tilde> );
$closer = $closer.zyg[0] if $closer.^isa(::RxOp::Cut) &&
$closer.zyg[0].^isa(::RxOp::String);
if !$closer.^isa(::RxOp::String) {
$/.CURSOR.sorry("Non-literal closers for ~ NYI");
make ::RxOp::None.new;
return Nil;
}
$inner = self.encapsulate_regex($/, $inner, passcut => True,
goal => $closer.text, passcap => True);
$atom = ::RxOp::Sequence.new(zyg => [$atom,
::RxOp::Tilde.new(closer => $closer.text, dba => %*RX<dba>,
zyg => [$inner])]);
}
make $atom;
}
sub mkstringycat($/, *@strings) {
my @a;
for @strings -> $s {
my $i = ($s !~~ Op) ?? ::Op::StringLiteral.new(|node($/),
text => $s) !! $s;
# this *might* belong in an optimization pass
if @a && @a[*-1] ~~ ::Op::StringLiteral &&
$i ~~ ::Op::StringLiteral {
@a[*-1] = ::Op::StringLiteral.new(|node($/),
text => (@a[*-1].text ~ $i.text));
} else {
push @a, $i;
}
}
if @a == 0 {
return ::Op::StringLiteral.new(|node($/), text => "");
} elsif @a == 1 {
return (@a[0] ~~ ::Op::StringLiteral) ?? @a[0] !!
mkcall($/, '&prefix:<~>', @a[0]);
} else {
return mkcall($/, '&infix:<~>', @a);
}
}
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 && defined($prefix) && $prefix ne "" {
$ast = $ast.split(/^^<before \h>[ $prefix || \h+ ]/).join("");
}
push @acc, $ast;
}
my $post = $/.CURSOR.postprocessor;
make mkstringycat($/, @acc);
if $post eq 'null' {
# already OK
}
# actually quotewords is a bit trickier than this...
elsif $post eq 'words' || $post eq 'quotewords' {
my $sl = $/.ast;
if !$sl.^isa(::Op::StringLiteral) {
make ::Op::CallMethod.new(|node($/), :name<words>, receiver => $sl);
}
else {
my @tok = $sl.text.words;
@tok = map { ::Op::StringLiteral.new(|node($/), text => $_) }, @tok;
make ((@tok == 1) ?? @tok[0] !!
::Op::SimpleParcel.new(|node($/), items => @tok));
}
}
elsif $post eq 'path' {
# TODO could stand to be a lot fancier.
make ::Op::CallMethod(|node($/), receiver => $/.ast, :name<IO>);
}
elsif $post eq 'run' {
make mkcall($/, 'rungather', $/.ast);
}
else {
$/.CURSOR.sorry("Unhandled postprocessor $post");
}
$/.ast;
}
method trait_mod:is ($/) {
my $trait = ~$<longname>;
my $noparm;
if $/.CURSOR.is_name($trait) {
make self.mangle_longname($<longname>);
$noparm = 'Superclasses cannot have parameters';
} elsif $trait eq 'export' {
make { export => [ 'DEFAULT', 'ALL' ] };
$noparm = 'Export tags NYI';
} elsif $trait eq 'endsym' {
my $text;
if !$<circumfix> || !$<circumfix>[0].ast.^isa(::Op::StringLiteral) {
$/.CURSOR.sorry("Argument to endsym must be a literal string");
} else {
$text = $<circumfix>[0].ast.text;
}
make { endsym => $text };
} elsif $trait eq 'rawcall' {
make { nobinder => True };
} elsif $trait eq 'return-pass' { # &return special
make { return_pass => 1 };
} elsif $trait eq 'parcel' {
make { rwt => 1 };
} elsif $trait eq 'parcel' {
make { rwt => 1 };
} else {
make { $trait => True };
}
if $noparm && $<circumfix> {
$/.CURSOR.sorry($noparm);
}
}
method op_for_regex($/, $rxop) {
my @lift = $rxop.oplift;
{
my $*paren = 0;
my $*dba = 'anonymous rule';
my $*symtext;
my $*endsym;
$rxop.check
}
my ($orxop, $mb) = OptRxSimple.run($rxop);
self.transparent($/, ::Op::RegexBody.new(|node($/), canback => $mb,
pre => @lift, rxop => $orxop),
class => 'Regex', type => 'regex', sig => Sig.simple.for_method);
}
method regex_def($/) {
sub _symtext($name) {
($name ~~ /\:sym\<(.*)\>/) ?? ($name.substr(0, $/.from), ~$0) !!
($name ~~ /\:(\w+)/) ?? ($name.substr(0, $/.from), ~$0) !!
($name, Str);
}
my ($name, $path) = $<deflongname> ??
self.mangle_longname($<deflongname>[0]).<name path> !! Nil;
my $cname;
if defined($path) && $path == 0 && $name.^isa(Op) {
$cname = $name;
$name = ~$<deflongname>[0];
$path = Any;
}
my $scope = (!defined($name)) ?? "anon" !! ($*SCOPE || "has");
if $<signature> > 1 {
$/.CURSOR.sorry("Multiple signatures on a regex NYI");
return Nil;
}
if $cname && $scope ne 'has' {
$/.CURSOR.sorry("Only has regexes may have computed names");
make ::Op::StatementList.new;
return Nil;
}
my $isproto;
my ($basename, $symtext) = ($cname || !defined($name))
?? (Str, Str) !! _symtext($name);
my $endsym;
for map *.ast, @$<trait> -> $t {
if $t<unary> || $t<binary> || $t<defequiv> {
# Ignored for now
}
elsif defined $t<endsym> {
$endsym = $t<endsym>;
}
else {
$/.CURSOR.sorry("Unhandled regex trait $t.keys.[0]");
}
}
if $*MULTINESS eq 'proto' {
if $<signature> || !$<regex_block><onlystar> || $scope ne 'has' ||
!defined($basename) {
$/.CURSOR.sorry("Only simple {*} protoregexes with no parameters are supported");
return Nil;
}
@*MEMOS[0]<proto_endsym>{$basename} = $endsym;
$isproto = True;
} else {
my $m2 = defined($symtext) ?? 'multi' !! 'only';
if $*MULTINESS && $*MULTINESS ne $m2 {
$/.CURSOR.sorry("Inferred multiness disagrees with explicit");
return Nil;
}
$endsym //= @*MEMOS[0]<proto_endsym>{$basename} if defined $basename;
}
if defined($path) && $scope ne 'our' {
$/.CURSOR.sorry("Putting a regex in a package requires using the our scope.");
return Nil;
}
my $sig = $<signature> ?? $<signature>[0].ast !! Sig.simple;
if $scope eq 'state' || $scope eq 'supercede' || $scope eq 'augment' {
$/.CURSOR.sorry("Nonsensical scope $scope for regex");
return Nil;
}
if $scope eq 'our' {
$/.CURSOR.sorry("our regexes NYI");
return Nil;
}
my $var = ($scope eq 'anon' || $scope eq 'has') ?? self.gensym
!! '&' ~ $name;
my $ast = $<regex_block>.ast;
if $isproto {
$ast = ::RxOp::ProtoRedis.new(name => $name);
}
{
my $*paren = 0;
my $*symtext = $symtext;
my $*endsym = $endsym;
my $*dba = $name // 'anonymous regex';
$ast.check;
}
my $lad = OptRxSimple.run_lad($ast.lad);
my @lift = $ast.oplift;
($ast, my $mb) = OptRxSimple.run($ast);
make ::Op::SubDef.new(|node($/),
var => $var,
method_too => ($scope eq 'has' ?? ['normal', $cname // $name] !! Any),
body => Body.new(
ltm => $lad,
returnable => True,
class => 'Regex',
type => 'regex',
name => $name // 'ANONrx',
signature => $sig.for_method,
do => ::Op::RegexBody.new(|node($/), pre => @lift,
name => ($name // ''), rxop => $ast, canback => $mb)));
}
method quote:rx ($/) { make self.op_for_regex($/, $<quibble>.ast); }
method quote:m ($/) {
make ::Op::CallMethod.new(|node($/), name => 'ACCEPTS',
receiver => self.op_for_regex($/, $<quibble>.ast),
args => [ mklex($/, '$_') ]);
}
# actually we need a few more special cases here.
method assertion:variable ($/) {
make ::RxOp::Subrule.new(|node($/), regex =>
::Op::CallSub.new(|node($/), invocant => $<variable>.ast,
positionals => [ ::Op::MakeCursor.new(|node($/)) ]));
}
}
my $usage = q:to/EOM/;
niecza -- a command line wrapper for Niecza
usage: niecza -e 'code' # run a one-liner
OR: niecza file.pl [args] # run a program
OR: niecza -C MyModule # precompile a module
OR: niecza # interactive shell
general options:
-B --backend=NAME # select backend (nam, dotnet, clisp)
-L --language=NAME # select your setting
-v --verbose # detailed timing info
-c --compile # don't run (implied with -C)
--stop-after=STAGE # stop after STAGE and dump AST
--safe # disable system interaction, implies -L SAFE
--help # display this message
backend options:
--obj-dir=DIR # select output location (all)
EOM
my $runobj = Q:CgOp { (box Str (rawcall get_BaseDirectory (rawscall System.AppDomain.get_CurrentDomain))) };
my $basedir = $runobj.IO.append("..").realpath;
my @lib = $basedir.append("lib"), ".".IO.realpath;
my $lang = "CORE";
my $safe = False;
my $bcnd = "dotnet";
my $odir = $basedir.append("obj");
my $verb = 0;
my @eval;
my $cmod = False;
my $comp = False;
my $stop = "";
my $aotc = False;
GetOptions(:!permute,
"evaluate|e=s" => sub { push @eval, $_ },
"compile-module|C" => sub { $cmod = True },
"backend|B=s" => sub { $bcnd = $_ },
"language|L=s" => sub { $lang = $_ },
"verbose|v" => sub { $verb++ },
"compile|c" => sub { $comp = True },
"safe" => sub { $safe = True },
"stop=s" => sub { $stop = $_ },
"aot" => sub { $aotc = True },
"include|I=s" => sub { unshift @lib, $_.IO.realpath },
"obj-dir=s" => sub { $odir = $_ },
"help|h" => sub { say $usage; exit 0 },
);
my $backend;
if $bcnd eq 'nam' {
$backend = NieczaBackendNAM.new(obj_dir => $odir);
}
elsif $bcnd eq 'dotnet' || $bcnd eq 'mono' {
$backend = NieczaBackendDotnet.new(obj_dir => $odir);
}
elsif $bcnd eq 'clisp' {
$backend = NieczaBackendClisp.new(obj_dir => $odir);
}
else {
note "Backend '$bcnd' not supported";
exit 1;
}
my $c = NieczaCompiler.new(
module_finder => NieczaPathSearch.new(
path => @lib,
),
frontend => NieczaFrontendSTD.new(
lang => $safe ?? 'SAFE' !! $lang,
safemode => $safe,
),
stages => [
NieczaPassBegin.new,
NieczaPassBeta.new,
NieczaPassSimplifier.new,
],
backend => $backend,
verbose => $verb,
);
if $cmod {
if @eval {
note "Module compilation cannot be used with strings to evaluate";
exit 1;
}
if !@*ARGS {
say "No modules named to compile!";
exit 0;
}
for @*ARGS {
$c.compile_module($_, $stop);
}
}
elsif @eval {
$c.backend.run_args = @*ARGS;
for @eval {
$c.compile_string($_, !$comp, $stop);
}
}
elsif @*ARGS {
my $file = shift @*ARGS;
$c.backend.run_args = @*ARGS;
$c.compile_file($file, !$comp, $stop);
}
else {
while True {
print "niecza> ";
my $l = $*IN.get // last;
$c.compile_string("say (" ~ $l ~ ").perl", !$comp, $stop);
}
}
Jump to Line
Something went wrong with that request. Please try again.