1 |
;; Calculator for GNU Emacs, part I [calc-macs.el] |
;; Calculator for GNU Emacs, part I [calc-macs.el] |
2 |
;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. |
;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc. |
3 |
;; Written by Dave Gillespie, daveg@synaptics.com. |
;; Written by Dave Gillespie, daveg@synaptics.com. |
4 |
|
|
5 |
;; This file is part of GNU Emacs. |
;; This file is part of GNU Emacs. |
32 |
|
|
33 |
|
|
34 |
(defmacro calc-wrapper (&rest body) |
(defmacro calc-wrapper (&rest body) |
35 |
(list 'calc-do (list 'function (append (list 'lambda ()) body))) |
(list 'calc-do (list 'function (append (list 'lambda ()) body)))) |
|
) |
|
36 |
|
|
37 |
;; We use "point" here to generate slightly smaller byte-code than "t". |
;; We use "point" here to generate slightly smaller byte-code than "t". |
38 |
(defmacro calc-slow-wrapper (&rest body) |
(defmacro calc-slow-wrapper (&rest body) |
39 |
(list 'calc-do (list 'function (append (list 'lambda ()) body)) (point)) |
(list 'calc-do (list 'function (append (list 'lambda ()) body)) (point))) |
|
) |
|
40 |
|
|
41 |
|
|
42 |
(defmacro math-showing-full-precision (body) |
(defmacro math-showing-full-precision (body) |
43 |
(list 'let |
(list 'let |
44 |
'((calc-float-format calc-full-float-format)) |
'((calc-float-format calc-full-float-format)) |
45 |
body) |
body)) |
|
) |
|
46 |
|
|
47 |
|
|
48 |
(defmacro math-with-extra-prec (delta &rest body) |
(defmacro math-with-extra-prec (delta &rest body) |
49 |
(` (math-normalize |
(` (math-normalize |
50 |
(let ((calc-internal-prec (+ calc-internal-prec (, delta)))) |
(let ((calc-internal-prec (+ calc-internal-prec (, delta)))) |
51 |
(,@ body)))) |
(,@ body))))) |
|
) |
|
52 |
|
|
53 |
|
|
54 |
;;; Faster in-line version zerop, normalized values only. |
;;; Faster in-line version zerop, normalized values only. |
58 |
(if (eq (car (, a)) 'float) |
(if (eq (car (, a)) 'float) |
59 |
(eq (nth 1 (, a)) 0) |
(eq (nth 1 (, a)) 0) |
60 |
(math-zerop (, a)))) |
(math-zerop (, a)))) |
61 |
(eq (, a) 0))) |
(eq (, a) 0)))) |
|
) |
|
62 |
|
|
63 |
(defmacro Math-integer-negp (a) |
(defmacro Math-integer-negp (a) |
64 |
(` (if (consp (, a)) |
(` (if (consp (, a)) |
65 |
(eq (car (, a)) 'bigneg) |
(eq (car (, a)) 'bigneg) |
66 |
(< (, a) 0))) |
(< (, a) 0)))) |
|
) |
|
67 |
|
|
68 |
(defmacro Math-integer-posp (a) |
(defmacro Math-integer-posp (a) |
69 |
(` (if (consp (, a)) |
(` (if (consp (, a)) |
70 |
(eq (car (, a)) 'bigpos) |
(eq (car (, a)) 'bigpos) |
71 |
(> (, a) 0))) |
(> (, a) 0)))) |
|
) |
|
72 |
|
|
73 |
|
|
74 |
(defmacro Math-negp (a) |
(defmacro Math-negp (a) |
78 |
(if (memq (car (, a)) '(frac float)) |
(if (memq (car (, a)) '(frac float)) |
79 |
(Math-integer-negp (nth 1 (, a))) |
(Math-integer-negp (nth 1 (, a))) |
80 |
(math-negp (, a))))) |
(math-negp (, a))))) |
81 |
(< (, a) 0))) |
(< (, a) 0)))) |
|
) |
|
82 |
|
|
83 |
|
|
84 |
(defmacro Math-looks-negp (a) ; [P x] [Public] |
(defmacro Math-looks-negp (a) ; [P x] [Public] |
86 |
(and (consp (, a)) (or (eq (car (, a)) 'neg) |
(and (consp (, a)) (or (eq (car (, a)) 'neg) |
87 |
(and (memq (car (, a)) '(* /)) |
(and (memq (car (, a)) '(* /)) |
88 |
(or (math-looks-negp (nth 1 (, a))) |
(or (math-looks-negp (nth 1 (, a))) |
89 |
(math-looks-negp (nth 2 (, a))))))))) |
(math-looks-negp (nth 2 (, a)))))))))) |
|
) |
|
90 |
|
|
91 |
|
|
92 |
(defmacro Math-posp (a) |
(defmacro Math-posp (a) |
96 |
(if (memq (car (, a)) '(frac float)) |
(if (memq (car (, a)) '(frac float)) |
97 |
(Math-integer-posp (nth 1 (, a))) |
(Math-integer-posp (nth 1 (, a))) |
98 |
(math-posp (, a))))) |
(math-posp (, a))))) |
99 |
(> (, a) 0))) |
(> (, a) 0)))) |
|
) |
|
100 |
|
|
101 |
|
|
102 |
(defmacro Math-integerp (a) |
(defmacro Math-integerp (a) |
103 |
(` (or (not (consp (, a))) |
(` (or (not (consp (, a))) |
104 |
(memq (car (, a)) '(bigpos bigneg)))) |
(memq (car (, a)) '(bigpos bigneg))))) |
|
) |
|
105 |
|
|
106 |
|
|
107 |
(defmacro Math-natnump (a) |
(defmacro Math-natnump (a) |
108 |
(` (if (consp (, a)) |
(` (if (consp (, a)) |
109 |
(eq (car (, a)) 'bigpos) |
(eq (car (, a)) 'bigpos) |
110 |
(>= (, a) 0))) |
(>= (, a) 0)))) |
|
) |
|
111 |
|
|
112 |
(defmacro Math-ratp (a) |
(defmacro Math-ratp (a) |
113 |
(` (or (not (consp (, a))) |
(` (or (not (consp (, a))) |
114 |
(memq (car (, a)) '(bigpos bigneg frac)))) |
(memq (car (, a)) '(bigpos bigneg frac))))) |
|
) |
|
115 |
|
|
116 |
(defmacro Math-realp (a) |
(defmacro Math-realp (a) |
117 |
(` (or (not (consp (, a))) |
(` (or (not (consp (, a))) |
118 |
(memq (car (, a)) '(bigpos bigneg frac float)))) |
(memq (car (, a)) '(bigpos bigneg frac float))))) |
|
) |
|
119 |
|
|
120 |
(defmacro Math-anglep (a) |
(defmacro Math-anglep (a) |
121 |
(` (or (not (consp (, a))) |
(` (or (not (consp (, a))) |
122 |
(memq (car (, a)) '(bigpos bigneg frac float hms)))) |
(memq (car (, a)) '(bigpos bigneg frac float hms))))) |
|
) |
|
123 |
|
|
124 |
(defmacro Math-numberp (a) |
(defmacro Math-numberp (a) |
125 |
(` (or (not (consp (, a))) |
(` (or (not (consp (, a))) |
126 |
(memq (car (, a)) '(bigpos bigneg frac float cplx polar)))) |
(memq (car (, a)) '(bigpos bigneg frac float cplx polar))))) |
|
) |
|
127 |
|
|
128 |
(defmacro Math-scalarp (a) |
(defmacro Math-scalarp (a) |
129 |
(` (or (not (consp (, a))) |
(` (or (not (consp (, a))) |
130 |
(memq (car (, a)) '(bigpos bigneg frac float cplx polar hms)))) |
(memq (car (, a)) '(bigpos bigneg frac float cplx polar hms))))) |
|
) |
|
131 |
|
|
132 |
(defmacro Math-vectorp (a) |
(defmacro Math-vectorp (a) |
133 |
(` (and (consp (, a)) (eq (car (, a)) 'vec))) |
(` (and (consp (, a)) (eq (car (, a)) 'vec)))) |
|
) |
|
134 |
|
|
135 |
(defmacro Math-messy-integerp (a) |
(defmacro Math-messy-integerp (a) |
136 |
(` (and (consp (, a)) |
(` (and (consp (, a)) |
137 |
(eq (car (, a)) 'float) |
(eq (car (, a)) 'float) |
138 |
(>= (nth 2 (, a)) 0))) |
(>= (nth 2 (, a)) 0)))) |
|
) |
|
139 |
|
|
140 |
(defmacro Math-objectp (a) ; [Public] |
(defmacro Math-objectp (a) ; [Public] |
141 |
(` (or (not (consp (, a))) |
(` (or (not (consp (, a))) |
142 |
(memq (car (, a)) |
(memq (car (, a)) |
143 |
'(bigpos bigneg frac float cplx polar hms date sdev intv mod)))) |
'(bigpos bigneg frac float cplx polar hms date sdev intv mod))))) |
|
) |
|
144 |
|
|
145 |
(defmacro Math-objvecp (a) ; [Public] |
(defmacro Math-objvecp (a) ; [Public] |
146 |
(` (or (not (consp (, a))) |
(` (or (not (consp (, a))) |
147 |
(memq (car (, a)) |
(memq (car (, a)) |
148 |
'(bigpos bigneg frac float cplx polar hms date |
'(bigpos bigneg frac float cplx polar hms date |
149 |
sdev intv mod vec)))) |
sdev intv mod vec))))) |
|
) |
|
150 |
|
|
151 |
|
|
152 |
;;; Compute the negative of A. [O O; o o] [Public] |
;;; Compute the negative of A. [O O; o o] [Public] |
155 |
(if (eq (car (, a)) 'bigpos) |
(if (eq (car (, a)) 'bigpos) |
156 |
(cons 'bigneg (cdr (, a))) |
(cons 'bigneg (cdr (, a))) |
157 |
(cons 'bigpos (cdr (, a)))) |
(cons 'bigpos (cdr (, a)))) |
158 |
(- (, a)))) |
(- (, a))))) |
|
) |
|
159 |
|
|
160 |
|
|
161 |
(defmacro Math-equal (a b) |
(defmacro Math-equal (a b) |
162 |
(` (= (math-compare (, a) (, b)) 0)) |
(` (= (math-compare (, a) (, b)) 0))) |
|
) |
|
163 |
|
|
164 |
(defmacro Math-lessp (a b) |
(defmacro Math-lessp (a b) |
165 |
(` (= (math-compare (, a) (, b)) -1)) |
(` (= (math-compare (, a) (, b)) -1))) |
|
) |
|
166 |
|
|
167 |
|
|
168 |
(defmacro math-working (msg arg) ; [Public] |
(defmacro math-working (msg arg) ; [Public] |
169 |
(` (if (eq calc-display-working-message 'lots) |
(` (if (eq calc-display-working-message 'lots) |
170 |
(math-do-working (, msg) (, arg)))) |
(math-do-working (, msg) (, arg))))) |
|
) |
|
171 |
|
|
172 |
|
|
173 |
(defmacro calc-with-default-simplification (body) |
(defmacro calc-with-default-simplification (body) |
174 |
(list 'let |
(list 'let |
175 |
'((calc-simplify-mode (and (not (memq calc-simplify-mode '(none num))) |
'((calc-simplify-mode (and (not (memq calc-simplify-mode '(none num))) |
176 |
calc-simplify-mode))) |
calc-simplify-mode))) |
177 |
body) |
body)) |
|
) |
|
178 |
|
|
179 |
|
|
180 |
(defmacro Math-primp (a) |
(defmacro Math-primp (a) |
181 |
(` (or (not (consp (, a))) |
(` (or (not (consp (, a))) |
182 |
(memq (car (, a)) '(bigpos bigneg frac float cplx polar |
(memq (car (, a)) '(bigpos bigneg frac float cplx polar |
183 |
hms date mod var)))) |
hms date mod var))))) |
|
) |
|
184 |
|
|
185 |
|
|
186 |
(defmacro calc-with-trail-buffer (&rest body) |
(defmacro calc-with-trail-buffer (&rest body) |
191 |
(set-buffer (calc-trail-display t)) |
(set-buffer (calc-trail-display t)) |
192 |
(goto-char calc-trail-pointer)) |
(goto-char calc-trail-pointer)) |
193 |
body)) |
body)) |
194 |
(set-buffer save-buf)))) |
(set-buffer save-buf))))) |
|
) |
|
195 |
|
|
196 |
|
|
197 |
(defmacro Math-num-integerp (a) |
(defmacro Math-num-integerp (a) |
198 |
(` (or (not (consp (, a))) |
(` (or (not (consp (, a))) |
199 |
(memq (car (, a)) '(bigpos bigneg)) |
(memq (car (, a)) '(bigpos bigneg)) |
200 |
(and (eq (car (, a)) 'float) |
(and (eq (car (, a)) 'float) |
201 |
(>= (nth 2 (, a)) 0)))) |
(>= (nth 2 (, a)) 0))))) |
|
) |
|
202 |
|
|
203 |
|
|
204 |
(defmacro Math-bignum-test (a) ; [B N; B s; b b] |
(defmacro Math-bignum-test (a) ; [B N; B s; b b] |
205 |
(` (if (consp (, a)) |
(` (if (consp (, a)) |
206 |
(, a) |
(, a) |
207 |
(math-bignum (, a)))) |
(math-bignum (, a))))) |
|
) |
|
208 |
|
|
209 |
|
|
210 |
(defmacro Math-equal-int (a b) |
(defmacro Math-equal-int (a b) |
212 |
(and (consp (, a)) |
(and (consp (, a)) |
213 |
(eq (car (, a)) 'float) |
(eq (car (, a)) 'float) |
214 |
(eq (nth 1 (, a)) (, b)) |
(eq (nth 1 (, a)) (, b)) |
215 |
(= (nth 2 (, a)) 0)))) |
(= (nth 2 (, a)) 0))))) |
|
) |
|
216 |
|
|
217 |
(defmacro Math-natnum-lessp (a b) |
(defmacro Math-natnum-lessp (a b) |
218 |
(` (if (consp (, a)) |
(` (if (consp (, a)) |
219 |
(and (consp (, b)) |
(and (consp (, b)) |
220 |
(= (math-compare-bignum (cdr (, a)) (cdr (, b))) -1)) |
(= (math-compare-bignum (cdr (, a)) (cdr (, b))) -1)) |
221 |
(or (consp (, b)) |
(or (consp (, b)) |
222 |
(< (, a) (, b))))) |
(< (, a) (, b)))))) |
|
) |
|
223 |
|
|
224 |
|
|
225 |
(defmacro math-format-radix-digit (a) ; [X D] |
(defmacro math-format-radix-digit (a) ; [X D] |
226 |
(` (aref math-radix-digits (, a))) |
(` (aref math-radix-digits (, a)))) |
|
) |
|
227 |
|
|
228 |
|
;;; calc-macs.el ends here |
229 |
|
|