diff options
| author | Colin Walters | 2001-11-19 07:35:49 +0000 |
|---|---|---|
| committer | Colin Walters | 2001-11-19 07:35:49 +0000 |
| commit | 3e3b3c7e386d4345dfb2d7537341de49ca4a3aac (patch) | |
| tree | 54baba7bac9aead2a9f078cdb51efa426802c9ab | |
| parent | 1e253dcb115e9c30fbc190427f26e9a1da332f65 (diff) | |
| download | emacs-3e3b3c7e386d4345dfb2d7537341de49ca4a3aac.tar.gz emacs-3e3b3c7e386d4345dfb2d7537341de49ca4a3aac.zip | |
(calc-wrapper, calc-slow-wrapper)
(math-showing-full-precision, math-with-extra-prec, math-working)
(calc-with-default-simplification)
(calc-with-trail-buffer): Use backtick.
(Math-zerop, Math-integer-negp, Math-integer-posp, Math-negp)
(Math-looks-negp, Math-posp, Math-integerp, Math-natnump)
(Math-ratp, Math-realp, Math-anglep, Math-numberp, Math-scalarp)
(Math-vectorp, Math-messy-integerp, Math-objectp, Math-objvecp)
(Math-integer-neg, Math-equal, Math-lessp, Math-primp)
(Math-num-integerp, Math-bignum-test, Math-equal-int)
(Math-natnum-lessp, math-format-radix-digit): Change to `defsubst'.
(calc-record-compilation-date-macro): Deleted. Callers updated.
(math-format-radix-digit): Move to calc-bin.el.
Change all toplevel `setq' forms to `defvar' forms, and move them
before their first use. Use `when', `unless'. Remove trailing
periods from error forms. Add description and headers suggested by
Emacs Lisp coding conventions.
| -rw-r--r-- | lisp/calc/calc-macs.el | 355 |
1 files changed, 165 insertions, 190 deletions
diff --git a/lisp/calc/calc-macs.el b/lisp/calc/calc-macs.el index 12ece3a9949..0aee9556aef 100644 --- a/lisp/calc/calc-macs.el +++ b/lisp/calc/calc-macs.el | |||
| @@ -1,6 +1,9 @@ | |||
| 1 | ;; Calculator for GNU Emacs, part I [calc-macs.el] | 1 | ;;; calc-macs.el --- important macros for Calc |
| 2 | |||
| 2 | ;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc. | 3 | ;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc. |
| 3 | ;; Written by Dave Gillespie, daveg@synaptics.com. | 4 | |
| 5 | ;; Author: David Gillespie <daveg@synaptics.com> | ||
| 6 | ;; Maintainer: Colin Walters <walters@debian.org> | ||
| 4 | 7 | ||
| 5 | ;; This file is part of GNU Emacs. | 8 | ;; This file is part of GNU Emacs. |
| 6 | 9 | ||
| @@ -19,211 +22,183 @@ | |||
| 19 | ;; file named COPYING. Among other things, the copyright notice | 22 | ;; file named COPYING. Among other things, the copyright notice |
| 20 | ;; and this notice must be preserved on all copies. | 23 | ;; and this notice must be preserved on all copies. |
| 21 | 24 | ||
| 25 | ;;; Commentary: | ||
| 26 | |||
| 27 | ;;; Code: | ||
| 22 | 28 | ||
| 23 | (provide 'calc-macs) | 29 | (provide 'calc-macs) |
| 24 | 30 | ||
| 25 | (defun calc-need-macros () nil) | 31 | (defun calc-need-macros () nil) |
| 26 | 32 | ||
| 27 | |||
| 28 | (defmacro calc-record-compilation-date-macro () | ||
| 29 | `(setq calc-installed-date ,(concat (current-time-string) | ||
| 30 | " by " | ||
| 31 | (user-full-name)))) | ||
| 32 | |||
| 33 | |||
| 34 | (defmacro calc-wrapper (&rest body) | 33 | (defmacro calc-wrapper (&rest body) |
| 35 | (list 'calc-do (list 'function (append (list 'lambda ()) body)))) | 34 | `(calc-do (function (lambda () |
| 35 | ,@body)))) | ||
| 36 | 36 | ||
| 37 | ;; We use "point" here to generate slightly smaller byte-code than "t". | ||
| 38 | (defmacro calc-slow-wrapper (&rest body) | 37 | (defmacro calc-slow-wrapper (&rest body) |
| 39 | (list 'calc-do (list 'function (append (list 'lambda ()) body)) (point))) | 38 | `(calc-do |
| 40 | 39 | (function (lambda () ,@body) (point)))) | |
| 41 | |||
| 42 | (defmacro math-showing-full-precision (body) | ||
| 43 | (list 'let | ||
| 44 | '((calc-float-format calc-full-float-format)) | ||
| 45 | body)) | ||
| 46 | 40 | ||
| 41 | (defmacro math-showing-full-precision (form) | ||
| 42 | `(let ((calc-float-format calc-full-float-format)) | ||
| 43 | ,form)) | ||
| 47 | 44 | ||
| 48 | (defmacro math-with-extra-prec (delta &rest body) | 45 | (defmacro math-with-extra-prec (delta &rest body) |
| 49 | (` (math-normalize | 46 | `(math-normalize |
| 50 | (let ((calc-internal-prec (+ calc-internal-prec (, delta)))) | 47 | (let ((calc-internal-prec (+ calc-internal-prec ,delta))) |
| 51 | (,@ body))))) | 48 | ,@body))) |
| 52 | |||
| 53 | |||
| 54 | ;;; Faster in-line version zerop, normalized values only. | ||
| 55 | (defmacro Math-zerop (a) ; [P N] | ||
| 56 | (` (if (consp (, a)) | ||
| 57 | (and (not (memq (car (, a)) '(bigpos bigneg))) | ||
| 58 | (if (eq (car (, a)) 'float) | ||
| 59 | (eq (nth 1 (, a)) 0) | ||
| 60 | (math-zerop (, a)))) | ||
| 61 | (eq (, a) 0)))) | ||
| 62 | |||
| 63 | (defmacro Math-integer-negp (a) | ||
| 64 | (` (if (consp (, a)) | ||
| 65 | (eq (car (, a)) 'bigneg) | ||
| 66 | (< (, a) 0)))) | ||
| 67 | |||
| 68 | (defmacro Math-integer-posp (a) | ||
| 69 | (` (if (consp (, a)) | ||
| 70 | (eq (car (, a)) 'bigpos) | ||
| 71 | (> (, a) 0)))) | ||
| 72 | |||
| 73 | |||
| 74 | (defmacro Math-negp (a) | ||
| 75 | (` (if (consp (, a)) | ||
| 76 | (or (eq (car (, a)) 'bigneg) | ||
| 77 | (and (not (eq (car (, a)) 'bigpos)) | ||
| 78 | (if (memq (car (, a)) '(frac float)) | ||
| 79 | (Math-integer-negp (nth 1 (, a))) | ||
| 80 | (math-negp (, a))))) | ||
| 81 | (< (, a) 0)))) | ||
| 82 | |||
| 83 | |||
| 84 | (defmacro Math-looks-negp (a) ; [P x] [Public] | ||
| 85 | (` (or (Math-negp (, a)) | ||
| 86 | (and (consp (, a)) (or (eq (car (, a)) 'neg) | ||
| 87 | (and (memq (car (, a)) '(* /)) | ||
| 88 | (or (math-looks-negp (nth 1 (, a))) | ||
| 89 | (math-looks-negp (nth 2 (, a)))))))))) | ||
| 90 | |||
| 91 | |||
| 92 | (defmacro Math-posp (a) | ||
| 93 | (` (if (consp (, a)) | ||
| 94 | (or (eq (car (, a)) 'bigpos) | ||
| 95 | (and (not (eq (car (, a)) 'bigneg)) | ||
| 96 | (if (memq (car (, a)) '(frac float)) | ||
| 97 | (Math-integer-posp (nth 1 (, a))) | ||
| 98 | (math-posp (, a))))) | ||
| 99 | (> (, a) 0)))) | ||
| 100 | |||
| 101 | |||
| 102 | (defmacro Math-integerp (a) | ||
| 103 | (` (or (not (consp (, a))) | ||
| 104 | (memq (car (, a)) '(bigpos bigneg))))) | ||
| 105 | |||
| 106 | |||
| 107 | (defmacro Math-natnump (a) | ||
| 108 | (` (if (consp (, a)) | ||
| 109 | (eq (car (, a)) 'bigpos) | ||
| 110 | (>= (, a) 0)))) | ||
| 111 | |||
| 112 | (defmacro Math-ratp (a) | ||
| 113 | (` (or (not (consp (, a))) | ||
| 114 | (memq (car (, a)) '(bigpos bigneg frac))))) | ||
| 115 | |||
| 116 | (defmacro Math-realp (a) | ||
| 117 | (` (or (not (consp (, a))) | ||
| 118 | (memq (car (, a)) '(bigpos bigneg frac float))))) | ||
| 119 | |||
| 120 | (defmacro Math-anglep (a) | ||
| 121 | (` (or (not (consp (, a))) | ||
| 122 | (memq (car (, a)) '(bigpos bigneg frac float hms))))) | ||
| 123 | |||
| 124 | (defmacro Math-numberp (a) | ||
| 125 | (` (or (not (consp (, a))) | ||
| 126 | (memq (car (, a)) '(bigpos bigneg frac float cplx polar))))) | ||
| 127 | |||
| 128 | (defmacro Math-scalarp (a) | ||
| 129 | (` (or (not (consp (, a))) | ||
| 130 | (memq (car (, a)) '(bigpos bigneg frac float cplx polar hms))))) | ||
| 131 | |||
| 132 | (defmacro Math-vectorp (a) | ||
| 133 | (` (and (consp (, a)) (eq (car (, a)) 'vec)))) | ||
| 134 | |||
| 135 | (defmacro Math-messy-integerp (a) | ||
| 136 | (` (and (consp (, a)) | ||
| 137 | (eq (car (, a)) 'float) | ||
| 138 | (>= (nth 2 (, a)) 0)))) | ||
| 139 | |||
| 140 | (defmacro Math-objectp (a) ; [Public] | ||
| 141 | (` (or (not (consp (, a))) | ||
| 142 | (memq (car (, a)) | ||
| 143 | '(bigpos bigneg frac float cplx polar hms date sdev intv mod))))) | ||
| 144 | |||
| 145 | (defmacro Math-objvecp (a) ; [Public] | ||
| 146 | (` (or (not (consp (, a))) | ||
| 147 | (memq (car (, a)) | ||
| 148 | '(bigpos bigneg frac float cplx polar hms date | ||
| 149 | sdev intv mod vec))))) | ||
| 150 | |||
| 151 | |||
| 152 | ;;; Compute the negative of A. [O O; o o] [Public] | ||
| 153 | (defmacro Math-integer-neg (a) | ||
| 154 | (` (if (consp (, a)) | ||
| 155 | (if (eq (car (, a)) 'bigpos) | ||
| 156 | (cons 'bigneg (cdr (, a))) | ||
| 157 | (cons 'bigpos (cdr (, a)))) | ||
| 158 | (- (, a))))) | ||
| 159 | |||
| 160 | |||
| 161 | (defmacro Math-equal (a b) | ||
| 162 | (` (= (math-compare (, a) (, b)) 0))) | ||
| 163 | |||
| 164 | (defmacro Math-lessp (a b) | ||
| 165 | (` (= (math-compare (, a) (, b)) -1))) | ||
| 166 | |||
| 167 | |||
| 168 | (defmacro math-working (msg arg) ; [Public] | ||
| 169 | (` (if (eq calc-display-working-message 'lots) | ||
| 170 | (math-do-working (, msg) (, arg))))) | ||
| 171 | 49 | ||
| 50 | (defmacro math-working (msg arg) ; [Public] | ||
| 51 | `(if (eq calc-display-working-message 'lots) | ||
| 52 | (math-do-working ,msg ,arg))) | ||
| 172 | 53 | ||
| 173 | (defmacro calc-with-default-simplification (body) | 54 | (defmacro calc-with-default-simplification (body) |
| 174 | (list 'let | 55 | `(let ((calc-simplify-mode (and (not (memq calc-simplify-mode '(none num))) |
| 175 | '((calc-simplify-mode (and (not (memq calc-simplify-mode '(none num))) | 56 | calc-simplify-mode))) |
| 176 | calc-simplify-mode))) | 57 | ,@body)) |
| 177 | body)) | ||
| 178 | |||
| 179 | 58 | ||
| 180 | (defmacro Math-primp (a) | 59 | (defmacro calc-with-trail-buffer (&rest body) |
| 181 | (` (or (not (consp (, a))) | 60 | `(let ((save-buf (current-buffer)) |
| 182 | (memq (car (, a)) '(bigpos bigneg frac float cplx polar | 61 | (calc-command-flags nil)) |
| 183 | hms date mod var))))) | 62 | (with-current-buffer (calc-trail-display t) |
| 63 | (progn | ||
| 64 | (goto-char calc-trail-pointer) | ||
| 65 | ,@body)))) | ||
| 184 | 66 | ||
| 67 | ;;; Faster in-line version zerop, normalized values only. | ||
| 68 | (defsubst Math-zerop (a) ; [P N] | ||
| 69 | (if (consp a) | ||
| 70 | (and (not (memq (car a) '(bigpos bigneg))) | ||
| 71 | (if (eq (car a) 'float) | ||
| 72 | (eq (nth 1 a) 0) | ||
| 73 | (math-zerop a))) | ||
| 74 | (eq a 0))) | ||
| 75 | |||
| 76 | (defsubst Math-integer-negp (a) | ||
| 77 | (if (consp a) | ||
| 78 | (eq (car a) 'bigneg) | ||
| 79 | (< a 0))) | ||
| 80 | |||
| 81 | (defsubst Math-integer-posp (a) | ||
| 82 | (if (consp a) | ||
| 83 | (eq (car a) 'bigpos) | ||
| 84 | (> a 0))) | ||
| 85 | |||
| 86 | (defsubst Math-negp (a) | ||
| 87 | (if (consp a) | ||
| 88 | (or (eq (car a) 'bigneg) | ||
| 89 | (and (not (eq (car a) 'bigpos)) | ||
| 90 | (if (memq (car a) '(frac float)) | ||
| 91 | (Math-integer-negp (nth 1 a)) | ||
| 92 | (math-negp a)))) | ||
| 93 | (< a 0))) | ||
| 94 | |||
| 95 | (defsubst Math-looks-negp (a) ; [P x] [Public] | ||
| 96 | (or (Math-negp a) | ||
| 97 | (and (consp a) (or (eq (car a) 'neg) | ||
| 98 | (and (memq (car a) '(* /)) | ||
| 99 | (or (math-looks-negp (nth 1 a)) | ||
| 100 | (math-looks-negp (nth 2 a)))))))) | ||
| 101 | |||
| 102 | (defsubst Math-posp (a) | ||
| 103 | (if (consp a) | ||
| 104 | (or (eq (car a) 'bigpos) | ||
| 105 | (and (not (eq (car a) 'bigneg)) | ||
| 106 | (if (memq (car a) '(frac float)) | ||
| 107 | (Math-integer-posp (nth 1 a)) | ||
| 108 | (math-posp a)))) | ||
| 109 | (> a 0))) | ||
| 110 | |||
| 111 | (defsubst Math-integerp (a) | ||
| 112 | (or (not (consp a)) | ||
| 113 | (memq (car a) '(bigpos bigneg)))) | ||
| 114 | |||
| 115 | (defsubst Math-natnump (a) | ||
| 116 | (if (consp a) | ||
| 117 | (eq (car a) 'bigpos) | ||
| 118 | (>= a 0))) | ||
| 119 | |||
| 120 | (defsubst Math-ratp (a) | ||
| 121 | (or (not (consp a)) | ||
| 122 | (memq (car a) '(bigpos bigneg frac)))) | ||
| 123 | |||
| 124 | (defsubst Math-realp (a) | ||
| 125 | (or (not (consp a)) | ||
| 126 | (memq (car a) '(bigpos bigneg frac float)))) | ||
| 127 | |||
| 128 | (defsubst Math-anglep (a) | ||
| 129 | (or (not (consp a)) | ||
| 130 | (memq (car a) '(bigpos bigneg frac float hms)))) | ||
| 131 | |||
| 132 | (defsubst Math-numberp (a) | ||
| 133 | (or (not (consp a)) | ||
| 134 | (memq (car a) '(bigpos bigneg frac float cplx polar)))) | ||
| 135 | |||
| 136 | (defsubst Math-scalarp (a) | ||
| 137 | (or (not (consp a)) | ||
| 138 | (memq (car a) '(bigpos bigneg frac float cplx polar hms)))) | ||
| 139 | |||
| 140 | (defsubst Math-vectorp (a) | ||
| 141 | (and (consp a) (eq (car a) 'vec))) | ||
| 142 | |||
| 143 | (defsubst Math-messy-integerp (a) | ||
| 144 | (and (consp a) | ||
| 145 | (eq (car a) 'float) | ||
| 146 | (>= (nth 2 a) 0))) | ||
| 147 | |||
| 148 | (defsubst Math-objectp (a) ; [Public] | ||
| 149 | (or (not (consp a)) | ||
| 150 | (memq (car a) | ||
| 151 | '(bigpos bigneg frac float cplx polar hms date sdev intv mod)))) | ||
| 152 | |||
| 153 | (defsubst Math-objvecp (a) ; [Public] | ||
| 154 | (or (not (consp a)) | ||
| 155 | (memq (car a) | ||
| 156 | '(bigpos bigneg frac float cplx polar hms date | ||
| 157 | sdev intv mod vec)))) | ||
| 185 | 158 | ||
| 186 | (defmacro calc-with-trail-buffer (&rest body) | 159 | ;;; Compute the negative of A. [O O; o o] [Public] |
| 187 | (` (let ((save-buf (current-buffer)) | 160 | (defsubst Math-integer-neg (a) |
| 188 | (calc-command-flags nil)) | 161 | (if (consp a) |
| 189 | (unwind-protect | 162 | (if (eq (car a) 'bigpos) |
| 190 | (, (append '(progn | 163 | (cons 'bigneg (cdr a)) |
| 191 | (set-buffer (calc-trail-display t)) | 164 | (cons 'bigpos (cdr a))) |
| 192 | (goto-char calc-trail-pointer)) | 165 | (- a))) |
| 193 | body)) | 166 | |
| 194 | (set-buffer save-buf))))) | 167 | (defsubst Math-equal (a b) |
| 195 | 168 | (= (math-compare a b) 0)) | |
| 196 | 169 | ||
| 197 | (defmacro Math-num-integerp (a) | 170 | (defsubst Math-lessp (a b) |
| 198 | (` (or (not (consp (, a))) | 171 | (= (math-compare a b) -1)) |
| 199 | (memq (car (, a)) '(bigpos bigneg)) | 172 | |
| 200 | (and (eq (car (, a)) 'float) | 173 | (defsubst Math-primp (a) |
| 201 | (>= (nth 2 (, a)) 0))))) | 174 | (or (not (consp a)) |
| 202 | 175 | (memq (car a) '(bigpos bigneg frac float cplx polar | |
| 203 | 176 | hms date mod var)))) | |
| 204 | (defmacro Math-bignum-test (a) ; [B N; B s; b b] | 177 | |
| 205 | (` (if (consp (, a)) | 178 | (defsubst Math-num-integerp (a) |
| 206 | (, a) | 179 | (or (not (consp a)) |
| 207 | (math-bignum (, a))))) | 180 | (memq (car a) '(bigpos bigneg)) |
| 208 | 181 | (and (eq (car a) 'float) | |
| 209 | 182 | (>= (nth 2 a) 0)))) | |
| 210 | (defmacro Math-equal-int (a b) | 183 | |
| 211 | (` (or (eq (, a) (, b)) | 184 | (defsubst Math-bignum-test (a) ; [B N; B s; b b] |
| 212 | (and (consp (, a)) | 185 | (if (consp a) |
| 213 | (eq (car (, a)) 'float) | 186 | a |
| 214 | (eq (nth 1 (, a)) (, b)) | 187 | (math-bignum a))) |
| 215 | (= (nth 2 (, a)) 0))))) | 188 | |
| 216 | 189 | (defsubst Math-equal-int (a b) | |
| 217 | (defmacro Math-natnum-lessp (a b) | 190 | (or (eq a b) |
| 218 | (` (if (consp (, a)) | 191 | (and (consp a) |
| 219 | (and (consp (, b)) | 192 | (eq (car a) 'float) |
| 220 | (= (math-compare-bignum (cdr (, a)) (cdr (, b))) -1)) | 193 | (eq (nth 1 a) b) |
| 221 | (or (consp (, b)) | 194 | (= (nth 2 a) 0)))) |
| 222 | (< (, a) (, b)))))) | 195 | |
| 223 | 196 | (defsubst Math-natnum-lessp (a b) | |
| 224 | 197 | (if (consp a) | |
| 225 | (defmacro math-format-radix-digit (a) ; [X D] | 198 | (and (consp b) |
| 226 | (` (aref math-radix-digits (, a)))) | 199 | (= (math-compare-bignum (cdr a) (cdr b)) -1)) |
| 200 | (or (consp b) | ||
| 201 | (< a b)))) | ||
| 227 | 202 | ||
| 228 | ;;; calc-macs.el ends here | 203 | ;;; calc-macs.el ends here |
| 229 | 204 | ||