Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: 0b2219d912
Fetching contributors…

Cannot retrieve contributors at this time

305 lines (275 sloc) 8.845 kb
use MONKEY_TYPING;
use CClass;
use CgOp;
use GetOptLong;
use JSYNC;
use Metamodel;
use NAMOutput;
use NieczaActions;
use NieczaBackendClisp;
use NieczaBackendDotnet;
use NieczaBackendHoopl;
use NieczaBackendNAM;
use NieczaCompiler;
use NieczaFrontendSTD;
use NieczaPassSimplifier;
use NieczaPathSearch;
use Op;
use Operator;
use OpHelpers;
use OptBeta;
use OptRxSimple;
use RxOp;
use Sig;
use STD;
augment grammar STD::P6 {
token pblock () {
:temp $*CURLEX;
:dba('parameterized block')
[<?before <.lambda> | '{' > ||
{
if $*BORG and $*BORG.<block> {
if $*BORG.<name> {
my $m = "Function '" ~ $*BORG.<name> ~ "' needs parens to avoid gobbling block" ~ $*BORG.<culprit>.locmess;
$*BORG.<block>.panic($m ~ "\nMissing block (apparently gobbled by '" ~ $*BORG.<name> ~ "')");
}
else {
my $m = "Expression needs parens to avoid gobbling block" ~ $*BORG.<culprit>.locmess;
$*BORG.<block>.panic($m ~ "\nMissing block (apparently gobbled by expression)");
}
}
elsif %*MYSTERY {
$¢.panic("Missing block (apparently gobbled by undeclared routine?)");
}
else {
$¢.panic("Missing block");
}
}
]
[
| <lambda>
<.newlex(1)>
{ $*CURLEX<!rw_lambda> = True if $<lambda> eq '<->' }
<signature(1)>
<blockoid>
<.getsig>
| <?before '{'>
<.newlex(1)>
<blockoid>
<.getsig>
]
}
}
augment class Sig::Parameter {
method simple($n) { self.new(name => $n, slot => $n, :rwtrans) }
}
augment class Operator::CompoundAssign {
method with_args($/, *@rest) {
my $left = shift @rest;
if $left.^isa(::Op::Lexical) {
my $nlft = ::Op::Lexical.new(|node($/), name => $left.name);
mkcall($/, '&infix:<=>', $left, $.base.with_args($/, $nlft, @rest));
} else {
mklet($left, -> $ll {
mkcall($/, '&infix:<=>', $ll, $.base.with_args($/, $ll, @rest)) });
}
}
}
class Op::DoOnceLoop is Op {
has Op $.body = die "DoOnceLoop.body required";
method zyg() { $!body }
method code($body) { self.code_labelled($body,'') }
method code_labelled($body, $l) {
my $id = ::GLOBAL::NieczaActions.genid;
CgOp.xspan("redo$id", "next$id", 0, $.body.cgop($body),
1, $l, "next$id", 2, $l, "next$id", 3, $l, "redo$id");
}
}
augment class Op::When {
method code($body) {
my $id = ::GLOBAL::NieczaActions.genid;
CgOp.ternary(CgOp.obj_getbool(CgOp.methodcall(
$.match.cgop($body), 'ACCEPTS', CgOp.scopedlex('$_'))),
CgOp.xspan("start$id", "end$id", 0, CgOp.prog(
CgOp.control(6, CgOp.null('frame'), CgOp.int(-1),
CgOp.null('str'), $.body.cgop($body))),
7, '', "end$id"),
CgOp.corelex('Nil'));
}
}
augment class NieczaActions {
method parameter($/) {
my $rw = ?( $*SIGNUM && $*CURLEX<!rw_lambda> );
my $copy = False;
my $sorry;
my $slurpy = False;
my $slurpycap = False;
my $optional = False;
my $rwt = False;
my $type;
if $<type_constraint> {
my $t = self.simple_longname($<type_constraint>[0]<typename><longname>);
$type = $*CURLEX<!sub>.compile_get_pkg(@$t).xref;
}
for @( $<trait> ) -> $trait {
if $trait.ast<rw> { $rw = True }
elsif $trait.ast<copy> { $copy = True }
elsif $trait.ast<parcel> { $rwt = True }
elsif $trait.ast<readonly> { $rw = False }
else {
$trait.CURSOR.sorry('Unhandled trait ' ~ $trait.ast.keys.[0]);
}
}
if $<post_constraint> > 0 {
$/.sorry('Parameter post constraints NYI');
make ::Sig::Parameter.new;
return Nil;
}
my $default = $<default_value> ?? $<default_value>[0].ast !! Any;
$*unit.deref($default).set_name("$/ init") if $default;
my $tag = $<quant> ~ ':' ~ $<kind>;
if $tag eq '**:*' { $sorry = "Slice parameters NYI" }
elsif $tag eq '*:*' { $slurpy = True }
elsif $tag eq '|:*' { $slurpycap = True }
elsif $tag eq '\\:!' { $rwt = True }
elsif $tag eq '\\:?' { $rwt = True; $optional = True }
elsif $tag eq ':!' { }
elsif $tag eq ':*' { $optional = True }
elsif $tag eq ':?' { $optional = True }
elsif $tag eq '?:?' { $optional = True }
elsif $tag eq '!:!' { }
elsif $tag eq '!:?' { $optional = True }
elsif $tag eq '!:*' { }
else { $sorry = "Confusing parameters ($tag)" }
if $sorry { $/.CURSOR.sorry($sorry); }
my $p = $<param_var> // $<named_param>;
if defined $p.ast<slot> {
# TODO: type constraint here
}
make ::Sig::Parameter.new(name => ~$/, mdefault => $default,
:$optional, :$slurpy, :$rw, tclass => $type,
:$slurpycap, rwtrans => $rwt, is_copy => $copy, |$p.ast);
}
method statement_prefix:do ($/) {
make Op::DoOnceLoop.new(|node($/),
body => self.inliney_call($/, $<blast>.ast));
}
}
CgOp._register_ops: <
>;
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:
-n # short for -L CORN
-p # short for -L CORP
-B --backend=NAME # select backend (nam, dotnet, clisp, hoopl)
-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
--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 = $_ },
"p" => sub { $lang = "CORP" },
"n" => sub { $lang = "CORN" },
"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, safemode => $safe);
}
elsif $bcnd eq 'clisp' {
$backend = NieczaBackendClisp.new(obj_dir => $odir);
}
elsif $bcnd eq 'hoopl' {
$backend = NieczaBackendHoopl.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 => $lang,
safemode => $safe,
),
stages => [ 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 {
my $*repl_outer;
$c.compile_string('', !$comp, $stop);
while True {
print "niecza> ";
my $l = $*IN.get // last;
my $ok;
try {
$c.compile_string($l, !$comp, $stop, :repl, :evalmode,
:outer($*repl_outer));
$ok = True;
}
say $! unless $ok;
}
}
Jump to Line
Something went wrong with that request. Please try again.