Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: 8a35c4fa6e
Fetching contributors…

Cannot retrieve contributors at this time

1074 lines (950 sloc) 34.484 kb
use MONKEY_TYPING;
use CClass;
use CgOp;
use GetOptLong;
use JSYNC;
use Metamodel;
use NAMOutput;
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;
augment grammar STD::P6 {
rule package_def {
:my $longname;
:my $*IN_DECL = 'package';
:my $*HAS_SELF = '';
# augments in niecza are a bit weird because they always
# defer to INIT time
:my $*AUGMENT_BUFFER;
: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">
}
}
augment grammar STD {
method finishlex() {
my $sub = $*CURLEX<!sub>;
if $sub.is_routine {
$sub.add_my_name('$/', :roinit) unless $sub.has_lexical('$/');
$sub.add_my_name('$!', :roinit) unless $sub.has_lexical('$!');
}
$sub.add_my_name('$_', :defouter(!$sub.is_routine ||
$sub.is($sub.to_unit))) unless $sub.has_lexical('$_');
$*SIGNUM = 0;
self;
}
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);
$*CURLEX<!sub>.parameterize_topic;
}
$*CURLEX<!sub>.set_signature(::GLOBAL::Sig.new(params => @parms));
}
my regex interesting () {
<!before anon_ >
<!before <[ \$ \@ \% ]> _ >
<?before <[ \$ \@ \% \& ]> \w >
}
if ($*CURLEX<!multi>//'') ne 'proto' {
for $*CURLEX<!sub>.unused_lexicals -> $k, $pos {
next unless interesting(Cursor.new($k));
# next if $[_/!] declared automatically "dynamic" TODO
next unless $pos >= 0;
self.cursor($pos).worry("$k is declared but not used");
}
}
self;
}
method explain_mystery() {
my %post_types;
my %unk_types;
my %unk_routines;
my $m = '';
for keys(%*MYSTERY) {
my $p = %*MYSTERY{$_}.<lex>;
if self.is_name($_, $p) {
# types may not be post-declared
%post_types{$_} = %*MYSTERY{$_};
next;
}
next if self.is_known($_, $p) or self.is_known('&' ~ $_, $p);
# just a guess, but good enough to improve error reporting
if $_ lt 'a' {
%unk_types{$_} = %*MYSTERY{$_};
}
else {
%unk_routines{$_} = %*MYSTERY{$_};
}
}
if %post_types {
my @tmp = sort keys(%post_types);
$m ~= "Illegally post-declared type" ~ ('s' x (@tmp != 1)) ~ ":\n";
for @tmp {
$m ~= "\t'$_' used at line " ~ %post_types{$_}.<line> ~ "\n";
}
}
if %unk_types {
my @tmp = sort keys(%unk_types);
$m ~= "Undeclared name" ~ ('s' x (@tmp != 1)) ~ ":\n";
for @tmp {
$m ~= "\t'$_' used at line " ~ %unk_types{$_}.<line> ~ "\n";
}
}
if %unk_routines {
my @tmp = sort keys(%unk_routines);
$m ~= "Undeclared routine" ~ ('s' x (@tmp != 1)) ~ ":\n";
for @tmp {
$m ~= "\t'$_' used at line " ~ %unk_routines{$_}.<line> ~ "\n";
}
}
self.sorry($m) if $m;
for $*unit.stubbed_stashes -> $pos, $type {
next if $type.closed || $type.kind eq 'package';
self.cursor($pos).sorry("Package was stubbed but not defined");
}
self;
}
method newlex ($needsig = 0, $once = False) {
my $osub = $*CURLEX<!sub>;
$*CURLEX = { };
$*CURLEX<!NEEDSIG> = 1 if $needsig;
$*CURLEX<!IN_DECL> = $*IN_DECL if $*IN_DECL;
$*CURLEX<!sub> = $*unit.create_sub(
outer => $osub,
class => 'Block',
cur_pkg => $osub.cur_pkg,
in_class => $osub.in_class,
run_once => $once && $osub.run_once,
name => "ANON");
self;
}
method lookup_lex($name, $lex) {
($lex // $*CURLEX)<!sub>.lookup_lex($name, $*FILE<name>, self.lineof(self.pos));
}
method mark_used($name) {
$*CURLEX<!sub>.lookup_lex($name, $*FILE<name>, self.lineof(self.pos));
Nil;
}
method add_placeholder($name) {
my $decl = $*CURLEX.<!IN_DECL> // '';
my $sub = $*CURLEX<!sub>;
$decl = ' ' ~ $decl if $decl;
my $*IN_DECL = 'variable';
if $*SIGNUM {
return self.sorry("Placeholder variable $name is not allowed in the$decl signature");
}
elsif my $siggy = $*CURLEX.<$?SIGNATURE> {
return self.sorry("Placeholder variable $name cannot override existing signature $siggy");
}
if not $*CURLEX.<!NEEDSIG> {
if $*CURLEX === $*UNIT {
return self.sorry("Placeholder variable $name may not be used outside of a block");
}
return self.sorry("Placeholder variable $name may not be used here because the surrounding$decl block takes no signature");
}
if $name ~~ /\:\:/ {
return self.sorry("Placeholder variable $name may not be package qualified");
}
my $varname = $name;
my $twigil = '';
my $signame = $varname;
if $varname ~~ s/<[ ^ : ]>// {
$twigil = $/.Str;
$signame = ($twigil eq ':' ?? ':' !! '') ~ $varname;
}
return self if $*CURLEX.{'%?PLACEHOLDERS'}{$signame}++;
if $sub.lexical_used($varname) || $sub.has_lexical($varname) {
return self.sorry("$varname has already been used as a non-placeholder in the surrounding$decl block,\n so you will confuse the reader if you suddenly declare $name here");
}
self.trymop({
self.check_categorical($varname);
$*CURLEX<!sub>.add_my_name($varname, :noinit, |mnode(self),
list => substr($varname,0,1) eq '@',
hash => substr($varname,0,1) eq '%');
});
self.mark_used($varname);
self;
}
}
augment class Op::ForLoop {
method statement_level() {
my $body = $*CURLEX<!sub>.lookup_lex($!sink)[4];
my $var = [ map { ::GLOBAL::NieczaActions.gensym },
0 ..^ +$body.signature.params ];
::Op::ImmedForLoop.new(source => $!source, var => $var,
sink => ::GLOBAL::OptBeta.make_call($!sink,
map { ::Op::LetVar.new(name => $_) }, @$var));
}
}
augment class Op::Lexical {
method to_bind($/, $ro, $rhs) {
my @lex = $*CURLEX<!sub>.lookup_lex($!name) or
($/.CURSOR.sorry("Cannot find definition for binding???"),
return ::Op::StatementList.new);
my $list = False;
my $type = $*CURLEX<!sub>.compile_get_pkg('Mu').xref;
given @lex[0] {
when 'simple' {
$list = ?(@lex[4] +& 24); # LIST | HASH from LISimple
$type = @lex[5] // $type;
}
when 'common' {
$list = substr(@lex[5],0,1) eq '%' || substr(@lex[5],0,1) eq '@';
}
default {
nextsame;
}
}
::Op::LexicalBind.new(name => $!name, :$ro, :$rhs, :$list, :$type);
}
}
augment class NieczaActions {
method package_var($/, $slot, $name, $path) {
$/.CURSOR.trymop({
$/.CURSOR.check_categorical($slot);
my $ref = $path.^can('xref') ?? $path.xref !!
$*CURLEX<!sub>.compile_get_pkg(@$path, :auto).xref;
$*CURLEX<!sub>.add_common_name($slot, $ref, $name, |mnode($/));
$/.CURSOR.mark_used($slot);
});
::Op::Lexical.new(|node($/), name => $slot);
}
method blockoid($/) {
# XXX horrible cheat, but my data structures aren't up to the task of
# $::UNIT being a class body &c.
if $/ eq '{YOU_ARE_HERE}' {
$*unit.bottom_ref = $*CURLEX<!sub>.xref;
$*CURLEX<!sub>.strong_used = True;
$*CURLEX<!sub>.create_static_pad;
loop (my $l = $*CURLEX<!sub>; $l; $l.=outer) {
# this isn't *quite* right, as it will cause declaring
# anything more in the same scope to fail.
$/.CURSOR.mark_used($_) for $l.lex_names;
}
make ::Op::YouAreHere.new(|node($/), unitname => $*UNITNAME);
} else {
make $<statementlist>.ast;
}
}
sub phaser($/, $ph, :$unique, :$topic, :$csp) {
my $sub = ($<blast> // $<block>).ast;
if $unique {
$/.CURSOR.sorry("Limit one $ph phaser per block, please.")
if any($sub.outer.children).is_phaser == ::Metamodel::Phaser.($ph);
$sub.code = ::Op::CatchyWrapper.new(inner => $sub.code);
}
$sub.outer.noninlinable;
$sub.is_phaser = +::Metamodel::Phaser.($ph);
if $topic {
$sub.has_lexical('$_') || $sub.add_my_name('$_');
$sub.parameterize_topic;
$sub.set_signature(Sig.simple('$_'));
}
$*CURLEX<!sub>.create_static_pad if $csp;
make ::Op::StatementList.new;
}
method install_sub($/, $sub, :$multiness is copy, :$scope is copy, :$class,
:$longname, :$method_type is copy, :$contextual is copy) {
$multiness ||= 'only';
my ($pkg, $name) = self.process_name($longname, :declaring);
if !$scope {
if !defined($name) {
$scope = 'anon';
} elsif defined($pkg) {
$scope = 'our';
} elsif defined($method_type) {
$scope = 'has';
} else {
$scope = 'my';
}
}
if $class eq 'Regex' {
my $/;
$*CURLEX<!name> = $name;
$*CURLEX<!cleanname !sym> =
!defined($name) ?? (Str, Str) !!
($name ~~ /\:sym\<(.*)\>/) ?? ($name.substr(0, $/.from), ~$0) !!
($name ~~ /\:(\w+)/) ?? ($name.substr(0, $/.from), ~$0) !!
($name, Str);
$multiness = 'multi' if defined $*CURLEX<!sym>;
$*CURLEX<!multi> = $multiness;
}
if $scope ne 'my' && $scope ne 'our' && $scope ne 'anon' && $scope ne 'has' {
$/.CURSOR.sorry("Illegal scope $scope for subroutine");
$scope = 'anon';
}
if $scope eq 'has' && !defined($method_type) {
$/.CURSOR.sorry('has scope-type is only valid for methods');
$scope = 'anon';
}
if $scope ne 'anon' && !defined($name) {
$/.CURSOR.sorry("Scope $scope requires a name");
$scope = 'anon';
}
if $scope ne 'our' && defined($pkg) {
$/.CURSOR.sorry("Double-colon-qualified subs must be our");
$scope = 'our';
}
if $scope eq 'anon' && $multiness ne 'only' {
$/.CURSOR.sorry("Multi routines must have a name");
$multiness = 'only';
}
if $contextual && (defined($method_type) || $scope ne 'my') {
$/.CURSOR.sorry("Context-named routines must by purely my-scoped");
$contextual = False;
}
$method_type = Str if $scope eq 'anon';
my $method_targ = $method_type && $sub.outer.body_of;
if !$method_targ && defined($method_type) {
$/.CURSOR.sorry("Methods must be used in some kind of package");
$method_type = Str;
}
if $method_targ && !$method_targ.can_add_method {
$/.CURSOR.sorry("A {$method_targ.WHAT} cannot have methods added");
$method_type = Str;
$method_targ = Any;
}
if $name ~~ Op && (!defined($method_type) || $scope ne 'has' ||
$method_targ.kind ne 'prole') {
$/.CURSOR.sorry("Computed names are only implemented for parametric roles");
$name = "placeholder";
}
my $bindlex = $scope eq 'my' || ($scope eq 'our' && !$pkg);
$sub.set_name(defined($method_type) ?? $method_targ.name ~ "." ~ $name !!
($name // 'ANON'));
$sub.set_class($class);
my $std = $/.CURSOR;
{
my $/;
if $sub.name ~~ /^(\w+)\:\<(.*)\>$/ {
my %new = %( $std.default_O(~$0, ~$1) );
$sub.extend.<prec> = %new;
}
}
my Str $symbol;
$/.CURSOR.trymop({
if $bindlex && $class eq 'Regex' {
$symbol = '&' ~ $name;
my $proto = $symbol;
$proto ~~ s/\:.*//;
$sub.outer.add_dispatcher($proto, |mnode($/))
if $multiness ne 'only' && !$sub.outer.has_lexical($proto);
$symbol ~= ":(!proto)" if $multiness eq 'proto';
} elsif $bindlex {
$symbol = '&' ~ $name;
$/.CURSOR.check_categorical($symbol);
if $multiness ne 'only' && !$sub.outer.has_lexical($symbol) {
$sub.outer.add_dispatcher($symbol, |mnode($/))
}
given $multiness {
when 'multi' { $symbol ~= ":({ self.gensym })"; }
when 'proto' { $symbol ~= ":(!proto)"; }
default {
$/.CURSOR.check_categorical($symbol);
}
}
} else {
$symbol = self.gensym;
}
$sub.set_outervar($symbol);
$sub.set_methodof(defined($method_type) ?? $method_targ !! Any);
$sub.outer.add_my_sub($symbol, $sub, |mnode($/));
if $multiness ne 'only' || $scope eq 'our' || $method_type {
$/.CURSOR.mark_used($symbol);
}
if defined($method_type) || $scope eq 'our' {
$sub.outer.create_static_pad;
}
if defined($method_type) {
if $sub.outer.augment_hack {
push $sub.outer.augment_hack,
[ $multiness, $method_type, $name, $symbol, $sub.xref ];
} else {
$method_targ.add_method($multiness, $method_type, $name,
$symbol, $sub.xref, |mnode($/));
}
}
if $scope eq 'our' {
$*unit.bind($pkg // $*unit.deref($sub.outer.cur_pkg),
"&$name", $sub.xref);
}
});
}
method routine_def ($/) {
$*CURLEX<!sub>.finish($<blockoid>.ast);
make ::Op::Lexical.new(|node($/), name => $*CURLEX<!sub>.outervar);
}
method open_package_def($, $/ = $*cursor) {
my $sub = $*CURLEX<!sub>;
if $*MULTINESS {
$/.CURSOR.sorry("Multi variables NYI");
}
if $*SCOPE eq 'augment' {
my ($obj) = self.process_name($<longname>, :clean);
$*AUGMENT_BUFFER = [];
$/.CURSOR.trymop({
die "Augment requires a target" unless $obj;
die "Illegal augment of a role" if $obj.kind eq 'role' | 'prole';
$sub.set_body_of($obj);
$sub.set_in_class($obj);
$sub.set_cur_pkg($obj);
$sub.set_name("augment-$obj.name()");
});
} else {
my $class = $*PKGDECL;
if $class eq 'role' && $<signature> {
$sub.set_signature($<signature>.ast);
$class = 'prole';
}
$/.CURSOR.trymop({
my ($lexvar, $obj) = self.do_new_package($/, sub => $sub.outer,
:$class, name => $<longname>, scope => $*SCOPE);
$sub.set_outervar($lexvar);
$sub.set_body_of($obj);
$sub.set_in_class($obj);
$sub.set_cur_pkg($obj);
self.process_block_traits($/, $<trait>);
$sub.set_name($*PKGDECL ~ "-" ~ $obj.name);
});
}
}
method package_def ($/) {
my $sub = $*CURLEX<!sub>;
my $obj = $sub.body_of;
my $bodyvar = self.gensym;
$sub.outer.add_my_sub($bodyvar, $sub);
my $ast = ($<blockoid> // $<statementlist>).ast;
if defined $*AUGMENT_BUFFER {
# generate an INIT block to do the augment
my $ph = $*unit.create_sub(
outer => $sub,
cur_pkg => $sub.cur_pkg,
name => "phaser-$sub.name()",
class => 'Code',
run_once => $sub.run_once);
my @ops;
for @( $*AUGMENT_BUFFER ) -> $mode, $name, $sym {
push @ops, CgOp._addmethod(CgOp.letvar('!mo'), $mode,
CgOp.str($name), CgOp.scopedlex($sym));
}
my $fin = CgOp.letn('!mo', CgOp.class_ref('mo', $obj),
@ops, CgOp._invalidate(CgOp.letvar('!mo')), CgOp.corelex('Nil'));
$ph.finish(::Op::CgOp.new(op => $fin));
$sub.create_static_pad;
$ph.set_phaser(+::Metamodel::Phaser::INIT);
make ::Op::CallSub.new(|node($/), invocant => mklex($/, $bodyvar));
}
else {
if $<stub> {
$*unit.stub_stash($/.from, $obj);
make mklex($/, $*CURLEX<!sub>.outervar);
}
else {
$/.CURSOR.trymop({ $obj.close; });
if $obj.kind eq 'prole' {
# return the frame object so that role instantiation can
# find the cloned methods
$ast = ::Op::StatementList.new(|node($/), children => [
$ast, mkcall($/, '&callframe') ]);
$sub.create_static_pad;
$obj.set_instantiation_block($sub);
make mklex($/, $*CURLEX<!sub>.outervar);
} else {
make ::Op::StatementList.new(|node($/), children => [
::Op::CallSub.new(invocant => mklex($/, $bodyvar)),
::Op::Lexical.new(name => $*CURLEX<!sub>.outervar) ]);
}
}
}
$sub.finish($ast);
}
method do_new_package($/, :$sub = $*CURLEX<!sub>, :$scope!, :$name!, :$class!,
:$exports) {
$scope := $scope || 'our';
if $scope ne 'our' && $scope ne 'my' && $scope ne 'anon' {
$/.CURSOR.sorry("Invalid packageoid scope $scope");
$scope := 'anon';
}
my ($pkg, $head) = self.process_name($name, :declaring, :clean);
if defined($pkg) && $scope ne 'our' {
$/.CURSOR.sorry("Pathed definitions require our scope");
$scope := 'our';
}
if !$head {
$scope := 'anon';
$head := 'ANON';
}
my $npkg;
my $lexname;
$/.CURSOR.trymop({
my $old;
if $scope ne 'anon' && !$pkg && $sub.has_lexical($head) {
my @linfo = $sub.lookup_lex(head);
die "Cannot resume definition - $head not a packageoid"
unless @linfo[0] eq 'package';
$old = @linfo[4];
} elsif defined $pkg {
$old = $*unit.get($pkg.who, $head);
}
my $lexed_already;
if $old && ($old.?kind // '') eq $class && !$old.closed {
$npkg = $old;
$lexed_already = True;
} elsif $scope eq 'our' {
my $opkg = $pkg // $sub.cur_pkg;
$npkg = $*unit.create_type(name => $head, :$class,
who => $opkg.who ~ '::' ~ $head);
$*unit.bind($opkg.who, $head, $npkg, |mnode($/));
} else {
my $id = $*unit.anon_stash;
$npkg = $*unit.create_type(name => $head, :$class,
who => "::$id");
$*unit.bind("", $id, $npkg, |mnode($/));
}
$lexname = (!$lexed_already && $scope ne 'anon' && !defined($pkg))
?? $head !! self.gensym;
$sub.add_my_stash($lexname, $npkg, |mnode($/));
$sub.add_exports($head, $npkg, $exports) if $exports;
});
$lexname, $npkg
}
method process_block_traits($/, @tr) {
my $sub = $*CURLEX<!sub>;
my $pack = $sub.body_of;
for @tr -> $T {
my $tr = $T.ast;
if $pack && $tr<name> {
my $super = $tr<name>;
$T.CURSOR.sorry("superclass $super.name() declared outside of any class"),
next unless $sub.body_of;
$T.CURSOR.sorry("superclass $super.name() declared in an augment"),
next if $sub.augmenting;
$T.CURSOR.sorry("cannot declare a superclass in this kind of package"),
next if !$*unit.deref($pack).^can('add_super');
$T.CURSOR.trymop({
$*unit.deref($pack).add_super($super.xref);
});
} elsif $pack && $tr<export> {
my @exports = @( $tr<export> );
$sub.outer.add_exports($*unit.deref($pack).name, $pack, @exports);
} elsif !$pack && $tr<export> {
my @exports = @( $tr<export> );
$sub.outer.add_exports('&'~$sub.name, $sub.xref, @exports);
$sub.strong_used = True;
$sub.outer.create_static_pad;
$/.CURSOR.mark_used($sub.outervar)
if defined $sub.outervar;
} elsif !$pack && $tr<nobinder> {
$sub.set_signature(Any);
} elsif !$pack && grep { defined $tr{$_} }, <looser tighter equiv> {
my $rel = $tr.keys.[0];
my $to = $tr.values.[0];
$to = $to.inside if $to ~~ ::Op::Paren;
$to = $to.children[0] if $to ~~ ::Op::StatementList && $to.children == 1;
my $oprec;
if $to ~~ ::Op::Lexical {
$oprec = $T.CURSOR.function_O($to.name);
} elsif $to ~~ ::Op::StringLiteral && $sub.name ~~ /^(\w+)\:\<.*\>$/ {
$oprec = $T.CURSOR.cat_O(~$0, $to.text);
} else {
$T.CURSOR.sorry("Cannot interpret operator reference");
next;
}
unless $sub.extend<prec> {
$T.CURSOR.sorry("Target does not seem to be an operator");
next;
}
unless $oprec {
$T.CURSOR.sorry("No precedence available for reference target");
next;
}
if $rel eq 'equiv' {
my %copy = %$oprec;
$sub.extend.<prec> = %copy;
} else {
$sub.extend.<prec><prec> = $oprec.<prec>;
}
$sub.extend.<prec><prec> ~~ s/\=/<=/ if $rel eq 'looser';
$sub.extend.<prec><prec> ~~ s/\=/>=/ if $rel eq 'tighter';
} elsif !$pack && $tr<assoc> {
my $arg = ~self.trivial_eval($T, $tr<assoc>);
unless $sub.extend<prec> {
$T.CURSOR.sorry("Target does not seem to be an operator");
next;
}
my @valid = < left right non list unary chain >;
unless grep $arg, @valid {
$T.CURSOR.sorry("Invalid associativity $arg");
next;
}
$sub.extend.<prec><assoc> = $arg;
} elsif !$pack && $tr<Niecza::absprec> {
my $arg = ~self.trivial_eval($T, $tr<Niecza::absprec>);
unless $sub.extend.<prec> {
$T.CURSOR.sorry("Target does not seem to be an operator");
next;
}
$sub.extend.<prec><prec> = $arg;
$sub.extend.<prec><dba> = "like $sub.name()";
} elsif !$pack && $tr<Niecza::builtin> {
$sub.extend.<builtin> = [
self.trivial_eval($T, $tr<Niecza::builtin>) ];
} elsif !$pack && $tr<return_pass> {
$sub.returnable = False;
} elsif !$pack && $tr<of> {
} elsif !$pack && $tr<rw> {
} elsif !$pack && $tr<unsafe> {
$sub.unsafe = True;
} else {
$T.CURSOR.sorry("Unhandled trait $tr.keys[0] for this context");
}
}
}
method comp_unit($/) {
$*CURLEX{'!sub'}.finish($<statementlist>.ast);
make $*unit;
}
method process_name($/, :$declaring, :$defer, :$clean) {
return () unless defined $/;
my @ns = @( $<name>.ast<names> );
my $ext = '';
my $trail = @ns && !defined @ns[*-1];
pop @ns if $trail;
if !$clean {
for @( $<colonpair> ) {
$ext ~= $_.ast<ext> // (
$_.CURSOR.sorry("Invalid colonpair for name extension");
"";
)
}
}
for $defer ?? () !! @ns.grep(Op) {
$_ = ~self.trivial_eval($/, $_);
# XXX should this always stringify?
if $_ ~~ Cool {
$_ = ~$_;
} else {
$_ = "XXX";
$/.CURSOR.sorry("Name components must evaluate to strings");
}
}
if $declaring {
# class :: is ... { } is a placeholder for a lack of name
return () if $trail && !@ns;
$/.CURSOR.sorry("Illegal explicit declaration of a symbol table")
if $trail;
die "Unimplemented" if $defer;
return () unless @ns;
my $head = pop(@ns) ~ $ext;
return Any, $head unless @ns;
# the remainder is assumed to name an existing or new package
my $pkg;
$/.CURSOR.trymop({
$pkg = $*CURLEX<!sub>.compile_get_pkg(@ns, :auto);
});
return $pkg, $head;
}
else {
if $defer {
# The stuff returned here is processed by the variable rule,
# and also by method call generation
goto "dyn" if $trail;
goto "dyn" if $_.^isa(Op) for @ns;
my $pkg;
my @tail = @ns;
my $head = pop(@tail) ~ $ext;
unless @tail {
goto "dyn" if $head eq any < MY OUR CORE DYNAMIC GLOBAL CALLER OUTER UNIT SETTING PROCESS COMPILING PARENT CLR >;
return { name => $head } unless @tail;
}
try { $pkg = $*CURLEX<!sub>.compile_get_pkg(@tail, :auto) };
goto "dyn" unless $pkg;
return { name => $head, pkg => $pkg };
dyn:
my @bits = map { $_, '::' }, @ns;
pop @bits if @bits;
push @bits, '::' if $trail;
return { iname => mkstringycat($/, @bits) };
}
$/.CURSOR.sorry("Class required, but symbol table name used instead")
if $trail;
return () unless @ns;
my $head = pop(@ns) ~ $ext;
my $pkg;
$/.CURSOR.trymop({
$pkg = $*CURLEX<!sub>.compile_get_pkg(@ns, $head);
});
return $pkg;
}
}
method term:identifier ($/) {
my $id = $<identifier>.ast;
my $sal = $<args> ?? ($<args>.ast // []) !! [];
# TODO: support zero-D slicels
if $sal > 1 {
$/.CURSOR.sorry("Slicel lists are NYI");
make ::Op::StatementList.new;
return;
}
if $id eq any < MY OUR CORE DYNAMIC GLOBAL CALLER OUTER UNIT SETTING PROCESS COMPILING PARENT CLR > {
make Op::IndirectVar.new(|node($/),
name => Op::StringLiteral.new(text => $id));
return;
}
my $is_name = $/.CURSOR.is_name(~$<identifier>);
if $is_name && $<args>.chars == 0 {
make mklex($/, $id);
return;
}
my $args = $sal[0] // [];
make ::Op::CallSub.new(|node($/),
invocant => mklex($/, $is_name ?? $id !! '&' ~ $id),
args => $args);
}
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 "" {
my $start_nl = !$n.from || "\r\n".index(
substr($n.orig, $n.from-1, 1)).defined;
$ast = $ast.split(/ ^^ [ <?{ $start_nl }> || <?after <[\r\n]> > ]
<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::Paren.new(|node($/),
inside => ::Op::SimpleParcel.new(|node($/), items => @tok)));
}
}
elsif $post eq 'path' {
# TODO could stand to be a lot fancier.
make ::Op::CallMethod.new(|node($/), receiver => $/.ast, :name<IO>);
}
elsif $post eq 'run' {
make mkcall($/, 'rungather', $/.ast);
}
else {
$/.CURSOR.sorry("Unhandled postprocessor $post");
}
$/.ast;
}
method backslash:qq ($/) { make $<quote>.ast }
}
CgOp._register_ops: < who sc_root sc_indir temporize
>;
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 @*INC;
my $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,
),
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 "";
}
Jump to Line
Something went wrong with that request. Please try again.