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