[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 5509 - (download) (as text) (annotate)
Sat Sep 15 00:56:51 2007 UTC (12 years, 3 months ago) by dpvc
File size: 10748 byte(s)
Formula objects and Context objects contain reference loops, which
prevent them from being freed properly by perl when they are no longer
needed.  This is a source of an important memory leak in WeBWorK.  The
problem has been fixed by using Scalar::Util::weaken for these
recursive references, so these objects can be freed properly when they
go out of scope.  This should cause an improvement in the memory usage
of the httpd child processes.

    1 #########################################################################
    2 #
    3 #  Implements the base Binary Operator class
    4 #
    5 
    6 package Parser::BOP;
    7 use strict;
    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