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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 6126 - (view) (download) (as text)

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

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9