Changeset 22836 for src

Timestamp:

10/31/08 07:55:25 (2 months ago)

Author:

lwall

Message:

[Cursor] {_to} is gone, {_from} now set only on bound cursors, unbound cursors

now only propagate {_pos} (will help optimization of simple traversals)

Location:

src/perl6

Files:

• Cursor.pmc (modified) (29 diffs)
• Makefile (modified) (1 diff)
• STD.pm (modified) (7 diffs)
• gimme5 (modified) (5 diffs)

src/perl6/Cursor.pmc

@@ -169 +169 @@
 our %lexers;       # per language, the cache of lexers, keyed by rule name
 
-sub from { $_[0]->{_from} }
-sub to { $_[0]->{_to} }
-sub chars { $_[0]->{_to} - $_[0]->{_from} }
-sub text { substr($::ORIG, $_[0]->{_from}, $_[0]->{_to} - $_[0]->{_from}) }
+sub from { $_[0]->{_from} // $_[0]->{_pos} }
+sub to { $_[0]->{_pos} }
 sub pos { $_[0]->{_pos} }
+sub chars { $_[0]->{_pos} - ($_[0]->{_from} // $_[0]->{_pos}) }
+sub text { exists $_[0]->{_from} ? substr($::ORIG, $_[0]->{_from}, $_[0]->{_pos} - $_[0]->{_from}) : '' }
 sub peek { $_[0]->{_peek} }
 sub orig { \$::ORIG }
@@ -711 +711 @@
     my $lang = @_ && $_[0] ? shift() : ref $self;
     $self->deb("cursor_fresh lang $lang") if $DEBUG & DEBUG::cursors;
-    $r{_to} = $r{_from} = $r{_pos} = $self->{_pos};
+   # $r{_from} =
+    $r{_pos} = $self->{_pos};
     $r{_fate} = $self->{_fate};
     $r{_herelang} = $self->{_herelang} if $self->{_herelang};
@@ -798 +799 @@
     delete $copy{_fate};
     my $text = STD::Dump(\%copy);
-    $text =~ s/^\s*_(?:pos|orig):.*\n//mg;
     $text;
 }
@@ -819 +819 @@
         }
     }
-    $r{_pos} = $r{_to} = $submatch->{_to};
+    $submatch->{_from} = $r{_from} = $r{_pos};
+    $r{_pos} = $submatch->{_pos};
     delete $r{_fate};
     CORE::bless \%r, ref $self;         # return new match cursor for parent
@@ -871 +872 @@
     $self->deb("cursor_all from $fpos to $tpos") if $DEBUG & DEBUG::cursors;
     my %r = %$self;
-    $r{_from} = $fpos;
-    $r{_to} = $tpos;
+#    $r{_from} = $fpos;
     $r{_pos} = $tpos;
 
@@ -887 +887 @@
         $self->deb("cursor to $tpos --------->$GREEN$peek$CLEAR");
     }
-    $self->{_to} = $tpos;
     $self->{_pos} = $tpos;
 
@@ -903 +902 @@
     }
     my %r = %$self;
-    $r{_from} = $self->{_pos} // 0;
-    $r{_to} = $tpos;
+#    $r{_from} = $self->{_pos} // 0;
     $r{_pos} = $tpos;
 
@@ -921 +919 @@
     my %r = %$self;
     $r{_pos} = $fpos;
-    $r{_from} = $fpos;
-    $r{_to} = $self->{_from};
+#    $r{_from} = $self->{_from};
 
     CORE::bless \%r, ref $self;
@@ -1012 +1009 @@
 
     my \$C = \$self;
+    my \$S = \$self->{_pos};
     \$C->{'sym'} = \$sym;
 
