Changeset 21213

Timestamp:

07/04/08 13:39:38 (3 months ago)

Author:

pmurias

Message:

[pixie] arrays are marked in the dumps, stranger token names work more often

Files:

• misc/pixie/extract_actions (modified) (1 diff)
• misc/pixie/insert_actions (modified) (1 diff)
• misc/pixie/pixie (modified) (4 diffs)
• misc/pixie/pixie_actions5 (modified) (2 diffs)
• src/perl6/DumpMatch.pm (modified) (3 diffs)
• src/perl6/STD5_dump_match (modified) (1 diff)

misc/pixie/extract_actions

@@ -11 +11 @@
 my @last_token;
 for (@chunks) {
-    /^.* (?:regex|rule|token) \s+ ([:\w]+)/sx;
-    push (@last_token,$1);
+    /^.* (?:regex|rule|token) \s+ ([:\w]+?(?:sym<.*?>)?)\s/sx;
+    my $name = $1;
+    $name =~ s/sym:<(.*)>/$1/g;
+    push (@last_token,$name);
 }
 

misc/pixie/insert_actions

@@ -17 +17 @@
 my ($name);
 for (<$std>) {
-    if (/(?:token|rule) ([\w:]+)/) {
+    if (/(?:regex|rule|token) \s+ ([:\w]+?(?:sym<.*?>)?)\s/x) {
         $name = $1;
+        $name =~ s/:sym<(.*)>/$1/;
 #        warn YELLOW,"$name",RESET;
     }
-    if (/\{\*\} \s* (?:\#=(.*))?/x) {
+    if (/\{\*\} .*? (?:\#=(.*))?$/x) {
         my $tag = $1 || ""; 
         my $full_name = $name . $tag;
-#        warn "inserting ".GREEN.$full_name.RESET if $actions{$full_name};
+#        warn "inserting ".GREEN.$full_name.RESET."\n".$_ if $actions{$full_name};
 #        warn "not inserting <".RED.$full_name.RESET.">" unless $actions{$full_name};
         my $content = $actions{$full_name} // "*";

misc/pixie/pixie

@@ -25 +25 @@
 use Encode;
 require 'mangle.pl'; 
+sub ::unmangle {
+    local $_ = shift;
+    s/Grave/\`/g;
+    s/Tilde/\~/g;
+    s/Bang/\!/g;
+    s/At/\@/g;
+    s/Sharp/\#/g;
+    s/Dollar/\$/g;
+    s/Percent/\%/g;
+    s/Caret/\^/g;
+    s/Amp/\&/g;
+    s/Star/\*/g;
+    s/Paren/\(/g;
+    s/Thesis/\)/g;
+    s/Minus/\-/g;
+    s/Plus/\+/g;
+    s/Equal/\=/g;
+    s/Cur/\{/g;
+    s/Ly/\}/g;
+    s/Bra/\[/g;
+    s/Ket/\]/g;
+    s/Vert/\|/g;
+    s/Back/\\/g;
+    s/Colon/\:/g;
+    s/Semi/\;/g;
+    s/Single/\'/g;
+    s/Double/\"/g;
+    s/Lt/\</g;
+    s/Gt/\>/g;
+    s/Fre/\«/g;
+    s/Nch/\»/g;
+    s/Comma/\,/g;
+    s/Dot/\./g;
+    s/Question/\?/g;
+    s/Slash/\//g;
+    return $_;
+#       s/(\W)/sprintf("_%02x_",ord($1))/eg;
+}
 use strict;
 use warnings;
@@ -50 +88 @@
 
 while (my ($name,$code) = each %actions) {
-    $actions{$name} = eval("sub {package pixie_actions;".$code."}");
+    my $str = qq!sub {\npackage pixie_actions;\n#line 1 "action $name"\n!.$code."}";
+    print $str;
+    $actions{$name} = eval($str);
     die "error at pixie_action5, action $name: $@\n" if $@;
 }
@@ -118 +158 @@
         my $tag = shift;
         $tag =~ s/__S_\d+/:/;
+        my $tag = ::unmangle($tag);
 
         if ($actions{$tag}) {
-            print (GREEN,$tag,"\n",RESET) unless $quiet;
+            print (GREEN,$tag,RESET,"\n") unless $quiet;
             local $_ = $self;
             $actions{$tag}->();
             $self;
         } else {
-            print (RED,$tag,"\n",RESET) unless $quiet;
+            print (RED,$tag,RESET,"\n") unless $quiet;
             $self;
         }
@@ -136 +177 @@
     exit;
 } else {
-    print dump_match($what=>$r,{vertical=>1,actions=>sub {Compiler::dump_IRx1(@_)}}),"\n" unless $quiet;
+    print dump_match($what=>$r,{vertical=>1,mark_arrays=>1,actions=>sub {Compiler::dump_IRx1(@_)}}),"\n" unless $quiet;
 }
 my $ir = $r->{''};

misc/pixie/pixie_actions5

@@ -1 +1 @@
 ### comp_unit 
 make (IRx1::CompUnit->new(statements=>$_->{statementlist}->item))
+### block 
+make (IRx1::Block->new(statements=>$_->{statementlist}->item))
 ### statementlist 
- make ([map { ref $_->item ? $_->item : '#' . $_->item } @{$_->{statement}}])
+ make ([map { ref $_->item ? $_->item : do {(my $tmp = $_->item) =~ s/^^/#todo: /mg;$tmp}} @{$_->{statement}}])
 ### statement control
 make ($_->{statement_control}->item) 
@@ -10 +12 @@
 ### statement_control:use 
 make(IRx1::Use->new(module_name=>$_->{module_name}->item))
+### statement_control:if 
+make (IRx1::Cond->new(clauses=>[EXPR($_->{EXPR}),$_->{pblock}{block}->item],default=>$_->{else} ? $_->{else}->item : undef))
 ### noun 
 

src/perl6/DumpMatch.pm

@@ -54 +54 @@
 }
 sub traverse_match {
-    my ($r,$label,$depth,$events) = @_;
+    my ($r,$label,$depth,$events,$opt) = @_;
     return unless ref $r && ref $r ne 'SCALAR' && ref $r ne 'ARRAY';
      if (defined $r->{_from}) {
@@ -68 +68 @@
         my $v = $r->{$name};
         if (ref $v eq 'ARRAY') {
+            $name = "[$name]" if $opt->{mark_arrays};
             for my $i (0 .. scalar @{$v}) {
-                traverse_match($v->[$i],$name,$depth+1,$events);
+                traverse_match($v->[$i],$name,$depth+1,$events,$opt);
             }
         } elsif (ref $v eq 'SCALAR') {
         } elsif (ref $v) {
-            traverse_match($v,$name,$depth+1,$events);
+            traverse_match($v,$name,$depth+1,$events,$opt);
         } else {
         }
@@ -83 +84 @@
     my $opt = shift || {};
     my $events = [];
-    traverse_match($r,$name,0,$events);
+    traverse_match($r,$name,0,$events,$opt);
     process_events(${$r->{_orig}},$events,$opt);
 }

src/perl6/STD5_dump_match

@@ -14 +14 @@
 GetOptions("nocolor"=>\$nocolor,"vertical"=>\$vertical,"yaml"=>\$yaml);
 unless ($#ARGV <= 0) {
-    die "USAGE: [--nocolor] [filename]\n";
+    die "USAGE: [--nocolor --vertical] [filename]\n";
 }
 if ($nocolor) {