diff options
| author | Jay Belanger | 2004-11-09 20:30:10 +0000 |
|---|---|---|
| committer | Jay Belanger | 2004-11-09 20:30:10 +0000 |
| commit | dc78141338626ca255d34b58f0ec035c4a0d22c3 (patch) | |
| tree | 1f98e65e6423b2496a0764474435f301bcb7eba9 | |
| parent | 722401eb1289ca370b82a229b46819bd7e275222 (diff) | |
| download | emacs-dc78141338626ca255d34b58f0ec035c4a0d22c3.tar.gz emacs-dc78141338626ca255d34b58f0ec035c4a0d22c3.zip | |
(math-normalize-a): New variable.
(math-normalize): Use declared variable math-normalize-a.
| -rw-r--r-- | lisp/calc/calc.el | 123 |
1 files changed, 68 insertions, 55 deletions
diff --git a/lisp/calc/calc.el b/lisp/calc/calc.el index 75e6d534e4e..6480b1960a5 100644 --- a/lisp/calc/calc.el +++ b/lisp/calc/calc.el | |||
| @@ -2232,62 +2232,72 @@ See calc-keypad for details." | |||
| 2232 | (defvar math-eval-rules-cache) | 2232 | (defvar math-eval-rules-cache) |
| 2233 | (defvar math-eval-rules-cache-other) | 2233 | (defvar math-eval-rules-cache-other) |
| 2234 | ;;; Reduce an object to canonical (normalized) form. [O o; Z Z] [Public] | 2234 | ;;; Reduce an object to canonical (normalized) form. [O o; Z Z] [Public] |
| 2235 | (defun math-normalize (a) | 2235 | |
| 2236 | (defvar math-normalize-a) | ||
| 2237 | (defun math-normalize (math-normalize-a) | ||
| 2236 | (cond | 2238 | (cond |
| 2237 | ((not (consp a)) | 2239 | ((not (consp math-normalize-a)) |
| 2238 | (if (integerp a) | 2240 | (if (integerp math-normalize-a) |
| 2239 | (if (or (>= a 1000000) (<= a -1000000)) | 2241 | (if (or (>= math-normalize-a 1000000) (<= math-normalize-a -1000000)) |
| 2240 | (math-bignum a) | 2242 | (math-bignum math-normalize-a) |
| 2241 | a) | 2243 | math-normalize-a) |
| 2242 | a)) | 2244 | math-normalize-a)) |
| 2243 | ((eq (car a) 'bigpos) | 2245 | ((eq (car math-normalize-a) 'bigpos) |
| 2244 | (if (eq (nth (1- (length a)) a) 0) | 2246 | (if (eq (nth (1- (length math-normalize-a)) math-normalize-a) 0) |
| 2245 | (let* ((last (setq a (copy-sequence a))) (digs a)) | 2247 | (let* ((last (setq math-normalize-a |
| 2248 | (copy-sequence math-normalize-a))) (digs math-normalize-a)) | ||
| 2246 | (while (setq digs (cdr digs)) | 2249 | (while (setq digs (cdr digs)) |
| 2247 | (or (eq (car digs) 0) (setq last digs))) | 2250 | (or (eq (car digs) 0) (setq last digs))) |
| 2248 | (setcdr last nil))) | 2251 | (setcdr last nil))) |
| 2249 | (if (cdr (cdr (cdr a))) | 2252 | (if (cdr (cdr (cdr math-normalize-a))) |
| 2250 | a | 2253 | math-normalize-a |
| 2251 | (cond | 2254 | (cond |
| 2252 | ((cdr (cdr a)) (+ (nth 1 a) (* (nth 2 a) 1000))) | 2255 | ((cdr (cdr math-normalize-a)) (+ (nth 1 math-normalize-a) |
| 2253 | ((cdr a) (nth 1 a)) | 2256 | (* (nth 2 math-normalize-a) 1000))) |
| 2257 | ((cdr math-normalize-a) (nth 1 math-normalize-a)) | ||
| 2254 | (t 0)))) | 2258 | (t 0)))) |
| 2255 | ((eq (car a) 'bigneg) | 2259 | ((eq (car math-normalize-a) 'bigneg) |
| 2256 | (if (eq (nth (1- (length a)) a) 0) | 2260 | (if (eq (nth (1- (length math-normalize-a)) math-normalize-a) 0) |
| 2257 | (let* ((last (setq a (copy-sequence a))) (digs a)) | 2261 | (let* ((last (setq math-normalize-a (copy-sequence math-normalize-a))) |
| 2262 | (digs math-normalize-a)) | ||
| 2258 | (while (setq digs (cdr digs)) | 2263 | (while (setq digs (cdr digs)) |
| 2259 | (or (eq (car digs) 0) (setq last digs))) | 2264 | (or (eq (car digs) 0) (setq last digs))) |
| 2260 | (setcdr last nil))) | 2265 | (setcdr last nil))) |
| 2261 | (if (cdr (cdr (cdr a))) | 2266 | (if (cdr (cdr (cdr math-normalize-a))) |
| 2262 | a | 2267 | math-normalize-a |
| 2263 | (cond | 2268 | (cond |
| 2264 | ((cdr (cdr a)) (- (+ (nth 1 a) (* (nth 2 a) 1000)))) | 2269 | ((cdr (cdr math-normalize-a)) (- (+ (nth 1 math-normalize-a) |
| 2265 | ((cdr a) (- (nth 1 a))) | 2270 | (* (nth 2 math-normalize-a) 1000)))) |
| 2271 | ((cdr math-normalize-a) (- (nth 1 math-normalize-a))) | ||
| 2266 | (t 0)))) | 2272 | (t 0)))) |
| 2267 | ((eq (car a) 'float) | 2273 | ((eq (car math-normalize-a) 'float) |
| 2268 | (math-make-float (math-normalize (nth 1 a)) (nth 2 a))) | 2274 | (math-make-float (math-normalize (nth 1 math-normalize-a)) |
| 2269 | ((or (memq (car a) '(frac cplx polar hms date mod sdev intv vec var quote | 2275 | (nth 2 math-normalize-a))) |
| 2270 | special-const calcFunc-if calcFunc-lambda | 2276 | ((or (memq (car math-normalize-a) |
| 2271 | calcFunc-quote calcFunc-condition | 2277 | '(frac cplx polar hms date mod sdev intv vec var quote |
| 2272 | calcFunc-evalto)) | 2278 | special-const calcFunc-if calcFunc-lambda |
| 2273 | (integerp (car a)) | 2279 | calcFunc-quote calcFunc-condition |
| 2274 | (and (consp (car a)) (not (eq (car (car a)) 'lambda)))) | 2280 | calcFunc-evalto)) |
| 2281 | (integerp (car math-normalize-a)) | ||
| 2282 | (and (consp (car math-normalize-a)) | ||
| 2283 | (not (eq (car (car math-normalize-a)) 'lambda)))) | ||
| 2275 | (calc-extensions) | 2284 | (calc-extensions) |
| 2276 | (math-normalize-fancy a)) | 2285 | (math-normalize-fancy math-normalize-a)) |
| 2277 | (t | 2286 | (t |
| 2278 | (or (and calc-simplify-mode | 2287 | (or (and calc-simplify-mode |
| 2279 | (calc-extensions) | 2288 | (calc-extensions) |
| 2280 | (math-normalize-nonstandard)) | 2289 | (math-normalize-nonstandard)) |
| 2281 | (let ((args (mapcar 'math-normalize (cdr a)))) | 2290 | (let ((args (mapcar 'math-normalize (cdr math-normalize-a)))) |
| 2282 | (or (condition-case err | 2291 | (or (condition-case err |
| 2283 | (let ((func (assq (car a) '( ( + . math-add ) | 2292 | (let ((func |
| 2284 | ( - . math-sub ) | 2293 | (assq (car math-normalize-a) '( ( + . math-add ) |
| 2285 | ( * . math-mul ) | 2294 | ( - . math-sub ) |
| 2286 | ( / . math-div ) | 2295 | ( * . math-mul ) |
| 2287 | ( % . math-mod ) | 2296 | ( / . math-div ) |
| 2288 | ( ^ . math-pow ) | 2297 | ( % . math-mod ) |
| 2289 | ( neg . math-neg ) | 2298 | ( ^ . math-pow ) |
| 2290 | ( | . math-concat ) )))) | 2299 | ( neg . math-neg ) |
| 2300 | ( | . math-concat ) )))) | ||
| 2291 | (or (and var-EvalRules | 2301 | (or (and var-EvalRules |
| 2292 | (progn | 2302 | (progn |
| 2293 | (or (eq var-EvalRules math-eval-rules-cache-tag) | 2303 | (or (eq var-EvalRules math-eval-rules-cache-tag) |
| @@ -2295,51 +2305,54 @@ See calc-keypad for details." | |||
| 2295 | (calc-extensions) | 2305 | (calc-extensions) |
| 2296 | (math-recompile-eval-rules))) | 2306 | (math-recompile-eval-rules))) |
| 2297 | (and (or math-eval-rules-cache-other | 2307 | (and (or math-eval-rules-cache-other |
| 2298 | (assq (car a) math-eval-rules-cache)) | 2308 | (assq (car math-normalize-a) |
| 2309 | math-eval-rules-cache)) | ||
| 2299 | (math-apply-rewrites | 2310 | (math-apply-rewrites |
| 2300 | (cons (car a) args) | 2311 | (cons (car math-normalize-a) args) |
| 2301 | (cdr math-eval-rules-cache) | 2312 | (cdr math-eval-rules-cache) |
| 2302 | nil math-eval-rules-cache)))) | 2313 | nil math-eval-rules-cache)))) |
| 2303 | (if func | 2314 | (if func |
| 2304 | (apply (cdr func) args) | 2315 | (apply (cdr func) args) |
| 2305 | (and (or (consp (car a)) | 2316 | (and (or (consp (car math-normalize-a)) |
| 2306 | (fboundp (car a)) | 2317 | (fboundp (car math-normalize-a)) |
| 2307 | (and (not calc-extensions-loaded) | 2318 | (and (not calc-extensions-loaded) |
| 2308 | (calc-extensions) | 2319 | (calc-extensions) |
| 2309 | (fboundp (car a)))) | 2320 | (fboundp (car math-normalize-a)))) |
| 2310 | (apply (car a) args))))) | 2321 | (apply (car math-normalize-a) args))))) |
| 2311 | (wrong-number-of-arguments | 2322 | (wrong-number-of-arguments |
| 2312 | (calc-record-why "*Wrong number of arguments" | 2323 | (calc-record-why "*Wrong number of arguments" |
| 2313 | (cons (car a) args)) | 2324 | (cons (car math-normalize-a) args)) |
| 2314 | nil) | 2325 | nil) |
| 2315 | (wrong-type-argument | 2326 | (wrong-type-argument |
| 2316 | (or calc-next-why (calc-record-why "Wrong type of argument" | 2327 | (or calc-next-why |
| 2317 | (cons (car a) args))) | 2328 | (calc-record-why "Wrong type of argument" |
| 2329 | (cons (car math-normalize-a) args))) | ||
| 2318 | nil) | 2330 | nil) |
| 2319 | (args-out-of-range | 2331 | (args-out-of-range |
| 2320 | (calc-record-why "*Argument out of range" (cons (car a) args)) | 2332 | (calc-record-why "*Argument out of range" |
| 2333 | (cons (car math-normalize-a) args)) | ||
| 2321 | nil) | 2334 | nil) |
| 2322 | (inexact-result | 2335 | (inexact-result |
| 2323 | (calc-record-why "No exact representation for result" | 2336 | (calc-record-why "No exact representation for result" |
| 2324 | (cons (car a) args)) | 2337 | (cons (car math-normalize-a) args)) |
| 2325 | nil) | 2338 | nil) |
| 2326 | (math-overflow | 2339 | (math-overflow |
| 2327 | (calc-record-why "*Floating-point overflow occurred" | 2340 | (calc-record-why "*Floating-point overflow occurred" |
| 2328 | (cons (car a) args)) | 2341 | (cons (car math-normalize-a) args)) |
| 2329 | nil) | 2342 | nil) |
| 2330 | (math-underflow | 2343 | (math-underflow |
| 2331 | (calc-record-why "*Floating-point underflow occurred" | 2344 | (calc-record-why "*Floating-point underflow occurred" |
| 2332 | (cons (car a) args)) | 2345 | (cons (car math-normalize-a) args)) |
| 2333 | nil) | 2346 | nil) |
| 2334 | (void-variable | 2347 | (void-variable |
| 2335 | (if (eq (nth 1 err) 'var-EvalRules) | 2348 | (if (eq (nth 1 err) 'var-EvalRules) |
| 2336 | (progn | 2349 | (progn |
| 2337 | (setq var-EvalRules nil) | 2350 | (setq var-EvalRules nil) |
| 2338 | (math-normalize (cons (car a) args))) | 2351 | (math-normalize (cons (car math-normalize-a) args))) |
| 2339 | (calc-record-why "*Variable is void" (nth 1 err))))) | 2352 | (calc-record-why "*Variable is void" (nth 1 err))))) |
| 2340 | (if (consp (car a)) | 2353 | (if (consp (car math-normalize-a)) |
| 2341 | (math-dimension-error) | 2354 | (math-dimension-error) |
| 2342 | (cons (car a) args)))))))) | 2355 | (cons (car math-normalize-a) args)))))))) |
| 2343 | 2356 | ||
| 2344 | 2357 | ||
| 2345 | 2358 | ||