Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP

Loading…

Qpir to nqp #44

Closed
wants to merge 11 commits into from

1 participant

@kboga
Collaborator

Just an experiment

"translation" to nqp of the old PIR "cheats" in HLL::Grammar.
Just 1 Q:PIR block left. (nqp doesn't support getting multiple return arguments from subs/methods?)

It passes the nqp testsuite, however I'm not sure about the magnitude of possible slowdowns.

@kboga kboga closed this
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
This page is out of date. Refresh to see the latest.
Showing with 324 additions and 557 deletions.
  1. +324 −557 src/HLL/Grammar.pm
View
881 src/HLL/Grammar.pm
@@ -32,7 +32,6 @@ grammar HLL::Grammar {
# Return <termish> if it matches, <nullterm_alt> otherwise.
method nulltermish() { self.termish || self.nullterm_alt }
- # token quote_EXPR is in src/cheats/hll-grammar.pir
token quote_delimited {
<starter> <quote_atom>* <stopper>
}
@@ -165,142 +164,111 @@ Currently the only pairs recognized have the form C< :pair >,
C< :!pair >, and C<< :pair<strval> >>.
=end
- method O($spec, $save?) {
- Q:PIR {
- .local pmc self, cur_class
- .local string spec, save
- .local int has_save
- self = find_lex 'self'
- cur_class = find_lex '$cursor_class'
- $P0 = find_lex '$spec'
- spec = $P0
- has_save = 0
- $P0 = find_lex '$save'
- unless $P0 goto no_save
- save = $P0
- has_save = 1
- no_save:
-
- # First, get the hash cache. Right now we have one
- # cache for all grammars; eventually we may need a way to
- # separate them out by cursor type.
- .local pmc ohash
- ohash = get_global '%!ohash'
- unless null ohash goto have_ohash
- ohash = new ['Hash']
- set_global '%!ohash', ohash
- have_ohash:
-
- # See if we've already created a Hash for the current
- # specification string -- if so, use that.
- .local pmc hash
- hash = ohash[spec]
- unless null hash goto hash_done
+ method O($spec, $save?) {
+ # First, get the hash cache. Right now we have one
+ # cache for all grammars; eventually we may need a way to
+ # separate them out by cursor type.
+ my %ohash := pir::get_global__Ps('%!ohash');
+ unless %ohash {
+ %ohash := nqp::hash();
+ pir::set_global__vsP('%!ohash', %ohash);
+ }
+
+ # See if we've already created a Hash for the current
+ # specification string -- if so, use that.
+ my %hash := %ohash{$spec};
+ unless %hash {
# Otherwise, we need to build a new one.
- hash = new ['Hash']
- .local int pos, eos
- pos = 0
- eos = length spec
- spec_loop:
- pos = find_not_cclass .CCLASS_WHITESPACE, spec, pos, eos
- if pos >= eos goto spec_done
- $S0 = substr spec, pos, 1
- if $S0 == ',' goto spec_comma
- if $S0 == ':' goto spec_pair
-
- # If whatever we found doesn't start with a colon, treat it
- # as a lookup of a previously saved hash to be merged in.
- .local string lookup
- .local int lpos
- # Find the first whitespace or comma
- lpos = find_cclass .CCLASS_WHITESPACE, spec, pos, eos
- $I0 = index spec, ',', pos
- if $I0 < 0 goto have_lookup_lpos
- if $I0 >= lpos goto have_lookup_lpos
- lpos = $I0
- have_lookup_lpos:
- $I0 = lpos - pos
- lookup = substr spec, pos, $I0
- .local pmc lhash, lhash_it
- lhash = ohash[lookup]
- if null lhash goto err_lookup
- lhash_it = iter lhash
- lhash_loop:
- unless lhash_it goto lhash_done
- $S0 = shift lhash_it
- $P0 = lhash[$S0]
- hash[$S0] = $P0
- goto lhash_loop
- lhash_done:
- pos = lpos
- goto spec_loop
-
- # We just ignore commas between elements for now.
- spec_comma:
- inc pos
- goto spec_loop
-
- # If we see a colon, then we want to parse whatever
- # comes next like a pair.
- spec_pair:
- # eat colon
- inc pos
- .local string name
- .local pmc value
- value = new ['Boolean']
-
- # If the pair is of the form :!name, then reverse the value
- # and skip the colon.
- $S0 = substr spec, pos, 1
- $I0 = iseq $S0, '!'
- pos += $I0
- $I0 = not $I0
- value = $I0
-
- # Get the name of the pair.
- lpos = find_not_cclass .CCLASS_WORD, spec, pos, eos
- $I0 = lpos - pos
- name = substr spec, pos, $I0
- pos = lpos
-
- # Look for a <...> that follows.
- $S0 = substr spec, pos, 1
- unless $S0 == '<' goto have_value
- inc pos
- lpos = index spec, '>', pos
- $I0 = lpos - pos
- $S0 = substr spec, pos, $I0
- value = box $S0
- pos = lpos + 1
- have_value:
- # Done processing the pair, store it in the hash.
- hash[name] = value
- goto spec_loop
- spec_done:
+ %hash := nqp::hash();
+ my $pos := 0;
+ my $eos := nqp::chars($spec);
+ while 1 {
+ $pos := nqp::findnotcclass(
+ pir::const::CCLASS_WHITESPACE, $spec, $pos, $eos);
+ last if $pos >= $eos;
+ my $s := nqp::substr($spec, $pos, 1);
+ my $i;
+ my $lpos;
+ if $s eq ',' {
+ # We just ignore commas between elements for now.
+ $pos := $pos + 1;
+ next;
+ }
+ elsif $s eq ':' {
+ # If we see a colon, then we want to parse whatever
+ # comes next like a pair.
+ # eat colon
+ $pos := $pos + 1;
+ my $value := pir::new__Ps('Boolean');
+
+ # If the pair is of the form :!name, then reverse the value
+ # and skip the colon.
+ if nqp::substr($spec, $pos, 1) eq '!' {
+ $pos := $pos + 1;
+ $value := 0;
+ }
+ else {
+ $value := 1;
+ }
+
+ # Get the name of the pair.
+ $lpos := nqp::findnotcclass(
+ pir::const::CCLASS_WORD, $spec, $pos, $eos);
+ my $name := nqp::substr($spec, $pos, $lpos - $pos);
+ $pos := $lpos;
+
+ # Look for a <...> that follows.
+ if nqp::substr($spec, $pos, 1) eq '<' {
+ $pos := $pos + 1;
+ $lpos := nqp::index($spec, '>', $pos);
+ $s := nqp::substr($spec, $pos, $lpos - $pos);
+ $value := pir::box__Ps($s);
+ $pos := $lpos + 1;
+ }
+ # Done processing the pair, store it in the hash.
+ %hash{$name} := $value;
+ }
+ else {
+ my $lookup;
+ # If whatever we found doesn't start with a colon, treat it
+ # as a lookup of a previously saved hash to be merged in.
+ # Find the first whitespace or comma
+ $lpos := pir::find_cclass__Iisii(
+ pir::const::CCLASS_WHITESPACE, $spec, $pos, $eos);
+ $i := nqp::index($spec, ',', $pos);
+ $lpos := $i unless $i < 0 || $i >= $lpos;
+ $lookup := nqp::substr($spec, $pos, $lpos - $pos);
+ my %lhash := %ohash{$lookup};
+ self.'panic'('Unknown operator precedence specification "',
+ $lookup, '"') unless %lhash;
+ my $lhash_it := nqp::iterator(%lhash);
+ while $lhash_it {
+ $s := nqp::shift($lhash_it);
+ %hash{$s} := %lhash{$s};
+ }
+ $pos := $lpos;
+ }
+ }
# Done processing the spec string, cache the hash for later.
- ohash[spec] = hash
- hash_done:
+ %ohash{$spec} := %hash;
+ }
+ if $save {
+ %ohash{$save} := %hash;
+ return self;
+ }
+ else {
# If we've been called as a subrule, then build a pass-cursor
# to indicate success and set the hash as the subrule's match object.
- if has_save goto save_hash
- ($P0, $S0, $I0) = self.'!cursor_start'()
- $P0.'!cursor_pass'($I0, '')
- setattribute $P0, cur_class, '$!match', hash
- .return ($P0)
-
- # save the hash under a new entry
- save_hash:
- ohash[save] = hash
- .return (self)
-
- err_lookup:
- self.'panic'('Unknown operator precedence specification "', lookup, '"')
- };
+ my $cur := self.'!cursor_start'();
+ my $pos := nqp::getattr_i($cur, $cursor_class, '$!from');
+ $cur.'!cursor_pass'($pos);
+ nqp::bindattr($cur, $cursor_class, '$!match', %hash);
+ return $cur;
+ }
}
-
=begin
=item panic([args :slurpy])
@@ -333,65 +301,42 @@ position C<pos>.
=end
method peek_delimiters($target, $pos) {
- Q:PIR {
- .local pmc self
- self = find_lex 'self'
- .local string target
- $P0 = find_lex '$target'
- target = $P0
- .local int pos
- $P0 = find_lex '$pos'
- pos = $P0
-
- .local string brackets, start, stop
- $P0 = find_lex '$brackets'
- brackets = $P0
-
- # peek at the next character
- start = substr target, pos, 1
- # colon and word characters aren't valid delimiters
- if start == ':' goto err_colon_delim
- $I0 = is_cclass .CCLASS_WORD, start, 0
- if $I0 goto err_word_delim
- $I0 = is_cclass .CCLASS_WHITESPACE, start, 0
- if $I0 goto err_ws_delim
-
- # assume stop delim is same as start, for the moment
- stop = start
-
- # see if we have an opener or closer
- $I0 = index brackets, start
- if $I0 < 0 goto bracket_end
- # if it's a closing bracket, that's an error also
- $I1 = $I0 % 2
- if $I1 goto err_close
- # it's an opener, so get the closing bracket
- inc $I0
- stop = substr brackets, $I0, 1
-
- # see if the opening bracket is repeated
- .local int len
- len = 0
- bracket_loop:
- inc pos
- inc len
- $S0 = substr target, pos, 1
- if $S0 == start goto bracket_loop
- if len == 1 goto bracket_end
- start = repeat start, len
- stop = repeat stop, len
- bracket_end:
- .return (start, stop, pos)
-
- err_colon_delim:
- self.'panic'('Colons may not be used to delimit quoting constructs')
- err_word_delim:
- self.'panic'('Alphanumeric character is not allowed as a delimiter')
- err_ws_delim:
- self.'panic'('Whitespace character is not allowed as a delimiter')
- err_close:
- self.'panic'('Use of a closing delimiter for an opener is reserved')
- };
+ # Peek at the next character.
+ my $start := nqp::substr($target, $pos, 1);
+
+ self.'panic'('Colons may not be used to delimit quoting constructs')
+ if $start eq ':';
+ self.'panic'('Whitespace character is not allowed as a delimiter')
+ if nqp::iscclass(pir::const::CCLASS_WHITESPACE, $start, 0);
+
+ # assume stop delim is same as start, for the moment
+ my $stop := $start;
+
+ # see if we have an opener or closer
+ my $index := nqp::index($brackets, $start);
+ unless $index < 0 {
+ # If it's a closing bracket, that's an error also.
+ self.'panic'('Use of a closing delimiter for an opener is reserved')
+ if $index % 2;
+
+ # It's an opener, so get the closing bracket.
+ $stop := nqp::substr($brackets, $index + 1, 1);
+
+ # See if the opening bracket is repeated.
+ my $len := 0;
+ my $s;
+ repeat {
+ $pos := $pos + 1;
+ $len := $len + 1;
+ $s := nqp::substr($target, $pos, 1);
+ } while $s eq $start;
+
+ unless $len == 1 {
+ $start := nqp::x($start, $len);
+ $stop := nqp::x($stop, $len);
+ }
+ }
+ pir::return__vssi($start, $stop, $pos);
}
token quote_EXPR(*@args) {
@@ -399,40 +344,30 @@ position C<pos>.
:my $*QUOTE_START;
:my $*QUOTE_STOP;
{
- Q:PIR {
- .local pmc self, cur_class, args
- self = find_lex 'self'
- cur_class = find_lex '$cursor_class'
- args = find_lex '@args'
-
- .local pmc quotemod, true
- quotemod = find_lex '%*QUOTEMOD'
- true = box 1
-
- args_loop:
- unless args goto args_done
- .local string mod
- mod = shift args
- mod = substr mod, 1
- quotemod[mod] = true
- if mod == 'qq' goto opt_qq
- if mod == 'b' goto opt_b
- goto args_loop
- opt_qq:
- quotemod['s'] = true
- quotemod['a'] = true
- quotemod['h'] = true
- quotemod['f'] = true
- quotemod['c'] = true
- quotemod['b'] = true
- opt_b:
- quotemod['q'] = true
- goto args_loop
- args_done:
-
- .local pmc start, stop
+ my $true := pir::box__Pi(1);
+ for @args {
+ my $mod := nqp::substr($_, 1);
+ %*QUOTEMOD{$mod} := $true;
+
+ if $mod eq 'qq' {
+ %*QUOTEMOD<s> := $true;
+ %*QUOTEMOD<a> := $true;
+ %*QUOTEMOD<h> := $true;
+ %*QUOTEMOD<f> := $true;
+ %*QUOTEMOD<c> := $true;
+ %*QUOTEMOD<b> := $true;
+ }
+ elsif $mod eq 'b' {
+ %*QUOTEMOD<q> := $true
+ }
+ }
+
+ Q:PIR {
+ .local pmc self, cur_class, start, stop
.local string target
.local int pos
+ self = find_lex 'self'
+ cur_class = find_lex '$cursor_class'
target = repr_get_attr_str self, cur_class, '$!target'
pos = repr_get_attr_int self, cur_class, '$!pos'
(start, stop) = self.'peek_delimiters'(target, pos)
@@ -448,74 +383,49 @@ position C<pos>.
}
method starter() {
- Q:PIR {
- .local pmc self, cur
- .local string target, start
- .local int pos
- self = find_lex 'self'
-
- (cur, target, pos) = self.'!cursor_start'()
-
- $P0 = find_dynamic_lex '$*QUOTE_START'
- if null $P0 goto fail
- start = $P0
-
- $I0 = length start
- $S0 = substr target, pos, $I0
- unless $S0 == start goto fail
- pos += $I0
- cur.'!cursor_pass'(pos, 'starter')
- fail:
- .return (cur)
- };
+ my $cur := self.'!cursor_start'();
+ my $target := nqp::getattr_s($cur, $cursor_class, '$!target');
+ my $pos := nqp::getattr_i($cur, $cursor_class, '$!from');
+ my $quote_start := pir::find_dynamic_lex__Ps('$*QUOTE_START');
+ return $cur if $quote_start eq '';
+
+ my $i := nqp::chars($quote_start);
+ return $cur unless $quote_start eq nqp::substr($target, $pos, $i);
+
+ $cur.'!cursor_pass'($pos + $i, 'starter');
+ return $cur;
+
}
method stopper() {
- Q:PIR {
- .local pmc self, cur
- .local string target, stop
- .local int pos
- self = find_lex 'self'
-
- (cur, target, pos) = self.'!cursor_start'()
-
- $P0 = find_dynamic_lex '$*QUOTE_STOP'
- if null $P0 goto fail
- stop = $P0
-
- $I0 = length stop
- $S0 = substr target, pos, $I0
- unless $S0 == stop goto fail
- pos += $I0
- cur.'!cursor_pass'(pos, 'stopper')
- fail:
- .return (cur)
- };
+ my $cur := self.'!cursor_start'();
+ my $target := nqp::getattr_s($cur, $cursor_class, '$!target');
+ my $pos := nqp::getattr_i($cur, $cursor_class, '$!from');
+ my $quote_stop := pir::find_dynamic_lex__Ps('$*QUOTE_STOP');
+ return $cur if $quote_stop eq '';
+
+ my $i := nqp::chars($quote_stop);
+ return $cur unless $quote_stop eq nqp::substr($target, $pos, $i);
+
+ $cur.'!cursor_pass'($pos + $i, 'stopper');
+ return $cur;
}
our method split_words($words) {
- Q:PIR {
- .include 'src/Regex/constants.pir'
- .local string words
- $P0 = find_lex '$words'
- words = $P0
- .local int pos, eos
- .local pmc result
- pos = 0
- eos = length words
- result = new ['ResizablePMCArray']
- split_loop:
- pos = find_not_cclass .CCLASS_WHITESPACE, words, pos, eos
- unless pos < eos goto split_done
- $I0 = find_cclass .CCLASS_WHITESPACE, words, pos, eos
- $I1 = $I0 - pos
- $S0 = substr words, pos, $I1
- push result, $S0
- pos = $I0
- goto split_loop
- split_done:
- .return (result)
- };
+ my $pos := 0;
+ my $eos := nqp::chars($words);
+ my @result := nqp::list();
+
+ while 1 {
+ $pos := nqp::findnotcclass(pir::const::CCLASS_WHITESPACE,
+ $words, $pos, $eos);
+ last unless $pos < $eos;
+ my $i := pir::find_cclass__Iisii(pir::const::CCLASS_WHITESPACE,
+ $words, $pos, $eos);
+ nqp::push(@result, nqp::substr($words, $pos, $i - $pos));
+ $pos := $i;
+ }
+ return @result;
}
=begin
@@ -527,276 +437,137 @@ An operator precedence parser.
=end
method EXPR($preclim = '') {
- Q:PIR {
- .local pmc self, cur_class
- self = find_lex 'self'
- cur_class = find_lex '$cursor_class'
-
- .local string preclim
- $P0 = find_lex '$preclim'
- preclim = $P0
+ my $here := self.'!cursor_start'();
+ my $pos := nqp::getattr_i($here, $cursor_class, '$!from');
+ my $termishrx := 'termish';
+ my @opstack := nqp::list();
+ my @termstack := nqp::list();
+
+ while 1 {
+ nqp::bindattr_i($here, $cursor_class, '$!pos', $pos);
+ my $termcur := $here."$termishrx"();
+ $pos := nqp::getattr_i($termcur, $cursor_class, '$!pos');
+ nqp::bindattr_i($here, $cursor_class, '$!pos', $pos);
+ return $here if $pos < 0;
- .local pmc here
- .local string tgt
- .local int pos
- (here, tgt, pos) = self.'!cursor_start'()
-
- .local string termishrx
- termishrx = 'termish'
-
- .local pmc opstack, termstack
- opstack = new ['ResizablePMCArray']
- .lex '@opstack', opstack
- termstack = new ['ResizablePMCArray']
- .lex '@termstack', termstack
-
- term_loop:
- .local pmc termcur
- repr_bind_attr_int here, cur_class, "$!pos", pos
- termcur = here.termishrx()
- pos = repr_get_attr_int termcur, cur_class, "$!pos"
- repr_bind_attr_int here, cur_class, "$!pos", pos
- if pos < 0 goto fail
- .local pmc termish
- termish = termcur.'MATCH'()
-
- # interleave any prefix/postfix we might have found
- .local pmc termOPER, prefixish, postfixish
- termOPER = termish
- termOPER_loop:
- $I0 = exists termOPER['OPER']
- unless $I0 goto termOPER_done
- termOPER = termOPER['OPER']
- goto termOPER_loop
- termOPER_done:
- prefixish = termOPER['prefixish']
- postfixish = termOPER['postfixish']
- if null prefixish goto prefix_done
-
- prepostfix_loop:
- unless prefixish goto prepostfix_done
- unless postfixish goto prepostfix_done
- .local pmc preO, postO
- .local string preprec, postprec
- $P0 = prefixish[0]
- $P0 = $P0['OPER']
- preO = $P0['O']
- preprec = preO['prec']
- $P0 = postfixish[-1]
- $P0 = $P0['OPER']
- postO = $P0['O']
- postprec = postO['prec']
- if postprec < preprec goto post_shift
- if postprec > preprec goto pre_shift
- $S0 = postO['uassoc']
- if $S0 == 'right' goto pre_shift
- post_shift:
- $P0 = pop postfixish
- push opstack, $P0
- goto prepostfix_loop
- pre_shift:
- $P0 = shift prefixish
- push opstack, $P0
- goto prepostfix_loop
- prepostfix_done:
-
- prefix_loop:
- unless prefixish goto prefix_done
- $P0 = shift prefixish
- push opstack, $P0
- goto prefix_loop
- prefix_done:
- delete termish['prefixish']
-
- postfix_loop:
- if null postfixish goto postfix_done
- unless postfixish goto postfix_done
- $P0 = pop postfixish
- push opstack, $P0
- goto postfix_loop
- postfix_done:
- delete termish['postfixish']
-
- $P0 = termish['term']
- push termstack, $P0
-
- # Now see if we can fetch an infix operator
- .local pmc wscur, infixcur, infix
+ my $termish := $termcur.MATCH();
+ # Interleave any prefix/postfix we might have found.
+ my %termOPER := $termish;
+ %termOPER := %termOPER<OPER> while nqp::existskey(%termOPER,'OPER');
+ my @prefixish := %termOPER<prefixish>;
+ my @postfixish := %termOPER<postfixish>;
+
+ while @prefixish && @postfixish {
+ my %preO := @prefixish[0]<OPER><O>;
+ my %postO := @postfixish[+@postfixish-1]<OPER><O>;
+ my $preprec := ~%preO<prec>;
+ my $postprec := ~%postO<prec>;
+
+ if $postprec gt $preprec ||
+ $postprec eq $preprec && %postO<uassoc> eq 'right'
+ {
+ nqp::push(@opstack, nqp::shift(@prefixish));
+ }
+ else {
+ nqp::push(@opstack, nqp::pop(@postfixish));
+ }
+ }
+ nqp::push(@opstack, nqp::shift(@prefixish)) while @prefixish;
+ nqp::deletekey($termish, 'prefixish');
+ nqp::push(@opstack, nqp::pop(@postfixish)) while @postfixish;
+ nqp::deletekey($termish, 'postfixish');
+ nqp::push(@termstack, $termish<term>);
+ # Now see if we can fetch an infix operator
# First, we need ws to match.
- repr_bind_attr_int here, cur_class, "$!pos", pos
- wscur = here.'ws'()
- pos = repr_get_attr_int wscur, cur_class, '$!pos'
- if pos < 0 goto term_done
- repr_bind_attr_int here, cur_class, "$!pos", pos
+ nqp::bindattr_i($here, $cursor_class, '$!pos', $pos);
+ my $wscur := $here.ws();
+ $pos := nqp::getattr_i($wscur, $cursor_class, '$!pos');
+ last if $pos < 0;
# Next, try the infix itself.
- infixcur = here.'infixish'()
- pos = repr_get_attr_int infixcur, cur_class, '$!pos'
- if pos < 0 goto term_done
- infix = infixcur.'MATCH'()
+ nqp::bindattr_i($here, $cursor_class, '$!pos', $pos);
+ my $infixcur := $here.infixish();
+ $pos := nqp::getattr_i($infixcur, $cursor_class, '$!pos');
+ last if $pos < 0;
+ my $infix := $infixcur.MATCH();
# We got an infix.
- .local pmc inO
- $P0 = infix['OPER']
- inO = $P0['O']
- termishrx = inO['nextterm']
- if termishrx goto have_termishrx
- nonextterm:
- termishrx = 'termish'
- have_termishrx:
-
- .local string inprec, inassoc, opprec
- inprec = inO['prec']
- unless inprec goto err_inprec
- if inprec < preclim goto term_done
- inassoc = inO['assoc']
-
- $P0 = inO['sub']
- if null $P0 goto subprec_done
- inO['prec'] = $P0
- subprec_done:
-
- reduce_loop:
- unless opstack goto reduce_done
- $P0 = opstack[-1]
- $P0 = $P0['OPER']
- $P0 = $P0['O']
- opprec = $P0['prec']
- unless opprec > inprec goto reduce_gt_done
- self.'EXPR_reduce'(termstack, opstack)
- goto reduce_loop
- reduce_gt_done:
-
- unless opprec == inprec goto reduce_done
- # equal precedence, use associativity to decide
- unless inassoc == 'left' goto reduce_done
- # left associative, reduce immediately
- self.'EXPR_reduce'(termstack, opstack)
- reduce_done:
-
- push opstack, infix # The Shift
- repr_bind_attr_int here, cur_class, "$!pos", pos
- wscur = here.'ws'()
- pos = repr_get_attr_int wscur, cur_class, '$!pos'
- repr_bind_attr_int here, cur_class, "$!pos", pos
- if pos < 0 goto fail
- goto term_loop
- term_done:
-
- opstack_loop:
- unless opstack goto opstack_done
- self.'EXPR_reduce'(termstack, opstack)
- goto opstack_loop
- opstack_done:
-
- expr_done:
- .local pmc term
- term = pop termstack
- pos = here.'pos'()
- here = self.'!cursor_start'()
- here.'!cursor_pass'(pos)
- repr_bind_attr_int here, cur_class, '$!pos', pos
- setattribute here, cur_class, '$!match', term
- here.'!reduce'('EXPR')
- goto done
-
- fail:
- done:
- .return (here)
-
- err_internal:
- $I0 = termstack
- here.'panic'('Internal operator parser error, @termstack == ', $I0)
- err_inprec:
- infixcur.'panic'('Missing infixish operator precedence')
- };
+ my %inO := $infix<OPER><O>;
+ $termishrx := %inO<nextterm> // 'termish';
+ my $inprec := ~%inO<prec>;
+ $infixcur.'panic'('Missing infixish operator precedence')
+ unless $inprec;
+ last if $inprec lt $preclim;
+
+ my $inassoc := ~%inO<assoc>;
+ my $subprec := ~%inO<sub>;
+ %inO<prec> := $subprec if $subprec ne '';
+
+ while @opstack {
+ my $opprec := ~@opstack[+@opstack-1]<OPER><O><prec>;
+ if $opprec gt $inprec {
+ self.EXPR_reduce(@termstack, @opstack);
+ }
+ else {
+ self.EXPR_reduce(@termstack, @opstack)
+ if $opprec eq $inprec && $inassoc eq 'left';
+ last;
+ }
+ }
+ nqp::push(@opstack, $infix); # The Shift
+ nqp::bindattr_i($here, $cursor_class, '$!pos', $pos);
+ $wscur := $here.ws();
+ $pos := nqp::getattr_i($wscur, $cursor_class, '$!pos');
+ nqp::bindattr_i($here, $cursor_class, '$!pos', $pos);
+ return $here if $pos < 0;
+ }
+ self.EXPR_reduce(@termstack, @opstack) while @opstack;
+ my $term := nqp::pop(@termstack);
+ $pos := $here.pos();
+ $here := self.'!cursor_start'();
+ $here.'!cursor_pass'($pos);
+ nqp::bindattr_i($here, $cursor_class, '$!pos', $pos);
+ nqp::bindattr($here, $cursor_class, '$!match', $term);
+ $here.'!reduce'('EXPR');
+ return $here;
}
- method EXPR_reduce($termstack, $opstack) {
- Q:PIR {
- .local pmc self, termstack, opstack
- self = find_lex 'self'
- termstack = find_lex '$termstack'
- opstack = find_lex '$opstack'
-
- .local pmc op, opOPER, opO
- .local string opassoc
- op = pop opstack
-
- # Give it a fresh capture list, since we'll have assumed it has
- # no positional captures and not taken them.
- .local pmc cap_class
- cap_class = find_lex 'NQPCapture'
- $P0 = new ['ResizablePMCArray']
- setattribute op, cap_class, '@!array', $P0
-
- opOPER = op['OPER']
- opO = opOPER['O']
- $P0 = opO['assoc']
- opassoc = $P0
- if opassoc == 'unary' goto op_unary
- if opassoc == 'list' goto op_list
- op_infix:
- .local pmc right, left
- right = pop termstack
- left = pop termstack
- op[0] = left
- op[1] = right
- $P0 = opO['reducecheck']
- if null $P0 goto op_infix_1
- $S0 = $P0
- self.$S0(op)
- op_infix_1:
- self.'!reduce_with_match'('EXPR', 'INFIX', op)
- goto done
-
- op_unary:
- .local pmc arg, afrom, ofrom
- arg = pop termstack
- op[0] = arg
- afrom = arg.'from'()
- ofrom = op.'from'()
- if afrom < ofrom goto op_postfix
- op_prefix:
- self.'!reduce_with_match'('EXPR', 'PREFIX', op)
- goto done
- op_postfix:
- self.'!reduce_with_match'('EXPR', 'POSTFIX', op)
- goto done
-
- op_list:
- .local string sym
- sym = ''
- $P0 = opOPER['sym']
- if null $P0 goto op_list_1
- sym = $P0
- op_list_1:
- arg = pop termstack
- unshift op, arg
- op_sym_loop:
- unless opstack goto op_sym_done
- $S0 = ''
- $P0 = opstack[-1]
- $P0 = $P0['OPER']
- $P0 = $P0['sym']
- if null $P0 goto op_sym_1
- $S0 = $P0
- op_sym_1:
- if sym != $S0 goto op_sym_done
- arg = pop termstack
- unshift op, arg
- $P0 = pop opstack
- goto op_sym_loop
- op_sym_done:
- arg = pop termstack
- unshift op, arg
- self.'!reduce_with_match'('EXPR', 'LIST', op)
- goto done
-
- done:
- push termstack, op
- };
+ method EXPR_reduce(@termstack, @opstack) {
+ my $op := nqp::pop(@opstack);
+ # Give it a fresh capture list, since we'll have assumed it has
+ # no positional captures and not taken them.
+ nqp::bindattr($op, NQPCapture, '@!array', nqp::list());
+ my %opOPER := $op<OPER>;
+ my %opO := %opOPER<O>;
+ my $opassoc := ~%opO<assoc>;
+ my $key;
+
+ if $opassoc eq 'unary' {
+ my $arg := nqp::pop(@termstack);
+ $op[0] := $arg;
+ $key := $arg.from() < $op.from() ?? 'POSTFIX' !! 'PREFIX';
+ }
+ elsif $opassoc eq 'list' {
+ my $sym := ~%opOPER<sym>;
+ nqp::unshift($op, nqp::pop(@termstack));
+ while @opstack {
+ last if $sym ne @opstack[+@opstack-1]<OPER><sym>;
+ nqp::unshift($op, nqp::pop(@termstack));
+ nqp::pop(@opstack);
+ }
+ nqp::unshift($op, nqp::pop(@termstack));
+ $key := 'LIST';
+ }
+ else { # infix op assoc: left|right|ternary|...
+ $op[1] := nqp::pop(@termstack); # right
+ $op[0] := nqp::pop(@termstack); # left
+ my $reducecheck := %opO<reducecheck>;
+ self."$reducecheck"($op) if $reducecheck ne '';
+ $key := 'INFIX';
+ }
+ self.'!reduce_with_match'('EXPR', $key, $op);
+ nqp::push(@termstack, $op);
}
method ternary($match) {
@@ -805,26 +576,22 @@ An operator precedence parser.
}
method MARKER($markname) {
- my %markhash := Q:PIR {
- %r = get_global '%!MARKHASH'
- unless null %r goto have_markhash
- %r = new ['Hash']
- set_global '%!MARKHASH', %r
- have_markhash:
- };
+ my %markhash := pir::get_global__Ps('%!MARKHASH');
+ unless %markhash {
+ %markhash := nqp::hash();
+ pir::set_global__vsP('%!MARKHASH', %markhash);
+ }
my $cur := self."!cursor_start"();
$cur."!cursor_pass"(self.pos());
%markhash{$markname} := $cur;
}
method MARKED($markname) {
- my %markhash := Q:PIR {
- %r = get_global '%!MARKHASH'
- unless null %r goto have_markhash
- %r = new ['Hash']
- set_global '%!MARKHASH', %r
- have_markhash:
- };
+ my %markhash := pir::get_global__Ps('%!MARKHASH');
+ unless %markhash {
+ %markhash := nqp::hash();
+ pir::set_global__vsP('%!MARKHASH', %markhash);
+ }
my $cur := %markhash{$markname};
unless nqp::istype($cur, NQPCursor) && $cur.pos() == self.pos() {
$cur := self."!cursor_start"();
Something went wrong with that request. Please try again.