40785
|
1 ;; Calculator for GNU Emacs, part I [calc-macs.el]
|
|
2 ;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
|
|
3 ;; Written by Dave Gillespie, daveg@synaptics.com.
|
|
4
|
|
5 ;; This file is part of GNU Emacs.
|
|
6
|
|
7 ;; GNU Emacs is distributed in the hope that it will be useful,
|
|
8 ;; but WITHOUT ANY WARRANTY. No author or distributor
|
|
9 ;; accepts responsibility to anyone for the consequences of using it
|
|
10 ;; or for whether it serves any particular purpose or works at all,
|
|
11 ;; unless he says so in writing. Refer to the GNU Emacs General Public
|
|
12 ;; License for full details.
|
|
13
|
|
14 ;; Everyone is granted permission to copy, modify and redistribute
|
|
15 ;; GNU Emacs, but only under the conditions described in the
|
|
16 ;; GNU Emacs General Public License. A copy of this license is
|
|
17 ;; supposed to have been given to you along with GNU Emacs so you
|
|
18 ;; can know your rights and responsibilities. It should be in a
|
|
19 ;; file named COPYING. Among other things, the copyright notice
|
|
20 ;; and this notice must be preserved on all copies.
|
|
21
|
|
22
|
|
23 (provide 'calc-macs)
|
|
24
|
|
25 (defun calc-need-macros () nil)
|
|
26
|
|
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
|
|
35 (defmacro calc-wrapper (&rest body)
|
|
36 (list 'calc-do (list 'function (append (list 'lambda ()) body)))
|
|
37 )
|
|
38
|
|
39 ;; We use "point" here to generate slightly smaller byte-code than "t".
|
|
40 (defmacro calc-slow-wrapper (&rest body)
|
|
41 (list 'calc-do (list 'function (append (list 'lambda ()) body)) (point))
|
|
42 )
|
|
43
|
|
44
|
|
45 (defmacro math-showing-full-precision (body)
|
|
46 (list 'let
|
|
47 '((calc-float-format calc-full-float-format))
|
|
48 body)
|
|
49 )
|
|
50
|
|
51
|
|
52 (defmacro math-with-extra-prec (delta &rest body)
|
|
53 (` (math-normalize
|
|
54 (let ((calc-internal-prec (+ calc-internal-prec (, delta))))
|
|
55 (,@ body))))
|
|
56 )
|
|
57
|
|
58
|
|
59 ;;; Faster in-line version zerop, normalized values only.
|
|
60 (defmacro Math-zerop (a) ; [P N]
|
|
61 (` (if (consp (, a))
|
|
62 (and (not (memq (car (, a)) '(bigpos bigneg)))
|
|
63 (if (eq (car (, a)) 'float)
|
|
64 (eq (nth 1 (, a)) 0)
|
|
65 (math-zerop (, a))))
|
|
66 (eq (, a) 0)))
|
|
67 )
|
|
68
|
|
69 (defmacro Math-integer-negp (a)
|
|
70 (` (if (consp (, a))
|
|
71 (eq (car (, a)) 'bigneg)
|
|
72 (< (, a) 0)))
|
|
73 )
|
|
74
|
|
75 (defmacro Math-integer-posp (a)
|
|
76 (` (if (consp (, a))
|
|
77 (eq (car (, a)) 'bigpos)
|
|
78 (> (, a) 0)))
|
|
79 )
|
|
80
|
|
81
|
|
82 (defmacro Math-negp (a)
|
|
83 (` (if (consp (, a))
|
|
84 (or (eq (car (, a)) 'bigneg)
|
|
85 (and (not (eq (car (, a)) 'bigpos))
|
|
86 (if (memq (car (, a)) '(frac float))
|
|
87 (Math-integer-negp (nth 1 (, a)))
|
|
88 (math-negp (, a)))))
|
|
89 (< (, a) 0)))
|
|
90 )
|
|
91
|
|
92
|
|
93 (defmacro Math-looks-negp (a) ; [P x] [Public]
|
|
94 (` (or (Math-negp (, a))
|
|
95 (and (consp (, a)) (or (eq (car (, a)) 'neg)
|
|
96 (and (memq (car (, a)) '(* /))
|
|
97 (or (math-looks-negp (nth 1 (, a)))
|
|
98 (math-looks-negp (nth 2 (, a)))))))))
|
|
99 )
|
|
100
|
|
101
|
|
102 (defmacro 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
|
|
112
|
|
113 (defmacro Math-integerp (a)
|
|
114 (` (or (not (consp (, a)))
|
|
115 (memq (car (, a)) '(bigpos bigneg))))
|
|
116 )
|
|
117
|
|
118
|
|
119 (defmacro Math-natnump (a)
|
|
120 (` (if (consp (, a))
|
|
121 (eq (car (, a)) 'bigpos)
|
|
122 (>= (, a) 0)))
|
|
123 )
|
|
124
|
|
125 (defmacro Math-ratp (a)
|
|
126 (` (or (not (consp (, a)))
|
|
127 (memq (car (, a)) '(bigpos bigneg frac))))
|
|
128 )
|
|
129
|
|
130 (defmacro Math-realp (a)
|
|
131 (` (or (not (consp (, a)))
|
|
132 (memq (car (, a)) '(bigpos bigneg frac float))))
|
|
133 )
|
|
134
|
|
135 (defmacro Math-anglep (a)
|
|
136 (` (or (not (consp (, a)))
|
|
137 (memq (car (, a)) '(bigpos bigneg frac float hms))))
|
|
138 )
|
|
139
|
|
140 (defmacro Math-numberp (a)
|
|
141 (` (or (not (consp (, a)))
|
|
142 (memq (car (, a)) '(bigpos bigneg frac float cplx polar))))
|
|
143 )
|
|
144
|
|
145 (defmacro Math-scalarp (a)
|
|
146 (` (or (not (consp (, a)))
|
|
147 (memq (car (, a)) '(bigpos bigneg frac float cplx polar hms))))
|
|
148 )
|
|
149
|
|
150 (defmacro Math-vectorp (a)
|
|
151 (` (and (consp (, a)) (eq (car (, a)) 'vec)))
|
|
152 )
|
|
153
|
|
154 (defmacro Math-messy-integerp (a)
|
|
155 (` (and (consp (, a))
|
|
156 (eq (car (, a)) 'float)
|
|
157 (>= (nth 2 (, a)) 0)))
|
|
158 )
|
|
159
|
|
160 (defmacro Math-objectp (a) ; [Public]
|
|
161 (` (or (not (consp (, a)))
|
|
162 (memq (car (, a))
|
|
163 '(bigpos bigneg frac float cplx polar hms date sdev intv mod))))
|
|
164 )
|
|
165
|
|
166 (defmacro Math-objvecp (a) ; [Public]
|
|
167 (` (or (not (consp (, a)))
|
|
168 (memq (car (, a))
|
|
169 '(bigpos bigneg frac float cplx polar hms date
|
|
170 sdev intv mod vec))))
|
|
171 )
|
|
172
|
|
173
|
|
174 ;;; Compute the negative of A. [O O; o o] [Public]
|
|
175 (defmacro Math-integer-neg (a)
|
|
176 (` (if (consp (, a))
|
|
177 (if (eq (car (, a)) 'bigpos)
|
|
178 (cons 'bigneg (cdr (, a)))
|
|
179 (cons 'bigpos (cdr (, a))))
|
|
180 (- (, a))))
|
|
181 )
|
|
182
|
|
183
|
|
184 (defmacro Math-equal (a b)
|
|
185 (` (= (math-compare (, a) (, b)) 0))
|
|
186 )
|
|
187
|
|
188 (defmacro Math-lessp (a b)
|
|
189 (` (= (math-compare (, a) (, b)) -1))
|
|
190 )
|
|
191
|
|
192
|
|
193 (defmacro math-working (msg arg) ; [Public]
|
|
194 (` (if (eq calc-display-working-message 'lots)
|
|
195 (math-do-working (, msg) (, arg))))
|
|
196 )
|
|
197
|
|
198
|
|
199 (defmacro calc-with-default-simplification (body)
|
|
200 (list 'let
|
|
201 '((calc-simplify-mode (and (not (memq calc-simplify-mode '(none num)))
|
|
202 calc-simplify-mode)))
|
|
203 body)
|
|
204 )
|
|
205
|
|
206
|
|
207 (defmacro Math-primp (a)
|
|
208 (` (or (not (consp (, a)))
|
|
209 (memq (car (, a)) '(bigpos bigneg frac float cplx polar
|
|
210 hms date mod var))))
|
|
211 )
|
|
212
|
|
213
|
|
214 (defmacro calc-with-trail-buffer (&rest body)
|
|
215 (` (let ((save-buf (current-buffer))
|
|
216 (calc-command-flags nil))
|
|
217 (unwind-protect
|
|
218 (, (append '(progn
|
|
219 (set-buffer (calc-trail-display t))
|
|
220 (goto-char calc-trail-pointer))
|
|
221 body))
|
|
222 (set-buffer save-buf))))
|
|
223 )
|
|
224
|
|
225
|
|
226 (defmacro Math-num-integerp (a)
|
|
227 (` (or (not (consp (, a)))
|
|
228 (memq (car (, a)) '(bigpos bigneg))
|
|
229 (and (eq (car (, a)) 'float)
|
|
230 (>= (nth 2 (, a)) 0))))
|
|
231 )
|
|
232
|
|
233
|
|
234 (defmacro Math-bignum-test (a) ; [B N; B s; b b]
|
|
235 (` (if (consp (, a))
|
|
236 (, a)
|
|
237 (math-bignum (, a))))
|
|
238 )
|
|
239
|
|
240
|
|
241 (defmacro Math-equal-int (a b)
|
|
242 (` (or (eq (, a) (, b))
|
|
243 (and (consp (, a))
|
|
244 (eq (car (, a)) 'float)
|
|
245 (eq (nth 1 (, a)) (, b))
|
|
246 (= (nth 2 (, a)) 0))))
|
|
247 )
|
|
248
|
|
249 (defmacro Math-natnum-lessp (a b)
|
|
250 (` (if (consp (, a))
|
|
251 (and (consp (, b))
|
|
252 (= (math-compare-bignum (cdr (, a)) (cdr (, b))) -1))
|
|
253 (or (consp (, b))
|
|
254 (< (, a) (, b)))))
|
|
255 )
|
|
256
|
|
257
|
|
258 (defmacro math-format-radix-digit (a) ; [X D]
|
|
259 (` (aref math-radix-digits (, a)))
|
|
260 )
|
|
261
|
|
262
|