Legend:
- Unmodified
- Added
- Removed
-
src/perl6/Cursor.pmc
r22848 r22853 19 19 $::DEPTH = 0; 20 20 $::ORIG = ''; 21 @::ORIG = (); 21 22 @::MEMOS = (); 22 23 %::LEXERS = (); … … 103 104 my $class = shift; 104 105 $::ORIG = shift() . "\n"; # original string 105 $::MEMOS[length $::ORIG] = undef; # memos kept by position 106 @::ORIG = unpack("U*", $::ORIG); 107 $::MEMOS[@::ORIG] = undef; # memos kept by position 106 108 my %args = ('_pos' => 0, '_from' => 0); 107 109 while (@_) { … … 242 244 $file =~ s/:\*$//; 243 245 my $name = $key; 244 $name =~ s/_01//; 246 my $dba = $retree->{$key}{dba}; 247 if (not $dba) { 248 $dba = $name; 249 $dba =~ s/_0[01]$//; 250 $dba =~ s/_(\d\d)$/ (alt $1)/; 251 $dba =~ s/:\*$//; 252 } 245 253 246 254 if (open(LEX, "$dir/$file")) { … … 254 262 my %lexer; 255 263 $lexer{NAME} = $name; 256 $lexer{DBA} = $ retree->{$key}{dba} // $name;264 $lexer{DBA} = $dba; 257 265 $lexer{FILE} = "$dir/$file"; 258 266 $lexer{PATS} = \@pat; … … 307 315 $AUTOLEXED{$key} = $oldfakepos; 308 316 309 $lexer = { "NAME" => $name, "FILE" => "$dir/$file", "PATS" => [@pat], "DBA" => $ retree->{$key}{dba} // $name};317 $lexer = { "NAME" => $name, "FILE" => "$dir/$file", "PATS" => [@pat], "DBA" => $dba}; 310 318 311 319 return $lexer if $lang =~ /ANON/; … … 431 439 $self->_AUTOLEXpeek($key,$retree); 432 440 }; 433 $self->highwater($lexer->{DBA}) if $self->{_pos} >= $::HIGHWATER; 441 if ($self->{_pos} >= $::HIGHWATER) { 442 if ($self->{_pos} > $::HIGHWATER) { 443 %$::HIGHEXPECT = (); 444 $::HIGHMESS = ''; 445 } 446 $::HIGHEXPECT->{$lexer->{DBA}}++; 447 $::HIGHWATER = $self->{_pos}; 448 } 449 434 450 my $P = $self->{_pos}; 435 if ($P == length($::ORIG)) {451 if ($P >= @::ORIG) { 436 452 return sub { return }; 437 453 } … … 530 546 sub { 531 547 my $C = shift; 532 533 # die "orig disappeared!!!" unless length($::ORIG);534 548 535 549 return unless $lexer; … … 674 688 } 675 689 676 sub highwater {677 my $self = shift;678 if ($self->{_pos} > $::HIGHWATER) {679 %$::HIGHEXPECT = ();680 $::HIGHMESS = '';681 }682 for (@_) {683 my $name = $_;684 $name =~ s/_0[01]$//;685 $name =~ s/_(\d\d)$/ (alt $1)/;686 $name =~ s/:\*$//;687 $::HIGHEXPECT->{$name}++;688 }689 $::HIGHWATER = $self->{_pos};690 }691 692 690 sub delete { 693 691 my $self = shift; … … 1113 1111 local $CTX = $self->callm if $DEBUG & DEBUG::trace_call; 1114 1112 my $pos = $self->{_pos}; 1115 my $eos = length(${\$::ORIG});1113 my $eos = @::ORIG; 1116 1114 1117 1115 lazymap( sub { $self->cursor($_[0])->retm() }, LazyRange->new($pos,$eos) ); … … 1122 1120 local $CTX = $self->callm if $DEBUG & DEBUG::trace_call; 1123 1121 my $pos = $self->{_pos}; 1124 my $eos = length(${\$::ORIG});1122 my $eos = @::ORIG; 1125 1123 1126 1124 lazymap( sub { $self->cursor($_[0])->retm() }, LazyRangeRev->new($eos,$pos) ); … … 1156 1154 my $prev_pos = $pos->{_pos} // 0; 1157 1155 my @all; 1158 my $eos = length(${\$::ORIG});1156 my $eos = @::ORIG; 1159 1157 for (;;) { 1160 1158 last if $pos->{_pos} == $eos; … … 1178 1176 1179 1177 # don't go beyond end of string 1180 return () if $self->{_pos} == length(${\$::ORIG});1178 return () if $self->{_pos} == @::ORIG; 1181 1179 lazymap( 1182 1180 sub { … … 1205 1203 my $to = $self; 1206 1204 my @all; 1207 my $eos = length(${\$::ORIG});1205 my $eos = @::ORIG; 1208 1206 for (;;) { 1209 1207 last if $to->{_pos} == $eos; … … 1229 1227 my @result; 1230 1228 # don't go beyond end of string 1231 return () if $self->{_pos} == length(${\$::ORIG});1229 return () if $self->{_pos} == @::ORIG; 1232 1230 do { 1233 1231 for my $x ($block->($self)) { … … 1256 1254 my $to = $self; 1257 1255 my @all; 1258 my $eos = length(${\$::ORIG});1256 my $eos = @::ORIG; 1259 1257 for (;;) { 1260 1258 last if $to->{_pos} == $eos; … … 1456 1454 } 1457 1455 1456 sub _EXACT_rev { my $self = shift; 1457 my $s = shift() // ''; 1458 my @ints = unpack("U*", $s); 1459 1460 local $CTX = $self->callm($s) if $DEBUG & DEBUG::trace_call; 1461 my $P = $self->{_pos} // 0; 1462 while (@ints) { 1463 return () unless ($::ORIG[--$P]//-1) == pop @ints; 1464 } 1465 return $self->cursor($P)->retm(); 1466 } 1467 1458 1468 sub _EXACT { my $self = shift; 1459 1469 my $s = shift() // ''; 1470 my @ints = unpack("U*", $s); 1460 1471 1461 1472 local $CTX = $self->callm($s) if $DEBUG & DEBUG::trace_call; 1462 1473 my $P = $self->{_pos} // 0; 1463 my $len = length($s); 1464 if (substr($::ORIG, $P, $len) eq $s) { 1465 $self->deb("EXACT $s matched @{[substr($::ORIG,$P,$len)]} at $P $len") if $DEBUG & DEBUG::matchers; 1466 my $r = $self->cursor($P+$len); 1467 $r->retm(); 1468 } 1469 else { 1470 $self->deb("EXACT $s didn't match @{[substr($::ORIG,$P,$len)]} at $P $len") if $DEBUG & DEBUG::matchers; 1471 return (); 1472 } 1474 while (@ints) { 1475 return () unless ($::ORIG[$P++]//-1) == shift @ints; 1476 } 1477 return $self->cursor($P)->retm(); 1478 # if (substr($::ORIG, $P, $len) eq $s) { 1479 # $self->deb("EXACT $s matched @{[substr($::ORIG,$P,$len)]} at $P $len") if $DEBUG & DEBUG::matchers; 1480 # my $r = $self->cursor($P+$len); 1481 # $r->retm(); 1482 # } 1483 # else { 1484 # $self->deb("EXACT $s didn't match @{[substr($::ORIG,$P,$len)]} at $P $len") if $DEBUG & DEBUG::matchers; 1485 # return (); 1486 # } 1473 1487 } 1474 1488 … … 1533 1547 } 1534 1548 1535 sub _EXACT_rev { my $self = shift;1536 my $s = shift;1537 1538 local $CTX = $self->callm if $DEBUG & DEBUG::trace_call;1539 my $len = length($s);1540 my $from = $self->{_pos} - $len;1541 if ($from >= 0 and substr($::ORIG, $from, $len) eq $s) {1542 my $r = $self->cursor_rev($from);1543 $r->retm();1544 }1545 else {1546 # say "EXACT_rev $s didn't match @{[substr($!orig,$from,$len)]} at $from $len";1547 return ();1548 }1549 }1549 #sub _EXACT_rev { my $self = shift; 1550 # my $s = shift; 1551 # 1552 # local $CTX = $self->callm if $DEBUG & DEBUG::trace_call; 1553 # my $len = length($s); 1554 # my $from = $self->{_pos} - $len; 1555 # if ($from >= 0 and substr($::ORIG, $from, $len) eq $s) { 1556 # my $r = $self->cursor_rev($from); 1557 # $r->retm(); 1558 # } 1559 # else { 1560 ## say "EXACT_rev $s didn't match @{[substr($!orig,$from,$len)]} at $from $len"; 1561 # return (); 1562 # } 1563 #} 1550 1564 1551 1565 sub _ARRAY { my $self = shift; … … 1810 1824 local $CTX = $self->callm if $DEBUG & DEBUG::trace_call; 1811 1825 my $P = $self->{_pos}; 1812 if ($P < length($::ORIG)) {1826 if ($P < @::ORIG) { 1813 1827 $self->cursor($P+1)->retm(); 1814 1828 } … … 1855 1869 local $CTX = $self->callm if $DEBUG & DEBUG::trace_call; 1856 1870 my $P = $self->{_pos}; 1857 if ($P == length($::ORIG)) {1871 if ($P == @::ORIG) { 1858 1872 $self->cursor($P)->retm(); 1859 1873 } … … 1867 1881 local $CTX = $self->callm if $DEBUG & DEBUG::trace_call; 1868 1882 my $P = $self->{_pos}; 1869 if ($P == length($::ORIG)or substr($::ORIG, $P, 1) =~ /^(?:\r\n|[\n\f\x0b\x{2028}\x{2029}])$/) {1883 if ($P == @::ORIG or substr($::ORIG, $P, 1) =~ /^(?:\r\n|[\n\f\x0b\x{2028}\x{2029}])$/) { 1870 1884 $self->cursor($P)->retm(); 1871 1885 } -
src/perl6/gimme5
r22836 r22853 1760 1760 sub walk { 1761 1761 my $self = shift; 1762 my $text = quotemeta($$self{text});1763 $text = "(?<=$text)" if $REV;1764 1762 if ($$self{i}) { 1763 my $text = quotemeta($$self{text}); 1764 $text = "(?<=$text)" if $REV; 1765 1765 '$C->_PATTERN(qr/\\G(?i:' . $text . ')/)'; 1766 1766 } 1767 1767 else { 1768 "\$C->_PATTERN(qr/\\G$text/)"; 1768 my $text = $$self{text}; 1769 $text =~ s/([\\'])/\\$1/g; 1770 "\$C->_EXACT$REV('$text')"; 1771 # "\$C->_PATTERN(qr/\\G$text/)"; 1769 1772 # my $l = length($text); 1770 1773 # "(substr(\$\$buf, \$C->{_pos}, $l) eq '" . $text . "' ? \$C->cursor(\$C->{_pos} + $l) : ())" -
src/perl6/tryfile
r22848 r22853 7 7 8 8 for my $file (@ARGV) { 9 warn $file,"\n" ;9 warn $file,"\n" if @ARGV > 1; 10 10 eval { 11 11 STD->parsefile($file);
