home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / calc-2.02d-bin.lha / lib / emacs / site-lisp / calc-macs.el < prev    next >
Encoding:
Text File  |  1996-10-12  |  6.0 KB  |  263 lines
  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.  
  35. (defmacro calc-wrapper (&rest body)
  36.   (list 'calc-do (list 'function (append (list 'lambda ()) body)))
  37. )
  38.  
  39. ;; We use "point" here to generate slightly smaller byte-code than "t".
  40. (defmacro calc-slow-wrapper (&rest body)
  41.   (list 'calc-do (list 'function (append (list 'lambda ()) body)) (point))
  42. )
  43.  
  44.  
  45. (defmacro math-showing-full-precision (body)
  46.   (list 'let
  47.     '((calc-float-format calc-full-float-format))
  48.     body)
  49. )
  50.  
  51.  
  52. (defmacro math-with-extra-prec (delta &rest body)
  53.   (` (math-normalize
  54.       (let ((calc-internal-prec (+ calc-internal-prec (, delta))))
  55.     (,@ body))))
  56. )
  57.  
  58.  
  59. ;;; Faster in-line version zerop, normalized values only.
  60. (defmacro Math-zerop (a)   ; [P N]
  61.   (` (if (consp (, a))
  62.      (and (not (memq (car (, a)) '(bigpos bigneg)))
  63.           (if (eq (car (, a)) 'float)
  64.           (eq (nth 1 (, a)) 0)
  65.         (math-zerop (, a))))
  66.        (eq (, a) 0)))
  67. )
  68.  
  69. (defmacro Math-integer-negp (a)
  70.   (` (if (consp (, a))
  71.      (eq (car (, a)) 'bigneg)
  72.        (< (, a) 0)))
  73. )
  74.  
  75. (defmacro Math-integer-posp (a)
  76.   (` (if (consp (, a))
  77.      (eq (car (, a)) 'bigpos)
  78.        (> (, a) 0)))
  79. )
  80.  
  81.  
  82. (defmacro Math-negp (a)
  83.   (` (if (consp (, a))
  84.      (or (eq (car (, a)) 'bigneg)
  85.          (and (not (eq (car (, a)) 'bigpos))
  86.           (if (memq (car (, a)) '(frac float))
  87.               (Math-integer-negp (nth 1 (, a)))
  88.             (math-negp (, a)))))
  89.        (< (, a) 0)))
  90. )
  91.  
  92.  
  93. (defmacro Math-looks-negp (a)   ; [P x] [Public]
  94.   (` (or (Math-negp (, a))
  95.      (and (consp (, a)) (or (eq (car (, a)) 'neg)
  96.                 (and (memq (car (, a)) '(* /))
  97.                      (or (math-looks-negp (nth 1 (, a)))
  98.                      (math-looks-negp (nth 2 (, a)))))))))
  99. )
  100.  
  101.  
  102. (defmacro 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.  
  112.  
  113. (defmacro Math-integerp (a)
  114.   (` (or (not (consp (, a)))
  115.      (memq (car (, a)) '(bigpos bigneg))))
  116. )
  117.  
  118.  
  119. (defmacro Math-natnump (a)
  120.   (` (if (consp (, a))
  121.      (eq (car (, a)) 'bigpos)
  122.        (>= (, a) 0)))
  123. )
  124.  
  125. (defmacro Math-ratp (a)
  126.   (` (or (not (consp (, a)))
  127.      (memq (car (, a)) '(bigpos bigneg frac))))
  128. )
  129.  
  130. (defmacro Math-realp (a)
  131.   (` (or (not (consp (, a)))
  132.      (memq (car (, a)) '(bigpos bigneg frac float))))
  133. )
  134.  
  135. (defmacro Math-anglep (a)
  136.   (` (or (not (consp (, a)))
  137.      (memq (car (, a)) '(bigpos bigneg frac float hms))))
  138. )
  139.  
  140. (defmacro Math-numberp (a)
  141.   (` (or (not (consp (, a)))
  142.      (memq (car (, a)) '(bigpos bigneg frac float cplx polar))))
  143. )
  144.  
  145. (defmacro Math-scalarp (a)
  146.   (` (or (not (consp (, a)))
  147.      (memq (car (, a)) '(bigpos bigneg frac float cplx polar hms))))
  148. )
  149.  
  150. (defmacro Math-vectorp (a)
  151.   (` (and (consp (, a)) (eq (car (, a)) 'vec)))
  152. )
  153.  
  154. (defmacro Math-messy-integerp (a)
  155.   (` (and (consp (, a))
  156.       (eq (car (, a)) 'float)
  157.       (>= (nth 2 (, a)) 0)))
  158. )
  159.  
  160. (defmacro Math-objectp (a)    ;  [Public]
  161.   (` (or (not (consp (, a)))
  162.      (memq (car (, a))
  163.            '(bigpos bigneg frac float cplx polar hms date sdev intv mod))))
  164. )
  165.  
  166. (defmacro Math-objvecp (a)    ;  [Public]
  167.   (` (or (not (consp (, a)))
  168.      (memq (car (, a))
  169.            '(bigpos bigneg frac float cplx polar hms date
  170.             sdev intv mod vec))))
  171. )
  172.  
  173.  
  174. ;;; Compute the negative of A.  [O O; o o] [Public]
  175. (defmacro Math-integer-neg (a)
  176.   (` (if (consp (, a))
  177.      (if (eq (car (, a)) 'bigpos)
  178.          (cons 'bigneg (cdr (, a)))
  179.        (cons 'bigpos (cdr (, a))))
  180.        (- (, a))))
  181. )
  182.  
  183.  
  184. (defmacro Math-equal (a b)
  185.   (` (= (math-compare (, a) (, b)) 0))
  186. )
  187.  
  188. (defmacro Math-lessp (a b)
  189.   (` (= (math-compare (, a) (, b)) -1))
  190. )
  191.  
  192.  
  193. (defmacro math-working (msg arg)    ; [Public]
  194.   (` (if (eq calc-display-working-message 'lots)
  195.      (math-do-working (, msg) (, arg))))
  196. )
  197.  
  198.  
  199. (defmacro calc-with-default-simplification (body)
  200.   (list 'let
  201.     '((calc-simplify-mode (and (not (memq calc-simplify-mode '(none num)))
  202.                    calc-simplify-mode)))
  203.     body)
  204. )
  205.  
  206.  
  207. (defmacro Math-primp (a)
  208.   (` (or (not (consp (, a)))
  209.      (memq (car (, a)) '(bigpos bigneg frac float cplx polar
  210.                     hms date mod var))))
  211. )
  212.  
  213.  
  214. (defmacro calc-with-trail-buffer (&rest body)
  215.   (` (let ((save-buf (current-buffer))
  216.        (calc-command-flags nil))
  217.        (unwind-protect
  218.        (, (append '(progn
  219.              (set-buffer (calc-trail-display t))
  220.              (goto-char calc-trail-pointer))
  221.               body))
  222.      (set-buffer save-buf))))
  223. )
  224.  
  225.  
  226. (defmacro Math-num-integerp (a)
  227.   (` (or (not (consp (, a)))
  228.      (memq (car (, a)) '(bigpos bigneg))
  229.      (and (eq (car (, a)) 'float)
  230.           (>= (nth 2 (, a)) 0))))
  231. )
  232.  
  233.  
  234. (defmacro Math-bignum-test (a)   ; [B N; B s; b b]
  235.   (` (if (consp (, a))
  236.      (, a)
  237.        (math-bignum (, a))))
  238. )
  239.  
  240.  
  241. (defmacro Math-equal-int (a b)
  242.   (` (or (eq (, a) (, b))
  243.      (and (consp (, a))
  244.           (eq (car (, a)) 'float)
  245.           (eq (nth 1 (, a)) (, b))
  246.           (= (nth 2 (, a)) 0))))
  247. )
  248.  
  249. (defmacro Math-natnum-lessp (a b)
  250.   (` (if (consp (, a))
  251.      (and (consp (, b))
  252.           (= (math-compare-bignum (cdr (, a)) (cdr (, b))) -1))
  253.        (or (consp (, b))
  254.        (< (, a) (, b)))))
  255. )
  256.  
  257.  
  258. (defmacro math-format-radix-digit (a)   ; [X D]
  259.   (` (aref math-radix-digits (, a)))
  260. )
  261.  
  262.  
  263.