diff options
Diffstat (limited to 'lisp')
| -rw-r--r-- | lisp/calc/calc-macs.el | 355 |
1 files changed, 165 insertions, 190 deletions
diff --git a/lisp/calc/calc-macs.el b/lisp/calc/calc-macs.el index 12ece3a9949..0aee9556aef 100644 --- a/lisp/calc/calc-macs.el +++ b/lisp/calc/calc-macs.el @@ -1,6 +1,9 @@ -;; Calculator for GNU Emacs, part I [calc-macs.el] +;;; calc-macs.el --- important macros for Calc + ;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc. -;; Written by Dave Gillespie, daveg@synaptics.com. + +;; Author: David Gillespie <daveg@synaptics.com> +;; Maintainer: Colin Walters <walters@debian.org> ;; This file is part of GNU Emacs. @@ -19,211 +22,183 @@ ;; file named COPYING. Among other things, the copyright notice ;; and this notice must be preserved on all copies. +;;; Commentary: + +;;; Code: (provide 'calc-macs) (defun calc-need-macros () nil) - -(defmacro calc-record-compilation-date-macro () - `(setq calc-installed-date ,(concat (current-time-string) - " by " - (user-full-name)))) - - (defmacro calc-wrapper (&rest body) - (list 'calc-do (list 'function (append (list 'lambda ()) body)))) + `(calc-do (function (lambda () + ,@body)))) -;; We use "point" here to generate slightly smaller byte-code than "t". (defmacro calc-slow-wrapper (&rest body) - (list 'calc-do (list 'function (append (list 'lambda ()) body)) (point))) - - -(defmacro math-showing-full-precision (body) - (list 'let - '((calc-float-format calc-full-float-format)) - body)) + `(calc-do + (function (lambda () ,@body) (point)))) +(defmacro math-showing-full-precision (form) + `(let ((calc-float-format calc-full-float-format)) + ,form)) (defmacro math-with-extra-prec (delta &rest body) - (` (math-normalize - (let ((calc-internal-prec (+ calc-internal-prec (, delta)))) - (,@ body))))) - - -;;; Faster in-line version zerop, normalized values only. -(defmacro Math-zerop (a) ; [P N] - (` (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))))) + `(math-normalize + (let ((calc-internal-prec (+ calc-internal-prec ,delta))) + ,@body))) +(defmacro math-working (msg arg) ; [Public] + `(if (eq calc-display-working-message 'lots) + (math-do-working ,msg ,arg))) (defmacro calc-with-default-simplification (body) - (list 'let - '((calc-simplify-mode (and (not (memq calc-simplify-mode '(none num))) - calc-simplify-mode))) - body)) - + `(let ((calc-simplify-mode (and (not (memq calc-simplify-mode '(none num))) + calc-simplify-mode))) + ,@body)) -(defmacro Math-primp (a) - (` (or (not (consp (, a))) - (memq (car (, a)) '(bigpos bigneg frac float cplx polar - hms date mod var))))) +(defmacro calc-with-trail-buffer (&rest body) + `(let ((save-buf (current-buffer)) + (calc-command-flags nil)) + (with-current-buffer (calc-trail-display t) + (progn + (goto-char calc-trail-pointer) + ,@body)))) +;;; Faster in-line version zerop, normalized values only. +(defsubst Math-zerop (a) ; [P N] + (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))) + +(defsubst Math-integer-negp (a) + (if (consp a) + (eq (car a) 'bigneg) + (< a 0))) + +(defsubst Math-integer-posp (a) + (if (consp a) + (eq (car a) 'bigpos) + (> a 0))) + +(defsubst 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))) + +(defsubst 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)))))))) + +(defsubst 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))) + +(defsubst Math-integerp (a) + (or (not (consp a)) + (memq (car a) '(bigpos bigneg)))) + +(defsubst Math-natnump (a) + (if (consp a) + (eq (car a) 'bigpos) + (>= a 0))) + +(defsubst Math-ratp (a) + (or (not (consp a)) + (memq (car a) '(bigpos bigneg frac)))) + +(defsubst Math-realp (a) + (or (not (consp a)) + (memq (car a) '(bigpos bigneg frac float)))) + +(defsubst Math-anglep (a) + (or (not (consp a)) + (memq (car a) '(bigpos bigneg frac float hms)))) + +(defsubst Math-numberp (a) + (or (not (consp a)) + (memq (car a) '(bigpos bigneg frac float cplx polar)))) + +(defsubst Math-scalarp (a) + (or (not (consp a)) + (memq (car a) '(bigpos bigneg frac float cplx polar hms)))) + +(defsubst Math-vectorp (a) + (and (consp a) (eq (car a) 'vec))) + +(defsubst Math-messy-integerp (a) + (and (consp a) + (eq (car a) 'float) + (>= (nth 2 a) 0))) + +(defsubst Math-objectp (a) ; [Public] + (or (not (consp a)) + (memq (car a) + '(bigpos bigneg frac float cplx polar hms date sdev intv mod)))) + +(defsubst Math-objvecp (a) ; [Public] + (or (not (consp a)) + (memq (car a) + '(bigpos bigneg frac float cplx polar hms date + sdev intv mod vec)))) -(defmacro calc-with-trail-buffer (&rest body) - (` (let ((save-buf (current-buffer)) - (calc-command-flags nil)) - (unwind-protect - (, (append '(progn - (set-buffer (calc-trail-display t)) - (goto-char calc-trail-pointer)) - 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)))))) - - -(defmacro math-format-radix-digit (a) ; [X D] - (` (aref math-radix-digits (, a)))) +;;; Compute the negative of A. [O O; o o] [Public] +(defsubst Math-integer-neg (a) + (if (consp a) + (if (eq (car a) 'bigpos) + (cons 'bigneg (cdr a)) + (cons 'bigpos (cdr a))) + (- a))) + +(defsubst Math-equal (a b) + (= (math-compare a b) 0)) + +(defsubst Math-lessp (a b) + (= (math-compare a b) -1)) + +(defsubst Math-primp (a) + (or (not (consp a)) + (memq (car a) '(bigpos bigneg frac float cplx polar + hms date mod var)))) + +(defsubst Math-num-integerp (a) + (or (not (consp a)) + (memq (car a) '(bigpos bigneg)) + (and (eq (car a) 'float) + (>= (nth 2 a) 0)))) + +(defsubst Math-bignum-test (a) ; [B N; B s; b b] + (if (consp a) + a + (math-bignum a))) + +(defsubst 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)))) + +(defsubst Math-natnum-lessp (a b) + (if (consp a) + (and (consp b) + (= (math-compare-bignum (cdr a) (cdr b)) -1)) + (or (consp b) + (< a b)))) ;;; calc-macs.el ends here |