1;;; calc-macs.el --- important macros for Calc
2
3;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
4;;   2005, 2006, 2007 Free Software Foundation, Inc.
5
6;; Author: David Gillespie <daveg@synaptics.com>
7;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
8
9;; This file is part of GNU Emacs.
10
11;; GNU Emacs is free software; you can redistribute it and/or modify
12;; it under the terms of the GNU General Public License as published by
13;; the Free Software Foundation; either version 2, or (at your option)
14;; any later version.
15
16;; GNU Emacs is distributed in the hope that it will be useful,
17;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
19;; GNU General Public License for more details.
20
21;; You should have received a copy of the GNU General Public License
22;; along with GNU Emacs; see the file COPYING.  If not, write to the
23;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
24;; Boston, MA 02110-1301, USA.
25
26;;; Commentary:
27
28;;; Code:
29
30(defmacro calc-wrapper (&rest body)
31  `(calc-do (function (lambda ()
32			,@body))))
33
34(defmacro calc-slow-wrapper (&rest body)
35  `(calc-do
36    (function (lambda () ,@body)) (point)))
37
38(defmacro math-showing-full-precision (form)
39  `(let ((calc-float-format calc-full-float-format))
40     ,form))
41
42(defmacro math-with-extra-prec (delta &rest body)
43  `(math-normalize
44    (let ((calc-internal-prec (+ calc-internal-prec ,delta)))
45      ,@body)))
46
47(defmacro math-working (msg arg)	; [Public]
48  `(if (eq calc-display-working-message 'lots)
49       (math-do-working ,msg ,arg)))
50
51(defmacro calc-with-default-simplification (&rest body)
52  `(let ((calc-simplify-mode (and (not (memq calc-simplify-mode '(none num)))
53				  calc-simplify-mode)))
54     ,@body))
55
56(defmacro calc-with-trail-buffer (&rest body)
57  `(let ((save-buf (current-buffer))
58	 (calc-command-flags nil))
59     (with-current-buffer (calc-trail-display t)
60       (progn
61	 (goto-char calc-trail-pointer)
62	 ,@body))))
63
64;;; Faster in-line version zerop, normalized values only.
65(defsubst Math-zerop (a)		; [P N]
66  (if (consp a)
67      (and (not (memq (car a) '(bigpos bigneg)))
68	   (if (eq (car a) 'float)
69	       (eq (nth 1 a) 0)
70	     (math-zerop a)))
71    (eq a 0)))
72
73(defsubst Math-integer-negp (a)
74  (if (consp a)
75      (eq (car a) 'bigneg)
76    (< a 0)))
77
78(defsubst Math-integer-posp (a)
79  (if (consp a)
80      (eq (car a) 'bigpos)
81    (> a 0)))
82
83(defsubst Math-negp (a)
84  (if (consp a)
85      (or (eq (car a) 'bigneg)
86	  (and (not (eq (car a) 'bigpos))
87	       (if (memq (car a) '(frac float))
88		   (Math-integer-negp (nth 1 a))
89		 (math-negp a))))
90    (< a 0)))
91
92(defsubst Math-looks-negp (a)		; [P x] [Public]
93  (or (Math-negp a)
94      (and (consp a) (or (eq (car a) 'neg)
95			 (and (memq (car a) '(* /))
96			      (or (math-looks-negp (nth 1 a))
97				  (math-looks-negp (nth 2 a))))))))
98
99(defsubst Math-posp (a)
100  (if (consp a)
101      (or (eq (car a) 'bigpos)
102	  (and (not (eq (car a) 'bigneg))
103	       (if (memq (car a) '(frac float))
104		   (Math-integer-posp (nth 1 a))
105		 (math-posp a))))
106    (> a 0)))
107
108(defsubst Math-integerp (a)
109  (or (not (consp a))
110      (memq (car a) '(bigpos bigneg))))
111
112(defsubst Math-natnump (a)
113  (if (consp a)
114      (eq (car a) 'bigpos)
115    (>= a 0)))
116
117(defsubst Math-ratp (a)
118  (or (not (consp a))
119      (memq (car a) '(bigpos bigneg frac))))
120
121(defsubst Math-realp (a)
122  (or (not (consp a))
123      (memq (car a) '(bigpos bigneg frac float))))
124
125(defsubst Math-anglep (a)
126  (or (not (consp a))
127      (memq (car a) '(bigpos bigneg frac float hms))))
128
129(defsubst Math-numberp (a)
130  (or (not (consp a))
131      (memq (car a) '(bigpos bigneg frac float cplx polar))))
132
133(defsubst Math-scalarp (a)
134  (or (not (consp a))
135      (memq (car a) '(bigpos bigneg frac float cplx polar hms))))
136
137(defsubst Math-vectorp (a)
138  (and (consp a) (eq (car a) 'vec)))
139
140(defsubst Math-messy-integerp (a)
141  (and (consp a)
142       (eq (car a) 'float)
143       (>= (nth 2 a) 0)))
144
145(defsubst Math-objectp (a)		;  [Public]
146  (or (not (consp a))
147      (memq (car a)
148	    '(bigpos bigneg frac float cplx polar hms date sdev intv mod))))
149
150(defsubst Math-objvecp (a)		;  [Public]
151  (or (not (consp a))
152      (memq (car a)
153	    '(bigpos bigneg frac float cplx polar hms date
154		     sdev intv mod vec))))
155
156;;; Compute the negative of A.  [O O; o o] [Public]
157(defsubst Math-integer-neg (a)
158  (if (consp a)
159      (if (eq (car a) 'bigpos)
160	  (cons 'bigneg (cdr a))
161	(cons 'bigpos (cdr a)))
162    (- a)))
163
164(defsubst Math-equal (a b)
165  (= (math-compare a b) 0))
166
167(defsubst Math-lessp (a b)
168  (= (math-compare a b) -1))
169
170(defsubst Math-primp (a)
171  (or (not (consp a))
172      (memq (car a) '(bigpos bigneg frac float cplx polar
173			     hms date mod var))))
174
175(defsubst Math-num-integerp (a)
176  (or (not (consp a))
177      (memq (car a) '(bigpos bigneg))
178      (and (eq (car a) 'float)
179	   (>= (nth 2 a) 0))))
180
181(defsubst Math-bignum-test (a)		; [B N; B s; b b]
182  (if (consp a)
183      a
184    (math-bignum a)))
185
186(defsubst Math-equal-int (a b)
187  (or (eq a b)
188      (and (consp a)
189	   (eq (car a) 'float)
190	   (eq (nth 1 a) b)
191	   (= (nth 2 a) 0))))
192
193(defsubst Math-natnum-lessp (a b)
194  (if (consp a)
195      (and (consp b)
196	   (= (math-compare-bignum (cdr a) (cdr b)) -1))
197    (or (consp b)
198	(< a b))))
199
200(provide 'calc-macs)
201
202;;; arch-tag: 08ba8ec2-fcff-4b80-a079-ec661bdb057e
203;;; calc-macs.el ends here
204