Changeset 21975 for src/perl6

Timestamp:

08/21/08 03:30:51 (3 months ago)

Author:

lwall

Message:

[STD] rudimentary global symbol table to detect routine definitions

Location:

src/perl6

Files:

• Cursor.pmc (modified) (13 diffs)
• STD.pm (modified) (12 diffs)
• gimme5 (modified) (3 diffs)

src/perl6/Cursor.pmc

@@ -102 +102 @@
         $args{'_' . $name} = shift;
     }
-    my $self = bless \%args, ref $class || $class;
+    my $self = CORE::bless \%args, ref $class || $class;
     my $buf = $self->{_orig};
 #    $self->deb(" orig ", $$buf) if $DEBUG & DEBUG::cursors;
@@ -186 +186 @@
 sub peek { $_[0]->{_peek} }
 sub orig { $_[0]->{_orig} }
-sub WHAT { ref $_[0] }
+sub WHAT { ref $_[0] || $_[0] }
+sub bless { CORE::bless $_[1], $_[0]->WHAT }
 
 sub item { exists $_[0]->{''} ? $_[0]->{''} : $_[0]->text }
@@ -692 +693 @@
     sub new { my $self = shift;
         my %args = @_;
-        bless \%args, $self;
+        CORE::bless \%args, $self;
     }
 
@@ -708 +709 @@
     my %r = %$self;
     $r{_peek} = 1;
-    bless \%r, ref $self;
+    CORE::bless \%r, ref $self;
 }
 
@@ -720 +721 @@
     $r{_fate} = $self->{_fate};
     $r{_herelang} = $self->{_herelang} if $self->{_herelang};
-    bless \%r, ref $lang || $lang;
+    CORE::bless \%r, ref $lang || $lang;
 }
 
@@ -727 +728 @@
     my %r = %$self;
     $r{_herelang} = $self;
-    bless \%r, 'STD::Q';
+    CORE::bless \%r, 'STD::Q';
 }
 
@@ -835 +836 @@
     $r{_pos} = $r{_to} = $submatch->{_to};
     delete $r{_fate};
-    bless \%r, ref $self;               # return new match cursor for parent
+    CORE::bless \%r, ref $self;         # return new match cursor for parent
 }
 
@@ -874 +875 @@
         }
     }
-    return (bless \%r, ref $self), $tag, $try, $relex;
+    return (CORE::bless \%r, ref $self), $tag, $try, $relex;
 }
 
@@ -887 +888 @@
     $r{_pos} = $tpos;
 
-    bless \%r, ref $self;
+    CORE::bless \%r, ref $self;
 }
 
@@ -905 +906 @@
     $r{_pos} = $tpos;
 
-    bless \%r, ref $self;
+    CORE::bless \%r, ref $self;
 }
 
@@ -923 +924 @@
     $r{_to} = $self->{_from};
 
-    bless \%r, ref $self;
+    CORE::bless \%r, ref $self;
 }
 
@@ -1296 +1297 @@
 
     local $CTX = $self->callm if $DEBUG & DEBUG::trace_call;
-    lazymap(sub { bless($_[0],ref($self))->retm() },
+    lazymap(sub { CORE::bless($_[0],ref($self))->retm() },
         $block->($self));
 }
@@ -1305 +1306 @@
     local $CTX = $self->callm if $DEBUG & DEBUG::trace_call;
     my ($val) = $block->($self) or return ();
-    bless($val,ref($self))->retm();
+    CORE::bless($val,ref($self))->retm();
 }
 

src/perl6/STD.pm

@@ -8 +8 @@
 my $PARSER is context<rw>;
 my $IN_DECL is context<rw>;
+my %ROUTINES;
 
 # random rule for debugging, please ignore
@@ -95 +96 @@
     Buf  buf   buf1  buf2  buf4 buf8  buf16  buf32  buf64
 
-    Bit Bool True False
+    Bit Bool
     bit bool
 
@@ -106 +107 @@
     KitchenSink
 ];
+push @typenames, "True", "False";  # in quotes lest gimme5 translate them
 
 my %typenames;
@@ -123 +125 @@
     %typenames{$qualname} = $qualname;
     %typenames{$shortname} = $qualname;
