misc/Parser-Mini/parser-p5.pl

   1 # a simple p6 parser
   2 # by fglock
   3
   4 use strict;
   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 = 0;   # show tree while it is built
  15
  16 # ---
  17
  18 sub tab {
  19     return '    ' x $tab_depth;
  20 }
  21
  22 sub error {
  23     printf "# %04d: %s\n", $line_number, $line;
  24     print "# *** $_[0]\n";
  25     die "\n";
  26 }
  27
  28 sub token {
  29   while(1) {
  30     return shift @tokens if @tokens;
  31
  32     unless ( $line = <> ) {
  33         return shift @post_tokens if @post_tokens;
  34         error "end of file";
  35     }
  36
  37     $line_number++;
  38     chomp $line;
  39     if ( $line =~ /^#/ || $line =~ /^$/ ) {
  40         next;
  41     };
  42     # printf "# %04d: %s\n", $line_number, $line;
  43     @tokens = split( /\b/, $line );
  44   }
  45 }
  46
  47 sub optional_space {
  48     my $word;
  49     while(1) {
  50         $word = token;
  51         $word =~ s/^\s+//;
  52         next if $word eq '';
  53         unshift @tokens, $word;
  54         return;
  55     }
  56 }
  57
  58 sub sentence {
  59     my @param = @_;  # not used
  60     #$tab_depth++;
  61     print tab(), "sentence(\n" if $debug_tree;
  62     $tab_depth++;
  63
  64     my @ret;
  65
  66     my $word;
  67     #$word = token;
  68     #print "# Start sentence [@param]\n";
  69
  70     while(1) {
  71         $word = token;
  72         # print "<$word> ";
  73
  74         if ( $word =~ /^(.*?\S)(\s.*?)$/ ) {
  75             # split on inner space left from the simple tokenizer, like in ' = {'
  76             $word = $1;
  77             unshift @tokens, $2;
  78         }
  79
  80         if ( $word =~ /^\s*\;/ ) {
  81             #print "# End sentence [@param] [$word]\n";
  82             $word =~ s/^\s*\;//;
  83             unshift @tokens, $word if $word ne '';
  84
  85             $tab_depth--;
  86             print tab(), ")sentence,\n" if $debug_tree;
  87             #$tab_depth--;
  88             return @ret;
  89         };
  90
  91         if ( $word =~ /^\s*\(/ ) {
  92             # print "#  paren\n";
  93             unshift @tokens, $word;
  94             push @ret, [ parenthesis( 'bare paren' ) ];
  95             #print "# continue sentence: \n";
  96             next;
  97         };
  98
  99         if ( $word =~ /^\s*\{/ ) {
 100             # print "#  start block\n";
 101             unshift @tokens, $word;
 102             push @ret, [ block( 'bare block' ) ];
 103             #print "# continue sentence: \n";
 104             next;
 105         };
 106
 107         if ( $word =~ /^\s*\)/ ) {
 108             # print "#  end paren\n";
 109             unshift @tokens, $word;
 110             $tab_depth--;
 111             print tab(), ")sentence,\n" if $debug_tree;
 112             #$tab_depth--;
 113             return @ret;
 114         };
 115
 116         if ( $word =~ /^\s*\}/ ) {
 117             # print "#  end block\n";
 118             unshift @tokens, $word;
 119             $tab_depth--;
 120             print tab(), ")sentence,\n" if $debug_tree;
 121             #$tab_depth--;
 122             return @ret;
 123         };
 124
 125         push @ret, $word;
 126         print tab(), "'$word'\n" if $debug_tree;
 127
 128     }
 129
 130 }
 131
 132 sub parenthesis {
 133     my @param = @_;  # not used
 134     #$tab_depth++;
 135     print tab(), "paren(\n" if $debug_tree;
 136     $tab_depth++;
 137
 138     my @ret;
 139
 140     my $word;
 141     $word = token;
 142     #print "# Start paren $tab_depth [@param] [$word]\n";
 143     $word =~ s/^\s*\(// or error "not a <(> [$word]\n";
 144     unshift @tokens, $word if $word ne '';
 145     while(1) {
 146         $word = token;
 147         # print " [ $word ] ";
 148
 149         if ( $word =~ /^\s*\)/ ) {
 150             #print "# End paren $tab_depth [@param] [$word]\n";
 151             $word =~ s/^\s*\)//;
 152             unshift @tokens, $word if $word ne '';
 153
 154             $tab_depth--;
 155             print tab(), ")paren,\n" if $debug_tree;
 156             #$tab_depth--;
 157             return @ret;
 158         };
 159
 160         if ( $word =~ /^\s*\(/ ) {
 161             # print "#  paren\n";
 162             unshift @tokens, $word;
 163             push @ret, [ parenthesis( 'bare paren' ) ];
 164         };
 165
 166         unshift @tokens, $word;
 167         push @ret, [ sentence( $word ) ];
 168
 169     }
 170 }
 171
 172 sub block {
 173     my @param = @_;  # not used
 174
 175     my $word;
 176     $word = token;
 177     #print "# Start block $tab_depth [@param] [$word]\n";
 178     print tab(), "block{\n" if $debug_tree;
 179     $tab_depth++;
 180
 181     my @ret;
 182
 183     $word =~ s/^\s*{// or error "not a <{> [$word]\n";
 184     unshift @tokens, $word if $word ne '';
 185     while(1) {
 186         $word = token;
 187         # print " [ $word ] ";
 188         if ( $word =~ /^(class|method|submethod|sub|multi|macro)$/ ) {
 189             print tab(), "define(\n" if $debug_tree;
 190             $tab_depth++;
 191
 192             my %block;
 193
 194             # multi sub|method
 195             if ( $word eq 'multi' ) {
 196                 optional_space;
 197                 my $word2 = token;
 198                 if ( $word2 eq 'method' || $word2 eq 'sub' ) {
 199                     $word .= ' ' . $word2;
 200                 }
 201                 else {
 202                     push @tokens, $word2;
 203                 }
 204             };
 205             $block{thing} = $word;
 206
 207             print tab(), "thing = $word,\n" if $debug_tree;
 208
 209             optional_space;
 210             $word = token;
 211             my $namespace;
 212             if ($word eq '*') { $namespace = $word }
 213                 else { unshift @tokens, $word };
 214             print tab(), "namespace_modifier = $namespace,\n" if $debug_tree;
 215             $block{namespace_modifier} = $namespace;
 216
 217             $word = token;
 218             my $name;
 219             if ($word =~ /(\(|\{)/) { unshift @tokens, $word }
 220                 else { $name = $word };
 221             print tab(), "name = $name,\n" if $debug_tree;
 222             $block{name} = $name;
 223
 224             $word = token;
 225             unshift @tokens, $word;
 226             if ( $word =~ /^\s*\(/ ) {
 227                 print tab(), "param = \n" if $debug_tree;
 228                 $tab_depth++;
 229                 $block{param} = [ parenthesis( 'parameter paren' ) ];
 230                 $tab_depth--;
 231             }
 232
 233             print tab(), "block = \n" if $debug_tree;
 234             $tab_depth++;
 235             $block{block} = [ block( $1, $name ) ];
 236             $tab_depth--;
 237
 238
 239             push @ret, \%block;
 240
 241             $tab_depth--;
 242             print tab(), "}define,\n" if $debug_tree;
 243             next;
 244         }; # class
 245
 246         if ( $word =~ /^\s*}/ ) {
 247             #print "# End block $tab_depth [@param] [$word]\n";
 248             $word =~ s/^\s*\}//;
 249             unshift @tokens, $word if $word ne '';
 250
 251             $tab_depth--;
 252             print tab(), "}block,\n" if $debug_tree;
 253             return @ret;
 254         };
 255
 256         if ( $word =~ /^\s*{/ ) {
 257             # print "#  bare block\n";
 258             unshift @tokens, $word;
 259             push @ret, [ block( 'bare block' ) ];
 260             next;
 261         };
 262
 263         if ( $word =~ /^\s+$/ ) {
 264             # spaces
 265             next;
 266         }
 267
 268         unshift @tokens, $word;
 269         push @ret, [ sentence( $word ) ];
 270
 271     }
 272 }
 273
 274 # main
 275
 276 $line = '';
 277 @tokens = ( '{' );
 278 @post_tokens = ( '}' );
 279 $tab_depth = 0;
 280 $line_number = -1;
 281 my @tree = block( 'main block' );
 282
 283 use Data::Dumper;
 284 $Data::Dumper::Indent = 1;
 285 print Dumper( \@tree );