41271
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
diff
changeset
|
1 ;;; calc-prog.el --- user programmability functions for Calc
|
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
diff
changeset
|
2
|
64325
|
3 ;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
|
100908
|
4 ;; 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
|
41271
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
diff
changeset
|
5
|
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
diff
changeset
|
6 ;; Author: David Gillespie <daveg@synaptics.com>
|
77465
|
7 ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
|
40785
|
8
|
|
9 ;; This file is part of GNU Emacs.
|
|
10
|
94654
|
11 ;; GNU Emacs is free software: you can redistribute it and/or modify
|
76595
|
12 ;; it under the terms of the GNU General Public License as published by
|
94654
|
13 ;; the Free Software Foundation, either version 3 of the License, or
|
|
14 ;; (at your option) any later version.
|
40785
|
15
|
76595
|
16 ;; GNU Emacs is distributed in the hope that it will be useful,
|
|
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
19 ;; GNU General Public License for more details.
|
|
20
|
|
21 ;; You should have received a copy of the GNU General Public License
|
94654
|
22 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
|
40785
|
23
|
41271
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
diff
changeset
|
24 ;;; Commentary:
|
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
diff
changeset
|
25
|
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
diff
changeset
|
26 ;;; Code:
|
40785
|
27
|
|
28 ;; This file is autoloaded from calc-ext.el.
|
|
29
|
58668
|
30 (require 'calc-ext)
|
40785
|
31 (require 'calc-macs)
|
|
32
|
86481
|
33 ;; Declare functions which are defined elsewhere.
|
|
34 (declare-function edmacro-format-keys "edmacro" (macro &optional verbose))
|
|
35 (declare-function edmacro-parse-keys "edmacro" (string &optional need-vector))
|
|
36 (declare-function math-read-expr-level "calc-aent" (exp-prec &optional exp-term))
|
|
37
|
40785
|
38
|
|
39 (defun calc-equal-to (arg)
|
|
40 (interactive "P")
|
|
41 (calc-wrapper
|
|
42 (if (and (integerp arg) (> arg 2))
|
|
43 (calc-enter-result arg "eq" (cons 'calcFunc-eq (calc-top-list-n arg)))
|
41047
|
44 (calc-binary-op "eq" 'calcFunc-eq arg))))
|
40785
|
45
|
|
46 (defun calc-remove-equal (arg)
|
|
47 (interactive "P")
|
|
48 (calc-wrapper
|
41047
|
49 (calc-unary-op "rmeq" 'calcFunc-rmeq arg)))
|
40785
|
50
|
|
51 (defun calc-not-equal-to (arg)
|
|
52 (interactive "P")
|
|
53 (calc-wrapper
|
|
54 (if (and (integerp arg) (> arg 2))
|
|
55 (calc-enter-result arg "neq" (cons 'calcFunc-neq (calc-top-list-n arg)))
|
41047
|
56 (calc-binary-op "neq" 'calcFunc-neq arg))))
|
40785
|
57
|
|
58 (defun calc-less-than (arg)
|
|
59 (interactive "P")
|
|
60 (calc-wrapper
|
41047
|
61 (calc-binary-op "lt" 'calcFunc-lt arg)))
|
40785
|
62
|
|
63 (defun calc-greater-than (arg)
|
|
64 (interactive "P")
|
|
65 (calc-wrapper
|
41047
|
66 (calc-binary-op "gt" 'calcFunc-gt arg)))
|
40785
|
67
|
|
68 (defun calc-less-equal (arg)
|
|
69 (interactive "P")
|
|
70 (calc-wrapper
|
41047
|
71 (calc-binary-op "leq" 'calcFunc-leq arg)))
|
40785
|
72
|
|
73 (defun calc-greater-equal (arg)
|
|
74 (interactive "P")
|
|
75 (calc-wrapper
|
41047
|
76 (calc-binary-op "geq" 'calcFunc-geq arg)))
|
40785
|
77
|
|
78 (defun calc-in-set (arg)
|
|
79 (interactive "P")
|
|
80 (calc-wrapper
|
41047
|
81 (calc-binary-op "in" 'calcFunc-in arg)))
|
40785
|
82
|
|
83 (defun calc-logical-and (arg)
|
|
84 (interactive "P")
|
|
85 (calc-wrapper
|
41047
|
86 (calc-binary-op "land" 'calcFunc-land arg 1)))
|
40785
|
87
|
|
88 (defun calc-logical-or (arg)
|
|
89 (interactive "P")
|
|
90 (calc-wrapper
|
41047
|
91 (calc-binary-op "lor" 'calcFunc-lor arg 0)))
|
40785
|
92
|
|
93 (defun calc-logical-not (arg)
|
|
94 (interactive "P")
|
|
95 (calc-wrapper
|
41047
|
96 (calc-unary-op "lnot" 'calcFunc-lnot arg)))
|
40785
|
97
|
|
98 (defun calc-logical-if ()
|
|
99 (interactive)
|
|
100 (calc-wrapper
|
41047
|
101 (calc-enter-result 3 "if" (cons 'calcFunc-if (calc-top-list-n 3)))))
|
40785
|
102
|
|
103
|
|
104
|
|
105
|
|
106
|
|
107 (defun calc-timing (n)
|
|
108 (interactive "P")
|
|
109 (calc-wrapper
|
|
110 (calc-change-mode 'calc-timing n nil t)
|
|
111 (message (if calc-timing
|
41271
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
diff
changeset
|
112 "Reporting timing of slow commands in Trail"
|
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
diff
changeset
|
113 "Not reporting timing of commands"))))
|
40785
|
114
|
|
115 (defun calc-pass-errors ()
|
|
116 (interactive)
|
|
117 ;; The following two cases are for the new, optimizing byte compiler
|
|
118 ;; or the standard 18.57 byte compiler, respectively.
|
|
119 (condition-case err
|
|
120 (let ((place (aref (nth 2 (nth 2 (symbol-function 'calc-do))) 15)))
|
|
121 (or (memq (car-safe (car-safe place)) '(error xxxerror))
|
|
122 (setq place (aref (nth 2 (nth 2 (symbol-function 'calc-do))) 27)))
|
|
123 (or (memq (car (car place)) '(error xxxerror))
|
|
124 (error "foo"))
|
|
125 (setcar (car place) 'xxxerror))
|
41271
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
diff
changeset
|
126 (error (error "The calc-do function has been modified; unable to patch"))))
|
40785
|
127
|
|
128 (defun calc-user-define ()
|
|
129 (interactive)
|
|
130 (message "Define user key: z-")
|
|
131 (let ((key (read-char)))
|
|
132 (if (= (calc-user-function-classify key) 0)
|
|
133 (error "Can't redefine \"?\" key"))
|
|
134 (let ((func (intern (completing-read (concat "Set key z "
|
|
135 (char-to-string key)
|
|
136 " to command: ")
|
|
137 obarray
|
|
138 'commandp
|
|
139 t
|
|
140 "calc-"))))
|
|
141 (let* ((kmap (calc-user-key-map))
|
|
142 (old (assq key kmap)))
|
|
143 (if old
|
|
144 (setcdr old func)
|
41047
|
145 (setcdr kmap (cons (cons key func) (cdr kmap))))))))
|
40785
|
146
|
|
147 (defun calc-user-undefine ()
|
|
148 (interactive)
|
|
149 (message "Undefine user key: z-")
|
|
150 (let ((key (read-char)))
|
|
151 (if (= (calc-user-function-classify key) 0)
|
|
152 (error "Can't undefine \"?\" key"))
|
|
153 (let* ((kmap (calc-user-key-map)))
|
|
154 (delq (or (assq key kmap)
|
|
155 (assq (upcase key) kmap)
|
|
156 (assq (downcase key) kmap)
|
|
157 (error "No such user key is defined"))
|
41047
|
158 kmap))))
|
40785
|
159
|
58390
|
160
|
|
161 ;; math-integral-cache-state is originally declared in calcalg2.el,
|
|
162 ;; it is used in calc-user-define-variable.
|
|
163 (defvar math-integral-cache-state)
|
|
164
|
|
165 ;; calc-user-formula-alist is local to calc-user-define-formula,
|
92025
|
166 ;; calc-user-define-composition and calc-finish-formula-edit,
|
58390
|
167 ;; but is used by calc-fix-user-formula.
|
|
168 (defvar calc-user-formula-alist)
|
|
169
|
40785
|
170 (defun calc-user-define-formula ()
|
|
171 (interactive)
|
|
172 (calc-wrapper
|
|
173 (let* ((form (calc-top 1))
|
|
174 (arglist nil)
|
|
175 (is-lambda (and (eq (car-safe form) 'calcFunc-lambda)
|
|
176 (>= (length form) 2)))
|
59184
a4aaaf92f7da
(calc-user-define-formula): Put default values for function names in
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
177 odef key keyname cmd cmd-base cmd-base-default
|
a4aaaf92f7da
(calc-user-define-formula): Put default values for function names in
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
178 func calc-user-formula-alist is-symb)
|
40785
|
179 (if is-lambda
|
|
180 (setq arglist (mapcar (function (lambda (x) (nth 1 x)))
|
|
181 (nreverse (cdr (reverse (cdr form)))))
|
|
182 form (nth (1- (length form)) form))
|
|
183 (calc-default-formula-arglist form)
|
|
184 (setq arglist (sort arglist 'string-lessp)))
|
|
185 (message "Define user key: z-")
|
|
186 (setq key (read-char))
|
|
187 (if (= (calc-user-function-classify key) 0)
|
|
188 (error "Can't redefine \"?\" key"))
|
|
189 (setq key (and (not (memq key '(13 32))) key)
|
|
190 keyname (and key
|
|
191 (if (or (and (<= ?0 key) (<= key ?9))
|
|
192 (and (<= ?a key) (<= key ?z))
|
|
193 (and (<= ?A key) (<= key ?Z)))
|
|
194 (char-to-string key)
|
|
195 (format "%03d" key)))
|
|
196 odef (assq key (calc-user-key-map)))
|
59184
a4aaaf92f7da
(calc-user-define-formula): Put default values for function names in
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
197 (unless keyname
|
a4aaaf92f7da
(calc-user-define-formula): Put default values for function names in
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
198 (setq keyname (format "%05d" (abs (% (random) 10000)))))
|
40785
|
199 (while
|
|
200 (progn
|
59184
a4aaaf92f7da
(calc-user-define-formula): Put default values for function names in
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
201 (setq cmd-base-default (concat "User-" keyname))
|
105022
|
202 (setq cmd (completing-read
|
65680
|
203 (concat "Define M-x command name (default calc-"
|
59184
a4aaaf92f7da
(calc-user-define-formula): Put default values for function names in
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
204 cmd-base-default
|
a4aaaf92f7da
(calc-user-define-formula): Put default values for function names in
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
205 "): ")
|
a4aaaf92f7da
(calc-user-define-formula): Put default values for function names in
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
206 obarray 'commandp nil
|
a4aaaf92f7da
(calc-user-define-formula): Put default values for function names in
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
207 (if (and odef (symbolp (cdr odef)))
|
a4aaaf92f7da
(calc-user-define-formula): Put default values for function names in
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
208 (symbol-name (cdr odef))
|
a4aaaf92f7da
(calc-user-define-formula): Put default values for function names in
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
209 "calc-")))
|
a4aaaf92f7da
(calc-user-define-formula): Put default values for function names in
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
210 (if (or (string-equal cmd "")
|
a4aaaf92f7da
(calc-user-define-formula): Put default values for function names in
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
211 (string-equal cmd "calc-"))
|
a4aaaf92f7da
(calc-user-define-formula): Put default values for function names in
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
212 (setq cmd (concat "calc-User-" keyname)))
|
a4aaaf92f7da
(calc-user-define-formula): Put default values for function names in
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
213 (setq cmd-base (and (string-match "\\`calc-\\(.+\\)\\'" cmd)
|
a4aaaf92f7da
(calc-user-define-formula): Put default values for function names in
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
214 (math-match-substring cmd 1)))
|
a4aaaf92f7da
(calc-user-define-formula): Put default values for function names in
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
215 (setq cmd (intern cmd))
|
40785
|
216 (and cmd
|
|
217 (fboundp cmd)
|
|
218 odef
|
|
219 (not
|
|
220 (y-or-n-p
|
|
221 (if (get cmd 'calc-user-defn)
|
|
222 (concat "Replace previous definition for "
|
|
223 (symbol-name cmd) "? ")
|
|
224 "That name conflicts with a built-in Emacs function. Replace this function? "))))))
|
|
225 (while
|
|
226 (progn
|
105022
|
227 (setq cmd-base-default
|
59184
a4aaaf92f7da
(calc-user-define-formula): Put default values for function names in
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
228 (if cmd-base
|
a4aaaf92f7da
(calc-user-define-formula): Put default values for function names in
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
229 (if (string-match
|
a4aaaf92f7da
(calc-user-define-formula): Put default values for function names in
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
230 "\\`User-.+" cmd-base)
|
a4aaaf92f7da
(calc-user-define-formula): Put default values for function names in
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
231 (concat
|
a4aaaf92f7da
(calc-user-define-formula): Put default values for function names in
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
232 "User"
|
a4aaaf92f7da
(calc-user-define-formula): Put default values for function names in
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
233 (substring cmd-base 5))
|
a4aaaf92f7da
(calc-user-define-formula): Put default values for function names in
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
234 cmd-base)
|
a4aaaf92f7da
(calc-user-define-formula): Put default values for function names in
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
235 (concat "User" keyname)))
|
105022
|
236 (setq func
|
59183
f27d7a9c6f27
(calc-user-define-permanent, calc-user-define-composition)
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
237 (concat "calcFunc-"
|
105022
|
238 (completing-read
|
65680
|
239 (concat "Define algebraic function name (default "
|
59184
a4aaaf92f7da
(calc-user-define-formula): Put default values for function names in
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
240 cmd-base-default "): ")
|
a4aaaf92f7da
(calc-user-define-formula): Put default values for function names in
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
241 (mapcar (lambda (x) (substring x 9))
|
a4aaaf92f7da
(calc-user-define-formula): Put default values for function names in
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
242 (all-completions "calcFunc-"
|
a4aaaf92f7da
(calc-user-define-formula): Put default values for function names in
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
243 obarray))
|
105022
|
244 (lambda (x)
|
|
245 (fboundp
|
59184
a4aaaf92f7da
(calc-user-define-formula): Put default values for function names in
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
246 (intern (concat "calcFunc-" x))))
|
a4aaaf92f7da
(calc-user-define-formula): Put default values for function names in
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
247 nil)))
|
a4aaaf92f7da
(calc-user-define-formula): Put default values for function names in
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
248 (setq func
|
a4aaaf92f7da
(calc-user-define-formula): Put default values for function names in
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
249 (if (string-equal func "calcFunc-")
|
a4aaaf92f7da
(calc-user-define-formula): Put default values for function names in
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
250 (intern (concat "calcFunc-" cmd-base-default))
|
a4aaaf92f7da
(calc-user-define-formula): Put default values for function names in
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
251 (intern func)))
|
40785
|
252 (and func
|
|
253 (fboundp func)
|
|
254 (not (fboundp cmd))
|
|
255 odef
|
|
256 (not
|
|
257 (y-or-n-p
|
|
258 (if (get func 'calc-user-defn)
|
|
259 (concat "Replace previous definition for "
|
|
260 (symbol-name func) "? ")
|
|
261 "That name conflicts with a built-in Emacs function. Replace this function? "))))))
|
59184
a4aaaf92f7da
(calc-user-define-formula): Put default values for function names in
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
262
|
40785
|
263 (if (not func)
|
|
264 (setq func (intern (concat "calcFunc-User"
|
|
265 (or keyname
|
|
266 (and cmd (symbol-name cmd))
|
|
267 (format "%05d" (% (random) 10000)))))))
|
59184
a4aaaf92f7da
(calc-user-define-formula): Put default values for function names in
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
268
|
40785
|
269 (if is-lambda
|
58390
|
270 (setq calc-user-formula-alist arglist)
|
40785
|
271 (while
|
|
272 (progn
|
105022
|
273 (setq calc-user-formula-alist
|
58390
|
274 (read-from-minibuffer "Function argument list: "
|
|
275 (if arglist
|
|
276 (prin1-to-string arglist)
|
|
277 "()")
|
|
278 minibuffer-local-map
|
|
279 t))
|
|
280 (and (not (calc-subsetp calc-user-formula-alist arglist))
|
40785
|
281 (not (y-or-n-p
|
|
282 "Okay for arguments that don't appear in formula to be ignored? "))))))
|
58390
|
283 (setq is-symb (and calc-user-formula-alist
|
40785
|
284 func
|
|
285 (y-or-n-p
|
|
286 "Leave it symbolic for non-constant arguments? ")))
|
105022
|
287 (setq calc-user-formula-alist
|
58390
|
288 (mapcar (function (lambda (x)
|
|
289 (or (cdr (assq x '((nil . arg-nil)
|
|
290 (t . arg-t))))
|
|
291 x))) calc-user-formula-alist))
|
40785
|
292 (if cmd
|
|
293 (progn
|
58614
eba1cd703531
(calc-user-define-formula, calc-do-defmath): Replace calc-need-macros by
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
294 (require 'calc-macs)
|
40785
|
295 (fset cmd
|
|
296 (list 'lambda
|
|
297 '()
|
|
298 '(interactive)
|
|
299 (list 'calc-wrapper
|
|
300 (list 'calc-enter-result
|
58390
|
301 (length calc-user-formula-alist)
|
40785
|
302 (let ((name (symbol-name (or func cmd))))
|
|
303 (and (string-match
|
|
304 "\\([^-][^-]?[^-]?[^-]?\\)[^-]*\\'"
|
|
305 name)
|
|
306 (math-match-substring name 1)))
|
|
307 (list 'cons
|
|
308 (list 'quote func)
|
|
309 (list 'calc-top-list-n
|
58390
|
310 (length calc-user-formula-alist)))))))
|
40785
|
311 (put cmd 'calc-user-defn t)))
|
|
312 (let ((body (list 'math-normalize (calc-fix-user-formula form))))
|
|
313 (fset func
|
|
314 (append
|
58390
|
315 (list 'lambda calc-user-formula-alist)
|
40785
|
316 (and is-symb
|
|
317 (mapcar (function (lambda (v)
|
|
318 (list 'math-check-const v t)))
|
58390
|
319 calc-user-formula-alist))
|
40785
|
320 (list body))))
|
|
321 (put func 'calc-user-defn form)
|
|
322 (setq math-integral-cache-state nil)
|
|
323 (if key
|
|
324 (let* ((kmap (calc-user-key-map))
|
|
325 (old (assq key kmap)))
|
|
326 (if old
|
|
327 (setcdr old cmd)
|
|
328 (setcdr kmap (cons (cons key cmd) (cdr kmap)))))))
|
41047
|
329 (message "")))
|
40785
|
330
|
105022
|
331 (defvar arglist) ; dynamically bound in all callers
|
40785
|
332 (defun calc-default-formula-arglist (form)
|
|
333 (if (consp form)
|
|
334 (if (eq (car form) 'var)
|
|
335 (if (or (memq (nth 1 form) arglist)
|
|
336 (math-const-var form))
|
|
337 ()
|
|
338 (setq arglist (cons (nth 1 form) arglist)))
|
41047
|
339 (calc-default-formula-arglist-step (cdr form)))))
|
40785
|
340
|
|
341 (defun calc-default-formula-arglist-step (l)
|
|
342 (and l
|
|
343 (progn
|
|
344 (calc-default-formula-arglist (car l))
|
41047
|
345 (calc-default-formula-arglist-step (cdr l)))))
|
40785
|
346
|
|
347 (defun calc-subsetp (a b)
|
|
348 (or (null a)
|
|
349 (and (memq (car a) b)
|
41047
|
350 (calc-subsetp (cdr a) b))))
|
40785
|
351
|
|
352 (defun calc-fix-user-formula (f)
|
|
353 (if (consp f)
|
|
354 (let (temp)
|
|
355 (cond ((and (eq (car f) 'var)
|
|
356 (memq (setq temp (or (cdr (assq (nth 1 f) '((nil . arg-nil)
|
|
357 (t . arg-t))))
|
|
358 (nth 1 f)))
|
58390
|
359 calc-user-formula-alist))
|
40785
|
360 temp)
|
|
361 ((or (math-constp f) (eq (car f) 'var))
|
|
362 (list 'quote f))
|
|
363 ((and (eq (car f) 'calcFunc-eval)
|
|
364 (= (length f) 2))
|
|
365 (list 'let '((calc-simplify-mode nil))
|
|
366 (list 'math-normalize (calc-fix-user-formula (nth 1 f)))))
|
|
367 ((and (eq (car f) 'calcFunc-evalsimp)
|
|
368 (= (length f) 2))
|
|
369 (list 'math-simplify (calc-fix-user-formula (nth 1 f))))
|
|
370 ((and (eq (car f) 'calcFunc-evalextsimp)
|
|
371 (= (length f) 2))
|
|
372 (list 'math-simplify-extended
|
|
373 (calc-fix-user-formula (nth 1 f))))
|
|
374 (t
|
|
375 (cons 'list
|
|
376 (cons (list 'quote (car f))
|
|
377 (mapcar 'calc-fix-user-formula (cdr f)))))))
|
41047
|
378 f))
|
40785
|
379
|
|
380 (defun calc-user-define-composition ()
|
|
381 (interactive)
|
|
382 (calc-wrapper
|
|
383 (if (eq calc-language 'unform)
|
|
384 (error "Can't define formats for unformatted mode"))
|
|
385 (let* ((comp (calc-top 1))
|
105022
|
386 (func (intern
|
59183
f27d7a9c6f27
(calc-user-define-permanent, calc-user-define-composition)
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
387 (concat "calcFunc-"
|
f27d7a9c6f27
(calc-user-define-permanent, calc-user-define-composition)
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
388 (completing-read "Define format for which function: "
|
f27d7a9c6f27
(calc-user-define-permanent, calc-user-define-composition)
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
389 (mapcar (lambda (x) (substring x 9))
|
f27d7a9c6f27
(calc-user-define-permanent, calc-user-define-composition)
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
390 (all-completions "calcFunc-"
|
f27d7a9c6f27
(calc-user-define-permanent, calc-user-define-composition)
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
391 obarray))
|
105022
|
392 (lambda (x)
|
|
393 (fboundp
|
59183
f27d7a9c6f27
(calc-user-define-permanent, calc-user-define-composition)
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
394 (intern (concat "calcFunc-" x))))))))
|
40785
|
395 (comps (get func 'math-compose-forms))
|
|
396 entry entry2
|
|
397 (arglist nil)
|
58390
|
398 (calc-user-formula-alist nil))
|
40785
|
399 (if (math-zerop comp)
|
|
400 (if (setq entry (assq calc-language comps))
|
|
401 (put func 'math-compose-forms (delq entry comps)))
|
|
402 (calc-default-formula-arglist comp)
|
|
403 (setq arglist (sort arglist 'string-lessp))
|
|
404 (while
|
|
405 (progn
|
105022
|
406 (setq calc-user-formula-alist
|
58390
|
407 (read-from-minibuffer "Composition argument list: "
|
|
408 (if arglist
|
|
409 (prin1-to-string arglist)
|
|
410 "()")
|
|
411 minibuffer-local-map
|
|
412 t))
|
|
413 (and (not (calc-subsetp calc-user-formula-alist arglist))
|
40785
|
414 (y-or-n-p
|
|
415 "Okay for arguments that don't appear in formula to be invisible? "))))
|
|
416 (or (setq entry (assq calc-language comps))
|
|
417 (put func 'math-compose-forms
|
|
418 (cons (setq entry (list calc-language)) comps)))
|
58390
|
419 (or (setq entry2 (assq (length calc-user-formula-alist) (cdr entry)))
|
40785
|
420 (setcdr entry
|
105022
|
421 (cons (setq entry2
|
58390
|
422 (list (length calc-user-formula-alist))) (cdr entry))))
|
105022
|
423 (setcdr entry2
|
58390
|
424 (list 'lambda calc-user-formula-alist (calc-fix-user-formula comp))))
|
40785
|
425 (calc-pop-stack 1)
|
41047
|
426 (calc-do-refresh))))
|
40785
|
427
|
|
428
|
|
429 (defun calc-user-define-kbd-macro (arg)
|
|
430 (interactive "P")
|
|
431 (or last-kbd-macro
|
|
432 (error "No keyboard macro defined"))
|
|
433 (message "Define last kbd macro on user key: z-")
|
|
434 (let ((key (read-char)))
|
|
435 (if (= (calc-user-function-classify key) 0)
|
|
436 (error "Can't redefine \"?\" key"))
|
|
437 (let ((cmd (intern (completing-read "Full name for new command: "
|
|
438 obarray
|
|
439 'commandp
|
|
440 nil
|
|
441 (concat "calc-User-"
|
|
442 (if (or (and (>= key ?a)
|
|
443 (<= key ?z))
|
|
444 (and (>= key ?A)
|
|
445 (<= key ?Z))
|
|
446 (and (>= key ?0)
|
|
447 (<= key ?9)))
|
|
448 (char-to-string key)
|
|
449 (format "%03d" key)))))))
|
|
450 (and (fboundp cmd)
|
|
451 (not (let ((f (symbol-function cmd)))
|
|
452 (or (stringp f)
|
|
453 (and (consp f)
|
|
454 (eq (car-safe (nth 3 f))
|
|
455 'calc-execute-kbd-macro)))))
|
|
456 (error "Function %s is already defined and not a keyboard macro"
|
|
457 cmd))
|
|
458 (put cmd 'calc-user-defn t)
|
|
459 (fset cmd (if (< (prefix-numeric-value arg) 0)
|
|
460 last-kbd-macro
|
|
461 (list 'lambda
|
|
462 '(arg)
|
|
463 '(interactive "P")
|
|
464 (list 'calc-execute-kbd-macro
|
|
465 (vector (key-description last-kbd-macro)
|
|
466 last-kbd-macro)
|
|
467 'arg
|
|
468 (format "z%c" key)))))
|
|
469 (let* ((kmap (calc-user-key-map))
|
|
470 (old (assq key kmap)))
|
|
471 (if old
|
|
472 (setcdr old cmd)
|
41047
|
473 (setcdr kmap (cons (cons key cmd) (cdr kmap))))))))
|
40785
|
474
|
|
475
|
|
476 (defun calc-edit-user-syntax ()
|
|
477 (interactive)
|
|
478 (calc-wrapper
|
|
479 (let ((lang calc-language))
|
|
480 (calc-edit-mode (list 'calc-finish-user-syntax-edit (list 'quote lang))
|
|
481 t
|
59298
bcf56eea4fb8
(calc-edit-user-syntax): Change title to edit mode to match new
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
482 (format "Editing %s-Mode Syntax Table. "
|
40785
|
483 (cond ((null lang) "Normal")
|
|
484 ((eq lang 'tex) "TeX")
|
59812
|
485 ((eq lang 'latex) "LaTeX")
|
40785
|
486 (t (capitalize (symbol-name lang))))))
|
|
487 (calc-write-parse-table (cdr (assq lang calc-user-parse-tables))
|
|
488 lang)))
|
41047
|
489 (calc-show-edit-buffer))
|
40785
|
490
|
58390
|
491 (defvar calc-original-buffer)
|
|
492
|
40785
|
493 (defun calc-finish-user-syntax-edit (lang)
|
|
494 (let ((tab (calc-read-parse-table calc-original-buffer lang))
|
|
495 (entry (assq lang calc-user-parse-tables)))
|
|
496 (if tab
|
|
497 (setcdr (or entry
|
|
498 (car (setq calc-user-parse-tables
|
|
499 (cons (list lang) calc-user-parse-tables))))
|
|
500 tab)
|
|
501 (if entry
|
|
502 (setq calc-user-parse-tables
|
|
503 (delq entry calc-user-parse-tables)))))
|
41047
|
504 (switch-to-buffer calc-original-buffer))
|
40785
|
505
|
58390
|
506 ;; The variable calc-lang is local to calc-write-parse-table, but is
|
105022
|
507 ;; used by calc-write-parse-table-part which is called by
|
|
508 ;; calc-write-parse-table. The variable is also local to
|
58390
|
509 ;; calc-read-parse-table, but is used by calc-fix-token-name which
|
|
510 ;; is called (indirectly) by calc-read-parse-table.
|
|
511 (defvar calc-lang)
|
|
512
|
40785
|
513 (defun calc-write-parse-table (tab calc-lang)
|
|
514 (let ((p tab))
|
|
515 (while p
|
|
516 (calc-write-parse-table-part (car (car p)))
|
|
517 (insert ":= "
|
|
518 (let ((math-format-hash-args t))
|
|
519 (math-format-flat-expr (cdr (car p)) 0))
|
|
520 "\n")
|
41047
|
521 (setq p (cdr p)))))
|
40785
|
522
|
|
523 (defun calc-write-parse-table-part (p)
|
|
524 (while p
|
|
525 (cond ((stringp (car p))
|
|
526 (let ((s (car p)))
|
|
527 (if (and (string-match "\\`\\\\dots\\>" s)
|
59983
d3632c99711e
(calc-write-parse-table-part, calc-fix-token-name): Fix a check for
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
528 (not (memq calc-lang '(tex latex))))
|
40785
|
529 (setq s (concat ".." (substring s 5))))
|
|
530 (if (or (and (string-match
|
|
531 "[a-zA-Z0-9\"{}]\\|\\`:=\\'\\|\\`#\\|\\`%%" s)
|
|
532 (string-match "[^a-zA-Z0-9\\]" s))
|
|
533 (and (assoc s '((")") ("]") (">")))
|
|
534 (not (cdr p))))
|
|
535 (insert (prin1-to-string s) " ")
|
|
536 (insert s " "))))
|
|
537 ((integerp (car p))
|
|
538 (insert "#")
|
|
539 (or (= (car p) 0)
|
|
540 (insert "/" (int-to-string (car p))))
|
|
541 (insert " "))
|
|
542 ((and (eq (car (car p)) '\?) (equal (car (nth 2 (car p))) "$$"))
|
|
543 (insert (car (nth 1 (car p))) " "))
|
|
544 (t
|
|
545 (insert "{ ")
|
|
546 (calc-write-parse-table-part (nth 1 (car p)))
|
|
547 (insert "}" (symbol-name (car (car p))))
|
|
548 (if (nth 2 (car p))
|
|
549 (calc-write-parse-table-part (list (car (nth 2 (car p)))))
|
|
550 (insert " "))))
|
41047
|
551 (setq p (cdr p))))
|
40785
|
552
|
|
553 (defun calc-read-parse-table (calc-buf calc-lang)
|
|
554 (let ((tab nil))
|
|
555 (while (progn
|
|
556 (skip-chars-forward "\n\t ")
|
|
557 (not (eobp)))
|
|
558 (if (looking-at "%%")
|
|
559 (end-of-line)
|
|
560 (let ((pt (point))
|
|
561 (p (calc-read-parse-table-part ":=[\n\t ]+" ":=")))
|
|
562 (or (stringp (car p))
|
|
563 (and (integerp (car p))
|
|
564 (stringp (nth 1 p)))
|
|
565 (progn
|
|
566 (goto-char pt)
|
|
567 (error "Malformed syntax rule")))
|
|
568 (let ((pos (point)))
|
|
569 (end-of-line)
|
|
570 (let* ((str (buffer-substring pos (point)))
|
|
571 (exp (save-excursion
|
|
572 (set-buffer calc-buf)
|
|
573 (let ((calc-user-parse-tables nil)
|
|
574 (calc-language nil)
|
81471
46f072d4a30f
(calc-read-parse-table): Let math-expr-opers equal the function
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
575 (math-expr-opers (math-standard-ops))
|
40785
|
576 (calc-hashes-used 0))
|
|
577 (math-read-expr
|
|
578 (if (string-match ",[ \t]*\\'" str)
|
|
579 (substring str 0 (match-beginning 0))
|
|
580 str))))))
|
|
581 (if (eq (car-safe exp) 'error)
|
|
582 (progn
|
|
583 (goto-char (+ pos (nth 1 exp)))
|
|
584 (error (nth 2 exp))))
|
|
585 (setq tab (nconc tab (list (cons p exp)))))))))
|
41047
|
586 tab))
|
40785
|
587
|
|
588 (defun calc-fix-token-name (name &optional unquoted)
|
|
589 (cond ((string-match "\\`\\.\\." name)
|
|
590 (concat "\\dots" (substring name 2)))
|
59812
|
591 ((and (equal name "{") (memq calc-lang '(tex latex eqn)))
|
40785
|
592 "(")
|
59812
|
593 ((and (equal name "}") (memq calc-lang '(tex latex eqn)))
|
40785
|
594 ")")
|
59983
d3632c99711e
(calc-write-parse-table-part, calc-fix-token-name): Fix a check for
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
595 ((and (equal name "&") (memq calc-lang '(tex latex)))
|
40785
|
596 ",")
|
|
597 ((equal name "#")
|
|
598 (search-backward "#")
|
|
599 (error "Token '#' is reserved"))
|
|
600 ((and unquoted (string-match "#" name))
|
|
601 (error "Tokens containing '#' must be quoted"))
|
|
602 ((not (string-match "[^ ]" name))
|
|
603 (search-backward "\"" nil t)
|
|
604 (error "Blank tokens are not allowed"))
|
41047
|
605 (t name)))
|
40785
|
606
|
|
607 (defun calc-read-parse-table-part (term eterm)
|
|
608 (let ((part nil)
|
|
609 (quoted nil))
|
|
610 (while (progn
|
|
611 (skip-chars-forward "\n\t ")
|
|
612 (if (eobp) (error "Expected '%s'" eterm))
|
|
613 (not (looking-at term)))
|
|
614 (cond ((looking-at "%%")
|
|
615 (end-of-line))
|
|
616 ((looking-at "{[\n\t ]")
|
|
617 (forward-char 2)
|
|
618 (let ((p (calc-read-parse-table-part "}" "}")))
|
|
619 (or (looking-at "[+*?]")
|
|
620 (error "Expected '+', '*', or '?'"))
|
|
621 (let ((sym (intern (buffer-substring (point) (1+ (point))))))
|
|
622 (forward-char 1)
|
|
623 (looking-at "[^\n\t ]*")
|
|
624 (let ((sep (buffer-substring (point) (match-end 0))))
|
|
625 (goto-char (match-end 0))
|
|
626 (and (eq sym '\?) (> (length sep) 0)
|
|
627 (not (equal sep "$")) (not (equal sep "."))
|
|
628 (error "Separator not allowed with { ... }?"))
|
|
629 (if (string-match "\\`\"" sep)
|
|
630 (setq sep (read-from-string sep)))
|
|
631 (setq sep (calc-fix-token-name sep))
|
|
632 (setq part (nconc part
|
|
633 (list (list sym p
|
|
634 (and (> (length sep) 0)
|
|
635 (cons sep p))))))))))
|
|
636 ((looking-at "}")
|
|
637 (error "Too many }'s"))
|
|
638 ((looking-at "\"")
|
|
639 (setq quoted (calc-fix-token-name (read (current-buffer)))
|
|
640 part (nconc part (list quoted))))
|
|
641 ((looking-at "#\\(\\(/[0-9]+\\)?\\)[\n\t ]")
|
|
642 (setq part (nconc part (list (if (= (match-beginning 1)
|
|
643 (match-end 1))
|
|
644 0
|
62038
a5b38402e3e1
(calc-read-parse-table-part, calc-edit-macro-repeats): Replace
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
645 (string-to-number
|
40785
|
646 (buffer-substring
|
|
647 (1+ (match-beginning 1))
|
|
648 (match-end 1)))))))
|
|
649 (goto-char (match-end 0)))
|
|
650 ((looking-at ":=[\n\t ]")
|
|
651 (error "Misplaced ':='"))
|
|
652 (t
|
|
653 (looking-at "[^\n\t ]*")
|
|
654 (let ((end (match-end 0)))
|
|
655 (setq part (nconc part (list (calc-fix-token-name
|
|
656 (buffer-substring
|
|
657 (point) end) t))))
|
|
658 (goto-char end)))))
|
|
659 (goto-char (match-end 0))
|
|
660 (let ((len (length part)))
|
|
661 (while (and (> len 1)
|
|
662 (let ((last (nthcdr (setq len (1- len)) part)))
|
|
663 (and (assoc (car last) '((")") ("]") (">")))
|
|
664 (not (eq (car last) quoted))
|
|
665 (setcar last
|
|
666 (list '\? (list (car last)) '("$$"))))))))
|
41047
|
667 part))
|
40785
|
668
|
|
669 (defun calc-user-define-invocation ()
|
|
670 (interactive)
|
|
671 (or last-kbd-macro
|
|
672 (error "No keyboard macro defined"))
|
|
673 (setq calc-invocation-macro last-kbd-macro)
|
67193
|
674 (message "Use `C-x * Z' to invoke this macro"))
|
40785
|
675
|
59295
|
676 (defun calc-user-define-edit ()
|
|
677 (interactive) ; but no calc-wrapper!
|
40785
|
678 (message "Edit definition of command: z-")
|
60170
|
679 (let* (cmdname
|
|
680 (key (read-char))
|
40785
|
681 (def (or (assq key (calc-user-key-map))
|
|
682 (assq (upcase key) (calc-user-key-map))
|
|
683 (assq (downcase key) (calc-user-key-map))
|
|
684 (error "No command defined for that key")))
|
|
685 (cmd (cdr def)))
|
59295
|
686 (when (symbolp cmd)
|
|
687 (setq cmdname (symbol-name cmd))
|
|
688 (setq cmd (symbol-function cmd)))
|
40785
|
689 (cond ((or (stringp cmd)
|
|
690 (and (consp cmd)
|
|
691 (eq (car-safe (nth 3 cmd)) 'calc-execute-kbd-macro)))
|
59295
|
692 (let* ((mac (elt (nth 1 (nth 3 cmd)) 1))
|
|
693 (str (edmacro-format-keys mac t))
|
59298
bcf56eea4fb8
(calc-edit-user-syntax): Change title to edit mode to match new
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
694 (kys (nth 3 (nth 3 cmd))))
|
105022
|
695 (calc-edit-mode
|
59298
bcf56eea4fb8
(calc-edit-user-syntax): Change title to edit mode to match new
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
696 (list 'calc-edit-macro-finish-edit cmdname kys)
|
105022
|
697 t (format (concat
|
|
698 "Editing keyboard macro (%s, bound to %s).\n"
|
59309
|
699 "Original keys: %s \n")
|
|
700 cmdname kys (elt (nth 1 (nth 3 cmd)) 0)))
|
59295
|
701 (insert str "\n")
|
|
702 (calc-edit-format-macro-buffer)
|
59309
|
703 (calc-show-edit-buffer)))
|
40785
|
704 (t (let* ((func (calc-stack-command-p cmd))
|
|
705 (defn (and func
|
|
706 (symbolp func)
|
59298
bcf56eea4fb8
(calc-edit-user-syntax): Change title to edit mode to match new
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
707 (get func 'calc-user-defn)))
|
bcf56eea4fb8
(calc-edit-user-syntax): Change title to edit mode to match new
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
708 (kys (concat "z" (char-to-string (car def))))
|
bcf56eea4fb8
(calc-edit-user-syntax): Change title to edit mode to match new
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
709 (intcmd (symbol-name (cdr def)))
|
62717
|
710 (algcmd (if func (substring (symbol-name func) 9) "")))
|
40785
|
711 (if (and defn (calc-valid-formula-func func))
|
59641
292caf631179
(calc-user-define-edit): Put original formula in formula editing buffer.
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
712 (let ((niceexpr (math-format-nice-expr defn (frame-width))))
|
40785
|
713 (calc-wrapper
|
105022
|
714 (calc-edit-mode
|
59298
bcf56eea4fb8
(calc-edit-user-syntax): Change title to edit mode to match new
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
715 (list 'calc-finish-formula-edit (list 'quote func))
|
bcf56eea4fb8
(calc-edit-user-syntax): Change title to edit mode to match new
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
716 nil
|
59641
292caf631179
(calc-user-define-edit): Put original formula in formula editing buffer.
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
717 (format (concat
|
292caf631179
(calc-user-define-edit): Put original formula in formula editing buffer.
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
718 "Editing formula (%s, %s, bound to %s).\n"
|
292caf631179
(calc-user-define-edit): Put original formula in formula editing buffer.
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
719 "Original formula: %s\n")
|
292caf631179
(calc-user-define-edit): Put original formula in formula editing buffer.
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
720 intcmd algcmd kys niceexpr))
|
59303
603f6649f30b
(calc-edit-user-formula, calc-finish-formula-edit): Handle extra line
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
721 (insert (math-showing-full-precision
|
59641
292caf631179
(calc-user-define-edit): Put original formula in formula editing buffer.
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
722 niceexpr)
|
59303
603f6649f30b
(calc-edit-user-formula, calc-finish-formula-edit): Handle extra line
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
723 "\n"))
|
59309
|
724 (calc-show-edit-buffer))
|
41047
|
725 (error "That command's definition cannot be edited")))))))
|
40785
|
726
|
59295
|
727 ;; Formatting the macro buffer
|
|
728
|
60170
|
729 (defvar calc-edit-top)
|
|
730
|
59295
|
731 (defun calc-edit-macro-repeats ()
|
59309
|
732 (goto-char calc-edit-top)
|
59295
|
733 (while
|
|
734 (re-search-forward "^\\([0-9]+\\)\\*" nil t)
|
62038
a5b38402e3e1
(calc-read-parse-table-part, calc-edit-macro-repeats): Replace
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
735 (let ((num (string-to-number (match-string 1)))
|
60170
|
736 (line (buffer-substring (point) (line-end-position))))
|
|
737 (goto-char (line-beginning-position))
|
|
738 (kill-line 1)
|
|
739 (while (> num 0)
|
|
740 (insert line "\n")
|
|
741 (setq num (1- num))))))
|
59295
|
742
|
|
743 (defun calc-edit-macro-adjust-buffer ()
|
|
744 (calc-edit-macro-repeats)
|
59309
|
745 (goto-char calc-edit-top)
|
59295
|
746 (while (re-search-forward "^RET$" nil t)
|
|
747 (delete-char 1))
|
59309
|
748 (goto-char calc-edit-top)
|
59295
|
749 (while (and (re-search-forward "^$" nil t)
|
|
750 (not (= (point) (point-max))))
|
|
751 (delete-char 1)))
|
|
752
|
|
753 (defun calc-edit-macro-command ()
|
|
754 "Return the command on the current line in a Calc macro editing buffer."
|
|
755 (let ((beg (line-beginning-position))
|
|
756 (end (save-excursion
|
|
757 (if (search-forward ";;" (line-end-position) 1)
|
|
758 (forward-char -2))
|
|
759 (skip-chars-backward " \t")
|
|
760 (point))))
|
|
761 (buffer-substring beg end)))
|
|
762
|
|
763 (defun calc-edit-macro-command-type ()
|
|
764 "Return the type of command on the current line in a Calc macro editing buffer."
|
|
765 (let ((beg (save-excursion
|
|
766 (if (search-forward ";;" (line-end-position) t)
|
|
767 (progn
|
|
768 (skip-chars-forward " \t")
|
|
769 (point)))))
|
|
770 (end (save-excursion
|
|
771 (goto-char (line-end-position))
|
|
772 (skip-chars-backward " \t")
|
|
773 (point))))
|
|
774 (if beg
|
|
775 (buffer-substring beg end)
|
|
776 "")))
|
|
777
|
|
778 (defun calc-edit-macro-combine-alg-ent ()
|
|
779 "Put an entire algebraic entry on a single line."
|
|
780 (let ((line (calc-edit-macro-command))
|
|
781 (type (calc-edit-macro-command-type))
|
|
782 curline
|
|
783 match)
|
|
784 (goto-char (line-beginning-position))
|
|
785 (kill-line 1)
|
|
786 (setq curline (calc-edit-macro-command))
|
|
787 (while (and curline
|
|
788 (not (string-equal "RET" curline))
|
|
789 (not (setq match (string-match "<return>" curline))))
|
|
790 (setq line (concat line curline))
|
|
791 (kill-line 1)
|
|
792 (setq curline (calc-edit-macro-command)))
|
|
793 (when match
|
|
794 (kill-line 1)
|
|
795 (setq line (concat line (substring curline 0 match))))
|
105022
|
796 (setq line (replace-regexp-in-string "SPC" " SPC "
|
59295
|
797 (replace-regexp-in-string " " "" line)))
|
|
798 (insert line "\t\t\t")
|
|
799 (if (> (current-column) 24)
|
|
800 (delete-char -1))
|
|
801 (insert ";; " type "\n")
|
|
802 (if match
|
|
803 (insert "RET\t\t\t;; calc-enter\n"))))
|
|
804
|
|
805 (defun calc-edit-macro-combine-ext-command ()
|
|
806 "Put an entire extended command on a single line."
|
|
807 (let ((cmdbeg (calc-edit-macro-command))
|
|
808 (line "")
|
|
809 (type (calc-edit-macro-command-type))
|
|
810 curline
|
|
811 match)
|
|
812 (goto-char (line-beginning-position))
|
|
813 (kill-line 1)
|
|
814 (setq curline (calc-edit-macro-command))
|
|
815 (while (and curline
|
|
816 (not (string-equal "RET" curline))
|
|
817 (not (setq match (string-match "<return>" curline))))
|
|
818 (setq line (concat line curline))
|
|
819 (kill-line 1)
|
|
820 (setq curline (calc-edit-macro-command)))
|
105022
|
821 (when match
|
59295
|
822 (kill-line 1)
|
|
823 (setq line (concat line (substring curline 0 match))))
|
|
824 (setq line (replace-regexp-in-string " " "" line))
|
|
825 (insert cmdbeg " " line "\t\t\t")
|
|
826 (if (> (current-column) 24)
|
|
827 (delete-char -1))
|
|
828 (insert ";; " type "\n")
|
|
829 (if match
|
|
830 (insert "RET\t\t\t;; calc-enter\n"))))
|
|
831
|
|
832 (defun calc-edit-macro-combine-var-name ()
|
|
833 "Put an entire variable name on a single line."
|
|
834 (let ((line (calc-edit-macro-command))
|
|
835 curline
|
|
836 match)
|
|
837 (goto-char (line-beginning-position))
|
|
838 (kill-line 1)
|
59298
bcf56eea4fb8
(calc-edit-user-syntax): Change title to edit mode to match new
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
839 (if (member line '("0" "1" "2" "3" "4" "5" "6" "7" "8" "9"))
|
59295
|
840 (insert line "\t\t\t;; calc quick variable\n")
|
|
841 (setq curline (calc-edit-macro-command))
|
|
842 (while (and curline
|
|
843 (not (string-equal "RET" curline))
|
|
844 (not (setq match (string-match "<return>" curline))))
|
|
845 (setq line (concat line curline))
|
|
846 (kill-line 1)
|
|
847 (setq curline (calc-edit-macro-command)))
|
105022
|
848 (when match
|
59295
|
849 (kill-line 1)
|
|
850 (setq line (concat line (substring curline 0 match))))
|
|
851 (setq line (replace-regexp-in-string " " "" line))
|
|
852 (insert line "\t\t\t")
|
|
853 (if (> (current-column) 24)
|
|
854 (delete-char -1))
|
|
855 (insert ";; calc variable\n")
|
|
856 (if match
|
|
857 (insert "RET\t\t\t;; calc-enter\n")))))
|
|
858
|
|
859 (defun calc-edit-macro-combine-digits ()
|
|
860 "Put an entire sequence of digits on a single line."
|
|
861 (let ((line (calc-edit-macro-command))
|
|
862 curline)
|
|
863 (goto-char (line-beginning-position))
|
|
864 (kill-line 1)
|
|
865 (while (string-equal (calc-edit-macro-command-type) "calcDigit-start")
|
|
866 (setq line (concat line (calc-edit-macro-command)))
|
|
867 (kill-line 1))
|
|
868 (insert line "\t\t\t")
|
|
869 (if (> (current-column) 24)
|
|
870 (delete-char -1))
|
|
871 (insert ";; calc digits\n")))
|
|
872
|
|
873 (defun calc-edit-format-macro-buffer ()
|
|
874 "Rewrite the Calc macro editing buffer."
|
|
875 (calc-edit-macro-adjust-buffer)
|
59309
|
876 (goto-char calc-edit-top)
|
59295
|
877 (let ((type (calc-edit-macro-command-type)))
|
|
878 (while (not (string-equal type ""))
|
|
879 (cond
|
|
880 ((or
|
|
881 (string-equal type "calc-algebraic-entry")
|
|
882 (string-equal type "calc-auto-algebraic-entry"))
|
|
883 (calc-edit-macro-combine-alg-ent))
|
|
884 ((string-equal type "calc-execute-extended-command")
|
|
885 (calc-edit-macro-combine-ext-command))
|
|
886 ((string-equal type "calcDigit-start")
|
|
887 (calc-edit-macro-combine-digits))
|
|
888 ((or
|
|
889 (string-equal type "calc-store")
|
|
890 (string-equal type "calc-store-into")
|
|
891 (string-equal type "calc-store-neg")
|
|
892 (string-equal type "calc-store-plus")
|
|
893 (string-equal type "calc-store-minus")
|
|
894 (string-equal type "calc-store-div")
|
|
895 (string-equal type "calc-store-times")
|
|
896 (string-equal type "calc-store-power")
|
|
897 (string-equal type "calc-store-concat")
|
|
898 (string-equal type "calc-store-inv")
|
|
899 (string-equal type "calc-store-dec")
|
|
900 (string-equal type "calc-store-incr")
|
|
901 (string-equal type "calc-store-exchange")
|
|
902 (string-equal type "calc-unstore")
|
|
903 (string-equal type "calc-recall")
|
|
904 (string-equal type "calc-let")
|
|
905 (string-equal type "calc-permanent-variable"))
|
|
906 (forward-line 1)
|
|
907 (calc-edit-macro-combine-var-name))
|
|
908 ((or
|
|
909 (string-equal type "calc-copy-variable")
|
62391
65d4d337ea31
(calc-edit-format-macro-buffer): Add `calc-copy-special-constant'.
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
910 (string-equal type "calc-copy-special-constant")
|
59295
|
911 (string-equal type "calc-declare-variable"))
|
|
912 (forward-line 1)
|
|
913 (calc-edit-macro-combine-var-name)
|
|
914 (calc-edit-macro-combine-var-name))
|
|
915 (t (forward-line 1)))
|
|
916 (setq type (calc-edit-macro-command-type))))
|
59309
|
917 (goto-char calc-edit-top))
|
59295
|
918
|
|
919 ;; Finish editing the macro
|
|
920
|
|
921 (defun calc-edit-macro-pre-finish-edit ()
|
59309
|
922 (goto-char calc-edit-top)
|
59295
|
923 (while (re-search-forward "\\(^\\| \\)RET\\($\\|\t\\| \\)" nil t)
|
|
924 (search-backward "RET")
|
|
925 (delete-char 3)
|
|
926 (insert "<return>")))
|
|
927
|
|
928 (defun calc-edit-macro-finish-edit (cmdname key)
|
|
929 "Finish editing a Calc macro.
|
|
930 Redefine the corresponding command."
|
|
931 (interactive)
|
|
932 (let ((cmd (intern cmdname)))
|
|
933 (calc-edit-macro-pre-finish-edit)
|
59309
|
934 (let* ((str (buffer-substring calc-edit-top (point-max)))
|
59295
|
935 (mac (edmacro-parse-keys str t)))
|
|
936 (if (= (length mac) 0)
|
|
937 (fmakunbound cmd)
|
|
938 (fset cmd
|
|
939 (list 'lambda '(arg)
|
|
940 '(interactive "P")
|
|
941 (list 'calc-execute-kbd-macro
|
|
942 (vector (key-description mac)
|
|
943 mac)
|
|
944 'arg key)))))))
|
40785
|
945
|
|
946 (defun calc-finish-formula-edit (func)
|
|
947 (let ((buf (current-buffer))
|
59309
|
948 (str (buffer-substring calc-edit-top (point-max)))
|
40785
|
949 (start (point))
|
|
950 (body (calc-valid-formula-func func)))
|
|
951 (set-buffer calc-original-buffer)
|
|
952 (let ((val (math-read-expr str)))
|
|
953 (if (eq (car-safe val) 'error)
|
|
954 (progn
|
|
955 (set-buffer buf)
|
|
956 (goto-char (+ start (nth 1 val)))
|
|
957 (error (nth 2 val))))
|
|
958 (setcar (cdr body)
|
58390
|
959 (let ((calc-user-formula-alist (nth 1 (symbol-function func))))
|
40785
|
960 (calc-fix-user-formula val)))
|
41047
|
961 (put func 'calc-user-defn val))))
|
40785
|
962
|
|
963 (defun calc-valid-formula-func (func)
|
|
964 (let ((def (symbol-function func)))
|
|
965 (and (consp def)
|
|
966 (eq (car def) 'lambda)
|
|
967 (progn
|
|
968 (setq def (cdr (cdr def)))
|
|
969 (while (and def
|
|
970 (not (eq (car (car def)) 'math-normalize)))
|
|
971 (setq def (cdr def)))
|
41047
|
972 (car def)))))
|
40785
|
973
|
|
974
|
|
975 (defun calc-get-user-defn ()
|
|
976 (interactive)
|
|
977 (calc-wrapper
|
|
978 (message "Get definition of command: z-")
|
|
979 (let* ((key (read-char))
|
|
980 (def (or (assq key (calc-user-key-map))
|
|
981 (assq (upcase key) (calc-user-key-map))
|
|
982 (assq (downcase key) (calc-user-key-map))
|
|
983 (error "No command defined for that key")))
|
|
984 (cmd (cdr def)))
|
|
985 (if (symbolp cmd)
|
|
986 (setq cmd (symbol-function cmd)))
|
|
987 (cond ((stringp cmd)
|
|
988 (message "Keyboard macro: %s" cmd))
|
|
989 (t (let* ((func (calc-stack-command-p cmd))
|
|
990 (defn (and func
|
|
991 (symbolp func)
|
|
992 (get func 'calc-user-defn))))
|
|
993 (if defn
|
|
994 (progn
|
|
995 (and (calc-valid-formula-func func)
|
|
996 (setq defn (append '(calcFunc-lambda)
|
|
997 (mapcar 'math-build-var-name
|
|
998 (nth 1 (symbol-function
|
|
999 func)))
|
|
1000 (list defn))))
|
|
1001 (calc-enter-result 0 "gdef" defn))
|
41047
|
1002 (error "That command is not defined by a formula"))))))))
|
40785
|
1003
|
|
1004
|
|
1005 (defun calc-user-define-permanent ()
|
|
1006 (interactive)
|
|
1007 (calc-wrapper
|
|
1008 (message "Record in %s the command: z-" calc-settings-file)
|
|
1009 (let* ((key (read-char))
|
|
1010 (def (or (assq key (calc-user-key-map))
|
|
1011 (assq (upcase key) (calc-user-key-map))
|
|
1012 (assq (downcase key) (calc-user-key-map))
|
49598
|
1013 (and (eq key ?\')
|
40785
|
1014 (cons nil
|
59183
f27d7a9c6f27
(calc-user-define-permanent, calc-user-define-composition)
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
1015 (intern
|
f27d7a9c6f27
(calc-user-define-permanent, calc-user-define-composition)
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
1016 (concat "calcFunc-"
|
f27d7a9c6f27
(calc-user-define-permanent, calc-user-define-composition)
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
1017 (completing-read
|
f27d7a9c6f27
(calc-user-define-permanent, calc-user-define-composition)
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
1018 (format "Record in %s the algebraic function: "
|
f27d7a9c6f27
(calc-user-define-permanent, calc-user-define-composition)
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
1019 calc-settings-file)
|
f27d7a9c6f27
(calc-user-define-permanent, calc-user-define-composition)
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
1020 (mapcar (lambda (x) (substring x 9))
|
f27d7a9c6f27
(calc-user-define-permanent, calc-user-define-composition)
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
1021 (all-completions "calcFunc-"
|
f27d7a9c6f27
(calc-user-define-permanent, calc-user-define-composition)
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
1022 obarray))
|
105022
|
1023 (lambda (x)
|
|
1024 (fboundp
|
59183
f27d7a9c6f27
(calc-user-define-permanent, calc-user-define-composition)
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
1025 (intern (concat "calcFunc-" x))))
|
f27d7a9c6f27
(calc-user-define-permanent, calc-user-define-composition)
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
1026 t)))))
|
f27d7a9c6f27
(calc-user-define-permanent, calc-user-define-composition)
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
1027 (and (eq key ?\M-x)
|
f27d7a9c6f27
(calc-user-define-permanent, calc-user-define-composition)
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
1028 (cons nil
|
40785
|
1029 (intern (completing-read
|
59183
f27d7a9c6f27
(calc-user-define-permanent, calc-user-define-composition)
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
1030 (format "Record in %s the command: "
|
40785
|
1031 calc-settings-file)
|
59183
f27d7a9c6f27
(calc-user-define-permanent, calc-user-define-composition)
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
1032 obarray 'fboundp nil "calc-"))))
|
40785
|
1033 (error "No command defined for that key"))))
|
|
1034 (set-buffer (find-file-noselect (substitute-in-file-name
|
|
1035 calc-settings-file)))
|
|
1036 (goto-char (point-max))
|
|
1037 (let* ((cmd (cdr def))
|
|
1038 (fcmd (and cmd (symbolp cmd) (symbol-function cmd)))
|
|
1039 (func nil)
|
|
1040 (pt (point))
|
|
1041 (fill-column 70)
|
|
1042 (fill-prefix nil)
|
|
1043 str q-ok)
|
|
1044 (insert "\n;;; Definition stored by Calc on " (current-time-string)
|
|
1045 "\n(put 'calc-define '"
|
|
1046 (if (symbolp cmd) (symbol-name cmd) (format "key%d" key))
|
|
1047 " '(progn\n")
|
|
1048 (if (and fcmd
|
|
1049 (eq (car-safe fcmd) 'lambda)
|
|
1050 (get cmd 'calc-user-defn))
|
|
1051 (let ((pt (point)))
|
|
1052 (and (eq (car-safe (nth 3 fcmd)) 'calc-execute-kbd-macro)
|
|
1053 (vectorp (nth 1 (nth 3 fcmd)))
|
|
1054 (progn (and (fboundp 'edit-kbd-macro)
|
|
1055 (edit-kbd-macro nil))
|
59218
|
1056 (fboundp 'edmacro-parse-keys))
|
40785
|
1057 (setq q-ok t)
|
|
1058 (aset (nth 1 (nth 3 fcmd)) 1 nil))
|
|
1059 (insert (setq str (prin1-to-string
|
|
1060 (cons 'defun (cons cmd (cdr fcmd)))))
|
|
1061 "\n")
|
|
1062 (or (and (string-match "\"" str) (not q-ok))
|
|
1063 (fill-region pt (point)))
|
|
1064 (indent-rigidly pt (point) 2)
|
|
1065 (delete-region pt (1+ pt))
|
|
1066 (insert " (put '" (symbol-name cmd)
|
|
1067 " 'calc-user-defn '"
|
|
1068 (prin1-to-string (get cmd 'calc-user-defn))
|
|
1069 ")\n")
|
|
1070 (setq func (calc-stack-command-p cmd))
|
|
1071 (let ((ffunc (and func (symbolp func) (symbol-function func)))
|
|
1072 (pt (point)))
|
|
1073 (and ffunc
|
|
1074 (eq (car-safe ffunc) 'lambda)
|
|
1075 (get func 'calc-user-defn)
|
|
1076 (progn
|
|
1077 (insert (setq str (prin1-to-string
|
|
1078 (cons 'defun (cons func
|
|
1079 (cdr ffunc)))))
|
|
1080 "\n")
|
|
1081 (or (and (string-match "\"" str) (not q-ok))
|
|
1082 (fill-region pt (point)))
|
|
1083 (indent-rigidly pt (point) 2)
|
|
1084 (delete-region pt (1+ pt))
|
|
1085 (setq pt (point))
|
|
1086 (insert "(put '" (symbol-name func)
|
|
1087 " 'calc-user-defn '"
|
|
1088 (prin1-to-string (get func 'calc-user-defn))
|
|
1089 ")\n")
|
|
1090 (fill-region pt (point))
|
|
1091 (indent-rigidly pt (point) 2)
|
|
1092 (delete-region pt (1+ pt))))))
|
|
1093 (and (stringp fcmd)
|
|
1094 (insert " (fset '" (prin1-to-string cmd)
|
|
1095 " " (prin1-to-string fcmd) ")\n")))
|
|
1096 (or func (setq func (and cmd (symbolp cmd) (fboundp cmd) cmd)))
|
|
1097 (if (get func 'math-compose-forms)
|
|
1098 (let ((pt (point)))
|
|
1099 (insert "(put '" (symbol-name cmd)
|
|
1100 " 'math-compose-forms '"
|
|
1101 (prin1-to-string (get func 'math-compose-forms))
|
|
1102 ")\n")
|
|
1103 (fill-region pt (point))
|
|
1104 (indent-rigidly pt (point) 2)
|
|
1105 (delete-region pt (1+ pt))))
|
|
1106 (if (car def)
|
|
1107 (insert " (define-key calc-mode-map "
|
|
1108 (prin1-to-string (concat "z" (char-to-string key)))
|
|
1109 " '"
|
|
1110 (prin1-to-string cmd)
|
|
1111 ")\n")))
|
|
1112 (insert "))\n")
|
41047
|
1113 (save-buffer))))
|
40785
|
1114
|
|
1115 (defun calc-stack-command-p (cmd)
|
|
1116 (if (and cmd (symbolp cmd))
|
|
1117 (and (fboundp cmd)
|
|
1118 (calc-stack-command-p (symbol-function cmd)))
|
|
1119 (and (consp cmd)
|
|
1120 (eq (car cmd) 'lambda)
|
|
1121 (setq cmd (or (assq 'calc-wrapper cmd)
|
|
1122 (assq 'calc-slow-wrapper cmd)))
|
|
1123 (setq cmd (assq 'calc-enter-result cmd))
|
|
1124 (memq (car (nth 3 cmd)) '(cons list))
|
|
1125 (eq (car (nth 1 (nth 3 cmd))) 'quote)
|
41047
|
1126 (nth 1 (nth 1 (nth 3 cmd))))))
|
40785
|
1127
|
|
1128
|
|
1129 (defun calc-call-last-kbd-macro (arg)
|
|
1130 (interactive "P")
|
|
1131 (and defining-kbd-macro
|
|
1132 (error "Can't execute anonymous macro while defining one"))
|
|
1133 (or last-kbd-macro
|
|
1134 (error "No kbd macro has been defined"))
|
41047
|
1135 (calc-execute-kbd-macro last-kbd-macro arg))
|
40785
|
1136
|
|
1137 (defun calc-execute-kbd-macro (mac arg &rest prefix)
|
59631
|
1138 (if calc-keep-args-flag
|
|
1139 (calc-keep-args))
|
40785
|
1140 (if (and (vectorp mac) (> (length mac) 0) (stringp (aref mac 0)))
|
|
1141 (setq mac (or (aref mac 1)
|
|
1142 (aset mac 1 (progn (and (fboundp 'edit-kbd-macro)
|
|
1143 (edit-kbd-macro nil))
|
59218
|
1144 (edmacro-parse-keys (aref mac 0)))))))
|
40785
|
1145 (if (< (prefix-numeric-value arg) 0)
|
|
1146 (execute-kbd-macro mac (- (prefix-numeric-value arg)))
|
|
1147 (if calc-executing-macro
|
|
1148 (execute-kbd-macro mac arg)
|
|
1149 (calc-slow-wrapper
|
|
1150 (let ((old-stack-whole (copy-sequence calc-stack))
|
|
1151 (old-stack-top calc-stack-top)
|
|
1152 (old-buffer-size (buffer-size))
|
|
1153 (old-refresh-count calc-refresh-count))
|
|
1154 (unwind-protect
|
|
1155 (let ((calc-executing-macro mac))
|
|
1156 (execute-kbd-macro mac arg))
|
|
1157 (calc-select-buffer)
|
|
1158 (let ((new-stack (reverse calc-stack))
|
|
1159 (old-stack (reverse old-stack-whole)))
|
|
1160 (while (and new-stack old-stack
|
|
1161 (equal (car new-stack) (car old-stack)))
|
|
1162 (setq new-stack (cdr new-stack)
|
|
1163 old-stack (cdr old-stack)))
|
|
1164 (or (equal prefix '(nil))
|
|
1165 (calc-record-list (if (> (length new-stack) 1)
|
|
1166 (mapcar 'car new-stack)
|
|
1167 '(""))
|
|
1168 (or (car prefix) "kmac")))
|
|
1169 (calc-record-undo (list 'set 'saved-stack-top old-stack-top))
|
|
1170 (and old-stack
|
|
1171 (calc-record-undo (list 'pop 1 (mapcar 'car old-stack))))
|
|
1172 (let ((calc-stack old-stack-whole)
|
|
1173 (calc-stack-top 0))
|
|
1174 (calc-cursor-stack-index (length old-stack)))
|
|
1175 (if (and (= old-buffer-size (buffer-size))
|
|
1176 (= old-refresh-count calc-refresh-count))
|
|
1177 (let ((buffer-read-only nil))
|
|
1178 (delete-region (point) (point-max))
|
|
1179 (while new-stack
|
|
1180 (calc-record-undo (list 'push 1))
|
|
1181 (insert (math-format-stack-value (car new-stack)) "\n")
|
|
1182 (setq new-stack (cdr new-stack)))
|
|
1183 (calc-renumber-stack))
|
|
1184 (while new-stack
|
|
1185 (calc-record-undo (list 'push 1))
|
|
1186 (setq new-stack (cdr new-stack)))
|
|
1187 (calc-refresh))
|
41047
|
1188 (calc-record-undo (list 'set 'saved-stack-top 0)))))))))
|
40785
|
1189
|
|
1190 (defun calc-push-list-in-macro (vals m sels)
|
|
1191 (let ((entry (list (car vals) 1 (car sels)))
|
|
1192 (mm (+ (or m 1) calc-stack-top)))
|
|
1193 (if (> mm 1)
|
|
1194 (setcdr (nthcdr (- mm 2) calc-stack)
|
|
1195 (cons entry (nthcdr (1- mm) calc-stack)))
|
41047
|
1196 (setq calc-stack (cons entry calc-stack)))))
|
40785
|
1197
|
|
1198 (defun calc-pop-stack-in-macro (n mm)
|
|
1199 (if (> mm 1)
|
|
1200 (setcdr (nthcdr (- mm 2) calc-stack)
|
|
1201 (nthcdr (+ n mm -1) calc-stack))
|
41047
|
1202 (setq calc-stack (nthcdr n calc-stack))))
|
40785
|
1203
|
|
1204
|
|
1205 (defun calc-kbd-if ()
|
|
1206 (interactive)
|
|
1207 (calc-wrapper
|
|
1208 (let ((cond (calc-top-n 1)))
|
|
1209 (calc-pop-stack 1)
|
|
1210 (if (math-is-true cond)
|
|
1211 (if defining-kbd-macro
|
105275
|
1212 (message "If true..."))
|
40785
|
1213 (if defining-kbd-macro
|
|
1214 (message "Condition is false; skipping to Z: or Z] ..."))
|
41047
|
1215 (calc-kbd-skip-to-else-if t)))))
|
40785
|
1216
|
|
1217 (defun calc-kbd-else-if ()
|
|
1218 (interactive)
|
41047
|
1219 (calc-kbd-if))
|
40785
|
1220
|
|
1221 (defun calc-kbd-skip-to-else-if (else-okay)
|
|
1222 (let ((count 0)
|
|
1223 ch)
|
|
1224 (while (>= count 0)
|
|
1225 (setq ch (read-char))
|
|
1226 (if (= ch -1)
|
|
1227 (error "Unterminated Z[ in keyboard macro"))
|
|
1228 (if (= ch ?Z)
|
|
1229 (progn
|
|
1230 (setq ch (read-char))
|
|
1231 (cond ((= ch ?\[)
|
|
1232 (setq count (1+ count)))
|
|
1233 ((= ch ?\])
|
|
1234 (setq count (1- count)))
|
|
1235 ((= ch ?\:)
|
|
1236 (and (= count 0)
|
|
1237 else-okay
|
|
1238 (setq count -1)))
|
|
1239 ((eq ch 7)
|
|
1240 (keyboard-quit))))))
|
|
1241 (and defining-kbd-macro
|
|
1242 (if (= ch ?\:)
|
|
1243 (message "Else...")
|
41047
|
1244 (message "End-if...")))))
|
40785
|
1245
|
|
1246 (defun calc-kbd-end-if ()
|
|
1247 (interactive)
|
|
1248 (if defining-kbd-macro
|
41047
|
1249 (message "End-if...")))
|
40785
|
1250
|
|
1251 (defun calc-kbd-else ()
|
|
1252 (interactive)
|
|
1253 (if defining-kbd-macro
|
|
1254 (message "Else; skipping to Z] ..."))
|
41047
|
1255 (calc-kbd-skip-to-else-if nil))
|
40785
|
1256
|
|
1257
|
|
1258 (defun calc-kbd-repeat ()
|
|
1259 (interactive)
|
|
1260 (let (count)
|
|
1261 (calc-wrapper
|
|
1262 (setq count (math-trunc (calc-top-n 1)))
|
|
1263 (or (Math-integerp count)
|
|
1264 (error "Count must be an integer"))
|
|
1265 (if (Math-integer-negp count)
|
|
1266 (setq count 0))
|
|
1267 (or (integerp count)
|
|
1268 (setq count 1000000))
|
|
1269 (calc-pop-stack 1))
|
41047
|
1270 (calc-kbd-loop count)))
|
40785
|
1271
|
|
1272 (defun calc-kbd-for (dir)
|
|
1273 (interactive "P")
|
|
1274 (let (init final)
|
|
1275 (calc-wrapper
|
|
1276 (setq init (calc-top-n 2)
|
|
1277 final (calc-top-n 1))
|
|
1278 (or (and (math-anglep init) (math-anglep final))
|
|
1279 (error "Initial and final values must be real numbers"))
|
|
1280 (calc-pop-stack 2))
|
41047
|
1281 (calc-kbd-loop nil init final (and dir (prefix-numeric-value dir)))))
|
40785
|
1282
|
|
1283 (defun calc-kbd-loop (rpt-count &optional initial final dir)
|
|
1284 (interactive "P")
|
|
1285 (setq rpt-count (if rpt-count (prefix-numeric-value rpt-count) 1000000))
|
|
1286 (let* ((count 0)
|
|
1287 (parts nil)
|
|
1288 (body "")
|
101001
|
1289 (open last-command-event)
|
40785
|
1290 (counter initial)
|
|
1291 ch)
|
40998
|
1292 (or executing-kbd-macro
|
40785
|
1293 (message "Reading loop body..."))
|
|
1294 (while (>= count 0)
|
|
1295 (setq ch (read-char))
|
|
1296 (if (= ch -1)
|
|
1297 (error "Unterminated Z%c in keyboard macro" open))
|
|
1298 (if (= ch ?Z)
|
|
1299 (progn
|
|
1300 (setq ch (read-char)
|
|
1301 body (concat body "Z" (char-to-string ch)))
|
|
1302 (cond ((memq ch '(?\< ?\( ?\{))
|
|
1303 (setq count (1+ count)))
|
|
1304 ((memq ch '(?\> ?\) ?\}))
|
|
1305 (setq count (1- count)))
|
|
1306 ((and (= ch ?/)
|
|
1307 (= count 0))
|
|
1308 (setq parts (nconc parts (list (concat (substring body 0 -2)
|
|
1309 "Z]")))
|
|
1310 body ""))
|
|
1311 ((eq ch 7)
|
|
1312 (keyboard-quit))))
|
|
1313 (setq body (concat body (char-to-string ch)))))
|
|
1314 (if (/= ch (cdr (assq open '( (?\< . ?\>) (?\( . ?\)) (?\{ . ?\}) ))))
|
|
1315 (error "Mismatched Z%c and Z%c in keyboard macro" open ch))
|
40998
|
1316 (or executing-kbd-macro
|
40785
|
1317 (message "Looping..."))
|
|
1318 (setq body (concat (substring body 0 -2) "Z]"))
|
40998
|
1319 (and (not executing-kbd-macro)
|
40785
|
1320 (= rpt-count 1000000)
|
|
1321 (null parts)
|
|
1322 (null counter)
|
|
1323 (progn
|
41271
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
diff
changeset
|
1324 (message "Warning: Infinite loop! Not executing")
|
40785
|
1325 (setq rpt-count 0)))
|
|
1326 (or (not initial) dir
|
|
1327 (setq dir (math-compare final initial)))
|
|
1328 (calc-wrapper
|
|
1329 (while (> rpt-count 0)
|
|
1330 (let ((part parts))
|
|
1331 (if counter
|
|
1332 (if (cond ((eq dir 0) (Math-equal final counter))
|
|
1333 ((eq dir 1) (Math-lessp final counter))
|
|
1334 ((eq dir -1) (Math-lessp counter final)))
|
|
1335 (setq rpt-count 0)
|
|
1336 (calc-push counter)))
|
|
1337 (while (and part (> rpt-count 0))
|
|
1338 (execute-kbd-macro (car part))
|
|
1339 (if (math-is-true (calc-top-n 1))
|
|
1340 (setq rpt-count 0)
|
|
1341 (setq part (cdr part)))
|
|
1342 (calc-pop-stack 1))
|
|
1343 (if (> rpt-count 0)
|
|
1344 (progn
|
|
1345 (execute-kbd-macro body)
|
|
1346 (if counter
|
|
1347 (let ((step (calc-top-n 1)))
|
|
1348 (calc-pop-stack 1)
|
|
1349 (setq counter (calcFunc-add counter step)))
|
|
1350 (setq rpt-count (1- rpt-count))))))))
|
40998
|
1351 (or executing-kbd-macro
|
41047
|
1352 (message "Looping...done"))))
|
40785
|
1353
|
|
1354 (defun calc-kbd-end-repeat ()
|
|
1355 (interactive)
|
41047
|
1356 (error "Unbalanced Z> in keyboard macro"))
|
40785
|
1357
|
|
1358 (defun calc-kbd-end-for ()
|
|
1359 (interactive)
|
41047
|
1360 (error "Unbalanced Z) in keyboard macro"))
|
40785
|
1361
|
|
1362 (defun calc-kbd-end-loop ()
|
|
1363 (interactive)
|
41047
|
1364 (error "Unbalanced Z} in keyboard macro"))
|
40785
|
1365
|
|
1366 (defun calc-kbd-break ()
|
|
1367 (interactive)
|
|
1368 (calc-wrapper
|
|
1369 (let ((cond (calc-top-n 1)))
|
|
1370 (calc-pop-stack 1)
|
|
1371 (if (math-is-true cond)
|
41271
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
diff
changeset
|
1372 (error "Keyboard macro aborted")))))
|
40785
|
1373
|
|
1374
|
41271
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
diff
changeset
|
1375 (defvar calc-kbd-push-level 0)
|
58390
|
1376
|
|
1377 ;; The variables var-q0 through var-q9 are the "quick" variables.
|
|
1378 (defvar var-q0 nil)
|
|
1379 (defvar var-q1 nil)
|
|
1380 (defvar var-q2 nil)
|
|
1381 (defvar var-q3 nil)
|
|
1382 (defvar var-q4 nil)
|
|
1383 (defvar var-q5 nil)
|
|
1384 (defvar var-q6 nil)
|
|
1385 (defvar var-q7 nil)
|
|
1386 (defvar var-q8 nil)
|
|
1387 (defvar var-q9 nil)
|
|
1388
|
40785
|
1389 (defun calc-kbd-push (arg)
|
|
1390 (interactive "P")
|
|
1391 (calc-wrapper
|
|
1392 (let* ((defs (and arg (> (prefix-numeric-value arg) 0)))
|
58390
|
1393 (var-q0 var-q0)
|
|
1394 (var-q1 var-q1)
|
|
1395 (var-q2 var-q2)
|
|
1396 (var-q3 var-q3)
|
|
1397 (var-q4 var-q4)
|
|
1398 (var-q5 var-q5)
|
|
1399 (var-q6 var-q6)
|
|
1400 (var-q7 var-q7)
|
|
1401 (var-q8 var-q8)
|
|
1402 (var-q9 var-q9)
|
40785
|
1403 (calc-internal-prec (if defs 12 calc-internal-prec))
|
|
1404 (calc-word-size (if defs 32 calc-word-size))
|
|
1405 (calc-angle-mode (if defs 'deg calc-angle-mode))
|
|
1406 (calc-simplify-mode (if defs nil calc-simplify-mode))
|
|
1407 (calc-algebraic-mode (if arg nil calc-algebraic-mode))
|
|
1408 (calc-incomplete-algebraic-mode (if arg nil
|
|
1409 calc-incomplete-algebraic-mode))
|
|
1410 (calc-symbolic-mode (if defs nil calc-symbolic-mode))
|
|
1411 (calc-matrix-mode (if defs nil calc-matrix-mode))
|
|
1412 (calc-prefer-frac (if defs nil calc-prefer-frac))
|
|
1413 (calc-complex-mode (if defs nil calc-complex-mode))
|
|
1414 (calc-infinite-mode (if defs nil calc-infinite-mode))
|
|
1415 (count 0)
|
|
1416 (body "")
|
|
1417 ch)
|
40998
|
1418 (if (or executing-kbd-macro defining-kbd-macro)
|
40785
|
1419 (progn
|
|
1420 (if defining-kbd-macro
|
|
1421 (message "Reading body..."))
|
|
1422 (while (>= count 0)
|
|
1423 (setq ch (read-char))
|
|
1424 (if (= ch -1)
|
|
1425 (error "Unterminated Z` in keyboard macro"))
|
|
1426 (if (= ch ?Z)
|
|
1427 (progn
|
|
1428 (setq ch (read-char)
|
|
1429 body (concat body "Z" (char-to-string ch)))
|
|
1430 (cond ((eq ch ?\`)
|
|
1431 (setq count (1+ count)))
|
|
1432 ((eq ch ?\')
|
|
1433 (setq count (1- count)))
|
|
1434 ((eq ch 7)
|
|
1435 (keyboard-quit))))
|
|
1436 (setq body (concat body (char-to-string ch)))))
|
|
1437 (if defining-kbd-macro
|
|
1438 (message "Reading body...done"))
|
|
1439 (let ((calc-kbd-push-level 0))
|
|
1440 (execute-kbd-macro (substring body 0 -2))))
|
|
1441 (let ((calc-kbd-push-level (1+ calc-kbd-push-level)))
|
|
1442 (message "Saving modes; type Z' to restore")
|
41047
|
1443 (recursive-edit))))))
|
40785
|
1444
|
|
1445 (defun calc-kbd-pop ()
|
|
1446 (interactive)
|
|
1447 (if (> calc-kbd-push-level 0)
|
|
1448 (progn
|
|
1449 (message "Mode settings restored")
|
|
1450 (exit-recursive-edit))
|
41047
|
1451 (error "Unbalanced Z' in keyboard macro")))
|
40785
|
1452
|
|
1453
|
62819
|
1454 ;; (defun calc-kbd-report (msg)
|
|
1455 ;; (interactive "sMessage: ")
|
|
1456 ;; (calc-wrapper
|
|
1457 ;; (math-working msg (calc-top-n 1))))
|
40785
|
1458
|
62819
|
1459 (defun calc-kbd-query ()
|
|
1460 (interactive)
|
|
1461 (let ((defining-kbd-macro nil)
|
|
1462 (executing-kbd-macro nil)
|
|
1463 (msg (calc-top 1)))
|
|
1464 (if (not (eq (car-safe msg) 'vec))
|
62820
|
1465 (error "No prompt string provided")
|
62819
|
1466 (setq msg (math-vector-to-string msg))
|
|
1467 (calc-wrapper
|
|
1468 (calc-pop-stack 1)
|
|
1469 (calc-alg-entry nil (and (not (equal msg "")) msg))))))
|
40785
|
1470
|
|
1471 ;;;; Logical operations.
|
|
1472
|
|
1473 (defun calcFunc-eq (a b &rest more)
|
|
1474 (if more
|
|
1475 (let* ((args (cons a (cons b (copy-sequence more))))
|
|
1476 (res 1)
|
|
1477 (p args)
|
|
1478 p2)
|
|
1479 (while (and (cdr p) (not (eq res 0)))
|
|
1480 (setq p2 p)
|
|
1481 (while (and (setq p2 (cdr p2)) (not (eq res 0)))
|
|
1482 (setq res (math-two-eq (car p) (car p2)))
|
|
1483 (if (eq res 1)
|
|
1484 (setcdr p (delq (car p2) (cdr p)))))
|
|
1485 (setq p (cdr p)))
|
|
1486 (if (eq res 0)
|
|
1487 0
|
|
1488 (if (cdr args)
|
|
1489 (cons 'calcFunc-eq args)
|
|
1490 1)))
|
|
1491 (or (math-two-eq a b)
|
|
1492 (if (and (or (math-looks-negp a) (math-zerop a))
|
|
1493 (or (math-looks-negp b) (math-zerop b)))
|
|
1494 (list 'calcFunc-eq (math-neg a) (math-neg b))
|
41047
|
1495 (list 'calcFunc-eq a b)))))
|
40785
|
1496
|
|
1497 (defun calcFunc-neq (a b &rest more)
|
|
1498 (if more
|
|
1499 (let* ((args (cons a (cons b more)))
|
|
1500 (res 0)
|
|
1501 (all t)
|
|
1502 (p args)
|
|
1503 p2)
|
|
1504 (while (and (cdr p) (not (eq res 1)))
|
|
1505 (setq p2 p)
|
|
1506 (while (and (setq p2 (cdr p2)) (not (eq res 1)))
|
|
1507 (setq res (math-two-eq (car p) (car p2)))
|
|
1508 (or res (setq all nil)))
|
|
1509 (setq p (cdr p)))
|
|
1510 (if (eq res 1)
|
|
1511 0
|
|
1512 (if all
|
|
1513 1
|
|
1514 (cons 'calcFunc-neq args))))
|
|
1515 (or (cdr (assq (math-two-eq a b) '((0 . 1) (1 . 0))))
|
|
1516 (if (and (or (math-looks-negp a) (math-zerop a))
|
|
1517 (or (math-looks-negp b) (math-zerop b)))
|
|
1518 (list 'calcFunc-neq (math-neg a) (math-neg b))
|
41047
|
1519 (list 'calcFunc-neq a b)))))
|
40785
|
1520
|
|
1521 (defun math-two-eq (a b)
|
|
1522 (if (eq (car-safe a) 'vec)
|
|
1523 (if (eq (car-safe b) 'vec)
|
|
1524 (if (= (length a) (length b))
|
|
1525 (let ((res 1))
|
|
1526 (while (and (setq a (cdr a) b (cdr b)) (not (eq res 0)))
|
|
1527 (if res
|
|
1528 (setq res (math-two-eq (car a) (car b)))
|
|
1529 (if (eq (math-two-eq (car a) (car b)) 0)
|
|
1530 (setq res 0))))
|
|
1531 res)
|
|
1532 0)
|
|
1533 (if (Math-objectp b)
|
|
1534 0
|
|
1535 nil))
|
|
1536 (if (eq (car-safe b) 'vec)
|
|
1537 (if (Math-objectp a)
|
|
1538 0
|
|
1539 nil)
|
|
1540 (let ((res (math-compare a b)))
|
|
1541 (if (= res 0)
|
|
1542 1
|
|
1543 (if (and (= res 2) (not (and (Math-scalarp a) (Math-scalarp b))))
|
|
1544 nil
|
41047
|
1545 0))))))
|
40785
|
1546
|
|
1547 (defun calcFunc-lt (a b)
|
|
1548 (let ((res (math-compare a b)))
|
|
1549 (if (= res -1)
|
|
1550 1
|
|
1551 (if (= res 2)
|
|
1552 (if (and (or (math-looks-negp a) (math-zerop a))
|
|
1553 (or (math-looks-negp b) (math-zerop b)))
|
|
1554 (list 'calcFunc-gt (math-neg a) (math-neg b))
|
|
1555 (list 'calcFunc-lt a b))
|
41047
|
1556 0))))
|
40785
|
1557
|
|
1558 (defun calcFunc-gt (a b)
|
|
1559 (let ((res (math-compare a b)))
|
|
1560 (if (= res 1)
|
|
1561 1
|
|
1562 (if (= res 2)
|
|
1563 (if (and (or (math-looks-negp a) (math-zerop a))
|
|
1564 (or (math-looks-negp b) (math-zerop b)))
|
|
1565 (list 'calcFunc-lt (math-neg a) (math-neg b))
|
|
1566 (list 'calcFunc-gt a b))
|
41047
|
1567 0))))
|
40785
|
1568
|
|
1569 (defun calcFunc-leq (a b)
|
|
1570 (let ((res (math-compare a b)))
|
|
1571 (if (= res 1)
|
|
1572 0
|
|
1573 (if (= res 2)
|
|
1574 (if (and (or (math-looks-negp a) (math-zerop a))
|
|
1575 (or (math-looks-negp b) (math-zerop b)))
|
|
1576 (list 'calcFunc-geq (math-neg a) (math-neg b))
|
|
1577 (list 'calcFunc-leq a b))
|
41047
|
1578 1))))
|
40785
|
1579
|
|
1580 (defun calcFunc-geq (a b)
|
|
1581 (let ((res (math-compare a b)))
|
|
1582 (if (= res -1)
|
|
1583 0
|
|
1584 (if (= res 2)
|
|
1585 (if (and (or (math-looks-negp a) (math-zerop a))
|
|
1586 (or (math-looks-negp b) (math-zerop b)))
|
|
1587 (list 'calcFunc-leq (math-neg a) (math-neg b))
|
|
1588 (list 'calcFunc-geq a b))
|
41047
|
1589 1))))
|
40785
|
1590
|
|
1591 (defun calcFunc-rmeq (a)
|
|
1592 (if (math-vectorp a)
|
|
1593 (math-map-vec 'calcFunc-rmeq a)
|
|
1594 (if (assq (car-safe a) calc-tweak-eqn-table)
|
|
1595 (if (and (eq (car-safe (nth 2 a)) 'var)
|
|
1596 (math-objectp (nth 1 a)))
|
|
1597 (nth 1 a)
|
|
1598 (nth 2 a))
|
|
1599 (if (eq (car-safe a) 'calcFunc-assign)
|
|
1600 (nth 2 a)
|
|
1601 (if (eq (car-safe a) 'calcFunc-evalto)
|
|
1602 (nth 1 a)
|
41047
|
1603 (list 'calcFunc-rmeq a))))))
|
40785
|
1604
|
|
1605 (defun calcFunc-land (a b)
|
|
1606 (cond ((Math-zerop a)
|
|
1607 a)
|
|
1608 ((Math-zerop b)
|
|
1609 b)
|
|
1610 ((math-is-true a)
|
|
1611 b)
|
|
1612 ((math-is-true b)
|
|
1613 a)
|
41047
|
1614 (t (list 'calcFunc-land a b))))
|
40785
|
1615
|
|
1616 (defun calcFunc-lor (a b)
|
|
1617 (cond ((Math-zerop a)
|
|
1618 b)
|
|
1619 ((Math-zerop b)
|
|
1620 a)
|
|
1621 ((math-is-true a)
|
|
1622 a)
|
|
1623 ((math-is-true b)
|
|
1624 b)
|
41047
|
1625 (t (list 'calcFunc-lor a b))))
|
40785
|
1626
|
|
1627 (defun calcFunc-lnot (a)
|
|
1628 (if (Math-zerop a)
|
|
1629 1
|
|
1630 (if (math-is-true a)
|
|
1631 0
|
|
1632 (let ((op (and (= (length a) 3)
|
|
1633 (assq (car a) calc-tweak-eqn-table))))
|
|
1634 (if op
|
|
1635 (cons (nth 2 op) (cdr a))
|
41047
|
1636 (list 'calcFunc-lnot a))))))
|
40785
|
1637
|
|
1638 (defun calcFunc-if (c e1 e2)
|
|
1639 (if (Math-zerop c)
|
|
1640 e2
|
|
1641 (if (and (math-is-true c) (not (Math-vectorp c)))
|
|
1642 e1
|
|
1643 (or (and (Math-vectorp c)
|
|
1644 (math-constp c)
|
|
1645 (let ((ee1 (if (Math-vectorp e1)
|
|
1646 (if (= (length c) (length e1))
|
|
1647 (cdr e1)
|
|
1648 (calc-record-why "*Dimension error" e1))
|
|
1649 (list e1)))
|
|
1650 (ee2 (if (Math-vectorp e2)
|
|
1651 (if (= (length c) (length e2))
|
|
1652 (cdr e2)
|
|
1653 (calc-record-why "*Dimension error" e2))
|
|
1654 (list e2))))
|
|
1655 (and ee1 ee2
|
|
1656 (cons 'vec (math-if-vector (cdr c) ee1 ee2)))))
|
41047
|
1657 (list 'calcFunc-if c e1 e2)))))
|
40785
|
1658
|
|
1659 (defun math-if-vector (c e1 e2)
|
|
1660 (and c
|
|
1661 (cons (if (Math-zerop (car c)) (car e2) (car e1))
|
|
1662 (math-if-vector (cdr c)
|
|
1663 (or (cdr e1) e1)
|
41047
|
1664 (or (cdr e2) e2)))))
|
40785
|
1665
|
|
1666 (defun math-normalize-logical-op (a)
|
|
1667 (or (and (eq (car a) 'calcFunc-if)
|
|
1668 (= (length a) 4)
|
|
1669 (let ((a1 (math-normalize (nth 1 a))))
|
|
1670 (if (Math-zerop a1)
|
|
1671 (math-normalize (nth 3 a))
|
|
1672 (if (Math-numberp a1)
|
|
1673 (math-normalize (nth 2 a))
|
|
1674 (if (and (Math-vectorp (nth 1 a))
|
|
1675 (math-constp (nth 1 a)))
|
|
1676 (calcFunc-if (nth 1 a)
|
|
1677 (math-normalize (nth 2 a))
|
|
1678 (math-normalize (nth 3 a)))
|
|
1679 (let ((calc-simplify-mode 'none))
|
|
1680 (list 'calcFunc-if a1
|
|
1681 (math-normalize (nth 2 a))
|
|
1682 (math-normalize (nth 3 a)))))))))
|
41047
|
1683 a))
|
40785
|
1684
|
|
1685 (defun calcFunc-in (a b)
|
|
1686 (or (and (eq (car-safe b) 'vec)
|
|
1687 (let ((bb b))
|
|
1688 (while (and (setq bb (cdr bb))
|
|
1689 (not (if (memq (car-safe (car bb)) '(vec intv))
|
|
1690 (eq (calcFunc-in a (car bb)) 1)
|
|
1691 (Math-equal a (car bb))))))
|
|
1692 (if bb 1 (and (math-constp a) (math-constp bb) 0))))
|
|
1693 (and (eq (car-safe b) 'intv)
|
|
1694 (let ((res (math-compare a (nth 2 b))) res2)
|
|
1695 (cond ((= res -1)
|
|
1696 0)
|
|
1697 ((and (= res 0)
|
|
1698 (or (/= (nth 1 b) 2)
|
|
1699 (Math-lessp (nth 2 b) (nth 3 b))))
|
|
1700 (if (memq (nth 1 b) '(2 3)) 1 0))
|
|
1701 ((= (setq res2 (math-compare a (nth 3 b))) 1)
|
|
1702 0)
|
|
1703 ((and (= res2 0)
|
|
1704 (or (/= (nth 1 b) 1)
|
|
1705 (Math-lessp (nth 2 b) (nth 3 b))))
|
|
1706 (if (memq (nth 1 b) '(1 3)) 1 0))
|
|
1707 ((/= res 1)
|
|
1708 nil)
|
|
1709 ((/= res2 -1)
|
|
1710 nil)
|
|
1711 (t 1))))
|
|
1712 (and (Math-equal a b)
|
|
1713 1)
|
|
1714 (and (math-constp a) (math-constp b)
|
|
1715 0)
|
41047
|
1716 (list 'calcFunc-in a b)))
|
40785
|
1717
|
|
1718 (defun calcFunc-typeof (a)
|
|
1719 (cond ((Math-integerp a) 1)
|
|
1720 ((eq (car a) 'frac) 2)
|
|
1721 ((eq (car a) 'float) 3)
|
|
1722 ((eq (car a) 'hms) 4)
|
|
1723 ((eq (car a) 'cplx) 5)
|
|
1724 ((eq (car a) 'polar) 6)
|
|
1725 ((eq (car a) 'sdev) 7)
|
|
1726 ((eq (car a) 'intv) 8)
|
|
1727 ((eq (car a) 'mod) 9)
|
|
1728 ((eq (car a) 'date) (if (Math-integerp (nth 1 a)) 10 11))
|
|
1729 ((eq (car a) 'var)
|
|
1730 (if (memq (nth 2 a) '(var-inf var-uinf var-nan)) 12 100))
|
|
1731 ((eq (car a) 'vec) (if (math-matrixp a) 102 101))
|
58390
|
1732 (t (math-calcFunc-to-var (car a)))))
|
40785
|
1733
|
|
1734 (defun calcFunc-integer (a)
|
|
1735 (if (Math-integerp a)
|
|
1736 1
|
|
1737 (if (Math-objvecp a)
|
|
1738 0
|
41047
|
1739 (list 'calcFunc-integer a))))
|
40785
|
1740
|
|
1741 (defun calcFunc-real (a)
|
|
1742 (if (Math-realp a)
|
|
1743 1
|
|
1744 (if (Math-objvecp a)
|
|
1745 0
|
41047
|
1746 (list 'calcFunc-real a))))
|
40785
|
1747
|
|
1748 (defun calcFunc-constant (a)
|
|
1749 (if (math-constp a)
|
|
1750 1
|
|
1751 (if (Math-objvecp a)
|
|
1752 0
|
41047
|
1753 (list 'calcFunc-constant a))))
|
40785
|
1754
|
|
1755 (defun calcFunc-refers (a b)
|
|
1756 (if (math-expr-contains a b)
|
|
1757 1
|
|
1758 (if (eq (car-safe a) 'var)
|
|
1759 (list 'calcFunc-refers a b)
|
41047
|
1760 0)))
|
40785
|
1761
|
|
1762 (defun calcFunc-negative (a)
|
|
1763 (if (math-looks-negp a)
|
|
1764 1
|
|
1765 (if (or (math-zerop a)
|
|
1766 (math-posp a))
|
|
1767 0
|
41047
|
1768 (list 'calcFunc-negative a))))
|
40785
|
1769
|
|
1770 (defun calcFunc-variable (a)
|
|
1771 (if (eq (car-safe a) 'var)
|
|
1772 1
|
|
1773 (if (Math-objvecp a)
|
|
1774 0
|
41047
|
1775 (list 'calcFunc-variable a))))
|
40785
|
1776
|
|
1777 (defun calcFunc-nonvar (a)
|
|
1778 (if (eq (car-safe a) 'var)
|
|
1779 (list 'calcFunc-nonvar a)
|
41047
|
1780 1))
|
40785
|
1781
|
|
1782 (defun calcFunc-istrue (a)
|
|
1783 (if (math-is-true a)
|
|
1784 1
|
41047
|
1785 0))
|
40785
|
1786
|
|
1787
|
|
1788
|
|
1789 ;;;; User-programmability.
|
|
1790
|
|
1791 ;;; Compiling Lisp-like forms to use the math library.
|
|
1792
|
|
1793 (defun math-do-defmath (func args body)
|
58614
eba1cd703531
(calc-user-define-formula, calc-do-defmath): Replace calc-need-macros by
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
1794 (require 'calc-macs)
|
40785
|
1795 (let* ((fname (intern (concat "calcFunc-" (symbol-name func))))
|
|
1796 (doc (if (stringp (car body)) (list (car body))))
|
|
1797 (clargs (mapcar 'math-clean-arg args))
|
|
1798 (body (math-define-function-body
|
|
1799 (if (stringp (car body)) (cdr body) body)
|
|
1800 clargs)))
|
|
1801 (list 'progn
|
|
1802 (if (and (consp (car body))
|
|
1803 (eq (car (car body)) 'interactive))
|
|
1804 (let ((inter (car body)))
|
|
1805 (setq body (cdr body))
|
|
1806 (if (or (> (length inter) 2)
|
|
1807 (integerp (nth 1 inter)))
|
|
1808 (let ((hasprefix nil) (hasmulti nil))
|
|
1809 (if (stringp (nth 1 inter))
|
|
1810 (progn
|
|
1811 (cond ((equal (nth 1 inter) "p")
|
|
1812 (setq hasprefix t))
|
|
1813 ((equal (nth 1 inter) "m")
|
|
1814 (setq hasmulti t))
|
|
1815 (t (error
|
|
1816 "Can't handle interactive code string \"%s\""
|
|
1817 (nth 1 inter))))
|
|
1818 (setq inter (cdr inter))))
|
|
1819 (if (not (integerp (nth 1 inter)))
|
|
1820 (error
|
|
1821 "Expected an integer in interactive specification"))
|
|
1822 (append (list 'defun
|
|
1823 (intern (concat "calc-"
|
|
1824 (symbol-name func)))
|
|
1825 (if (or hasprefix hasmulti)
|
|
1826 '(&optional n)
|
|
1827 ()))
|
|
1828 doc
|
|
1829 (if (or hasprefix hasmulti)
|
|
1830 '((interactive "P"))
|
|
1831 '((interactive)))
|
|
1832 (list
|
|
1833 (append
|
|
1834 '(calc-slow-wrapper)
|
|
1835 (and hasmulti
|
|
1836 (list
|
|
1837 (list 'setq
|
|
1838 'n
|
|
1839 (list 'if
|
|
1840 'n
|
|
1841 (list 'prefix-numeric-value
|
|
1842 'n)
|
|
1843 (nth 1 inter)))))
|
|
1844 (list
|
|
1845 (list 'calc-enter-result
|
|
1846 (if hasmulti 'n (nth 1 inter))
|
|
1847 (nth 2 inter)
|
|
1848 (if hasprefix
|
|
1849 (list 'append
|
|
1850 (list 'quote (list fname))
|
|
1851 (list 'calc-top-list-n
|
|
1852 (nth 1 inter))
|
|
1853 (list 'and
|
|
1854 'n
|
|
1855 (list
|
|
1856 'list
|
|
1857 (list
|
|
1858 'math-normalize
|
|
1859 (list
|
|
1860 'prefix-numeric-value
|
|
1861 'n)))))
|
|
1862 (list 'cons
|
|
1863 (list 'quote fname)
|
|
1864 (list 'calc-top-list-n
|
|
1865 (if hasmulti
|
|
1866 'n
|
|
1867 (nth 1 inter)))))))))))
|
|
1868 (append (list 'defun
|
|
1869 (intern (concat "calc-" (symbol-name func)))
|
|
1870 args)
|
|
1871 doc
|
|
1872 (list
|
|
1873 inter
|
|
1874 (cons 'calc-wrapper body))))))
|
|
1875 (append (list 'defun fname clargs)
|
|
1876 doc
|
|
1877 (math-do-arg-list-check args nil nil)
|
41047
|
1878 body))))
|
40785
|
1879
|
|
1880 (defun math-clean-arg (arg)
|
|
1881 (if (consp arg)
|
|
1882 (math-clean-arg (nth 1 arg))
|
41047
|
1883 arg))
|
40785
|
1884
|
|
1885 (defun math-do-arg-check (arg var is-opt is-rest)
|
|
1886 (if is-opt
|
|
1887 (let ((chk (math-do-arg-check arg var nil nil)))
|
|
1888 (list (cons 'and
|
|
1889 (cons var
|
|
1890 (if (cdr chk)
|
|
1891 (setq chk (list (cons 'progn chk)))
|
|
1892 chk)))))
|
|
1893 (and (consp arg)
|
|
1894 (let* ((rest (math-do-arg-check (nth 1 arg) var is-opt is-rest))
|
|
1895 (qual (car arg))
|
|
1896 (qqual (list 'quote qual))
|
|
1897 (qual-name (symbol-name qual))
|
|
1898 (chk (intern (concat "math-check-" qual-name))))
|
|
1899 (if (fboundp chk)
|
|
1900 (append rest
|
|
1901 (list
|
|
1902 (if is-rest
|
|
1903 (list 'setq var
|
|
1904 (list 'mapcar (list 'quote chk) var))
|
|
1905 (list 'setq var (list chk var)))))
|
|
1906 (if (fboundp (setq chk (intern (concat "math-" qual-name))))
|
|
1907 (append rest
|
|
1908 (list
|
|
1909 (if is-rest
|
|
1910 (list 'mapcar
|
|
1911 (list 'function
|
|
1912 (list 'lambda '(x)
|
|
1913 (list 'or
|
|
1914 (list chk 'x)
|
|
1915 (list 'math-reject-arg
|
|
1916 'x qqual))))
|
|
1917 var)
|
|
1918 (list 'or
|
|
1919 (list chk var)
|
|
1920 (list 'math-reject-arg var qqual)))))
|
|
1921 (if (and (string-match "\\`not-\\(.*\\)\\'" qual-name)
|
|
1922 (fboundp (setq chk (intern
|
|
1923 (concat "math-"
|
|
1924 (math-match-substring
|
|
1925 qual-name 1))))))
|
|
1926 (append rest
|
|
1927 (list
|
|
1928 (if is-rest
|
|
1929 (list 'mapcar
|
|
1930 (list 'function
|
|
1931 (list 'lambda '(x)
|
|
1932 (list 'and
|
|
1933 (list chk 'x)
|
|
1934 (list 'math-reject-arg
|
|
1935 'x qqual))))
|
|
1936 var)
|
|
1937 (list 'and
|
|
1938 (list chk var)
|
|
1939 (list 'math-reject-arg var qqual)))))
|
41047
|
1940 (error "Unknown qualifier `%s'" qual-name))))))))
|
40785
|
1941
|
|
1942 (defun math-do-arg-list-check (args is-opt is-rest)
|
|
1943 (cond ((null args) nil)
|
|
1944 ((consp (car args))
|
|
1945 (append (math-do-arg-check (car args)
|
|
1946 (math-clean-arg (car args))
|
|
1947 is-opt is-rest)
|
|
1948 (math-do-arg-list-check (cdr args) is-opt is-rest)))
|
|
1949 ((eq (car args) '&optional)
|
|
1950 (math-do-arg-list-check (cdr args) t nil))
|
|
1951 ((eq (car args) '&rest)
|
|
1952 (math-do-arg-list-check (cdr args) nil t))
|
41047
|
1953 (t (math-do-arg-list-check (cdr args) is-opt is-rest))))
|
40785
|
1954
|
|
1955 (defconst math-prim-funcs
|
|
1956 '( (~= . math-nearly-equal)
|
|
1957 (% . math-mod)
|
|
1958 (lsh . calcFunc-lsh)
|
|
1959 (ash . calcFunc-ash)
|
|
1960 (logand . calcFunc-and)
|
|
1961 (logandc2 . calcFunc-diff)
|
|
1962 (logior . calcFunc-or)
|
|
1963 (logxor . calcFunc-xor)
|
|
1964 (lognot . calcFunc-not)
|
|
1965 (equal . equal) ; need to leave these ones alone!
|
|
1966 (eq . eq)
|
|
1967 (and . and)
|
|
1968 (or . or)
|
|
1969 (if . if)
|
|
1970 (^ . math-pow)
|
|
1971 (expt . math-pow)
|
41047
|
1972 ))
|
40785
|
1973
|
|
1974 (defconst math-prim-vars
|
|
1975 '( (nil . nil)
|
|
1976 (t . t)
|
|
1977 (&optional . &optional)
|
|
1978 (&rest . &rest)
|
41047
|
1979 ))
|
40785
|
1980
|
|
1981 (defun math-define-function-body (body env)
|
|
1982 (let ((body (math-define-body body env)))
|
|
1983 (if (math-body-refers-to body 'math-return)
|
|
1984 (list (cons 'catch (cons '(quote math-return) body)))
|
41047
|
1985 body)))
|
40785
|
1986
|
58390
|
1987 ;; The variable math-exp-env is local to math-define-body, but is
|
|
1988 ;; used by math-define-exp, which is called (indirectly) by
|
|
1989 ;; by math-define-body.
|
|
1990 (defvar math-exp-env)
|
|
1991
|
|
1992 (defun math-define-body (body math-exp-env)
|
41047
|
1993 (math-define-list body))
|
40785
|
1994
|
|
1995 (defun math-define-list (body &optional quote)
|
|
1996 (cond ((null body)
|
|
1997 nil)
|
|
1998 ((and (eq (car body) ':)
|
|
1999 (stringp (nth 1 body)))
|
|
2000 (cons (let* ((math-read-expr-quotes t)
|
|
2001 (exp (math-read-plain-expr (nth 1 body) t)))
|
|
2002 (math-define-exp exp))
|
|
2003 (math-define-list (cdr (cdr body)))))
|
|
2004 (quote
|
|
2005 (cons (cond ((consp (car body))
|
|
2006 (math-define-list (cdr body) t))
|
|
2007 (t
|
|
2008 (car body)))
|
|
2009 (math-define-list (cdr body))))
|
|
2010 (t
|
|
2011 (cons (math-define-exp (car body))
|
41047
|
2012 (math-define-list (cdr body))))))
|
40785
|
2013
|
|
2014 (defun math-define-exp (exp)
|
|
2015 (cond ((consp exp)
|
|
2016 (let ((func (car exp)))
|
|
2017 (cond ((memq func '(quote function))
|
|
2018 (if (and (consp (nth 1 exp))
|
|
2019 (eq (car (nth 1 exp)) 'lambda))
|
|
2020 (cons 'quote
|
58390
|
2021 (math-define-lambda (nth 1 exp) math-exp-env))
|
40785
|
2022 exp))
|
|
2023 ((memq func '(let let* for foreach))
|
|
2024 (let ((head (nth 1 exp))
|
|
2025 (body (cdr (cdr exp))))
|
|
2026 (if (memq func '(let let*))
|
|
2027 ()
|
|
2028 (setq func (cdr (assq func '((for . math-for)
|
|
2029 (foreach . math-foreach)))))
|
|
2030 (if (not (listp (car head)))
|
|
2031 (setq head (list head))))
|
|
2032 (macroexpand
|
|
2033 (cons func
|
|
2034 (cons (math-define-let head)
|
|
2035 (math-define-body body
|
|
2036 (nconc
|
|
2037 (math-define-let-env head)
|
58390
|
2038 math-exp-env)))))))
|
40785
|
2039 ((and (memq func '(setq setf))
|
|
2040 (math-complicated-lhs (cdr exp)))
|
|
2041 (if (> (length exp) 3)
|
|
2042 (cons 'progn (math-define-setf-list (cdr exp)))
|
|
2043 (math-define-setf (nth 1 exp) (nth 2 exp))))
|
|
2044 ((eq func 'condition-case)
|
|
2045 (cons func
|
|
2046 (cons (nth 1 exp)
|
|
2047 (math-define-body (cdr (cdr exp))
|
|
2048 (cons (nth 1 exp)
|
58390
|
2049 math-exp-env)))))
|
40785
|
2050 ((eq func 'cond)
|
|
2051 (cons func
|
|
2052 (math-define-cond (cdr exp))))
|
|
2053 ((and (consp func) ; ('spam a b) == force use of plain spam
|
|
2054 (eq (car func) 'quote))
|
|
2055 (cons func (math-define-list (cdr exp))))
|
|
2056 ((symbolp func)
|
|
2057 (let ((args (math-define-list (cdr exp)))
|
|
2058 (prim (assq func math-prim-funcs)))
|
|
2059 (cond (prim
|
|
2060 (cons (cdr prim) args))
|
|
2061 ((eq func 'floatp)
|
|
2062 (list 'eq (car args) '(quote float)))
|
|
2063 ((eq func '+)
|
|
2064 (math-define-binop 'math-add 0
|
|
2065 (car args) (cdr args)))
|
|
2066 ((eq func '-)
|
|
2067 (if (= (length args) 1)
|
|
2068 (cons 'math-neg args)
|
|
2069 (math-define-binop 'math-sub 0
|
|
2070 (car args) (cdr args))))
|
|
2071 ((eq func '*)
|
|
2072 (math-define-binop 'math-mul 1
|
|
2073 (car args) (cdr args)))
|
|
2074 ((eq func '/)
|
|
2075 (math-define-binop 'math-div 1
|
|
2076 (car args) (cdr args)))
|
|
2077 ((eq func 'min)
|
|
2078 (math-define-binop 'math-min 0
|
|
2079 (car args) (cdr args)))
|
|
2080 ((eq func 'max)
|
|
2081 (math-define-binop 'math-max 0
|
|
2082 (car args) (cdr args)))
|
|
2083 ((eq func '<)
|
|
2084 (if (and (math-numberp (nth 1 args))
|
|
2085 (math-zerop (nth 1 args)))
|
|
2086 (list 'math-negp (car args))
|
|
2087 (cons 'math-lessp args)))
|
|
2088 ((eq func '>)
|
|
2089 (if (and (math-numberp (nth 1 args))
|
|
2090 (math-zerop (nth 1 args)))
|
|
2091 (list 'math-posp (car args))
|
|
2092 (list 'math-lessp (nth 1 args) (nth 0 args))))
|
|
2093 ((eq func '<=)
|
|
2094 (list 'not
|
|
2095 (if (and (math-numberp (nth 1 args))
|
|
2096 (math-zerop (nth 1 args)))
|
|
2097 (list 'math-posp (car args))
|
|
2098 (list 'math-lessp
|
|
2099 (nth 1 args) (nth 0 args)))))
|
|
2100 ((eq func '>=)
|
|
2101 (list 'not
|
|
2102 (if (and (math-numberp (nth 1 args))
|
|
2103 (math-zerop (nth 1 args)))
|
|
2104 (list 'math-negp (car args))
|
|
2105 (cons 'math-lessp args))))
|
|
2106 ((eq func '=)
|
|
2107 (if (and (math-numberp (nth 1 args))
|
|
2108 (math-zerop (nth 1 args)))
|
|
2109 (list 'math-zerop (nth 0 args))
|
|
2110 (if (and (integerp (nth 1 args))
|
|
2111 (/= (% (nth 1 args) 10) 0))
|
|
2112 (cons 'math-equal-int args)
|
|
2113 (cons 'math-equal args))))
|
|
2114 ((eq func '/=)
|
|
2115 (list 'not
|
|
2116 (if (and (math-numberp (nth 1 args))
|
|
2117 (math-zerop (nth 1 args)))
|
|
2118 (list 'math-zerop (nth 0 args))
|
|
2119 (if (and (integerp (nth 1 args))
|
|
2120 (/= (% (nth 1 args) 10) 0))
|
|
2121 (cons 'math-equal-int args)
|
|
2122 (cons 'math-equal args)))))
|
|
2123 ((eq func '1+)
|
|
2124 (list 'math-add (car args) 1))
|
|
2125 ((eq func '1-)
|
|
2126 (list 'math-add (car args) -1))
|
|
2127 ((eq func 'not) ; optimize (not (not x)) => x
|
|
2128 (if (eq (car-safe args) func)
|
|
2129 (car (nth 1 args))
|
|
2130 (cons func args)))
|
|
2131 ((and (eq func 'elt) (cdr (cdr args)))
|
|
2132 (math-define-elt (car args) (cdr args)))
|
|
2133 (t
|
|
2134 (macroexpand
|
|
2135 (let* ((name (symbol-name func))
|
|
2136 (cfunc (intern (concat "calcFunc-" name)))
|
|
2137 (mfunc (intern (concat "math-" name))))
|
|
2138 (cond ((fboundp cfunc)
|
|
2139 (cons cfunc args))
|
|
2140 ((fboundp mfunc)
|
|
2141 (cons mfunc args))
|
|
2142 ((or (fboundp func)
|
|
2143 (string-match "\\`calcFunc-.*" name))
|
|
2144 (cons func args))
|
|
2145 (t
|
|
2146 (cons cfunc args)))))))))
|
58390
|
2147 (t (cons func (math-define-list (cdr exp))))))) ;;args
|
40785
|
2148 ((symbolp exp)
|
|
2149 (let ((prim (assq exp math-prim-vars))
|
|
2150 (name (symbol-name exp)))
|
|
2151 (cond (prim
|
|
2152 (cdr prim))
|
58390
|
2153 ((memq exp math-exp-env)
|
40785
|
2154 exp)
|
|
2155 ((string-match "-" name)
|
|
2156 exp)
|
|
2157 (t
|
|
2158 (intern (concat "var-" name))))))
|
|
2159 ((integerp exp)
|
|
2160 (if (or (<= exp -1000000) (>= exp 1000000))
|
|
2161 (list 'quote (math-normalize exp))
|
|
2162 exp))
|
41047
|
2163 (t exp)))
|
40785
|
2164
|
|
2165 (defun math-define-cond (forms)
|
|
2166 (and forms
|
|
2167 (cons (math-define-list (car forms))
|
41047
|
2168 (math-define-cond (cdr forms)))))
|
40785
|
2169
|
|
2170 (defun math-complicated-lhs (body)
|
|
2171 (and body
|
|
2172 (or (not (symbolp (car body)))
|
41047
|
2173 (math-complicated-lhs (cdr (cdr body))))))
|
40785
|
2174
|
|
2175 (defun math-define-setf-list (body)
|
|
2176 (and body
|
|
2177 (cons (math-define-setf (nth 0 body) (nth 1 body))
|
41047
|
2178 (math-define-setf-list (cdr (cdr body))))))
|
40785
|
2179
|
|
2180 (defun math-define-setf (place value)
|
|
2181 (setq place (math-define-exp place)
|
|
2182 value (math-define-exp value))
|
|
2183 (cond ((symbolp place)
|
|
2184 (list 'setq place value))
|
|
2185 ((eq (car-safe place) 'nth)
|
|
2186 (list 'setcar (list 'nthcdr (nth 1 place) (nth 2 place)) value))
|
|
2187 ((eq (car-safe place) 'elt)
|
|
2188 (list 'setcar (list 'nthcdr (nth 2 place) (nth 1 place)) value))
|
|
2189 ((eq (car-safe place) 'car)
|
|
2190 (list 'setcar (nth 1 place) value))
|
|
2191 ((eq (car-safe place) 'cdr)
|
|
2192 (list 'setcdr (nth 1 place) value))
|
|
2193 (t
|
41047
|
2194 (error "Bad place form for setf: %s" place))))
|
40785
|
2195
|
|
2196 (defun math-define-binop (op ident arg1 rest)
|
|
2197 (if rest
|
|
2198 (math-define-binop op ident
|
|
2199 (list op arg1 (car rest))
|
|
2200 (cdr rest))
|
41047
|
2201 (or arg1 ident)))
|
40785
|
2202
|
|
2203 (defun math-define-let (vlist)
|
|
2204 (and vlist
|
|
2205 (cons (if (consp (car vlist))
|
|
2206 (cons (car (car vlist))
|
|
2207 (math-define-list (cdr (car vlist))))
|
|
2208 (car vlist))
|
41047
|
2209 (math-define-let (cdr vlist)))))
|
40785
|
2210
|
|
2211 (defun math-define-let-env (vlist)
|
|
2212 (and vlist
|
|
2213 (cons (if (consp (car vlist))
|
|
2214 (car (car vlist))
|
|
2215 (car vlist))
|
41047
|
2216 (math-define-let-env (cdr vlist)))))
|
40785
|
2217
|
|
2218 (defun math-define-lambda (exp exp-env)
|
|
2219 (nconc (list (nth 0 exp) ; 'lambda
|
|
2220 (nth 1 exp)) ; arg list
|
|
2221 (math-define-function-body (cdr (cdr exp))
|
41047
|
2222 (append (nth 1 exp) exp-env))))
|
40785
|
2223
|
|
2224 (defun math-define-elt (seq idx)
|
|
2225 (if idx
|
|
2226 (math-define-elt (list 'elt seq (car idx)) (cdr idx))
|
41047
|
2227 seq))
|
40785
|
2228
|
|
2229
|
|
2230
|
|
2231 ;;; Useful programming macros.
|
|
2232
|
|
2233 (defmacro math-while (head &rest body)
|
|
2234 (let ((body (cons 'while (cons head body))))
|
|
2235 (if (math-body-refers-to body 'math-break)
|
|
2236 (cons 'catch (cons '(quote math-break) (list body)))
|
41047
|
2237 body)))
|
41271
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
diff
changeset
|
2238 ;; (put 'math-while 'lisp-indent-hook 1)
|
40785
|
2239
|
|
2240 (defmacro math-for (head &rest body)
|
|
2241 (let ((body (if head
|
|
2242 (math-handle-for head body)
|
|
2243 (cons 'while (cons t body)))))
|
|
2244 (if (math-body-refers-to body 'math-break)
|
|
2245 (cons 'catch (cons '(quote math-break) (list body)))
|
41047
|
2246 body)))
|
41271
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
diff
changeset
|
2247 ;; (put 'math-for 'lisp-indent-hook 1)
|
40785
|
2248
|
|
2249 (defun math-handle-for (head body)
|
|
2250 (let* ((var (nth 0 (car head)))
|
|
2251 (init (nth 1 (car head)))
|
|
2252 (limit (nth 2 (car head)))
|
|
2253 (step (or (nth 3 (car head)) 1))
|
|
2254 (body (if (cdr head)
|
|
2255 (list (math-handle-for (cdr head) body))
|
|
2256 body))
|
|
2257 (all-ints (and (integerp init) (integerp limit) (integerp step)))
|
|
2258 (const-limit (or (integerp limit)
|
|
2259 (and (eq (car-safe limit) 'quote)
|
|
2260 (math-realp (nth 1 limit)))))
|
|
2261 (const-step (or (integerp step)
|
|
2262 (and (eq (car-safe step) 'quote)
|
|
2263 (math-realp (nth 1 step)))))
|
|
2264 (save-limit (if const-limit limit (make-symbol "<limit>")))
|
|
2265 (save-step (if const-step step (make-symbol "<step>"))))
|
|
2266 (cons 'let
|
|
2267 (cons (append (if const-limit nil (list (list save-limit limit)))
|
|
2268 (if const-step nil (list (list save-step step)))
|
|
2269 (list (list var init)))
|
|
2270 (list
|
|
2271 (cons 'while
|
|
2272 (cons (if all-ints
|
|
2273 (if (> step 0)
|
|
2274 (list '<= var save-limit)
|
|
2275 (list '>= var save-limit))
|
|
2276 (list 'not
|
|
2277 (if const-step
|
|
2278 (if (or (math-posp step)
|
|
2279 (math-posp
|
|
2280 (cdr-safe step)))
|
|
2281 (list 'math-lessp
|
|
2282 save-limit
|
|
2283 var)
|
|
2284 (list 'math-lessp
|
|
2285 var
|
|
2286 save-limit))
|
|
2287 (list 'if
|
|
2288 (list 'math-posp
|
|
2289 save-step)
|
|
2290 (list 'math-lessp
|
|
2291 save-limit
|
|
2292 var)
|
|
2293 (list 'math-lessp
|
|
2294 var
|
|
2295 save-limit)))))
|
|
2296 (append body
|
|
2297 (list (list 'setq
|
|
2298 var
|
|
2299 (list (if all-ints
|
|
2300 '+
|
|
2301 'math-add)
|
|
2302 var
|
41047
|
2303 save-step)))))))))))
|
40785
|
2304
|
|
2305 (defmacro math-foreach (head &rest body)
|
|
2306 (let ((body (math-handle-foreach head body)))
|
|
2307 (if (math-body-refers-to body 'math-break)
|
|
2308 (cons 'catch (cons '(quote math-break) (list body)))
|
41047
|
2309 body)))
|
41271
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
diff
changeset
|
2310 ;; (put 'math-foreach 'lisp-indent-hook 1)
|
40785
|
2311
|
|
2312 (defun math-handle-foreach (head body)
|
|
2313 (let ((var (nth 0 (car head)))
|
|
2314 (data (nth 1 (car head)))
|
|
2315 (body (if (cdr head)
|
|
2316 (list (math-handle-foreach (cdr head) body))
|
|
2317 body)))
|
|
2318 (cons 'let
|
|
2319 (cons (list (list var data))
|
|
2320 (list
|
|
2321 (cons 'while
|
|
2322 (cons var
|
|
2323 (append body
|
|
2324 (list (list 'setq
|
|
2325 var
|
41047
|
2326 (list 'cdr var)))))))))))
|
40785
|
2327
|
|
2328
|
|
2329 (defun math-body-refers-to (body thing)
|
|
2330 (or (equal body thing)
|
|
2331 (and (consp body)
|
|
2332 (or (math-body-refers-to (car body) thing)
|
41047
|
2333 (math-body-refers-to (cdr body) thing)))))
|
40785
|
2334
|
|
2335 (defun math-break (&optional value)
|
41047
|
2336 (throw 'math-break value))
|
40785
|
2337
|
|
2338 (defun math-return (&optional value)
|
41047
|
2339 (throw 'math-return value))
|
40785
|
2340
|
|
2341
|
|
2342
|
|
2343
|
|
2344
|
|
2345 (defun math-composite-inequalities (x op)
|
|
2346 (if (memq (nth 1 op) '(calcFunc-eq calcFunc-neq))
|
|
2347 (if (eq (car x) (nth 1 op))
|
|
2348 (append x (list (math-read-expr-level (nth 3 op))))
|
|
2349 (throw 'syntax "Syntax error"))
|
|
2350 (list 'calcFunc-in
|
|
2351 (nth 2 x)
|
|
2352 (if (memq (nth 1 op) '(calcFunc-lt calcFunc-leq))
|
|
2353 (if (memq (car x) '(calcFunc-lt calcFunc-leq))
|
|
2354 (math-make-intv
|
|
2355 (+ (if (eq (car x) 'calcFunc-leq) 2 0)
|
|
2356 (if (eq (nth 1 op) 'calcFunc-leq) 1 0))
|
|
2357 (nth 1 x) (math-read-expr-level (nth 3 op)))
|
|
2358 (throw 'syntax "Syntax error"))
|
|
2359 (if (memq (car x) '(calcFunc-gt calcFunc-geq))
|
|
2360 (math-make-intv
|
|
2361 (+ (if (eq (nth 1 op) 'calcFunc-geq) 2 0)
|
|
2362 (if (eq (car x) 'calcFunc-geq) 1 0))
|
|
2363 (math-read-expr-level (nth 3 op)) (nth 1 x))
|
41047
|
2364 (throw 'syntax "Syntax error"))))))
|
40785
|
2365
|
58668
|
2366 (provide 'calc-prog)
|
|
2367
|
93975
|
2368 ;; arch-tag: 4c5a183b-c9e5-4632-bb3f-e41a764518b0
|
41047
|
2369 ;;; calc-prog.el ends here
|