-;; Calculator for GNU Emacs, part II [calc-prog.el]
-;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
-;; Written by Dave Gillespie, daveg@synaptics.com.
+;;; calc-prog.el --- user programmability functions for Calc
+
+;; Copyright (C) 1990-1993, 2001-2015 Free Software Foundation, Inc.
+
+;; Author: David Gillespie <daveg@synaptics.com>
;; This file is part of GNU Emacs.
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY. No author or distributor
-;; accepts responsibility to anyone for the consequences of using it
-;; or for whether it serves any particular purpose or works at all,
-;; unless he says so in writing. Refer to the GNU Emacs General Public
-;; License for full details.
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
-;; Everyone is granted permission to copy, modify and redistribute
-;; GNU Emacs, but only under the conditions described in the
-;; GNU Emacs General Public License. A copy of this license is
-;; supposed to have been given to you along with GNU Emacs so you
-;; can know your rights and responsibilities. It should be in a
-;; file named COPYING. Among other things, the copyright notice
-;; and this notice must be preserved on all copies.
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+;;; Commentary:
+;;; Code:
;; This file is autoloaded from calc-ext.el.
-(require 'calc-ext)
+(require 'calc-ext)
(require 'calc-macs)
-
-(defun calc-Need-calc-prog () nil)
-
+(autoload 'edmacro-format-keys "edmacro")
+(autoload 'edmacro-parse-keys "edmacro")
(defun calc-equal-to (arg)
(interactive "P")
(calc-wrapper
(if (and (integerp arg) (> arg 2))
(calc-enter-result arg "eq" (cons 'calcFunc-eq (calc-top-list-n arg)))
- (calc-binary-op "eq" 'calcFunc-eq arg)))
-)
+ (calc-binary-op "eq" 'calcFunc-eq arg))))
(defun calc-remove-equal (arg)
(interactive "P")
(calc-wrapper
- (calc-unary-op "rmeq" 'calcFunc-rmeq arg))
-)
+ (calc-unary-op "rmeq" 'calcFunc-rmeq arg)))
(defun calc-not-equal-to (arg)
(interactive "P")
(calc-wrapper
(if (and (integerp arg) (> arg 2))
(calc-enter-result arg "neq" (cons 'calcFunc-neq (calc-top-list-n arg)))
- (calc-binary-op "neq" 'calcFunc-neq arg)))
-)
+ (calc-binary-op "neq" 'calcFunc-neq arg))))
(defun calc-less-than (arg)
(interactive "P")
(calc-wrapper
- (calc-binary-op "lt" 'calcFunc-lt arg))
-)
+ (calc-binary-op "lt" 'calcFunc-lt arg)))
(defun calc-greater-than (arg)
(interactive "P")
(calc-wrapper
- (calc-binary-op "gt" 'calcFunc-gt arg))
-)
+ (calc-binary-op "gt" 'calcFunc-gt arg)))
(defun calc-less-equal (arg)
(interactive "P")
(calc-wrapper
- (calc-binary-op "leq" 'calcFunc-leq arg))
-)
+ (calc-binary-op "leq" 'calcFunc-leq arg)))
(defun calc-greater-equal (arg)
(interactive "P")
(calc-wrapper
- (calc-binary-op "geq" 'calcFunc-geq arg))
-)
+ (calc-binary-op "geq" 'calcFunc-geq arg)))
(defun calc-in-set (arg)
(interactive "P")
(calc-wrapper
- (calc-binary-op "in" 'calcFunc-in arg))
-)
+ (calc-binary-op "in" 'calcFunc-in arg)))
(defun calc-logical-and (arg)
(interactive "P")
(calc-wrapper
- (calc-binary-op "land" 'calcFunc-land arg 1))
-)
+ (calc-binary-op "land" 'calcFunc-land arg 1)))
(defun calc-logical-or (arg)
(interactive "P")
(calc-wrapper
- (calc-binary-op "lor" 'calcFunc-lor arg 0))
-)
+ (calc-binary-op "lor" 'calcFunc-lor arg 0)))
(defun calc-logical-not (arg)
(interactive "P")
(calc-wrapper
- (calc-unary-op "lnot" 'calcFunc-lnot arg))
-)
+ (calc-unary-op "lnot" 'calcFunc-lnot arg)))
(defun calc-logical-if ()
(interactive)
(calc-wrapper
- (calc-enter-result 3 "if" (cons 'calcFunc-if (calc-top-list-n 3))))
-)
+ (calc-enter-result 3 "if" (cons 'calcFunc-if (calc-top-list-n 3)))))
(calc-wrapper
(calc-change-mode 'calc-timing n nil t)
(message (if calc-timing
- "Reporting timing of slow commands in Trail."
- "Not reporting timing of commands.")))
-)
-
-(defun calc-pass-errors ()
- (interactive)
- ;; The following two cases are for the new, optimizing byte compiler
- ;; or the standard 18.57 byte compiler, respectively.
- (condition-case err
- (let ((place (aref (nth 2 (nth 2 (symbol-function 'calc-do))) 15)))
- (or (memq (car-safe (car-safe place)) '(error xxxerror))
- (setq place (aref (nth 2 (nth 2 (symbol-function 'calc-do))) 27)))
- (or (memq (car (car place)) '(error xxxerror))
- (error "foo"))
- (setcar (car place) 'xxxerror))
- (error (error "The calc-do function has been modified; unable to patch.")))
-)
+ "Reporting timing of slow commands in Trail"
+ "Not reporting timing of commands"))))
(defun calc-user-define ()
(interactive)
'commandp
t
"calc-"))))
- (let* ((kmap (calc-user-key-map))
- (old (assq key kmap)))
- (if old
- (setcdr old func)
- (setcdr kmap (cons (cons key func) (cdr kmap)))))))
-)
+
+ (define-key calc-z-map (char-to-string key) func))))
(defun calc-user-undefine ()
(interactive)
(let ((key (read-char)))
(if (= (calc-user-function-classify key) 0)
(error "Can't undefine \"?\" key"))
- (let* ((kmap (calc-user-key-map)))
- (delq (or (assq key kmap)
- (assq (upcase key) kmap)
- (assq (downcase key) kmap)
- (error "No such user key is defined"))
- kmap)))
-)
+ (define-key calc-z-map
+ (or (lookup-key calc-z-map key)
+ (lookup-key calc-z-map (upcase key))
+ (lookup-key calc-z-map (downcase key))
+ (error "No such user key is defined"))
+ nil)))
+
+
+;; math-integral-cache-state is originally declared in calcalg2.el,
+;; it is used in calc-user-define-variable.
+(defvar math-integral-cache-state)
+
+;; calc-user-formula-alist is local to calc-user-define-formula,
+;; calc-user-define-composition and calc-finish-formula-edit,
+;; but is used by calc-fix-user-formula.
+(defvar calc-user-formula-alist)
(defun calc-user-define-formula ()
(interactive)
(calc-wrapper
(let* ((form (calc-top 1))
- (arglist nil)
+ (math-arglist nil)
(is-lambda (and (eq (car-safe form) 'calcFunc-lambda)
(>= (length form) 2)))
- odef key keyname cmd cmd-base func alist is-symb)
+ odef key keyname cmd cmd-base cmd-base-default
+ func calc-user-formula-alist is-symb)
(if is-lambda
- (setq arglist (mapcar (function (lambda (x) (nth 1 x)))
+ (setq math-arglist (mapcar (function (lambda (x) (nth 1 x)))
(nreverse (cdr (reverse (cdr form)))))
form (nth (1- (length form)) form))
(calc-default-formula-arglist form)
- (setq arglist (sort arglist 'string-lessp)))
+ (setq math-arglist (sort math-arglist 'string-lessp)))
(message "Define user key: z-")
(setq key (read-char))
(if (= (calc-user-function-classify key) 0)
(error "Can't redefine \"?\" key"))
- (setq key (and (not (memq key '(?\r ? ))) key)
+ (setq key (and (not (memq key '(13 32))) key)
keyname (and key
(if (or (and (<= ?0 key) (<= key ?9))
(and (<= ?a key) (<= key ?z))
(and (<= ?A key) (<= key ?Z)))
(char-to-string key)
(format "%03d" key)))
- odef (assq key (calc-user-key-map)))
+ odef (lookup-key calc-z-map key))
+ (unless keyname
+ (setq keyname (format "%05d" (abs (% (random) 10000)))))
(while
(progn
- (setq cmd (completing-read "Define M-x command name: "
- obarray 'commandp nil
- (if (and odef (symbolp (cdr odef)))
- (symbol-name (cdr odef))
- "calc-"))
- cmd-base (and (string-match "\\`calc-\\(.+\\)\\'" cmd)
- (math-match-substring cmd 1))
- cmd (and (not (or (string-equal cmd "")
- (string-equal cmd "calc-")))
- (intern cmd)))
+ (setq cmd-base-default (concat "User-" keyname))
+ (setq cmd (completing-read
+ (concat "Define M-x command name (default calc-"
+ cmd-base-default
+ "): ")
+ obarray 'commandp nil
+ (if (and odef (symbolp odef))
+ (symbol-name odef)
+ "calc-")))
+ (if (or (string-equal cmd "")
+ (string-equal cmd "calc-"))
+ (setq cmd (concat "calc-User-" keyname)))
+ (setq cmd-base (and (string-match "\\`calc-\\(.+\\)\\'" cmd)
+ (math-match-substring cmd 1)))
+ (setq cmd (intern cmd))
(and cmd
(fboundp cmd)
odef
(concat "Replace previous definition for "
(symbol-name cmd) "? ")
"That name conflicts with a built-in Emacs function. Replace this function? "))))))
- (if (and key (not cmd))
- (setq cmd (intern (concat "calc-User-" keyname))))
(while
(progn
- (setq func (completing-read "Define algebraic function name: "
- obarray 'fboundp nil
- (concat "calcFunc-"
- (if cmd-base
- (if (string-match
- "\\`User-.+" cmd-base)
- (concat
- "User"
- (substring cmd-base 5))
- cmd-base)
- "")))
- func (and (not (or (string-equal func "")
- (string-equal func "calcFunc-")))
- (intern func)))
+ (setq cmd-base-default
+ (if cmd-base
+ (if (string-match
+ "\\`User-.+" cmd-base)
+ (concat
+ "User"
+ (substring cmd-base 5))
+ cmd-base)
+ (concat "User" keyname)))
+ (setq func
+ (concat "calcFunc-"
+ (completing-read
+ (concat "Define algebraic function name (default "
+ cmd-base-default "): ")
+ (mapcar (lambda (x) (substring x 9))
+ (all-completions "calcFunc-"
+ obarray))
+ (lambda (x)
+ (fboundp
+ (intern (concat "calcFunc-" x))))
+ nil)))
+ (setq func
+ (if (string-equal func "calcFunc-")
+ (intern (concat "calcFunc-" cmd-base-default))
+ (intern func)))
(and func
(fboundp func)
(not (fboundp cmd))
(concat "Replace previous definition for "
(symbol-name func) "? ")
"That name conflicts with a built-in Emacs function. Replace this function? "))))))
+
(if (not func)
(setq func (intern (concat "calcFunc-User"
(or keyname
(and cmd (symbol-name cmd))
(format "%05d" (% (random) 10000)))))))
+
(if is-lambda
- (setq alist arglist)
+ (setq calc-user-formula-alist math-arglist)
(while
(progn
- (setq alist (read-from-minibuffer "Function argument list: "
- (if arglist
- (prin1-to-string arglist)
- "()")
- minibuffer-local-map
- t))
- (and (not (calc-subsetp alist arglist))
+ (setq calc-user-formula-alist
+ (read-from-minibuffer "Function argument list: "
+ (if math-arglist
+ (prin1-to-string math-arglist)
+ "()")
+ minibuffer-local-map
+ t))
+ (and (not (calc-subsetp calc-user-formula-alist math-arglist))
(not (y-or-n-p
"Okay for arguments that don't appear in formula to be ignored? "))))))
- (setq is-symb (and alist
+ (setq is-symb (and calc-user-formula-alist
func
(y-or-n-p
"Leave it symbolic for non-constant arguments? ")))
- (setq alist (mapcar (function (lambda (x)
- (or (cdr (assq x '((nil . arg-nil)
- (t . arg-t))))
- x))) alist))
+ (setq calc-user-formula-alist
+ (mapcar (function (lambda (x)
+ (or (cdr (assq x '((nil . arg-nil)
+ (t . arg-t))))
+ x))) calc-user-formula-alist))
(if cmd
(progn
- (calc-need-macros)
+ (require 'calc-macs)
(fset cmd
(list 'lambda
'()
'(interactive)
(list 'calc-wrapper
(list 'calc-enter-result
- (length alist)
+ (length calc-user-formula-alist)
(let ((name (symbol-name (or func cmd))))
(and (string-match
"\\([^-][^-]?[^-]?[^-]?\\)[^-]*\\'"
(list 'cons
(list 'quote func)
(list 'calc-top-list-n
- (length alist)))))))
+ (length calc-user-formula-alist)))))))
(put cmd 'calc-user-defn t)))
(let ((body (list 'math-normalize (calc-fix-user-formula form))))
(fset func
(append
- (list 'lambda alist)
+ (list 'lambda calc-user-formula-alist)
(and is-symb
(mapcar (function (lambda (v)
(list 'math-check-const v t)))
- alist))
+ calc-user-formula-alist))
(list body))))
(put func 'calc-user-defn form)
(setq math-integral-cache-state nil)
- (if key
- (let* ((kmap (calc-user-key-map))
- (old (assq key kmap)))
- (if old
- (setcdr old cmd)
- (setcdr kmap (cons (cons key cmd) (cdr kmap)))))))
- (message ""))
-)
+ (define-key calc-z-map (char-to-string key) cmd))))
+
+(defvar math-arglist) ; dynamically bound in all callers
(defun calc-default-formula-arglist (form)
(if (consp form)
(if (eq (car form) 'var)
- (if (or (memq (nth 1 form) arglist)
+ (if (or (memq (nth 1 form) math-arglist)
(math-const-var form))
()
- (setq arglist (cons (nth 1 form) arglist)))
- (calc-default-formula-arglist-step (cdr form))))
-)
+ (setq math-arglist (cons (nth 1 form) math-arglist)))
+ (calc-default-formula-arglist-step (cdr form)))))
(defun calc-default-formula-arglist-step (l)
(and l
(progn
(calc-default-formula-arglist (car l))
- (calc-default-formula-arglist-step (cdr l))))
-)
+ (calc-default-formula-arglist-step (cdr l)))))
(defun calc-subsetp (a b)
(or (null a)
(and (memq (car a) b)
- (calc-subsetp (cdr a) b)))
-)
+ (calc-subsetp (cdr a) b))))
(defun calc-fix-user-formula (f)
(if (consp f)
(memq (setq temp (or (cdr (assq (nth 1 f) '((nil . arg-nil)
(t . arg-t))))
(nth 1 f)))
- alist))
+ calc-user-formula-alist))
temp)
((or (math-constp f) (eq (car f) 'var))
(list 'quote f))
(cons 'list
(cons (list 'quote (car f))
(mapcar 'calc-fix-user-formula (cdr f)))))))
- f)
-)
+ f))
(defun calc-user-define-composition ()
(interactive)
(if (eq calc-language 'unform)
(error "Can't define formats for unformatted mode"))
(let* ((comp (calc-top 1))
- (func (intern (completing-read "Define format for which function: "
- obarray 'fboundp nil "calcFunc-")))
+ (func (intern
+ (concat "calcFunc-"
+ (completing-read "Define format for which function: "
+ (mapcar (lambda (x) (substring x 9))
+ (all-completions "calcFunc-"
+ obarray))
+ (lambda (x)
+ (fboundp
+ (intern (concat "calcFunc-" x))))))))
(comps (get func 'math-compose-forms))
entry entry2
- (arglist nil)
- (alist nil))
+ (math-arglist nil)
+ (calc-user-formula-alist nil))
(if (math-zerop comp)
(if (setq entry (assq calc-language comps))
(put func 'math-compose-forms (delq entry comps)))
(calc-default-formula-arglist comp)
- (setq arglist (sort arglist 'string-lessp))
+ (setq math-arglist (sort math-arglist 'string-lessp))
(while
(progn
- (setq alist (read-from-minibuffer "Composition argument list: "
- (if arglist
- (prin1-to-string arglist)
- "()")
- minibuffer-local-map
- t))
- (and (not (calc-subsetp alist arglist))
+ (setq calc-user-formula-alist
+ (read-from-minibuffer "Composition argument list: "
+ (if math-arglist
+ (prin1-to-string math-arglist)
+ "()")
+ minibuffer-local-map
+ t))
+ (and (not (calc-subsetp calc-user-formula-alist math-arglist))
(y-or-n-p
"Okay for arguments that don't appear in formula to be invisible? "))))
(or (setq entry (assq calc-language comps))
(put func 'math-compose-forms
(cons (setq entry (list calc-language)) comps)))
- (or (setq entry2 (assq (length alist) (cdr entry)))
+ (or (setq entry2 (assq (length calc-user-formula-alist) (cdr entry)))
(setcdr entry
- (cons (setq entry2 (list (length alist))) (cdr entry))))
- (setcdr entry2 (list 'lambda alist (calc-fix-user-formula comp))))
+ (cons (setq entry2
+ (list (length calc-user-formula-alist))) (cdr entry))))
+ (setcdr entry2
+ (list 'lambda calc-user-formula-alist (calc-fix-user-formula comp))))
(calc-pop-stack 1)
- (calc-do-refresh)))
-)
+ (calc-do-refresh))))
(defun calc-user-define-kbd-macro (arg)
last-kbd-macro)
'arg
(format "z%c" key)))))
- (let* ((kmap (calc-user-key-map))
- (old (assq key kmap)))
- (if old
- (setcdr old cmd)
- (setcdr kmap (cons (cons key cmd) (cdr kmap)))))))
-)
+ (define-key calc-z-map (char-to-string key) cmd))))
(defun calc-edit-user-syntax ()
(interactive)
(let ((lang calc-language))
(calc-edit-mode (list 'calc-finish-user-syntax-edit (list 'quote lang))
t
- (format "Editing %s-Mode Syntax Table"
+ (format "Editing %s-Mode Syntax Table. "
(cond ((null lang) "Normal")
((eq lang 'tex) "TeX")
+ ((eq lang 'latex) "LaTeX")
(t (capitalize (symbol-name lang))))))
(calc-write-parse-table (cdr (assq lang calc-user-parse-tables))
lang)))
- (calc-show-edit-buffer)
-)
+ (calc-show-edit-buffer))
+
+(defvar calc-original-buffer)
(defun calc-finish-user-syntax-edit (lang)
(let ((tab (calc-read-parse-table calc-original-buffer lang))
(if entry
(setq calc-user-parse-tables
(delq entry calc-user-parse-tables)))))
- (switch-to-buffer calc-original-buffer)
-)
+ (switch-to-buffer calc-original-buffer))
+
+;; The variable calc-lang is local to calc-write-parse-table, but is
+;; used by calc-write-parse-table-part which is called by
+;; calc-write-parse-table. The variable is also local to
+;; calc-read-parse-table, but is used by calc-fix-token-name which
+;; is called (indirectly) by calc-read-parse-table.
+(defvar calc-lang)
(defun calc-write-parse-table (tab calc-lang)
(let ((p tab))
(let ((math-format-hash-args t))
(math-format-flat-expr (cdr (car p)) 0))
"\n")
- (setq p (cdr p))))
-)
+ (setq p (cdr p)))))
(defun calc-write-parse-table-part (p)
(while p
(cond ((stringp (car p))
(let ((s (car p)))
(if (and (string-match "\\`\\\\dots\\>" s)
- (not (eq calc-lang 'tex)))
+ (not (memq calc-lang '(tex latex))))
(setq s (concat ".." (substring s 5))))
(if (or (and (string-match
"[a-zA-Z0-9\"{}]\\|\\`:=\\'\\|\\`#\\|\\`%%" s)
(if (nth 2 (car p))
(calc-write-parse-table-part (list (car (nth 2 (car p)))))
(insert " "))))
- (setq p (cdr p)))
-)
+ (setq p (cdr p))))
(defun calc-read-parse-table (calc-buf calc-lang)
(let ((tab nil))
(let ((pos (point)))
(end-of-line)
(let* ((str (buffer-substring pos (point)))
- (exp (save-excursion
- (set-buffer calc-buf)
+ (exp (with-current-buffer calc-buf
(let ((calc-user-parse-tables nil)
(calc-language nil)
- (math-expr-opers math-standard-opers)
+ (math-expr-opers (math-standard-ops))
(calc-hashes-used 0))
(math-read-expr
(if (string-match ",[ \t]*\\'" str)
(goto-char (+ pos (nth 1 exp)))
(error (nth 2 exp))))
(setq tab (nconc tab (list (cons p exp)))))))))
- tab)
-)
+ tab))
(defun calc-fix-token-name (name &optional unquoted)
(cond ((string-match "\\`\\.\\." name)
(concat "\\dots" (substring name 2)))
- ((and (equal name "{") (memq calc-lang '(tex eqn)))
+ ((and (equal name "{") (memq calc-lang '(tex latex eqn)))
"(")
- ((and (equal name "}") (memq calc-lang '(tex eqn)))
+ ((and (equal name "}") (memq calc-lang '(tex latex eqn)))
")")
- ((and (equal name "&") (eq calc-lang 'tex))
+ ((and (equal name "&") (memq calc-lang '(tex latex)))
",")
((equal name "#")
(search-backward "#")
- (error "Token '#' is reserved"))
+ (error "Token `#' is reserved"))
((and unquoted (string-match "#" name))
- (error "Tokens containing '#' must be quoted"))
+ (error "Tokens containing `#' must be quoted"))
((not (string-match "[^ ]" name))
(search-backward "\"" nil t)
(error "Blank tokens are not allowed"))
- (t name))
-)
+ (t name)))
(defun calc-read-parse-table-part (term eterm)
(let ((part nil)
(quoted nil))
(while (progn
(skip-chars-forward "\n\t ")
- (if (eobp) (error "Expected '%s'" eterm))
+ (if (eobp) (error "Expected `%s'" eterm))
(not (looking-at term)))
(cond ((looking-at "%%")
(end-of-line))
(forward-char 2)
(let ((p (calc-read-parse-table-part "}" "}")))
(or (looking-at "[+*?]")
- (error "Expected '+', '*', or '?'"))
+ (error "Expected `+', `*', or `?'"))
(let ((sym (intern (buffer-substring (point) (1+ (point))))))
(forward-char 1)
(looking-at "[^\n\t ]*")
(error "Separator not allowed with { ... }?"))
(if (string-match "\\`\"" sep)
(setq sep (read-from-string sep)))
- (setq sep (calc-fix-token-name sep))
+ (if (> (length sep) 0)
+ (setq sep (calc-fix-token-name sep)))
(setq part (nconc part
(list (list sym p
(and (> (length sep) 0)
(setq part (nconc part (list (if (= (match-beginning 1)
(match-end 1))
0
- (string-to-int
+ (string-to-number
(buffer-substring
(1+ (match-beginning 1))
(match-end 1)))))))
(goto-char (match-end 0)))
((looking-at ":=[\n\t ]")
- (error "Misplaced ':='"))
+ (error "Misplaced `:='"))
(t
(looking-at "[^\n\t ]*")
(let ((end (match-end 0)))
(not (eq (car last) quoted))
(setcar last
(list '\? (list (car last)) '("$$"))))))))
- part)
-)
-
+ part))
(defun calc-user-define-invocation ()
(interactive)
(or last-kbd-macro
(error "No keyboard macro defined"))
(setq calc-invocation-macro last-kbd-macro)
- (message "Use `M-# Z' to invoke this macro")
-)
-
+ (message "Use `C-x * Z' to invoke this macro"))
-(defun calc-user-define-edit (prefix)
- (interactive "P") ; but no calc-wrapper!
+(defun calc-user-define-edit ()
+ (interactive) ; but no calc-wrapper!
(message "Edit definition of command: z-")
- (let* ((key (read-char))
- (def (or (assq key (calc-user-key-map))
- (assq (upcase key) (calc-user-key-map))
- (assq (downcase key) (calc-user-key-map))
- (error "No command defined for that key")))
- (cmd (cdr def)))
- (if (symbolp cmd)
- (setq cmd (symbol-function cmd)))
+ (let* (cmdname
+ (key (read-char))
+ (cmd (or (lookup-key calc-z-map key)
+ (lookup-key calc-z-map (upcase key))
+ (lookup-key calc-z-map (downcase key))
+ (error "No command defined for that key"))))
+ (when (symbolp cmd)
+ (setq cmdname (symbol-name cmd))
+ (setq cmd (symbol-function cmd)))
(cond ((or (stringp cmd)
(and (consp cmd)
(eq (car-safe (nth 3 cmd)) 'calc-execute-kbd-macro)))
- (if (and (>= (prefix-numeric-value prefix) 0)
- (fboundp 'edit-kbd-macro)
- (symbolp (cdr def))
- (eq major-mode 'calc-mode))
- (progn
- (if (and (< (window-width) (frame-width))
- calc-display-trail)
- (let ((win (get-buffer-window (calc-trail-buffer))))
- (if win
- (delete-window win))))
- (edit-kbd-macro (cdr def) prefix nil
- (function
- (lambda (x)
- (and calc-display-trail
- (calc-wrapper
- (calc-trail-display 1 t)))))
- (function
- (lambda (cmd)
- (if (stringp (symbol-function cmd))
- (symbol-function cmd)
- (let ((mac (nth 1 (nth 3 (symbol-function
- cmd)))))
- (if (vectorp mac)
- (aref mac 1)
- mac)))))
- (function
- (lambda (new cmd)
- (if (stringp (symbol-function cmd))
- (fset cmd new)
- (let ((mac (cdr (nth 3 (symbol-function
- cmd)))))
- (if (vectorp (car mac))
- (progn
- (aset (car mac) 0
- (key-description new))
- (aset (car mac) 1 new))
- (setcar mac new))))))))
- (let ((keys (progn (and (fboundp 'edit-kbd-macro)
- (edit-kbd-macro nil))
- (fboundp 'MacEdit-parse-keys))))
- (calc-wrapper
- (calc-edit-mode (list 'calc-finish-macro-edit
- (list 'quote def)
- keys)
- t)
- (if keys
- (let (top
- (fill-column 70)
- (fill-prefix nil))
- (insert "Notations: RET, SPC, TAB, DEL, LFD, NUL"
- ", C-xxx, M-xxx.\n\n")
- (setq top (point))
- (insert (if (stringp cmd)
- (key-description cmd)
- (if (vectorp (nth 1 (nth 3 cmd)))
- (aref (nth 1 (nth 3 cmd)) 0)
- (key-description (nth 1 (nth 3 cmd)))))
- "\n")
- (if (>= (prog2 (forward-char -1)
- (current-column)
- (forward-char 1))
- (frame-width))
- (fill-region top (point))))
- (insert "Press C-q to quote control characters like RET"
- " and TAB.\n"
- (if (stringp cmd)
- cmd
- (if (vectorp (nth 1 (nth 3 cmd)))
- (aref (nth 1 (nth 3 cmd)) 1)
- (nth 1 (nth 3 cmd)))))))
- (calc-show-edit-buffer)
- (forward-line (if keys 2 1)))))
+ (let* ((mac (elt (nth 1 (nth 3 cmd)) 1))
+ (str (edmacro-format-keys mac t))
+ (kys (nth 3 (nth 3 cmd))))
+ (calc-edit-mode
+ (list 'calc-edit-macro-finish-edit cmdname kys)
+ t (format (concat
+ "Editing keyboard macro (%s, bound to %s).\n"
+ "Original keys: %s \n")
+ cmdname kys (elt (nth 1 (nth 3 cmd)) 0)))
+ (insert str "\n")
+ (calc-edit-format-macro-buffer)
+ (calc-show-edit-buffer)))
(t (let* ((func (calc-stack-command-p cmd))
(defn (and func
(symbolp func)
- (get func 'calc-user-defn))))
+ (get func 'calc-user-defn)))
+ (kys (concat "z" (char-to-string key)))
+ (intcmd (symbol-name func))
+ (algcmd (if func (substring (symbol-name func) 9) "")))
(if (and defn (calc-valid-formula-func func))
- (progn
+ (let ((niceexpr (math-format-nice-expr defn (frame-width))))
(calc-wrapper
- (calc-edit-mode (list 'calc-finish-formula-edit
- (list 'quote func)))
- (insert (math-showing-full-precision
- (math-format-nice-expr defn (frame-width)))
- "\n"))
+ (calc-edit-mode
+ (list 'calc-finish-formula-edit (list 'quote func))
+ nil
+ (format (concat
+ "Editing formula (%s, %s, bound to %s).\n"
+ "Original formula: %s\n")
+ intcmd algcmd kys niceexpr))
+ (insert (math-showing-full-precision
+ niceexpr)
+ "\n"))
(calc-show-edit-buffer))
- (error "That command's definition cannot be edited"))))))
-)
-
-(defun calc-finish-macro-edit (def keys)
- (forward-line 1)
- (if (and keys (looking-at "\n")) (forward-line 1))
- (let* ((true-str (buffer-substring (point) (point-max)))
- (str true-str))
- (if keys (setq str (MacEdit-parse-keys str)))
- (if (symbolp (cdr def))
- (if (stringp (symbol-function (cdr def)))
- (fset (cdr def) str)
- (let ((mac (cdr (nth 3 (symbol-function (cdr def))))))
- (if (vectorp (car mac))
- (progn
- (aset (car mac) 0 (if keys true-str (key-description str)))
- (aset (car mac) 1 str))
- (setcar mac str))))
- (setcdr def str)))
-)
-
-;;; The following are hooks into the MacEdit package from macedit.el.
-(put 'calc-execute-extended-command 'MacEdit-print
- (function (lambda ()
- (setq macro-str (concat "\excalc-" macro-str))))
-)
-
-(put 'calcDigit-start 'MacEdit-print
- (function (lambda ()
- (if calc-algebraic-mode
- (calc-macro-edit-algebraic)
- (MacEdit-unread-chars key-last)
- (let ((str "")
- (min-bsp 0)
- ch last)
- (while (and (setq ch (MacEdit-read-char))
- (or (and (>= ch ?0) (<= ch ?9))
- (memq ch '(?\. ?e ?\_ ?n ?\: ?\# ?M
- ?o ?h ?\@ ?\"))
- (and (memq ch '(?\' ?m ?s))
- (string-match "[@oh]" str))
- (and (or (and (>= ch ?a) (<= ch ?z))
- (and (>= ch ?A) (<= ch ?Z)))
- (string-match
- "^[-+]?\\(1[1-9]\\|[2-9][0-9]\\)#"
- str))
- (and (memq ch '(?\177 ?\C-h))
- (> (length str) 0))
- (and (memq ch '(?+ ?-))
- (> (length str) 0)
- (eq (aref str (1- (length str)))
- ?e))))
- (if (or (and (>= ch ?0) (<= ch ?9))
- (and (or (not (memq ch '(?\177 ?\C-h)))
- (<= (length str) min-bsp))
- (setq min-bsp (1+ (length str)))))
- (setq str (concat str (char-to-string ch)))
- (setq str (substring str 0 -1))))
- (if (memq ch '(? ?\n ?\r))
- (setq str (concat str (char-to-string ch)))
- (MacEdit-unread-chars ch))
- (insert "type \"")
- (MacEdit-insert-string str)
- (insert "\"\n")))))
-)
-
-(defun calc-macro-edit-algebraic ()
- (MacEdit-unread-chars key-last)
- (let ((str "")
- (min-bsp 0))
- (while (progn
- (MacEdit-lookup-key calc-alg-ent-map)
- (or (and (memq key-symbol '(self-insert-command
- calcAlg-previous))
- (< (length str) 60))
- (memq key-symbol
- '(backward-delete-char
- delete-backward-char
- backward-delete-char-untabify))
- (eq key-last 9)))
- (setq macro-str (substring macro-str (length key-str)))
- (if (or (eq key-symbol 'self-insert-command)
- (and (or (not (memq key-symbol '(backward-delete-char
- delete-backward-char
- backward-delete-char-untabify)))
- (<= (length str) min-bsp))
- (setq min-bsp (+ (length str) (length key-str)))))
- (setq str (concat str key-str))
- (setq str (substring str 0 -1))))
- (if (memq key-last '(?\n ?\r))
- (setq str (concat str key-str)
- macro-str (substring macro-str (length key-str))))
- (if (> (length str) 0)
- (progn
- (insert "type \"")
- (MacEdit-insert-string str)
- (insert "\"\n"))))
-)
-(put 'calc-algebraic-entry 'MacEdit-print 'calc-macro-edit-algebraic)
-(put 'calc-auto-algebraic-entry 'MacEdit-print 'calc-macro-edit-algebraic)
-
-(defun calc-macro-edit-variable (&optional no-cmd)
- (let ((str "") ch)
- (or no-cmd (insert (symbol-name key-symbol) "\n"))
- (if (memq (MacEdit-peek-char) '(?\+ ?\- ?\* ?\/ ?\^ ?\|))
- (setq str (char-to-string (MacEdit-read-char))))
- (if (and (setq ch (MacEdit-peek-char))
- (>= ch ?0) (<= ch ?9))
- (insert "type \"" str
- (char-to-string (MacEdit-read-char)) "\"\n")
- (if (> (length str) 0)
- (insert "type \"" str "\"\n"))
- (MacEdit-read-argument)))
-)
-(put 'calc-store 'MacEdit-print 'calc-macro-edit-variable)
-(put 'calc-store-into 'MacEdit-print 'calc-macro-edit-variable)
-(put 'calc-store-neg 'MacEdit-print 'calc-macro-edit-variable)
-(put 'calc-store-plus 'MacEdit-print 'calc-macro-edit-variable)
-(put 'calc-store-minus 'MacEdit-print 'calc-macro-edit-variable)
-(put 'calc-store-times 'MacEdit-print 'calc-macro-edit-variable)
-(put 'calc-store-div 'MacEdit-print 'calc-macro-edit-variable)
-(put 'calc-store-power 'MacEdit-print 'calc-macro-edit-variable)
-(put 'calc-store-concat 'MacEdit-print 'calc-macro-edit-variable)
-(put 'calc-store-inv 'MacEdit-print 'calc-macro-edit-variable)
-(put 'calc-store-decr 'MacEdit-print 'calc-macro-edit-variable)
-(put 'calc-store-incr 'MacEdit-print 'calc-macro-edit-variable)
-(put 'calc-store-exchange 'MacEdit-print 'calc-macro-edit-variable)
-(put 'calc-unstore 'MacEdit-print 'calc-macro-edit-variable)
-(put 'calc-recall 'MacEdit-print 'calc-macro-edit-variable)
-(put 'calc-let 'MacEdit-print 'calc-macro-edit-variable)
-(put 'calc-permanent-variable 'MacEdit-print 'calc-macro-edit-variable)
-
-(defun calc-macro-edit-variable-2 ()
- (calc-macro-edit-variable)
- (calc-macro-edit-variable t)
-)
-(put 'calc-copy-variable 'MacEdit-print 'calc-macro-edit-variable-2)
-(put 'calc-declare-variable 'MacEdit-print 'calc-macro-edit-variable-2)
-
-(defun calc-macro-edit-quick-digit ()
- (insert "type \"" key-str "\" # " (symbol-name key-symbol) "\n")
-)
-(put 'calc-store-quick 'MacEdit-print 'calc-macro-edit-quick-digit)
-(put 'calc-store-into-quick 'MacEdit-print 'calc-macro-edit-quick-digit)
-(put 'calc-recall-quick 'MacEdit-print 'calc-macro-edit-quick-digit)
-(put 'calc-select-part 'MacEdit-print 'calc-macro-edit-quick-digit)
-(put 'calc-clean-num 'MacEdit-print 'calc-macro-edit-quick-digit)
-
+ (error "That command's definition cannot be edited")))))))
+
+;; Formatting the macro buffer
+
+(defvar calc-edit-top)
+
+(defun calc-edit-macro-repeats ()
+ (goto-char calc-edit-top)
+ (while
+ (re-search-forward "^\\([0-9]+\\)\\*" nil t)
+ (let ((num (string-to-number (match-string 1)))
+ (line (buffer-substring (point) (line-end-position))))
+ (goto-char (line-beginning-position))
+ (kill-line 1)
+ (while (> num 0)
+ (insert line "\n")
+ (setq num (1- num))))))
+
+(defun calc-edit-macro-adjust-buffer ()
+ (calc-edit-macro-repeats)
+ (goto-char calc-edit-top)
+ (while (re-search-forward "^RET$" nil t)
+ (delete-char 1))
+ (goto-char calc-edit-top)
+ (while (and (re-search-forward "^$" nil t)
+ (not (= (point) (point-max))))
+ (delete-char 1)))
+
+(defun calc-edit-macro-command ()
+ "Return the command on the current line in a Calc macro editing buffer."
+ (let ((beg (line-beginning-position))
+ (end (save-excursion
+ (if (search-forward ";;" (line-end-position) 1)
+ (forward-char -2))
+ (skip-chars-backward " \t")
+ (point))))
+ (buffer-substring beg end)))
+
+(defun calc-edit-macro-command-type ()
+ "Return the type of command on the current line in a Calc macro editing buffer."
+ (let ((beg (save-excursion
+ (if (search-forward ";;" (line-end-position) t)
+ (progn
+ (skip-chars-forward " \t")
+ (point)))))
+ (end (save-excursion
+ (goto-char (line-end-position))
+ (skip-chars-backward " \t")
+ (point))))
+ (if beg
+ (buffer-substring beg end)
+ "")))
+
+(defun calc-edit-macro-combine-alg-ent ()
+ "Put an entire algebraic entry on a single line."
+ (let ((line (calc-edit-macro-command))
+ (type (calc-edit-macro-command-type))
+ curline
+ match)
+ (goto-char (line-beginning-position))
+ (kill-line 1)
+ (setq curline (calc-edit-macro-command))
+ (while (and curline
+ (not (string-equal "RET" curline))
+ (not (setq match (string-match "<return>" curline))))
+ (setq line (concat line curline))
+ (kill-line 1)
+ (setq curline (calc-edit-macro-command)))
+ (when match
+ (kill-line 1)
+ (setq line (concat line (substring curline 0 match))))
+ (setq line (replace-regexp-in-string "SPC" " SPC "
+ (replace-regexp-in-string " " "" line)))
+ (insert line "\t\t\t")
+ (if (> (current-column) 24)
+ (delete-char -1))
+ (insert ";; " type "\n")
+ (if match
+ (insert "RET\t\t\t;; calc-enter\n"))))
+
+(defun calc-edit-macro-combine-ext-command ()
+ "Put an entire extended command on a single line."
+ (let ((cmdbeg (calc-edit-macro-command))
+ (line "")
+ (type (calc-edit-macro-command-type))
+ curline
+ match)
+ (goto-char (line-beginning-position))
+ (kill-line 1)
+ (setq curline (calc-edit-macro-command))
+ (while (and curline
+ (not (string-equal "RET" curline))
+ (not (setq match (string-match "<return>" curline))))
+ (setq line (concat line curline))
+ (kill-line 1)
+ (setq curline (calc-edit-macro-command)))
+ (when match
+ (kill-line 1)
+ (setq line (concat line (substring curline 0 match))))
+ (setq line (replace-regexp-in-string " " "" line))
+ (insert cmdbeg " " line "\t\t\t")
+ (if (> (current-column) 24)
+ (delete-char -1))
+ (insert ";; " type "\n")
+ (if match
+ (insert "RET\t\t\t;; calc-enter\n"))))
+
+(defun calc-edit-macro-combine-var-name ()
+ "Put an entire variable name on a single line."
+ (let ((line (calc-edit-macro-command))
+ curline
+ match)
+ (goto-char (line-beginning-position))
+ (kill-line 1)
+ (if (member line '("0" "1" "2" "3" "4" "5" "6" "7" "8" "9"))
+ (insert line "\t\t\t;; calc quick variable\n")
+ (setq curline (calc-edit-macro-command))
+ (while (and curline
+ (not (string-equal "RET" curline))
+ (not (setq match (string-match "<return>" curline))))
+ (setq line (concat line curline))
+ (kill-line 1)
+ (setq curline (calc-edit-macro-command)))
+ (when match
+ (kill-line 1)
+ (setq line (concat line (substring curline 0 match))))
+ (setq line (replace-regexp-in-string " " "" line))
+ (insert line "\t\t\t")
+ (if (> (current-column) 24)
+ (delete-char -1))
+ (insert ";; calc variable\n")
+ (if match
+ (insert "RET\t\t\t;; calc-enter\n")))))
+
+(defun calc-edit-macro-combine-digits ()
+ "Put an entire sequence of digits on a single line."
+ (let ((line (calc-edit-macro-command)))
+ (goto-char (line-beginning-position))
+ (kill-line 1)
+ (while (string-equal (calc-edit-macro-command-type) "calcDigit-start")
+ (setq line (concat line (calc-edit-macro-command)))
+ (kill-line 1))
+ (insert line "\t\t\t")
+ (if (> (current-column) 24)
+ (delete-char -1))
+ (insert ";; calc digits\n")))
+
+(defun calc-edit-format-macro-buffer ()
+ "Rewrite the Calc macro editing buffer."
+ (calc-edit-macro-adjust-buffer)
+ (goto-char calc-edit-top)
+ (let ((type (calc-edit-macro-command-type)))
+ (while (not (string-equal type ""))
+ (cond
+ ((or
+ (string-equal type "calc-algebraic-entry")
+ (string-equal type "calc-auto-algebraic-entry"))
+ (calc-edit-macro-combine-alg-ent))
+ ((string-equal type "calc-execute-extended-command")
+ (calc-edit-macro-combine-ext-command))
+ ((string-equal type "calcDigit-start")
+ (calc-edit-macro-combine-digits))
+ ((or
+ (string-equal type "calc-store")
+ (string-equal type "calc-store-into")
+ (string-equal type "calc-store-neg")
+ (string-equal type "calc-store-plus")
+ (string-equal type "calc-store-minus")
+ (string-equal type "calc-store-div")
+ (string-equal type "calc-store-times")
+ (string-equal type "calc-store-power")
+ (string-equal type "calc-store-concat")
+ (string-equal type "calc-store-inv")
+ (string-equal type "calc-store-dec")
+ (string-equal type "calc-store-incr")
+ (string-equal type "calc-store-exchange")
+ (string-equal type "calc-unstore")
+ (string-equal type "calc-recall")
+ (string-equal type "calc-let")
+ (string-equal type "calc-permanent-variable"))
+ (forward-line 1)
+ (calc-edit-macro-combine-var-name))
+ ((or
+ (string-equal type "calc-copy-variable")
+ (string-equal type "calc-copy-special-constant")
+ (string-equal type "calc-declare-variable"))
+ (forward-line 1)
+ (calc-edit-macro-combine-var-name)
+ (calc-edit-macro-combine-var-name))
+ (t (forward-line 1)))
+ (setq type (calc-edit-macro-command-type))))
+ (goto-char calc-edit-top))
+
+;; Finish editing the macro
+
+(defun calc-edit-macro-pre-finish-edit ()
+ (goto-char calc-edit-top)
+ (while (re-search-forward "\\(^\\| \\)RET\\($\\|\t\\| \\)" nil t)
+ (search-backward "RET")
+ (delete-char 3)
+ (insert "<return>")))
+
+(defun calc-edit-macro-finish-edit (cmdname key)
+ "Finish editing a Calc macro.
+Redefine the corresponding command."
+ (interactive)
+ (let ((cmd (intern cmdname)))
+ (calc-edit-macro-pre-finish-edit)
+ (let* ((str (buffer-substring calc-edit-top (point-max)))
+ (mac (edmacro-parse-keys str)))
+ (if (= (length mac) 0)
+ (fmakunbound cmd)
+ (fset cmd
+ (list 'lambda '(arg)
+ '(interactive "P")
+ (list 'calc-execute-kbd-macro
+ (vector (key-description mac)
+ mac)
+ 'arg key)))))))
(defun calc-finish-formula-edit (func)
(let ((buf (current-buffer))
- (str (buffer-substring (point) (point-max)))
+ (str (buffer-substring calc-edit-top (point-max)))
(start (point))
(body (calc-valid-formula-func func)))
(set-buffer calc-original-buffer)
(goto-char (+ start (nth 1 val)))
(error (nth 2 val))))
(setcar (cdr body)
- (let ((alist (nth 1 (symbol-function func))))
+ (let ((calc-user-formula-alist (nth 1 (symbol-function func))))
(calc-fix-user-formula val)))
- (put func 'calc-user-defn val)))
-)
+ (put func 'calc-user-defn val))))
(defun calc-valid-formula-func (func)
(let ((def (symbol-function func)))
(while (and def
(not (eq (car (car def)) 'math-normalize)))
(setq def (cdr def)))
- (car def))))
-)
+ (car def)))))
(defun calc-get-user-defn ()
(calc-wrapper
(message "Get definition of command: z-")
(let* ((key (read-char))
- (def (or (assq key (calc-user-key-map))
- (assq (upcase key) (calc-user-key-map))
- (assq (downcase key) (calc-user-key-map))
- (error "No command defined for that key")))
- (cmd (cdr def)))
+ (cmd (or (lookup-key calc-z-map key)
+ (lookup-key calc-z-map (upcase key))
+ (lookup-key calc-z-map (downcase key))
+ (error "No command defined for that key"))))
(if (symbolp cmd)
(setq cmd (symbol-function cmd)))
(cond ((stringp cmd)
func)))
(list defn))))
(calc-enter-result 0 "gdef" defn))
- (error "That command is not defined by a formula")))))))
-)
+ (error "That command is not defined by a formula"))))))))
(defun calc-user-define-permanent ()
(calc-wrapper
(message "Record in %s the command: z-" calc-settings-file)
(let* ((key (read-char))
- (def (or (assq key (calc-user-key-map))
- (assq (upcase key) (calc-user-key-map))
- (assq (downcase key) (calc-user-key-map))
- (and (eq key ?\')
+ (cmd (or (lookup-key calc-z-map key)
+ (lookup-key calc-z-map (upcase key))
+ (lookup-key calc-z-map (downcase key))
+ (and (eq key ?\')
+ (cons nil
+ (intern
+ (concat "calcFunc-"
+ (completing-read
+ (format "Record in %s the algebraic function: "
+ calc-settings-file)
+ (mapcar (lambda (x) (substring x 9))
+ (all-completions "calcFunc-"
+ obarray))
+ (lambda (x)
+ (fboundp
+ (intern (concat "calcFunc-" x))))
+ t)))))
+ (and (eq key ?\M-x)
(cons nil
(intern (completing-read
- (format "Record in %s the function: "
+ (format "Record in %s the command: "
calc-settings-file)
- obarray 'fboundp nil "calcFunc-"))))
+ obarray 'fboundp nil "calc-"))))
(error "No command defined for that key"))))
(set-buffer (find-file-noselect (substitute-in-file-name
calc-settings-file)))
(goto-char (point-max))
- (let* ((cmd (cdr def))
- (fcmd (and cmd (symbolp cmd) (symbol-function cmd)))
+ (let* ((fcmd (and cmd (symbolp cmd) (symbol-function cmd)))
(func nil)
- (pt (point))
+ ; (pt (point)) -- unused? --SY.
(fill-column 70)
(fill-prefix nil)
str q-ok)
(let ((pt (point)))
(and (eq (car-safe (nth 3 fcmd)) 'calc-execute-kbd-macro)
(vectorp (nth 1 (nth 3 fcmd)))
- (progn (and (fboundp 'edit-kbd-macro)
- (edit-kbd-macro nil))
- (fboundp 'MacEdit-parse-keys))
+ (progn (fboundp 'edit-kbd-macro)
+ (fboundp 'edmacro-parse-keys))
(setq q-ok t)
- (aset (nth 1 (nth 3 fcmd)) 1 nil))
+ (setcdr (nth 3 fcmd)
+ (cons (edmacro-parse-keys
+ (elt (nth 1 (nth 3 fcmd)) 0))
+ (cddr (nth 3 fcmd)))))
(insert (setq str (prin1-to-string
(cons 'defun (cons cmd (cdr fcmd)))))
"\n")
(fill-region pt (point))
(indent-rigidly pt (point) 2)
(delete-region pt (1+ pt))))
- (if (car def)
+ (if (and key cmd)
(insert " (define-key calc-mode-map "
(prin1-to-string (concat "z" (char-to-string key)))
" '"
(prin1-to-string cmd)
")\n")))
(insert "))\n")
- (save-buffer)))
-)
+ (save-buffer))))
(defun calc-stack-command-p (cmd)
(if (and cmd (symbolp cmd))
(setq cmd (assq 'calc-enter-result cmd))
(memq (car (nth 3 cmd)) '(cons list))
(eq (car (nth 1 (nth 3 cmd))) 'quote)
- (nth 1 (nth 1 (nth 3 cmd)))))
-)
+ (nth 1 (nth 1 (nth 3 cmd))))))
(defun calc-call-last-kbd-macro (arg)
(error "Can't execute anonymous macro while defining one"))
(or last-kbd-macro
(error "No kbd macro has been defined"))
- (calc-execute-kbd-macro last-kbd-macro arg)
-)
+ (calc-execute-kbd-macro last-kbd-macro arg))
(defun calc-execute-kbd-macro (mac arg &rest prefix)
+ (if calc-keep-args-flag
+ (calc-keep-args))
(if (and (vectorp mac) (> (length mac) 0) (stringp (aref mac 0)))
(setq mac (or (aref mac 1)
(aset mac 1 (progn (and (fboundp 'edit-kbd-macro)
(edit-kbd-macro nil))
- (MacEdit-parse-keys (aref mac 0)))))))
+ (edmacro-parse-keys (aref mac 0)))))))
(if (< (prefix-numeric-value arg) 0)
(execute-kbd-macro mac (- (prefix-numeric-value arg)))
(if calc-executing-macro
(calc-record-undo (list 'push 1))
(setq new-stack (cdr new-stack)))
(calc-refresh))
- (calc-record-undo (list 'set 'saved-stack-top 0))))))))
-)
+ (calc-record-undo (list 'set 'saved-stack-top 0)))))))))
(defun calc-push-list-in-macro (vals m sels)
(let ((entry (list (car vals) 1 (car sels)))
(if (> mm 1)
(setcdr (nthcdr (- mm 2) calc-stack)
(cons entry (nthcdr (1- mm) calc-stack)))
- (setq calc-stack (cons entry calc-stack))))
-)
+ (setq calc-stack (cons entry calc-stack)))))
(defun calc-pop-stack-in-macro (n mm)
(if (> mm 1)
(setcdr (nthcdr (- mm 2) calc-stack)
(nthcdr (+ n mm -1) calc-stack))
- (setq calc-stack (nthcdr n calc-stack)))
-)
+ (setq calc-stack (nthcdr n calc-stack))))
(defun calc-kbd-if ()
(message "If true..."))
(if defining-kbd-macro
(message "Condition is false; skipping to Z: or Z] ..."))
- (calc-kbd-skip-to-else-if t))))
-)
+ (calc-kbd-skip-to-else-if t)))))
(defun calc-kbd-else-if ()
(interactive)
- (calc-kbd-if)
-)
+ (calc-kbd-if))
+
+(defun math-read-char ()
+ (condition-case nil (read-char) (error nil)))
(defun calc-kbd-skip-to-else-if (else-okay)
(let ((count 0)
ch)
(while (>= count 0)
- (setq ch (read-char))
- (if (= ch -1)
+ (setq ch (math-read-char))
+ (if (eq ch -1)
(error "Unterminated Z[ in keyboard macro"))
- (if (= ch ?Z)
+ (if (eq ch ?Z)
(progn
- (setq ch (read-char))
- (cond ((= ch ?\[)
+ (setq ch (math-read-char))
+ (cond ((eq ch ?\[)
(setq count (1+ count)))
- ((= ch ?\])
+ ((eq ch ?\])
(setq count (1- count)))
- ((= ch ?\:)
+ ((eq ch ?\:)
(and (= count 0)
else-okay
(setq count -1)))
- ((eq ch 7)
+ ((eq ch ?\^G)
(keyboard-quit))))))
(and defining-kbd-macro
- (if (= ch ?\:)
+ (if (eq ch ?\:)
(message "Else...")
- (message "End-if..."))))
-)
+ (message "End-if...")))))
(defun calc-kbd-end-if ()
(interactive)
(if defining-kbd-macro
- (message "End-if..."))
-)
+ (message "End-if...")))
(defun calc-kbd-else ()
(interactive)
(if defining-kbd-macro
(message "Else; skipping to Z] ..."))
- (calc-kbd-skip-to-else-if nil)
-)
+ (calc-kbd-skip-to-else-if nil))
(defun calc-kbd-repeat ()
(or (integerp count)
(setq count 1000000))
(calc-pop-stack 1))
- (calc-kbd-loop count))
-)
+ (calc-kbd-loop count)))
(defun calc-kbd-for (dir)
(interactive "P")
(or (and (math-anglep init) (math-anglep final))
(error "Initial and final values must be real numbers"))
(calc-pop-stack 2))
- (calc-kbd-loop nil init final (and dir (prefix-numeric-value dir))))
-)
+ (calc-kbd-loop nil init final (and dir (prefix-numeric-value dir)))))
(defun calc-kbd-loop (rpt-count &optional initial final dir)
(interactive "P")
(setq counter (calcFunc-add counter step)))
(setq rpt-count (1- rpt-count))))))))
(or executing-kbd-macro
- (message "Looping...done")))
-)
+ (message "Looping...done"))))
(defun calc-kbd-end-repeat ()
(interactive)
- (error "Unbalanced Z> in keyboard macro")
-)
+ (error "Unbalanced Z> in keyboard macro"))
(defun calc-kbd-end-for ()
(interactive)
- (error "Unbalanced Z) in keyboard macro")
-)
+ (error "Unbalanced Z) in keyboard macro"))
(defun calc-kbd-end-loop ()
(interactive)
- (error "Unbalanced Z} in keyboard macro")
-)
+ (error "Unbalanced Z} in keyboard macro"))
(defun calc-kbd-break ()
(interactive)
(let ((cond (calc-top-n 1)))
(calc-pop-stack 1)
(if (math-is-true cond)
- (error "Keyboard macro aborted."))))
-)
+ (error "Keyboard macro aborted")))))
+(defvar calc-kbd-push-level 0)
+
+;; The variables var-q0 through var-q9 are the "quick" variables.
+(defvar var-q0 nil)
+(defvar var-q1 nil)
+(defvar var-q2 nil)
+(defvar var-q3 nil)
+(defvar var-q4 nil)
+(defvar var-q5 nil)
+(defvar var-q6 nil)
+(defvar var-q7 nil)
+(defvar var-q8 nil)
+(defvar var-q9 nil)
+
(defun calc-kbd-push (arg)
(interactive "P")
(calc-wrapper
(let* ((defs (and arg (> (prefix-numeric-value arg) 0)))
- (var-q0 (and (boundp 'var-q0) var-q0))
- (var-q1 (and (boundp 'var-q1) var-q1))
- (var-q2 (and (boundp 'var-q2) var-q2))
- (var-q3 (and (boundp 'var-q3) var-q3))
- (var-q4 (and (boundp 'var-q4) var-q4))
- (var-q5 (and (boundp 'var-q5) var-q5))
- (var-q6 (and (boundp 'var-q6) var-q6))
- (var-q7 (and (boundp 'var-q7) var-q7))
- (var-q8 (and (boundp 'var-q8) var-q8))
- (var-q9 (and (boundp 'var-q9) var-q9))
+ (var-q0 var-q0)
+ (var-q1 var-q1)
+ (var-q2 var-q2)
+ (var-q3 var-q3)
+ (var-q4 var-q4)
+ (var-q5 var-q5)
+ (var-q6 var-q6)
+ (var-q7 var-q7)
+ (var-q8 var-q8)
+ (var-q9 var-q9)
(calc-internal-prec (if defs 12 calc-internal-prec))
(calc-word-size (if defs 32 calc-word-size))
(calc-angle-mode (if defs 'deg calc-angle-mode))
(let ((calc-kbd-push-level 0))
(execute-kbd-macro (substring body 0 -2))))
(let ((calc-kbd-push-level (1+ calc-kbd-push-level)))
- (message "Saving modes; type Z' to restore")
- (recursive-edit)))))
-)
-(setq calc-kbd-push-level 0)
+ (message "%s" "Saving modes; type Z' to restore")
+ (recursive-edit))))))
(defun calc-kbd-pop ()
(interactive)
(progn
(message "Mode settings restored")
(exit-recursive-edit))
- (error "Unbalanced Z' in keyboard macro"))
-)
-
-
-(defun calc-kbd-report (msg)
- (interactive "sMessage: ")
- (calc-wrapper
- (let ((executing-kbd-macro nil)
- (defining-kbd-macro nil))
- (math-working msg (calc-top-n 1))))
-)
-
-(defun calc-kbd-query (msg)
- (interactive "sPrompt: ")
- (calc-wrapper
- (let ((executing-kbd-macro nil)
- (defining-kbd-macro nil))
- (calc-alg-entry nil (and (not (equal msg "")) msg))))
-)
-
-
-
-
-
+ (error "%s" "Unbalanced Z' in keyboard macro")))
+(defun calc-kbd-query ()
+ (interactive)
+ (let ((defining-kbd-macro nil)
+ (executing-kbd-macro nil)
+ (msg (calc-top 1)))
+ (if (not (eq (car-safe msg) 'vec))
+ (error "No prompt string provided")
+ (setq msg (math-vector-to-string msg))
+ (calc-wrapper
+ (calc-pop-stack 1)
+ (calc-alg-entry nil (and (not (equal msg "")) msg))))))
;;;; Logical operations.
(if (and (or (math-looks-negp a) (math-zerop a))
(or (math-looks-negp b) (math-zerop b)))
(list 'calcFunc-eq (math-neg a) (math-neg b))
- (list 'calcFunc-eq a b))))
-)
+ (list 'calcFunc-eq a b)))))
(defun calcFunc-neq (a b &rest more)
(if more
(if (and (or (math-looks-negp a) (math-zerop a))
(or (math-looks-negp b) (math-zerop b)))
(list 'calcFunc-neq (math-neg a) (math-neg b))
- (list 'calcFunc-neq a b))))
-)
+ (list 'calcFunc-neq a b)))))
(defun math-two-eq (a b)
(if (eq (car-safe a) 'vec)
1
(if (and (= res 2) (not (and (Math-scalarp a) (Math-scalarp b))))
nil
- 0)))))
-)
+ 0))))))
(defun calcFunc-lt (a b)
(let ((res (math-compare a b)))
(or (math-looks-negp b) (math-zerop b)))
(list 'calcFunc-gt (math-neg a) (math-neg b))
(list 'calcFunc-lt a b))
- 0)))
-)
+ 0))))
(defun calcFunc-gt (a b)
(let ((res (math-compare a b)))
(or (math-looks-negp b) (math-zerop b)))
(list 'calcFunc-lt (math-neg a) (math-neg b))
(list 'calcFunc-gt a b))
- 0)))
-)
+ 0))))
(defun calcFunc-leq (a b)
(let ((res (math-compare a b)))
(or (math-looks-negp b) (math-zerop b)))
(list 'calcFunc-geq (math-neg a) (math-neg b))
(list 'calcFunc-leq a b))
- 1)))
-)
+ 1))))
(defun calcFunc-geq (a b)
(let ((res (math-compare a b)))
(or (math-looks-negp b) (math-zerop b)))
(list 'calcFunc-leq (math-neg a) (math-neg b))
(list 'calcFunc-geq a b))
- 1)))
-)
+ 1))))
(defun calcFunc-rmeq (a)
(if (math-vectorp a)
(nth 2 a)
(if (eq (car-safe a) 'calcFunc-evalto)
(nth 1 a)
- (list 'calcFunc-rmeq a)))))
-)
+ (list 'calcFunc-rmeq a))))))
(defun calcFunc-land (a b)
(cond ((Math-zerop a)
b)
((math-is-true b)
a)
- (t (list 'calcFunc-land a b)))
-)
+ (t (list 'calcFunc-land a b))))
(defun calcFunc-lor (a b)
(cond ((Math-zerop a)
a)
((math-is-true b)
b)
- (t (list 'calcFunc-lor a b)))
-)
+ (t (list 'calcFunc-lor a b))))
(defun calcFunc-lnot (a)
(if (Math-zerop a)
(assq (car a) calc-tweak-eqn-table))))
(if op
(cons (nth 2 op) (cdr a))
- (list 'calcFunc-lnot a)))))
-)
+ (list 'calcFunc-lnot a))))))
(defun calcFunc-if (c e1 e2)
(if (Math-zerop c)
(list e2))))
(and ee1 ee2
(cons 'vec (math-if-vector (cdr c) ee1 ee2)))))
- (list 'calcFunc-if c e1 e2))))
-)
+ (list 'calcFunc-if c e1 e2)))))
(defun math-if-vector (c e1 e2)
(and c
(cons (if (Math-zerop (car c)) (car e2) (car e1))
(math-if-vector (cdr c)
(or (cdr e1) e1)
- (or (cdr e2) e2))))
-)
+ (or (cdr e2) e2)))))
(defun math-normalize-logical-op (a)
(or (and (eq (car a) 'calcFunc-if)
(list 'calcFunc-if a1
(math-normalize (nth 2 a))
(math-normalize (nth 3 a)))))))))
- a)
-)
+ a))
(defun calcFunc-in (a b)
(or (and (eq (car-safe b) 'vec)
1)
(and (math-constp a) (math-constp b)
0)
- (list 'calcFunc-in a b))
-)
+ (list 'calcFunc-in a b)))
(defun calcFunc-typeof (a)
(cond ((Math-integerp a) 1)
((eq (car a) 'var)
(if (memq (nth 2 a) '(var-inf var-uinf var-nan)) 12 100))
((eq (car a) 'vec) (if (math-matrixp a) 102 101))
- (t (math-calcFunc-to-var func)))
-)
+ (t (math-calcFunc-to-var (car a)))))
(defun calcFunc-integer (a)
(if (Math-integerp a)
1
(if (Math-objvecp a)
0
- (list 'calcFunc-integer a)))
-)
+ (list 'calcFunc-integer a))))
(defun calcFunc-real (a)
(if (Math-realp a)
1
(if (Math-objvecp a)
0
- (list 'calcFunc-real a)))
-)
+ (list 'calcFunc-real a))))
(defun calcFunc-constant (a)
(if (math-constp a)
1
(if (Math-objvecp a)
0
- (list 'calcFunc-constant a)))
-)
+ (list 'calcFunc-constant a))))
(defun calcFunc-refers (a b)
(if (math-expr-contains a b)
1
(if (eq (car-safe a) 'var)
(list 'calcFunc-refers a b)
- 0))
-)
+ 0)))
(defun calcFunc-negative (a)
(if (math-looks-negp a)
(if (or (math-zerop a)
(math-posp a))
0
- (list 'calcFunc-negative a)))
-)
+ (list 'calcFunc-negative a))))
(defun calcFunc-variable (a)
(if (eq (car-safe a) 'var)
1
(if (Math-objvecp a)
0
- (list 'calcFunc-variable a)))
-)
+ (list 'calcFunc-variable a))))
(defun calcFunc-nonvar (a)
(if (eq (car-safe a) 'var)
(list 'calcFunc-nonvar a)
- 1)
-)
+ 1))
(defun calcFunc-istrue (a)
(if (math-is-true a)
1
- 0)
-)
-
+ 0))
;;; Compiling Lisp-like forms to use the math library.
(defun math-do-defmath (func args body)
- (calc-need-macros)
+ (require 'calc-macs)
(let* ((fname (intern (concat "calcFunc-" (symbol-name func))))
- (doc (if (stringp (car body)) (list (car body))))
+ (doc (if (stringp (car body))
+ (prog1 (list (car body))
+ (setq body (cdr body)))))
(clargs (mapcar 'math-clean-arg args))
- (body (math-define-function-body
- (if (stringp (car body)) (cdr body) body)
- clargs)))
- (list 'progn
- (if (and (consp (car body))
- (eq (car (car body)) 'interactive))
- (let ((inter (car body)))
- (setq body (cdr body))
- (if (or (> (length inter) 2)
- (integerp (nth 1 inter)))
- (let ((hasprefix nil) (hasmulti nil))
- (if (stringp (nth 1 inter))
- (progn
- (cond ((equal (nth 1 inter) "p")
- (setq hasprefix t))
- ((equal (nth 1 inter) "m")
- (setq hasmulti t))
- (t (error
- "Can't handle interactive code string \"%s\""
- (nth 1 inter))))
- (setq inter (cdr inter))))
- (if (not (integerp (nth 1 inter)))
- (error
- "Expected an integer in interactive specification"))
- (append (list 'defun
- (intern (concat "calc-"
- (symbol-name func)))
- (if (or hasprefix hasmulti)
- '(&optional n)
- ()))
- doc
- (if (or hasprefix hasmulti)
- '((interactive "P"))
- '((interactive)))
- (list
- (append
- '(calc-slow-wrapper)
- (and hasmulti
- (list
- (list 'setq
- 'n
- (list 'if
- 'n
- (list 'prefix-numeric-value
- 'n)
- (nth 1 inter)))))
- (list
- (list 'calc-enter-result
- (if hasmulti 'n (nth 1 inter))
- (nth 2 inter)
- (if hasprefix
- (list 'append
- (list 'quote (list fname))
- (list 'calc-top-list-n
- (nth 1 inter))
- (list 'and
- 'n
- (list
- 'list
- (list
- 'math-normalize
- (list
- 'prefix-numeric-value
- 'n)))))
- (list 'cons
- (list 'quote fname)
- (list 'calc-top-list-n
- (if hasmulti
- 'n
- (nth 1 inter)))))))))))
- (append (list 'defun
- (intern (concat "calc-" (symbol-name func)))
- args)
- doc
- (list
- inter
- (cons 'calc-wrapper body))))))
- (append (list 'defun fname clargs)
- doc
- (math-do-arg-list-check args nil nil)
- body)))
-)
+ (inter (if (and (consp (car body))
+ (eq (car (car body)) 'interactive))
+ (prog1 (car body)
+ (setq body (cdr body))))))
+ (setq body (math-define-function-body body clargs))
+ `(progn
+ ,(if inter
+ (if (or (> (length inter) 2)
+ (integerp (nth 1 inter)))
+ (let ((hasprefix nil) (hasmulti nil))
+ (when (stringp (nth 1 inter))
+ (cond ((equal (nth 1 inter) "p")
+ (setq hasprefix t))
+ ((equal (nth 1 inter) "m")
+ (setq hasmulti t))
+ (t (error
+ "Can't handle interactive code string \"%s\""
+ (nth 1 inter))))
+ (setq inter (cdr inter)))
+ (unless (integerp (nth 1 inter))
+ (error "Expected an integer in interactive specification"))
+ `(defun ,(intern (concat "calc-" (symbol-name func)))
+ ,(if (or hasprefix hasmulti) '(&optional n) ())
+ ,@doc
+ (interactive ,@(if (or hasprefix hasmulti) '("P")))
+ (calc-slow-wrapper
+ ,@(if hasmulti
+ `((setq n (if n
+ (prefix-numeric-value n)
+ ,(nth 1 inter)))))
+ (calc-enter-result
+ ,(if hasmulti 'n (nth 1 inter))
+ ,(nth 2 inter)
+ ,(if hasprefix
+ `(append '(,fname)
+ (calc-top-list-n ,(nth 1 inter))
+ (and n
+ (list
+ (math-normalize
+ (prefix-numeric-value n)))))
+ `(cons ',fname
+ (calc-top-list-n
+ ,(if hasmulti
+ 'n
+ (nth 1 inter)))))))))
+ `(defun ,(intern (concat "calc-" (symbol-name func))) ,clargs
+ ,@doc
+ ,inter
+ (calc-wrapper ,@body))))
+ (defun ,fname ,clargs
+ ,@doc
+ ,@(math-do-arg-list-check args nil nil)
+ ,@body))))
(defun math-clean-arg (arg)
(if (consp arg)
(math-clean-arg (nth 1 arg))
- arg)
-)
+ arg))
(defun math-do-arg-check (arg var is-opt is-rest)
(if is-opt
(list (cons 'and
(cons var
(if (cdr chk)
- (setq chk (list (cons 'progn chk)))
+ `((progn ,@chk))
chk)))))
- (and (consp arg)
- (let* ((rest (math-do-arg-check (nth 1 arg) var is-opt is-rest))
- (qual (car arg))
- (qqual (list 'quote qual))
- (qual-name (symbol-name qual))
- (chk (intern (concat "math-check-" qual-name))))
- (if (fboundp chk)
- (append rest
- (list
+ (when (consp arg)
+ (let* ((rest (math-do-arg-check (nth 1 arg) var is-opt is-rest))
+ (qual (car arg))
+ (qual-name (symbol-name qual))
+ (chk (intern (concat "math-check-" qual-name))))
+ (if (fboundp chk)
+ (append rest
+ (if is-rest
+ `((setq ,var (mapcar ',chk ,var)))
+ `((setq ,var (,chk ,var)))))
+ (if (fboundp (setq chk (intern (concat "math-" qual-name))))
+ (append rest
+ (if is-rest
+ `((mapcar #'(lambda (x)
+ (or (,chk x)
+ (math-reject-arg x ',qual)))
+ ,var))
+ `((or (,chk ,var)
+ (math-reject-arg ,var ',qual)))))
+ (if (and (string-match "\\`not-\\(.*\\)\\'" qual-name)
+ (fboundp (setq chk (intern
+ (concat "math-"
+ (math-match-substring
+ qual-name 1))))))
+ (append rest
(if is-rest
- (list 'setq var
- (list 'mapcar (list 'quote chk) var))
- (list 'setq var (list chk var)))))
- (if (fboundp (setq chk (intern (concat "math-" qual-name))))
- (append rest
- (list
- (if is-rest
- (list 'mapcar
- (list 'function
- (list 'lambda '(x)
- (list 'or
- (list chk 'x)
- (list 'math-reject-arg
- 'x qqual))))
- var)
- (list 'or
- (list chk var)
- (list 'math-reject-arg var qqual)))))
- (if (and (string-match "\\`not-\\(.*\\)\\'" qual-name)
- (fboundp (setq chk (intern
- (concat "math-"
- (math-match-substring
- qual-name 1))))))
- (append rest
- (list
- (if is-rest
- (list 'mapcar
- (list 'function
- (list 'lambda '(x)
- (list 'and
- (list chk 'x)
- (list 'math-reject-arg
- 'x qqual))))
- var)
- (list 'and
- (list chk var)
- (list 'math-reject-arg var qqual)))))
- (error "Unknown qualifier `%s'" qual-name)))))))
-)
+ `((mapcar #'(lambda (x)
+ (and (,chk x)
+ (math-reject-arg x ',qual)))
+ ,var))
+ `((and
+ (,chk ,var)
+ (math-reject-arg ,var ',qual)))))
+ (error "Unknown qualifier `%s'" qual-name))))))))
(defun math-do-arg-list-check (args is-opt is-rest)
(cond ((null args) nil)
(math-do-arg-list-check (cdr args) t nil))
((eq (car args) '&rest)
(math-do-arg-list-check (cdr args) nil t))
- (t (math-do-arg-list-check (cdr args) is-opt is-rest)))
-)
+ (t (math-do-arg-list-check (cdr args) is-opt is-rest))))
(defconst math-prim-funcs
'( (~= . math-nearly-equal)
(or . or)
(if . if)
(^ . math-pow)
- (expt . math-pow)
- )
-)
+ (expt . math-pow)))
(defconst math-prim-vars
'( (nil . nil)
(t . t)
(&optional . &optional)
- (&rest . &rest)
- )
-)
+ (&rest . &rest)))
(defun math-define-function-body (body env)
(let ((body (math-define-body body env)))
(if (math-body-refers-to body 'math-return)
- (list (cons 'catch (cons '(quote math-return) body)))
- body))
-)
+ `((catch 'math-return ,@body))
+ body)))
-(defun math-define-body (body exp-env)
- (math-define-list body)
-)
+;; The variable math-exp-env is local to math-define-body, but is
+;; used by math-define-exp, which is called (indirectly) by
+;; by math-define-body.
+(defvar math-exp-env)
+
+(defun math-define-body (body math-exp-env)
+ (math-define-list body))
(defun math-define-list (body &optional quote)
(cond ((null body)
(math-define-list (cdr body))))
(t
(cons (math-define-exp (car body))
- (math-define-list (cdr body)))))
-)
+ (math-define-list (cdr body))))))
(defun math-define-exp (exp)
(cond ((consp exp)
(if (and (consp (nth 1 exp))
(eq (car (nth 1 exp)) 'lambda))
(cons 'quote
- (math-define-lambda (nth 1 exp) exp-env))
+ (math-define-lambda (nth 1 exp) math-exp-env))
exp))
((memq func '(let let* for foreach))
(let ((head (nth 1 exp))
(math-define-body body
(nconc
(math-define-let-env head)
- exp-env)))))))
+ math-exp-env)))))))
((and (memq func '(setq setf))
(math-complicated-lhs (cdr exp)))
(if (> (length exp) 3)
(cons (nth 1 exp)
(math-define-body (cdr (cdr exp))
(cons (nth 1 exp)
- exp-env)))))
+ math-exp-env)))))
((eq func 'cond)
(cons func
(math-define-cond (cdr exp))))
(cons func args))
(t
(cons cfunc args)))))))))
- (t (cons func args)))))
+ (t (cons func (math-define-list (cdr exp))))))) ;;args
((symbolp exp)
(let ((prim (assq exp math-prim-vars))
(name (symbol-name exp)))
(cond (prim
(cdr prim))
- ((memq exp exp-env)
+ ((memq exp math-exp-env)
exp)
((string-match "-" name)
exp)
(if (or (<= exp -1000000) (>= exp 1000000))
(list 'quote (math-normalize exp))
exp))
- (t exp))
-)
+ (t exp)))
(defun math-define-cond (forms)
(and forms
(cons (math-define-list (car forms))
- (math-define-cond (cdr forms))))
-)
+ (math-define-cond (cdr forms)))))
(defun math-complicated-lhs (body)
(and body
(or (not (symbolp (car body)))
- (math-complicated-lhs (cdr (cdr body)))))
-)
+ (math-complicated-lhs (cdr (cdr body))))))
(defun math-define-setf-list (body)
(and body
(cons (math-define-setf (nth 0 body) (nth 1 body))
- (math-define-setf-list (cdr (cdr body)))))
-)
+ (math-define-setf-list (cdr (cdr body))))))
(defun math-define-setf (place value)
(setq place (math-define-exp place)
((eq (car-safe place) 'cdr)
(list 'setcdr (nth 1 place) value))
(t
- (error "Bad place form for setf: %s" place)))
-)
+ (error "Bad place form for setf: %s" place))))
(defun math-define-binop (op ident arg1 rest)
(if rest
(math-define-binop op ident
(list op arg1 (car rest))
(cdr rest))
- (or arg1 ident))
-)
+ (or arg1 ident)))
(defun math-define-let (vlist)
(and vlist
(cons (car (car vlist))
(math-define-list (cdr (car vlist))))
(car vlist))
- (math-define-let (cdr vlist))))
-)
+ (math-define-let (cdr vlist)))))
(defun math-define-let-env (vlist)
(and vlist
(cons (if (consp (car vlist))
(car (car vlist))
(car vlist))
- (math-define-let-env (cdr vlist))))
-)
+ (math-define-let-env (cdr vlist)))))
(defun math-define-lambda (exp exp-env)
(nconc (list (nth 0 exp) ; 'lambda
(nth 1 exp)) ; arg list
(math-define-function-body (cdr (cdr exp))
- (append (nth 1 exp) exp-env)))
-)
+ (append (nth 1 exp) exp-env))))
(defun math-define-elt (seq idx)
(if idx
(math-define-elt (list 'elt seq (car idx)) (cdr idx))
- seq)
-)
-
+ seq))
;;; Useful programming macros.
(let ((body (cons 'while (cons head body))))
(if (math-body-refers-to body 'math-break)
(cons 'catch (cons '(quote math-break) (list body)))
- body))
-)
-
+ body)))
(defmacro math-for (head &rest body)
(let ((body (if head
(cons 'while (cons t body)))))
(if (math-body-refers-to body 'math-break)
(cons 'catch (cons '(quote math-break) (list body)))
- body))
-)
+ body)))
(defun math-handle-for (head body)
(let* ((var (nth 0 (car head)))
'+
'math-add)
var
- save-step))))))))))
-)
-
+ save-step)))))))))))
(defmacro math-foreach (head &rest body)
(let ((body (math-handle-foreach head body)))
(if (math-body-refers-to body 'math-break)
(cons 'catch (cons '(quote math-break) (list body)))
- body))
-)
-
+ body)))
(defun math-handle-foreach (head body)
(let ((var (nth 0 (car head)))
(append body
(list (list 'setq
var
- (list 'cdr var))))))))))
-)
+ (list 'cdr var)))))))))))
(defun math-body-refers-to (body thing)
(or (equal body thing)
(and (consp body)
(or (math-body-refers-to (car body) thing)
- (math-body-refers-to (cdr body) thing))))
-)
+ (math-body-refers-to (cdr body) thing)))))
(defun math-break (&optional value)
- (throw 'math-break value)
-)
+ (throw 'math-break value))
(defun math-return (&optional value)
- (throw 'math-return value)
-)
-
-
-
+ (throw 'math-return value))
(defun math-composite-inequalities (x op)
(+ (if (eq (nth 1 op) 'calcFunc-geq) 2 0)
(if (eq (car x) 'calcFunc-geq) 1 0))
(math-read-expr-level (nth 3 op)) (nth 1 x))
- (throw 'syntax "Syntax error")))))
-)
+ (throw 'syntax "Syntax error"))))))
+
+(provide 'calc-prog)
+;;; calc-prog.el ends here
projects / packages / blobdiff