Benchmark-Perl-Formance-Cargo
view release on metacpan or search on metacpan
share/P6STD/STD.pm6 view on Meta::CPAN
my $*IN_PANIC; # don't panic recursively
# symbol table management
our $ALL; # all the stashes, keyed by id
my $*CORE; # the CORE scope
my $*SETTING; # the SETTING scope
my $*GLOBAL; # the GLOBAL scope
my $*PROCESS; # the PROCESS scope
my $*UNIT; # the UNIT scope
my $*CURLEX; # current lexical scope info
my $*CURPKG; # current package scope
my %*MYSTERY; # names we assume may be post-declared functions
# tree attributes, marked as propagating up (u) down (d) or up-and-down (u/d)
my %*LANG; # (d) braided languages: MAIN, Q, Regex, etc
my $*IN_DECL; # (d) a declarator is looking for a name to declare
my $*HAS_SELF; # (d) in a context where 'self' exists
my $*SCOPE = ""; # (d) which scope declarator we're under
my $*MULTINESS; # (d) which multi declarator we're under
my $*PKGDECL ::= ""; # (d) current package declarator
my $*NEWPKG; # (u/d) new package being declared
my $*NEWLEX; # (u/d) new lex info being declared
my $*DECLARAND; # (u/d) new object associated with declaration
my $*GOAL ::= "(eof)"; # (d) which special terminator we're most wanting
my $*IN_REDUCE; # (d) attempting to parse an [op] construct
my $*IN_META; # (d) parsing a metaoperator like [..]
my $*QUASIMODO; # (d) don't carp about quasi variables
my $*LEFTSIGIL; # (u) sigil of LHS for item vs list assignment
my $*QSIGIL; # (d) sigil of current interpolation
my $*INVOCANT_OK; # (d) parsing a list that allows an invocant
my $*INVOCANT_IS; # (u) invocant of args match
my $*BORG; # (u/d) who to blame if we're missing a block
=end comment
=begin notes
Some rules are named by syntactic category plus an additional symbol
specified in adverbial form, either in bare :name form or in :sym<name>
form. (It does not matter which form you use for identifier symbols,
except that to specify a symbol "sym" you must use the :sym<sym> form
of adverb.) If you use the <sym> rule within the rule, it will parse the
symbol at that point. At the final reduction point of a rule, if $sym
has been set, that is used as the final symbol name for the rule. This
need not match the symbol specified as part the rule name; that is just
for disambiguating the name. However, if no $sym is set, the original
symbol will be used by default.
This grammar relies on transitive longest-token semantics.
=end notes
method p6class () { ::STD::P6 }
method TOP ($STOP = '') {
my $lang = self.cursor_fresh( self.p6class );
if $STOP {
my $*GOAL ::= $STOP;
$lang.unitstop($STOP).comp_unit;
}
else {
$lang.comp_unit;
}
}
##############
# Precedence #
##############
# The internal precedence levels are *not* part of the public interface.
# The current values are mere implementation; they may change at any time.
# Users should specify precedence only in relation to existing levels.
constant %term = (:dba('term') , :prec<z=>);
constant %methodcall = (:dba('methodcall') , :prec<y=>, :assoc<unary>, :uassoc<left>, :fiddly, :!pure);
constant %autoincrement = (:dba('autoincrement') , :prec<x=>, :assoc<unary>, :uassoc<non>, :!pure);
constant %exponentiation = (:dba('exponentiation') , :prec<w=>, :assoc<right>, :pure);
constant %symbolic_unary = (:dba('symbolic unary') , :prec<v=>, :assoc<unary>, :uassoc<left>, :pure);
constant %multiplicative = (:dba('multiplicative') , :prec<u=>, :assoc<left>, :pure);
constant %additive = (:dba('additive') , :prec<t=>, :assoc<left>, :pure);
constant %replication = (:dba('replication') , :prec<s=>, :assoc<left>, :pure);
constant %concatenation = (:dba('concatenation') , :prec<r=>, :assoc<list>, :pure);
constant %junctive_and = (:dba('junctive and') , :prec<q=>, :assoc<list>, :pure);
constant %junctive_or = (:dba('junctive or') , :prec<p=>, :assoc<list>, :pure);
constant %named_unary = (:dba('named unary') , :prec<o=>, :assoc<unary>, :uassoc<left>, :pure);
constant %structural = (:dba('structural infix'), :prec<n=>, :assoc<non>, :diffy);
constant %chaining = (:dba('chaining') , :prec<m=>, :assoc<chain>, :diffy, :iffy, :pure);
constant %tight_and = (:dba('tight and') , :prec<l=>, :assoc<list>);
constant %tight_or = (:dba('tight or') , :prec<k=>, :assoc<list>);
constant %conditional = (:dba('conditional') , :prec<j=>, :assoc<right>, :fiddly);
constant %item_assignment = (:dba('item assignment') , :prec<i=>, :assoc<right>, :!pure);
constant %list_assignment = (:dba('list assignment') , :prec<i=>, :assoc<right>, :fiddly, :!pure);
constant %loose_unary = (:dba('loose unary') , :prec<h=>, :assoc<unary>, :uassoc<left>, :pure);
constant %comma = (:dba('comma') , :prec<g=>, :assoc<list>, :nextterm<nulltermish>, :fiddly, :pure);
constant %list_infix = (:dba('list infix') , :prec<f=>, :assoc<list>, :pure);
constant %list_prefix = (:dba('list prefix') , :prec<e=>, :assoc<unary>, :uassoc<left>);
constant %loose_and = (:dba('loose and') , :prec<d=>, :assoc<list>);
constant %loose_or = (:dba('loose or') , :prec<c=>, :assoc<list>);
constant %sequencer = (:dba('sequencer') , :prec<b=>, :assoc<list>, :nextterm<statement>, :fiddly);
constant %LOOSEST = (:dba('LOOSEST') , :prec<a=!>);
constant %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=';
##############
# Categories #
##############
# Categories are designed to be easily extensible in derived grammars
# by merely adding more rules in the same category. The rules within
# a given category start with the category name followed by a differentiating
share/P6STD/STD.pm6 view on Meta::CPAN
while substr(self.orig,$pos,1) eq $char {
$pos++;
}
my $len = $pos - $startpos;
my $start = $char x $len;
my $stop = $rightbrack x $len;
return $start, $stop;
}
role startstop[$start,$stop] {
token starter { $start }
token stopper { $stop }
}
role stop[$stop] {
token starter { <!> }
token stopper { $stop }
}
role unitstop[$stop] {
token unitstopper { $stop }
}
token unitstopper { $ }
method balanced ($start,$stop) { self.mixin( ::startstop[$start,$stop] ); }
method unbalanced ($stop) { self.mixin( ::stop[$stop] ); }
method unitstop ($stop) { self.mixin( ::unitstop[$stop] ); }
method truly ($bool,$opt) {
return self if $bool;
self.sorry("Cannot negate $opt adverb");
self;
}
token charname {
[
| <radint>
| <alpha> .*? <?before \s*[ ',' | '#' | ']']>
] || <.sorry: "Unrecognized character name"> .*?<?terminator>
}
token charnames { \s* [<charname><.ws>] +% [','\s*] }
token charspec {
[
| :dba('character name') '[' ~ ']' <charnames>
| \d+
| <[ ?..Z \\.._ ]>
| <?> <.sorry: "Unrecognized \\c character"> .
]
}
proto token backslash {*}
proto token escape {*}
token starter { <!> }
token escape:none { <!> }
# and this is what makes nibbler polymorphic...
method nibble ($lang) {
self.cursor_fresh($lang).nibbler;
}
# note: polymorphic over many quote languages, we hope
token nibbler {
:my $text = '';
:my $from = self.pos;
:my $to = $from;
:my @nibbles = ();
:my $multiline = 0;
{ $.from = self.pos; }
[ <!before <stopper> >
[
|| <starter> <nibbler> <stopper>
{
push @nibbles, $¢.makestr(TEXT => $text, _from => $from, _pos => $to ) if $from != $to;
my $n = $<nibbler>[*-1]<nibbles>;
my @n = @$n;
push @nibbles, $<starter>;
push @nibbles, @n;
push @nibbles, $<stopper>;
$text = '';
$to = $from = $¢.pos;
}
|| <escape> {
push @nibbles, $¢.makestr(TEXT => $text, _from => $from, _pos => $to ) if $from != $to;
push @nibbles, $<escape>[*-1];
$text = '';
$to = $from = $¢.pos;
}
|| .
{
my $ch = substr(self.orig, $¢.pos-1, 1);
$text ~= $ch;
$to = $¢.pos;
if $ch ~~ "\n" {
$multiline++;
}
}
]
]*
{
push @nibbles, $¢.makestr(TEXT => $text, _from => $from, _pos => $to ) if $from != $to or !@nibbles;
$<nibbles> = \@nibbles;
$.pos = $¢.pos;
$<nibbler> :delete;
$<escape> :delete;
$<starter> :delete;
$<stopper> :delete;
$*LAST_NIBBLE = $¢;
$*LAST_NIBBLE_MULTILINE = $¢ if $multiline;
}
}
token babble ($l) {
:my $lang = $l;
:my $start;
:my $stop;
<.ws>
[ <quotepair> <.ws>
{
my $kv = $<quotepair>[*-1];
$lang = ($lang.tweak(| ($kv.<k> => $kv.<v>))
or $lang.sorry("Unrecognized adverb :" ~ $kv.<k> ~ '(' ~ $kv.<v> ~ ')'));
}
]*
$<B> = {
($start,$stop) = $¢.peek_delimiters();
$lang = $start ne $stop ?? $lang.balanced($start,$stop)
!! $lang.unbalanced($stop);
[$lang,$start,$stop];
}
}
our @herestub_queue;
class Herestub {
has Str $.delim;
has $.orignode;
has $.lang;
}
role herestop {
token stopper { ^^ {} $<ws>=(\h*?) $*DELIM \h* <.unv>?? $$ \v? }
}
# XXX be sure to temporize @herestub_queue on reentry to new line of heredocs
method heredoc () {
my $*CTX ::= self.callm if $*DEBUG +& DEBUG::trace_call;
my $here = self;
while my $herestub = shift @herestub_queue {
my $*DELIM = $herestub.delim;
my $lang = $herestub.lang.mixin( ::herestop );
my $doc;
if ($doc) = $here.nibble($lang) {
$here = $doc.trim_heredoc();
$herestub.orignode<doc> = $doc;
}
else {
self.panic("Ending delimiter $*DELIM not found");
}
}
return self.cursor($here.pos); # return to initial type
}
token quibble ($l) {
:my ($lang, $start, $stop);
<babble($l)>
{ my $B = $<babble><B>; ($lang,$start,$stop) = @$B; }
$start <nibble($lang)> [ $stop || <.panic: "Couldn't find terminator $stop"> ]
{
if $lang<_herelang> {
push @herestub_queue,
::Herestub.new(
delim => $<nibble><nibbles>[0]<TEXT>,
orignode => $¢,
lang => $lang<_herelang>,
);
}
}
}
token quotepair {
:my $key;
:my $value;
':'
:dba('colon pair (restricted)')
[
| '!' <identifier> [ <?before '('> <.sorry: "Argument not allowed on negated pair"> <circumfix> ]?
{ $key = $<identifier>.Str; $value = 0; }
| <identifier>
{ $key = $<identifier>.Str; }
[
|| <.unsp>? <?before '('> <circumfix> { $value = $<circumfix>; }
|| { $value = 1; }
]
| $<n>=(\d+) $<id>=(<[a..z]>+) [ <?before '('> <.sorry: "2nd argument not allowed on pair"> <circumfix> ]?
{ $key = $<id>.Str; $value = $<n>.Str; }
]
$<k> = {$key} $<v> = {$value}
}
token quote:sym<｢ ｣> { :dba('perfect quotes') "｢" ~ "｣" <nibble($¢.cursor_fresh( %*LANG<Q> ).unbalanced("｣"))> }
token quote:sym<' '> { :dba('single quotes') "'" ~ "'" <nibble($¢.cursor_fresh( %*LANG<Q> ).tweak(:q).unbalanced("'"))> }
token quote:sym<" "> { :dba('double quotes') '"' ~ '"' <nibble($¢.cursor_fresh( %*LANG<Q> ).tweak(:qq).unbalanced('"'))> }
token circumfix:sym<« »> { :dba('shell-quote words') '«' ~ '»' <nibble($¢.cursor_fresh( %*LANG<Q> ).tweak(:qq).tweak(:ww).balanced('«','»'))> }
token circumfix:sym«<< >>» { :dba('shell-quote words') '<<' ~ '>>' <nibble($¢.cursor_fresh( %*LANG<Q> ).tweak(:qq).tweak(:ww).balanced('<<','>>'))> }
token circumfix:sym«< >» { :dba('quote words') '<' ~ '>'
[
[ <?before 'STDIN>' > <.obs('<STDIN>', '$' ~ '*IN.lines (or add whitespace to suppress warning)')> ]? # XXX fake out gimme5
[ <?before '>' > <.obs('<>', "lines() to read input,\n or ('') to represent the null string,\n or () to represent Nil")> ]?
<nibble($¢.cursor_fresh( %*LANG<Q> ).tweak(:q).tweak(:w).balanced('<','>'))>
]
}
##################
# Lexer routines #
##################
token ws {
:temp $*STUB = return self if @*MEMOS[self.pos]<ws> :exists;
:my $startpos = self.pos;
:my $*HIGHEXPECT = {};
:dba('whitespace')
[
| \h+ <![\#\s\\]> { @*MEMOS[$¢.pos]<ws> = $startpos; } # common case
| <?before \w> <?after \w> :::
{ @*MEMOS[$startpos]<ws>:delete; }
<.sorry: "Whitespace is required between alphanumeric tokens"> # must \s+ between words
]
||
[
| <.unsp>
| <.vws> <.heredoc>
| <.unv>
| $ { $¢.moreinput }
]*
{
if ($¢.pos == $startpos) {
@*MEMOS[$¢.pos]<ws>:delete;
}
else {
@*MEMOS[$¢.pos]<ws> = $startpos;
@*MEMOS[$¢.pos]<endstmt> = @*MEMOS[$startpos]<endstmt>
if @*MEMOS[$startpos]<endstmt> :exists;
}
}
}
token unsp {
\\ <?before [\s|'#'] >
:dba('unspace')
[
| <.vws>
| <.unv>
| $ { $¢.moreinput }
]*
}
token vws {
:dba('vertical whitespace')
[
[
| \v
| '#DEBUG -1' { say "DEBUG"; $*DEBUG = -1; } \V* \v
| '<<<<<<<' :: <?before [.*? \v '=======']: .*? \v '>>>>>>>' > <.sorry: 'Found a version control conflict marker'> \V* \v
| '=======' :: .*? \v '>>>>>>>' \V* \v # ignore second half
]
]+
}
# We provide two mechanisms here:
# 1) define $*moreinput, or
# 2) override moreinput method
method moreinput () {
$*moreinput.() if $*moreinput;
self;
}
token unv {
:dba('horizontal whitespace')
[
| \h+
| <?before \h* '=' [ \w | '\\'] > ^^ <.pod_comment>
| \h* <comment>
]+
}
token comment:sym<#`(...)> {
'#`' :: [ <?opener> || <.panic: "Opening bracket is required for #` comment"> ]
<.quibble($¢.cursor_fresh( %*LANG<Q> ))>
}
token comment:sym<#(...)> {
'#' <?opener>
<.suppose
<quibble($¢.cursor_fresh( %*LANG<Q> ))>
<!before <[,;:]>* \h* [ '#' | $$ ] > # extra stuff on line after closer?
>
<.worry: "Embedded comment seems to be missing backtick"> <!>
}
token comment:sym<#=(...)> {
'#=' <?opener> ::
<quibble($¢.cursor_fresh( %*LANG<Q> ))>
}
token comment:sym<#=> {
'#=' :: $<attachment> = [\N*]
}
token comment:sym<#> {
'#' {} \N*
}
token ident {
<.alpha> \w*
}
token apostrophe {
<[ ' \- ]>
}
token identifier {
<.ident> [ <.apostrophe> <.ident> ]*
}
# XXX We need to parse the pod eventually to support $= variables.
token pod_comment {
^^ \h* '=' <.unsp>?
[
| 'begin' \h+ <identifier> ::
[
|| .*? "\n" [ :r \h* '=' <.unsp>? 'end' \h+ $<identifier> » \N* ]
|| <?{ $<identifier>.Str eq 'END'}> .*
|| { my $id = $<identifier>.Str; self.panic("=begin $id without matching =end $id"); }
]
| 'begin' » :: \h* [ $$ || '#' || <.sorry: "Unrecognized token after =begin"> \N* ]
[ .*? "\n" \h* '=' <.unsp>? 'end' » \N* || { self.panic("=begin without matching =end"); } ]
| 'for' » :: \h* [ <identifier> || $$ || '#' || <.sorry: "Unrecognized token after =for"> \N* ]
[.*? ^^ \h* $$ || .*]
| ::
[ <?before .*? ^^ '=cut' » > <.panic: "Obsolescent pod format, please use =begin/=end instead"> ]?
[<alpha>||\s||<.sorry: "Illegal pod directive">]
\N*
]
}
# suppress fancy end-of-line checking
token embeddedblock {
# encapsulate braided languages
:temp %*LANG;
:my $*SIGNUM;
:my $*GOAL ::= '}';
:temp $*CURLEX;
:dba('embedded block')
<.newlex>
<.finishlex>
'{' :: [ :lang(%*LANG<MAIN>) <statementlist> ]
[ '}' || <.panic: "Unable to parse statement list; couldn't find right brace"> ]
}
share/P6STD/STD.pm6 view on Meta::CPAN
grammar P6 is STD {
###################
# Top-level rules #
###################
# Note: we only check for the stopper. We don't check for ^ because
# we might be embedded in something else.
rule comp_unit {
:my $*begin_compunit = 1;
:my $*endargs = -1;
:my %*LANG;
:my $*PKGDECL ::= "";
:my $*IN_DECL = '';
:my $*HAS_SELF = '';
:my $*DECLARAND;
:my $*OFTYPE;
:my $*NEWPKG;
:my $*NEWLEX;
: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;
:my $*CURPKG;
{
%*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 = ();
self.load_setting($*SETTINGNAME);
my $oid = $*SETTING.id;
my $id = 'MY:file<' ~ $*FILE<name> ~ '>';
$*CURLEX = Stash.new(
'OUTER::' => [$oid],
'!file' => $*FILE, '!line' => 0,
'!id' => [$id],
);
$ALL.{$id} = $*CURLEX;
$*UNIT = $*CURLEX;
$ALL.<UNIT> = $*UNIT;
self.finishlex;
# $¢ = self.cursor_fresh($*CURLEX<$?LANGNAME>);
}
<.unitstart>
<statementlist>
[ <?unitstopper> || <.panic: "Confused"> ]
# "CHECK" time...
$<LEX> = { $*CURLEX }
{
$¢.explain_mystery();
if @*WORRIES {
note "Potential difficulties:\n " ~ join( "\n ", @*WORRIES) ~ "\n";
}
die "Check failed\n" if $*FATALS;
}
}
# Note: because of the possibility of placeholders we can't determine arity of
# the block syntactically, so this must be determined via semantic analysis.
# Also, pblocks used in an if/unless statement do not treat $_ as a placeholder,
# while most other blocks treat $_ as equivalent to $^x. Therefore the first
# possible place to check arity is not here but in the rule that calls this
# rule. (Could also be done in a later pass.)
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)>
<signature(1)>
<blockoid>
<.getsig>
| <?before '{'>
<.newlex(1)>
<blockoid>
<.getsig>
]
}
# this is a hook for subclasses
token unitstart { <?> }
token lambda { '->' | '<->' }
# Look for an expression followed by a required lambda.
token xblock {
:my $*GOAL ::= '{';
:my $*BORG = {};
<.ws> # XXX
<EXPR>
{ $*BORG.<culprit> //= $<EXPR>.cursor(self.pos) }
<.ws>
<pblock>
}
token block () {
:temp $*CURLEX;
:dba('scoped block')
[ <?before '{' > || <.panic: "Missing block"> ]
<.newlex>
<blockoid>
<.checkyada>
}
token blockoid {
# encapsulate braided languages
:temp %*LANG;
:my $*SIGNUM;
<.finishlex>
[
| '{YOU_ARE_HERE}' <.you_are_here>
| :dba('block') '{' ~ '}' <statementlist> :: <.curlycheck(1)>
| <?terminator> <.panic: 'Missing block'>
| <?> <.panic: "Malformed block">
]
}
token curlycheck($code) {
[
|| <?before \h* $$> # (usual case without comments)
{ @*MEMOS[$¢.pos]<endstmt> = 2; }
|| <?before \h* <[\\,:]>>
|| <.unv> $$
{ @*MEMOS[$¢.pos]<endstmt> = 2; }
|| <.unsp>? { @*MEMOS[$¢.pos]<endargs> = $code; }
]
}
token regex_block {
# encapsulate braided languages
:temp %*LANG;
:temp %*RX;
:my $lang = %*LANG<Regex>;
:my $*GOAL ::= '}';
[ <quotepair> <.ws>
{
my $kv = $<quotepair>[*-1];
$lang = ($lang.tweak(|($kv.<k>.Str => $kv.<v>))
or $lang.panic("Unrecognized adverb :" ~ $kv.<k> ~ '(' ~ $kv.<v> ~ ')'));
}
]*
[
| '{*}' <?{ $*MULTINESS eq 'proto' }> $<onlystar> = {1}
| [
'{'
<nibble( $¢.cursor_fresh($lang).unbalanced('}') )>
[ '}' || <.panic: "Unable to parse regex; couldn't find right brace"> ]
]
]
<.curlycheck(1)>
}
# statement semantics
rule statementlist {
:my $*INVOCANT_OK = 0;
:temp $*MONKEY_TYPING;
:dba('statement list')
''
[
| $
| <?before <[\)\]\}]>>
| [<statement><eat_terminator> ]*
{ self.mark_sinks($<statement>) }
]
}
# embedded semis, context-dependent semantics
rule semilist {
:my $*INVOCANT_OK = 0;
:dba('semicolon list')
''
[
| <?before <[\)\]\}]>>
| [<statement><eat_terminator> ]*
]
}
token label {
:my $label;
<identifier> ':' <?before \s> <.ws>
[ <?{ $¢.is_name($label = $<identifier>.Str) }>
<.worry("Redeclaration of '$label'")>
]?
# add label as a pseudo constant
{ $¢.add_constant($label,self.label_id); }
}
token statement {
:my $*endargs = -1;
:my $*QSIGIL ::= 0;
<!before <[\)\]\}]> >
<!stopper>
# this could either be a statement that follows a declaration
# or a statement that is within the block of a code declaration
<!!{ $*LASTSTATE = $¢.pos; $¢ = %*LANG<MAIN>.bless($¢); }>
[
| <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><statement_prefix>;
if $sp and $sp<sym> eq 'do' {
my $s = $<statement_mod_loop>[0]<sym>;
if $s eq 'while' or $s eq 'until' {
$¢.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?)">
]?
}
token eat_terminator {
[
|| ';'
|| <?{ (@*MEMOS[$¢.pos]<endstmt>//0) >= 2 }> <.ws>
|| <?before ')' | ']' | '}' >
|| $
|| <?stopper>
|| <?before <.suppose <statement_control> > > <.backup_ws> { $*HIGHWATER = -1; } <.panic: "Missing semicolon">
|| <.panic: "Confused">
]
}
# undo any line transition
method backup_ws () {
if @*MEMOS[self.pos]<ws> {
return self.cursor(@*MEMOS[self.pos]<ws>);
}
return self;
}
#####################
# statement control #
#####################
rule statement_control:need {
:my $longname;
<sym>
[
|<version>
|<module_name>
{
my $*IN_DECL = 'use';
my $*SCOPE = 'use';
$longname = $<module_name>[*-1]<longname>;
$¢.do_need($longname<name>);
}
] +% ','
}
token statement_control:import {
:my $*IN_DECL = 'use';
:my $*HAS_SELF = '';
:my $*SCOPE = 'use';
<sym> <.ws>
<term>
[
|| <.spacey> <arglist>
{
my %*MYSTERY;
$¢.do_import($<term>, $<arglist>);
$¢.explain_mystery();
}
|| { $¢.do_import($<term>, ''); }
]
<.ws>
}
token statement_control:use {
:my $longname;
:my $*IN_DECL = 'use';
:my $*SCOPE = 'use';
:my $*HAS_SELF = '';
:my %*MYSTERY;
<sym> <.ws>
[
| <version>
| <module_name>
{
$longname = $<module_name><longname>;
if $longname.Str eq 'MONKEY_TYPING' {
$*MONKEY_TYPING = True;
}
}
[
|| <.spacey> <arglist>
{
share/P6STD/STD.pm6 view on Meta::CPAN
# Quotes #
##########
token sibble ($l, $lang2) {
:my ($lang, $start, $stop);
<babble($l)>
{ my $B = $<babble><B>; ($lang,$start,$stop) = @$B; }
$start <left=.nibble($lang)> [ $stop || <.panic: "Couldn't find terminator $stop"> ]
[ <?{ $start ne $stop }>
<.ws>
[ <?[ \[ \{ \( \< ]> <.obs('brackets around replacement', 'assignment syntax')> ]?
[ <infixish> || <panic: "Missing assignment operator"> ]
[ <?{ $<infixish>.Str eq '=' || $<infixish>.<infix_postfix_meta_operator> }> || <.panic: "Malformed assignment operator"> ]
<.ws>
<right=EXPR(item %item_assignment)>
||
{ $lang = $lang2.unbalanced($stop); }
<right=.nibble($lang)> $stop || <.panic: "Malformed replacement part; couldn't find final $stop">
]
}
token tribble ($l, $lang2 = $l) {
:my ($lang, $start, $stop);
:my $*CCSTATE = '';
<babble($l)>
{ my $B = $<babble><B>; ($lang,$start,$stop) = @$B; }
$start <left=.nibble($lang)> [ $stop || <.panic: "Couldn't find terminator $stop"> ]
{ $*CCSTATE = ''; }
[ <?{ $start ne $stop }>
<.ws> <quibble($lang2)>
||
{ $lang = $lang2.unbalanced($stop); }
<right=.nibble($lang)> $stop || <.panic: "Malformed replacement part; couldn't find final $stop">
]
}
token quasiquibble ($l) {
:temp %*LANG;
:my ($lang, $start, $stop);
:my $*QUASIMODO = 0; # :COMPILING sets true
<babble($l)>
{
my $B = $<babble><B>;
($lang,$start,$stop) = @$B;
%*LANG<MAIN> = $lang;
}
[
|| <?{ $start eq '{' }> [ :lang($lang) <block> ]
|| [ :lang($lang) <starter> <statementlist> [ <stopper> || <.panic: "Couldn't find terminator $stop"> ] ]
]
}
token quote:sym<//> {
'/'\s*'/' <.sorry: "Null regex not allowed">
}
token quote:sym</ /> {
'/' <nibble( $¢.cursor_fresh( %*LANG<Regex> ).unbalanced("/") )> [ '/' || <.panic: "Unable to parse regex; couldn't find final '/'"> ]
<.old_rx_mods>?
}
# handle composite forms like qww
token quote:qq {
:my $qm;
'qq'
[
| <quote_mod> » <!before '('> { $qm = $<quote_mod>.Str } <.ws> <quibble($¢.cursor_fresh( %*LANG<Q> ).tweak(:qq).tweak(|($qm => 1)))>
| » <!before '('> <.ws> <quibble($¢.cursor_fresh( %*LANG<Q> ).tweak(:qq))>
]
}
token quote:q {
:my $qm;
'q'
[
| <quote_mod> » <!before '('> { $qm = $<quote_mod>.Str } <quibble($¢.cursor_fresh( %*LANG<Q> ).tweak(:q).tweak(|($qm => 1)))>
| » <!before '('> <.ws> <quibble($¢.cursor_fresh( %*LANG<Q> ).tweak(:q))>
]
}
token quote:Q {
:my $qm;
'Q'
[
| <quote_mod> » <!before '('> { $qm = $<quote_mod>.Str } <quibble($¢.cursor_fresh( %*LANG<Q> ).tweak(|($qm => 1)))>
| » <!before '('> <.ws> <quibble($¢.cursor_fresh( %*LANG<Q> ))>
]
}
token quote_mod:w { <sym> }
token quote_mod:ww { <sym> }
token quote_mod:p { <sym> }
token quote_mod:x { <sym> }
token quote_mod:to { <sym> }
token quote_mod:s { <sym> }
token quote_mod:a { <sym> }
token quote_mod:h { <sym> }
token quote_mod:f { <sym> }
token quote_mod:c { <sym> }
token quote_mod:b { <sym> }
token quote:rx {
<sym> » <!before '('>
<quibble( $¢.cursor_fresh( %*LANG<Regex> ) )>
<!old_rx_mods>
}
token quote:m {
<sym> » <!before '('>
<quibble( $¢.cursor_fresh( %*LANG<Regex> ) )>
<!old_rx_mods>
}
token quote:ms {
<sym> » <!before '('>
<quibble( $¢.cursor_fresh( %*LANG<Regex> ).tweak(:s))>
<!old_rx_mods>
}
token quote:s {
<sym> » <!before '('>
<pat=.sibble( $¢.cursor_fresh( %*LANG<Regex> ), $¢.cursor_fresh( %*LANG<Q> ).tweak(:qq))>
<!old_rx_mods>
}
token quote:ss {
<sym> » <!before '('>
<pat=.sibble( $¢.cursor_fresh( %*LANG<Regex> ).tweak(:s), $¢.cursor_fresh( %*LANG<Q> ).tweak(:qq))>
<!old_rx_mods>
}
token quote:tr {
<sym> » <!before '('> <pat=.tribble( $¢.cursor_fresh( %*LANG<Q> ).tweak(:cc))>
<!old_tr_mods>
}
token old_rx_mods {
<!after \s>
(\w+)
{
given $0.Str {
$_ ~~ /i/ and $¢.worryobs('/i',':i');
$_ ~~ /g/ and $¢.worryobs('/g',':g');
$_ ~~ /m/ and $¢.worryobs('/m','^^ and $$ anchors');
$_ ~~ /s/ and $¢.worryobs('/s','. or \N');
$_ ~~ /x/ and $¢.worryobs('/x','normal default whitespace');
$_ ~~ /c/ and $¢.worryobs('/c',':c or :p');
$_ ~~ /e/ and $¢.worryobs('/e','interpolated {...} or s{} = ... form');
$_ ~~ /r/ and $¢.worryobs('/c','.subst');
$_ ~~ /a/ and $¢.worryobs('/a','Unicode');
$_ ~~ /d/ and $¢.worryobs('/d','Unicode');
$_ ~~ /l/ and $¢.worryobs('/l','Unicode');
$_ ~~ /u/ and $¢.worryobs('/l','normal regex');
$_ ~~ /p/ and $¢.worryobs('/c','substr or /$<PREMATCH>=[...] <(...)> $<POSTMATCH>=[...]');
$¢.obs('suffix regex modifiers','prefix adverbs');
}
}
}
token old_tr_mods {
(< c d s ] >+)
{
given $0.Str {
$_ ~~ /c/ and $¢.worryobs('/c',':c');
$_ ~~ /d/ and $¢.worryobs('/g',':d');
$_ ~~ /s/ and $¢.worryobs('/s',':s');
$¢.obs('suffix transliteration modifiers','prefix adverbs');
}
}
}
token quote:quasi {
<sym> » <!before '('> <quasiquibble($¢.cursor_fresh( %*LANG<Quasi> ))>
}
###########################
# Captures and Signatures #
###########################
token capterm {
'\\'
[
| '(' <capture>? ')'
| <?before \S> <termish>
| {} <.panic: "You can't backslash that">
]
}
rule capture {
:my $*INVOCANT_OK = 1;
<EXPR>
}
token sigterm {
:dba('signature')
':(' ~ ')' <fakesignature>
}
rule param_sep {'' [','|':'|';'|';;'] }
token fakesignature() {
:temp $*CURLEX;
:my $*DECLARAND;
<.newlex>
<signature>
}
token signature ($lexsig = 0) {
:my $*IN_DECL = 'sig';
:my $*zone = 'posreq';
:my $startpos = self.pos;
:my $*MULTINESS = 'only';
:my $*SIGNUM = $lexsig;
<.ws>
[
| '\|' [ <defterm> || <.panic: "\\| signature must contain one identifier"> ]
<.ws> [ <?before '-->' | ')' | ']' > || <.panic: "\\| signature may contain only an identifier"> ]
| [
| <?before '-->' | ')' | ']' | '{' | ':'\s | ';;' >
| [ <parameter> || <.panic: "Malformed parameter"> ]
] +% <param_sep>
]
<.ws>
{ $*IN_DECL = ''; }
[ '-->' <.ws>
[
|| <type_constraint>
|| <longname> <.panic("Typename " ~ $<longname>[0].Str ~ " must be predeclared")>
|| <.panic: "No type found after -->">
]
<.ws>
]?
{
share/P6STD/STD.pm6 view on Meta::CPAN
}
token term:sym<undef> {
<sym> » {}
[ <?before \h*'$/' >
<.obs('$/ variable as input record separator',
"the filehandle's .slurp method")>
]?
[ <?before [ '(' || \h*<sigil><twigil>?\w ] >
<.obs('undef as a verb', 'undefine function or assignment of Nil')>
]?
<.obs('undef as a value', "something more specific:\n\tMu (the \"most undefined\" type object),\n\tan undefined type object such as Int,\n\t:!defined as a matcher,\n\tAny:U as a type constraint,\n\tNil as the absense of a value\n\tor fail() a...
}
token term:sym<proceed>
{ <sym> » <O(|%term)> }
token term:sym<time>
{ <sym> » <O(|%term)> }
token term:sym<now>
{ <sym> » <O(|%term)> }
token term:sym<self> {
<sym> »
{ $*HAS_SELF || $¢.sorry("'self' used where no object is available") }
<O(|%term)>
}
token term:sym<defer>
{ <sym> » <O(|%term)> }
token term:rand {
<sym> »
[ <?before '('? \h* [\d|'$']> <.obs('rand(N)', 'N.rand or (1..N).pick')> ]?
[ <?before '()'> <.obs('rand()', 'rand')> ]?
<O(|%term)>
}
token term:sym<*>
{ <sym> <O(|%term)> }
token term:sym<**>
{ <sym> <O(|%term)> }
token infix:lambda {
<?before '{' | '->' > <!{ $*IN_META }> {
my $needparens = 0;
my $line = $¢.lineof($¢.pos);
for 'if', 'unless', 'while', 'until', 'for', 'given', 'when', 'loop', 'sub', 'method' {
$needparens++ if $_ eq 'loop';
my $m = %*MYSTERY{$_};
next unless $m;
if $line - ($m.<line>//-123) < 5 {
if $m.<ctx> eq '(' {
$¢.panic("Word '$_' interpreted as '$_" ~ "()' function call; please use whitespace " ~
($needparens ?? 'around the parens' !! 'instead of parens') ~ $m<token>.locmess ~
"\nUnexpected block in infix position (two terms in a row)");
}
else {
$¢.panic("Word '$_' interpreted as a listop; please use 'do $_' to introduce the statement control word" ~ $m<token>.cursor($m<token>.from).locmess ~
"\nUnexpected block in infix position (two terms in a row)");
}
}
}
return () if $*IN_REDUCE;
my $endpos = $¢.pos;
my $startpos = @*MEMOS[$endpos]<ws> // $endpos;
if self.lineof($startpos) != self.lineof($endpos) {
$¢.panic("Unexpected block in infix position (previous line missing its semicolon?)");
}
elsif @*MEMOS[$startpos]<baremeth> {
$¢.cursor($startpos).panic("Unexpected block in infix position (method call with args needs colon or parens without whitespace)");
}
else {
$¢.panic("Unexpected block in infix position (two terms in a row, or previous statement missing semicolon?)");
}
}
<O(|%term)>
}
token circumfix:sigil
{ :dba('contextualizer') <sigil> '(' ~ ')' <semilist> { $*LEFTSIGIL ||= $<sigil>.Str } <O(|%term)> }
token circumfix:sym<( )>
{ :dba('parenthesized expression') '(' ~ ')' <semilist> <O(|%term)> }
token circumfix:sym<[ ]>
{ :dba('array composer') '[' ~ ']' <semilist> <O(|%term)> { @*MEMOS[$¢.pos]<arraycomp> = 1; } }
#############
# Operators #
#############
token PRE {
:dba('prefix or meta-prefix')
[
| <prefix>
$<O> = {$<prefix><O>} $<sym> = {$<prefix><sym>}
| <prefix_circumfix_meta_operator>
$<O> = {$<prefix_circumfix_meta_operator><O>} $<sym> = {$<prefix_circumfix_meta_operator>.Str}
]
# XXX assuming no precedence change
<prefix_postfix_meta_operator>*
<.ws>
}
token infixish ($in_meta = $*IN_META) {
:my $infix;
:my $*IN_META = $in_meta;
<!stdstopper>
<!infixstopper>
:dba('infix or meta-infix')
[
| <colonpair> {
$<fake> = 1;
$<sym> = ':';
%<O><prec> = %item_assignment<prec>; # actual test is non-inclusive!
%<O><assoc> = 'unary';
%<O><dba> = 'adverb';
}
| [
| :dba('bracketed infix') '[' ~ ']' <infix=.infixish('[]')>
{ $<O> = $<infix><O>; $<sym> = $<infix><sym>; }
[ <!before '='> { self.worry("Useless use of [] around infix op") unless $*IN_META; } ]?
| :dba('infixed function') <?before '[&' <twigil>? [<alpha>|'('] > '[' ~ ']' <infix=.variable>
{ $<O> = $<infix><O> // {%additive}; $<sym> = $<infix>; }
{ $¢.check_variable($<infix>) }
| <infix=infix_circumfix_meta_operator> { $<O> = $<infix><O>; $<sym> = $<infix><sym>; }
| <infix=infix_prefix_meta_operator> { $<O> = $<infix><O>; $<sym> = $<infix><sym>; }
| <infix> { $<O> = $<infix><O>; $<sym> = $<infix><sym>; }
| <?{ $in_meta }> :: <!>
share/P6STD/STD.pm6 view on Meta::CPAN
<.can_meta($<infixish>, "hyper with")>
$<O> = {$<infixish><O>}
}
token infix_circumfix_meta_operator:sym«<< >>» {
[
| '<<'
| '>>'
]
{} <infixish('HYPER')> [ '<<' | '>>' || <.panic("Missing << or >>")> ]
<.can_meta($<infixish>, "hyper with")>
$<O> = {$<infixish><O>}
}
token infix_postfix_meta_operator:sym<=> ($op) {
:my %prec;
'='
<.can_meta($op, "make assignment out of")>
[ <!{ $op<O><diffy> }> || <.sorry("Cannot make assignment out of " ~ $op<sym> ~ " because " ~ $op<O><dba> ~ " operators are diffy")> ]
{
$<sym> = $op<sym> ~ '=';
if $op<O><prec> gt %comma<prec> {
%prec = %item_assignment;
}
else {
%prec = %list_assignment;
}
}
<O($op.Opairs, |%prec, dba => 'assignment operator', iffy => 0)>
}
token postcircumfix:sym<( )>
{ :dba('argument list') '(' ~ ')' <semiarglist> <O(|%methodcall)> }
token postcircumfix:sym<[ ]> { :dba('subscript') '[' ~ ']' <semilist> <O(|%methodcall)>
{
my $innards = $<semilist>.Str;
$innards ~~ s/^\s+//;
$innards ~~ s/\s+$//;
if $innards ~~ /^\-\d+$/ {
$¢.obs("[$innards] subscript to access from end of array","[*$innards]");
}
}
}
token postcircumfix:sym<{ }> {
:temp $*CURLEX;
:dba('subscript')
<.newlex>
# <.finishlex> # XXX not sure if we need this
'{' ~ '}' <semilist> <O(|%methodcall)>
<.checkyada>
<.curlycheck(0)>
}
token postcircumfix:sym«< >» {
:my $pos;
'<'
{ $pos = $¢.pos }
[
|| <nibble($¢.cursor_fresh( %*LANG<Q> ).tweak(:q).tweak(:w).balanced('<','>'))> '>'
|| <?before \h* [ \d | <sigil> | ':' ] >
{ $¢.cursor_force($pos).panic("Whitespace required before < operator") }
|| { $¢.cursor_force($pos).panic("Unable to parse quote-words subscript; couldn't find right angle quote") }
]
<O(|%methodcall)>
}
token postcircumfix:sym«<< >>»
{ '<<' <nibble($¢.cursor_fresh( %*LANG<Q> ).tweak(:qq).tweak(:ww).balanced('<<','>>'))> [ '>>' || <.panic: "Unable to parse quote-words subscript; couldn't find right double-angle quote"> ] <O(|%methodcall)> }
token postcircumfix:sym<« »>
{ '«' <nibble($¢.cursor_fresh( %*LANG<Q> ).tweak(:qq).tweak(:ww).balanced('«','»'))> [ '»' || <.panic: "Unable to parse quote-words subscript; couldn't find right double-angle quote"> ] <O(|%methodcall)> }
token postop {
| <postfix> $<O> = {$<postfix><O>} $<sym> = {$<postfix><sym>}
| <postcircumfix> $<O> = {$<postcircumfix><O>} $<sym> = {$<postcircumfix><sym>}
}
token methodop {
[
| <longname>
| <?before '$' | '@' | '&' > <variable> { $¢.check_variable($<variable>) }
| <?before <[ ' " ]> >
[ <!{$*QSIGIL}> || <!before '"' <-["]>*? \s > ] # dwim on "$foo."
<quote>
[ <?before '(' | '.(' | '\\'> || <.obs('. to concatenate strings or to call a quoted method', '~ to concatenate, or if you meant to call a quoted method, please supply the required parentheses')> ]
{ my $t = $<quote><nibble>.Str; $t ~~ /\W/ or $t eq '' or $t ~~ /^(WHO|WHAT|WHERE|WHEN|WHY|HOW)$/ or $¢.worry("Useless use of quotes") }
] <.unsp>?
:dba('method arguments')
[
| ':' <?before \s | '{'> <!{ $*QSIGIL }> <arglist>
| <?[\\(]> <args>
| { @*MEMOS[$¢.pos]<baremeth> = 1 }
]?
}
token semiarglist {
<arglist> +% ';'
<.ws>
}
token arglist {
:my $inv_ok = $*INVOCANT_OK;
:my StrPos $*endargs = 0;
:my $*GOAL ::= 'endargs';
:my $*QSIGIL ::= '';
<.ws>
:dba('argument list')
[
| <?stdstopper>
| <EXPR(item %list_prefix)> {
my $delims = $<EXPR><delims>;
for @$delims {
if $_.<infix><wascolon> // '' {
if $inv_ok {
$*INVOCANT_IS = $<EXPR><list>[0];
}
}
}
}
]
}
token term:lambda {
<?before <.lambda> >
<pblock>
{
if $*BORG {
$*BORG.<block> = $<pblock>;
}
}
share/P6STD/STD.pm6 view on Meta::CPAN
token infix:sym<ff^>
{ <sym> <O(|%conditional)> }
token infix:sym<^ff^>
{ <sym> <O(|%conditional)> }
token infix:sym<fff>
{ <sym> <O(|%conditional)> }
token infix:sym<^fff>
{ <sym> <O(|%conditional)> }
token infix:sym<fff^>
{ <sym> <O(|%conditional)> }
token infix:sym<^fff^>
{ <sym> <O(|%conditional)> }
## assignment
token infix:sym<=> ()
{
<sym>
[
|| <?{ $*LEFTSIGIL eq '$' }>
<O(|%item_assignment)>
|| <O(|%list_assignment)>
]
}
token infix:sym<:=>
{ <sym> <O(|%list_assignment)> }
token infix:sym<::=>
{ <sym> <O(|%list_assignment)> }
token infix:sym<.=> {
<sym>
<O(|%item_assignment,
nextterm => 'dottyopish',
_reducecheck => 'check_doteq'
)>
}
method check_doteq {
# [ <?before \w+';' | 'new'|'sort'|'subst'|'trans'|'reverse'|'uniq'|'map'|'samecase'|'substr'|'flip'|'fmt'|'pick' > || ]
return self if self.<left><scope_declarator>;
my $ok = 0;
try {
my $methop = self.<right><methodop>;
my $name = $methop.<longname>.Str;
if grep { $_ eq $name }, <new clone sort subst trans reverse uniq map samecase substr flip fmt pick> {
$ok = 1;
}
elsif not $methop.<args>[0] {
$ok = 1;
}
};
self.cursor_force(self.<infix>.pos).worryobs('.= as append operator', '~=') unless $ok;
self;
}
token infix:sym« => »
{ <sym> <O(|%item_assignment, fiddly => 0)> }
# Note, other assignment ops generated by infix_postfix_meta_operator rule
## loose unary
token prefix:sym<so>
{ <sym> » <O(|%loose_unary)> }
token prefix:sym<not>
{ <sym> » <O(|%loose_unary)> }
## list item separator
token infix:sym<,> {
<sym> <O(|%comma, fiddly => 0)>
[ <?before \h*'...'> <.worry: "Comma found before apparent series operator; please remove comma (or put parens\n around the ... listop, or use 'fail' instead of ...)"> ]?
}
token infix:sym<:> {
':' <?before \s | <terminator> >
{
$¢.sorry("Illegal use of colon as invocant marker") unless $*INVOCANT_OK-- or $*PRECLIM ge $item_assignment_prec;
}
$<wascolon> = {True}
$<sym> = {','}
<O(|%comma)>
}
token infix:sym<X>
{ <sym> <O(|%list_infix)> }
token infix:sym<Z>
{ <sym> <O(|%list_infix)> }
token infix:sym<minmax>
{ <sym> <O(|%list_infix)> }
token infix:sym<...>
{ <sym> <O(|%list_infix)> '^'? }
token term:sym<...>
{ <sym> <args>? <O(|%list_prefix)> }
token term:sym<???>
{ <sym> <args>? <O(|%list_prefix)> }
token term:sym<!!!>
{ <sym> <args>? <O(|%list_prefix)> }
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(2), :WHICH(2), :WHERE(2), :HOW(2), :WHENCE(2), :WHO(2),
:VAR(2),
:any(2), :all(2), :none(2), :one(2),
);
# force identifier(), identifier.(), etc. to be a function call always
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> = $<identifier>.cursor($pos);
$*BORG.<name> = $name;
}
}
if %deftrap{$name} {
my $al = $<args><arglist>[0];
my $ok = 0;
$ok = 1 if $isname;
$ok = 1 if $al and $al.from != $al.to;
$ok = 1 if $<args><semiarglist>;
if not $ok {
given +%deftrap{$name} {
when 1 { # probably misused P5ism
$<identifier>.sorryobs("bare '$name'", ".$name if you meant \$_, or use an explicit invocant or argument");
}
when 2 { # probably misused P6ism
$<identifier>.sorry("The '$name' listop may not be called without arguments (please use () or whitespace to clarify)");
}
}
}
}
}
<O(|%term)>
}
token args ($istype = 0) {
:my $listopish = 0;
:my $*GOAL ::= '';
:my $*INVOCANT_OK = 1;
:my $*INVOCANT_IS;
[
# | :dba('argument list') '.(' ~ ')' <semiarglist>
| :dba('argument list') '(' ~ ')' <semiarglist>
| :dba('argument list') <.unsp> '(' ~ ')' <semiarglist>
| { $listopish = 1; @*MEMOS[$¢.pos]<listop> = 1; }
[<?before \s> <!{ $istype }> <.ws> <!infixstopper> <arglist>]?
]
$<invocant> = {$*INVOCANT_IS}
:dba('extra arglist after (...):')
[
|| <?{ $listopish }>
|| ':' <?before \s> <moreargs=.arglist> # either switch to listopiness
|| $<O> = { {} } # or allow adverbs (XXX needs hoisting?)
]
}
# names containing :: may or may not be function calls
# bare identifier without parens also handled here if no other rule parses it
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 = $¢.cursor_all(self.pos, $¢.pos) }
]?
# 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> = $<longname>.cursor($pos);
$*BORG.<name> //= $name;
}
}
}
]
<O(|%term)>
}
method check_nodecl($name) {
if $name lt 'a' {
@*MEMOS[self.pos]<nodecl> = $name;
}
}
## loose and
token infix:sym<and>
{ <sym> <O(|%loose_and, iffy => 1)> }
token infix:sym<andthen>
{ <sym> <O(|%loose_and)> }
## loose or
token infix:sym<or>
{ <sym> <O(|%loose_or, iffy => 1)> }
token infix:sym<orelse>
{ <sym> <O(|%loose_or)> }
token infix:sym<xor>
{ <sym> <O(|%loose_or, iffy => 1)> }
## sequencer
token infix:sym« <== »
{ <sym> <O(|%sequencer)> }
token infix:sym« ==> »
{ <sym> <O(|%sequencer)> }
token infix:sym« <<== »
{ <sym> <O(|%sequencer)> }
token infix:sym« ==>> »
{ <sym> <O(|%sequencer)> }
## expression terminator
# Note: must always be called as <?terminator> or <?before ...<terminator>...>
token terminator:sym<;>
{ ';' <O(|%terminator)> }
token terminator:sym<if>
{ 'if' » <.nofun> <O(|%terminator)> }
token terminator:sym<unless>
{ 'unless' » <.nofun> <O(|%terminator)> }
token terminator:sym<while>
{ 'while' » <.nofun> <O(|%terminator)> }
token terminator:sym<until>
{ 'until' » <.nofun> <O(|%terminator)> }
token terminator:sym<for>
{ 'for' » <.nofun> <O(|%terminator)> }
token terminator:sym<given>
{ 'given' » <.nofun> <O(|%terminator)> }
token terminator:sym<when>
{ 'when' » <.nofun> <O(|%terminator)> }
token terminator:sym« --> »
{ '-->' <O(|%terminator)> }
token terminator:sym<!!>
{ '!!' <?{ $*GOAL eq '!!' }> <O(|%terminator)> }
regex infixstopper {
:dba('infix stopper')
[
| <?before <stopper> >
| <?before '!!'> <?{ $*GOAL eq '!!' }>
| <?before '{' | <lambda> > <?{ ($*GOAL eq '{' or $*GOAL eq 'endargs') and @*MEMOS[$¢.pos]<ws> }>
| <?{ $*GOAL eq 'endargs' and @*MEMOS[@*MEMOS[$¢.pos]<ws>//$¢.pos]<endargs> }>
]
}
}
grammar Q is STD {
role b1 {
token escape:sym<\\> { <sym> {} <item=.backslash> }
token backslash:qq { <?before 'q'> { $<quote> = $¢.cursor_fresh(%*LANG<MAIN>).quote(); } }
token backslash:sym<\\> { <text=.sym> }
token backslash:stopper { <text=.stopper> }
token backslash:a { <sym> }
token backslash:b { <sym> }
token backslash:c { <sym> <charspec> }
token backslash:e { <sym> }
token backslash:f { <sym> }
token backslash:n { <sym> }
token backslash:o { :dba('octal character') <sym> [ <octint> | '[' ~ ']' <octints> ] }
token backslash:r { <sym> }
token backslash:t { <sym> }
token backslash:x { :dba('hex character') <sym> [ <hexint> | '[' ~ ']' <hexints> ] }
token backslash:sym<0> { <sym> }
}
role b0 {
token escape:sym<\\> { <!> }
}
role c1 {
token escape:sym<{ }> { <?before '{'> [ :lang(%*LANG<MAIN>) <embeddedblock> ] }
}
role c0 {
token escape:sym<{ }> { <!> }
}
role s1 {
token escape:sym<$> {
:my $*QSIGIL ::= '$';
<?before '$'>
[ :lang(%*LANG<MAIN>) <EXPR(item %methodcall)> ] || <.panic: "Non-variable \$ must be backslashed">
}
}
role s0 {
token escape:sym<$> { <!> }
}
role a1 {
token escape:sym<@> {
:my $*QSIGIL ::= '@';
<?before '@'>
[ :lang(%*LANG<MAIN>) <EXPR(item %methodcall)> | <!> ] # trap ABORTBRANCH from variable's ::
}
}
role a0 {
token escape:sym<@> { <!> }
}
role h1 {
token escape:sym<%> {
:my $*QSIGIL ::= '%';
<?before '%'>
[ :lang(%*LANG<MAIN>) <EXPR(item %methodcall)> | <!> ]
}
}
role h0 {
token escape:sym<%> { <!> }
}
role f1 {
token escape:sym<&> {
:my $*QSIGIL ::= '&';
<?before '&'>
[ :lang(%*LANG<MAIN>) <EXPR(item %methodcall)> | <!> ]
}
}
role f0 {
token escape:sym<&> { <!> }
}
role p1 {
method postprocessor () { 'path' }
}
role p0 {
method postprocessor () { 'null' }
}
role w1 {
method postprocessor () { 'words' }
}
role w0 {
method postprocessor () { 'null' }
}
role ww1 {
method postprocessor () { 'quotewords' }
}
role ww0 {
method postprocessor () { 'null' }
}
role x1 {
method postprocessor () { 'run' }
}
role x0 {
method postprocessor () { 'null' }
}
role q {
token stopper { \' }
token escape:sym<\\> { <sym> <item=.backslash> }
token backslash:qq { <?before 'q'> { $<quote> = $¢.cursor_fresh(%*LANG<MAIN>).quote(); } }
token backslash:sym<\\> { <text=.sym> }
token backslash:stopper { <text=.stopper> }
# in single quotes, keep backslash on random character by default
token backslash:misc { {} (.) { $<text> = "\\" ~ $0.Str; } }
multi method tweak (:single(:$q)!) { self.panic("Too late for :q") }
multi method tweak (:double(:$qq)!) { self.panic("Too late for :qq") }
multi method tweak (:cclass(:$cc)!) { self.panic("Too late for :cc") }
}
role qq does b1 does c1 does s1 does a1 does h1 does f1 {
token stopper { \" }
# in double quotes, omit backslash on random \W backslash by default
token backslash:misc { {} [ (\W) { $<text> = $0.Str; } | $<x>=(\w) <.sorry("Unrecognized backslash sequence: '\\" ~ $<x>.Str ~ "'")> ] }
multi method tweak (:single(:$q)!) { self.panic("Too late for :q") }
multi method tweak (:double(:$qq)!) { self.panic("Too late for :qq") }
multi method tweak (:cclass(:$cc)!) { self.panic("Too late for :cc") }
}
role cc {
token stopper { \' }
method ccstate ($s) {
if $*CCSTATE eq '..' {
$*CCSTATE = '';
}
else {
$*CCSTATE = $s;
}
self;
}
# (must not allow anything to match . in nibbler or we'll lose track of state)
token escape:ws { \s+ [ <?before '#'> <.ws> ]? }
token escape:sym<#> { '#' <.panic: "Please backslash # for literal char or put whitespace in front for comment"> }
token escape:sym<\\> { <sym> <item=.backslash> <.ccstate('\\' ~ $<item>.Str)> }
token escape:sym<..> { <sym>
[
|| <?{ $*CCSTATE eq '' or $*CCSTATE eq '..' }> <.sorry: "Range missing start character on the left">
|| <?before \s* <!stopper> <!before '..'> \S >
|| <.sorry: "Range missing stop character on the right">
]
{ $*CCSTATE = '..'; }
}
token escape:sym<-> { '-' <?{ $*CCSTATE ne '' }> \s* <!stopper> \S <.obs('- as character range','..')> }
token escape:ch { $<ch> = [\S] <.ccstate($<ch>.Str)> }
token backslash:stopper { <text=.stopper> }
token backslash:a { :i <sym> }
token backslash:b { :i <sym> }
token backslash:c { :i <sym> <charspec> }
token backslash:d { :i <sym> { $*CCSTATE = '' } }
token backslash:e { :i <sym> }
token backslash:f { :i <sym> }
token backslash:h { :i <sym> { $*CCSTATE = '' } }
token backslash:n { :i <sym> }
token backslash:o { :i :dba('octal character') <sym> [ <octint> | '[' ~ ']' <octints> ] }
token backslash:r { :i <sym> }
token backslash:s { :i <sym> { $*CCSTATE = '' } }
token backslash:t { :i <sym> }
token backslash:v { :i <sym> { $*CCSTATE = '' } }
token backslash:w { :i <sym> { $*CCSTATE = '' } }
token backslash:x { :i :dba('hex character') <sym> [ <hexint> | '[' ~ ']' <hexints> ] }
token backslash:sym<0> { <sym> }
# keep random backslashes like qq does
token backslash:misc { {} [ (\W) { $<text> = $0.Str; } | $<x>=(\w) <.sorry("Unrecognized backslash sequence: '\\" ~ $<x>.Str ~ "'")> ] }
multi method tweak (:single(:$q)!) { self.panic("Too late for :q") }
multi method tweak (:double(:$qq)!) { self.panic("Too late for :qq") }
multi method tweak (:cclass(:$cc)!) { self.panic("Too late for :cc") }
}
role p5 {
multi method tweak (:$g!) { self }
multi method tweak (:$i!) { self }
multi method tweak (:$m!) { self }
multi method tweak (:$s!) { self }
multi method tweak (:$x!) { self }
multi method tweak (:$p!) { self }
multi method tweak (:$c!) { self }
}
multi method tweak (:single(:$q)!) { self.truly($q,':q'); self.mixin( ::q ); }
multi method tweak (:double(:$qq)!) { self.truly($qq, ':qq'); self.mixin( ::qq ); }
multi method tweak (:cclass(:$cc)!) { self.truly($cc, ':cc'); self.mixin( ::cc ); }
multi method tweak (:backslash(:$b)!) { self.mixin($b ?? ::b1 !! ::b0) }
multi method tweak (:scalar(:$s)!) { self.mixin($s ?? ::s1 !! ::s0) }
multi method tweak (:array(:$a)!) { self.mixin($a ?? ::a1 !! ::a0) }
multi method tweak (:hash(:$h)!) { self.mixin($h ?? ::h1 !! ::h0) }
multi method tweak (:function(:$f)!) { self.mixin($f ?? ::f1 !! ::f0) }
multi method tweak (:closure(:$c)!) { self.mixin($c ?? ::c1 !! ::c0) }
multi method tweak (:path(:$p)!) { self.mixin($p ?? ::p1 !! ::p0) }
multi method tweak (:exec(:$x)!) { self.mixin($x ?? ::x1 !! ::x0) }
multi method tweak (:words(:$w)!) { self.mixin($w ?? ::w1 !! ::w0) }
multi method tweak (:quotewords(:$ww)!) { self.mixin($ww ?? ::ww1 !! ::ww0) }
multi method tweak (:heredoc(:$to)!) { self.truly($to, ':to'); self.cursor_herelang; }
multi method tweak (:$regex!) {
return %*LANG<Regex>;
}
multi method tweak (*%x) {
my @k = keys(%x);
self.sorry("Unrecognized quote modifier: " ~ join('',@k));
}
}
grammar Quasi is STD::P6 {
token term:unquote {
:my $*QUASIMODO = 0;
<starter><starter><starter> <.ws>
[ <EXPR> <stopper><stopper><stopper> || <.panic: "Confused"> ]
}
multi method tweak (:$ast!) { self; } # XXX some transformer operating on the normal AST?
multi method tweak (:$lang!) { self.cursor_fresh( $lang ); }
multi method tweak (:$unquote!) { self; } # XXX needs to override unquote
multi method tweak (:$COMPILING!) { $*QUASIMODO = 1; self; } # XXX needs to lazify the lexical lookups somehow
multi method tweak (*%x) {
my @k = keys(%x);
self.sorry("Unrecognized quasiquote modifier: " ~ join('',@k));
}
}
##############################
# Operator Precedence Parser #
##############################
method EXPR ($preclvl?) {
my $*CTX ::= self.callm if $*DEBUG +& DEBUG::trace_call;
my $preclim = $preclvl ?? $preclvl.<prec> // $LOOSEST !! $LOOSEST;
my $*LEFTSIGIL = ''; # XXX P6
my $*PRECLIM = $preclim;
my @termstack;
my @opstack;
my $termish = 'termish';
push @opstack, { 'O' => item %terminator, 'sym' => '' }; # (just a sentinel value)
my $here = self;
my $S = $here.pos;
self.deb("In EXPR, at $S") if $*DEBUG +& DEBUG::EXPR;
my &reduce := -> {
self.deb("entering reduce, termstack == ", +@termstack, " opstack == ", +@opstack) if $*DEBUG +& DEBUG::EXPR;
my $op = pop @opstack;
my $sym = $op<sym>;
given $op<O><assoc> // 'unary' {
when 'chain' {
self.deb("reducing chain") if $*DEBUG +& DEBUG::EXPR;
my @chain;
push @chain, pop(@termstack);
push @chain, $op;
while @opstack {
last if $op<O><prec> ne @opstack[*-1]<O><prec>;
push @chain, pop(@termstack);
push @chain, pop(@opstack);
}
push @chain, pop(@termstack);
my $endpos = @chain[0].pos;
@chain = reverse @chain if @chain > 1;
my $startpos = @chain[0].from;
my $nop = $op.cursor_fresh();
$nop.prepbind(@chain);
$nop<chain> = [@chain];
$nop<_arity> = 'CHAIN';
$nop.from = $startpos;
$nop.pos = $endpos;
my @caps;
my $i = 0;
for @chain {
push(@caps, $i++ % 2 ?? 'op' !! 'term' );
push(@caps, $_);
}
$nop<~CAPS> = \@caps;
push @termstack, $nop._REDUCE($startpos, 'CHAIN');
@termstack[*-1].<PRE>:delete;
@termstack[*-1].<POST> :delete;
}
when 'list' {
self.deb("reducing list") if $*DEBUG +& DEBUG::EXPR;
my @list;
my @delims = $op;
push @list, pop(@termstack);
while @opstack {
self.deb($sym ~ " vs " ~ @opstack[*-1]<sym>) if $*DEBUG +& DEBUG::EXPR;
last if $sym ne @opstack[*-1]<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");
}
my $endpos = @list[0].pos;
@list = reverse @list if @list > 1;
my $startpos = @list[0].from;
@delims = reverse @delims if @delims > 1;
my $nop = $op.cursor_fresh();
$nop.prepbind(@list,@delims);
$nop<sym> = $sym;
$nop<O> = $op<O>;
$nop<list> = [@list];
$nop<delims> = [@delims];
$nop<_arity> = 'LIST';
$nop.from = $startpos;
$nop.pos = $endpos;
if @list {
my @caps;
push @caps, 'elem', @list[0] if @list[0];
for 0..@delims-1 {
my $d = @delims[$_];
my $l = @list[$_+1];
push @caps, 'delim', $d;
push @caps, 'elem', $l if $l; # nullterm?
}
$nop<~CAPS> = \@caps;
}
push @termstack, $nop._REDUCE($startpos, 'LIST');
@termstack[*-1].<PRE>:delete;
@termstack[*-1].<POST>:delete;
}
when 'unary' {
self.deb("reducing") if $*DEBUG +& DEBUG::EXPR;
self.deb("Termstack size: ", +@termstack) if $*DEBUG +& DEBUG::EXPR;
self.deb($op.dump) if $*DEBUG +& DEBUG::EXPR;
my $arg = pop @termstack;
$op.prepbind($arg);
$op<arg> = $arg;
my $a = $op<~CAPS>;
$op<_arity> = 'UNARY';
if $arg.from < $op.from { # postfix
$op.from = $arg.from; # extend from to include arg
# note "OOPS ", $arg.Str, "\n" if @acaps > 1;
unshift @$a, 'arg', $arg;
push @termstack, $op._REDUCE($op.from, 'POSTFIX');
@termstack[*-1].<PRE>:delete;
@termstack[*-1].<POST>:delete;
}
elsif $arg.pos > $op.pos { # prefix
$op.pos = $arg.pos; # extend pos to include arg
# note "OOPS ", $arg.Str, "\n" if @acaps > 1;
push @$a, 'arg', $arg;
push @termstack, $op._REDUCE($op.from, 'PREFIX');
@termstack[*-1].<PRE>:delete;
@termstack[*-1].<POST>:delete;
}
}
default {
self.deb("reducing") if $*DEBUG +& DEBUG::EXPR;
self.deb("Termstack size: ", +@termstack) if $*DEBUG +& DEBUG::EXPR;
my $right = pop @termstack;
my $left = pop @termstack;
$op.prepbind($left,$right);
$op<right> = $right;
$op<left> = $left;
$op.from = $left.from;
$op.pos = $right.pos;
$op<_arity> = 'BINARY';
my $a = $op<~CAPS>;
unshift @$a, 'left', $left;
push @$a, 'right', $right;
self.deb($op.dump) if $*DEBUG +& DEBUG::EXPR;
my $ck;
if $ck = $op<O><_reducecheck> {
$op = $op.$ck;
}
push @termstack, $op._REDUCE($op.from, 'INFIX');
@termstack[*-1].<PRE>:delete;
@termstack[*-1].<POST>:delete;
}
}
};
TERM:
loop {
self.deb("In loop, at ", $here.pos) if $*DEBUG +& DEBUG::EXPR;
my $oldpos = $here.pos;
$here = $here.cursor_fresh();
$*LEFTSIGIL = @opstack[*-1]<O><prec> gt $item_assignment_prec ?? '@' !! ''; # XXX P6
my @t = $here.$termish;
if not @t or not $here = @t[0] or ($here.pos == $oldpos and $termish eq 'termish') {
$here.panic("Bogus term") if @opstack > 1;
return ();
}
$termish = 'termish';
my $PRE = ($here.<PRE>:delete) // [];
my $POST = ($here.<POST>:delete) // [];
my @PRE = @$PRE;
my @POST = reverse @$POST;
# interleave prefix and postfix, pretend they're infixish
my $M = $here;
# 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, $here.<term>;
@termstack[*-1].<POST>:delete;
self.deb("after push: " ~ (0+@termstack)) if $*DEBUG +& DEBUG::EXPR;
last TERM if $preclim eq $methodcall_prec; # in interpolation, probably # XXX P6
loop { # while we see adverbs
$oldpos = $here.pos;
last TERM if (@*MEMOS[$oldpos]<endstmt> // 0) == 2; # XXX P6
$here = $here.cursor_fresh.ws;
my @infix = $here.cursor_fresh.infixish();
last TERM unless @infix;
my $infix = @infix[0];
last TERM unless $infix.pos > $oldpos;
if not $infix<sym> {
die $infix.dump if $*DEBUG +& DEBUG::EXPR;
}
my $inO = $infix<O>;
my Str $inprec = $inO<prec>;
if not defined $inprec {
self.deb("No prec given in infix!") if $*DEBUG +& DEBUG::EXPR;
die $infix.dump if $*DEBUG +& DEBUG::EXPR;
$inprec = %terminator<prec>; # XXX lexical scope is wrong
}
if $inprec le $preclim {
if $preclim ne $LOOSEST {
my $dba = $preclvl.<dba>;
my $h = $*HIGHEXPECT;
%$h = ();
$h.{"an infix operator with precedence tighter than $dba"} = 1;
}
last TERM;
}
$here = $infix.cursor_fresh.ws();
# Does new infix (or terminator) force any reductions?
while @opstack[*-1]<O><prec> gt $inprec {
&reduce();
}
# Not much point in reducing the sentinels...
last if $inprec lt $LOOSEST;
if $infix<fake> {
push @opstack, $infix;
&reduce();
next; # not really an infix, so keep trying
}
# Equal precedence, so use associativity to decide.
if @opstack[*-1]<O><prec> eq $inprec {
my $assoc = 1;
given $inO<assoc> {
when 'non' { $assoc = 0; }
when 'left' { &reduce() } # reduce immediately
when 'right' { } # just shift
when 'chain' { } # just shift
when 'unary' { } # just shift
when 'list' {
$assoc = 0 unless $infix<sym> eqv @opstack[*-1]<sym>;
}
default { $here.panic('Unknown associativity "' ~ $_ ~ '" for "' ~ $infix<sym> ~ '"') }
}
if not $assoc {
$here.sorry('"' ~ @opstack[*-1]<sym> ~ '" and "' ~ $infix.Str ~ '" are non-associative and require parens');
}
}
$termish = $inO<nextterm> if $inO<nextterm>;
push @opstack, $infix; # The Shift
last;
}
}
&reduce() while +@opstack > 1;
if @termstack {
+@termstack == 1 or $here.panic("Internal operator parser error, termstack == " ~ (+@termstack));
@termstack[0].from = self.pos;
@termstack[0].pos = $here.pos;
}
self._MATCHIFYr($S, "EXPR", @termstack);
}
##########
## Regex #
##########
grammar Regex is STD {
multi method tweak (:Perl5(:$P5)!) { self.require_P5; self.cursor_fresh( %*LANG<Q> ).mixin( ::q ).mixin( ::p5 ) }
multi method tweak (:overlap(:$ov)!) { %*RX<ov> = $ov; self; }
multi method tweak (:exhaustive(:$ex)!) { %*RX<ex> = $ex; self; }
multi method tweak (:continue(:$c)!) { %*RX<c> = $c; self; }
multi method tweak (:pos(:$p)!) { %*RX<p> = $p; self; }
multi method tweak (:sigspace(:$s)!) { %*RX<s> = $s; self; }
multi method tweak (:ratchet(:$r)!) { %*RX<r> = $r; self; }
multi method tweak (:global(:$g)!) { %*RX<g> = $g; self; }
multi method tweak (:ignorecase(:$i)!) { %*RX<i> = $i; self; }
multi method tweak (:ignoremark(:$m)!) { %*RX<m> = $m; self; }
multi method tweak (:samecase(:$ii)!) { %*RX<ii> = $ii; self; }
multi method tweak (:samemark(:$mm)!) { %*RX<mm> = $mm; self; }
multi method tweak (:$nth!) { %*RX<nth> = $nth; self; }
multi method tweak (:st(:$nd)!) { %*RX<nth> = $nd; self; }
multi method tweak (:rd(:$th)!) { %*RX<nth> = $th; self; }
multi method tweak (:$x!) { %*RX<x> = $x; self; }
multi method tweak (:$bytes!) { %*RX<bytes> = $bytes; self; }
multi method tweak (:$codes!) { %*RX<codes> = $codes; self; }
multi method tweak (:$graphs!) { %*RX<graphs> = $graphs; self; }
multi method tweak (:$chars!) { %*RX<chars> = $chars; self; }
multi method tweak (:$rw!) { %*RX<rw> = $rw; self; }
token category:metachar { <sym> }
proto token metachar {*}
token category:sigmaybe { <sym> }
proto token sigmaybe {*}
token category:backslash { <sym> }
proto token backslash {*}
token category:assertion { <sym> }
proto token assertion {*}
token category:quantifier { <sym> }
proto token quantifier {*}
token category:cclass_elem { <sym> }
proto token cclass_elem {*}
token category:mod_internal { <sym> }
proto token mod_internal {*}
proto token regex_infix {*}
token normspace {
<?before \s | '#'> [ :lang(%*LANG<MAIN>) <.ws> ]
}
token unsp { '\\' <?before \s | '#'> <.panic: "No unspace allowed in regex; if you meant to match the literal character, please enclose in single quotes ('" ~ substr(self.orig,$¢.pos,1) ~ "') or use a backslashed form like \\x" ~ sprintf('%02x',...
rule nibbler {
:temp %*RX;
[ <.normspace>? < || | && & > ]?
<EXPR>
[
|| <?infixstopper>
|| $$ <.panic: "Regex not terminated">
|| (\W)<.sorry("Unrecognized regex metacharacter " ~ $0.Str ~ " (must be quoted to match literally)")>
|| <.panic: "Regex not terminated">
]
share/P6STD/STD.pm6 view on Meta::CPAN
{ $¢.check_variable($<variable>) unless substr($<sym>,1,1) eq '<' }
|| { $¢.check_variable($<variable>) }
[ <?before '.'? <[ \[ \{ \< ]>> <.worry: "Apparent subscript will be treated as regex"> ]?
]
<.SIGOK>
}
token backslash:unspace { <?before \s> [ :lang( %*LANG<MAIN> ) <.ws> ] }
token backslash:sym<0> { '0' <!before <[0..7]> > <.SIGOK> }
token backslash:A { <sym> <.obs('\\A as beginning-of-string matcher', '^')> }
token backslash:a { <sym> <.sorry: "\\a is allowed only in strings, not regexes"> }
token backslash:B { <sym> <.obs('\\B as word non-boundary', '<!wb>')> }
token backslash:b { <sym> <.obs('\\b as word boundary', '<?wb> (or either of « or »)')> }
token backslash:c { :i <sym> <charspec> <.SIGOK> }
token backslash:d { :i <sym> <.SIGOK> }
token backslash:e { :i <sym> <.SIGOK> }
token backslash:f { :i <sym> <.SIGOK> }
token backslash:h { :i <sym> <.SIGOK> }
token backslash:n { :i <sym> <.SIGOK> }
token backslash:o { :i :dba('octal character') <sym> [ <octint> | '[' ~ ']' <octints> ] <.SIGOK> }
token backslash:p {
:my $s;
:my $m;
:my $p;
<sym=[pP]>
{ $s = $<sym>.Str; $m = $s lt 'a' ?? '-' !! ''; }
[
|| (\w) { $p = $0.Str; $¢.obs("\\$s$p", '<' ~ $m ~ ":$p>"); }
|| '{' $<param>=[\w+] '}' { $p = $<param>.Str; $¢.obs("\\$s\{$p\}", '<' ~ $m ~ ":$p>"); }
|| '{' $<param>=[\w+] \= $<val>=[<-[\}]>*] '}' { $p = $<param>.Str; my $v = $<val>.Str; $¢.obs("\\$s\{$p=$v\}", '<' ~ $m ~ ":$p\('$v')>"); }
]
}
token backslash:Q { <sym> <.obs('\\Q as quotemeta', 'quotes or literal variable match')> }
token backslash:r { :i <sym> <.SIGOK> }
token backslash:s { :i <sym> <.SIGOK> }
token backslash:t { :i <sym> <.SIGOK> }
token backslash:v { :i <sym> <.SIGOK> }
token backslash:w { :i <sym> <.SIGOK> }
token backslash:x { :i :dba('hex character') <sym> [ <hexint> | '[' ~ ']' <hexints> ] <.SIGOK> }
token backslash:z { <sym> <.obs('\\z as end-of-string matcher', '$')> }
token backslash:Z { <sym> <.obs('\\Z as end-of-string matcher', '\\n?$')> }
token backslash:misc { $<litchar>=(\W) <.SIGOK> }
token backslash:oldbackref { (<[1..9]>\d*) { my $d = $0.Str; $¢.sorryobs("the 1-based special form '\\$d' as a backreference", "the 0-based variable '\$" ~ ($d - 1) ~ "' instead" ); } }
token backslash:oops { <.sorry: "Unrecognized regex backslash sequence"> . }
token assertion:sym<...> { <sym> }
token assertion:sym<???> { <sym> }
token assertion:sym<!!!> { <sym> }
token assertion:sym<|> { <sym> [ <?before '>'> | <?before \w> <assertion> ] } # assertion-like syntax, anyway
token assertion:sym<?> { <sym> [ <?before '>'> | <assertion> ] }
token assertion:sym<!> { <sym> [ <?before '>'> | <assertion> ] }
token assertion:sym<*> { <sym> [ <?before '>'> | <.ws> <nibbler> ] }
token assertion:sym<{ }> { <embeddedblock> }
token assertion:variable {
<?before <sigil>> # note: semantics must be determined per-sigil
[:lang($¢.cursor_fresh(%*LANG<MAIN>).unbalanced('>')) <variable=.EXPR(item %LOOSEST)>]
}
token assertion:method {
'.' [
| <?before <alpha> > <assertion>
| [ :lang($¢.cursor_fresh(%*LANG<MAIN>).unbalanced('>')) <dottyop> ]
]
}
token assertion:name { [ :lang($¢.cursor_fresh(%*LANG<MAIN>).unbalanced('>')) <longname> ]
[
| <?before '>' > {
my $n = $<longname>.Str;
if $n eq 'before' or $n eq 'after' {
$¢.panic("$n requires an argument");
}
}
| <.normspace>? <nibbler> <.ws>
| '=' <assertion>
| ':' [ :lang($¢.cursor_fresh(%*LANG<MAIN>).unbalanced('>')) <.ws> <arglist> ]
| '(' {}
[ :lang(%*LANG<MAIN>) <arglist> ]
[ ')' || <.panic: "Assertion call missing right parenthesis"> ]
]?
}
token assertion:sym<:> { <?before ':'> <cclass_expr> }
token assertion:sym<[> { <?before '['> <cclass_expr> }
token assertion:sym<+> { <?before '+'> <cclass_expr> }
token assertion:sym<-> { <?before '-'> <cclass_expr> }
token assertion:sym<.> { <sym> }
token assertion:sym<,> { <sym> }
token assertion:sym<~~> { <sym> [ <?before '>'> | \d+ | <desigilname> ] }
token assertion:bogus { <.panic: "Unrecognized regex assertion"> }
token sign { '+' | '-' | <?> }
token cclass_expr {
::
<.normspace>?
<sign>
<cclass_union> +% [$<op>=[ '|' | '^' ]]
}
token cclass_union {
<.normspace>?
<cclass_add> +% [$<op>=[ '&' ]]
}
token cclass_add {
<.normspace>?
<cclass_elem> +% [$<op>=[ '+' | '-' ]<.normspace>?]
}
token cclass_elem:name {
:dba('character class element')
<name>
<.normspace>?
}
token cclass_elem:sym<[ ]> {
:my $*CCSTATE = '';
:dba('character class element')
"[" ~ "]" <nibble($¢.cursor_fresh( %*LANG<Q> ).tweak(:cc).unbalanced("]"))>
<.normspace>?
}
token cclass_elem:sym<( )> {
:my $*CCSTATE = '';
:dba('character class element')
'(' ~ ')' <cclass_expr>
<.normspace>?
}
token cclass_elem:property {
:dba('character class element')
[:lang(%*LANG<MAIN>) <colonpair> ]
<.normspace>?
}
token cclass_elem:quote {
<?before '"' | "'">
[:lang(%*LANG<MAIN>) <quote> ]
<.normspace>?
}
token mod_arg { :dba('modifier argument') '(' ~ ')' [:lang(%*LANG<MAIN>) <semilist> ] }
token mod_internal:sym<:my> { ':' <?before ['my'|'state'|'our'|'anon'|'constant'|'temp'|'let'] \s > [:lang(%*LANG<MAIN>) <statement> <eat_terminator> ] }
# XXX needs some generalization
token mod_internal:sym<:i> { $<sym>=[':i'|':ignorecase'] » { %*RX<i> = 1 } }
token mod_internal:sym<:!i> { $<sym>=[':!i'|':!ignorecase'] » { %*RX<i> = 0 } }
token mod_internal:sym<:i( )> { $<sym>=[':i'|':ignorecase'] <mod_arg> { %*RX<i> = eval $<mod_arg>.Str } }
token mod_internal:sym<:0i> { ':' (\d+) ['i'|'ignorecase'] { %*RX<i> = $0 } }
token mod_internal:sym<:m> { $<sym>=[':m'|':ignoremark'] » { %*RX<m> = 1 } }
token mod_internal:sym<:!m> { $<sym>=[':!m'|':!ignoremark'] » { %*RX<m> = 0 } }
token mod_internal:sym<:m( )> { $<sym>=[':m'|':ignoremark'] <mod_arg> { %*RX<m> = eval $<mod_arg>.Str } }
token mod_internal:sym<:0m> { ':' (\d+) ['m'|'ignoremark'] { %*RX<m> = $0 } }
token mod_internal:sym<:s> { ':s' 'igspace'? » { %*RX<s> = 1 } }
token mod_internal:sym<:!s> { ':!s' 'igspace'? » { %*RX<s> = 0 } }
token mod_internal:sym<:s( )> { ':s' 'igspace'? <mod_arg> { %*RX<s> = eval $<mod_arg>.Str } }
token mod_internal:sym<:0s> { ':' (\d+) 's' 'igspace'? » { %*RX<s> = $0 } }
token mod_internal:sym<:r> { ':r' 'atchet'? » { %*RX<r> = 1 } }
token mod_internal:sym<:!r> { ':!r' 'atchet'? » { %*RX<r> = 0 } }
token mod_internal:sym<:r( )> { ':r' 'atchet'? » <mod_arg> { %*RX<r> = eval $<mod_arg>.Str } }
token mod_internal:sym<:0r> { ':' (\d+) 'r' 'atchet'? » { %*RX<r> = $0 } }
token mod_internal:sym<:Perl5> { [':Perl5' | ':P5'] <.require_P5> [ :lang( $¢.cursor_fresh( %*LANG<P5Regex> ).unbalanced($*GOAL) ) <nibbler> ] }
token mod_internal:p6adv {
<?before ':' ['dba'|'lang'] » > [ :lang(%*LANG<MAIN>) <quotepair> ] $<sym> = {':' ~ $<quotepair><k>}
}
token mod_internal:oops { {} (':'\w+) <.sorry: "Unrecognized regex modifier " ~ $0.Str > }
token quantifier:sym<*> { <sym> <quantmod> }
token quantifier:sym<+> { <sym> <quantmod> }
token quantifier:sym<?> { <sym> <quantmod> }
token quantifier:sym<:> { <sym> {} <?before \s> }
token quantifier:sym<**> { '**' :: <normspace>? <quantmod> <normspace>?
[
| \d+ \s+ '..' <.panic: "Spaces not allowed in bare range">
| (\d+) [ '..' [ (\d+) { $¢.panic("Empty range") if $0.Str > $1[0].Str } | '*' | <.panic: "Malformed range"> ] ]?
| <embeddedblock>
| {} <quantified_atom> { $¢.worryobs("atom ** " ~ $<quantified_atom>.Str ~ " as separator", "atom +% " ~ $<quantified_atom>.Str, " nowadays"); }
]
}
token quantifier:sym<~> {
<sym> :: <normspace>? <quantified_atom> <normspace>? <quantified_atom>
}
token quantifier:sym<~~> {
[
| '!' <sym>
| <sym>
]
<normspace> <quantified_atom> }
token quantmod { ':'? [ '?' | '!' | '+' ]? }
token quantifier:sym<{N,M}> {
{} '{' (\d+) (','?) (\d*) '}'
{
my $all = substr(self.orig, self.pos, $¢.pos - self.pos);
my $repl = chars($1.Str) ??
($0.Str ~ '..' ~ ($2.Str || '*')) !! $0.Str;
$¢.sorryobs($all ~ " as general quantifier", 'X**' ~ $repl);
}
}
}
method require_P5 {
require STD_P5;
self;
}
method require_P6 {
require STD_P6;
self;
}
#################
# Symbol tables #
#################
method newlex ($needsig = 0) {
my $oid = $*CURLEX.id;
share/P6STD/STD.pm6 view on Meta::CPAN
}
else {
$id = 'MY:file<' ~ $*FILE<name> ~ '>:line(' ~ $line ~ '):pos(' ~ self.pos ~ ')';
$*CURLEX = Stash.new(
'OUTER::' => [$oid],
'!file' => $*FILE, '!line' => $line,
'!id' => [$id],
);
}
$*CURLEX.<!NEEDSIG> = 1 if $needsig;
$*CURLEX.<!IN_DECL> = $*IN_DECL if $*IN_DECL;
$ALL.{$id} = $*CURLEX;
self.<LEX> = $*CURLEX;
$*DECLARAND<curlex> = $*CURLEX if $*DECLARAND;
self;
}
method finishlex {
my $line = self.lineof(self.pos);
$*CURLEX<$_> //= NAME.new( name => '$_', file => $*FILE, line => $line, dynamic => 1, scope => 'my' );
$*CURLEX<$/> //= NAME.new( name => '$/', file => $*FILE, line => $line, dynamic => 1, scope => 'my' );
$*CURLEX<$!> //= NAME.new( name => '$!', file => $*FILE, line => $line, dynamic => 1, scope => 'my' );
$*SIGNUM = 0;
self;
}
method getsig {
my $pv = $*CURLEX.{'%?PLACEHOLDERS'};
my $sig;
if $*CURLEX.<!NEEDSIG>:delete {
if $pv {
my $h_ = ($pv.<%_>:delete);
my $a_ = ($pv.<@_>:delete);
$sig = join ', ', sort { substr($^a,1) leg substr($^b,1) }, keys %$pv;
$sig ~= ', *@_' if $a_;
$sig ~= ', *%_' if $h_;
}
else {
$sig = '$_ is ref = OUTER::<$_>';
}
$*CURLEX.<$?SIGNATURE> = $sig;
}
else {
$sig = $*CURLEX.<$?SIGNATURE>;
}
self.<sig> = self.makestr(TEXT => $sig);
self.<lex> = $*CURLEX.idref;
if ($*DECLARAND<mult>//'') ne 'proto' {
for keys %$*CURLEX {
my $desc = $*CURLEX{$_};
next unless $_ ~~ m/(\$|\@|\%|\&)\w/;
next if $_ eq '$_' or $_ eq '@_' or $_ eq '%_';
next if $desc<used>;
next if $desc<rebind>;
next if $desc<dynamic>;
my $scope = $desc<scope> // 'my';
next if $scope eq 'our';
next if $scope eq 'state';
next if $desc<stub>;
my $pos = $desc<declaredat> // self.pos;
self.cursor($pos).worry("$_ is declared but not used");
}
}
self;
}
method getdecl {
self.<decl> = $*DECLARAND;
self;
}
method is_name ($n, $curlex = $*CURLEX) {
my $name = $n;
self.deb("is_name $name") if $*DEBUG +& DEBUG::symtab;
my $curpkg = $*CURPKG;
return True if $name ~~ /\:\:\(/;
my @components = self.canonicalize_name($name);
if @components > 1 {
return True if @components[0] eq 'COMPILING::';
return True if @components[0] eq 'CALLER::';
return True if @components[0] eq 'CONTEXT::';
if $curpkg = self.find_top_pkg(@components[0]) {
self.deb("Found lexical package ", @components[0]) if $*DEBUG +& DEBUG::symtab;
shift @components;
}
else {
self.deb("Looking for GLOBAL::<$name>") if $*DEBUG +& DEBUG::symtab;
$curpkg = $*GLOBAL;
}
while @components > 1 {
my $pkg = shift @components;
$curpkg = $curpkg.{$pkg};
return False unless $curpkg;
try {
my $outlexid = $curpkg.[0];
return False unless $outlexid;
$curpkg = $ALL.{$outlexid};
return False unless $curpkg;
};
self.deb("Found $pkg okay") if $*DEBUG +& DEBUG::symtab;
}
}
$name = shift(@components)//'';
self.deb("Looking for $name") if $*DEBUG +& DEBUG::symtab;
return True if $name eq '';
my $lex = $curlex;
while $lex {
self.deb("Looking in ", $lex.id) if $*DEBUG +& DEBUG::symtab;
if $lex.{$name} {
self.deb("Found $name in ", $lex.id) if $*DEBUG +& DEBUG::symtab;
$lex.{$name}<used> = 1;
return True;
}
my $oid = $lex.<OUTER::>[0] || last;
$lex = $ALL.{$oid};
}
return True if $curpkg.{$name};
return True if $*GLOBAL.{$name};
self.deb("$name not found") if $*DEBUG +& DEBUG::symtab;
return False;
share/P6STD/STD.pm6 view on Meta::CPAN
my $scope = $*SCOPE || 'our';
return self if $scope eq 'anon';
if $scope eq 'our' {
self.add_our_name($name);
}
else {
self.add_my_name($name);
}
self;
}
method add_constant($name,$value) {
my $*IN_DECL = 'constant';
self.deb("add_constant $name = $value in", $*CURLEX.id) if $*DEBUG +& DEBUG::symtab;
my $*DECLARAND;
self.add_my_name($name);
$*DECLARAND<value> = $value;
self;
}
method add_placeholder($name) {
my $decl = $*CURLEX.<!IN_DECL> // '';
$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;
$twigil = '^' if $varname ~~ s/\^//;
$signame = $twigil = ':' if $varname ~~ s/\://;
$signame ~= $varname;
return self if $*CURLEX.{'%?PLACEHOLDERS'}{$signame}++;
if $*CURLEX{$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.add_my_name($varname);
$*CURLEX{$varname}<used> = 1;
self;
}
method check_variable ($variable) {
my $name = $variable.Str;
my $here = self.cursor($variable.from);
self.deb("check_variable $name") if $*DEBUG +& DEBUG::symtab;
my ($sigil, $twigil, $first) = $name ~~ /(\$|\@|\%|\&)(\W*)(.?)/;
($first,$twigil) = ($twigil, '') if $first eq '';
given $twigil {
when '' {
my $ok = 0;
$ok ||= $*IN_DECL;
$ok ||= $first lt 'A';
$ok ||= $first eq '¢';
$ok ||= self.is_known($name);
$ok ||= $name ~~ /.\:\:/ && $name !~~ /MY|UNIT|OUTER|SETTING|CORE/;
if not $ok {
my $id = $name;
$id ~~ s/^\W\W?//;
if $sigil eq '&' {
$here.add_mystery($variable.<sublongname>, self.pos, 'var')
}
elsif $name eq '@_' or $name eq '%_' {
$here.add_placeholder($name);
}
else { # guaranteed fail now
if my $scope = @*MEMOS[$variable.from]<declend> {
return $here.sorry("Variable $name is not predeclared (declarators are tighter than comma, so maybe your '$scope' signature needs parens?)");
}
elsif $id !~~ /\:\:/ {
if self.is_known('@' ~ $id) {
return $here.sorry("Variable $name is not predeclared (did you mean \@$id?)");
}
elsif self.is_known('%' ~ $id) {
return $here.sorry("Variable $name is not predeclared (did you mean \%$id?)");
}
}
return $here.sorry("Variable $name is not predeclared");
}
}
elsif $*CURLEX{$name} {
$*CURLEX{$name}<used>++;
}
}
when '!' {
if not $*HAS_SELF { # XXX to be replaced by MOP queries
$here.sorry("Variable $name used where no 'self' is available");
}
}
when '.' {
given $*HAS_SELF { # XXX to be replaced by MOP queries
when 'complete' {}
when 'partial' { $here.sorry("Virtual call $name may not be used on partially constructed object"); }
default { $here.sorry("Variable $name used where no 'self' is available"); }
}
}
when '^' {
my $*MULTINESS = 'multi';
$here.add_placeholder($name);
}
when ':' {
my $*MULTINESS = 'multi';
$here.add_placeholder($name);
}
when '~' {
share/P6STD/STD.pm6 view on Meta::CPAN
}
else {
return $lex.<value>;
}
}
given $name {
when '$?FILE' { return $*FILE<name>; }
when '$?LINE' { return self.lineof(self.pos); }
when '$?POSITION' { return self.pos; }
when '$?LANG' { return item %*LANG; }
when '$?LEXINFO' { return $*CURLEX; }
when '$?PACKAGE' { return $*CURPKG; }
when '$?MODULE' { return $*CURPKG; } # XXX should scan
when '$?CLASS' { return $*CURPKG; } # XXX should scan
when '$?ROLE' { return $*CURPKG; } # XXX should scan
when '$?GRAMMAR' { return $*CURPKG; } # XXX should scan
when '$?PACKAGENAME' { return $*CURPKG.id }
when '$?OS' { return 'unimpl'; }
when '$?DISTRO' { return 'unimpl'; }
when '$?VM' { return 'unimpl'; }
when '$?XVM' { return 'unimpl'; }
when '$?PERL' { return 'unimpl'; }
when '$?USAGE' { return 'unimpl'; }
when '&?ROUTINE' { return 'unimpl'; }
when '&?BLOCK' { return 'unimpl'; }
when '%?CONFIG' { return 'unimpl'; }
when '%?DEEPMAGIC' { return 'unimpl'; }
my $dynvar = self.lookup_dynvar($name);
return $dynvar if defined $dynvar;
return $default if defined $default;
# (derived grammars should default to nextsame, terminating here)
default { self.worry("Unrecognized variable: $name"); return 0; }
}
}
####################
# Service Routines #
####################
method panic (Str $s) {
die "Recursive panic" if $*IN_PANIC;
$*IN_PANIC++;
self.deb("panic $s") if $*DEBUG;
my $m;
my $here = self;
# Have we backed off recently?
my $highvalid = self.pos <= $*HIGHWATER;
$here = self.cursor($*HIGHWATER) if $highvalid;
my $first = $here.lineof($*LAST_NIBBLE.from);
my $last = $here.lineof($*LAST_NIBBLE.pos);
if $first != $last {
if $here.lineof($here.pos) == $last {
$m ~= "(Possible runaway string from line $first)\n";
}
else {
$first = $here.lineof($*LAST_NIBBLE_MULTILINE.from);
$last = $here.lineof($*LAST_NIBBLE_MULTILINE.pos);
# the bigger the string (in lines), the further back we suspect it
if $here.lineof($here.pos) - $last < $last - $first {
$m ~= "(Possible runaway string from line $first to line $last)\n";
}
}
}
$m ~= $s;
if substr(self.orig,$here.pos,1) ~~ /\)|\]|\}|\»/ {
$m ~~ s|Confused|Unexpected closing bracket| and $highvalid = False;
}
if $highvalid {
$m ~= $*HIGHMESS if $*HIGHMESS;
$*HIGHMESS = $m;
}
else {
# not in backoff, so at "bleeding edge", as it were... therefore probably
# the exception will be caught and re-panicked later, so remember message
$*HIGHMESS ~= $s ~ "\n";
}
my $x = '';
if $highvalid and %$*HIGHEXPECT {
my @keys = sort keys %$*HIGHEXPECT;
if @keys > 1 {
$x = " expecting any of:\n\t" ~ join("\n\t", sort keys %$*HIGHEXPECT) ~ "\n";
}
else {
$x = " expecting @keys\n" unless @keys[0] eq 'whitespace';
}
}
if $x ~~ /infix|nofun/ and not $x ~~ /regex/ and not $x ~~ /infix_circumfix/ {
my @t = $here.suppose( sub { $here.term } );
if @t {
my $endpos = $here.pos;
my $startpos = @*MEMOS[$endpos]<ws> // $endpos;
if self.lineof($startpos) != self.lineof($endpos) {
$m ~~ s|Confused|Two terms in a row (previous line missing its semicolon?)|;
}
elsif @*MEMOS[$startpos]<listop> {
$m ~~ s|Confused|Two terms in a row (listop with args requires whitespace or parens)|;
}
elsif @*MEMOS[$startpos]<baremeth> {
$here = $here.cursor($startpos);
$m ~~ s|Confused|Two terms in a row (method call with args requires colon or parens without whitespace)|;
}
elsif @*MEMOS[$startpos]<arraycomp> {
$m ~~ s|Confused|Two terms in a row (preceding is not a valid reduce operator)|;
}
else {
$m ~~ s|Confused|Two terms in a row|;
}
}
elsif my $type = @*MEMOS[$here.pos - 1]<nodecl> {
my @t = $here.suppose( sub { $here.variable } );
if @t {
my $variable = @t[0].Str;
$m ~~ s|Confused|Bare type $type cannot declare $variable without a preceding scope declarator such as 'my'|;
}
}
}
elsif my $type = @*MEMOS[$here.pos - 1]<wasname> {
my @t = $here.suppose( sub { $here.identifier } );
my $name = @t[0].Str;
my $s = $*SCOPE ?? "'$*SCOPE'" !! '(missing) scope declarator';
my $d = $*IN_DECL;
$d = "$*MULTINESS $d" if $*MULTINESS and $*MULTINESS ne $d;
$m ~~ s|Malformed block|Return type $type is not allowed between '$d' and '$name'; please put it:\n after the $s but before the '$d',\n within the signature following the '-->' marker, or\n as the argument of a 'returns' trait after the si...
}
$m ~= $here.locmess;
$m ~= "\n" unless $m ~~ /\n$/;
$m ~= $x;
if @*WORRIES {
$m ~= "Other potential difficulties:\n " ~ join( "\n ", @*WORRIES) ~ "\n";
}
$*IN_PANIC--;
die $m if $*IN_SUPPOSE; # just throw the exception back to the supposer
$*IN_PANIC++;
note $Cursor::RED, '===', $Cursor::CLEAR, 'SORRY!', $Cursor::RED, '===', $Cursor::CLEAR, "\n"
unless $*FATALS++;
note $m;
self.explain_mystery();
$*IN_PANIC--;
die "Parse failed\n";
}
regex is_ok {
\N*? '#OK' \h*? $<okif>=[\N*?] \h*? $$
}
method worry (Str $s) {
my $m = $s ~ self.locmess;
# allow compile-time warning suppression with #OK some string
my ($okmaybe) = self.suppose( sub {
self.is_ok;
});
if $okmaybe {
my $okif = $okmaybe<okif>.Str;
( run in 1.229 second using v1.01-cache-2.11-cpan-39bf76dae61 )