+}
+
+# XXX likewise for routine defs
+
+my @routinenames = qw[
+    WHAT WHICH VAR
+    die exit warn eval temp
+    callsame callwith nextsame nextwith lastcall
+    defined undefine item list slice
+    join split substr index chars pack unpack uc ucfirst lc lcfirst
+    say print open close printf sprintf slurp unlink
+    elems grep map sort push reverse take splice
+    zip each roundrobin caller
+    return leave pop shift unshift reduce
+    keys values hash
+    sqrt floor ceil
+    any all none one
+    plan is ok dies_ok lives_ok skip todo pass flunk force_todo use_ok isa_ok
+    cmp_ok diag is_deeply isnt like skip_rest unlike nonce skip_rest eval_dies_okay
+];
+push @routinenames, "HOW", "fail";
+
+# if True ref False unless length bless delete exists
+
+my %routinenames;
+%routinenames{@routinenames} = (1 xx @routinenames);
+
+method is_routine ($name) {
+    return True if %routinenames{$name};
+    return True if %typenames{$name};
+    #return True if GLOBAL::{$name}.:exists;
+    return False;
+}
+
+method add_routine ($name) {
+    %routinenames{$name} = 1;
 }
 
@@ -482 +520 @@
     <statementlist>
     [ <?unitstopper> || <.panic: "Can't understand next input--giving up"> ]
+    # "CHECK" time...
+    {{
+        my %UNKNOWN;
+        for keys(%ROUTINES) {
+            next if $¢.is_routine($_);
+            %UNKNOWN{$_} = %ROUTINES{$_};
+        }
+        if %UNKNOWN {
+            warn "Unknown routines:\n";
+            for sort keys(%UNKNOWN) {
+                warn "\t$_ called at ", %UNKNOWN{$_}, "\n";
+            }
+        }
+    }}
 }
 
@@ -582 +634 @@
     # this could either be a statement that follows a declaration
     # or a statement that is within the block of a code declaration
-    <!!{ bless $¢, ref $PARSER; }>
+    <!!{ $¢ = $+PARSER.bless($¢); }>
 
     [
@@ -1541 +1593 @@
     # XXX too soon
     [ <colonpair>+ { $¢.add_macro($<name>) if $+IN_DECL; } ]?
+    { $¢.add_routine($<name>.text) if $+IN_DECL; }
 }
 
@@ -2376 +2429 @@
     :my $IN_DECL is context<rw> = 1;
     [ '&'<deflongname>? | <deflongname> ]? [ <multisig> | <trait> ]*
-    <!!{ bless $¢, ref $PARSER; }>
-    { $IN_DECL = 0; }
+    <!{
+        $¢ = $+PARSER.bless($¢);
+        $IN_DECL = 0;
+    }>
     <block>
 }
@@ -2407 +2462 @@
     :my $IN_DECL is context<rw> = 1;
     [ '&'<deflongname>? | <deflongname> ]? [ <multisig> | <trait> ]*
-    <!!{ bless $¢, ref $PARSER; }>
-    { $IN_DECL = 0; }
+    <!{
+        $¢ = $+PARSER.bless($¢);
+        $IN_DECL = 0;
+    }>
     <block>
 }
@@ -2626 +2683 @@
 
 token term:sym<next> ( --> Term)
-    { <sym> » <.ws> <termish>? }
+    { <sym> » <.ws> [<!stdstopper> <termish>]? }
 
 token term:sym<last> ( --> Term)
-    { <sym> » <.ws> <termish>? }
+    { <sym> » <.ws> [<!stdstopper> <termish>]? }
 
 token term:sym<redo> ( --> Term)
-    { <sym> » <.ws> <termish>? }
+    { <sym> » <.ws> [<!stdstopper> <termish>]? }
 
 token term:sym<goto> ( --> Term)
@@ -3075 +3132 @@
     :my $i;
     $i = <identifier> <args( $¢.is_type($i.text) )>
+    {{ %ROUTINES{$i.text} ~= $¢.lineof($¢.pos) ~ ' ' }}
 }
 
@@ -3864 +3922 @@
     for @text {
         $posprops.[$pos++]<L> = $line
-            for 1 .. length($_);
+            for 1 .. chars($_);
         $line++;
     }

src/perl6/gimme5

@@ -182 +182 @@
         $f =~ s/^\bdefault\s+\{//               and $t .= qq/else {/, next;
         $f =~ s/^\btemp\b//                     and $t .= qq/local/, next;
-        $f =~ s/^\bchars\(\b//                  and $t .= qq/length(/, next;
+        $f =~ s/^\bchars\(//                    and $t .= qq/length(/, next;
 
         # the following must do partial rescan of final expression
@@ -1565 +1565 @@
         local $NEEDMATCH = 0;
         %NEEDSEMI = ();
-        my $text;
+        my $text = '';
         for my $line (split /^/,$$self{text}) {
             if ($line =~ /^(\s*).*?given/) {
@@ -1579 +1579 @@
             $text .= $line;
         }
-        $text = ::un6($text);
+        $text = ::un6($text) // '';
         my $ctx = $$self{context};
         $text = 'my $M = $C; ' . $text . ';' if $NEEDMATCH;