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