/[emacs]/emacs/lisp/calc/calc.el
ViewVC logotype

Diff of /emacs/lisp/calc/calc.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

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

Legend:
Removed from v.1.32  
changed lines
  Added in v.1.33

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26