Mercurial > emacs
comparison lisp/calc/calc.el @ 58103:5fb84c291168
(math-normalize-a): New variable.
(math-normalize): Use declared variable math-normalize-a.
| author | Jay Belanger <jay.p.belanger@gmail.com> |
|---|---|
| date | Tue, 09 Nov 2004 20:30:10 +0000 |
| parents | 3f48c4fde605 |
| children | 4a905282edbb cb7f41387eb3 |
comparison
equal
deleted
inserted
replaced
| 58102:57dc7bb5ee57 | 58103:5fb84c291168 |
|---|---|
| 2230 ;;; [This notation has been neglected in many recent routines.] | 2230 ;;; [This notation has been neglected in many recent routines.] |
| 2231 | 2231 |
| 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) |
| 2294 (progn | 2304 (progn |
| 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 |
| 2346 ;;; True if A is a floating-point real or complex number. [P x] [Public] | 2359 ;;; True if A is a floating-point real or complex number. [P x] [Public] |
| 2347 (defun math-floatp (a) | 2360 (defun math-floatp (a) |