daveg@csvax.caltech.edu (David Gillespie) (06/06/90)
Posting-number: Volume 13, Issue 29
Submitted-by: daveg@csvax.caltech.edu (David Gillespie)
Archive-name: gmcalc/part03
---- Cut Here and unpack ----
#!/bin/sh
# this is part 3 of a multipart archive
# do not concatenate these parts, unpack them in order with /bin/sh
# file calc.el continued
#
CurArch=3
if test ! -r s2_seq_.tmp
then echo "Please unpack part 1 first!"
exit 1; fi
( read Scheck
if test "$Scheck" != $CurArch
then echo "Please unpack part $Scheck next!"
exit 1;
else exit 0; fi
) < s2_seq_.tmp || exit 1
echo "x - Continuing file calc.el"
sed 's/^X//' << 'SHAR_EOF' >> calc.el
X 0)))
X (math-make-float (math-quotient (math-scale-int (nth 1 a) ldiff) (nth 1 b))
X (- (- (nth 2 a) (nth 2 b)) ldiff)))
X)
X
X(defun math-inv (m)
X (if (Math-vectorp m)
X (progn
X (calc-extensions)
X (if (math-square-matrixp m)
X (or (math-with-extra-prec 2 (math-matrix-inv-raw m))
X (math-reject-arg m "Singular matrix"))
X (math-reject-arg m 'square-matrixp)))
X (math-div 1 m))
X)
X(fset 'calcFunc-inv (symbol-function 'math-inv))
X
X
X(defmacro math-working (msg arg) ; [Public]
X (` (if (eq calc-display-working-message 'lots)
X (progn
X (calc-set-command-flag 'clear-message)
X (message "Working... %s = %s"
X (, msg)
X (math-showing-full-precision
X (math-format-number (, arg)))))))
X)
X
X
X;;; Compute A modulo B, defined in terms of truncation toward minus infinity.
X(defun math-mod (a b) ; [R R R] [Public]
X (cond ((Math-zerop a) a)
X ((Math-zerop b)
X (math-reject-arg a "Division by zero"))
X ((and (Math-natnump a) (Math-natnump b))
X (math-imod a b))
X ((and (Math-anglep a) (Math-anglep b))
X (math-sub a (math-mul (math-floor (math-div a b)) b)))
X ((and (eq (car-safe a) 'mod) (Math-realp b) (math-posp b))
X (math-make-mod (nth 1 a) b))
X ((and (eq (car-safe a) 'intv) (math-constp a) (math-posp b))
X (math-mod-intv a b))
X (t
X (if (Math-anglep a)
X (calc-record-why 'anglep b)
X (calc-record-why 'anglep a))
X (list '% a b)))
X)
X(defun calcFunc-mod (a b)
X (math-normalize (list '% a b))
X)
X
X
X;;; Compute the greatest common divisor of A and B. [I I I] [Public]
X(defun math-gcd (a b)
X (cond
X ((not (or (consp a) (consp b)))
X (if (< a 0) (setq a (- a)))
X (if (< b 0) (setq b (- b)))
X (let (c)
X (if (< a b)
X (setq c b b a a c))
X (while (> b 0)
X (setq c b
X b (% a b)
X a c))
X a))
X ((Math-looks-negp a) (math-gcd (math-neg a) b))
X ((Math-looks-negp b) (math-gcd a (math-neg b)))
X ((eq a 0) b)
X ((eq b 0) a)
X ((not (Math-integerp a))
X (if (Math-messy-integerp a)
X (math-gcd (math-trunc a) b)
X (calc-record-why 'integerp a)
X (list 'calcFunc-gcd a b)))
X ((not (Math-integerp b))
X (if (Math-messy-integerp b)
X (math-gcd a (math-trunc b))
X (calc-record-why 'integerp b)
X (list 'calcFunc-gcd a b)))
X (t
X (let (c)
X (if (Math-natnum-lessp a b)
X (setq c b b a a c))
X (while (and (consp a) (not (eq b 0)))
X (setq c b
X b (math-imod a b)
X a c))
X (while (> b 0)
X (setq c b
X b (% a b)
X a c))
X a)))
X)
X(fset 'calcFunc-gcd (symbol-function 'math-gcd))
X
X
X
X;;; General exponentiation.
X
X(defun math-pow (a b) ; [O O N] [Public]
X (cond ((Math-zerop a)
X (if (math-zerop b)
X (math-reject-arg (list '^ a b) "Indeterminate form")
X (if (math-floatp b) (math-float a) a)))
X ((or (eq a 1) (eq b 1)) a)
X ((or (equal a '(float 1 0)) (equal b '(float 1 0))) a)
X ((Math-zerop b)
X (if (eq (car-safe a) 'mod)
X (math-make-mod 1 (nth 2 a))
X (if (or (math-floatp a) (math-floatp b))
X '(float 1 0) 1)))
X ((and (Math-integerp b) (math-numvecp a))
X (math-with-extra-prec 2
X (math-ipow a b)))
X (t
X (calc-extensions)
X (math-pow-fancy a b)))
X)
X(defun calcFunc-pow (a b)
X (math-normalize (list '^ a b))
X)
X
X(defun math-ipow (a n) ; [O O I] [Public]
X (cond ((Math-integer-negp n)
X (math-ipow (math-div 1 a) (Math-integer-neg n)))
X ((not (consp n))
X (if (and (Math-ratp a) (> n 20))
X (math-iipow-show a n)
X (math-iipow a n)))
X ((math-evenp n)
X (math-ipow (math-sqr a) (math-div2 n)))
X (t
X (math-mul a (math-ipow (math-sqr a)
X (math-div2 (math-add n -1))))))
X)
X
X(defun math-iipow (a n) ; [O O S]
X (cond ((= n 0) 1)
X ((= n 1) a)
X ((= (% n 2) 0) (math-iipow (math-sqr a) (/ n 2)))
X (t (math-mul a (math-iipow (math-sqr a) (/ n 2)))))
X)
X
X(defun math-iipow-show (a n) ; [O O S]
X (math-working "pow" a)
X (let ((val (cond
X ((= n 0) 1)
X ((= n 1) a)
X ((= (% n 2) 0) (math-iipow-show (math-sqr a) (/ n 2)))
X (t (math-mul a (math-iipow-show (math-sqr a) (/ n 2)))))))
X (math-working "pow" val)
X val)
X)
X
X
X
X
X
X;;; Format the number A as a string. [X N; X Z] [Public]
X;;; Target line-width is W.
X(defun math-format-stack-value (a &optional w)
X (or w (setq w (calc-window-width)))
X (let ((c (cond ((null a) "<nil>")
X ((eq calc-display-raw t) (format "%s" a))
X ((stringp a) a)
X ((eq a 'top-of-stack) ".")
X ((and (math-scalarp a)
X (memq calc-language '(nil flat unform)))
X (math-format-number a))
X (t (calc-extensions)
X (math-compose-expr a 0))))
X s ww)
X (if (and calc-display-just
X (< (setq ww (if (stringp c)
X (length c)
X (math-comp-width c))) w))
X (setq c (math-comp-concat
X (make-string (if (eq calc-display-just 'center)
X (/ (- w ww) 2)
X (- w ww)) 32)
X c))
X (if calc-line-numbering
X (setq c (math-comp-concat
X (if (eq calc-language 'big) "1: " " ") c))))
X (let ((s (if (stringp c)
X (if calc-display-raw
X (prin1-to-string c)
X c)
X (math-composition-to-string c w))))
X (if calc-language-output-filter
X (setq s (funcall calc-language-output-filter s)))
X (if (eq calc-language 'big)
X (concat s "\n")
X (if calc-line-numbering
X (progn
X (aset s 0 ?1)
X (aset s 1 ?:)))
X s)))
X)
X
X(defun math-format-value (a &optional w)
X (if (and (math-scalarp a)
X (memq calc-language '(nil flat unform)))
X (math-format-number a)
X (calc-extensions)
X (math-composition-to-string (math-compose-expr a 0) w))
X)
X
X(defun calc-window-width ()
X (1- (window-width (get-buffer-window (current-buffer))))
X)
X
X(defun math-comp-concat (c1 c2)
X (if (and (stringp c1) (stringp c2))
X (concat c1 c2)
X (list 'horiz c1 c2))
X)
X
X
X
X;;; Format an expression as a one-line string suitable for re-reading.
X
X(defun math-format-flat-expr (a prec)
X (cond
X ((or (not (or (consp a) (integerp a)))
X (eq calc-display-raw t))
X (let ((print-escape-newlines t))
X (concat "'" (prin1-to-string a))))
X ((math-scalarp a)
X (let ((calc-group-digits nil)
X (calc-point-char ".")
X (calc-frac-format (if (> (length calc-frac-format) 1) "::" ":"))
X (calc-complex-format nil)
X (calc-hms-format "%s@ %s' %s\"")
X (calc-language nil))
X (math-format-number a)))
X (t
X (calc-extensions)
X (math-format-flat-expr-fancy a prec)))
X)
X
X
X
X;;; Format a number as a string.
X(defun math-format-number (a) ; [X N] [Public]
X (cond
X ((eq calc-display-raw t) (format "%s" a))
X ((integerp a)
X (if (not (or calc-group-digits calc-leading-zeros))
X (if (= calc-number-radix 10)
X (int-to-string a)
X (if (< a 0)
X (concat "-" (math-format-number (- a)))
X (calc-extensions)
X (if math-radix-explicit-format
X (if calc-radix-formatter
X (funcall calc-radix-formatter
X calc-number-radix
X (if (= calc-number-radix 2)
X (math-format-binary a)
X (math-format-radix a)))
X (format "%d#%s" calc-number-radix
X (if (= calc-number-radix 2)
X (math-format-binary a)
X (math-format-radix a))))
X (math-format-radix a))))
X (math-format-number (math-bignum a))))
X ((stringp a) a)
X ((eq (car a) 'bigpos) (math-format-bignum (cdr a)))
X ((eq (car a) 'bigneg) (concat "-" (math-format-bignum (cdr a))))
X ((eq (car a) 'frac)
X (if (> (length calc-frac-format) 1)
X (if (Math-integer-negp (nth 1 a))
X (concat "-" (math-format-number (math-neg a)))
X (let ((q (math-idivmod (nth 1 a) (nth 2 a))))
X (concat (math-format-number (car q))
X (substring calc-frac-format 0 1)
X (let ((math-radix-explicit-format nil))
X (math-format-number (cdr q)))
X (substring calc-frac-format 1 2)
X (let ((math-radix-explicit-format nil))
X (math-format-number (nth 2 a))))))
X (concat (math-format-number (nth 1 a))
X calc-frac-format
X (let ((math-radix-explicit-format nil))
X (math-format-number (nth 2 a))))))
X ((eq (car a) 'float)
X (if (Math-integer-negp (nth 1 a))
X (concat "-" (math-format-number (math-neg a)))
X (let ((mant (nth 1 a))
X (exp (nth 2 a))
X (fmt (car calc-float-format))
X (figs (nth 1 calc-float-format))
X (point calc-point-char)
X str)
X (if (and (eq fmt 'fix)
X (or (and (< figs 0) (setq figs (- figs)))
X (> (+ exp (math-numdigs mant)) (- figs))))
X (progn
X (setq mant (math-scale-rounding mant (+ exp figs))
X str (if (integerp mant)
X (int-to-string mant)
X (math-format-bignum-decimal (cdr mant))))
X (if (<= (length str) figs)
X (setq str (concat (make-string (1+ (- figs (length str))) ?0)
X str)))
X (if (> figs 0)
X (setq str (concat (substring str 0 (- figs)) point
X (substring str (- figs))))
X (setq str (concat str point)))
X (if calc-group-digits
X (setq str (math-group-float str))))
X (if (< figs 0)
X (setq figs (+ calc-internal-prec figs)))
X (if (> figs 0)
X (let ((adj (- figs (math-numdigs mant))))
X (if (< adj 0)
X (setq mant (math-scale-rounding mant adj)
X exp (- exp adj)))))
X (setq str (if (integerp mant)
X (int-to-string mant)
X (math-format-bignum-decimal (cdr mant))))
X (let* ((len (length str))
X (dpos (+ exp len)))
X (if (and (eq fmt 'float)
X (<= dpos (+ calc-internal-prec calc-display-sci-high))
X (>= dpos (+ calc-display-sci-low 2)))
X (progn
X (cond
X ((= dpos 0)
X (setq str (concat "0" point str)))
X ((and (<= exp 0) (> dpos 0))
X (setq str (concat (substring str 0 dpos) point
X (substring str dpos))))
X ((> exp 0)
X (setq str (concat str (make-string exp ?0) point)))
X (t ; (< dpos 0)
X (setq str (concat "0" point
X (make-string (- dpos) ?0) str))))
X (if calc-group-digits
X (setq str (math-group-float str))))
X (let* ((eadj (+ exp len))
X (scale (if (eq fmt 'eng)
X (1+ (% (+ eadj 300002) 3))
X 1)))
X (if (> scale (length str))
X (setq str (concat str (make-string (- scale (length str))
X ?0))))
X (if (< scale (length str))
X (setq str (concat (substring str 0 scale) point
X (substring str scale))))
X (if calc-group-digits
X (setq str (math-group-float str)))
X (setq str (concat str
X (if (eq calc-language 'math)
X "*10.^" "e")
X (int-to-string (- eadj scale))))))))
X str)))
X (t
X (calc-extensions)
X (math-format-number-fancy a)))
X)
X
X(defvar math-radix-explicit-format t)
X
X(defun math-format-bignum (a) ; [X L]
X (if (and (= calc-number-radix 10)
X (not calc-leading-zeros)
X (not calc-group-digits))
X (math-format-bignum-decimal a)
X (calc-extensions)
X (math-format-bignum-fancy a))
X)
X
X(defun math-format-bignum-decimal (a) ; [X L]
X (if a
X (let ((s ""))
X (while (cdr (cdr a))
X (setq s (concat (format "%06d" (+ (* (nth 1 a) 1000) (car a))) s)
X a (cdr (cdr a))))
X (concat (int-to-string (+ (* (or (nth 1 a) 0) 1000) (car a))) s))
X "0")
X)
X
X
X
X;;; Parse a simple number in string form. [N X] [Public]
X(defun math-read-number (s)
X (math-normalize
X (cond
X
X ;; Integers (most common case)
X ((string-match "\\` *\\([0-9]+\\) *\\'" s)
X (let ((digs (math-match-substring s 1)))
X (if (and (eq calc-language 'c)
X (> (length digs) 1)
X (eq (aref digs 0) ?0))
X (math-read-number (concat "8#" digs))
X (if (<= (length digs) 6)
X (string-to-int digs)
X (cons 'bigpos (math-read-bignum digs))))))
X
X ;; Clean up the string if necessary
X ((string-match "\\`\\(.*\\)[ \t\n]+\\([^\001]\\)*\\'" s)
X (math-read-number (concat (math-match-substring s 1)
X (math-match-substring s 2))))
X
X ;; Minus sign
X ((string-match "^[-_]\\(.*\\)$" s)
X (let ((val (math-read-number (math-match-substring s 1))))
X (and val (math-neg val))))
X
X ;; Plus sign
X ((string-match "^\\+\\(.*\\)$" s)
X (math-read-number (math-match-substring s 1)))
X
X ;; Forms that require extensions module
X ((string-match "[a-df-zA-DF-Z/@'\"#^]" s)
X (calc-extensions)
X (math-read-number-fancy s))
X
X ;; Integer+fractions
X ((string-match "^\\(.*\\)[:/]\\(.*\\)[:/]\\(.*\\)$" s)
X (let ((int (math-match-substring s 1))
X (num (math-match-substring s 2))
X (den (math-match-substring s 3)))
X (let ((int (if (> (length int) 0) (math-read-number int) 0))
X (num (if (> (length num) 0) (math-read-number num) 1))
X (den (if (> (length num) 0) (math-read-number den) 1)))
X (and int num den
X (math-integerp int) (math-integerp num) (math-integerp den)
X (not (math-zerop den))
X (list 'frac (math-add num (math-mul int den)) den)))))
X
X ;; Fractions
X ((string-match "^\\(.*\\)[:/]\\(.*\\)$" s)
X (let ((num (math-match-substring s 1))
X (den (math-match-substring s 2)))
X (let ((num (if (> (length num) 0) (math-read-number num) 1))
X (den (if (> (length num) 0) (math-read-number den) 1)))
X (and num den (math-integerp num) (math-integerp den)
X (not (math-zerop den))
X (list 'frac num den)))))
X
X ;; Decimal point
X ((string-match "^\\([0-9]*\\)\\.\\([0-9]*\\)$" s)
X (let ((int (math-match-substring s 1))
X (frac (math-match-substring s 2)))
X (let ((ilen (length int))
X (flen (length frac)))
X (let ((int (if (> ilen 0) (math-read-number int) 0))
X (frac (if (> flen 0) (math-read-number frac) 0)))
X (and int frac (or (> ilen 0) (> flen 0))
X (list 'float
X (math-add (math-scale-int int flen) frac)
X (- flen)))))))
X
X ;; "e" notation
X ((string-match "^\\(.*\\)[eE]\\([-+]?[0-9]+\\)$" s)
X (let ((mant (math-match-substring s 1))
X (exp (math-match-substring s 2)))
X (let ((mant (if (> (length mant) 0) (math-read-number mant) 1))
X (exp (string-to-int exp)))
X (and mant (math-realp mant)
X (let ((mant (math-float mant)))
X (list 'float (nth 1 mant) (+ (nth 2 mant) exp)))))))
X
X ;; Syntax error!
X (t nil)))
X)
X
X(defun math-match-substring (s n)
X (if (match-beginning n)
X (substring s (match-beginning n) (match-end n))
X "")
X)
X
X(defun math-read-bignum (s) ; [l X]
X (if (> (length s) 3)
X (cons (string-to-int (substring s -3))
X (math-read-bignum (substring s 0 -3)))
X (list (string-to-int s)))
X)
X
X(defun math-read-radix-digit (dig) ; [D S; Z S]
X (if (> dig ?9)
X (if (< dig ?A)
X nil
X (- dig 55))
X (if (>= dig ?0)
X (- dig ?0)
X nil))
X)
X
X
X
X;;; Algebraic expression parsing. [Public]
X
X(defun math-read-exprs (exp-str)
X (let ((exp-pos 0)
X (exp-old-pos 0)
X (exp-keep-spaces nil)
X exp-token exp-data)
X (if calc-language-input-filter
X (setq exp-str (funcall calc-language-input-filter exp-str)))
X (while (setq exp-token (string-match "\\.\\." exp-str))
X (setq exp-str (concat (substring exp-str 0 exp-token) "\\dots"
X (substring exp-str (+ exp-token 2)))))
X (math-read-token)
X (let ((val (catch 'syntax (math-read-expr-list))))
X (if (stringp val)
X (list 'error exp-old-pos val)
X (if (equal exp-token 'end)
X val
X (list 'error exp-old-pos "Syntax error")))))
X)
X
X(defun math-read-expr-list ()
X (let* ((exp-keep-spaces nil)
X (val (list (math-read-expr-level 0)))
X (last val))
X (while (equal exp-data ",")
X (math-read-token)
X (let ((rest (list (math-read-expr-level 0))))
X (setcdr last rest)
X (setq last rest)))
X val)
X)
X
X(defun math-read-token ()
X (if (>= exp-pos (length exp-str))
X (setq exp-old-pos exp-pos
X exp-token 'end
X exp-data "\000")
X (let ((ch (elt exp-str exp-pos)))
X (setq exp-old-pos exp-pos)
X (cond ((memq ch '(32 10))
X (setq exp-pos (1+ exp-pos))
X (if exp-keep-spaces
X (setq exp-token 'space
X exp-data " ")
X (math-read-token)))
X ((or (and (>= ch ?a) (<= ch ?z))
X (and (>= ch ?A) (<= ch ?Z)))
X (string-match (if (eq calc-language 'tex)
X "[a-zA-Z0-9']*"
X "[a-zA-Z0-9'_]*")
X exp-str exp-pos)
X (setq exp-token 'symbol
X exp-pos (match-end 0)
X exp-data (math-restore-dashes
X (math-match-substring exp-str 0))))
X ((or (and (>= ch ?0) (<= ch ?9))
X (memq ch '(?\. ?_)))
X (or (and (eq calc-language 'c)
X (string-match "0[xX][0-9a-fA-F]+" exp-str exp-pos))
X (string-match "_?\\([0-9]+.?0*@ *\\)?\\([0-9]+.?0*' *\\)?\\([0-9]+\\(#\\|\\^\\^\\)[0-9a-zA-Z:]+\\|[0-9]+:[0-9:]+\\|[0-9.]+\\([eE][-+_]?[0-9]+\\)?\"?\\)?" exp-str exp-pos))
X (setq exp-token 'number
X exp-data (math-match-substring exp-str 0)
X exp-pos (match-end 0)))
X ((eq ch ?\$)
X (string-match "\\$+" exp-str exp-pos)
X (setq exp-token 'dollar
X exp-data (- (match-end 0) (match-beginning 0))
X exp-pos (match-end 0)))
X ((eq (string-match "~=\\|<=\\|>=\\|<>\\|/=\\|\\+/-\\|\\\\dots\\|\\*\\*\\|<<\\|>>\\|==\\|!=\\|&&\\|||\\|!!"
X exp-str exp-pos)
X exp-pos)
X (setq exp-token 'punc
X exp-data (math-match-substring exp-str 0)
X exp-pos (match-end 0)))
X ((and (eq ch ?\")
X (string-match "\\(\"\\([^\"\\]\\|\\\\.\\)*\\)\\(\"\\|\\'\\)" exp-str exp-pos))
X (setq exp-token 'string
X exp-data (math-match-substring exp-str 1)
X exp-pos (match-end 0)))
X ((and (= ch ?\\) (eq calc-language 'tex))
X (or (string-match "\\\\hbox *{\\([a-zA-Z0-9]+\\)}" exp-str exp-pos)
X (string-match "\\(\\\\\\([a-zA-Z]+\\|[^a-zA-Z]\\)\\)" exp-str exp-pos))
X (setq exp-token 'symbol
X exp-pos (match-end 0)
X exp-data (math-restore-dashes
X (math-match-substring exp-str 1)))
X (if (or (equal exp-data "\\left")
X (equal exp-data "\\right"))
X (math-read-token)))
X (t
X (if (and (eq ch ?\{) (eq calc-language 'tex))
X (setq ch ?\())
X (if (and (eq ch ?\}) (eq calc-language 'tex))
X (setq ch ?\)))
X (setq exp-token 'punc
X exp-data (char-to-string ch)
X exp-pos (1+ exp-pos))))))
X)
X
X(defconst math-standard-opers
X '( ( "u+" ident -1 1000 )
X ( "u-" neg -1 1000 )
X ( "u!" calcFunc-lnot -1 1000 )
X ( "mod" mod 400 400 )
X ( "+/-" sdev 300 300 )
X ( "!" calcFunc-fact 210 -1 )
X ( "^" ^ 201 200 )
X ( "*" * 196 195 )
X ( "2x" * 196 195 )
X ( "/" / 190 191 )
X ( "%" % 190 191 )
X ( "\\" calcFunc-idiv 190 191 )
X ( "+" + 180 181 )
X ( "-" - 180 181 )
X ( "|" | 170 171 )
X ( "<" calcFunc-lt 160 161 )
X ( ">" calcFunc-gt 160 161 )
X ( "<=" calcFunc-leq 160 161 )
X ( ">=" calcFunc-geq 160 161 )
X ( "=" calcFunc-eq 160 161 )
X ( "==" calcFunc-eq 160 161 )
X ( "!=" calcFunc-neq 160 161 )
X ( "&&" calcFunc-land 110 111 )
X ( "||" calcFunc-lor 100 101 )
X ( "?" calcFunc-if 91 90 )
X))
X(setq math-expr-opers math-standard-opers)
X(setq math-expr-function-mapping nil)
X(setq math-expr-variable-mapping nil)
X
X(defun math-read-expr-level (exp-prec)
X (let* ((x (math-read-factor)) op)
X (while (and (or (and (setq op (assoc exp-data math-expr-opers))
X (/= (nth 2 op) -1))
X (and (or (eq (nth 2 op) -1)
X (memq exp-token '(symbol number dollar))
X (equal exp-data "(")
X (and (equal exp-data "[")
X (not (eq calc-language 'math))
X (not (and exp-keep-spaces
X (eq (car-safe x) 'vec)))))
X (setq op (assoc "2x" math-expr-opers))))
X (>= (nth 2 op) exp-prec))
X (if (not (equal (car op) "2x"))
X (math-read-token))
X (and (memq (nth 1 op) '(sdev mod))
X (calc-extensions))
X (setq x (cond ((eq (nth 3 op) -1)
X (if (eq (nth 1 op) 'ident)
X x
X (list (nth 1 op) x)))
X ((equal (car op) "?")
X (let ((y (math-read-expr-level 0)))
X (or (equal exp-data ":")
X (throw 'syntax "Expected ':'"))
X (math-read-token)
X (list (nth 1 op)
X x
X y
X (math-read-expr-level (nth 3 op)))))
X (t (list (nth 1 op)
X x
X (math-read-expr-level (nth 3 op)))))))
X x)
X)
X
X(defun math-remove-dashes (x)
X (if (string-match "\\`\\(.*\\)-\\(.*\\)\\'" x)
X (math-remove-dashes
X (concat (math-match-substring x 1) "_" (math-match-substring x 2)))
X x)
X)
X
X(defun math-restore-dashes (x)
X (if (string-match "\\`\\(.*\\)_\\(.*\\)\\'" x)
X (math-restore-dashes
X (concat (math-match-substring x 1) "-" (math-match-substring x 2)))
X x)
X)
X
X(defun math-read-factor ()
X (let (op)
X (cond ((eq exp-token 'number)
X (let ((num (math-read-number exp-data)))
X (if (not num)
X (progn
X (setq exp-old-pos exp-pos)
X (throw 'syntax "Bad format")))
X (math-read-token)
X (if (and math-read-expr-quotes
X (consp num))
X (list 'quote num)
X num)))
X ((or (equal exp-data "-")
X (equal exp-data "+")
X (equal exp-data "!")
X (equal exp-data "|"))
X (setq exp-data (concat "u" exp-data))
X (math-read-factor))
X ((and (setq op (assoc exp-data math-expr-opers))
X (eq (nth 2 op) -1))
X (math-read-token)
X (let ((val (math-read-expr-level (nth 3 op))))
X (cond ((eq (nth 1 op) 'ident)
X val)
X ((and (math-numberp val)
X (equal (car op) "u-"))
X (math-neg val))
X (t (list (nth 1 op) val)))))
X ((eq exp-token 'symbol)
X (let ((sym (intern exp-data)))
X (math-read-token)
X (if (equal exp-data calc-function-open)
X (progn
X (math-read-token)
X (let ((args (if (equal exp-data calc-function-close)
X nil
X (math-read-expr-list))))
X (if (not (or (equal exp-data calc-function-close)
X (eq exp-token 'end)))
X (throw 'syntax "Expected `)'"))
X (math-read-token)
X (let ((f (assq sym math-expr-function-mapping)))
X (if f
X (setq sym (cdr f))
X (or (string-match "-" (symbol-name sym))
X (setq sym (intern (concat "calcFunc-"
X (symbol-name sym)))))))
X (cons sym args)))
X (if math-read-expr-quotes
X sym
X (let ((val (list 'var
X (intern (math-remove-dashes
X (symbol-name sym)))
X (if (string-match "-" (symbol-name sym))
X sym
X (intern (concat "var-"
X (symbol-name sym)))))))
X (let ((v (assq (nth 1 val) math-expr-variable-mapping)))
X (and v (setq val (list 'var
X (intern
X (substring (symbol-name (cdr v)) 4))
X (cdr v)))))
X (while (and (memq calc-language '(c pascal))
X (equal exp-data "["))
X (math-read-token)
X (setq val (append (list 'calcFunc-subscr val)
X (math-read-expr-list)))
X (if (equal exp-data "]")
X (math-read-token)
X (throw 'syntax "Expected ']'")))
X val)))))
X ((eq exp-token 'dollar)
X (if (>= (length calc-dollar-values) exp-data)
X (let ((num exp-data))
X (math-read-token)
X (setq calc-dollar-used (max calc-dollar-used num))
X (math-check-complete (nth (1- num) calc-dollar-values)))
X (throw 'syntax (if calc-dollar-values
X "Too many $'s"
X "$'s not allowed in this context"))))
X ((equal exp-data "(")
X (let* ((exp (let ((exp-keep-spaces nil))
X (math-read-token)
X (math-read-expr-level 0))))
X (let ((exp-keep-spaces nil))
X (cond
X ((equal exp-data ",")
X (progn
X (math-read-token)
X (let ((exp2 (math-read-expr-level 0)))
X (setq exp
X (if (and exp2 (math-realp exp) (math-realp exp2))
X (math-normalize (list 'cplx exp exp2))
X (list '+ exp (list '* exp2 '(var i var-i))))))))
X ((equal exp-data ";")
X (progn
X (math-read-token)
X (let ((exp2 (math-read-expr-level 0)))
X (setq exp (if (and exp2 (math-realp exp)
X (math-anglep exp2))
X (math-normalize (list 'polar exp exp2))
X (list '* exp
X (list 'calcFunc-exp
X (list '* exp2
X '(var i var-i)))))))))
X ((equal exp-data "\\dots")
X (progn
X (math-read-token)
X (let ((exp2 (math-read-expr-level 0)))
X (setq exp
X (list 'intv
X (if (equal exp-data ")") 0 1)
X exp
X exp2)))))))
X (if (not (or (equal exp-data ")")
X (and (equal exp-data "]") (eq (car-safe exp) 'intv))
X (eq exp-token 'end)))
X (throw 'syntax "Expected `)'"))
X (math-read-token)
X exp))
X ((eq exp-token 'string)
X (calc-extensions)
X (math-read-string))
X ((equal exp-data "[")
X (calc-extensions)
X (math-read-brackets t "]"))
X ((equal exp-data "{")
X (calc-extensions)
X (math-read-brackets nil "}"))
X (t (throw 'syntax "Expected a number"))))
X)
X
X(defvar math-read-expr-quotes nil)
X
X
X
X
X;;; Bug reporting
X
X(defun report-calc-bug (topic)
X "Report a bug in Calc, the GNU Emacs calculator.
XPrompts for bug subject. Leaves you in a mail buffer."
X (interactive "sBug Subject: ")
X (mail nil calc-bug-address topic)
X (goto-char (point-max))
X (insert "\nIn Calc 1.01, Emacs " (emacs-version) "\n\n")
X (message (substitute-command-keys "Type \\[mail-send] to send bug report."))
X)
X
X
X
X;;; User-programmability.
X
X(defmacro defmath (func args &rest body) ; [Public]
X (calc-extensions)
X (math-do-defmath func args body)
X)
X
X
X
X(if calc-always-load-extensions
X (calc-extensions)
X)
X
X
X
X;;; End.
X
SHAR_EOF
echo "File calc.el is complete"
chmod 0664 calc.el || echo "restore of calc.el fails"
set `wc -c calc.el`;Sum=$1
if test "$Sum" != "124988"
then echo original size 124988, current size $Sum;fi
echo "x - extracting calc-ext.el (Text)"
sed 's/^X//' << 'SHAR_EOF' > calc-ext.el &&
X;; Calculator for GNU Emacs, part II
X;; Copyright (C) 1990 Dave Gillespie
X
X;; This file is part of GNU Emacs.
X
X;; GNU Emacs is distributed in the hope that it will be useful,
X;; but WITHOUT ANY WARRANTY. No author or distributor
X;; accepts responsibility to anyone for the consequences of using it
X;; or for whether it serves any particular purpose or works at all,
X;; unless he says so in writing. Refer to the GNU Emacs General Public
X;; License for full details.
X
X;; Everyone is granted permission to copy, modify and redistribute
X;; GNU Emacs, but only under the conditions described in the
X;; GNU Emacs General Public License. A copy of this license is
X;; supposed to have been given to you along with GNU Emacs so you
X;; can know your rights and responsibilities. It should be in a
X;; file named COPYING. Among other things, the copyright notice
X;; and this notice must be preserved on all copies.
X
X
X
X(provide 'calc-ext)
X
X(setq calc-extensions-loaded t)
X
X;;; This function is the autoload "hook" to cause this file to be loaded.
X(defun calc-extensions ()
X t
X)
X
X;;; Auto-load part I, in case this part was loaded first.
X(if (fboundp 'calc)
X (and (eq (car-safe (symbol-function 'calc)) 'autoload)
X (load (nth 1 (symbol-function 'calc))))
X (error "Main part of Calc must be present in order to load this file."))
X
X;;; If the following fails with "Cannot open load file: calc"
X;;; do "M-x load-file calc.elc" before compiling calc-ext.el.
X(require 'calc) ;;; This should only occur in the byte compiler.
X
X
X
X(progn
X (define-key calc-mode-map ":" 'calc-fdiv)
X (define-key calc-mode-map "\\" 'calc-idiv)
X (define-key calc-mode-map "|" 'calc-concat)
X (define-key calc-mode-map "!" 'calc-factorial)
X (define-key calc-mode-map "A" 'calc-abs)
X (define-key calc-mode-map "B" 'calc-log)
X (define-key calc-mode-map "C" 'calc-cos)
X (define-key calc-mode-map "D" 'calc-redo)
X (define-key calc-mode-map "E" 'calc-exp)
X (define-key calc-mode-map "F" 'calc-floor)
X (define-key calc-mode-map "G" 'calc-argument)
X (define-key calc-mode-map "H" 'calc-hyperbolic)
X (define-key calc-mode-map "I" 'calc-inverse)
X (define-key calc-mode-map "J" 'calc-conj)
X (define-key calc-mode-map "K" 'calc-call-last-kbd-macro)
X (define-key calc-mode-map "L" 'calc-ln)
X (define-key calc-mode-map "M" 'calc-more-recursion-depth)
X (define-key calc-mode-map "N" 'calc-eval-num)
X (define-key calc-mode-map "P" 'calc-pi)
X (define-key calc-mode-map "Q" 'calc-sqrt)
X (define-key calc-mode-map "R" 'calc-round)
X (define-key calc-mode-map "S" 'calc-sin)
X (define-key calc-mode-map "T" 'calc-tan)
X (define-key calc-mode-map "U" 'calc-undo)
X (define-key calc-mode-map "X" 'calc-last-x)
X (define-key calc-mode-map "l" 'calc-let)
X (define-key calc-mode-map "r" 'calc-recall)
X (define-key calc-mode-map "s" 'calc-store)
X (define-key calc-mode-map "x" 'calc-execute-extended-command)
X
X (define-key calc-mode-map "(" 'calc-begin-complex)
X (define-key calc-mode-map ")" 'calc-end-complex)
X (define-key calc-mode-map "[" 'calc-begin-vector)
X (define-key calc-mode-map "]" 'calc-end-vector)
X (define-key calc-mode-map "," 'calc-comma)
X (define-key calc-mode-map ";" 'calc-semi)
X (define-key calc-mode-map "`" 'calc-edit)
X (define-key calc-mode-map "=" 'calc-evaluate)
X (define-key calc-mode-map "~" 'calc-num-prefix)
X (define-key calc-mode-map "y" 'calc-copy-to-buffer)
X (define-key calc-mode-map "\C-k" 'calc-kill)
X (define-key calc-mode-map "\M-k" 'calc-copy-as-kill)
X (define-key calc-mode-map "\C-w" 'calc-kill-region)
X (define-key calc-mode-map "\M-w" 'calc-copy-region-as-kill)
X (define-key calc-mode-map "\C-y" 'calc-yank)
X (define-key calc-mode-map "\C-_" 'calc-undo)
X
X (define-key calc-mode-map "a" nil)
X (define-key calc-mode-map "a?" 'calc-a-prefix-help)
X (define-key calc-mode-map "ab" 'calc-substitute)
X (define-key calc-mode-map "ac" 'calc-collect)
X (define-key calc-mode-map "ad" 'calc-derivative)
X (define-key calc-mode-map "ae" 'calc-simplify-extended)
X (define-key calc-mode-map "ai" 'calc-integral)
X (define-key calc-mode-map "ar" 'calc-rewrite)
X (define-key calc-mode-map "as" 'calc-simplify)
X (define-key calc-mode-map "at" 'calc-taylor)
X (define-key calc-mode-map "ax" 'calc-expand)
X (define-key calc-mode-map "aI" 'calc-integral-limit)
X (define-key calc-mode-map "aS" 'calc-solve-for)
X (define-key calc-mode-map "a=" 'calc-equal-to)
X (define-key calc-mode-map "a#" 'calc-not-equal-to)
X (define-key calc-mode-map "a<" 'calc-less-than)
X (define-key calc-mode-map "a>" 'calc-greater-than)
X (define-key calc-mode-map "a[" 'calc-less-equal)
X (define-key calc-mode-map "a]" 'calc-greater-equal)
X (define-key calc-mode-map "a{" 'calc-in-set)
X (define-key calc-mode-map "a&" 'calc-logical-and)
X (define-key calc-mode-map "a|" 'calc-logical-or)
X (define-key calc-mode-map "a!" 'calc-logical-not)
X
X (define-key calc-mode-map "b" nil)
X (define-key calc-mode-map "b?" 'calc-b-prefix-help)
X (define-key calc-mode-map "ba" 'calc-and)
X (define-key calc-mode-map "bc" 'calc-clip)
X (define-key calc-mode-map "bd" 'calc-diff)
X (define-key calc-mode-map "bl" 'calc-lshift-binary)
X (define-key calc-mode-map "bn" 'calc-not)
X (define-key calc-mode-map "bo" 'calc-or)
X (define-key calc-mode-map "br" 'calc-rshift-binary)
X (define-key calc-mode-map "bR" 'calc-rotate-binary)
X (define-key calc-mode-map "bs" 'calc-shift-binary)
X (define-key calc-mode-map "bw" 'calc-word-size)
X (define-key calc-mode-map "bx" 'calc-xor)
X
X (define-key calc-mode-map "c" nil)
X (define-key calc-mode-map "c?" 'calc-c-prefix-help)
X (define-key calc-mode-map "c1" 'calc-clean-1)
X (define-key calc-mode-map "c2" 'calc-clean-2)
X (define-key calc-mode-map "c3" 'calc-clean-3)
X (define-key calc-mode-map "cc" 'calc-clean)
X (define-key calc-mode-map "cd" 'calc-to-degrees)
X (define-key calc-mode-map "cf" 'calc-float)
X (define-key calc-mode-map "ch" 'calc-to-hms)
X (define-key calc-mode-map "cp" 'calc-polar)
X (define-key calc-mode-map "cr" 'calc-to-radians)
X (define-key calc-mode-map "cF" 'calc-fraction)
X
X (define-key calc-mode-map "d" nil)
X (define-key calc-mode-map "d?" 'calc-d-prefix-help)
X (define-key calc-mode-map "d0" 'calc-decimal-radix)
X (define-key calc-mode-map "d2" 'calc-binary-radix)
X (define-key calc-mode-map "d6" 'calc-hex-radix)
X (define-key calc-mode-map "d8" 'calc-octal-radix)
X (define-key calc-mode-map "db" 'calc-line-breaking)
X (define-key calc-mode-map "dc" 'calc-complex-notation)
X (define-key calc-mode-map "de" 'calc-eng-notation)
X (define-key calc-mode-map "df" 'calc-fix-notation)
X (define-key calc-mode-map "dg" 'calc-group-digits)
X (define-key calc-mode-map "dh" 'calc-hms-notation)
X (define-key calc-mode-map "di" 'calc-i-notation)
X (define-key calc-mode-map "dj" 'calc-j-notation)
X (define-key calc-mode-map "dl" 'calc-line-numbering)
X (define-key calc-mode-map "dn" 'calc-normal-notation)
X (define-key calc-mode-map "do" 'calc-over-notation)
X (define-key calc-mode-map "dr" 'calc-radix)
X (define-key calc-mode-map "ds" 'calc-sci-notation)
X (define-key calc-mode-map "dt" 'calc-truncate-stack)
X (define-key calc-mode-map "dw" 'calc-auto-why)
X (define-key calc-mode-map "dz" 'calc-leading-zeros)
X (define-key calc-mode-map "dB" 'calc-big-language)
X (define-key calc-mode-map "dC" 'calc-c-language)
X (define-key calc-mode-map "dF" 'calc-fortran-language)
X (define-key calc-mode-map "dM" 'calc-mathematica-language)
X (define-key calc-mode-map "dN" 'calc-normal-language)
X (define-key calc-mode-map "dO" 'calc-flat-language)
X (define-key calc-mode-map "dP" 'calc-pascal-language)
X (define-key calc-mode-map "dT" 'calc-tex-language)
X (define-key calc-mode-map "dU" 'calc-unformatted-language)
X (define-key calc-mode-map "d[" 'calc-truncate-up)
X (define-key calc-mode-map "d]" 'calc-truncate-down)
X (define-key calc-mode-map "d." 'calc-point-char)
X (define-key calc-mode-map "d," 'calc-group-char)
X (define-key calc-mode-map "d\"" 'calc-display-strings)
X (define-key calc-mode-map "d<" 'calc-left-justify)
X (define-key calc-mode-map "d=" 'calc-center-justify)
X (define-key calc-mode-map "d>" 'calc-right-justify)
X (define-key calc-mode-map "d'" 'calc-display-raw)
X (define-key calc-mode-map "d`" 'calc-realign)
X (define-key calc-mode-map "d~" 'calc-refresh)
X
X (define-key calc-mode-map "k" nil)
X (define-key calc-mode-map "k?" 'calc-k-prefix-help)
X (define-key calc-mode-map "ka" 'calc-random-again)
X (define-key calc-mode-map "kb" 'calc-choose)
X (define-key calc-mode-map "kd" 'calc-double-factorial)
X (define-key calc-mode-map "kf" 'calc-prime-factors)
X (define-key calc-mode-map "kg" 'calc-gcd)
X (define-key calc-mode-map "kl" 'calc-lcm)
X (define-key calc-mode-map "km" 'calc-moebius)
X (define-key calc-mode-map "kn" 'calc-next-prime)
X (define-key calc-mode-map "kp" 'calc-prime-test)
X (define-key calc-mode-map "kr" 'calc-random)
X (define-key calc-mode-map "kt" 'calc-totient)
X (define-key calc-mode-map "kG" 'calc-extended-gcd)
X
X (define-key calc-mode-map "m" nil)
X (define-key calc-mode-map "m?" 'calc-m-prefix-help)
X (define-key calc-mode-map "ma" 'calc-algebraic-mode)
X (define-key calc-mode-map "md" 'calc-degrees-mode)
X (define-key calc-mode-map "mf" 'calc-frac-mode)
X (define-key calc-mode-map "mh" 'calc-hms-mode)
X (define-key calc-mode-map "mm" 'calc-save-modes)
X (define-key calc-mode-map "mp" 'calc-polar-mode)
X (define-key calc-mode-map "mr" 'calc-radians-mode)
X (define-key calc-mode-map "ms" 'calc-symbolic-mode)
X (define-key calc-mode-map "mw" 'calc-working)
X (define-key calc-mode-map "mx" 'calc-always-load-extensions)
X (define-key calc-mode-map "mA" 'calc-alg-simplify-mode)
X (define-key calc-mode-map "mB" 'calc-bin-simplify-mode)
X (define-key calc-mode-map "mD" 'calc-default-simplify-mode)
X (define-key calc-mode-map "mE" 'calc-ext-simplify-mode)
X (define-key calc-mode-map "mN" 'calc-num-simplify-mode)
X (define-key calc-mode-map "mO" 'calc-no-simplify-mode)
X (define-key calc-mode-map "mU" 'calc-units-simplify-mode)
X
X (define-key calc-mode-map "t" nil)
X (define-key calc-mode-map "t?" 'calc-t-prefix-help)
X (define-key calc-mode-map "tb" 'calc-trail-backward)
X (define-key calc-mode-map "td" 'calc-trail-display)
X (define-key calc-mode-map "tf" 'calc-trail-forward)
X (define-key calc-mode-map "th" 'calc-trail-here)
X (define-key calc-mode-map "ti" 'calc-trail-in)
X (define-key calc-mode-map "tk" 'calc-trail-kill)
X (define-key calc-mode-map "tm" 'calc-trail-marker)
X (define-key calc-mode-map "tn" 'calc-trail-next)
X (define-key calc-mode-map "to" 'calc-trail-out)
X (define-key calc-mode-map "tp" 'calc-trail-previous)
X (define-key calc-mode-map "tr" 'calc-trail-isearch-backward)
X (define-key calc-mode-map "ts" 'calc-trail-isearch-forward)
X (define-key calc-mode-map "ty" 'calc-trail-yank)
X (define-key calc-mode-map "t[" 'calc-trail-first)
X (define-key calc-mode-map "t]" 'calc-trail-last)
X (define-key calc-mode-map "t<" 'calc-trail-scroll-left)
X (define-key calc-mode-map "t>" 'calc-trail-scroll-right)
X
X (define-key calc-mode-map "u" 'nil)
X (define-key calc-mode-map "u?" 'calc-u-prefix-help)
X (define-key calc-mode-map "ub" 'calc-base-units)
X (define-key calc-mode-map "uc" 'calc-convert-units)
X (define-key calc-mode-map "ud" 'calc-define-unit)
X (define-key calc-mode-map "ue" 'calc-explain-units)
X (define-key calc-mode-map "ug" 'calc-get-unit-definition)
X (define-key calc-mode-map "up" 'calc-permanent-units)
X (define-key calc-mode-map "ur" 'calc-remove-units)
X (define-key calc-mode-map "us" 'calc-simplify-units)
X (define-key calc-mode-map "ut" 'calc-convert-temperature)
X (define-key calc-mode-map "uu" 'calc-undefine-unit)
X (define-key calc-mode-map "uv" 'calc-enter-units-table)
X (define-key calc-mode-map "ux" 'calc-extract-units)
X (define-key calc-mode-map "uV" 'calc-view-units-table)
X
X (define-key calc-mode-map "v" 'nil)
X (define-key calc-mode-map "v?" 'calc-v-prefix-help)
X (define-key calc-mode-map "va" 'calc-arrange-vector)
X (define-key calc-mode-map "vb" 'calc-build-vector)
X (define-key calc-mode-map "vc" 'calc-mcol)
X (define-key calc-mode-map "vd" 'calc-diag)
X (define-key calc-mode-map "vh" 'calc-histogram)
X (define-key calc-mode-map "vi" 'calc-ident)
X (define-key calc-mode-map "vl" 'calc-vlength)
X (define-key calc-mode-map "vn" 'calc-rnorm)
X (define-key calc-mode-map "vp" 'calc-pack)
X (define-key calc-mode-map "vr" 'calc-mrow)
X (define-key calc-mode-map "vs" 'calc-sort)
X (define-key calc-mode-map "vt" 'calc-transpose)
X (define-key calc-mode-map "vu" 'calc-unpack)
X (define-key calc-mode-map "vx" 'calc-index)
X (define-key calc-mode-map "vA" 'calc-apply)
X (define-key calc-mode-map "vC" 'calc-cross)
X (define-key calc-mode-map "vD" 'calc-mdet)
X (define-key calc-mode-map "vI" 'calc-inv)
X (define-key calc-mode-map "vJ" 'calc-conj-transpose)
X (define-key calc-mode-map "vL" 'calc-mlud)
X (define-key calc-mode-map "vM" 'calc-map)
X (define-key calc-mode-map "vN" 'calc-cnorm)
X (define-key calc-mode-map "vR" 'calc-reduce)
X (define-key calc-mode-map "vT" 'calc-mtrace)
X (define-key calc-mode-map "v<" 'calc-matrix-left-justify)
X (define-key calc-mode-map "v=" 'calc-matrix-center-justify)
X (define-key calc-mode-map "v>" 'calc-matrix-right-justify)
X (define-key calc-mode-map "v," 'calc-vector-commas)
X (define-key calc-mode-map "v[" 'calc-vector-brackets)
X (define-key calc-mode-map "v{" 'calc-vector-braces)
X (define-key calc-mode-map "v(" 'calc-vector-parens)
X (aset calc-mode-map ?V (aref calc-mode-map ?v))
X
X (define-key calc-mode-map "z" 'nil)
X (define-key calc-mode-map "z?" 'calc-z-prefix-help)
X
X (define-key calc-mode-map "Z" 'nil)
X (define-key calc-mode-map "Z?" 'calc-shift-Z-prefix-help)
X (define-key calc-mode-map "Zd" 'calc-user-define)
X (define-key calc-mode-map "Ze" 'calc-user-define-edit)
X (define-key calc-mode-map "Zf" 'calc-user-define-formula)
X (define-key calc-mode-map "Zg" 'calc-get-user-defn)
X (define-key calc-mode-map "Zk" 'calc-user-define-kbd-macro)
X (define-key calc-mode-map "Zp" 'calc-user-define-permanent)
X (define-key calc-mode-map "Zu" 'calc-user-undefine)
X (define-key calc-mode-map "Zv" 'calc-permanent-variable)
X (define-key calc-mode-map "Z[" 'calc-kbd-if)
X (define-key calc-mode-map "Z:" 'calc-kbd-else)
X (define-key calc-mode-map "Z|" 'calc-kbd-else-if)
X (define-key calc-mode-map "Z]" 'calc-kbd-end-if)
X (define-key calc-mode-map "Z<" 'calc-kbd-repeat)
X (define-key calc-mode-map "Z>" 'calc-kbd-end-repeat)
X (define-key calc-mode-map "Z(" 'calc-kbd-for)
X (define-key calc-mode-map "Z)" 'calc-kbd-end-for)
X (define-key calc-mode-map "Z{" 'calc-kbd-loop)
X (define-key calc-mode-map "Z}" 'calc-kbd-end-loop)
X (define-key calc-mode-map "Z/" 'calc-kbd-break)
X (define-key calc-mode-map "Z`" 'calc-kbd-push)
X (define-key calc-mode-map "Z'" 'calc-kbd-pop)
X (define-key calc-mode-map "Z=" 'calc-kbd-report)
X (define-key calc-mode-map "Z#" 'calc-kbd-query)
X
X)
X
X
X
X
X;;;; Miscellaneous.
X
X(defun calc-record-message (tag &rest args)
X (let ((msg (apply 'format args)))
X (message "%s" msg)
X (calc-record msg tag))
X (calc-clear-command-flag 'clear-message)
X)
X
X
X(defun calc-do-prefix-help (msgs group key)
X (if (cdr msgs)
X (progn
X (setq calc-prefix-help-phase
X (if (eq this-command last-command)
X (% (1+ calc-prefix-help-phase) (1+ (length msgs)))
X 0))
X (let ((msg (nth calc-prefix-help-phase msgs)))
X (message "%s" (if msg
X (concat group ": " msg ":"
X (make-string
X (- (apply 'max (mapcar 'length msgs))
X (length msg)) 32)
X " [MORE]"
X (if key
X (concat " " (char-to-string key) "-")
X ""))
X (format "%c-" key)))))
X (setq calc-prefix-help-phase 0)
X (if key
X (if msgs
X (message (concat group ": " (car msgs) ": "
X (char-to-string key) "-"))
X (message (concat group ": (none) " (char-to-string key) "-")))
X (message (concat group ": " (car msgs)))))
X (and key
X (setq unread-command-char key))
X)
X(defvar calc-prefix-help-phase 0)
X
X
X
X
X;;;; Commands.
X
X
X;;; General.
X
X(defun calc-inverse (&optional n)
X "Next Calculator operation is inverse."
X (interactive "P")
X (calc-wrapper
X (calc-set-command-flag 'keep-flags)
X (setq calc-inverse-flag (not calc-inverse-flag)
X prefix-arg n)
X (message (if calc-inverse-flag "Inverse..." "")))
X)
X
X(defun calc-invert-func ()
X (setq calc-inverse-flag (not (calc-is-inverse))
X calc-hyperbolic-flag (calc-is-hyperbolic)
X current-prefix-arg nil)
X)
X
X(defun calc-is-inverse ()
X calc-inverse-flag
X)
X
X(defun calc-hyperbolic (&optional n)
X "Next Calculator operation is hyperbolic."
X (interactive "P")
X (calc-wrapper
X (calc-set-command-flag 'keep-flags)
X (setq calc-hyperbolic-flag (not calc-hyperbolic-flag)
X prefix-arg n)
X (message (if calc-hyperbolic-flag "Hyperbolic..." "")))
X)
X
X(defun calc-hyperbolic-func ()
X (setq calc-inverse-flag (calc-is-inverse)
X calc-hyperbolic-flag (not (calc-is-hyperbolic))
X current-prefix-arg nil)
X)
X
X(defun calc-is-hyperbolic ()
X calc-hyperbolic-flag
X)
X
X
X(defun calc-evaluate (n)
X "Evaluate all variables in the expression on the top of the stack.
XWith a numeric prefix argument, evaluate each of the top N stack elements."
X (interactive "p")
X (calc-slow-wrapper
X (if (= n 0)
X (setq n (calc-stack-size)))
X (if (< n 0)
X (error "Argument must be positive"))
X (calc-with-default-simplification
X (calc-pop-push-record-list n "eval" (mapcar 'math-evaluate-expr
X (calc-top-list-n n))))
X (calc-handle-whys))
X)
X
X
X(defun calc-eval-num (n)
X "Evaluate numerically the expression on the top of the stack.
XThis is only necessary when the calculator is in Symbolic mode."
X (interactive "P")
X (calc-slow-wrapper
X (let* ((nn (prefix-numeric-value n))
X (calc-internal-prec (cond ((>= nn 3) nn)
X ((< nn 0) (max (+ calc-internal-prec nn)
X 3))
X (t calc-internal-prec)))
X (calc-symbolic-mode nil))
X (calc-with-default-simplification
X (calc-pop-push-record 1 "num" (math-evaluate-expr (calc-top-n 1)))))
X (calc-handle-whys))
X)
X
X
X(defun calc-execute-extended-command (n)
X "Just like M-x, but inserts \"calc-\" prefix automatically."
X (interactive "P")
X (let* ((prompt (concat (calc-num-prefix-name n) "M-x "))
X (cmd (intern (completing-read prompt obarray 'commandp t "calc-"))))
X (setq prefix-arg n)
X (command-execute cmd))
X)
X
X
X(defun calc-num-prefix (n)
X "Use the number at the top of stack as the numeric prefix for the next command.
XWith a prefix, push that prefix as a number onto the stack."
X (interactive "P")
X (calc-wrapper
X (if n
X (calc-enter-result 0 "" (prefix-numeric-value n))
X (let ((num (calc-top 1)))
X (if (math-messy-integerp num)
X (setq num (math-trunc num)))
X (or (integerp num)
X (error "Argument must be a small integer"))
X (calc-pop 1)
X (setq prefix-arg num)
X (message "%d-" num)))) ; a (lame) simulation of the real thing...
X)
X
X
X(defun calc-more-recursion-depth (n)
X "Double the max-lisp-eval-depth value, in case this limit is wrongly exceeded.
XThis also doubles max-specpdl-size."
X (interactive "P")
X (let ((n (if n (prefix-numeric-value n) 2)))
X (if (> n 1)
X (setq max-specpdl-size (* max-specpdl-size n)
X max-lisp-eval-depth (* max-lisp-eval-depth n))))
X (message "max-lisp-eval-depth is now %d" max-lisp-eval-depth)
X)
X
X(defun calc-less-recursion-depth (n)
X "Halve the max-lisp-eval-depth value, in case this limit is too high.
XThis also halves max-specpdl-size.
XLower limits are 200 and 600, respectively."
X (interactive "P")
X (let ((n (if n (prefix-numeric-value n) 2)))
X (if (> n 1)
X (setq max-specpdl-size
X (max (/ max-specpdl-size n) 600)
X max-lisp-eval-depth
X (max (/ max-lisp-eval-depth n) 200))))
X (message "max-lisp-eval-depth is now %d" max-lisp-eval-depth)
X)
X
X
X(defun calc-time ()
X "Push the current time of day on the stack as an HMS form.
X\(Why? Why not!)"
X (interactive)
X (calc-wrapper
X (let ((time (current-time-string)))
X (calc-enter-result 0 "time"
X (list 'mod
X (list 'hms
X (string-to-int (substring time 11 13))
X (string-to-int (substring time 14 16))
X (string-to-int (substring time 17 19)))
X (list 'hms 24 0 0)))))
X)
X
X
X
X;;; Incomplete forms.
X
X(defun calc-begin-complex ()
X "Begin entering a complex number in the Calculator."
X (interactive)
X (calc-wrapper
X (if calc-algebraic-mode
X (calc-alg-entry "(")
X (calc-push (list 'incomplete calc-complex-mode))))
X)
X
X(defun calc-end-complex ()
X "Complete a complex number being entered in the Calculator."
X (interactive)
X (calc-comma t)
X (calc-wrapper
X (let ((top (calc-top 1)))
X (if (and (eq (car-safe top) 'incomplete)
X (eq (nth 1 top) 'intv))
X (progn
X (while (< (length top) 5)
X (setq top (append top '(0))))
X (calc-enter-result 1 "..)" (cdr top)))
X (if (not (and (eq (car-safe top) 'incomplete)
X (memq (nth 1 top) '(cplx polar))))
X (error "Not entering a complex number"))
X (while (< (length top) 4)
X (setq top (append top '(0))))
X (if (not (and (math-realp (nth 2 top))
X (math-anglep (nth 3 top))))
X (error "Components must be real"))
X (calc-enter-result 1 "()" (cdr top)))))
X)
X
X(defun calc-begin-vector ()
X "Begin entering a vector in the Calculator."
X (interactive)
X (calc-wrapper
X (if calc-algebraic-mode
X (calc-alg-entry "[")
X (calc-push '(incomplete vec))))
X)
X
X(defun calc-end-vector ()
X "Complete a vector being entered in the Calculator."
X (interactive)
X (calc-comma t)
X (calc-wrapper
X (let ((top (calc-top 1)))
X (if (and (eq (car-safe top) 'incomplete)
X (eq (nth 1 top) 'intv))
X (progn
X (while (< (length top) 5)
X (setq top (append top '(0))))
X (setcar (cdr (cdr top)) (1+ (nth 2 top)))
X (calc-enter-result 1 "..]" (cdr top)))
X (if (not (and (eq (car-safe top) 'incomplete)
X (eq (nth 1 top) 'vec)))
X (error "Not entering a vector"))
X (calc-pop-push-record 1 "[]" (cdr top)))))
X)
X
X(defun calc-comma (&optional allow-polar)
X "Separate components of a complex number or vector during entry."
X (interactive)
X (calc-wrapper
X (let ((num (calc-find-first-incomplete
X (nthcdr calc-stack-top calc-stack) 1)))
X (if (= num 0)
X (error "Not entering a vector or complex number"))
X (let* ((inc (calc-top num))
X (stuff (calc-top-list (1- num)))
X (new (append inc stuff)))
X (if (and (null stuff)
X (not allow-polar)
X (or (eq (nth 1 inc) 'vec)
X (< (length new) 4)))
X (setq new (append new
X (if (= (length new) 2)
X '(0)
X (nthcdr (1- (length new)) new)))))
X (or allow-polar
X (if (eq (nth 1 inc) 'polar)
X (setq inc (append '(incomplete cplx) (cdr (cdr inc))))
X (if (eq (nth 1 inc) 'intv)
X (setq inc (append '(incomplete cplx)
X (cdr (cdr (cdr inc))))))))
X (if (and (memq (nth 1 new) '(cplx polar))
X (> (length new) 4))
X (error "Too many components in complex number"))
X (calc-pop-push num new))))
X)
X
X(defun calc-semi ()
X "Separate parts of a polar complex number or rows of a matrix during entry."
X (interactive)
X (calc-wrapper
X (let ((num (calc-find-first-incomplete
X (nthcdr calc-stack-top calc-stack) 1)))
X (if (= num 0)
X (error "Not entering a vector or complex number"))
X (let ((inc (calc-top num))
X (stuff (calc-top-list (1- num))))
X (if (eq (nth 1 inc) 'cplx)
X (setq inc (append '(incomplete polar) (cdr (cdr inc))))
X (if (eq (nth 1 inc) 'intv)
X (setq inc (append '(incomplete polar) (cdr (cdr (cdr inc)))))))
X (cond ((eq (nth 1 inc) 'polar)
X (let ((new (append inc stuff)))
X (if (> (length new) 4)
X (error "Too many components in complex number")
X (if (= (length new) 2)
X (setq new (append new '(1)))))
X (calc-pop-push num new)))
X ((null stuff)
X (if (> (length inc) 2)
X (if (math-vectorp (nth 2 inc))
X (calc-comma)
X (calc-pop-push 1
X (list 'incomplete 'vec (cdr (cdr inc)))
X (list 'incomplete 'vec)))))
X ((math-vectorp (car stuff))
X (calc-comma))
X ((eq (car-safe (car-safe (nth (+ num calc-stack-top)
X calc-stack))) 'incomplete)
X (calc-end-vector)
X (calc-comma)
X (let ((calc-algebraic-mode nil))
X (calc-begin-vector)))
X ((or (= (length inc) 2)
X (math-vectorp (nth 2 inc)))
X (calc-pop-push num
X (append inc (list (cons 'vec stuff)))
X (list 'incomplete 'vec)))
X (t
X (calc-pop-push num
X (list 'incomplete 'vec
X (cons 'vec (append (cdr (cdr inc)) stuff)))
X (list 'incomplete 'vec)))))))
X)
X
X(defun calc-dots ()
X "Separate parts of an interval form during entry with a \"..\" symbol."
X (interactive)
X (calc-wrapper
X (let ((num (calc-find-first-incomplete
X (nthcdr calc-stack-top calc-stack) 1)))
X (if (= num 0)
X (error "Not entering an interval form"))
X (let* ((inc (calc-top num))
X (stuff (calc-top-list (1- num)))
X (new (append inc stuff)))
X (if (not (eq (nth 1 new) 'intv))
X (setq new (append '(incomplete intv)
X (if (eq (nth 1 new) 'vec) '(2) '(0))
X (cdr (cdr new)))))
X (if (and (null stuff)
X (or (eq (nth 1 inc) 'vec)
X (< (length new) 5)))
X (setq new (append new
X (if (= (length new) 2)
X '(0)
X (nthcdr (1- (length new)) new)))))
X (if (> (length new) 5)
X (error "Too many components in interval form"))
X (calc-pop-push num new))))
X)
X
X(defun calc-find-first-incomplete (stack n)
X (cond ((null stack)
X 0)
X ((eq (car-safe (car-safe (car stack))) 'incomplete)
X n)
X (t
X (calc-find-first-incomplete (cdr stack) (1+ n))))
X)
X
X
X
X
X;;; Undo.
X
X(defun calc-undo (n)
X "Undo the most recent operation in the Calculator.
XWith a numeric prefix argument, undo the last N operations.
XWith a negative argument, same as calc-redo.
XWith a zero argument, same as calc-last-x."
X (interactive "p")
X (and calc-executing-macro
X (error "Use C-x e, not K, to run a keyboard macro that uses Undo."))
X (if (<= n 0)
X (if (< n 0)
X (calc-redo (- n))
X (calc-last-x 1))
X (calc-wrapper
X (if (null (nthcdr (1- n) calc-undo-list))
X (error "No further undo information available"))
X (setq calc-undo-list
X (prog1
X (nthcdr n calc-undo-list)
X (let ((saved-stack-top calc-stack-top))
X (let ((calc-stack-top 0))
X (calc-handle-undos calc-undo-list n))
X (setq calc-stack-top saved-stack-top))))
X (message "Undo!")))
X)
X
X(defun calc-handle-undos (cl n)
X (if (> n 0)
X (progn
X (let ((old-redo calc-redo-list))
X (setq calc-undo-list nil)
X (calc-handle-undo (car cl))
X (setq calc-redo-list (append calc-undo-list old-redo)))
X (calc-handle-undos (cdr cl) (1- n))))
X)
X
X(defun calc-handle-undo (list)
X (and list
X (let ((action (car list)))
X (cond
X ((eq (car action) 'push)
X (calc-pop-stack 1 (nth 1 action)))
X ((eq (car action) 'pop)
X (calc-push-list (nth 2 action) (nth 1 action)))
X ((eq (car action) 'set)
X (calc-record-undo (list 'set (nth 1 action)
X (symbol-value (nth 1 action))))
X (set (nth 1 action) (nth 2 action)))
X ((eq (car action) 'store)
X (let ((v (intern (nth 1 action))))
X (calc-record-undo (list 'store (nth 1 action)
X (and (boundp v) (symbol-value v))))
X (if (y-or-n-p (format "Un-store variable %s? " (nth 1 action)))
X (if (nth 2 action)
X (set v (nth 2 action))
X (makunbound v)))))
X ((eq (car action) 'eval)
X (calc-record-undo (append (list 'eval (nth 2 action) (nth 1 action))
X (cdr (cdr (cdr action)))))
X (apply (nth 1 action) (cdr (cdr (cdr action))))))
X (calc-handle-undo (cdr list))))
X)
X
X(defun calc-redo (n)
X "Redo a command which was just inadvertently undone."
X (interactive "p")
X (and calc-executing-macro
X (error "Use C-x e, not K, to run a keyboard macro that uses Redo."))
X (if (< n 0)
X (calc-undo (- n))
X (calc-wrapper
X (if (null (nthcdr (1- n) calc-redo-list))
X (error "Unable to redo"))
X (setq calc-redo-list
X (prog1
X (nthcdr n calc-redo-list)
X (let ((saved-stack-top calc-stack-top))
X (let ((calc-stack-top 0))
X (calc-handle-redos calc-redo-list n))
X (setq calc-stack-top saved-stack-top))))
X (message "Redo!")))
X)
X
X(defun calc-handle-redos (cl n)
X (if (> n 0)
X (progn
X (let ((old-undo calc-undo-list))
X (setq calc-undo-list nil)
X (calc-handle-undo (car cl))
X (setq calc-undo-list (append calc-undo-list old-undo)))
X (calc-handle-redos (cdr cl) (1- n))))
X)
X
X(defun calc-last-x (n)
X "Restore the arguments to the last command, without removing its result.
XWith a numeric prefix argument, restore the arguments of the Nth last
Xcommand which popped things from the stack."
X (interactive "p")
X (and calc-executing-macro
X (error "Use C-x e, not K, to run a keyboard macro that uses Last X."))
X (calc-wrapper
X (let ((urec (calc-find-last-x calc-undo-list n)))
X (if urec
X (calc-handle-last-x urec)
X (error "Not enough undo information available"))))
X)
X
X(defun calc-handle-last-x (list)
X (and list
X (let ((action (car list)))
X (if (eq (car action) 'pop)
X (calc-pop-push-record-list 0 "lstx"
X (delq 'top-of-stack (nth 2 action))))
X (calc-handle-last-x (cdr list))))
X)
X
X(defun calc-find-last-x (ul n)
X (and ul
X (if (calc-undo-does-pushes (car ul))
X (if (<= n 1)
X (car ul)
X (calc-find-last-x (cdr ul) (1- n)))
X (calc-find-last-x (cdr ul) n)))
X)
X
X(defun calc-undo-does-pushes (list)
X (and list
X (or (eq (car (car list)) 'pop)
X (calc-undo-does-pushes (cdr list))))
X)
X
X
X
X;;; Arithmetic.
X
X(defun calc-min (arg)
X "Compute the minimum of the top two elements of the Calculator stack."
X (interactive "P")
X (calc-slow-wrapper
X (calc-binary-op "min" 'calcFunc-min arg))
X)
X
X(defun calc-max (arg)
X "Compute the maximum of the top two elements of the Calculator stack."
X (interactive "P")
X (calc-slow-wrapper
X (calc-binary-op "max" 'calcFunc-max arg))
X)
X
X(defun calc-abs (arg)
X "Compute the absolute value of the top element of the Calculator stack."
X (interactive "P")
X (calc-slow-wrapper
X (calc-unary-op "abs" 'calcFunc-abs arg))
X)
X
X(defun calc-sqrt (arg)
X "Take the square root of the top element of the Calculator stack."
X (interactive "P")
X (calc-slow-wrapper
X (if (calc-is-inverse)
X (calc-unary-op "^2" 'calcFunc-sqr arg)
X (calc-unary-op "sqrt" 'calcFunc-sqrt arg)))
X)
X
X(defun calc-idiv (arg)
X "Compute the integer quotient of the top two elements of the stack."
X (interactive "P")
X (calc-slow-wrapper
X (calc-binary-op "\\" 'calcFunc-idiv arg 1))
X)
X
X(defun calc-fdiv (arg)
X "Compute the quotient (in fraction form) of the top two elements of the stack."
X (interactive "P")
X (calc-slow-wrapper
X (calc-binary-op ":" 'calcFunc-fdiv arg 1))
X)
X
X(defun calc-floor (arg)
X "Truncate to an integer (toward minus infinity) the top element of the stack.
XWith Inverse flag, truncates toward plus infinity.
XWith Hyperbolic flag, represent result in floating-point."
X (interactive "P")
X (calc-slow-wrapper
X (if (calc-is-inverse)
X (if (calc-is-hyperbolic)
X (calc-unary-op "ceil" 'calcFunc-fceil arg)
X (calc-unary-op "ceil" 'calcFunc-ceil arg))
X (if (calc-is-hyperbolic)
X (calc-unary-op "flor" 'calcFunc-ffloor arg)
X (calc-unary-op "flor" 'calcFunc-floor arg))))
SHAR_EOF
echo "End of part 3"
echo "File calc-ext.el is continued in part 4"
echo "4" > s2_seq_.tmp
exit 0