1 |
;; Calculator for GNU Emacs, part I [calc-macs.el] |
;;; calc-macs.el --- important macros for Calc |
2 |
|
|
3 |
;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc. |
;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc. |
4 |
;; Written by Dave Gillespie, daveg@synaptics.com. |
|
5 |
|
;; Author: David Gillespie <daveg@synaptics.com> |
6 |
|
;; Maintainer: Colin Walters <walters@debian.org> |
7 |
|
|
8 |
;; This file is part of GNU Emacs. |
;; This file is part of GNU Emacs. |
9 |
|
|
22 |
;; file named COPYING. Among other things, the copyright notice |
;; file named COPYING. Among other things, the copyright notice |
23 |
;; and this notice must be preserved on all copies. |
;; and this notice must be preserved on all copies. |
24 |
|
|
25 |
|
;;; Commentary: |
26 |
|
|
27 |
|
;;; Code: |
28 |
|
|
29 |
(provide 'calc-macs) |
(provide 'calc-macs) |
30 |
|
|
31 |
(defun calc-need-macros () nil) |
(defun calc-need-macros () nil) |
32 |
|
|
|
|
|
|
(defmacro calc-record-compilation-date-macro () |
|
|
`(setq calc-installed-date ,(concat (current-time-string) |
|
|
" by " |
|
|
(user-full-name)))) |
|
|
|
|
|
|
|
33 |
(defmacro calc-wrapper (&rest body) |
(defmacro calc-wrapper (&rest body) |
34 |
(list 'calc-do (list 'function (append (list 'lambda ()) body)))) |
`(calc-do (function (lambda () |
35 |
|
,@body)))) |
36 |
|
|
|
;; We use "point" here to generate slightly smaller byte-code than "t". |
|
37 |
(defmacro calc-slow-wrapper (&rest body) |
(defmacro calc-slow-wrapper (&rest body) |
38 |
(list 'calc-do (list 'function (append (list 'lambda ()) body)) (point))) |
`(calc-do |
39 |
|
(function (lambda () ,@body) (point)))) |
|
|
|
|
(defmacro math-showing-full-precision (body) |
|
|
(list 'let |
|
|
'((calc-float-format calc-full-float-format)) |
|
|
body)) |
|
40 |
|
|
41 |
|
(defmacro math-showing-full-precision (form) |
42 |
|
`(let ((calc-float-format calc-full-float-format)) |
43 |
|
,form)) |
44 |
|
|
45 |
(defmacro math-with-extra-prec (delta &rest body) |
(defmacro math-with-extra-prec (delta &rest body) |
46 |
(` (math-normalize |
`(math-normalize |
47 |
(let ((calc-internal-prec (+ calc-internal-prec (, delta)))) |
(let ((calc-internal-prec (+ calc-internal-prec ,delta))) |
48 |
(,@ body))))) |
,@body))) |
49 |
|
|
50 |
|
(defmacro math-working (msg arg) ; [Public] |
51 |
;;; Faster in-line version zerop, normalized values only. |
`(if (eq calc-display-working-message 'lots) |
52 |
(defmacro Math-zerop (a) ; [P N] |
(math-do-working ,msg ,arg))) |
|
(` (if (consp (, a)) |
|
|
(and (not (memq (car (, a)) '(bigpos bigneg))) |
|
|
(if (eq (car (, a)) 'float) |
|
|
(eq (nth 1 (, a)) 0) |
|
|
(math-zerop (, a)))) |
|
|
(eq (, a) 0)))) |
|
|
|
|
|
(defmacro Math-integer-negp (a) |
|
|
(` (if (consp (, a)) |
|
|
(eq (car (, a)) 'bigneg) |
|
|
(< (, a) 0)))) |
|
|
|
|
|
(defmacro Math-integer-posp (a) |
|
|
(` (if (consp (, a)) |
|
|
(eq (car (, a)) 'bigpos) |
|
|
(> (, a) 0)))) |
|
|
|
|
|
|
|
|
(defmacro Math-negp (a) |
|
|
(` (if (consp (, a)) |
|
|
(or (eq (car (, a)) 'bigneg) |
|
|
(and (not (eq (car (, a)) 'bigpos)) |
|
|
(if (memq (car (, a)) '(frac float)) |
|
|
(Math-integer-negp (nth 1 (, a))) |
|
|
(math-negp (, a))))) |
|
|
(< (, a) 0)))) |
|
|
|
|
|
|
|
|
(defmacro Math-looks-negp (a) ; [P x] [Public] |
|
|
(` (or (Math-negp (, a)) |
|
|
(and (consp (, a)) (or (eq (car (, a)) 'neg) |
|
|
(and (memq (car (, a)) '(* /)) |
|
|
(or (math-looks-negp (nth 1 (, a))) |
|
|
(math-looks-negp (nth 2 (, a)))))))))) |
|
|
|
|
|
|
|
|
(defmacro Math-posp (a) |
|
|
(` (if (consp (, a)) |
|
|
(or (eq (car (, a)) 'bigpos) |
|
|
(and (not (eq (car (, a)) 'bigneg)) |
|
|
(if (memq (car (, a)) '(frac float)) |
|
|
(Math-integer-posp (nth 1 (, a))) |
|
|
(math-posp (, a))))) |
|
|
(> (, a) 0)))) |
|
|
|
|
|
|
|
|
(defmacro Math-integerp (a) |
|
|
(` (or (not (consp (, a))) |
|
|
(memq (car (, a)) '(bigpos bigneg))))) |
|
|
|
|
|
|
|
|
(defmacro Math-natnump (a) |
|
|
(` (if (consp (, a)) |
|
|
(eq (car (, a)) 'bigpos) |
|
|
(>= (, a) 0)))) |
|
|
|
|
|
(defmacro Math-ratp (a) |
|
|
(` (or (not (consp (, a))) |
|
|
(memq (car (, a)) '(bigpos bigneg frac))))) |
|
|
|
|
|
(defmacro Math-realp (a) |
|
|
(` (or (not (consp (, a))) |
|
|
(memq (car (, a)) '(bigpos bigneg frac float))))) |
|
|
|
|
|
(defmacro Math-anglep (a) |
|
|
(` (or (not (consp (, a))) |
|
|
(memq (car (, a)) '(bigpos bigneg frac float hms))))) |
|
|
|
|
|
(defmacro Math-numberp (a) |
|
|
(` (or (not (consp (, a))) |
|
|
(memq (car (, a)) '(bigpos bigneg frac float cplx polar))))) |
|
|
|
|
|
(defmacro Math-scalarp (a) |
|
|
(` (or (not (consp (, a))) |
|
|
(memq (car (, a)) '(bigpos bigneg frac float cplx polar hms))))) |
|
|
|
|
|
(defmacro Math-vectorp (a) |
|
|
(` (and (consp (, a)) (eq (car (, a)) 'vec)))) |
|
|
|
|
|
(defmacro Math-messy-integerp (a) |
|
|
(` (and (consp (, a)) |
|
|
(eq (car (, a)) 'float) |
|
|
(>= (nth 2 (, a)) 0)))) |
|
|
|
|
|
(defmacro Math-objectp (a) ; [Public] |
|
|
(` (or (not (consp (, a))) |
|
|
(memq (car (, a)) |
|
|
'(bigpos bigneg frac float cplx polar hms date sdev intv mod))))) |
|
|
|
|
|
(defmacro Math-objvecp (a) ; [Public] |
|
|
(` (or (not (consp (, a))) |
|
|
(memq (car (, a)) |
|
|
'(bigpos bigneg frac float cplx polar hms date |
|
|
sdev intv mod vec))))) |
|
|
|
|
|
|
|
|
;;; Compute the negative of A. [O O; o o] [Public] |
|
|
(defmacro Math-integer-neg (a) |
|
|
(` (if (consp (, a)) |
|
|
(if (eq (car (, a)) 'bigpos) |
|
|
(cons 'bigneg (cdr (, a))) |
|
|
(cons 'bigpos (cdr (, a)))) |
|
|
(- (, a))))) |
|
|
|
|
|
|
|
|
(defmacro Math-equal (a b) |
|
|
(` (= (math-compare (, a) (, b)) 0))) |
|
|
|
|
|
(defmacro Math-lessp (a b) |
|
|
(` (= (math-compare (, a) (, b)) -1))) |
|
|
|
|
|
|
|
|
(defmacro math-working (msg arg) ; [Public] |
|
|
(` (if (eq calc-display-working-message 'lots) |
|
|
(math-do-working (, msg) (, arg))))) |
|
|
|
|
53 |
|
|
54 |
(defmacro calc-with-default-simplification (body) |
(defmacro calc-with-default-simplification (body) |
55 |
(list 'let |
`(let ((calc-simplify-mode (and (not (memq calc-simplify-mode '(none num))) |
56 |
'((calc-simplify-mode (and (not (memq calc-simplify-mode '(none num))) |
calc-simplify-mode))) |
57 |
calc-simplify-mode))) |
,@body)) |
|
body)) |
|
|
|
|
|
|
|
|
(defmacro Math-primp (a) |
|
|
(` (or (not (consp (, a))) |
|
|
(memq (car (, a)) '(bigpos bigneg frac float cplx polar |
|
|
hms date mod var))))) |
|
|
|
|
58 |
|
|
59 |
(defmacro calc-with-trail-buffer (&rest body) |
(defmacro calc-with-trail-buffer (&rest body) |
60 |
(` (let ((save-buf (current-buffer)) |
`(let ((save-buf (current-buffer)) |
61 |
(calc-command-flags nil)) |
(calc-command-flags nil)) |
62 |
(unwind-protect |
(with-current-buffer (calc-trail-display t) |
63 |
(, (append '(progn |
(progn |
64 |
(set-buffer (calc-trail-display t)) |
(goto-char calc-trail-pointer) |
65 |
(goto-char calc-trail-pointer)) |
,@body)))) |
|
body)) |
|
|
(set-buffer save-buf))))) |
|
|
|
|
|
|
|
|
(defmacro Math-num-integerp (a) |
|
|
(` (or (not (consp (, a))) |
|
|
(memq (car (, a)) '(bigpos bigneg)) |
|
|
(and (eq (car (, a)) 'float) |
|
|
(>= (nth 2 (, a)) 0))))) |
|
|
|
|
|
|
|
|
(defmacro Math-bignum-test (a) ; [B N; B s; b b] |
|
|
(` (if (consp (, a)) |
|
|
(, a) |
|
|
(math-bignum (, a))))) |
|
|
|
|
|
|
|
|
(defmacro Math-equal-int (a b) |
|
|
(` (or (eq (, a) (, b)) |
|
|
(and (consp (, a)) |
|
|
(eq (car (, a)) 'float) |
|
|
(eq (nth 1 (, a)) (, b)) |
|
|
(= (nth 2 (, a)) 0))))) |
|
|
|
|
|
(defmacro Math-natnum-lessp (a b) |
|
|
(` (if (consp (, a)) |
|
|
(and (consp (, b)) |
|
|
(= (math-compare-bignum (cdr (, a)) (cdr (, b))) -1)) |
|
|
(or (consp (, b)) |
|
|
(< (, a) (, b)))))) |
|
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)))) |
158 |
|
|
159 |
(defmacro math-format-radix-digit (a) ; [X D] |
;;; Compute the negative of A. [O O; o o] [Public] |
160 |
(` (aref math-radix-digits (, a)))) |
(defsubst Math-integer-neg (a) |
161 |
|
(if (consp a) |
162 |
|
(if (eq (car a) 'bigpos) |
163 |
|
(cons 'bigneg (cdr a)) |
164 |
|
(cons 'bigpos (cdr a))) |
165 |
|
(- a))) |
166 |
|
|
167 |
|
(defsubst Math-equal (a b) |
168 |
|
(= (math-compare a b) 0)) |
169 |
|
|
170 |
|
(defsubst Math-lessp (a b) |
171 |
|
(= (math-compare a b) -1)) |
172 |
|
|
173 |
|
(defsubst Math-primp (a) |
174 |
|
(or (not (consp a)) |
175 |
|
(memq (car a) '(bigpos bigneg frac float cplx polar |
176 |
|
hms date mod var)))) |
177 |
|
|
178 |
|
(defsubst Math-num-integerp (a) |
179 |
|
(or (not (consp a)) |
180 |
|
(memq (car a) '(bigpos bigneg)) |
181 |
|
(and (eq (car a) 'float) |
182 |
|
(>= (nth 2 a) 0)))) |
183 |
|
|
184 |
|
(defsubst Math-bignum-test (a) ; [B N; B s; b b] |
185 |
|
(if (consp a) |
186 |
|
a |
187 |
|
(math-bignum a))) |
188 |
|
|
189 |
|
(defsubst Math-equal-int (a b) |
190 |
|
(or (eq a b) |
191 |
|
(and (consp a) |
192 |
|
(eq (car a) 'float) |
193 |
|
(eq (nth 1 a) b) |
194 |
|
(= (nth 2 a) 0)))) |
195 |
|
|
196 |
|
(defsubst Math-natnum-lessp (a b) |
197 |
|
(if (consp a) |
198 |
|
(and (consp b) |
199 |
|
(= (math-compare-bignum (cdr a) (cdr b)) -1)) |
200 |
|
(or (consp b) |
201 |
|
(< a b)))) |
202 |
|
|
203 |
;;; calc-macs.el ends here |
;;; calc-macs.el ends here |
204 |
|
|