1package Pugs::Grammar::Precedence; 2 3# Documentation in the __END__ 4use 5.006; 5use strict; 6use warnings; 7 8use Parse::Yapp; 9use Digest::MD5 'md5_hex'; 10 11my $cache; 12eval { 13 require Cache::FileCache; 14 $cache = new Cache::FileCache( { 'namespace' => 'v6-precedence' } ); 15}; 16 17my %relative_precedences = ( 18 tighter => sub { 19 splice( @{$_[0]->{levels}}, $_[1], 0, [ $_[2] ] ); 20 }, 21 looser => sub { 22 splice( @{$_[0]->{levels}}, $_[1]+1, 0, [ $_[2] ] ); 23 }, 24 equal => sub { 25 push @{$_[0]->{levels}[$_[1]]}, $_[2]; 26 }, 27); 28 29# note: S06 - 'chain' can't be mixed with other types in the same level 30my %rule_templates = ( 31 prefix_non => 32 "'name' exp \n" . 33 "\t{ \$_[0]->{out}= {fixity => 'prefix', op1 => \$_[1], exp1 => \$_[2],} }", 34 circumfix_non => 35 "'name' exp 'name2' \n" . 36 "\t{ \$_[0]->{out}= {fixity => 'circumfix', op1 => \$_[1], op2 => \$_[3], exp1 => \$_[2],} }\n" . 37 "\t | 'name' 'name2' \n" . 38 "\t{ \$_[0]->{out}= {fixity => 'circumfix', op1 => \$_[1], op2 => \$_[2] } }", 39 infix_right => 40 "exp 'name' exp \n" . 41 "\t{ \$_[0]->{out}= {fixity => 'infix', op1 => \$_[2], exp1 => \$_[1], exp2 => \$_[3],} }", 42 postfix_non => 43 "exp 'name' \n" . 44 "\t{ \$_[0]->{out}= {fixity => 'postfix', op1 => \$_[2], exp1 => \$_[1],} }", 45 postcircumfix_non => 46 "exp 'name' exp 'name2' \n" . 47 "\t{ \$_[0]->{out}= {fixity => 'postcircumfix', op1 => \$_[2], op2 => \$_[4], exp1 => \$_[1], exp2 => \$_[3],} } \n" . 48 "\t | exp 'name' 'name2' \n" . 49 "\t{ \$_[0]->{out}= {fixity => 'postcircumfix', op1 => \$_[2], op2 => \$_[3], exp1 => \$_[1], } }", 50 infix_left => 51 "exp 'name' exp \n" . 52 "\t{ \$_[0]->{out}= {fixity => 'infix', op1 => \$_[2], exp1 => \$_[1], exp2 => \$_[3],} }", 53 infix_non => 54 "exp 'name' exp \n" . 55 "\t{ \$_[0]->{out}= {fixity => 'infix', op1 => \$_[2], exp1 => \$_[1], exp2 => \$_[3],} }", 56 ternary_non => 57 "exp 'name' exp 'name2' exp \n" . 58 "\t{ \$_[0]->{out}= {fixity => 'ternary', op1 => \$_[2], op2 => \$_[4], exp1 => \$_[1], exp2 => \$_[3], exp3 => \$_[5],} }", 59 60 # XXX 61 #infix_chain => 62 # "exp 'name' chain_right \n" . 63 # "\t{ \$_[0]->{out}= {op1 => 'name', exp1 => \$_[1], exp2 => \$_[3],} }", 64 #infix_list => 65 # "exp 'name' list_right \n" . 66 # "\t{ \$_[0]->{out}= {op1 => 'name', exp1 => \$_[1], exp2 => \$_[3],} }", 67); 68 69sub new { 70 my $class = shift; 71 my $self = { levels => [], @_ }; 72 bless $self, $class; 73} 74 75our $op_count = '000'; 76sub add_op { 77 my ($self, $opt) = @_; 78 #print "adding $opt->{name}\n"; 79 $opt->{assoc} = 'non' unless defined $opt->{assoc}; 80 $opt->{fixity} = 'prefix' unless defined $opt->{fixity}; 81 $opt->{index} = 'OP' . $op_count++; 82 #my $fixity = $opt->{fixity}; 83 #$fixity .= '_' . $opt->{assoc} if $opt->{fixity} eq 'infix'; 84 for my $level ( 0 .. $#{$self->{levels}} ) { 85 if ( grep { 86 defined $opt->{other} 87 ? ($_->{name} eq $opt->{other}) 88 : 0 89 } @{$self->{levels}[$level]} ) { 90 #print "pos $level at $opt->{precedence} $opt->{other}\n"; 91 $relative_precedences{$opt->{precedence}}->($self, $level, $opt); 92 #print "Precedence table: ", Dump( $self ); 93 return; 94 } 95 } 96 if ( ! defined $opt->{precedence} ) { 97 push @{$self->{levels}}, [ $opt ]; 98 return; 99 } 100 die "there is no precedence like ", $opt->{other}; 101} 102 103 104sub add_to_list { 105 my ( $op, $x, $y ) = @_; 106 my @x = ($x); 107 @x = @{$x->{list}} if exists $x->{list} && $x->{op1} eq $op; 108 return { op1 => $op, list => [ @x, $y ], assoc => 'list' }; 109} 110 111sub add_to_chain { 112 my ( $op, $x, $y ) = @_; 113 my @x = exists $x->{chain} ? @{$x->{chain}} : ($x); 114 my @y = exists $y->{chain} ? @{$y->{chain}} : ($y); 115 return { chain => [ @x, $op, @y ], assoc => 'chain' }; 116} 117 118sub emit_yapp { 119 my ($self) = @_; 120 my $s; # = "%{ my \$_[0]->{out}; %}\n"; 121 my $prec = "P000"; 122 my %seen; 123 for my $level ( reverse 0 .. $#{$self->{levels}} ) { 124 my %assoc; 125 for my $operator ( @{$self->{levels}[$level]} ) { 126 push @{$assoc{ $operator->{assoc} }}, $operator; 127 } 128 for my $aaa ( keys %assoc ) { 129 if ( @{$assoc{$aaa}} ) { 130 my $a = $aaa; 131 $a = 'nonassoc' if $a eq 'non'; 132 $a = 'left' if $a eq 'list'; 133 $a = 'left' if $a eq 'chain'; 134 $s .= "%$a "; 135 for my $operator ( @{ $assoc{$aaa} } ) { 136 next if $seen{$operator->{name}}; 137 $seen{$operator->{name}} = 1; 138 $s .= ' ' . 139 "'$operator->{name}'" ; 140 # (( $aaa eq 'list' || $aaa eq 'chain' ) 141 # ? $operator->{index} 142 # : "'$operator->{name}'" 143 # ); 144 } 145 $s .= 146 " $prec" . 147 "\n"; 148 # $seen{$_->{name}} = 1 for @{$assoc{$_}}; 149 $prec++; 150 } 151 } 152 } 153 $s .= "%%\n" . 154 "statement: exp { return(\$_[0]->{out}) } ;\n"; 155 156 if ( defined $self->{header} ) { 157 $s .= $self->{header}; 158 } 159 else { 160 $s .= 161 "exp: NUM { \$_[0]->{out}= \$_[1] }\n"; 162 } 163 $prec = "P000"; 164 for my $level ( reverse 0 .. $#{$self->{levels}} ) { 165 my %assoc; 166 for ( @{$self->{levels}[$level]} ) { 167 push @{$assoc{ $_->{assoc} }}, $_; 168 } 169 for ( keys %assoc ) { 170 if ( @{$assoc{$_}} ) { 171 172 173 for my $op ( @{$assoc{$_}} ) { 174 if ( $op->{assoc} eq 'list' ) { 175 $s .= 176 " | exp '$op->{name}' exp %prec $prec\n" . 177 " { \$_[0]->{out}= Pugs::Grammar::Precedence::add_to_list( '$op->{name}', \$_[1], \$_[3] ) } \n" ; 178 $s .= 179 " | exp '$op->{name}' %prec $prec\n" . 180 " { \$_[0]->{out}= Pugs::Grammar::Precedence::add_to_list( '$op->{name}', \$_[1], { null => 1 } ) } \n" ; 181 # " { \$_[0]->{out}= \$_[1] } \n" ; 182 next; 183 } 184 if ( $op->{assoc} eq 'chain' ) { 185 $s .= 186 " | exp '$op->{name}' exp %prec $prec\n" . 187 " { \$_[0]->{out}= Pugs::Grammar::Precedence::add_to_chain( '$op->{name}', \$_[1], \$_[3] ) } \n" ; 188 $s .= 189 " | exp '$op->{name}' %prec $prec\n" . 190 " { \$_[0]->{out}= Pugs::Grammar::Precedence::add_to_chain( '$op->{name}', \$_[1], { null => 1 } ) } \n" ; 191 # " { \$_[0]->{out}= \$_[1] } \n" ; 192 next; 193 } 194 my $t = $rule_templates{"$op->{fixity}_$op->{assoc}"}; 195 unless ( defined $t ) { 196 warn "can't find template for '$op->{fixity}_$op->{assoc}'"; 197 next; 198 } 199 $t =~ s/$_/$op->{$_}/g for qw( name2 name ); 200 $t =~ s/\{ /%prec $prec { /; 201 $s .= " | $t \n" . 202 # "\t%prec $prec\n" . 203 "\t/* $op->{name} $op->{fixity} $op->{assoc} */\n"; 204 } 205 $prec++; 206 } 207 } 208 } 209 $s .= ";\n" . 210 "%%\n"; 211 #print $s; 212 return $s; 213} 214 215sub emit_grammar_perl5 { 216 my $self = shift; 217 my $g = $self->emit_yapp(); 218 #print $g; 219 220 my $digest = md5_hex($self->{grammar} . $g); 221 my $cached; 222 223 if ($cache && ($cached = $cache->get($digest))) { 224 return $cached; 225 } 226 227 my $p = Parse::Yapp->new( input => $g ); 228 $cached = $p->Output( classname => $self->{grammar} ); 229 $cache->set($digest, $cached) if $cache; 230 return $cached; 231} 232 233sub exists_op { die "not implemented" }; 234sub delete_op { die "not implemented" }; 235sub get_op { die "not implemented" }; 236sub inherit_category { die "not implemented" }; 237sub inherit_grammar { die "not implemented" }; 238sub merge_category { die "not implemented" }; 239sub code { die "not implemented" } 240sub match { die "not implemented" } 241sub perl5 { die "not implemented" } 242 2431; 244 245__END__ 246 247=head1 NAME 248 249Pugs::Grammar::Precedence - Engine for Perl 6 Rule operator precedence 250 251=head1 SYNOPSIS 252 253 use Pugs::Grammar::Precedence; 254 255 # example definition for "sub rxinfix:<|> ..." 256 257 my $rxinfix = Pugs::Grammar::Precedence->new( 258 grammar => 'rxinfix', 259 ); 260 $rxinfix->add_op( 261 name => '|', 262 assoc => 'left', 263 fixity => 'infix', 264 ); 265 266Pseudo-code for usage inside a grammar: 267 268 sub new_proto( $match ) { 269 return ${$match<category>}.add_op( 270 name => $match<name>, 271 fixity => ..., 272 precedence => ..., 273 ); 274 } 275 276 rule prototype { 277 proto <category>:<name> <options> 278 { 279 return new_proto($/); 280 } 281 } 282 283 rule statement { 284 <category.parse> ... 285 } 286 287=head1 DESCRIPTION 288 289This module provides an implementation for Perl 6 operator precedence. 290 291=head1 METHODS 292 293=head2 new () 294 295Class method. Returns a category object. 296 297options: 298 299=over 300 301=item * C<< grammar => $category_name >> - the name of this category 302(a namespace or a Grammar name). 303 304=back 305 306=head2 add_op () 307 308Instance method. Adds a new operator to the category. 309 310options: 311 312=over 313 314=item * name => $operator_name - the name of this operator, such as '+', '*' 315 316=item * name2 => $operator_name - the name of the second operator in 317an operator pair, such as circumfix [ '(', ')' ] or ternary [ '??', '!!' ]. 318 319 # precedence=>'tighter', 320 # tighter/looser/equiv 321 # other=>'+', 322 # fixity => 323 # infix/prefix/circumfix/postcircumfix/ternary 324 # assoc => 325 # left/right/non/chain/list 326 # rule=>$rule 327 # (is parsed) 328 329=back 330 331=head1 AUTHORS 332 333The Pugs Team E<lt>perl6-compiler@perl.orgE<gt>. 334 335=head1 SEE ALSO 336 337Summary of Perl 6 Operators: L<http://dev.perl.org/perl6/doc/design/syn/S03.html> 338 339=head1 COPYRIGHT 340 341Copyright 2006, 2007 by Flavio Soibelmann Glock and others. 342 343This program is free software; you can redistribute it and/or modify it 344under the same terms as Perl itself. 345 346See L<http://www.perl.com/perl/misc/Artistic.html> 347 348=cut 349 350