-    \$self->_MATCHIFY( '$mangle', Cursor::lazymap sub { STD::$coercion->coerce(\$_[0]) },
+    \$self->_MATCHIFY(\$S, '$mangle', Cursor::lazymap sub { STD::$coercion->coerce(\$_[0]) },
         \$C->_SYM(\$sym, 0)
     );
@@ -1078 +1076 @@
     warn "Returning non-Cursor: $self\n" unless exists $self->{_pos};
     my ($package, $file, $line, $subname, $hasargs) = caller(1);
-    $self->deb($subname, " returning @{[$self->{_from}]}..@{[$self->{_to}]}");
+    $self->deb($subname, " returning @{[$self->{_pos}]}");
     $self;
 }
 
 sub _MATCHIFY { my $self = shift;
+    my $S = shift;
     my $name = shift;
     return () unless @_;
-    my @result = lazymap( sub { my $x = shift; $x->{_from} = $self->{_from}; $x->_REDUCE($name)->retm() }, @_);
+    my @result = lazymap( sub { my $x = shift; $x->_REDUCE($S, $name)->retm() }, @_);
     if (wantarray) {
         @result;
@@ -1095 +1094 @@
 
 sub _MATCHIFYr { my $self = shift;
+    my $S = shift;
     my $name = shift;
     return () unless @_;
     my $var = shift;
-    $var->{_from} = $self->{_from};
-    $var->_REDUCE($name)->retm();
+#    $var->{_from} = $self->{_from};
+    $var->_REDUCE($S, $name)->retm();
 }
 
@@ -1146 +1146 @@
 
     local $CTX = $self->callm if $DEBUG & DEBUG::trace_call;
-    my $to = $self;
-    my $prev_to = $to->{_to} // 0;
+    my $pos = $self;
+    my $prev_pos = $pos->{_pos} // 0;
     my @all;
     my $eos = length(${\$::ORIG});
     for (;;) {
-      last if $to->{_pos} == $eos;
-        my @matches = $block->($to);  # XXX shouldn't read whole list
+      last if $pos->{_pos} == $eos;
+        my @matches = $block->($pos);  # XXX shouldn't read whole list
 #            say @matches.perl;
       last unless @matches;
         my $first = $matches[0];  # no backtracking into block on ratchet
-        last if $first->{_to} == $prev_to;
-        $prev_to = $first->{_to};
+        last if $first->{_pos} == $prev_pos;
+        $prev_pos = $first->{_pos};
         push @all, $first;
-        $to = $first;
-    }
-    $self->cursor_tweak($to->{_pos})->retm();
+        $pos = $first;
+    }
+    $self->cursor_tweak($pos->{_pos})->retm();
 }
 
@@ -1177 +1177 @@
             lazymap(
                 sub {
-                    $self->cursor($_[0]->{_to})->retm()
+                    $self->cursor($_[0]->{_pos})->retm()
                 }, $x, LazyMap->new(sub { $x->_PLUSf($_[0]) }, $block)
             );
@@ -1226 +1226 @@
         for my $x ($block->($self)) {
             for my $s ($sep->($x)) {
-                push @result, lazymap(sub { $self->cursor($_[0]->{_to}) }, $x, $s->_REPSEPf($sep,$block));
+                push @result, lazymap(sub { $self->cursor($_[0]->{_pos}) }, $x, $s->_REPSEPf($sep,$block));
             }
         }
@@ -1354 +1354 @@
     local $CTX = $self->callm if $DEBUG & DEBUG::trace_call;
     my $end = $self->cursor($self->{_pos});
