Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Tree: 62645be2fd
Fetching contributors…

Cannot retrieve contributors at this time

854 lines (774 sloc) 28.635 kB
# vim: ft=perl6
use MONKEY_TYPING;
use STD;
use Stash;
use NAME;
use JSYNC;
sub _subst($M is rw, $text is rw, $regex, $repl) {
$text = $text.Str;
$M = ($text ~~ $regex);
if $M {
$text = $text.substr(0, $M.from) ~
(($repl ~~ Str) ?? $repl !! $repl()) ~
$text.substr($M.to, $text.chars - $M.to);
}
?$M;
}
augment class Cool {
method lc() { Q:CgOp { (box Str (str_tolower (unbox str (@ {self.Str})))) }}
method uc() { Q:CgOp { (box Str (str_toupper (unbox str (@ {self.Str})))) }}
}
sub lc($s) { $s.Str.lc }
sub uc($s) { $s.Str.uc }
my %term = (:dba('term') , :prec<z=>);
my %methodcall = (:dba('methodcall') , :prec<y=>, :assoc<unary>, :uassoc<left>, :fiddly, :!pure);
my %autoincrement = (:dba('autoincrement') , :prec<x=>, :assoc<unary>, :uassoc<non>, :!pure);
my %exponentiation = (:dba('exponentiation') , :prec<w=>, :assoc<right>, :pure);
my %symbolic_unary = (:dba('symbolic unary') , :prec<v=>, :assoc<unary>, :uassoc<left>, :pure);
my %multiplicative = (:dba('multiplicative') , :prec<u=>, :assoc<left>, :pure);
my %additive = (:dba('additive') , :prec<t=>, :assoc<left>, :pure);
my %replication = (:dba('replication') , :prec<s=>, :assoc<left>, :pure);
my %concatenation = (:dba('concatenation') , :prec<r=>, :assoc<list>, :pure);
my %junctive_and = (:dba('junctive and') , :prec<q=>, :assoc<list>, :pure);
my %junctive_or = (:dba('junctive or') , :prec<p=>, :assoc<list>, :pure);
my %named_unary = (:dba('named unary') , :prec<o=>, :assoc<unary>, :uassoc<left>, :pure);
my %structural = (:dba('structural infix'), :prec<n=>, :assoc<non>, :diffy);
my %chaining = (:dba('chaining') , :prec<m=>, :assoc<chain>, :diffy, :iffy, :pure);
my %tight_and = (:dba('tight and') , :prec<l=>, :assoc<list>);
my %tight_or = (:dba('tight or') , :prec<k=>, :assoc<list>);
my %conditional = (:dba('conditional') , :prec<j=>, :assoc<right>, :fiddly);
my %item_assignment = (:dba('item assignment') , :prec<i=>, :assoc<right>, :!pure);
my %list_assignment = (:dba('list assignment') , :prec<i=>, :assoc<right>, :sub<e=>, :fiddly, :!pure);
my %loose_unary = (:dba('loose unary') , :prec<h=>, :assoc<unary>, :uassoc<left>, :pure);
my %comma = (:dba('comma') , :prec<g=>, :assoc<list>, :nextterm<nulltermish>, :fiddly, :pure);
my %list_infix = (:dba('list infix') , :prec<f=>, :assoc<list>, :pure);
my %list_prefix = (:dba('list prefix') , :prec<e=>, :assoc<unary>, :uassoc<left>);
my %loose_and = (:dba('loose and') , :prec<d=>, :assoc<list>);
my %loose_or = (:dba('loose or') , :prec<c=>, :assoc<list>);
my %sequencer = (:dba('sequencer') , :prec<b=>, :assoc<list>, :nextterm<statement>, :fiddly);
my %LOOSEST = (:dba('LOOSEST') , :prec<a=!>);
my %terminator = (:dba('terminator') , :prec<a=>, :assoc<list>);
# "epsilon" tighter than terminator
#constant $LOOSEST = %LOOSEST<prec>;
constant $LOOSEST = "a=!"; # XXX preceding line is busted
constant $item_assignment_prec = 'i=';
constant $methodcall_prec = 'y=';
augment class List {
}
augment class Mu {
}
augment class Cool {
}
augment class Any {
}
augment class Stash {
method iterator () { self.list.iterator }
}
augment class NAME {
}
augment class Regex {
}
augment class Match {
method trim_heredoc () { self } # NYI
}
augment class Hash {
}
augment class Cursor {
method suppose($rx) {
my $*IN_SUPPOSE = True;
my $*FATALS = 0;
my @*WORRIES;
my %*WORRIES;
my $*HIGHWATER = -1;
my $*HIGHEXPECT = {};
try {
my $ret = first($rx(self));
if ($ret) { return $ret }
};
return ();
}
token alpha {
<+INTERNAL::alpha+[_]> \w*
}
}
package Niecza {
grammar Grammar is STD {
grammar CgOp is STD {
rule nibbler { <cgexp> }
token category:cgexp { <sym> }
proto token cgexp {*}
token cgopname { <-[ ' " ( ) { } \[ \] \s ]> + }
token cgexp:op { <[ ( \[ ]>:s {} <cgopname> [ <cgexp> ]* <[ ) \] ]> }
token cgexp:name { <cgopname> }
token cgexp:quote { <?before <[ ' " ]>> {} [ :lang(%*LANG<MAIN>) <quote> ] }
token cgexp:decint { <decint> }
token cgexp:p6exp { :lang(%*LANG<MAIN>) '{' ~ '}' <statementlist> }
token cgexp:bad { <!before <[ ) \] ]> > {}
[ <?stdstopper> <.panic "Missing cgop"> ]
<.panic: "Unparsable cgop">
}
}
grammar Q is STD::Q { #} {
method tweak(:$CgOp, *%_) {
if $CgOp.defined { self.cursor_fresh(Niecza::Grammar::CgOp) }
else { nextwith(self, |%_) }
}
}
grammar P6 is STD::P6 {
method unitstart() {
%*LANG<Q> = Niecza::Grammar::Q ;
%*LANG<MAIN> = Niecza::Grammar::P6 ;
self;
}
}
method p6class () { Niecza::Grammar::P6 }
}
}
augment class STD {
our $ALL;
method lookup_dynvar($name) { Any } # NYI
method check_old_cclass($text) { } # NYI
method canonicalize_name($n) {
my $M;
my $name = $n;
if $M = first(/(< $ @ % & >)( \^ || \: <!before \:> )/(Cursor.new($name))) {
$name = $M[0] ~ substr($name, $M.to);
}
if $name.chars >= 2 && substr($name, $name.chars - 2, 2) ~~ / \: < U D _ > / {
$name = $name.substr(0, $name.chars - 2);
}
return $name unless $name ~~ /::/;
self.panic("Can't canonicalize a run-time name at compile time: $name") if $name ~~ / '::(' /;
if $M = $name ~~ /^ (< $ @ % & > < ! * = ? : ^ . >?) (.* '::')/ {
$name = $M[1] ~ "<" ~ $M[0] ~ substr($name, $M.to) ~ ">";
}
my $vname;
if $M = $name ~~ /'::<'/ && $name.substr($name.chars - 1, 1) eq '>' {
$name = substr($name, 0, $M.from);
$vname = substr($name, $M.to, $name.chars - $M.to - 1);
}
my @components;
while $M = $name ~~ / '::' / {
push @components, $name.substr(0, $M.to);
$name = substr($name, $M.to);
}
push @components, $name;
shift(@components) while @components and @components[0] eq '';
if (defined $vname) {
if @components {
my $last := @components[+@components - 1];
$last ~= '::' if $last.chars < 2 || $last.substr($last.chars - 2, 2) ne '::';
}
push(@components, $vname) if defined $vname;
}
@components;
}
method EXPR ($preclvl?) {
my $preclim = $preclvl ?? $preclvl.<prec> // $LOOSEST !! $LOOSEST;
my $*LEFTSIGIL = ''; # XXX P6
my $*PRECLIM = $preclim;
my @termstack;
my @opstack;
my $termish = 'termish';
sub _top(@a) { @a[ @a.elems - 1 ] }
my $state;
my $here;
sub reduce() {
self.deb("entering reduce, termstack == ", +@termstack, " opstack == ", +@opstack) if $DEBUG::EXPR;
my $op = pop @opstack;
my $sym = $op<sym>;
my $assoc = $op<O><assoc> // 'unary';
if $assoc eq 'chain' {
self.deb("reducing chain") if $DEBUG::EXPR;
my @chain;
push @chain, pop(@termstack);
push @chain, $op;
while @opstack {
last if $op<O><prec> ne _top(@opstack)<O><prec>;
push @chain, pop(@termstack);
push @chain, pop(@opstack);
}
push @chain, pop(@termstack);
my $endpos = @chain[0].to;
@chain = reverse @chain if (+@chain) > 1;
my $startpos = @chain[0].from;
my $i = True;
my @caplist;
for @chain -> $c {
push @caplist, ($i ?? 'term' !! 'op') => $c;
$i = !$i;
}
push @termstack, Match.synthetic(
:captures(@caplist, :_arity<CHAIN>, :chain(@chain)),
:method<CHAIN>,
:cursor(self),
:from($startpos),
:to($endpos));
}
elsif $assoc eq 'list' {
self.deb("reducing list") if $DEBUG::EXPR;
my @list;
my @delims = $op;
push @list, pop(@termstack);
while @opstack {
self.deb($sym ~ " vs " ~ _top(@opstack)<sym>) if $DEBUG::EXPR;
last if $sym ne _top(@opstack)<sym>;
if @termstack and defined @termstack[0] {
push @list, pop(@termstack);
}
else {
self.worry("Missing term in " ~ $sym ~ " list");
}
push @delims, pop(@opstack);
}
if @termstack and defined @termstack[0] {
push @list, pop(@termstack);
}
else {
self.worry("Missing final term in '" ~ $sym ~ "' list");
}
@list = grep *.defined, @list;
my $endpos = @list[0].to;
@list = reverse @list if (+@list) > 1;
my $startpos = @list[0].from;
@delims = reverse @delims if (+@delims) > 1;
my @caps;
if @list {
push @caps, (elem => @list[0]) if @list[0];
my $i = 0;
while $i < (+@delims)-1 {
my $d = @delims[$i];
my $l = @list[$i+1];
push @caps, (delim => $d);
push @caps, (elem => $l) if $l; # nullterm?
$i++;
}
}
push @termstack, Match.synthetic(
:method<LIST>, :cursor(self),
:from($startpos), :to($endpos),
:captures(@caps, :_arity<LIST>, :delims(@delims),
:list(@list), :O($op<O>), :sym($sym)));
}
elsif $assoc eq 'unary' {
self.deb("reducing") if $DEBUG::EXPR;
self.deb("Termstack size: ", +@termstack) if $DEBUG::EXPR;
my $arg = pop @termstack;
if $arg.from < $op.from { # postfix
push @termstack, Match.synthetic(
:cursor(self), :to($op.to), :from($arg.from),
:captures(arg => $arg, op => $op, _arity => 'UNARY'),
:method<POSTFIX>);
}
elsif $arg.to > $op.to { # prefix
push @termstack, Match.synthetic(
:cursor(self), :to($arg.to), :from($op.from),
:captures(op => $op, arg => $arg, _arity => 'UNARY'),
:method<PREFIX>);
}
}
else {
self.deb("reducing") if $DEBUG::EXPR;
self.deb("Termstack size: ", +@termstack) if $DEBUG::EXPR;
my $right = pop @termstack;
my $left = pop @termstack;
push @termstack, Match.synthetic(
:to($right.to), :from($left.from), :cursor(self),
:captures(:left($left), :infix($op), :right($right),
:_arity<BINARY>), :method<INFIX>);
# self.deb(_top(@termstack).dump) if $DEBUG::EXPR;
my $ck;
if $ck = $op<O><_reducecheck> {
_top(@termstack) = $ck(self,_top(@termstack));
}
}
}
sub termstate() {
$here.deb("Looking for a term") if $DEBUG::EXPR;
$here.deb("Top of opstack is ", _top(@opstack).dump) if $DEBUG::EXPR;
$*LEFTSIGIL = _top(@opstack)<O><prec> gt $item_assignment_prec
?? '@' !! ''; # XXX P6
my ($term) =
($termish eq 'termish') ?? $here.termish !!
($termish eq 'nulltermish') ?? $here.nulltermish !!
($termish eq 'statement') ?? $here.statement !!
($termish eq 'dottyopish') ?? $here.dottyopish !!
die "weird value of $termish";
if not $term {
$here.deb("Didn't find it") if $DEBUG::EXPR;
$here.panic("Bogus term") if (+@opstack) > 1;
return 2;
}
$here.deb("Found term to {$term.to}") if $DEBUG::EXPR;
$here = $here.cursor($term.to);
$termish = 'termish';
my @PRE = @( $term<PRE> // [] );
my @POST = reverse @( $term<POST> // [] );
# interleave prefix and postfix, pretend they're infixish
# note that we push loose stuff onto opstack before tight stuff
while @PRE and @POST {
my $postO = @POST[0]<O>;
my $preO = @PRE[0]<O>;
if $postO<prec> lt $preO<prec> {
push @opstack, shift @POST;
}
elsif $postO<prec> gt $preO<prec> {
push @opstack, shift @PRE;
}
elsif $postO<uassoc> eq 'left' {
push @opstack, shift @POST;
}
elsif $postO<uassoc> eq 'right' {
push @opstack, shift @PRE;
}
else {
$here.sorry('"' ~ @PRE[0]<sym> ~ '" and "' ~ @POST[0]<sym> ~ '" are not associative');
}
}
push @opstack, @PRE,@POST;
push @termstack, $term<term>;
$here.deb("after push: " ~ (+@termstack)) if $DEBUG::EXPR;
# say "methodcall break" if $preclim eq $methodcall_prec; # in interpolation, probably # XXX P6
$state = &infixstate;
return 0;
}
# std bug sees infixstate as unused
sub infixstate() { #OK
$here.deb("Looking for an infix") if $DEBUG::EXPR;
return 1 if (@*MEMOS[$here.pos]<endstmt> // 0) == 2; # XXX P6
# If this isn't here, then "$foo.method" will try to parse
# .method as an infix, and panic. No infix operator is
# tighter than this anyhow.
return 1 if $preclim ge $methodcall_prec;
my ($ws) = $here.ws;
$here = $here.cursor($ws.to);
my ($infix) = $here.infixish;
return 1 unless $infix;
my $inO = $infix<O>;
my $inprec = $inO<prec>;
if not defined $inprec {
die "No prec given in infix!";
}
if $inprec le $preclim {
if $preclim ne $LOOSEST {
my $dba = $*prevlevel.<dba>;
my $h = $*HIGHEXPECT;
%$h = ();
$h.{"an infix operator with precedence tighter than $dba"} = 1;
}
return 1;
}
$here = $here.cursor($infix.to);
($ws,) = $here.ws;
$here = $here.cursor($ws.to);
# substitute precedence for listops
$inO<prec> = $inO<sub> if $inO<sub>;
# Does new infix (or terminator) force any reductions?
while _top(@opstack)<O><prec> gt $inprec {
reduce;
}
# Not much point in reducing the sentinels...
return 1 if $inprec lt $LOOSEST;
if $infix<fake> {
push @opstack, $infix;
reduce();
return 0; # not really an infix, so keep trying
}
# Equal precedence, so use associativity to decide.
if _top(@opstack)<O><prec> eq $inprec {
my $assoc = 1;
my $atype = $inO<assoc>;
if $atype eq 'non' { $assoc = 0; }
elsif $atype eq 'left' { reduce() } # reduce immediately
elsif $atype eq 'right' { } # just shift
elsif $atype eq 'chain' { } # just shift
elsif $atype eq 'unary' { } # just shift
elsif $atype eq 'list' {
$assoc = 0 unless $infix<sym> eq _top(@opstack)<sym>;
}
else { $here.panic('Unknown associativity "' ~ $_ ~ '" for "' ~ $infix<sym> ~ '"') }
if not $assoc {
$here.sorry('"' ~ _top(@opstack)<sym> ~ '" and "' ~ $infix.Str ~ '" are non-associative and require parens');
}
}
$termish = $inO<nextterm> if $inO<nextterm>;
push @opstack, $infix; # The Shift
$state = &termstate;
return 0;
}
push @opstack, { 'O' => %terminator, 'sym' => '' }; # (just a sentinel value)
self.deb(@opstack.dump) if $DEBUG::EXPR;
$here = self;
self.deb("In EXPR, at {$here.pos}") if $DEBUG::EXPR;
my $stop = 0;
$state = &termstate;
until $stop {
$here.deb("At {$here.pos}, {@opstack.dump}; {@termstack.dump}") if $DEBUG::EXPR;
$stop = $state();
}
$here.deb("Stop code $stop") if $DEBUG::EXPR;
return () if $stop == 2;
reduce() while +@opstack > 1;
$here.deb("After final reduction, ", @termstack.dump, @opstack.dump) if $DEBUG::EXPR;
if @termstack {
+@termstack == 1 or $here.panic("Internal operator parser error, termstack == " ~ (+@termstack));
return @( Match.synthetic(:to($here.pos), :from(self.pos),
:cursor(self), :method<EXPR>,
:captures( root => @termstack[0] )), );
}
return ();
}
method do_use($module,$args) {
self.do_need($module);
self.do_import($module,$args);
self;
}
method do_need($mo) {
my $module = $mo.Str;
my $topsym;
try { $topsym = self.sys_load_modinfo($module); }
if !$topsym {
self.panic("Could not load $module");
}
self.add_my_name($module);
$*DECLARAND<really> = $topsym;
self;
}
method sys_load_modinfo($module) {
# TODO: Implement compile-on-demand. Requires some kind of modtime API.
from-jsync(slurp($module ~ ".syml"));
}
method load_lex($setting) {
if $setting eq 'NULL' {
my $id = "MY:file<NULL.pad>:line(1):pos(0)";
my $core = Stash.new('!id' => [$id], '!file' => 'NULL.pad',
'!line' => 1);
return Stash.new('CORE' => $core, 'MY:file<NULL.pad>' => $core,
'SETTING' => $core, $id => $core);
}
return Stash.new(%( from-jsync(slurp($setting ~ ".syml")) ));
}
method do_import($m, $args) { #, perl6.vim stupidity
my @imports;
my $module = $m.Str;
my $M;
if $M = ($module ~~ /(class|module|role|package)\s+(\S+)/) {
$module = $M[1];
}
my $pkg = self.find_stash($module);
if $pkg<really> {
$pkg = $pkg<really><UNIT>;
}
else {
$pkg = self.find_stash($module ~ '::');
}
if $args {
my $text = $args.Str;
return self unless $text;
while _subst($M, $text, /^\s*\:?(OUR|MY|STATE|HAS|AUGMENT|SUPERSEDE)?\<(.*?)\>\,?/, "") {
my $scope = lc($M[0] // 'my');
my $imports = $M[1].Str;
my $*SCOPE = $scope;
@imports = $imports.comb(/\S+/);
for @imports -> $i {
my $imp = $i;
if $pkg {
if _subst($M, $imp, /^\:/, "") {
my @tagimports;
try { @tagimports = $pkg<EXPORT::>{$imp}.keys }
self.do_import_aliases($pkg, @tagimports);
}
elsif $pkg{$imp}<export> {
self.add_my_name($imp, $pkg{$imp});
}
elsif $pkg{'&'~$imp}<export> {
$imp = '&' ~ $imp;
self.add_my_name($imp, $pkg{$imp});
}
elsif $pkg{$imp} {
self.worry("Can't import $imp because it's not exported by $module");
next;
}
}
else {
self.add_my_name($imp);
}
}
}
}
else {
return self unless $pkg;
try { @imports = $pkg<EXPORT::><DEFAULT::>.keys };
my $*SCOPE = 'my';
self.do_import_aliases($pkg, @imports);
}
self;
}
method do_import_aliases($pkg, *@names) {
# say "attempting to import @names";
for @names -> $n {
next if $n ~~ /^\!/;
next if $n ~~ /^PARENT\:\:/;
next if $n ~~ /^OUTER\:\:/;
self.add_my_name($n, $pkg{$n});
}
self;
}
}
augment class STD::P6 {
my %deftrap = (
:say, :print, :abs, :alarm, :chomp, :chop, :chr, :chroot, :cos,
:defined, :eval, :exp, :glob, :lc, :lcfirst, :log, :lstat, :mkdir,
:ord, :readlink, :readpipe, :require, :reverse, :rmdir, :sin,
:split, :sqrt, :stat, :uc, :ucfirst, :unlink,
:WHAT, :WHICH, :WHERE, :HOW, :WHENCE, :VAR,
);
token term:identifier
{
:my $name;
:my $pos;
:my $isname = 0;
<identifier> <?before [<unsp>|'(']? > <![:]>
{{
$name = $<identifier>.Str;
$pos = $¢.pos;
$isname = $¢.is_name($name);
$¢.check_nodecl($name) if $isname;
}}
<args($isname)>
{ self.add_mystery($<identifier>,$pos,substr(self.orig,$pos,1)) unless $<args><invocant>; }
{{
if $*BORG and $*BORG.<block> {
if not $*BORG.<name> {
$*BORG.<culprit> = self.cursor($pos);
$*BORG.<name> = $name;
}
}
if %deftrap{$name} {
my $al = $<args><arglist>[0];
my $ok = 0;
$ok = 1 if $al and $al.from != $al.to;
$ok = 1 if $<args><semiarglist>;
if not $ok {
self.cursor($<identifier>.to).worryobs("bare '$name'", ".$name if you meant \$_, or use an explicit invocant or argument");
}
}
}}
<O(|%term)>
}
token term:name
{
:my $name;
:my $pos;
<longname>
{
$name = $<longname>.Str;
$pos = $¢.pos;
}
[
|| <?{
$¢.is_name($name) or substr($name,0,2) eq '::'
}>
{ $¢.check_nodecl($name); }
# parametric type?
:dba('type parameter')
<.unsp>? [ <?before '['> <postcircumfix> ]?
:dba('namespace variable lookup')
[
<?after '::'>
<?before [ '«' | '<' | '{' | '<<' ] > <postcircumfix>
{ $*VAR = Match.synthetic(:cursor($¢), :from(self.pos), :to($¢.pos), :captures(), :method<Str>) }
]?
# unrecognized names are assumed to be post-declared listops.
|| <args> { self.add_mystery($<longname>,$pos,'termish') unless $<args><invocant>; }
{{
if $*BORG and $*BORG.<block> {
if not $*BORG.<name> {
$*BORG.<culprit> = self.cursor($pos);
$*BORG.<name> = $*BORG<name> // $name;
}
}
}}
]
<O(|%term)>
}
token arglist {
:my $inv_ok = $*INVOCANT_OK;
:my $*endargs = 0;
:my $*GOAL ::= 'endargs';
:my $*QSIGIL ::= '';
<.ws>
:dba('argument list')
[
| <?stdstopper>
| <EXPR(item %list_prefix)> {{
my $delims = $<EXPR><root><delims>;
for @$delims -> $d {
if $d.<infix><wascolon> // '' {
if $inv_ok {
$*INVOCANT_IS = $<EXPR><root><list>[0];
}
}
}
}}
]
}
method checkyada {
try {
my $statements = self.<blockoid><statementlist><statement>;
my $startsym = $statements[0]<EXPR><root><sym> // '';
if $startsym eq '...' { $*DECLARAND<stub> = 1 }
elsif $startsym eq '!!!' { $*DECLARAND<stub> = 1 }
elsif $startsym eq '???' { $*DECLARAND<stub> = 1 }
elsif $startsym eq '*' {
if $*MULTINESS eq 'proto' and $statements.elems == 1 {
self.<blockoid>:delete;
self.<onlystar> = 1;
}
}
}
return self;
}
token statement {
:my $*endargs = -1;
:my $*QSIGIL ::= 0;
<!before <[\)\]\}]> >
<!stopper>
<!before $>
# this could either be a statement that follows a declaration
# or a statement that is within the block of a code declaration
:lang( %*LANG<MAIN> )
<!!{ $*LASTSTATE = $¢.pos; True }>
# <!before $ >
[
| <label> <statement>
| <statement_control>
| <EXPR>
:dba('statement end')
[
|| <?{ (@*MEMOS[$¢.pos]<endstmt> // 0) == 2 }> # no mod after end-line curly
||
:dba('statement modifier')
<.ws>
[
| <statement_mod_loop>
{{
my $sp = $<EXPR><root><statement_prefix>;
if $sp and $sp<sym> eq 'do' {
my $s = $<statement_mod_loop>[0]<sym>;
$¢.obs("do...$s" ,"repeat...$s");
}
}}
| <statement_mod_cond>
:dba('statement modifier loop')
[
|| <?{ (@*MEMOS[$¢.pos]<endstmt> // 0) == 2 }>
|| <.ws> <statement_mod_loop>?
]
]?
]
| <?before ';'>
| <?before <stopper> >
| {} <.panic: "Bogus statement">
]
# Is there more on same line after a block?
[ <?{ (@*MEMOS[@*MEMOS[$¢.pos]<ws>//$¢.pos]<endargs>//0) == 1 }>
\h*
<!before ';' | ')' | ']' | '}' >
<!infixstopper>
{ $*HIGHWATER = $¢.pos = @*MEMOS[$¢.pos]<ws>//$¢.pos; }
<.panic: "Strange text after block (missing comma, semicolon, comment marker?)">
]?
}
}
augment class Cursor {
our $RED = "\e[31m";
our $GREEN = "\e[32m";
our $YELLOW = "\e[33m";
our $CLEAR = "\e[37m";
}
sub compiler(:$filename, :$text, :$settingname, :$niecza) {
my $*SETTINGNAME = $settingname;
my @*MEMOS;
my $*FILE = { name => $filename };
my @*ACTIVE;
my $*HIGHWATER = 0;
my $*HIGHEXPECT = {};
my $*HIGHMESS = "";
my $*LASTSTATE = 0;
my $*IN_PANIC = 0;
my $*IN_SUPPOSE = 0;
my $*FATALS = 0;
$DEBUG::EXPR = False;
$STD::DEBUG::EXPR = False;
$STD::DEBUG::symtab = False;
my $*LAST_NIBBLE = 0;
my $*LAST_NIBBLE_START = 0;
my $*LAST_NIBBLE_MULTILINE = 0;
my $*LAST_NIBBLE_MULTILINE_START = 0;
my $*GOAL = "(eof)";
my $*SETTING; my $*CORE; my $*GLOBAL; my $*UNIT; my $*YOU_WERE_HERE;
my $*CCSTATE; my $*BORG; my %*RX; my $*XACT; my $*VAR; my $*IN_REDUCE;
($niecza ?? Niecza::Grammar !! STD).parse($text);
my $all;
# setting?
if $*YOU_WERE_HERE {
$all = $STD::ALL;
$all<SETTING> = $*YOU_WERE_HERE;
$all<CORE> = $*YOU_WERE_HERE if $*UNIT<$?LONGNAME> eq 'CORE';
my %keepname;
my $ptr = 'SETTING';
while $all{$ptr}:exists {
%keepname{$ptr} = True;
%keepname{$all{$ptr}.id} = True;
#say "Keeping $ptr";
$ptr = $all{$ptr}<OUTER::>[0];
#say "Moving cursor to $ptr";
}
for keys %$all -> $key {
if $key ~~ /^MY/ && $key !~~ /\:\:/ && !%keepname{$key} {
$all{$key}:delete;
}
}
}
else {
$all = {};
for keys %( $STD::ALL ) -> $key {
next if $key ~~ /^MY\:file\<\w+\.setting\>/ or $key eq 'CORE' or $key eq 'SETTING';
$all{$key} = $STD::ALL{$key};
}
}
$all
}
if !@*ARGS {
note "Usage: tryfile.exe [--symbols]? [--niecza]? [--setting NAME]? [-e TEXT | FILENAME | -]";
exit 1;
}
my $symbols = False;
my $setting = 'CORE';
my $niecza = False;
if @*ARGS[0] eq '--symbols' {
$symbols = True;
shift @*ARGS;
}
if @*ARGS[0] eq '--niecza' {
$niecza = True;
shift @*ARGS;
}
if @*ARGS[0] eq '--setting' {
shift @*ARGS;
$setting = shift @*ARGS;
}
my $out;
if @*ARGS[0] eq '-' {
$out = compiler(filename => '(eval)', text => $*IN.slurp, settingname => $setting, niecza => $niecza);
} elsif @*ARGS[0] eq '-e' {
$out = compiler(filename => '(eval)', text => @*ARGS[1], settingname => $setting, niecza => $niecza);
} else {
$out = compiler(filename => @*ARGS[0], text => slurp(@*ARGS[0]), settingname => $setting, niecza => $niecza);
}
if $symbols {
say to-jsync($out);
} else {
say "OK"
}
Jump to Line
Something went wrong with that request. Please try again.