Skip to content
Fetching contributors…
Cannot retrieve contributors at this time
741 lines (681 sloc) 23.6 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 class Op::ContextVar {
method code($ ) {
CgOp.context_get($!name, +$!uplevel);
}
}
augment grammar STD {
method getsig {
my $pv = $*CURLEX.{'%?PLACEHOLDERS'};
state %method = (:Method, :Submethod, :Regex);
if $*CURLEX.<!NEEDSIG>:delete {
my @parms;
if %method{$*CURLEX<!sub>.class} {
my $cl = $*CURLEX<!sub>.methodof &&
$*unit.deref($*CURLEX<!sub>.methodof);
# XXX type checking against roles NYI
if $cl && $cl !~~ ::Metamodel::Role &&
$cl !~~ ::Metamodel::ParametricRole {
push @parms, ::Sig::Parameter.new(name => 'self', :invocant,
tclass => $cl.xref);
} else {
push @parms, ::Sig::Parameter.new(name => 'self', :invocant);
}
$*CURLEX<!sub>.add_my_name('self', :noinit);
}
if $pv {
my $h_ = $pv.<%_>:delete;
my $a_ = $pv.<@_>:delete;
for (keys %$pv).sort({ substr($^a,1) leg substr($^b,1) }) -> $pn is copy {
my $positional = True;
if substr($pn,0,1) eq ':' {
$pn = substr($pn,1);
$positional = False;
}
my $list = substr($pn,0,1) eq '@';
my $hash = substr($pn,0,1) eq '%';
push @parms, ::Sig::Parameter.new(slot => $pn, :$list, :$hash,
name => $pn, :$positional, names => [ substr($pn,1) ]);
}
if $a_ {
push @parms, ::Sig::Parameter.new(slot => '@_', name => '*@_',
:slurpy, :list);
}
if $h_ {
push @parms, ::Sig::Parameter.new(slot => '%_', name => '*%_',
:slurpy, :hash);
}
}
else {
push @parms, ::Sig::Parameter.new(name => '$_', slot => '$_',
:defouter, :rwtrans);
self.trymop({
$*CURLEX<!sub>.lexicals<$_>.noinit = True;
$*CURLEX<!sub>.lexicals<$_>.defouter = False;
});
}
$*CURLEX<!sub>.signature = ::GLOBAL::Sig.new(params => @parms);
}
my regex interesting () {
<!before anon_ >
<!before <[ \$ \@ \% ]> _ >
<?before <[ \$ \@ \% \& ]> \w >
}
if ($*CURLEX<!multi>//'') ne 'proto' {
my $lu = $*CURLEX<!sub>.lexicals-used;
for $*CURLEX<!sub>.lexicals.kv -> $k, $desc {
next unless interesting(Cursor.new($k));
next if $lu{$k};
# next if $[_/!] declared automatically "dynamic" TODO
next unless defined $desc.pos;
self.cursor($desc.pos).worry("$k is declared but not used");
}
}
self;
}
method finishlex() {
my $sub = $*CURLEX<!sub>;
if $sub.is_routine {
$sub.add_my_name('$/', :roinit) unless $sub.lexicals<$/>:exists;
$sub.add_my_name('$!', :roinit) unless $sub.lexicals<$!>:exists;
}
$sub.add_my_name('$_', :defouter(!$sub.is_routine ||
$sub === $sub.to_unit)) unless $sub.lexicals<$_>:exists;
self;
}
}
augment grammar STD::P6 {
token capterm {
'\\'
[
| '(' ~ ')' <capture>?
| <?before \S> <termish>
| {} <.panic: "You can't backslash that">
]
}
rule package_def {
:my $longname;
:my $*IN_DECL = 'package';
:my $*HAS_SELF = '';
:temp $*CURLEX;
:temp $*SCOPE;
:my $outer = $*CURLEX;
{ $*SCOPE ||= 'our'; }
[
[ <longname> { $longname = $<longname>[0]; } ]?
<.newlex(0, ($*PKGDECL//'') ne 'role')>
[ :dba('generic role')
<?{ ($*PKGDECL//'') eq 'role' }>
'[' ~ ']' <signature(1)>
{ $*IN_DECL = ''; }
]?
<trait>*
<.open_package_def($/)>
[
|| <?before '{'>
[
{ $*begin_compunit = 0; $*IN_DECL = ''; }
<blockoid>
$<stub>={$¢.checkyada}
]
|| <?before ';'>
[
|| <?{ $*begin_compunit }>
{
$longname orelse $¢.panic("Compilation unit cannot be anonymous");
$outer === $*UNIT or $¢.panic("Semicolon form of " ~ $*PKGDECL ~ " definition not allowed in subscope;\n please use block form");
$*PKGDECL eq 'package' and $¢.panic("Semicolon form of package definition indicates a Perl 5 module; unfortunately,\n STD doesn't know how to parse Perl 5 code yet");
$*begin_compunit = 0;
$*IN_DECL = '';
}
<.finishlex>
<statementlist> # whole rest of file, presumably
|| <.panic: "Too late for semicolon form of " ~ $*PKGDECL ~ " definition">
]
|| <.panic: "Unable to parse " ~ $*PKGDECL ~ " definition">
]
<.getsig>
] || <.panic: "Malformed $*PKGDECL">
}
token comp_unit {
:my $*DEBUG = $GLOBAL::DEBUG_STD // 0;
:my $*begin_compunit = 1;
:my $*endargs = -1;
:my %*LANG;
:my $*PKGDECL ::= "";
:my $*IN_DECL = '';
:my $*HAS_SELF = '';
:my $*OFTYPE;
:my $*QSIGIL ::= '';
:my $*IN_META = '';
:my $*QUASIMODO;
:my $*SCOPE = "";
:my $*LEFTSIGIL;
:my $*PRECLIM;
:my %*MYSTERY = ();
:my $*INVOCANT_OK;
:my $*INVOCANT_IS;
:my $*CURLEX;
:my $*MULTINESS = '';
:my $*SIGNUM = 0;
:my $*MONKEY_TYPING = False;
:my %*WORRIES;
:my @*WORRIES;
:my $*FATALS = 0;
:my $*IN_SUPPOSE = False;
{
%*LANG<MAIN> = ::STD::P6 ;
%*LANG<Q> = ::STD::Q ;
%*LANG<Quasi> = ::STD::Quasi ;
%*LANG<Regex> = ::STD::Regex ;
%*LANG<P5> = ::STD::P5 ;
%*LANG<P5Regex> = ::STD::P5::Regex ;
@*WORRIES = ();
$*CURLEX = { };
$*UNIT = $*CURLEX;
}:s
<.unitstart>
<.finishlex>
<statementlist>
[ <?unitstopper> || <.panic: "Confused"> ]
<.getsig>
# "CHECK" time...
{
$¢.explain_mystery();
if @*WORRIES {
note "Potential difficulties:\n " ~ join( "\n ", @*WORRIES) ~ "\n";
}
die "Check failed\n" if $*FATALS;
}
}
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'));
}
}
class Op::StateDecl is Op {
has Op $.inside;
method zyg() { $!inside }
method ctxzyg($f) { $!inside, $f }
method code($body) { $!inside.cgop($body) }
method to_bind($/, $ro, $rhs) { $!inside.to_bind($/, $ro, $rhs); }
}
augment class NieczaActions {
method declarator($/) {
if $<signature> {
temp $*SCOPE ||= 'my';
my $sub = $*CURLEX<!sub>;
my @p = @( $<signature>.ast.params );
# TODO: keep the original signature around somewhere := can find it
# TODO: fanciness checks
for @p -> \$param {
my $slot = $param.slot;
$sub.delete_lex($slot) if defined($slot);
$slot //= self.gensym;
$slot = self.gensym if $*SCOPE eq 'anon';
my $list = $param.list;
my $hash = $param.hash;
my $type = $param.tclass;
if $*SCOPE eq 'state' {
$sub.add_state_name($slot, self.gensym, :$list, :$hash,
typeconstraint => $type, |mnode($/));
$param = Op::Lexical.new(name => $slot, |node($/));
} elsif $*SCOPE eq 'our' {
$param = self.package_var($/, $slot, $slot, ['OUR'], :$list,
:$hash);
} else {
$sub.add_my_name($slot, :$list, :$hash,
typeconstraint => $type, |mnode($/));
$param = Op::Lexical.new(name => $slot, |node($/));
}
}
make Op::SimpleParcel.new(|node($/), items => @p);
make Op::StateDecl.new(|node($/), inside => $/.ast)
if $*SCOPE eq 'state';
return;
}
make $<variable_declarator> ?? $<variable_declarator>.ast !!
$<routine_declarator> ?? $<routine_declarator>.ast !!
$<regex_declarator> ?? $<regex_declarator>.ast !!
$<type_declarator>.ast;
}
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::StateDecl) {
my $cv = self.gensym;
$*CURLEX<!sub>.add_state_name(Str, $cv);
make mklet($lhs, -> $ll {
Op::StatementList.new(|node($/), children => [
Op::Start.new(condvar => $cv, body =>
$fn.with_args($/, $ll, $rhs)),
$ll]) });
}
elsif $lhs.^isa(::Op::Attribute) && !defined($lhs.initializer.ivar) {
my $init = self.thunk_sub($rhs,
:name($lhs.initializer.name ~ " init"));
$lhs.initializer.ivar = self.gensym;
$*CURLEX<!sub>.add_my_sub($lhs.initializer.ivar, $init);
$lhs.initializer.ibody = $init.xref;
make $lhs;
}
elsif $lhs.^isa(::Op::ConstantDecl) && !$lhs.init {
my $sig = substr($lhs.name, 0, 1);
if defined '$@&%'.index($sig) {
self.init_constant($lhs, self.docontext($/, $sig, $rhs));
} else {
self.init_constant($lhs, $rhs);
}
make $lhs;
}
}
make self.whatever_postcheck($/, $st, $/.ast);
}
method variable($/) {
my $sigil = $<sigil> ?? ~$<sigil> !! substr(~$/, 0, 1);
my $twigil = $<twigil> ?? $<twigil>[0]<sym> !! '';
my ($name, $rest);
my $dsosl = $<desigilname> ?? $<desigilname>.ast !!
$<sublongname> ?? $<sublongname>.ast !!
Any;
if defined($dsosl) && defined($dsosl<ind>) {
make { term => self.docontext($/, $sigil, $dsosl<ind>) };
return;
} elsif defined $dsosl {
($name, $rest) = $dsosl<name path>;
} elsif $<infixish> {
make { term => $<infixish>.ast.as_function($/) };
return;
} elsif $<name> {
# Both these cases are marked XXX in STD. I agree. What are they for?
if $<name>[0].ast<dc> {
$/.CURSOR.sorry("*ONE* pair of leading colons SHALL BE ENOUGH");
make { term => ::Op::StatementList.new };
return;
}
if substr(~$/,0,3) eq '$::' {
$rest = $<name>[0].ast.<names>;
$name = pop $rest;
} else {
if $<name>[0].ast<names> > 1 {
$/.CURSOR.sorry("Nonsensical attempt to qualify a self-declared named parameter detected");
make { term => ::Op::StatementList.new };
return;
}
$name = $<name>[0].ast<names>[0];
$twigil = ':';
}
} elsif $<special_variable> {
$name = substr(~$<special_variable>, 1);
} elsif $<index> {
make { capid => $<index>.ast, term =>
mkcall($/, '&postcircumfix:<[ ]>',
::Op::Lexical.new(name => '$/'),
::Op::Num.new(value => $<index>.ast))
};
return Nil;
} elsif $<longname> {
$/.CURSOR.sorry('::<> syntax NYI');
make { term => ::Op::StatementList.new };
return;
} elsif $<postcircumfix> {
if $<postcircumfix>[0].reduced eq 'postcircumfix:sym<< >>' { #XXX fiddly
make { capid => $<postcircumfix>[0].ast.args[0].text, term =>
mkcall($/, '&postcircumfix:<{ }>',
::Op::Lexical.new(name => '$/'),
@( $<postcircumfix>[0].ast.args))
};
return;
} else {
make { term => self.docontext($/, $sigil, $<postcircumfix>[0].ast.args[0]) };
return;
}
} else {
$name = '';
}
make {
sigil => $sigil, twigil => $twigil, name => $name, rest => $rest
};
}
method variable_declarator($/) {
if $*MULTINESS {
$/.CURSOR.sorry("Multi variables NYI");
}
for @$<trait> -> $t {
if $t.ast<rw> {
} else {
$/.CURSOR.sorry("Trait $t.ast.keys.[0] not available on variables");
}
}
if $<post_constraint> || $<postcircumfix> || $<semilist> {
$/.CURSOR.sorry("Postconstraints, and shapes on variable declarators NYI");
}
my $scope = $*SCOPE // 'my';
if $scope eq 'augment' || $scope eq 'supersede' {
$/.CURSOR.sorry("Illogical scope $scope for simple variable");
}
my $typeconstraint;
if $*OFTYPE {
$typeconstraint = self.simple_longname($*OFTYPE<longname>);
$/.CURSOR.sorry("Common variables are not unique definitions and may not have types") if $scope eq 'our';
}
my $v = $<variable>.ast;
my $t = $v<twigil>;
my $list = $v<sigil> eq '@';
my $hash = $v<sigil> eq '%';
if ($t && defined "?=~^:".index($t)) {
$/.CURSOR.sorry("Variables with the $t twigil cannot be declared " ~
"using $scope; they are created " ~
($t eq '?' ?? "using 'constant'." !!
$t eq '=' ?? "by parsing POD blocks." !!
$t eq '~' ?? "by 'slang' definitions." !!
"automatically as parameters to the current block."));
}
if $scope ne 'has' && ($t eq '.' || $t eq '!') {
$/.CURSOR.sorry("Twigil $t is only valid on attribute definitions ('has').");
}
if !defined($v<name>) && $scope ne any < my anon state > {
$/.CURSOR.sorry("Scope $scope requires a name");
}
if defined $v<rest> {
$/.CURSOR.sorry(":: syntax is only valid when referencing variables, not when defining them.");
}
my $name = $v<sigil> ~ $v<twigil> ~ $v<name>;
# otherwise identical to my
my $slot = ($scope eq 'anon' || !defined($v<name>))
?? self.gensym !! $name;
my $res_tc = $typeconstraint ??
$*CURLEX<!sub>.compile_get_pkg(@$typeconstraint).xref !! Any;
if $scope eq 'has' {
make self.add_attribute($/, $v<name>, $v<sigil>, $t eq '.', $res_tc);
} elsif $scope eq 'state' {
$/.CURSOR.trymop({
$/.CURSOR.check_categorical($slot);
$*CURLEX<!sub>.add_state_name($slot, self.gensym, :$list,
:$hash, typeconstraint => $res_tc, |mnode($/));
});
make Op::StateDecl.new(|node($/), inside =>
Op::Lexical.new(|node($/), name => $slot, :$list, :$hash));
} elsif $scope eq 'our' {
make self.package_var($/, $slot, $slot, ['OUR'], :$list, :$hash);
} else {
$/.CURSOR.trymop({
$/.CURSOR.check_categorical($slot);
$*CURLEX<!sub>.add_my_name($slot, :$list, :$hash,
typeconstraint => $res_tc, |mnode($/));
});
make ::Op::Lexical.new(|node($/), name => $slot, :$list, :$hash);
}
}
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;
}
say "";
}
Something went wrong with that request. Please try again.