code.delx.au - gnu-emacs/blob - lisp/calc/calc-macs.el

   1 ;; Calculator for GNU Emacs, part I [calc-macs.el]
   2 ;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
   3 ;; Written by Dave Gillespie, daveg@synaptics.com.
   4
   5 ;; This file is part of GNU Emacs.
   6
   7 ;; GNU Emacs is distributed in the hope that it will be useful,
   8 ;; but WITHOUT ANY WARRANTY.  No author or distributor
   9 ;; accepts responsibility to anyone for the consequences of using it
  10 ;; or for whether it serves any particular purpose or works at all,
  11 ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  12 ;; License for full details.
  13
  14 ;; Everyone is granted permission to copy, modify and redistribute
  15 ;; GNU Emacs, but only under the conditions described in the
  16 ;; GNU Emacs General Public License.   A copy of this license is
  17 ;; supposed to have been given to you along with GNU Emacs so you
  18 ;; can know your rights and responsibilities.  It should be in a
  19 ;; file named COPYING.  Among other things, the copyright notice
  20 ;; and this notice must be preserved on all copies.
  21
  22
  23 (provide 'calc-macs)
  24
  25 (defun calc-need-macros () nil)
  26
  27
  28 (defmacro calc-record-compilation-date-macro ()
  29   `(setq calc-installed-date ,(concat (current-time-string)
  30                                       " by "
  31                                       (user-full-name))))
  32
  33
  34 (defmacro calc-wrapper (&rest body)
  35   (list 'calc-do (list 'function (append (list 'lambda ()) body)))
  36 )
  37
  38 ;; We use "point" here to generate slightly smaller byte-code than "t".
  39 (defmacro calc-slow-wrapper (&rest body)
  40   (list 'calc-do (list 'function (append (list 'lambda ()) body)) (point))
  41 )
  42
  43
  44 (defmacro math-showing-full-precision (body)
  45   (list 'let
  46         '((calc-float-format calc-full-float-format))
  47         body)
  48 )
  49
  50
  51 (defmacro math-with-extra-prec (delta &rest body)
  52   (` (math-normalize
  53       (let ((calc-internal-prec (+ calc-internal-prec (, delta))))
  54         (,@ body))))
  55 )
  56
  57
  58 ;;; Faster in-line version zerop, normalized values only.
  59 (defmacro Math-zerop (a)   ; [P N]
  60   (` (if (consp (, a))
  61          (and (not (memq (car (, a)) '(bigpos bigneg)))
  62               (if (eq (car (, a)) 'float)
  63                   (eq (nth 1 (, a)) 0)
  64                 (math-zerop (, a))))
  65        (eq (, a) 0)))
  66 )
  67
  68 (defmacro Math-integer-negp (a)
  69   (` (if (consp (, a))
  70          (eq (car (, a)) 'bigneg)
  71        (< (, a) 0)))
  72 )
  73
  74 (defmacro Math-integer-posp (a)
  75   (` (if (consp (, a))
  76          (eq (car (, a)) 'bigpos)
  77        (> (, a) 0)))
  78 )
  79
  80
  81 (defmacro Math-negp (a)
  82   (` (if (consp (, a))
  83          (or (eq (car (, a)) 'bigneg)
  84              (and (not (eq (car (, a)) 'bigpos))
  85                   (if (memq (car (, a)) '(frac float))
  86                       (Math-integer-negp (nth 1 (, a)))
  87                     (math-negp (, a)))))
  88        (< (, a) 0)))
  89 )
  90
  91
  92 (defmacro 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
 100
 101 (defmacro Math-posp (a)
 102   (` (if (consp (, a))
 103          (or (eq (car (, a)) 'bigpos)
 104              (and (not (eq (car (, a)) 'bigneg))
 105                   (if (memq (car (, a)) '(frac float))
 106                       (Math-integer-posp (nth 1 (, a)))
 107                     (math-posp (, a)))))
 108        (> (, a) 0)))
 109 )
 110
 111
 112 (defmacro Math-integerp (a)
 113   (` (or (not (consp (, a)))
 114          (memq (car (, a)) '(bigpos bigneg))))
 115 )
 116
 117
 118 (defmacro Math-natnump (a)
 119   (` (if (consp (, a))
 120          (eq (car (, a)) 'bigpos)
 121        (>= (, a) 0)))
 122 )
 123
 124 (defmacro Math-ratp (a)
 125   (` (or (not (consp (, a)))
 126          (memq (car (, a)) '(bigpos bigneg frac))))
 127 )
 128
 129 (defmacro Math-realp (a)
 130   (` (or (not (consp (, a)))
 131          (memq (car (, a)) '(bigpos bigneg frac float))))
 132 )
 133
 134 (defmacro Math-anglep (a)
 135   (` (or (not (consp (, a)))
 136          (memq (car (, a)) '(bigpos bigneg frac float hms))))
 137 )
 138
 139 (defmacro Math-numberp (a)
 140   (` (or (not (consp (, a)))
 141          (memq (car (, a)) '(bigpos bigneg frac float cplx polar))))
 142 )
 143
 144 (defmacro Math-scalarp (a)
 145   (` (or (not (consp (, a)))
 146          (memq (car (, a)) '(bigpos bigneg frac float cplx polar hms))))
 147 )
 148
 149 (defmacro Math-vectorp (a)
 150   (` (and (consp (, a)) (eq (car (, a)) 'vec)))
 151 )
 152
 153 (defmacro Math-messy-integerp (a)
 154   (` (and (consp (, a))
 155           (eq (car (, a)) 'float)
 156           (>= (nth 2 (, a)) 0)))
 157 )
 158
 159 (defmacro Math-objectp (a)    ;  [Public]
 160   (` (or (not (consp (, a)))
 161          (memq (car (, a))
 162                '(bigpos bigneg frac float cplx polar hms date sdev intv mod))))
 163 )
 164
 165 (defmacro Math-objvecp (a)    ;  [Public]
 166   (` (or (not (consp (, a)))
 167          (memq (car (, a))
 168                '(bigpos bigneg frac float cplx polar hms date
 169                         sdev intv mod vec))))
 170 )
 171
 172
 173 ;;; Compute the negative of A.  [O O; o o] [Public]
 174 (defmacro Math-integer-neg (a)
 175   (` (if (consp (, a))
 176          (if (eq (car (, a)) 'bigpos)
 177              (cons 'bigneg (cdr (, a)))
 178            (cons 'bigpos (cdr (, a))))
 179        (- (, a))))
 180 )
 181
 182
 183 (defmacro Math-equal (a b)
 184   (` (= (math-compare (, a) (, b)) 0))
 185 )
 186
 187 (defmacro Math-lessp (a b)
 188   (` (= (math-compare (, a) (, b)) -1))
 189 )
 190
 191
 192 (defmacro math-working (msg arg)    ; [Public]
 193   (` (if (eq calc-display-working-message 'lots)
 194          (math-do-working (, msg) (, arg))))
 195 )
 196
 197
 198 (defmacro calc-with-default-simplification (body)
 199   (list 'let
 200         '((calc-simplify-mode (and (not (memq calc-simplify-mode '(none num)))
 201                                    calc-simplify-mode)))
 202         body)
 203 )
 204
 205
 206 (defmacro Math-primp (a)
 207   (` (or (not (consp (, a)))
 208          (memq (car (, a)) '(bigpos bigneg frac float cplx polar
 209                                     hms date mod var))))
 210 )
 211
 212
 213 (defmacro calc-with-trail-buffer (&rest body)
 214   (` (let ((save-buf (current-buffer))
 215            (calc-command-flags nil))
 216        (unwind-protect
 217            (, (append '(progn
 218                          (set-buffer (calc-trail-display t))
 219                          (goto-char calc-trail-pointer))
 220                       body))
 221          (set-buffer save-buf))))
 222 )
 223
 224
 225 (defmacro Math-num-integerp (a)
 226   (` (or (not (consp (, a)))
 227          (memq (car (, a)) '(bigpos bigneg))
 228          (and (eq (car (, a)) 'float)
 229               (>= (nth 2 (, a)) 0))))
 230 )
 231
 232
 233 (defmacro Math-bignum-test (a)   ; [B N; B s; b b]
 234   (` (if (consp (, a))
 235          (, a)
 236        (math-bignum (, a))))
 237 )
 238
 239
 240 (defmacro Math-equal-int (a b)
 241   (` (or (eq (, a) (, b))
 242          (and (consp (, a))
 243               (eq (car (, a)) 'float)
 244               (eq (nth 1 (, a)) (, b))
 245               (= (nth 2 (, a)) 0))))
 246 )
 247
 248 (defmacro Math-natnum-lessp (a b)
 249   (` (if (consp (, a))
 250          (and (consp (, b))
 251               (= (math-compare-bignum (cdr (, a)) (cdr (, b))) -1))
 252        (or (consp (, b))
 253            (< (, a) (, b)))))
 254 )
 255
 256
 257 (defmacro math-format-radix-digit (a)   ; [X D]
 258   (` (aref math-radix-digits (, a)))
 259 )
 260
 261