-    my @all = $block->($end);          # Make sure $_->{_from} == $_->{_to}
+    my @all = $block->($end);          # Make sure $_->{_from} == $_->{_pos}
     if (@all and $all[0]) {
         return $all[0]->cursor_all(($self->{_pos}) x 2)->retm();
@@ -1376 +1376 @@
 
     my $C = $self;
-    my $startpos = $C->pos;
-    $::MEMOS[$startpos]{ws} = undef;    # exists means we know, undef means no ws  before here
-
-    $self->_MATCHIFY( 'ws',
+    my $S = $C->pos;
+    $::MEMOS[$S]{ws} = undef;   # exists means we know, undef means no ws  before here
+
+    $self->_MATCHIFY($S, 'ws',
         $C->_BRACKET( sub { my $C=shift;
             do { my @gather;
@@ -1400 +1400 @@
                     push @gather, (map { my $C=$_;
                         (map { my $C=$_;
-                            scalar(do { $::MEMOS[$C->{_pos}]{ws} = $startpos unless $C->{_pos} == $startpos }, $C)
+                            scalar(do { $::MEMOS[$C->{_pos}]{ws} = $S unless $C->{_pos} == $S }, $C)
                         } $C->_STARr(sub { my $C=shift;
                             $C->_SPACE()
@@ -1531 +1531 @@
     local $CTX = $self->callm if $DEBUG & DEBUG::trace_call;
     my $len = length($s);
-    my $from = $self->{_from} - $len;
+    my $from = $self->{_pos} - $len;
     if ($from >= 0 and substr($::ORIG, $from, $len) eq $s) {
         my $r = $self->cursor_rev($from);
@@ -1564 +1564 @@
     for my $s (@array) {
         my $len = length($s);
-        my $from = $self->{_from} = $len;
+        my $from = $self->{_pos} = $len;
         if (substr($::ORIG, $from, $len) eq $s) {
             $self->deb("ARRAY_rev elem $s matched @{[substr($::ORIG,$from,$len)]} at $from $len") if $DEBUG & DEBUG::matchers;
@@ -1590 +1590 @@
 sub _DIGIT_rev { my $self = shift;
     local $CTX = $self->callm if $DEBUG & DEBUG::trace_call;
-    my $from = $self->{_from} - 1;
+    my $from = $self->{_pos} - 1;
     if ($from < 0) {
 #        say "DIGIT_rev didn't match $char at $from";
@@ -1622 +1622 @@
 sub _ALNUM_rev { my $self = shift;
     local $CTX = $self->callm if $DEBUG & DEBUG::trace_call;
-    my $from = $self->{_from} - 1;
+    my $from = $self->{_pos} - 1;
     if ($from < 0) {
 #        say "ALNUM_rev didn't match $char at $from";
@@ -1654 +1654 @@
 sub alpha_rev { my $self = shift;
     local $CTX = $self->callm if $DEBUG & DEBUG::trace_call;
-    my $from = $self->{_from} - 1;
+    my $from = $self->{_pos} - 1;
     if ($from < 0) {
         return ();
@@ -1684 +1684 @@
 sub _SPACE_rev { my $self = shift;
     local $CTX = $self->callm if $DEBUG & DEBUG::trace_call;
-    my $from = $self->{_from} - 1;
+    my $from = $self->{_pos} - 1;
     if ($from < 0) {
 #        say "SPACE_rev didn't match $char at $from";
@@ -1716 +1716 @@
 sub _HSPACE_rev { my $self = shift;
     local $CTX = $self->callm if $DEBUG & DEBUG::trace_call;
-    my $from = $self->{_from} - 1;
+    my $from = $self->{_pos} - 1;
     if ($from < 0) {
 #        say "HSPACE_rev didn't match $char at $from";
@@ -1748 +1748 @@
 sub _VSPACE_rev { my $self = shift;
     local $CTX = $self->callm if $DEBUG & DEBUG::trace_call;
-    my $from = $self->{_from} - 1;
+    my $from = $self->{_pos} - 1;
     if ($from < 0) {
 #        say "VSPACE_rev didn't match $char at $from";
@@ -1784 +1784 @@
 
     local $CTX = $self->callm if $DEBUG & DEBUG::trace_call;
-    my $from = $self->{_from} - 1;
+    my $from = $self->{_pos} - 1;
     if ($from < 0) {
 #        say "CCLASS didn't match $char at $from";
@@ -1814 +1814 @@
 sub _ANY_rev { my $self = shift;
     local $CTX = $self->callm if $DEBUG & DEBUG::trace_call;
-    my $from = $self->{_from} - 1;
+    my $from = $self->{_pos} - 1;
     if ($from < 0) {
         return ();
@@ -1909 +1909 @@
 
 sub _REDUCE { my $self = shift;
+    my $S = shift;
     my $tag = shift;
 
     $self->{_reduced} = $tag;
+    $self->{_from} = $S;
     if ($::ACTIONS) {
         eval { $::ACTIONS->$tag($self) };
         warn $@ if $@ and not $@ =~ /locate/;
     }
-    $self->deb("REDUCE $tag from " . $self->{_from} . " to " . $self->{_pos}) if $DEBUG & DEBUG::matchers;
+    $self->deb("REDUCE $tag from " . $S . " to " . $self->{_pos}) if $DEBUG & DEBUG::matchers;
     $self;
 }
@@ -1924 +1926 @@
     local $CTX = $self->callm if $DEBUG & DEBUG::trace_call;
     my $P = $self->{_pos};
-    my $F = $self->{_from};
-    $self->{FIRST} = substr($::ORIG, $F, $P - $F);
     $self->deb("Commit branch to $P") if $DEBUG & DEBUG::matchers;
     $self, LazyMap->new(sub { $self->deb("ABORTBRANCH") if $DEBUG & DEBUG::trace_call; die "ABORTBRANCH" }, $self);

src/perl6/Makefile

@@ -7 +7 @@
 STD.pmc: STD.pm gimme5
         ./gimme5 $< >STD.pm5
-        perl -p -e 'next if /^---/../\A\w+\Z/;' -e 's/\A\s+//;' STD.pm5 >$@
+        perl -p -e 'next if /^---/../\A\w+\Z/;' -e 's/\A[ \t]+//;' STD.pm5 >$@
         rm -rf lex
 

src/perl6/STD.pm

@@ -3406 +3406 @@
 
     my $here = self;
-    self.deb("In EXPR, at ", $here.pos) if $*DEBUG +& DEBUG::EXPR;
+    my $S = $here.pos;
+    self.deb("In EXPR, at $S") if $*DEBUG +& DEBUG::EXPR;
 
     my &reduce := -> {
@@ -3425 +3426 @@
                 push @chain, pop(@termstack).cleanup;
                 @chain = reverse @chain if @chain > 1;
+                my $startpos = @chain[0].pos;
                 my $nop = $op.cursor_fresh();
                 $nop<chain> = [@chain];
                 $nop<_arity> = 'CHAIN';
-                push @termstack, $nop._REDUCE('EXPR');
+                push @termstack, $nop._REDUCE($startpos, 'EXPR');
             }
             when 'list' {
@@ -3453 +3455 @@
                 }
                 @list = reverse @list if @list > 1;
+                my $startpos = @list[0].pos;
                 @delims = reverse @delims if @delims > 1;
                 my $nop = $op.cursor_fresh();
@@ -3460 +3463 @@
                 $nop<delims> = [@delims];
                 $nop<_arity> = 'LIST';
-                push @termstack, $nop._REDUCE('EXPR');
+                push @termstack, $nop._REDUCE($startpos, 'EXPR');
             }
             when 'unary' {
@@ -3472 +3475 @@
                     $op<_from> = $op<arg><_from>;
                 }
-                if ($op<arg><_to> > $op<_to>) {
-                    $op<_to> = $op<arg><_to>;
+                if ($op<arg><_pos> > $op<_pos>) {
+                    $op<_pos> = $op<arg><_pos>;
                 }
                 $op<_arity> = 'UNARY';
-                push @termstack, $op._REDUCE('EXPR');
+                push @termstack, $op._REDUCE($op<_from>, 'EXPR');
             }
             default {
@@ -3483 +3486 @@
                 self.deb("Termstack size: ", +@termstack) if $*DEBUG +& DEBUG::EXPR;
 
-                self.deb($op.dump) if $*DEBUG +& DEBUG::EXPR;
                 $op<right> = (pop @termstack).cleanup;
                 $op<left> = (pop @termstack).cleanup;
                 $op<_from> = $op<left><_from>;
-                $op<_to> = $op<right><_to>;
+                $op<_pos> = $op<right><_pos>;
                 $op<_arity> = 'BINARY';
-                push @termstack, $op._REDUCE('EXPR');
+                self.deb($op.dump) if $*DEBUG +& DEBUG::EXPR;
+                push @termstack, $op._REDUCE($op<_from>, 'EXPR');
             }
         }
@@ -3599 +3602 @@
         +@termstack == 1 or $here.panic("Internal operator parser error, termstack == " ~ (+@termstack));
         @termstack[0]<_from> = self.pos;
-        @termstack[0]<_to> = $here.pos;
-    }
-    self._MATCHIFYr("EXPR", @termstack);
+        @termstack[0]<_pos> = $here.pos;
+    }
+    self._MATCHIFYr($S, "EXPR", @termstack);
 }
 

src/perl6/gimme5

@@ -327 +327 @@
 
     my \$C = \$self;
-    \$C->{_to} = \$C->{_from} = \$C->{_pos};
+    my \$S = \$C->{_pos};
 
     my \@result = eval {
@@ -356 +356 @@
             push \@gather, \$C->\$try(\@_);
         }
-        \$self->_MATCHIFY("$name", \@gather);
+        \$self->_MATCHIFY(\$S, "$name", \@gather);
     };
     if (\$@) {
@@ -597 +597 @@
 
     my $C = $self;
-    $C->{_to} = $C->{_from} = $C->{_pos};
+    my $S = $C->{_pos};
 END
 
@@ -630 +630 @@
                 $body .= <<"END";
 
-    \$self->_MATCHIFY$ratchet("$NAME", $coercion
+    \$self->_MATCHIFY$ratchet(\$S, "$NAME", $coercion
 <<MEAT>>
     );
@@ -1218 +1218 @@
         ws();
         $key =~ s/(['\\])/\\$1/g;
-        return bless { name => '_REDUCE', args => "'$key'", min => 0, max => 0},
+        return bless { name => '_REDUCE', args => "\$S, '$key'", min => 0, max => 0},
                      "RE_method_internal";
     }