[system] / trunk / pg / lib / Parser / BOP.pm Repository:
ViewVC logotype

View of /trunk/pg/lib/Parser/BOP.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 5696 - (download) (as text) (annotate)
Sat Jun 14 12:14:21 2008 UTC (11 years, 8 months ago) by dpvc
File size: 10766 byte(s)
Added

	 no strict "refs"

to try to avoid new error checking in Perl 5.10.

    1 #########################################################################
    2 #
    3 #  Implements the base Binary Operator class
    4 #
    5 
    6 package Parser::BOP;
    7 use strict; no strict "refs";
    8 our @ISA = qw(Parser::Item);
    9 
   10 $Parser::class->{BOP} = 'Parser::BOP';
   11 
   12 #
   13 #  Make a new instance of a BOP
   14 #
   15 #  Make left and right operands into lists if they are comma operators
   16 #    and this operator isn't itself a comma.
   17 #
   18 sub new {
   19   my $self = shift; my $class = ref($self) || $self;
   20   my $equation = shift; my $context = $equation->{context};
   21   my ($bop,$lop,$rop,$ref) = @_;
   22   my $def = $context->{operators}{$bop};
   23   if (!$def->{isComma}) {
   24     $lop = $self->Item("List",$context)->new($equation,[$lop->makeList],
   25        $lop->{isConstant},$context->{parens}{start}) if ($lop->type eq 'Comma');
   26     $rop = $self->Item("List",$context)->new($equation,[$rop->makeList],$rop->{isConstant},
   27        $context->{parens}{start}) if ($rop->type eq 'Comma');
   28   }
   29   my $BOP = bless {
   30     bop => $bop, lop => $lop, rop => $rop,
   31     def => $def, ref => $ref, equation => $equation,
   32   }, $def->{class};
   33   $BOP->weaken;
   34   $BOP->{isConstant} = 1 if ($lop->{isConstant} && $rop->{isConstant});
   35   $BOP->_check;
   36   $BOP = $BOP->Item("Value")->new($equation,[$BOP->eval])
   37     if $BOP->{isConstant} && !$def->{isComma} && $context->flag('reduceConstants');
   38   return $BOP;
   39 }
   40 
   41 #
   42 #  Stub for checking if the BOP can operate on the given operands.
   43 #  (Implemented in subclasses.)
   44 #
   45 sub _check {}
   46 
   47 ##################################################
   48 
   49 #
   50 #  Evaluate the left and right operands and peform the
   51 #  required operation on the results.
   52 #
   53 sub eval {
   54   my $self = shift;
   55   $self->_eval($self->{lop}->eval,$self->{rop}->eval);
   56 }
   57 #
   58 #  Stub for sub-classes.
   59 #
   60 sub _eval {return $_[1]}
   61 
   62 #
   63 #  Reduce the left and right operands.
   64 #  If they are constant (and it's not a comma), make a constant value of them.
   65 #  Otherwise, reduce the result.
   66 #
   67 sub reduce {
   68   my $self = shift; my $bop = $self->{def};
   69   $self->{lop} = $self->{lop}->reduce;
   70   $self->{rop} = $self->{rop}->reduce;
   71   return $self->Item("Value")->new($self->{equation},[$self->eval])
   72     if (!$bop->{isComma} && $self->{lop}{isConstant} && $self->{rop}{isConstant});
   73   $self->_reduce;
   74 }
   75 #
   76 #  Stub for sub-classes.
   77 #
   78 sub _reduce {shift}
   79 
   80 #
   81 #  Substitute in the left and right operands.
   82 #
   83 sub substitute {
   84   my $self = shift; my $bop = $self->{def};
   85   $self->{lop} = $self->{lop}->substitute;
   86   $self->{rop} = $self->{rop}->substitute;
   87   my $equation = $self->{equation}; my $context = $equation->{context};
   88   return $self->Item("Value")->new($equation,[$self->eval])
   89     if !$bop->{isComma} && $self->{lop}{isConstant} && $self->{rop}{isConstant} &&
   90         $context->flag('reduceConstants');
   91   return $self;
   92 }
   93 
   94 #
   95 #  Copy the left and right operands as well as the rest
   96 #    of the equations.
   97 #
   98 sub copy {
   99   my $self = shift; my $equation = shift;
  100   my $new = $self->SUPER::copy($equation);
  101   $new->{lop} = $self->{lop}->copy($equation);
  102   $new->{rop} = $self->{rop}->copy($equation);
  103   return $new;
  104 }
  105 
  106 ##################################################
  107 #
  108 #  Service routines for checking the types of operands.
  109 #
  110 
  111 
  112 #
  113 #  Error if one of the operands is a string.
  114 #
  115 sub checkStrings {
  116   my $self = shift; return 0 if $self->context->flag("allowBadOperands");
  117   my $ltype = $self->{lop}->typeRef; my $rtype = $self->{rop}->typeRef;
  118   my $name = $self->{def}{string} || $self->{bop};
  119   if ($ltype->{name} eq 'String') {
  120     $self->Error("Operands of '%s' can't be %s",$name,
  121      ($self->{lop}{isInfinite}? 'infinities': 'words'));
  122     return 1;
  123   }
  124   if ($rtype->{name} eq 'String') {
  125     $self->Error("Operands of '%s' can't be %s",$name,
  126      ($self->{rop}{isInfinite}? 'infinities': 'words'));
  127     return 1;
  128   }
  129   return 0;
  130 }
  131 
  132 #
  133 #  Error if one of the operands is a list.
  134 #
  135 sub checkLists {
  136   my $self = shift; return 0 if $self->context->flag("allowBadOperands");
  137   my $ltype = $self->{lop}->typeRef; my $rtype = $self->{rop}->typeRef;
  138   return 0 if ($ltype->{name} ne 'List' and $rtype->{name} ne 'List');
  139   my $name = $self->{def}{string} || $self->{bop};
  140   $self->Error("Operands of '%s' can't be lists",$name);
  141   return 1;
  142 }
  143 
  144 #
  145 #  Determine if both operands are numbers, and promote to
  146 #    complex numbers if one is complex.
  147 #
  148 sub checkNumbers {
  149   my $self = shift;
  150   return 0 if !($self->{lop}->isNumber && $self->{rop}->isNumber) &&
  151               !$self->context->flag("allowBadOperands");
  152   if ($self->{lop}->isComplex || $self->{rop}->isComplex) {
  153     $self->{type} = $Value::Type{complex};
  154   } else {
  155     $self->{type} = $Value::Type{number};
  156   }
  157   return 1;
  158 }
  159 
  160 #
  161 #  Check if two matrices can be multiplied.
  162 #
  163 sub checkMatrixSize {
  164   my $self = shift;
  165   my ($lm,$rm) = @_;
  166   my ($ltype,$rtype) = ($lm->{entryType},$rm->{entryType});
  167   if ($ltype->{entryType}{name} eq 'Number' &&
  168       $rtype->{entryType}{name} eq 'Number') {
  169     my ($lr,$lc) = ($lm->{length},$ltype->{length});
  170     my ($rr,$rc) = ($rm->{length},$rtype->{length});
  171     if ($lc == $rr) {
  172       my $rowType = Value::Type('Matrix',$rc,$Value::Type{number},formMatrix=>1);
  173       $self->{type} = Value::Type('Matrix',$lr,$rowType,formMatrix=>1);
  174     } else {$self->Error("Matrices of dimensions %dx%d and %dx%d can't be multiplied",$lr,$lc,$rr,$rc)}
  175   } else {$self->Error("Matrices are too deep to be multiplied")}
  176 }
  177 
  178 #
  179 #  Promote point operands to vectors or matrices.
  180 #
  181 sub promotePoints {
  182   my $self = shift; my $class = shift;
  183   my $ltype = $self->{lop}->typeRef;
  184   my $rtype = $self->{rop}->typeRef;
  185   if ($ltype->{name} eq 'Point' ||
  186       ($ltype->{name} eq 'Matrix' && !$ltype->{entryType}{entryType})) {
  187     $ltype = {%{$ltype}, name => 'Vector'};
  188     $ltype = Value::Type($class,1,Value::Type($class,1,$ltype->{entryType}))
  189       if ($ltype->{length} == 1 && $class);
  190   }
  191   if ($rtype->{name} eq 'Point' ||
  192       ($rtype->{name} eq 'Matrix' && !$rtype->{entryType}{entryType})) {
  193     $rtype = {%{$rtype}, name => 'Vector'};
  194     $rtype = Value::Type($class,1,Value::Type($class,1,$rtype->{entryType}))
  195       if ($rtype->{length} == 1 && $class);
  196   }
  197   return ($ltype,$rtype);
  198 }
  199 
  200 #
  201 #  Report an error if the operand types don't match.
  202 #
  203 sub matchError {
  204   my $self = shift; return if $self->context->flag("allowBadOperands");
  205   my ($ltype,$rtype) = @_;
  206   my ($op,$ref) = ($self->{bop});
  207   if ($ltype->{name} eq $rtype->{name})
  208        {$self->Error("Operands for '%s' must be of the same length",$op)}
  209   else {$self->Error("Operands for '%s' must be of the same type",$op)}
  210 }
  211 
  212 ##################################################
  213 #
  214 #  Service routines for adjusting the values of operands.
  215 #
  216 
  217 #
  218 #  Return a zero, or a list of zeros of the proper length.
  219 #
  220 sub makeZero {
  221   my $self = shift; my $op = shift; my $zero = shift;
  222   return $zero if ($op->isNumber);
  223   if ($zero->isNumber && $op->type =~ m/Point|Vector/) {
  224     $op->{coords} = []; $op->{isZero} = 1;
  225     foreach my $i (0..($op->length-1)) {push(@{$op->{coords}},$zero)}
  226     return $op
  227   }
  228   return $self;
  229 }
  230 
  231 #
  232 #  Produce a negated version of a BOP.
  233 #
  234 sub makeNeg {
  235   my $self = shift;
  236   $self->{lop} = shift; $self->{rop} = shift;
  237   return Parser::UOP::Neg($self);
  238 }
  239 
  240 #
  241 #  Reverse the operands (left <=> right).
  242 #
  243 sub swapOps {
  244   my $self = shift;
  245   my $tmp = $self->{lop}; $self->{lop} = $self->{rop}; $self->{rop} = $tmp;
  246   return $self;
  247 }
  248 
  249 #
  250 #  Get the variables from the two operands
  251 #
  252 sub getVariables {
  253   my $self = shift;
  254   return {%{$self->{lop}->getVariables},%{$self->{rop}->getVariables}};
  255 }
  256 
  257 ##################################################
  258 #
  259 #  Generate the various output formats.
  260 #
  261 
  262 
  263 #
  264 #  Produce a string version of the BOP.
  265 #
  266 #  Parentheses are added when either:
  267 #    we are told to from our parent
  268 #    the BOP says to (fullparens)
  269 #    the BOP's precedence is lower than it's parent's, or
  270 #    the precedences are equal and either
  271 #       the associativity is right
  272 #       or we are supposed to show parens for the same precedence
  273 #
  274 sub string {
  275   my ($self,$precedence,$showparens,$position,$outerRight) = @_;
  276   my $string; my $bop = $self->{def};
  277   $position = '' unless defined($position);
  278   $showparens = '' unless defined($showparens);
  279   my $extraParens = $self->context->flag('showExtraParens');
  280   my $addparens =
  281       defined($precedence) &&
  282       ($showparens eq 'all' || (($showparens eq 'extra' || $bop->{fullparens}) && $extraParens > 1) ||
  283        $precedence > $bop->{precedence} || ($precedence == $bop->{precedence} &&
  284         ($bop->{associativity} eq 'right' || ($showparens eq 'same' && $extraParens))));
  285   $outerRight = !$addparens && ($outerRight || $position eq 'right');
  286 
  287   $string = $self->{lop}->string($bop->{precedence},$bop->{leftparens},'left',$outerRight).
  288             $bop->{string}.
  289             $self->{rop}->string($bop->{precedence},$bop->{rightparens},'right');
  290 
  291   $string = $self->addParens($string) if $addparens;
  292   return $string;
  293 }
  294 
  295 #
  296 #  Produce the TeX version of the BOP.
  297 #
  298 sub TeX {
  299   my ($self,$precedence,$showparens,$position,$outerRight) = @_;
  300   my $TeX; my $bop = $self->{def};
  301   $position = '' unless defined($position);
  302   $showparens = '' unless defined($showparens);
  303   my $extraParens = $self->context->flag('showExtraParens');
  304   my $addparens =
  305       defined($precedence) &&
  306       (($showparens eq 'all' && $extraParens > 1) || $precedence > $bop->{precedence} ||
  307       ($precedence == $bop->{precedence} &&
  308         ($bop->{associativity} eq 'right' || ($showparens eq 'same' && $extraParens))));
  309   $outerRight = !$addparens && ($outerRight || $position eq 'right');
  310 
  311   $TeX = $self->{lop}->TeX($bop->{precedence},$bop->{leftparens},'left',$outerRight).
  312          (defined($bop->{TeX}) ? $bop->{TeX} : $bop->{string}) .
  313          $self->{rop}->TeX($bop->{precedence},$bop->{rightparens},'right');
  314 
  315   $TeX = '\left('.$TeX.'\right)' if $addparens;
  316   return $TeX;
  317 }
  318 
  319 #
  320 #  Produce the perl version of the BOP.
  321 #
  322 sub perl {
  323   my $self= shift; my $parens = shift;
  324   my $bop = $self->{def}; my $perl;
  325   if ($bop->{isCommand}) {
  326     $perl =
  327       ($bop->{perl} || ref($self).'->call').
  328         '('.$self->{lop}->perl.','.$self->{rop}->perl.')';
  329   } else {
  330     $perl =
  331         $self->{lop}->perl(1).
  332   " ".($bop->{perl} || $bop->{string})." ".
  333         $self->{rop}->perl(2);
  334   }
  335   $perl = '('.$perl.')' if $parens;
  336   return $perl;
  337 }
  338 
  339 #########################################################################
  340 #
  341 #  Load the subclasses.
  342 #
  343 
  344 END {
  345   use Parser::BOP::undefined;
  346   use Parser::BOP::comma;
  347   use Parser::BOP::union;
  348   use Parser::BOP::add;
  349   use Parser::BOP::subtract;
  350   use Parser::BOP::multiply;
  351   use Parser::BOP::divide;
  352   use Parser::BOP::power;
  353   use Parser::BOP::cross;
  354   use Parser::BOP::dot;
  355   use Parser::BOP::underscore;
  356   use Parser::BOP::equality;
  357 }
  358 
  359 #########################################################################
  360 
  361 1;

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9