Parent Directory
| 
Revision Log
The perl method for UOP and BOP now put spaces around the operator, to prevent Perl from thinking that things like -e is a file test and *Parser::Function->call is a name reference. (Some of these had been done by hand earlier, but now the base BOP and UOP classes handle it, so we should not have problems in the future). I removed the ad hoc fixes from several other locations (Parser/Function.pm, Parser/Context/Default.pm). Also extended the operator definitions to allow operators to create function-call syntax in perl mode (for when the operator doesn't correspond to a perl operator).
1 ######################################################################### 2 # 3 # Implements the base Binary Operator class 4 # 5 6 package Parser::BOP; 7 use strict; use vars qw(@ISA); 8 @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 = $context->{parser}{List}->new($equation,[$lop->makeList], 25 $lop->{isConstant},$context->{parens}{start}) if ($lop->type eq 'Comma'); 26 $rop = $context->{parser}{List}->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->_check; 34 $BOP->{isConstant} = 1 if ($lop->{isConstant} && $rop->{isConstant}); 35 $BOP = $context->{parser}{Value}->new($equation,[$BOP->eval]) 36 if $BOP->{isConstant} && !$def->{isComma} && $context->flag('reduceConstants'); 37 return $BOP; 38 } 39 40 # 41 # Stub for checking if the BOP can operate on the given operands. 42 # (Implemented in subclasses.) 43 # 44 sub _check {} 45 46 ################################################## 47 48 # 49 # Evaluate the left and right operands and peform the 50 # required operation on the results. 51 # 52 sub eval { 53 my $self = shift; 54 $self->_eval($self->{lop}->eval,$self->{rop}->eval); 55 } 56 # 57 # Stub for sub-classes. 58 # 59 sub _eval {return $_[1]} 60 61 # 62 # Reduce the left and right operands. 63 # If they are constant (and it's not a comma), make a constant value of them. 64 # Otherwise, reduce the result. 65 # 66 sub reduce { 67 my $self = shift; my $bop = $self->{def}; 68 $self->{lop} = $self->{lop}->reduce; 69 $self->{rop} = $self->{rop}->reduce; 70 my $equation = $self->{equation}; 71 return $equation->{context}{parser}{Value}->new($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 $context->{parser}{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; 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; 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 if ($self->{lop}->isComplex || $self->{rop}->isComplex) { 152 $self->{type} = $Value::Type{complex}; 153 } else { 154 $self->{type} = $Value::Type{number}; 155 } 156 return 1; 157 } 158 159 # 160 # Check if two matrices can be multiplied. 161 # 162 sub checkMatrixSize { 163 my $self = shift; 164 my ($lm,$rm) = @_; 165 my ($ltype,$rtype) = ($lm->{entryType},$rm->{entryType}); 166 if ($ltype->{entryType}{name} eq 'Number' && 167 $rtype->{entryType}{name} eq 'Number') { 168 my ($lr,$lc) = ($lm->{length},$ltype->{length}); 169 my ($rr,$rc) = ($rm->{length},$rtype->{length}); 170 if ($lc == $rr) { 171 my $rowType = Value::Type('Matrix',$rc,$Value::Type{number},formMatrix=>1); 172 $self->{type} = Value::Type('Matrix',$lr,$rowType,formMatrix=>1); 173 } else {$self->Error("Matrices of dimensions %dx%d and %dx%d can't be multiplied",$lr,$lc,$rr,$rc)} 174 } else {$self->Error("Matrices are too deep to be multiplied")} 175 } 176 177 # 178 # Promote point operands to vectors or matrices. 179 # 180 sub promotePoints { 181 my $self = shift; my $class = shift; 182 my $ltype = $self->{lop}->typeRef; 183 my $rtype = $self->{rop}->typeRef; 184 if ($ltype->{name} eq 'Point' || 185 ($ltype->{name} eq 'Matrix' && !$ltype->{entryType}{entryType})) { 186 $ltype = {%{$ltype}, name => 'Vector'}; 187 $ltype = Value::Type($class,1,Value::Type($class,1,$ltype->{entryType})) 188 if ($ltype->{length} == 1 && $class); 189 } 190 if ($rtype->{name} eq 'Point' || 191 ($rtype->{name} eq 'Matrix' && !$rtype->{entryType}{entryType})) { 192 $rtype = {%{$rtype}, name => 'Vector'}; 193 $rtype = Value::Type($class,1,Value::Type($class,1,$rtype->{entryType})) 194 if ($rtype->{length} == 1 && $class); 195 } 196 return ($ltype,$rtype); 197 } 198 199 # 200 # Report an error if the operand types don't match. 201 # 202 sub matchError { 203 my $self = shift; 204 my ($ltype,$rtype) = @_; 205 my ($op,$ref) = ($self->{bop}); 206 if ($ltype->{name} eq $rtype->{name}) 207 {$self->Error("Operands for '%s' must be of the same length",$op)} 208 else {$self->Error("Operands for '%s' must be of the same type",$op)} 209 } 210 211 ################################################## 212 # 213 # Service routines for adjusting the values of operands. 214 # 215 216 # 217 # Return a zero, or a list of zeros of the proper length. 218 # 219 sub makeZero { 220 my $self = shift; my $op = shift; my $zero = shift; 221 return $zero if ($op->isNumber); 222 if ($zero->isNumber && $op->type =~ m/Point|Vector/) { 223 $op->{coords} = []; $op->{isZero} = 1; 224 foreach my $i (0..($op->length-1)) {push(@{$op->{coords}},$zero)} 225 return $op 226 } 227 return $self; 228 } 229 230 # 231 # Produce a negated version of a BOP. 232 # 233 sub makeNeg { 234 my $self = shift; 235 $self->{lop} = shift; $self->{rop} = shift; 236 return Parser::UOP::Neg($self); 237 } 238 239 # 240 # Reverse the operands (left <=> right). 241 # 242 sub swapOps { 243 my $self = shift; 244 my $tmp = $self->{lop}; $self->{lop} = $self->{rop}; $self->{rop} = $tmp; 245 return $self; 246 } 247 248 # 249 # Get the variables from the two operands 250 # 251 sub getVariables { 252 my $self = shift; 253 return {%{$self->{lop}->getVariables},%{$self->{rop}->getVariables}}; 254 } 255 256 ################################################## 257 # 258 # Generate the various output formats. 259 # 260 261 262 # 263 # Produce a string version of the BOP. 264 # 265 # Parentheses are added when either: 266 # we are told to from our parent 267 # the BOP says to (fullparens) 268 # the BOP's precedence is lower than it's parent's, or 269 # the precedences are equal and either 270 # the associativity is right 271 # or we are supposed to show parens for the same precedence 272 # 273 sub string { 274 my ($self,$precedence,$showparens,$position,$outerRight) = @_; 275 my $string; my $bop = $self->{def}; 276 $position = '' unless defined($position); 277 $showparens = '' unless defined($showparens); 278 my $extraParens = $self->{equation}{context}->flag('showExtraParens'); 279 my $addparens = 280 defined($precedence) && 281 ($showparens eq 'all' || (($showparens eq 'extra' || $bop->{fullparens}) && $extraParens) || 282 $precedence > $bop->{precedence} || ($precedence == $bop->{precedence} && 283 ($bop->{associativity} eq 'right' || $showparens eq 'same'))); 284 $outerRight = !$addparens && ($outerRight || $position eq 'right'); 285 286 $string = $self->{lop}->string($bop->{precedence},$bop->{leftparens},'left',$outerRight). 287 $bop->{string}. 288 $self->{rop}->string($bop->{precedence},$bop->{rightparens},'right'); 289 290 $string = $self->addParens($string) if ($addparens); 291 return $string; 292 } 293 294 # 295 # Produce the TeX version of the BOP. 296 # 297 sub TeX { 298 my ($self,$precedence,$showparens,$position,$outerRight) = @_; 299 my $TeX; my $bop = $self->{def}; 300 $position = '' unless defined($position); 301 $showparens = '' unless defined($showparens); 302 my $extraParens = $self->{equation}{context}->flag('showExtraParens'); 303 my $addparens = 304 defined($precedence) && 305 (($showparens eq 'all' && $extraParens) || $precedence > $bop->{precedence} || 306 ($precedence == $bop->{precedence} && 307 ($bop->{associativity} eq 'right' || $showparens eq 'same'))); 308 $outerRight = !$addparens && ($outerRight || $position eq 'right'); 309 310 $TeX = $self->{lop}->TeX($bop->{precedence},$bop->{leftparens},'left',$outerRight). 311 (defined($bop->{TeX}) ? $bop->{TeX} : $bop->{string}) . 312 $self->{rop}->TeX($bop->{precedence},$bop->{rightparens},'right'); 313 314 $TeX = '\left('.$TeX.'\right)' if ($addparens); 315 return $TeX; 316 } 317 318 # 319 # Produce the perl version of the BOP. 320 # 321 sub perl { 322 my $self= shift; my $parens = shift; 323 my $bop = $self->{def}; my $perl; 324 if ($bop->{isCommand}) { 325 $perl = 326 ($bop->{perl} || ref($self).'->call'). 327 '('.$self->{lop}->perl.','.$self->{rop}->perl.')'; 328 } else { 329 $perl = 330 $self->{lop}->perl(1). 331 " ".($bop->{perl} || $bop->{string})." ". 332 $self->{rop}->perl(2); 333 } 334 $perl = '('.$perl.')' if $parens; 335 return $perl; 336 } 337 338 ######################################################################### 339 # 340 # Load the subclasses. 341 # 342 343 use Parser::BOP::undefined; 344 use Parser::BOP::comma; 345 use Parser::BOP::union; 346 use Parser::BOP::add; 347 use Parser::BOP::subtract; 348 use Parser::BOP::multiply; 349 use Parser::BOP::divide; 350 use Parser::BOP::power; 351 use Parser::BOP::cross; 352 use Parser::BOP::dot; 353 use Parser::BOP::underscore; 354 use Parser::BOP::equality; 355 356 ######################################################################### 357 358 1; 359
| aubreyja at gmail dot com | ViewVC Help |
| Powered by ViewVC 1.0.9 |