/[emacs]/emacs/lisp/calc/calc-macs.el
ViewVC logotype

Diff of /emacs/lisp/calc/calc-macs.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.2 by eliz, Sun Nov 11 10:27:32 2001 UTC revision 1.3 by walters, Wed Nov 14 09:05:03 2001 UTC
# Line 1  Line 1 
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.
# Line 32  Line 32 
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.
# Line 62  Line 58 
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)
# Line 85  Line 78 
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]
# Line 94  Line 86 
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)
# Line 105  Line 96 
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]
# Line 176  Line 155 
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)
# Line 218  Line 191 
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)
# Line 242  Line 212 
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    

Legend:
Removed from v.1.2  
changed lines
  Added in v.1.3

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26