Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: 6915253d90
Fetching contributors…

Cannot retrieve contributors at this time

534 lines (487 sloc) 18.317 kb
use MONKEY_TYPING;
use CClass;
use CgOp;
use GetOptLong;
use NieczaActions;
use NieczaBackendDotnet;
use NieczaCompiler;
use NieczaFrontendSTD;
use NieczaPassSimplifier;
use NieczaPathSearch;
use Op;
use Operator;
use OpHelpers;
use OptBeta;
use OptRxSimple;
use RxOp;
use Sig;
use STD;
$GLOBAL::DEBUG_STD = (%*ENV<NIECZA_STD_DEBUG> ?? -1 !! 0);
augment class Any {
submethod new(|$) { die "Attempted to instantiate undefined class." }
}
our ($Operator, $Operator_Method, $Operator_Replicate, $Operator_FlipFlop,
$Operator_SmartMatch, $Operator_Comma, $Operator_Binding,
$Operator_ShortCircuit, $Operator_Ternary, $Operator_Temp,
$Operator_DotEq, $Operator_Mixin, $Operator_Let, $Operator_PostCall,
$Operator_Function, $Operator_CompoundAssign); #OK
our ($Op, $OpAttribute, $OpBareBlock, $OpBuiltin, $OpCallLike, $OpCallMethod,
$OpCallSub, $OpCatchyWrapper, $OpCgOp, $OpConditional, $OpConstantDecl,
$OpContextVar, $OpDoOnceLoop, $OpForLoop, $OpGather, $OpGeneralConst,
$OpGeneralLoop, $OpGetBlock, $OpGetSlot, $OpHereStub, $OpImmedForLoop,
$OpIndirectVar, $OpLabelled, $OpLetVar, $OpLexical, $OpMakeCursor, $OpNum,
$OpParen, $OpRegexBody, $OpRequire, $OpShortCircuit, $OpSimplePair,
$OpSimpleParcel, $OpStart, $OpStateDecl, $OpStatementList,
$OpStringLiteral, $OpTemporize, $OpTry, $OpWhatever, $OpWhateverCode,
$OpWhen, $OpWhileLoop, $OpYada, $OpYouAreHere, $OpLexicalBind); #OK
our ($RxOp, $RxOpAlt, $RxOpAny, $RxOpBefore, $RxOpCut, $RxOpConj, $RxOpCutLTM,
$RxOpCutBrack, $RxOpCutRule, $RxOpConfineLang, $RxOpCapturing,
$RxOpCClassElem, $RxOpCheckBlock, $RxOpEndpoint, $RxOpListPrim,
$RxOpNone, $RxOpNotBefore, $RxOpNewline, $RxOpProtoRedis, $RxOpQuantifier,
$RxOpSubrule, $RxOpString, $RxOpSequence, $RxOpSigspace, $RxOpSeqAlt,
$RxOpSaveValue, $RxOpStringCap, $RxOpSym, $RxOpStatement, $RxOpSetLang,
$RxOpTilde, $RxOpVoidBlock, $RxOpVarString, $RxOpZeroWidth,
$RxOpZeroWidthCCs); #OK
our ($Sig, $SigParameter, $PassSimplifier, $CClass); #OK
our $Actions; $Actions = $Actions but role {
method assertion:name ($/) {
my ($pname) = self.process_name($<longname>, :defer);
my $name = ~$<longname>;
if !$pname {
$pname = { name => 'alpha' };
$/.CURSOR.sorry('Method call requires a method name');
}
my @lex = $*CURLEX<!sub>.lookup_lex("&$name");
my $is_lexical = substr($/.orig, $/.from-1, 1) ne '.' &&
@lex && @lex[0] eq 'sub' && @lex[4].is_regex;
if $<assertion> {
make $<assertion>.ast;
} elsif $name eq 'sym' {
$/.CURSOR.sorry("<sym> is only valid in multiregexes")
unless defined %*RX<sym>;
make $RxOpSym.new(igcase => %*RX<i>, igmark => %*RX<a>,
text => %*RX<sym> // '', endsym => %*RX<endsym>);
} elsif $name eq 'before' {
make $RxOpBefore.new(zyg => [$<nibbler>.ast]);
return Nil;
} elsif $name eq 'after' {
my @l = $<nibbler>.ast.tocclist;
if grep { !defined $_ }, @l {
$/.CURSOR.sorry("Unsuppored elements in after list");
make $RxOpSequence.new;
return Nil;
}
make $RxOpZeroWidthCCs.new(neg => False, after => True, ccs => @l);
return;
} elsif !$<nibbler> && !$<arglist> && !$pname<pkg> && !$pname<iname> &&
!$is_lexical {
make $RxOpSubrule.new(method => $pname<name>);
} else {
my $args = $<nibbler> ??
[ self.op_for_regex($/, $<nibbler>.ast) ] !!
$<arglist> ?? $<arglist>.ast !! [];
my ($callop, $ltm);
if $is_lexical {
$callop = $OpCallSub.new(invocant => mklex($/, "&$name"),
positionals => [ mklex($/, '$¢'), @$args ]);
} elsif $pname<iname> {
$callop = $Operator_Method.new(name => $pname<iname>, :$args,
meta => '::(').with_args($/, mklex($/, '$¢'));
} else {
$ltm = [ 'Method', $pname<name> ];
$callop = $Operator_Method.new(name => $pname<name>, :$args,
package => $pname<pkg>).with_args($/, mklex($/, '$¢'));
}
my $regex = self.rxembed($/, $callop, True);
make $RxOpSubrule.new(:$regex, :$ltm);
}
make self.rxcapturize($/, ~$<longname>, $/.ast);
}
method methodop($/) {
if $<longname> {
my ($c) = self.process_name($<longname>, :defer);
make $Operator_Method.new(name => 'die');
unless $c {
$/.CURSOR.sorry("Method call requires a name");
return;
}
if $c<iname> {
make $Operator_Method.new(name => $c<iname>, meta => '::(');
} else {
make $Operator_Method.new(name => $c<name>, package => $c<pkg>);
}
} elsif $<quote> {
make $Operator_Method.new(name => $<quote>.ast);
} elsif $<variable> {
make $Operator_Function.new(function =>
self.do_variable_reference($/, $<variable>.ast));
}
$/.ast.args = $<args>.ast[0] // [] if $<args>;
$/.ast.args = $<arglist>.ast if $<arglist>;
}
method FALLBACK($meth, $/) {
my $S = $<sym>;
if substr($meth,0,7) eq 'prefix:' {
make $Operator.funop($/, q:s'&prefix:<$S>', 1);
} elsif substr($meth,0,14) eq 'postcircumfix:' {
make $Operator.funop($/, q:s'&postcircumfix:<$S>', 1, @( $<semilist>.ast ));
} elsif substr($meth,0,10) eq 'circumfix:' {
make mkcall($/, q:s'&circumfix:<$S>', @( $<semilist>.ast ));
} elsif substr($meth,0,8) eq 'postfix:' {
make $Operator.funop($/, q:s'&postfix:<$S>', 1);
} elsif substr($meth,0,6) eq 'infix:' {
make $Operator.funop($/, q:s'&infix:<$S>', 2);
} elsif substr($meth,0,5) eq 'term:' {
if $*CURLEX<!sub>.lookup_lex(q:s"term:<$S>") {
make mklex($/, q:s"term:<$S>");
} else {
make mkcall($/, q:s'&term:<$S>');
}
} else {
$/.CURSOR.sorry("Action method $meth not yet implemented");
}
}
method declarator($/) {
if $<defterm> {
make $<defterm>.ast;
self.do_initialize($/, True);
return;
}
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.flags +& $Sig::IS_LIST);
my $hash = ?($param.flags +& $Sig::IS_HASH);
my $type = $param.tclass;
if $*SCOPE eq 'state' {
$sub.add_state_name($slot, self.gensym, :$list, :$hash,
typeconstraint => $type, |mnode($/));
$param = $OpLexical.new(name => $slot, pos=>$/);
} elsif $*SCOPE eq 'our' {
$param = self.package_var($/, $slot, $slot, ['OUR']);
} else {
$sub.add_my_name($slot, :$list, :$hash,
typeconstraint => $type, |mnode($/));
$param = $OpLexical.new(name => $slot, pos=>$/);
}
}
make $OpSimpleParcel.new(pos=>$/, items => @p);
make $OpStateDecl.new(pos=>$/, inside => $/.ast)
if $*SCOPE eq 'state';
} else {
make $<variable_declarator> ?? $<variable_declarator>.ast !!
$<routine_declarator> ?? $<routine_declarator>.ast !!
$<regex_declarator> ?? $<regex_declarator>.ast !!
$<type_declarator>.ast;
}
self.do_initialize($/);
}
method type_declarator:constant ($/) {
self.do_initialize($/);
}
method install_constant ($/) {
if $*MULTINESS {
$/.CURSOR.sorry("Multi variables NYI");
}
my $name = ~($<defterm> // $<variable> // self.gensym);
make self.make_constant($/, $*SCOPE, $name);
}
method named_param_term($/) {
if $<named_param> {
make $<named_param>.ast;
} elsif $<param_var> {
make (anon % = %( $<param_var>.ast ));
$/.ast<names> = []; # completely replace
} else {
make { slot => $<defterm>.ast, names => [ ], flags => $Sig::RWTRANS };
}
}
method named_param($/) {
my %rt;
if $<defterm> {
# XXX funky syntax
my $id = ~$<defterm>;
make { slot => $id, names => [ $id ], flags => $Sig::RWTRANS };
$/.CURSOR.sorry("bare identifier forms NYI");
return;
}
if $<name> {
%rt = %( $<named_param_term>.ast );
%rt<names> = [ @( %rt<names> // [] ), ~$<name> ]
unless %rt<names> && %rt<names>.grep(~$<name>);
} else {
%rt = %( $<param_var>.ast );
if !%rt<names> {
$/.CURSOR.sorry("Abbreviated named parameter must have a name");
}
}
%rt<flags> +&= +^$Sig::POSITIONAL;
make %rt;
}
# now that initializer has been split out this can be a lot smaller...
method INFIX($/) {
my $fn = $<infix>.ast;
my ($st,$lhs,$rhs) = self.whatever_precheck($fn, $<left>.ast, $<right>.ast);
make $fn.with_args($/, $lhs, $rhs);
make self.whatever_postcheck($/, $st, $/.ast);
}
method parameter($/) {
my $sorry;
my $p = $<param_var> // $<named_param>;
my $p_ast = $p ?? $p.ast !! $<defterm> ??
{ names => [], flags => $Sig::POSITIONAL + $Sig::RWTRANS, slot => ~$<defterm> } !!
{ names => [], flags => $Sig::POSITIONAL };
my $flags = $p_ast<flags>;
$flags +|= $Sig::READWRITE if $*SIGNUM && $*CURLEX<!rw_lambda>;
for @( $<trait> ) -> $trait {
if $trait.ast<rw> { $flags +|= $Sig::READWRITE }
elsif $trait.ast<copy> { $flags +|= $Sig::IS_COPY }
elsif $trait.ast<parcel> { $flags +|= $Sig::RWTRANS }
elsif $trait.ast<readonly> { $flags +&= +^$Sig::READWRITE }
else {
$trait.CURSOR.sorry('Unhandled trait ' ~ $trait.ast.keys.[0]);
}
}
my $default = $<default_value> ?? $<default_value>.ast !! Any;
$default.set_name("$/ init") if $default && $default.kind eq 'sub';
my $tag = $<quant> ~ ':' ~ $<kind>;
if $tag eq '**:*' { $sorry = "Slice parameters NYI" }
elsif $tag eq '*:*' { $flags +|= ($flags +& $Sig::IS_HASH) ?? $Sig::SLURPY_NAM !! $Sig::SLURPY_POS }
elsif $tag eq '|:!' { $flags +|= $Sig::SLURPY_CAP }
elsif $tag eq '\\:!' { $flags +|= $Sig::RWTRANS }
elsif $tag eq '\\:?' { $flags +|= ($Sig::RWTRANS + $Sig::OPTIONAL) }
elsif $tag eq ':!' { }
elsif $tag eq ':*' { $flags +|= $Sig::OPTIONAL }
elsif $tag eq '?:*' { $flags +|= $Sig::OPTIONAL }
elsif $tag eq ':?' { $flags +|= $Sig::OPTIONAL }
elsif $tag eq '?:?' { $flags +|= $Sig::OPTIONAL }
elsif $tag eq '!:!' { }
elsif $tag eq '!:?' { $flags +|= $Sig::OPTIONAL }
elsif $tag eq '!:*' { }
else { $sorry = "Confusing parameters ($tag)" }
if $sorry { $/.CURSOR.sorry($sorry); }
if defined $p_ast<slot> {
# TODO: type constraint here
}
make $SigParameter.new(mdefault => $default, name => ($p_ast<slot> // ""),
|$p_ast, :$flags);
for @<type_constraint> -> $tc {
if $tc.ast<where> {
# Should we detect $foo where 5 here?
push ($/.ast.where //= []), self.thunk_sub($tc.ast<where>.ast);
} elsif $tc.ast<value> {
$/.ast.tclass = $tc.ast<value>.get_type;
push ($/.ast.where //= []), $tc.ast<value>;
} else {
$/.CURSOR.sorry("Parameter coercion NYI") if $tc.ast<as>;
my $type = $tc.ast<type>;
if $type.kind eq 'subset' {
push ($/.ast.where //= []), self.thunk_sub(
$OpGeneralConst.new(value => $type.get_type_var));
$type = $type.get_basetype while $type.kind eq 'subset';
}
$/.ast.tclass = $type;
$/.ast.flags +|= $tc.ast<tmode>;
}
}
for @<post_constraint> -> $pc {
# XXX this doesn't seem to be specced anywhere, but it's
# Rakudo-compatible and shouldn't hurt
if $pc<bracket> {
$/.ast.flags +&= +^$Sig::IS_HASH;
$/.ast.flags +|= $Sig::IS_LIST;
}
if $pc<signature> -> $ssig {
$ssig.CURSOR.sorry('Cannot have more than one sub-signature for a pparameter') if $/.ast.subsig;
$/.ast.subsig = $pc<signature>.ast;
} else {
push ($/.ast.where //= []), self.thunk_sub($pc<EXPR>.ast);
}
}
}
method defterm($/) {
make ~$/;
return if ($*IN_DECL // '') eq 'constant';
$/.CURSOR.trymop({
$*CURLEX<!sub>.add_my_name($/.ast, |mnode($/));
$/.CURSOR.check_categorical($/.ast);
});
}
method initializer($/) { }
method initializer:sym<=> ($/) { make $Operator.funop($/, '&infix:<=>', 2) }
method initializer:sym<:=> ($/) { make $Operator_Binding.new(:!readonly) }
method initializer:sym<::=> ($/) { make $Operator_Binding.new(:readonly) }
method initializer:sym<.=> ($/) { make $Operator_DotEq.new }
method do_initialize($/, $parcel?) {
my $i = $<initializer> or return;
my $fn = $i.ast;
my $lhs = $/.ast;
my $rhs = ($i<EXPR> // $i<dottyopish>).ast;
if $parcel {
if $i<sym> ne '=' {
$/.CURSOR.sorry('Parcel variables may only be set using = for now');
}
make $OpLexicalBind.new(name => $lhs, :$rhs);
return;
}
make $fn.with_args($/, $lhs, $rhs);
# Assignments to has and state declarators are rewritten into
# an appropriate phaser
if $lhs.^isa($OpStateDecl) {
my $cv = self.gensym;
$*CURLEX<!sub>.add_state_name(Str, $cv);
make mklet($lhs, -> $ll {
$OpStatementList.new(pos=>$/, children => [
$OpStart.new(condvar => $cv, body =>
$fn.with_args($/, $ll, $rhs)),
$ll]) });
}
elsif $lhs.^isa($OpAttribute) {
my $init = self.thunk_sub($rhs,
:name($lhs.initializer.name ~ " init"));
$init.set_outervar(my $ov = self.gensym);
$*CURLEX<!sub>.add_my_sub($ov, $init);
$lhs.initializer.add_initializer($lhs.name, $init);
make $OpStatementList.new;
}
elsif $lhs.^isa($OpConstantDecl) && !$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;
}
}
method comp_unit($/) {
my $ast = $<statementlist>.ast;
if $*CURLEX<!sub>.has_lexical('&MAIN') && $*UNITNAME eq 'MAIN' {
$ast = $OpStatementList.new(children =>
[ $ast, mkcall($/, '&MAIN_HELPER') ]);
}
$*CURLEX{'!sub'}.finish($ast);
make $*unit;
}
method unitstopper($/) { $/.CURSOR.mark_used('&MAIN') }
}
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 (dotnet)
-L --language=NAME # select your setting
-I --include=DIR # add a directory to search for modules
-v --verbose # detailed timing info
-c --compile # don't run (implied with -C)
--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 $version = 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" => sub { $verb++ },
"version|v" => sub { $version = True },
"compile|c" => sub { $comp = True },
"safe" => sub { $safe = True },
"include|I=s" => sub { unshift @lib, $_.IO.realpath },
"obj-dir=s" => sub { $odir = $_ },
"help|h" => sub { say $usage; exit 0 },
);
my @*INC;
our $Backend;
if $bcnd eq 'dotnet' || $bcnd eq 'mono' {
$Backend = NieczaBackendDotnet.new(obj_dir => $odir, safemode => $safe);
}
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,
),
backend => $Backend,
verbose => $verb,
);
if $version {
$c.compile_string('say "This is Niecza Perl 6 {$?PERL<version>}"', True);
exit 0;
}
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($_);
}
}
elsif @eval {
$c.backend.run_args = @*ARGS;
for @eval {
$c.compile_string($_, !$comp);
}
}
elsif @*ARGS {
my $file = shift @*ARGS;
$c.backend.run_args = @*ARGS;
$c.compile_file($file, !$comp);
}
else {
my $*repl_outer;
my $*repl_outer_frame;
$c.compile_string('$PROCESS::OUTPUT_USED ::= True', !$comp, :repl,
:evalmode);
while True {
print "niecza> ";
my $l = $*IN.get // last;
my $ok;
try {
$c.compile_string($l, !$comp, :repl, :evalmode,
:outer($*repl_outer), :outer_frame($*repl_outer_frame));
$ok = True;
}
say $! unless $ok;
}
say "";
}
Jump to Line
Something went wrong with that request. Please try again.