Permalink
Browse files

[STD,Cursor] Push error reporting functions down into the new Perl6 C…

…ursor. You can now define non-STD grammars with viv.

git-svn-id: http://svn.pugscode.org/pugs@31100 c213334d-75ef-0310-aa23-eaa082d1ae64
  • Loading branch information...
1 parent 27777d6 commit 920c0b2d9d0fc72e9c8be351e2276eafda9f0f7b sorear committed Jun 4, 2010
Showing with 95 additions and 49 deletions.
  1. +94 −0 Cursor.pm6
  2. +0 −48 STD.pm6
  3. +1 −1 viv
View
@@ -1,3 +1,10 @@
+# Cursor.pm
+#
+# Copyright 2007-2010, Larry Wall
+#
+# You may copy this software under the terms of the Artistic License,
+# version 2.0 or later.
+
use CursorBase;
class Cursor is CursorBase;
our $BLUE = $CursorBase::BLUE;
@@ -7,3 +14,90 @@ our $MAGENTA = $CursorBase::MAGENTA;
our $YELLOW = $CursorBase::YELLOW;
our $RED = $CursorBase::RED;
our $CLEAR = $CursorBase::CLEAR;
+
+method panic (Str $s) {
+ self.deb("panic $s") if $*DEBUG;
+ my $m;
+ my $here = self;
+
+ $m ~= $s;
+ $m ~= $here.locmess;
+ $m ~= "\n" unless $m ~~ /\n$/;
+
+ note $Cursor::RED, '===', $Cursor::CLEAR, 'SORRY!', $Cursor::RED, '===', $Cursor::CLEAR, "\n";
+ note $m;
+
+ die "Parse failed\n";
+}
+
+method worry (Str $s) {
+ my $m = $s ~ self.locmess;
+ push @*WORRIES, $m unless %*WORRIES{$s}++;
+ self;
+}
+
+method sorry (Str $s) {
+ self.deb("sorry $s") if $*DEBUG;
+ note $Cursor::RED, '===', $Cursor::CLEAR, 'SORRY!', $Cursor::RED, '===', $Cursor::CLEAR, "\n"
+ unless $*IN_SUPPOSE or $*FATALS++;
+ if $s {
+ my $m = $s;
+ $m ~= self.locmess ~ "\n" unless $m ~~ /\n$/;
+ if $*FATALS > 10 or $*IN_SUPPOSE {
+ die $m;
+ }
+ else {
+ note $m unless %*WORRIES{$m}++;
+ }
+ }
+ self;
+}
+
+method locmess () {
+ my $pos = self.pos;
+ my $line = self.lineof($pos);
+
+ # past final newline?
+ if $pos >= @*MEMOS - 1 {
+ $pos = $pos - 1;
+ $line = $line ~ " (EOF)";
+ }
+
+ my $pre = substr($*ORIG, 0, $pos);
+ $pre = substr($pre, -40, 40);
+ 1 while $pre ~~ s!.*\n!!;
+ $pre = '<BOL>' if $pre eq '';
+ my $post = substr($*ORIG, $pos, 40);
+ 1 while $post ~~ s!(\n.*)!!;
+ $post = '<EOL>' if $post eq '';
+ " at " ~ $*FILE<name> ~ " line $line:\n------> " ~ $Cursor::GREEN ~ $pre ~ $Cursor::YELLOW ~ $*PERL6HERE ~ $Cursor::RED ~
+ "$post$Cursor::CLEAR";
+}
+
+method line {
+ self.lineof(self.pos);
+}
+
+method lineof ($p) {
+ return 1 unless defined $p;
+ my $line = @*MEMOS[$p]<L>;
+ return $line if $line;
+ $line = 0;
+ my $pos = 0;
+ my @text = split(/^/,$*ORIG); # XXX p5ism, should be ^^
+ for @text {
+ $line++;
+ @*MEMOS[$pos++]<L> = $line
+ for 1 .. chars($_);
+ }
+ @*MEMOS[$pos++]<L> = $line;
+ return @*MEMOS[$p]<L> // 0;
+}
+
+method SETGOAL { }
+method FAILGOAL (Str $stop, Str $name, $startpos) {
+ my $s = "'$stop'";
+ $s = '"\'"' if $s eq "'''";
+ self.panic("Unable to parse $name" ~ $startpos.locmess ~ "\nCouldn't find final $s; gave up");
+}
+## vim: expandtab sw=4 ft=perl6
View
48 STD.pm6
@@ -6063,54 +6063,6 @@ method sorry (Str $s) {
self;
}
-method locmess () {
- my $pos = self.pos;
- my $line = self.lineof($pos);
-
- # past final newline?
- if $pos >= @*MEMOS - 1 {
- $pos = $pos - 1;
- $line = $line ~ " (EOF)";
- }
-
- my $pre = substr($*ORIG, 0, $pos);
- $pre = substr($pre, -40, 40);
- 1 while $pre ~~ s!.*\n!!;
- $pre = '<BOL>' if $pre eq '';
- my $post = substr($*ORIG, $pos, 40);
- 1 while $post ~~ s!(\n.*)!!;
- $post = '<EOL>' if $post eq '';
- " at " ~ $*FILE<name> ~ " line $line:\n------> " ~ $Cursor::GREEN ~ $pre ~ $Cursor::YELLOW ~ $*PERL6HERE ~ $Cursor::RED ~
- "$post$Cursor::CLEAR";
-}
-
-method line {
- self.lineof(self.pos);
-}
-
-method lineof ($p) {
- return 1 unless defined $p;
- my $line = @*MEMOS[$p]<L>;
- return $line if $line;
- $line = 0;
- my $pos = 0;
- my @text = split(/^/,$*ORIG); # XXX p5ism, should be ^^
- for @text {
- $line++;
- @*MEMOS[$pos++]<L> = $line
- for 1 .. chars($_);
- }
- @*MEMOS[$pos++]<L> = $line;
- return @*MEMOS[$p]<L> // 0;
-}
-
-method SETGOAL { }
-method FAILGOAL (Str $stop, Str $name, $startpos) {
- my $s = "'$stop'";
- $s = '"\'"' if $s eq "'''";
- self.panic("Unable to parse $name" ~ $startpos.locmess ~ "\nCouldn't find final $s; gave up");
-}
-
# "when" arg assumes more things will become obsolete after Perl 6 comes out...
method obs (Str $old, Str $new, Str $when = ' in Perl 6') {
View
2 viv
@@ -1582,7 +1582,7 @@ my \$retree;
use YAML::XS;
-\$SIG{__WARN__} = sub { die \@_," statement started at line ", 'STD'->lineof(\$::LASTSTATE), "\n" } if \$::DEBUG;
+\$SIG{__WARN__} = sub { die \@_," statement started at line ", 'Cursor'->lineof(\$::LASTSTATE), "\n" } if \$::DEBUG;
END
$header;

0 comments on commit 920c0b2

Please sign in to comment.