misc/Parser-Mini/parser.pl

   1 # a simple p6 parser
   2 # by fglock
   3
   4 use v6-alpha;
   5
   6 # globals
   7
   8 my $line;
   9 my @tokens;
  10 my @post_tokens;
  11 my $tab_depth;
  12 my $line_number;
  13
  14 my $debug_tree = 1;   # show tree while it is built
  15
  16 # ---
  17
  18 sub tab {
  19     return '    ' x $tab_depth;
  20 }
  21
  22 sub error {
  23     print "# $line_number: $line\n";
  24     print "# *** $_[0]\n";
  25     die "\n";
  26 }
  27
  28 sub token {
  29     state $empty_line;
  30     loop {
  31         if @tokens {
  32             if @tokens[0] ~~ '#' {
  33                 # skip comment
  34                 @tokens = ();
  35                 next;
  36             }
  37             # print "<",@tokens[0],"> ";
  38             return shift @tokens;
  39         }
  40         $line = =<>;
  41         unless defined $line {
  42             return shift @post_tokens if @post_tokens;
  43             error "end of file";
  44         }
  45         $line_number++;
  46         # print "# $line_number: $line\n";
  47         @tokens = $line ~~ m:g:perl5 {(\w+|\s+|.+?)};   # \b doesn't work ???
  48         @tokens = @tokens.map:{ ~$_ };  # force stringify ???
  49         # say "tokens: ", @tokens.join('|');
  50     }
  51 }
  52
  53 sub optional_space {
  54     my $word;
  55     loop {
  56         $word = token;
  57         next if $word ~~ m:perl5/^\s/;
  58         unshift @tokens, $word;
  59         return;
  60     }
  61 }
  62
  63 sub sentence {
  64     print tab(), "sentence(\n" if $debug_tree;
  65     $tab_depth++;
  66     my @ret;
  67     my $word;
  68     #print "# Start sentence\n";
  69     loop {
  70         $word = token;
  71         # print "<$word> ";
  72         if ( $word ~~ ';' ) {
  73             $tab_depth--;
  74             print tab(), ")sentence,\n" if $debug_tree;
  75             return @ret;
  76         };
  77         if ( $word ~~ '(' ) {
  78             # print "#  paren\n";
  79             unshift @tokens, $word;
  80             push @ret, [ parenthesis() ];
  81             next;
  82         };
  83         if ( $word ~~ '{' ) {
  84             # print "#  start block\n";
  85             unshift @tokens, $word;
  86             push @ret, [ block() ];
  87             next;
  88         };
  89         if ( $word ~~ ')' || $word ~~ '}' ) {
  90             # print "#  end paren|block\n";
  91             unshift @tokens, $word;
  92             $tab_depth--;
  93             print tab(), ")sentence,\n" if $debug_tree;
  94             return @ret;
  95         };
  96         push @ret, $word;
  97         print tab(), "<$word>\n" if $debug_tree;
  98     }
  99 }
 100
 101 sub parenthesis {
 102     print tab(), "paren(\n" if $debug_tree;
 103     $tab_depth++;
 104     my @ret;
 105     my $word = token;
 106     $word ~~ '(' err error "not a <(> [$word]\n";
 107     loop {
 108         $word = token;
 109         if $word ~~ ')' {
 110             $tab_depth--;
 111             print tab(), ")paren,\n" if $debug_tree;
 112             return @ret;
 113         };
 114         unshift @tokens, $word;
 115         push @ret, [ sentence() ];
 116     }
 117 }
 118
 119 sub block {
 120     print tab(), "block{\n" if $debug_tree;
 121     $tab_depth++;
 122     my @ret;
 123     my $word = token;
 124     # print "token1<$word> ";
 125     $word ~~ '{' err error "not a <{> [$word]\n";
 126     loop {
 127         $word = token;
 128         # print "token2<$word> ";
 129         if $word ~~ m:perl5/^(class|method|submethod|sub|multi|macro)$/ {
 130             print tab(), "define(\n" if $debug_tree;
 131             $tab_depth++;
 132             my %block;
 133
 134             # multi sub|method
 135             if $word ~~ 'multi' {
 136                 optional_space;
 137                 my $word2 = token;
 138                 if $word2 ~~ 'method' || $word2 ~~ 'sub' {
 139                     $word ~= ' ' ~ $word2;
 140                 }
 141                 else {
 142                     push @tokens, $word2;
 143                 }
 144             };
 145             %block<thing> = $word;
 146             print tab(), "thing = $word,\n" if $debug_tree;
 147
 148             optional_space;
 149             $word = token;
 150             if $word ~~ '*' {
 151                 %block<namespace_modifier> = $word;
 152                 print tab(), "namespace_modifier = $word,\n" if $debug_tree;
 153             }
 154             else {
 155                 unshift @tokens, $word
 156             };
 157
 158             $word = token;
 159             if $word ~~ '(' || $word ~~ '{' {
 160                 unshift @tokens, $word
 161             }
 162             else {
 163                 %block<name> = $word;
 164                 print tab(), "name = $word,\n" if $debug_tree;
 165             };
 166
 167             $word = token;
 168             unshift @tokens, $word;
 169             if $word ~~ '(' {
 170                 print tab(), "param = \n" if $debug_tree;
 171                 $tab_depth++;
 172                 %block<param> = [ parenthesis() ];
 173                 $tab_depth--;
 174             }
 175
 176             #print "<< ", @tokens , " -- $line >>\n";
 177             print tab(), "block = \n" if $debug_tree;
 178             $tab_depth++;
 179             optional_space;
 180             %block<block> = [ block() ];
 181             $tab_depth--;
 182
 183             push @ret, \%block;
 184             $tab_depth--;
 185             print tab(), "}define,\n" if $debug_tree;
 186             next;
 187         }; # class
 188
 189         if ( $word ~~ '}' ) {
 190             #print "# End block $tab_depth [$word]\n";
 191             $tab_depth--;
 192             print tab(), "}block,\n" if $debug_tree;
 193             return @ret;
 194         };
 195
 196         if ( $word ~~ '{' ) {
 197             # print "#  bare block\n";
 198             unshift @tokens, $word;
 199             push @ret, [ block() ];
 200             next;
 201         };
 202
 203         if ( $word ~~ m:perl5/^\s/ ) {
 204             # spaces
 205             next;
 206         }
 207
 208         unshift @tokens, $word;
 209         push @ret, [ sentence() ];
 210     }
 211 }
 212
 213 # main
 214
 215 $line = '';
 216 @tokens = ( '{' );
 217 @post_tokens = ( '}' );
 218 $tab_depth = 0;
 219 $line_number = -1;
 220 my @tree = block( 'main block' );
 221
 222 print @tree.perl;