/[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.3 by walters, Wed Nov 14 09:05:03 2001 UTC revision 1.4 by walters, Mon Nov 19 07:35:49 2001 UTC
# Line 1  Line 1 
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    
# Line 19  Line 22 
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    

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

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