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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2678 - (download) (as text) (annotate)
Mon Aug 23 23:55:37 2004 UTC (15 years, 5 months ago) by dpvc
File size: 23898 byte(s)
Modified the parser so that the classes for the various object
constructors are stored in the context table rather than hard-coded
into the parser.  That way, you can override the default classes with
your own.  This gives you even more complete control to modify the
parser.  (You had been able to replace the definitions of operators,
functions and list-like objects, but could not override the behaviour
of numbers, strings, variables, and so on.  Now you can.)

This effects most of the files, but only by changing the name of the
calls that create the various objects.

There are also a couple of other minor fixes.

    1 package Parser;
    2 my $pkg = "Parser";
    3 use strict;
    4 
    5 #
    6 #  Map class names to packages (added to Context, and
    7 #  can be overriden to customize the parser)
    8 #
    9 our %class = {Formula => 'Parser::Formula'};
   10 
   11 ##################################################
   12 #
   13 #  Parse a string and create a new Parser object
   14 #  If the string is already a parsed object then copy the parse tree
   15 #  If it is a Value, make an appropriate tree for it.
   16 #
   17 sub new {
   18   my $self = shift; my $class = ref($self) || $self;
   19   my $string = shift;
   20   $string = Value::List->new($string,@_)
   21     if scalar(@_) > 0 || ref($string) eq 'ARRAY';
   22   my $math = bless {
   23     string => undef,
   24     tokens => [], tree => undef,
   25     variables => {}, values => {},
   26     context => Parser::Context->current,
   27   }, $class;
   28   if (ref($string) =~ m/^(Parser|Value::Formula)/) {
   29     my $tree = $string; $tree = $tree->{tree} if exists $tree->{tree};
   30     $math->{tree} = $tree->copy($math);
   31   } elsif (Value::isValue($string)) {
   32     $math->{tree} = $math->{context}{parser}{Value}->new($math,$string);
   33   } else {
   34     $math->{string} = $string;
   35     $math->tokenize;
   36     $math->parse;
   37   }
   38   return $math;
   39 }
   40 
   41 sub copy {my $self = shift; $self->new($self)}
   42 
   43 ##################################################
   44 #
   45 #  Break the string into tokens based on the patterns for the various
   46 #  types of objects.
   47 #
   48 sub tokenize {
   49   my $self = shift; my $space;
   50   my $tokens = $self->{tokens}; my $string = $self->{string};
   51   my $tokenPattern = $self->{context}{pattern}{token};
   52   @{$tokens} = (); $self->{error} = 0; $self->{message} = '';
   53   $string =~ m/^\s*/gc; my $p0 = 0; my $p1;
   54   while (pos($string) < length($string)) {
   55     $p0 = pos($string);
   56     if ($string =~ m/\G$tokenPattern/gc) {
   57       $p1 = pos($string);
   58       push(@{$tokens},['str',$1,$p0,$p1,$space])   if (defined($1));
   59       push(@{$tokens},['fn',$2,$p0,$p1,$space])    if (defined($2));
   60       push(@{$tokens},['const',$3,$p0,$p1,$space]) if (defined($3));
   61       push(@{$tokens},['num',$4,$p0,$p1,$space])   if (defined($4));
   62       push(@{$tokens},['op',$5,$p0,$p1,$space])    if (defined($5));
   63       push(@{$tokens},['open',$6,$p0,$p1,$space])  if (defined($6));
   64       push(@{$tokens},['close',$7,$p0,$p1,$space]) if (defined($7));
   65       push(@{$tokens},['var',$8,$p0,$p1,$space])   if (defined($8));
   66     } else {
   67       push(@{$tokens},['error',substr($string,$p0,1),$p0,$p0+1]);
   68       $self->{error} = 1;
   69       last;
   70     }
   71     $space = ($string =~ m/\G\s+/gc);
   72   }
   73 }
   74 
   75 ##################################################
   76 #
   77 #  Parse the token list to produce the expression tree.  This does syntax checks
   78 #  and reports "compile-time" errors.
   79 #
   80 #  Start with a stack that has a single entry (an OPEN object for the expression)
   81 #  For each token, try to add that token to the tree.
   82 #  After all tokens have been finished, add a CLOSE object for the initial OPEN
   83 #    and save the complete tree
   84 #
   85 sub parse {
   86   my $self = shift;
   87   $self->{tree} = undef; $self->{error} = 0;
   88   $self->{stack} = [{type => 'open', value => 'start'}];
   89   foreach my $ref (@{$self->{tokens}}) {
   90     $self->{ref} = $ref; $self->{space} = $ref->[4];
   91     for ($ref->[0]) {
   92       /open/  and do {$self->Open($ref->[1]); last};
   93       /close/ and do {$self->Close($ref->[1],$ref); last};
   94       /op/    and do {$self->Op($ref->[1],$ref); last};
   95       /num/   and do {$self->Num($ref->[1]); last};
   96       /const/ and do {$self->Const($ref->[1]); last};
   97       /var/   and do {$self->Var($ref->[1]); last};
   98       /fn/    and do {$self->Fn($ref->[1]); last};
   99       /str/   and do {$self->Str($ref->[1]); last};
  100       /error/ and do {$self->Error("Unexpected character '$ref->[1]'",$ref); last};
  101     }
  102     return if ($self->{error});
  103   }
  104   $self->Close('start'); return if ($self->{error});
  105   $self->{tree} = $self->{stack}->[0]->{value};
  106 }
  107 
  108 
  109 #  Get the top or previous item of the stack
  110 #
  111 sub top {
  112   my $self = shift; my $i = shift || 0;
  113   return $self->{stack}->[$i-1];
  114 }
  115 sub prev {(shift)->top(-1)}
  116 
  117 #
  118 #  Push or pop the top of the stack
  119 #
  120 sub pop {pop(@{(shift)->{stack}})}
  121 sub push {push(@{(shift)->{stack}},@_)}
  122 
  123 #
  124 #  Return the type of the top item
  125 #
  126 sub state {(shift)->top->{type}}
  127 
  128 #
  129 #  Report an error at a given possition (if possible)
  130 #
  131 sub Error {
  132   my $self = shift; my $context = $self->{context};
  133   my $message = shift; my $ref = shift; my $string;
  134   if ($ref) {
  135     $message .= "; see position ".($ref->[2]+1)." of formula";
  136     $string = $self->{string};
  137     $ref = [$ref->[2],$ref->[3]];
  138   }
  139   $context->setError($message,$string,$ref);
  140   die $message . Value::getCaller();
  141 }
  142 
  143 #
  144 #  Insert an implicit multiplication
  145 #  (fix up the reference for spaces or juxtaposition)
  146 #
  147 sub ImplicitMult {
  148   my $self = shift;
  149   my $ref = $self->{ref}; my $iref = [@{$ref}];
  150   $iref->[2]--; $iref->[3] = $iref->[2]+1;
  151   $iref->[3]++ unless substr($self->{string},$iref->[2],1) eq ' ';
  152   $self->Error("Can't perform implied multiplication in this context",$iref)
  153     unless $self->{context}{operators}{' '}{class};
  154   $self->Op(' ',$iref);
  155   $self->{ref} = $ref;
  156 }
  157 
  158 #
  159 #  Push an operator onto the expression stack.
  160 #  We save the operator symbol, the precedence, etc.
  161 #
  162 sub pushOperator {
  163   my $self = shift;
  164   my ($op,$precedence,$reverse) = @_;
  165   $self->push({
  166     type => 'operator', ref => $self->{ref},
  167     name => $op, precedence => $precedence, reverse => $reverse
  168   });
  169 }
  170 
  171 #
  172 #  Push an operand onto the expression stack.
  173 #
  174 sub pushOperand {
  175   my $self = shift; my $value = shift;
  176   $self->push({type => 'operand', ref => $self->{ref}, value => $value});
  177 }
  178 
  179 ##################################################
  180 #
  181 #  Handle an operator token
  182 #
  183 #  Get the operator data from the context
  184 #  If the top of the stack is an operand
  185 #    If the operator is a left-associative unary operator
  186 #      Insert an implicit multiplication and save the operator
  187 #    Otherwise
  188 #      Complete any pending operations of higher precedence
  189 #      If the top item is still an operand
  190 #        If we have a (right associative) unary operator
  191 #          Apply it to the top operand
  192 #        Otherwise (binary operator)
  193 #          Convert the space operator to explicit multiplication
  194 #          Save the opertor on the stack
  195 #      Otherwise, (top is not an operand)
  196 #        If the operator is an explicit on or the top is a function
  197 #          Call Op again to report the error, or to apply
  198 #            the operator to the function (this happens when
  199 #            there is a function to a power, for example)
  200 #  Otherwise (top is not an operand)
  201 #    If this is a left-associative unary operator, save it on the stack
  202 #    Otherwise, if it is a left-associative operator that CAN be unary
  203 #      Save the unary version of the operator on the stack
  204 #    Otherwise, if the top item is a function
  205 #      If the operator can be applied to functions, save it on the stack
  206 #      Otherwise, report that the function is missing its inputs
  207 #    Otherwise, report the missing operand for this operator
  208 #
  209 sub Op {
  210   my $self = shift; my $name = shift;
  211   my $ref = $self->{ref} = shift;
  212   my $context = $self->{context}; my $op = $context->{operators}{$name};
  213   $op = $context->{operators}{$op->{space}} if $self->{space} && defined($op->{space});
  214   if ($self->state eq 'operand') {
  215     if ($op->{type} eq 'unary' && $op->{associativity} eq 'left') {
  216       $self->ImplicitMult();
  217       $self->pushOperator($name,$op->{precedence});
  218     } else {
  219       $self->Precedence($op->{precedence});
  220       if ($self->state eq 'operand') {
  221         if ($op->{type} eq 'unary') {
  222           my $top = $self->pop;
  223           $self->pushOperand($context->{parser}{UOP}->new($self,$name,$top->{value},$ref));
  224         } else {
  225           $name = $context->{operators}{' '}{string}
  226             if $name eq ' ' or $name eq $context->{operators}{' '}{space};
  227           $self->pushOperator($name,$op->{precedence});
  228         }
  229       } elsif ($ref || $self->state ne 'fn') {$self->Op($name,$ref)}
  230     }
  231   } else {
  232     $name = 'u'.$name, $op = $context->{operators}{$name}
  233       if ($op->{type} eq 'both' && defined $context->{operators}{'u'.$name});
  234     if ($op->{type} eq 'unary' && $op->{associativity} eq 'left') {
  235       $self->pushOperator($name,$op->{precedence});
  236     } elsif ($self->state eq 'fn') {
  237       if ($op->{leftf}) {
  238         $self->pushOperator($name,$op->{precedence},1);
  239       } else {
  240         my $top = $self->top;
  241         $self->Error("Function '$top->{name}' is missing its input(s)",$top->{ref});
  242       }
  243     } else {$self->Error("Missing operand before '$name'",$ref)}
  244   }
  245 }
  246 
  247 ##################################################
  248 #
  249 #  Handle an open parenthesis
  250 #
  251 #  If the top of the stack is an operand
  252 #    Check if the open paren is really a close paren (for when the open
  253 #      and close symbol are the same)
  254 #    Otherwise insert an implicit multiplication
  255 #  Save the open object on the stack
  256 #
  257 sub Open {
  258   my $self = shift; my $type = shift;
  259   my $paren = $self->{context}{parens}{$type};
  260   if ($self->state eq 'operand') {
  261     if ($type eq $paren->{close})
  262       {$self->Close($type,$self->{ref}); return} else {$self->ImplicitMult()}
  263   }
  264   $self->push({type => 'open', value => $type, ref => $self->{ref}});
  265 }
  266 
  267 ##################################################
  268 #
  269 #  Handle a close parenthesis
  270 #
  271 #  When the top stack object is
  272 #    An open parenthesis (that is empty):
  273 #      Get the data for the type of parentheses
  274 #      If the parentheses can be empty and the parentheses match
  275 #        Save the empty list
  276 #      Otherwise report a message appropriate to the type of parentheses
  277 #
  278 #    An operand:
  279 #      Complete any pending operations, and stop if there was an error
  280 #      If the top is no longer an operand
  281 #        Call Close to report the error and return
  282 #      Get the item before the operand (an OPEN object), and its parenthesis type
  283 #      If the parens match
  284 #        Pop the operand off the stack
  285 #        If the parens can't be removed, or if the operand is a list
  286 #          Make the operand into a list object
  287 #        Replace the paren object with the operand
  288 #        If the parentheses are used for function calls and the
  289 #          previous stack object is a function call, do the function apply
  290 #        Otherwise report an appropriate error message
  291 #
  292 #    A function:
  293 #      Report an error message about missing inputs
  294 #
  295 #    An operator:
  296 #      Report the missing operation
  297 #
  298 sub Close {
  299   my $self = shift; my $type = shift;
  300   my $ref = $self->{ref} = shift;
  301   my $parser = $self->{context}{parser};
  302   my $parens = $self->{context}{parens};
  303 
  304   for ($self->state) {
  305     /open/ and do {
  306       my $top = $self->pop; my $paren = $parens->{$top->{value}};
  307       if ($paren->{emptyOK} && $paren->{close} eq $type) {
  308         $self->pushOperand($parser->{List}->new($self,[],1,$paren))
  309       }
  310       elsif ($type eq 'start') {$self->Error("Missing close parenthesis for '$top->{value}'",$top->{ref})}
  311       elsif ($top->{value} eq 'start') {$self->Error("Extra close parenthesis '$type'",$ref)}
  312       else {$top->{ref}[3]=$ref->[3]; $self->Error("Empty parentheses",$top->{ref})}
  313       last;
  314     };
  315 
  316     /operand/ and do {
  317       $self->Precedence(0); return if ($self->{error});
  318       if ($self->state ne 'operand') {$self->Close($type,$ref); return}
  319       my $paren = $parens->{$self->prev->{value}};
  320       if ($paren->{close} eq $type) {
  321         my $top = $self->pop;
  322         if (!$paren->{removable} || ($top->{value}->type eq "Comma")) {
  323           $top = $top->{value};
  324           $top = {type => 'operand', value =>
  325             $parser->{List}->new($self,[$top->makeList],$top->{isConstant},$paren,
  326                     ($top->type eq 'Comma') ? $top->entryType : $top->typeRef,
  327                     ($type ne 'start') ? ($self->top->{value},$type) : () )};
  328         }
  329         $self->pop; $self->push($top);
  330         $self->CloseFn() if ($paren->{function} && $self->prev->{type} eq 'fn');
  331       } elsif ($paren->{formInterval} eq $type && $self->top->{value}->length == 2) {
  332         my $top = $self->pop->{value}; my $open = $self->pop->{value};
  333         $self->pushOperand(
  334            $parser->{List}->new($self,[$top->makeList],$top->{isConstant},
  335              $paren,$top->entryType,$open,$type));
  336       } else {
  337         my $prev = $self->prev;
  338         if ($type eq "start") {$self->Error("Missing close parenthesis for '$prev->{value}'",$prev->{ref})}
  339         elsif ($prev->{value} eq "start") {$self->Error("Extra close parenthesis '$type'",$ref)}
  340         else {$self->Error("Mismatched parentheses: '$prev->{value}' and '$type'",$ref)}
  341         return;
  342       }
  343       last;
  344     };
  345 
  346     /fn/ and do {
  347       my $top = $self->top;
  348       $self->Error("Function '$top->{name}' is missing its input(s)",$top->{ref});
  349       return;
  350     };
  351 
  352     /operator/ and do {
  353       my $top = $self->top(); my $name = $top->{name}; $name =~ s/^u//;
  354       $self->Error("Missing operand after '$name'",$top->{ref});
  355       return;
  356     };
  357   }
  358 }
  359 
  360 ##################################################
  361 #
  362 #  Handle any pending operations of higher precedence
  363 #
  364 #  While the top stack item is an operand:
  365 #    When the preceding item is:
  366 #      An pending operator:
  367 #        Get the precedence of the operator (use the special right-hand prrecedence
  368 #          of there is one, otherwise use the general precedence)
  369 #        Stop processing if the current operator precedence is higher
  370 #        If the stacked operator is binary or if it is reversed (for function operators)
  371 #          Stop processing if the precedence is equal and we are right associative
  372 #          If the operand for the stacked operator is a function
  373 #            If the operation is ^(-1) (for inverses)
  374 #              Push the inverse function name
  375 #            Otherwise
  376 #              Reverse the order of the stack, so that the function can be applied
  377 #                to the next operand (it will be unreversed later)
  378 #          Otherwise (not a function, so an operand)
  379 #            Get the operands and binary operator off the stack
  380 #            If it is reversed (for functions), get the order right
  381 #            Save the result of the binary operation as an operand on the stack
  382 #        Otherwise (the stack contains a unary operator)
  383 #          Get the operator and operand off the stack
  384 #          Push the result of the unary operator as an operand on the stack
  385 #
  386 #      A pending function call:
  387 #        Keep working if the precedence of the operator is higher than a function call
  388 #        Otherwise apply the function to the operator and continue
  389 #
  390 #      Anything else:
  391 #        Return (no more pending operations)
  392 #
  393 #    If there was an error, stop processing
  394 #
  395 sub Precedence {
  396   my $self = shift; my $precedence = shift;
  397   my $context = $self->{context};
  398   while ($self->state eq 'operand') {
  399     my $prev = $self->prev;
  400     for ($prev->{type}) {
  401 
  402       /operator/ and do {
  403         my $prev_prec = $context->{operators}{$prev->{name}}{rprecedence};
  404         $prev_prec = $prev->{precedence} unless $prev_prec;
  405         return if ($precedence > $prev_prec);
  406         if ($self->top(-2)->{type} eq 'operand' || $prev->{reverse}) {
  407           return if ($precedence == $prev_prec &&
  408               $context->{operators}{$prev->{name}}{associativity} eq 'right');
  409           if ($self->top(-2)->{type} eq 'fn') {
  410             my $top = $self->pop; my $op = $self->pop; my $fun = $self->pop;
  411             if (Parser::Function::checkInverse($self,$fun,$op,$top)) {
  412               $fun->{name} = $context->{functions}{$fun->{name}}{inverse};
  413               $self->push($fun);
  414             } else {$self->push($top,$op,$fun)}
  415           } else {
  416             my $rop = $self->pop; my $op = $self->pop; my $lop = $self->pop;
  417             if ($op->{reverse}) {my $tmp = $rop; $rop = $lop; $lop = $tmp}
  418             $self->pushOperand($context->{parser}{BOP}->new($self,$op->{name},
  419                  $lop->{value},$rop->{value},$op->{ref}),$op->{reverse});
  420           }
  421         } else {
  422           my $rop = $self->pop; my $op = $self->pop;
  423           $self->pushOperand($context->{parser}{UOP}->new
  424              ($self,$op->{name},$rop->{value},$op->{ref}),$op->{reverse});
  425         }
  426         last;
  427       };
  428 
  429       /fn/ and do {
  430         return if ($precedence > $context->{operators}{fn}{precedence});
  431         $self->CloseFn();
  432         last;
  433       };
  434 
  435       return;
  436 
  437     }
  438     return if ($self->{error});
  439   }
  440 }
  441 
  442 ##################################################
  443 #
  444 #  Apply a function to its parameters
  445 #
  446 #  If the operand is a list and the parens are those for function calls
  447 #    Use the list items as the parameters, otherwise use the top item
  448 #  Pop the function object, and push the result of the function call
  449 #
  450 sub CloseFn {
  451   my $self = shift; my $context = $self->{context};
  452   my $top = $self->pop->{value}; my $fn = $self->pop;
  453   my $constant = $top->{isConstant};
  454   if ($context->{parens}{$top->{open}}{function} &&
  455       $context->{parens}{$top->{open}}{close} eq $top->{close} &&
  456       !$context->{functions}{$fn->{name}}{vectorInput})
  457          {$top = $top->coords} else {$top = [$top]}
  458   $self->pushOperand($context->{parser}{Function}->new
  459      ($self,$fn->{name},$top,$constant,$fn->{ref}));
  460 }
  461 
  462 ##################################################
  463 #
  464 #  Handle a numeric token
  465 #
  466 #  Add an implicit multiplication, if needed
  467 #  Create the number object and check it
  468 #  Save the number as an operand
  469 #
  470 sub Num {
  471   my $self = shift;
  472   $self->ImplicitMult() if $self->state eq 'operand';
  473   my $num = $self->{context}{parser}{Number}->new($self,shift,$self->{ref});
  474   my $check = $self->{context}->flag('NumberCheck');
  475   &$check($num) if $check;
  476   $self->pushOperand($num);
  477 }
  478 
  479 ##################################################
  480 #
  481 #  Handle a constant token
  482 #
  483 #  Add an implicit multiplication, if needed
  484 #  Save the number as an operand
  485 #
  486 sub Const {
  487   my $self = shift; my $ref = $self->{ref}; my $name = shift;
  488   my $const = $self->{context}{constants}{$name};
  489   my $parser = $self->{context}{parser};
  490   $self->ImplicitMult() if $self->state eq 'operand';
  491   if (defined($self->{context}{variables}{$name})) {
  492     $self->pushOperand($parser->{Variable}->new($self,$name,$ref));
  493   } elsif ($const->{keepName}) {
  494     $self->pushOperand($parser->{Constant}->new($self,$name,$ref));
  495   } else {
  496     $self->pushOperand($parser->{Value}->new($self,[$const->{value}],$ref));
  497   }
  498 }
  499 
  500 ##################################################
  501 #
  502 #  Handle a variable token
  503 #
  504 #  Add an implicit multiplication, if needed
  505 #  Save the variable as an operand
  506 #
  507 sub Var {
  508   my $self = shift;
  509   $self->ImplicitMult() if $self->state eq 'operand';
  510   $self->pushOperand($self->{context}{parser}{Variable}->new($self,shift,$self->{ref}));
  511 }
  512 
  513 ##################################################
  514 #
  515 #  Handle a function token
  516 #
  517 #  Add an implicit multiplication, if needed
  518 #  Save the function object on the stack
  519 #
  520 sub Fn {
  521   my $self = shift;
  522   $self->ImplicitMult() if $self->state eq 'operand';
  523   $self->push({type => 'fn', name => shift, ref => $self->{ref}});
  524 }
  525 
  526 ##################################################
  527 #
  528 #  Handle a string constant
  529 #
  530 #  Add an implicit multiplication, if needed (will report an error)
  531 #  Save the string object on the stack
  532 #
  533 sub Str {
  534   my $self = shift;
  535   $self->ImplicitMult() if $self->state eq 'operand';
  536   $self->pushOperand($self->{context}{parser}{String}->new($self,shift,$self->{ref}));
  537 }
  538 
  539 ##################################################
  540 ##################################################
  541 #
  542 #  Evaluate the equation using the given values
  543 #
  544 sub eval {
  545   my $self = shift;
  546   $self->setValues(@_);
  547   foreach my $x (keys %{$self->{values}}) {
  548     $self->Error("The value of '$x' can't be a formula")
  549       if Value::isFormula($self->{values}{$x});
  550   }
  551   $self->{tree}->eval;
  552 }
  553 
  554 ##################################################
  555 #
  556 #  Removes redundent items (like x+-y, 0+x and 1*x, etc)
  557 #  (substituting the given values).
  558 #
  559 sub reduce {
  560   my $self = shift;
  561   $self = $self->copy($self);
  562   $self->setValues(@_);
  563   $self->{tree} = $self->{tree}->reduce;
  564   $self->{variables} = $self->{tree}->getVariables;
  565   return $self;
  566 }
  567 
  568 ##################################################
  569 #
  570 #  Substitute values for one or more variables
  571 #
  572 sub substitute {
  573   my $self = shift;
  574   $self = $self->copy($self);
  575   $self->setValues(@_);
  576   foreach my $x (keys %{$self->{values}}) {delete $self->{variables}{$x}}
  577   $self->{tree} = $self->{tree}->substitute;
  578   return $self;
  579 }
  580 
  581 ##################################################
  582 #
  583 #  Produces a printable string (substituting the given values).
  584 #
  585 sub string {
  586   my $self = shift;
  587   $self->setValues(@_);
  588   $self->{tree}->string;
  589 }
  590 
  591 ##################################################
  592 #
  593 #  Produces a TeX string (substituting the given values).
  594 #
  595 sub TeX {
  596   my $self = shift;
  597   $self->setValues(@_);
  598   $self->{tree}->TeX;
  599 }
  600 
  601 ##################################################
  602 #
  603 #  Produces a perl eval string (substituting the given values).
  604 #
  605 sub perl {
  606   my $self = shift;
  607   $self->setValues(@_);
  608   $self->{tree}->perl;
  609 }
  610 
  611 ##################################################
  612 #
  613 #  Produce a perl function
  614 #
  615 #  (Parameters specify an optional name and an array reference of
  616 #   optional variables. If the name is not included, an anonymous
  617 #   code reference is returned.  If the variables are not included,
  618 #   then the variables from the formula are used in sorted order.)
  619 #
  620 sub perlFunction {
  621   my $self = shift; my $name = shift; my $vars = shift;
  622   $vars = [sort(keys %{$self->{variables}})] unless $vars;
  623   my $n = scalar(@{$vars}); my $vnames = '';
  624   if ($n > 0) {
  625     my @v = (); foreach my $x (@{$vars}) {push(@v,'$'.$x)}
  626     $vnames = "my (".join(',',@v).") = \@_;";
  627   }
  628   my $fn = eval
  629    "package main;
  630     sub $name {
  631       die \"Wrong number of arguments".($name?" to '$name'":'')."\" if scalar(\@_) != $n;
  632       $vnames
  633       return ".$self->perl.";
  634     }";
  635   $self->Error($@) if $@;
  636   return $fn;
  637 }
  638 
  639 
  640 ##################################################
  641 #
  642 #  Sets the values of variables for evaluation purposes
  643 #
  644 sub setValues {
  645   my $self = shift; my ($value,$type);
  646   my $variables = $self->{context}{variables};
  647   $self->{values} = {@_};
  648   foreach my $x (keys %{$self->{values}}) {
  649     $self->Error("Undeclared variable '$x'") unless defined $variables->{$x};
  650     $value = Value::makeValue($self->{values}{$x});
  651     $value = Value::Formula->new($value) unless Value::isValue($value);
  652     ($value,$type) = Value::getValueType($self,$value);
  653     $self->Error("Variable '$x' should be of type $variables->{$x}{type}{name}")
  654       unless Parser::Item::typeMatch($type,$variables->{$x}{type});
  655     $self->{values}{$x} = $value;
  656   }
  657 }
  658 
  659 
  660 ##################################################
  661 ##################################################
  662 #
  663 #  Produce a vector in ijk form
  664 #
  665 sub ijk {
  666   my $self = shift;
  667   $self->{tree}->ijk;
  668 }
  669 
  670 #########################################################################
  671 #########################################################################
  672 #
  673 #  Load the sub-classes and Value.pm
  674 #
  675 
  676 use Parser::Item;
  677 use Value;
  678 use Parser::Context;
  679 use Parser::Context::Default;
  680 use Parser::Differentiation;
  681 
  682 ###########################################################################
  683 
  684 use vars qw($installed);
  685 $Parser::installed = 1;
  686 
  687 ###########################################################################
  688 ###########################################################################
  689 #
  690 #   To Do:
  691 #
  692 # handle sqrt(-1) and log of negatives (make complexes)
  693 # do division by zero and log of zero checks in compound functions
  694 # add context flags for various reduction checks
  695 # make context flag for reduction of constants
  696 # make reduce have reduce patterns as parameters
  697 # more reduce patterns
  698 # make operator strings customizable (reduce, and other places they are used)
  699 # add parens alternately as () and []?
  700 #
  701 #########################################################################
  702 
  703 1;
  704 

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9