Changeset 21813 for src/perl6

Timestamp:

08/06/08 20:21:22 (4 months ago)

Author:

lwall

Message:

[STD] factor out common prefix of all the *ibble routines
cleanup of type names

Location:

src/perl6

Files:

• Cursor.pmc (modified) (1 diff)
• STD.pm (modified) (7 diffs)

src/perl6/Cursor.pmc

@@ -1330 +1330 @@
 
 sub _EXACT { my $self = shift;
-    my $s = shift;
+    my $s = shift() // '';
 
     local $CTX = $self->callm($s) if $DEBUG & DEBUG::trace_call;

src/perl6/STD.pm

@@ -70 +70 @@
 
 
-#XXX shouldn't need this, it should all be in GLOBAL:: or the current package hash
-
-my @typenames = (      # (need parens for gimme5 translator)
-    <Void Bit Int UInt Str Num Complex Bool True False Rat>,
-    <Exception Code Block List Seq Range Set Bag Junction Pair>,
-    <Mapping Signature Capture Blob Whatever Undef Failure>,
-    <StrPos StrLen Version P6opaque>,
-    <bit int int8 int16 int32 uint uint8 uint16 uint32 buf buf8 buf16 buf32 num complex bool rat>,
-    <Scalar Array Hash KeyHash KeySet KeyBag Buf IO Routine Sub Method>,
-    <Submethod Macro Regex Match Package Module Class Role Grammar Any Object>,
-    ()
-);
+# XXX shouldn't need this, it should all be defined/imported by the prelude
+
+my @typenames = qw[
+    Object Any Junction Whatever
+    Capture Match Signature
+    Package Module Class Role Grammar
+    Scalar Array Hash KeyHash KeySet KeyBag
+    Pair List Seq Range Set Bag Mapping
+    Void Undef Failure Exception
+    Code Block Routine Sub Macro
+    Method Submethod Regex
+
+    Str Blob
+    Char Byte Codepoint Grapheme StrPos StrLen Version
+
+    Num Complex
+    num complex
+
+    Int  int   int1  int2  int4 int8  int16  int32  int64
+    Rat  rat   rat1  rat2  rat4 rat8  rat16  rat32  rat64
+    Uint uint uint1 uint2 uint4 uint8 uint16 uint32 uint64
+    Buf  buf   buf1  buf2  buf4 buf8  buf16  buf32  buf64
+
+    Bit Bool True False
+    bit bool
+
+    Order Increasing Decreasing
+    Ordered Callable Positional Associatve
+    Ordering KeyExtractor Comparator OrderingPair
+
+    IO
+
+    KitchenSink
+];
+
 my %typenames;
 %typenames{@typenames} = (1 xx @typenames);
@@ -1671 +1694 @@
 token escape:none { <!> }
 
-# XXX the front stuff needs to be factored out
-token quibble ($l) {
+token babble ($l) {
     :my $lang = $l;
     :my $start;
@@ -1690 +1712 @@
         $lang = $start ne $stop ?? $lang.balanced($start,$stop)
                                 !! $lang.unbalanced($stop);
-    }
+        $<B> = [$lang,$start,$stop];
+    }
+}
+
+token quibble ($l) {
+    :my ($lang, $start, $stop);
+    <babble($l)>
+    { my $B = $<babble><B>; ($lang,$start,$stop) = @$B; }
 
     $start <nibble($lang)> $stop
@@ -1706 +1735 @@
 }
 
-method nibble ($lang) {
-    my $outerlang = self.WHAT;
-    my $LANG is context = $outerlang;
-    self.cursor_fresh($lang).nibbler;
-}
-
 token sibble ($l, $lang2) {
-    :my $lang = $l;
-    :my $start;
-    :my $stop;
-
-    <.ws>
-    [ <quotepair> <.ws>
-        {
-            my $kv = $<quotepair>[*-1];
-            $lang = $lang.tweak($kv.<k>, $kv.<v>)
-                or self.panic("Unrecognized adverb :" ~ $kv.<k> ~ '(' ~ $kv.<v> ~ ')');
-        }
-    ]*
-
-    { ($start,$stop) = $¢.peek_delimiters(); }
-
+    :my ($lang, $start, $stop);
+    <babble($l)>
+    { my $B = $<babble><B>; ($lang,$start,$stop) = @$B; }
+
+    $start <left=nibble($lang)> $stop 
     [ <?{ $start ne $stop }> ::
-        { $lang = $lang.balanced($start,$stop); }
-        $start <left=nibble($lang)> $stop <.ws> '='<.ws> <right=EXPR(item %item_assignment)>
-    || { $lang = $lang.unbalanced($stop); }
-        $start <left=nibble($lang)> $stop
+        <.ws>
+        [ '=' || <.panic: "Missing '='"> ]
+        <.ws>
+        <right=EXPR(item %item_assignment)>
+    || 
         { $lang = $lang2.unbalanced($stop); }
         <right=nibble($lang)> $stop
@@ -1739 +1753 @@
 
 token tribble ($l, $lang2 = $l) {
-    :my $lang = $l;
-    :my $start;
-    :my $stop;
-
-    <.ws>
-    [ <quotepair> <.ws>
-        {
-            my $kv = $<quotepair>[*-1];
-            $lang = $lang.tweak($kv.<k>, $kv.<v>)
-                or self.panic("Unrecognized adverb :" ~ $kv.<k> ~ '(' ~ $kv.<v> ~ ')');
-        }
-    ]*
-
-    {
-        ($start,$stop) = $¢.peek_delimiters();
-        $lang = $start ne $stop ?? $lang.balanced($start,$stop)
-                                !! $lang.unbalanced($stop);
-    }
-
+    :my ($lang, $start, $stop);
+    <babble($l)>
+    { my $B = $<babble><B>; ($lang,$start,$stop) = @$B; }
+
+    $start <left=nibble($lang)> $stop 
     [ <?{ $start ne $stop }> ::
-        { $lang = $lang.balanced($start,$stop); }
-        $start <left=nibble($lang)> $stop <.ws> <quibble($lang2)>
-    || { $lang = $lang.unbalanced($stop); }
-        $start <left=nibble($lang)> $stop
+        <.ws> <quibble($lang2)>
+    || 
         { $lang = $lang2.unbalanced($stop); }
         <right=nibble($lang)> $stop
@@ -1769 +1767 @@
 
 token quasiquibble ($l) {
-    :my $lang = $l;
-    :my $start;
-    :my $stop;
-
-    <.ws>
-    [ <quotepair> <.ws>
-        {
-            my $kv = $<quotepair>[*-1];
-            $lang = $lang.tweak($kv.<k>, $kv.<v>)
-                or self.panic("Unrecognized adverb :" ~ $kv.<k> ~ '(' ~ $kv.<v> ~ ')');
-        }
-    ]*
-
-    {
-        ($start,$stop) = $¢.peek_delimiters();
-        $lang = $start ne $stop ?? $lang.balanced($start,$stop)
-                                !! $lang.unbalanced($stop);
-    }
+    :my ($lang, $start, $stop);
+    <babble($l)>
+    { my $B = $<babble><B>; ($lang,$start,$stop) = @$B; }
 
     [
@@ -1833 +1816 @@
         $COMPILING::LAST_NIBBLE_MULTILINE = $¢ if $multiline;
     }
+}
+
+# and this is what makes nibbler polymorphic...
+method nibble ($lang) {
+    my $outerlang = self.WHAT;
+    my $LANG is context = $outerlang;
+    self.cursor_fresh($lang).nibbler;
 }