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

View of /trunk/pg/lib/Parser/Function.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, 2 months ago) by dpvc
File size: 9387 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 function calls
    4 #
    5 
    6 package Parser::Function;
    7 use strict;
    8 our @ISA = qw(Parser::Item);
    9 
   10 $Parser::class->{Function} = 'Parser::Function';
   11 
   12 sub new {
   13   my $self = shift; my $class = ref($self) || $self;
   14   my $equation = shift; my $context = $equation->{context};
   15   my ($name,$params,$constant,$ref) = @_;
   16   my $def = $context->{functions}{$name};
   17   $name = $def->{alias}, $def = $context->{functions}{$name} if defined $def->{alias};
   18   my $fn = bless {
   19     name => $name, params => $params,
   20     def => $def, ref => $ref, equation => $equation,
   21   }, $def->{class};
   22   $fn->weaken;
   23   $fn->{isConstant} = $constant;
   24   $fn->_check;
   25   return $fn->Item("Value")->new($equation,[$fn->eval])
   26     if $constant && $context->flag('reduceConstantFunctions');
   27   $fn->{isConstant} = 0;
   28   return $fn;
   29 }
   30 
   31 #
   32 #  Stub to check if arguments are OK.
   33 #  (Implemented in sub-classes.)
   34 #
   35 sub _check {}
   36 
   37 ##################################################
   38 
   39 #
   40 #  Evaluate all the arguments and then perform the function
   41 #
   42 sub eval {
   43   my $self = shift; my @params = ();
   44   foreach my $x (@{$self->{params}}) {push(@params,$x->eval)}
   45   my $result = eval {$self->_eval(@params)};
   46   return $result unless $@;
   47   $self->Error("Can't take %s of %s",$self->{name},join(',',@params));
   48 }
   49 #
   50 #  Stub for sub-classes
   51 #
   52 sub _eval {shift; return @_}
   53 
   54 #
   55 #  Reduce all the arguments and compute the function if they are
   56 #    all constant.
   57 #  Otherwise, let the sub-classes reduce it.
   58 #
   59 sub reduce {
   60   my $self = shift;
   61   my $constant = 1;
   62   foreach my $x (@{$self->{params}})
   63     {$x = $x->reduce; $constant = 0 unless $x->{isConstant}}
   64   return $self->Item("Value")->new($self->{equation},[$self->eval]) if $constant;
   65   $self->_reduce;
   66 }
   67 #
   68 #  Stub for sub-classes.
   69 #
   70 sub _reduce {shift}
   71 
   72 #
   73 #  Substitute in each argument.
   74 #
   75 sub substitute {
   76   my $self = shift;
   77   my @params = (); my $constant = 1;
   78   my $equation = $self->{equation}; my $context = $equation->{context};
   79   foreach my $x (@{$self->{params}})
   80     {$x = $x->substitute; $constant = 0 unless $x->{isConstant}}
   81   return $self->Item("Value")->new($equation,[$self->eval])
   82     if $constant && $context->flag('reduceConstantFunctions');
   83   $self->{isConstant} = 0;
   84   return $self;
   85 }
   86 
   87 #
   88 #  Copy the arguments as well as the function object
   89 #
   90 sub copy {
   91   my $self = shift; my $equation = shift;
   92   my $new = $self->SUPER::copy($equation);
   93   $new->{params} = [];
   94   foreach my $x (@{$self->{params}}) {push(@{$new->{params}},$x->copy($equation))}
   95   return $new;
   96 }
   97 
   98 #
   99 #  Create a new formula if the function's arguments are formulas
  100 #  Otherwise evaluate the function call.
  101 #
  102 #  (This is used to "overload" function calls so that they will
  103 #   work in Value.pm to produce formulas when called on formulas.)
  104 #
  105 sub call {
  106   my $self = shift; my $name = shift;
  107   my $context = Parser::Context->current;
  108   my $fn = $context->{functions}{$name};
  109   Value::Error("No definition for function '%s'",$name) unless defined($fn);
  110   my $isFormula = 0;
  111   foreach my $x (@_) {return $self->formula($name,@_) if Value::isFormula($x)}
  112   my $class = $fn->{class};
  113   my $result = eval {$class->_call($name,@_)};
  114   return $result unless $@;
  115   Value::Error($context->{error}{message}) if $context->{error}{message};
  116   Value::Error("Can't take %s of %s",$name,join(',',@_));
  117 }
  118 #
  119 #  Stub for sub-classes.
  120 #  (Default is return the argument)
  121 #
  122 sub _call {shift; shift; shift}
  123 
  124 #
  125 #  Create a formula that consists of a function call on the
  126 #    given arguments.  They are converted to formulas as well.
  127 #
  128 sub formula {
  129   my $self = shift; my $name = shift;
  130   my $formula = $self->Package("Formula")->blank($self->context);
  131   my @args = Value::toFormula($formula,@_);
  132   $formula->{tree} = $formula->Item("Function")->new($formula,$name,[@args]);
  133   return $formula;
  134 }
  135 
  136 ##################################################
  137 #
  138 #  Service routines for checking the arguments
  139 #
  140 
  141 #
  142 #  Check that the function has a single numeric argument
  143 #    and check if it is allowed to be complex.
  144 #
  145 sub checkNumeric {
  146   my $self = shift;
  147   return if ($self->checkArgCount(1));
  148   my $arg = $self->{params}->[0];
  149   if ($arg->isComplex) {
  150     if (!$self->{def}{nocomplex} || $self->context->flag("allowBadFunctionInputs"))
  151       {$self->{type} = $Value::Type{complex}}
  152     else
  153       {$self->Error("Function '%s' doesn't accept Complex inputs",$self->{name})}
  154   } elsif ($arg->isNumber || $self->context->flag("allowBadFunctionInputs")) {
  155     $self->{type} = $Value::Type{number};
  156   } else {$self->Error("The input for '%s' must be a number",$self->{name})}
  157 }
  158 
  159 #
  160 #  Error if the argument is not a single vector
  161 #
  162 sub checkVector {
  163   my $self = shift;
  164   return if ($self->checkArgCount(1));
  165   if ($self->{params}->[0]->type =~ m/Point|Vector/ || $self->context->flag("allowBadFunctionInputs")) {
  166     $self->{type} = $Value::Type{number};
  167   } else {$self->Error("Function '%s' requires a Vector input",$self->{name})}
  168 }
  169 
  170 #
  171 #  Error if the argument isn't a single complex number
  172 #    and return a real.
  173 #
  174 sub checkReal {
  175   my $self = shift;
  176   return if ($self->checkArgCount(1));
  177   if ($self->{params}->[0]->isNumber || $self->context->flag("allowBadFunctionInputs")) {
  178     $self->{type} = $Value::Type{number};
  179   } else {$self->Error("Function '%s' requires a Complex input",$self->{name})}
  180 }
  181 
  182 #
  183 #  Error if the argument isn't a singe complex number
  184 #    and return a complex.
  185 #
  186 sub checkComplex {
  187   my $self = shift;
  188   return if ($self->checkArgCount(1));
  189   if ($self->{params}->[0]->isNumber || $self->context->flag("allowBadFunctionInputs")) {
  190     $self->{type} = $Value::Type{complex};
  191   } else {$self->Error("Function '%s' requires a Complex input",$self->{name})}
  192 }
  193 
  194 ##################################################
  195 #
  196 #  Service routines for arguments
  197 #
  198 
  199 #
  200 #  Check if the function's inverse can be written f^{-1}
  201 #
  202 sub checkInverse {
  203   my $equation = shift;
  204   my $fn = shift; my $op = shift; my $rop = shift;
  205   $op = $equation->{context}{operators}{$op->{name}};
  206   $fn = $equation->{context}{functions}{$fn->{name}};
  207   return ($fn->{inverse} && $op->{isInverse} && $rop->{value}->string eq "-1");
  208 }
  209 
  210 #
  211 #  Check that there are the right number of arguments
  212 #
  213 sub checkArgCount {
  214   my $self = shift; my $count = shift;
  215   return 1 if $self->context->flag("allowWrongArgCount");
  216   my $name = $self->{name};
  217   my $args = scalar(@{$self->{params}});
  218   if ($args == $count) {
  219     return 0 if ($count == 0 || $self->{params}->[0]->length > 0);
  220     $self->Error("Function '%s' requires a non-empty input list",$name);
  221   } elsif ($args < $count) {
  222     $self->Error("Function '%s' has too few inputs",$name);
  223   } else {
  224     $self->Error("Function '%s' has too many inputs",$name);
  225   }
  226   return 1;
  227 }
  228 
  229 #
  230 #  Find all the variables used in the arguments
  231 #
  232 sub getVariables {
  233   my $self = shift; my $vars = {};
  234   foreach my $x (@{$self->{params}}) {$vars = {%{$vars},%{$x->getVariables}}}
  235   return $vars;
  236 }
  237 
  238 ##################################################
  239 #
  240 #  Generate the different output formats
  241 #
  242 
  243 #
  244 #  Produce the string form.
  245 #
  246 #  Put parentheses around the funciton call if
  247 #    the function call is on the left of the parent operation
  248 #    and the precedence of the parent is higher than function call
  249 #    (e.g., powers, etc.)
  250 #
  251 sub string {
  252   my ($self,$precedence,$showparens,$position,$outerRight,$power) = @_;
  253   my $string; my $fn = $self->{equation}{context}{operators}{'fn'};
  254   my @pstr = (); my $fn_precedence = $fn->{precedence};
  255   $fn_precedence = $fn->{parenPrecedence} if $fn->{parenPrecedence};
  256   foreach my $x (@{$self->{params}}) {push(@pstr,$x->string)}
  257   $string = ($self->{def}{string} || $self->{name})."$power".'('.join(',',@pstr).')';
  258   $string = $self->addParens($string)
  259     if (defined($precedence) and $precedence > $fn_precedence) || $showparens;
  260   return $string;
  261 }
  262 
  263 #
  264 #  Produce the TeX form.
  265 #
  266 sub TeX {
  267   my ($self,$precedence,$showparens,$position,$outerRight,$power) = @_;
  268   my $TeX; my $fn = $self->{equation}{context}{operators}{'fn'};
  269   my @pstr = (); my $fn_precedence = $fn->{precedence};
  270   $fn_precedence = $fn->{parenPrecedence} if $fn->{parenPrecedence};
  271   $fn = $self->{def};
  272   my $name = '\mathop{\rm '.$self->{name}.'}';
  273   $name = $fn->{TeX} if defined($fn->{TeX});
  274   foreach my $x (@{$self->{params}}) {push(@pstr,$x->TeX)}
  275   if ($fn->{braceTeX}) {$TeX = $name.'{'.join(',',@pstr).'}'}
  276     else {$TeX = $name."$power".'\!\left('.join(',',@pstr).'\right)'}
  277   $TeX = '\left('.$TeX.'\right)'
  278     if (defined($precedence) and $precedence > $fn_precedence) or $showparens;
  279   return $TeX;
  280 }
  281 
  282 #
  283 #  Produce the perl form.
  284 #
  285 sub perl {
  286   my $self = shift; my $parens = shift;
  287   my $fn = $self->{def}; my @p = (); my $perl;
  288   foreach my $x (@{$self->{params}}) {push(@p,$x->perl)}
  289   if ($fn->{perl}) {$perl = $fn->{perl}.'('.join(',',@p).')'}
  290     else {$perl = 'Parser::Function->call('.join(',',"'$self->{name}'",@p).')'}
  291   $perl = '('.$perl.')' if $parens == 1;
  292   return $perl;
  293 }
  294 
  295 #########################################################################
  296 #
  297 #  Load the subclasses.
  298 #
  299 
  300 END {
  301   use Parser::Function::undefined;
  302   use Parser::Function::trig;
  303   use Parser::Function::hyperbolic;
  304   use Parser::Function::numeric;
  305   use Parser::Function::numeric2;
  306   use Parser::Function::complex;
  307   use Parser::Function::vector;
  308 }
  309 
  310 #########################################################################
  311 
  312 1;

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9