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