HCoop / bpt / emacs.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
blame | history | raw | HEAD
(calc-user-define-edit): Don't find substring of nil.
[bpt/emacs.git] / lisp / calc / calc-prog.el
1 ;;; calc-prog.el --- user programmability functions for Calc
2
3 ;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2005 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-number
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* (cmdname
675 (key (read-char))
676 (def (or (assq key (calc-user-key-map))
677 (assq (upcase key) (calc-user-key-map))
678 (assq (downcase key) (calc-user-key-map))
679 (error "No command defined for that key")))
680 (cmd (cdr def)))
681 (when (symbolp cmd)
682 (setq cmdname (symbol-name cmd))
683 (setq cmd (symbol-function cmd)))
684 (cond ((or (stringp cmd)
685 (and (consp cmd)
686 (eq (car-safe (nth 3 cmd)) 'calc-execute-kbd-macro)))
687 (let* ((mac (elt (nth 1 (nth 3 cmd)) 1))
688 (str (edmacro-format-keys mac t))
689 (kys (nth 3 (nth 3 cmd))))
690 (calc-edit-mode
691 (list 'calc-edit-macro-finish-edit cmdname kys)
692 t (format (concat
693 "Editing keyboard macro (%s, bound to %s).\n"
694 "Original keys: %s \n")
695 cmdname kys (elt (nth 1 (nth 3 cmd)) 0)))
696 (insert str "\n")
697 (calc-edit-format-macro-buffer)
698 (calc-show-edit-buffer)))
699 (t (let* ((func (calc-stack-command-p cmd))
700 (defn (and func
701 (symbolp func)
702 (get func 'calc-user-defn)))
703 (kys (concat "z" (char-to-string (car def))))
704 (intcmd (symbol-name (cdr def)))
705 (algcmd (if func (substring (symbol-name func) 9) "")))
706 (if (and defn (calc-valid-formula-func func))
707 (let ((niceexpr (math-format-nice-expr defn (frame-width))))
708 (calc-wrapper
709 (calc-edit-mode
710 (list 'calc-finish-formula-edit (list 'quote func))
711 nil
712 (format (concat
713 "Editing formula (%s, %s, bound to %s).\n"
714 "Original formula: %s\n")
715 intcmd algcmd kys niceexpr))
716 (insert (math-showing-full-precision
717 niceexpr)
718 "\n"))
719 (calc-show-edit-buffer))
720 (error "That command's definition cannot be edited")))))))
721
722 ;; Formatting the macro buffer
723
724 (defvar calc-edit-top)
725
726 (defun calc-edit-macro-repeats ()
727 (goto-char calc-edit-top)
728 (while
729 (re-search-forward "^\\([0-9]+\\)\\*" nil t)
730 (let ((num (string-to-number (match-string 1)))
731 (line (buffer-substring (point) (line-end-position))))
732 (goto-char (line-beginning-position))
733 (kill-line 1)
734 (while (> num 0)
735 (insert line "\n")
736 (setq num (1- num))))))
737
738 (defun calc-edit-macro-adjust-buffer ()
739 (calc-edit-macro-repeats)
740 (goto-char calc-edit-top)
741 (while (re-search-forward "^RET$" nil t)
742 (delete-char 1))
743 (goto-char calc-edit-top)
744 (while (and (re-search-forward "^$" nil t)
745 (not (= (point) (point-max))))
746 (delete-char 1)))
747
748 (defun calc-edit-macro-command ()
749 "Return the command on the current line in a Calc macro editing buffer."
750 (let ((beg (line-beginning-position))
751 (end (save-excursion
752 (if (search-forward ";;" (line-end-position) 1)
753 (forward-char -2))
754 (skip-chars-backward " \t")
755 (point))))
756 (buffer-substring beg end)))
757
758 (defun calc-edit-macro-command-type ()
759 "Return the type of command on the current line in a Calc macro editing buffer."
760 (let ((beg (save-excursion
761 (if (search-forward ";;" (line-end-position) t)
762 (progn
763 (skip-chars-forward " \t")
764 (point)))))
765 (end (save-excursion
766 (goto-char (line-end-position))
767 (skip-chars-backward " \t")
768 (point))))
769 (if beg
770 (buffer-substring beg end)
771 "")))
772
773 (defun calc-edit-macro-combine-alg-ent ()
774 "Put an entire algebraic entry on a single line."
775 (let ((line (calc-edit-macro-command))
776 (type (calc-edit-macro-command-type))
777 curline
778 match)
779 (goto-char (line-beginning-position))
780 (kill-line 1)
781 (setq curline (calc-edit-macro-command))
782 (while (and curline
783 (not (string-equal "RET" curline))
784 (not (setq match (string-match "<return>" curline))))
785 (setq line (concat line curline))
786 (kill-line 1)
787 (setq curline (calc-edit-macro-command)))
788 (when match
789 (kill-line 1)
790 (setq line (concat line (substring curline 0 match))))
791 (setq line (replace-regexp-in-string "SPC" " SPC "
792 (replace-regexp-in-string " " "" line)))
793 (insert line "\t\t\t")
794 (if (> (current-column) 24)
795 (delete-char -1))
796 (insert ";; " type "\n")
797 (if match
798 (insert "RET\t\t\t;; calc-enter\n"))))
799
800 (defun calc-edit-macro-combine-ext-command ()
801 "Put an entire extended command on a single line."
802 (let ((cmdbeg (calc-edit-macro-command))
803 (line "")
804 (type (calc-edit-macro-command-type))
805 curline
806 match)
807 (goto-char (line-beginning-position))
808 (kill-line 1)
809 (setq curline (calc-edit-macro-command))
810 (while (and curline
811 (not (string-equal "RET" curline))
812 (not (setq match (string-match "<return>" curline))))
813 (setq line (concat line curline))
814 (kill-line 1)
815 (setq curline (calc-edit-macro-command)))
816 (when match
817 (kill-line 1)
818 (setq line (concat line (substring curline 0 match))))
819 (setq line (replace-regexp-in-string " " "" line))
820 (insert cmdbeg " " line "\t\t\t")
821 (if (> (current-column) 24)
822 (delete-char -1))
823 (insert ";; " type "\n")
824 (if match
825 (insert "RET\t\t\t;; calc-enter\n"))))
826
827 (defun calc-edit-macro-combine-var-name ()
828 "Put an entire variable name on a single line."
829 (let ((line (calc-edit-macro-command))
830 curline
831 match)
832 (goto-char (line-beginning-position))
833 (kill-line 1)
834 (if (member line '("0" "1" "2" "3" "4" "5" "6" "7" "8" "9"))
835 (insert line "\t\t\t;; calc quick variable\n")
836 (setq curline (calc-edit-macro-command))
837 (while (and curline
838 (not (string-equal "RET" curline))
839 (not (setq match (string-match "<return>" curline))))
840 (setq line (concat line curline))
841 (kill-line 1)
842 (setq curline (calc-edit-macro-command)))
843 (when match
844 (kill-line 1)
845 (setq line (concat line (substring curline 0 match))))
846 (setq line (replace-regexp-in-string " " "" line))
847 (insert line "\t\t\t")
848 (if (> (current-column) 24)
849 (delete-char -1))
850 (insert ";; calc variable\n")
851 (if match
852 (insert "RET\t\t\t;; calc-enter\n")))))
853
854 (defun calc-edit-macro-combine-digits ()
855 "Put an entire sequence of digits on a single line."
856 (let ((line (calc-edit-macro-command))
857 curline)
858 (goto-char (line-beginning-position))
859 (kill-line 1)
860 (while (string-equal (calc-edit-macro-command-type) "calcDigit-start")
861 (setq line (concat line (calc-edit-macro-command)))
862 (kill-line 1))
863 (insert line "\t\t\t")
864 (if (> (current-column) 24)
865 (delete-char -1))
866 (insert ";; calc digits\n")))
867
868 (defun calc-edit-format-macro-buffer ()
869 "Rewrite the Calc macro editing buffer."
870 (calc-edit-macro-adjust-buffer)
871 (goto-char calc-edit-top)
872 (let ((type (calc-edit-macro-command-type)))
873 (while (not (string-equal type ""))
874 (cond
875 ((or
876 (string-equal type "calc-algebraic-entry")
877 (string-equal type "calc-auto-algebraic-entry"))
878 (calc-edit-macro-combine-alg-ent))
879 ((string-equal type "calc-execute-extended-command")
880 (calc-edit-macro-combine-ext-command))
881 ((string-equal type "calcDigit-start")
882 (calc-edit-macro-combine-digits))
883 ((or
884 (string-equal type "calc-store")
885 (string-equal type "calc-store-into")
886 (string-equal type "calc-store-neg")
887 (string-equal type "calc-store-plus")
888 (string-equal type "calc-store-minus")
889 (string-equal type "calc-store-div")
890 (string-equal type "calc-store-times")
891 (string-equal type "calc-store-power")
892 (string-equal type "calc-store-concat")
893 (string-equal type "calc-store-inv")
894 (string-equal type "calc-store-dec")
895 (string-equal type "calc-store-incr")
896 (string-equal type "calc-store-exchange")
897 (string-equal type "calc-unstore")
898 (string-equal type "calc-recall")
899 (string-equal type "calc-let")
900 (string-equal type "calc-permanent-variable"))
901 (forward-line 1)
902 (calc-edit-macro-combine-var-name))
903 ((or
904 (string-equal type "calc-copy-variable")
905 (string-equal type "calc-copy-special-constant")
906 (string-equal type "calc-declare-variable"))
907 (forward-line 1)
908 (calc-edit-macro-combine-var-name)
909 (calc-edit-macro-combine-var-name))
910 (t (forward-line 1)))
911 (setq type (calc-edit-macro-command-type))))
912 (goto-char calc-edit-top))
913
914 ;; Finish editing the macro
915
916 (defun calc-edit-macro-pre-finish-edit ()
917 (goto-char calc-edit-top)
918 (while (re-search-forward "\\(^\\| \\)RET\\($\\|\t\\| \\)" nil t)
919 (search-backward "RET")
920 (delete-char 3)
921 (insert "<return>")))
922
923 (defun calc-edit-macro-finish-edit (cmdname key)
924 "Finish editing a Calc macro.
925 Redefine the corresponding command."
926 (interactive)
927 (let ((cmd (intern cmdname)))
928 (calc-edit-macro-pre-finish-edit)
929 (let* ((str (buffer-substring calc-edit-top (point-max)))
930 (mac (edmacro-parse-keys str t)))
931 (if (= (length mac) 0)
932 (fmakunbound cmd)
933 (fset cmd
934 (list 'lambda '(arg)
935 '(interactive "P")
936 (list 'calc-execute-kbd-macro
937 (vector (key-description mac)
938 mac)
939 'arg key)))))))
940
941 (defun calc-finish-formula-edit (func)
942 (let ((buf (current-buffer))
943 (str (buffer-substring calc-edit-top (point-max)))
944 (start (point))
945 (body (calc-valid-formula-func func)))
946 (set-buffer calc-original-buffer)
947 (let ((val (math-read-expr str)))
948 (if (eq (car-safe val) 'error)
949 (progn
950 (set-buffer buf)
951 (goto-char (+ start (nth 1 val)))
952 (error (nth 2 val))))
953 (setcar (cdr body)
954 (let ((calc-user-formula-alist (nth 1 (symbol-function func))))
955 (calc-fix-user-formula val)))
956 (put func 'calc-user-defn val))))
957
958 (defun calc-valid-formula-func (func)
959 (let ((def (symbol-function func)))
960 (and (consp def)
961 (eq (car def) 'lambda)
962 (progn
963 (setq def (cdr (cdr def)))
964 (while (and def
965 (not (eq (car (car def)) 'math-normalize)))
966 (setq def (cdr def)))
967 (car def)))))
968
969
970 (defun calc-get-user-defn ()
971 (interactive)
972 (calc-wrapper
973 (message "Get definition of command: z-")
974 (let* ((key (read-char))
975 (def (or (assq key (calc-user-key-map))
976 (assq (upcase key) (calc-user-key-map))
977 (assq (downcase key) (calc-user-key-map))
978 (error "No command defined for that key")))
979 (cmd (cdr def)))
980 (if (symbolp cmd)
981 (setq cmd (symbol-function cmd)))
982 (cond ((stringp cmd)
983 (message "Keyboard macro: %s" cmd))
984 (t (let* ((func (calc-stack-command-p cmd))
985 (defn (and func
986 (symbolp func)
987 (get func 'calc-user-defn))))
988 (if defn
989 (progn
990 (and (calc-valid-formula-func func)
991 (setq defn (append '(calcFunc-lambda)
992 (mapcar 'math-build-var-name
993 (nth 1 (symbol-function
994 func)))
995 (list defn))))
996 (calc-enter-result 0 "gdef" defn))
997 (error "That command is not defined by a formula"))))))))
998
999
1000 (defun calc-user-define-permanent ()
1001 (interactive)
1002 (calc-wrapper
1003 (message "Record in %s the command: z-" calc-settings-file)
1004 (let* ((key (read-char))
1005 (def (or (assq key (calc-user-key-map))
1006 (assq (upcase key) (calc-user-key-map))
1007 (assq (downcase key) (calc-user-key-map))
1008 (and (eq key ?\')
1009 (cons nil
1010 (intern
1011 (concat "calcFunc-"
1012 (completing-read
1013 (format "Record in %s the algebraic function: "
1014 calc-settings-file)
1015 (mapcar (lambda (x) (substring x 9))
1016 (all-completions "calcFunc-"
1017 obarray))
1018 (lambda (x)
1019 (fboundp
1020 (intern (concat "calcFunc-" x))))
1021 t)))))
1022 (and (eq key ?\M-x)
1023 (cons nil
1024 (intern (completing-read
1025 (format "Record in %s the command: "
1026 calc-settings-file)
1027 obarray 'fboundp nil "calc-"))))
1028 (error "No command defined for that key"))))
1029 (set-buffer (find-file-noselect (substitute-in-file-name
1030 calc-settings-file)))
1031 (goto-char (point-max))
1032 (let* ((cmd (cdr def))
1033 (fcmd (and cmd (symbolp cmd) (symbol-function cmd)))
1034 (func nil)
1035 (pt (point))
1036 (fill-column 70)
1037 (fill-prefix nil)
1038 str q-ok)
1039 (insert "\n;;; Definition stored by Calc on " (current-time-string)
1040 "\n(put 'calc-define '"
1041 (if (symbolp cmd) (symbol-name cmd) (format "key%d" key))
1042 " '(progn\n")
1043 (if (and fcmd
1044 (eq (car-safe fcmd) 'lambda)
1045 (get cmd 'calc-user-defn))
1046 (let ((pt (point)))
1047 (and (eq (car-safe (nth 3 fcmd)) 'calc-execute-kbd-macro)
1048 (vectorp (nth 1 (nth 3 fcmd)))
1049 (progn (and (fboundp 'edit-kbd-macro)
1050 (edit-kbd-macro nil))
1051 (fboundp 'edmacro-parse-keys))
1052 (setq q-ok t)
1053 (aset (nth 1 (nth 3 fcmd)) 1 nil))
1054 (insert (setq str (prin1-to-string
1055 (cons 'defun (cons cmd (cdr fcmd)))))
1056 "\n")
1057 (or (and (string-match "\"" str) (not q-ok))
1058 (fill-region pt (point)))
1059 (indent-rigidly pt (point) 2)
1060 (delete-region pt (1+ pt))
1061 (insert " (put '" (symbol-name cmd)
1062 " 'calc-user-defn '"
1063 (prin1-to-string (get cmd 'calc-user-defn))
1064 ")\n")
1065 (setq func (calc-stack-command-p cmd))
1066 (let ((ffunc (and func (symbolp func) (symbol-function func)))
1067 (pt (point)))
1068 (and ffunc
1069 (eq (car-safe ffunc) 'lambda)
1070 (get func 'calc-user-defn)
1071 (progn
1072 (insert (setq str (prin1-to-string
1073 (cons 'defun (cons func
1074 (cdr ffunc)))))
1075 "\n")
1076 (or (and (string-match "\"" str) (not q-ok))
1077 (fill-region pt (point)))
1078 (indent-rigidly pt (point) 2)
1079 (delete-region pt (1+ pt))
1080 (setq pt (point))
1081 (insert "(put '" (symbol-name func)
1082 " 'calc-user-defn '"
1083 (prin1-to-string (get func 'calc-user-defn))
1084 ")\n")
1085 (fill-region pt (point))
1086 (indent-rigidly pt (point) 2)
1087 (delete-region pt (1+ pt))))))
1088 (and (stringp fcmd)
1089 (insert " (fset '" (prin1-to-string cmd)
1090 " " (prin1-to-string fcmd) ")\n")))
1091 (or func (setq func (and cmd (symbolp cmd) (fboundp cmd) cmd)))
1092 (if (get func 'math-compose-forms)
1093 (let ((pt (point)))
1094 (insert "(put '" (symbol-name cmd)
1095 " 'math-compose-forms '"
1096 (prin1-to-string (get func 'math-compose-forms))
1097 ")\n")
1098 (fill-region pt (point))
1099 (indent-rigidly pt (point) 2)
1100 (delete-region pt (1+ pt))))
1101 (if (car def)
1102 (insert " (define-key calc-mode-map "
1103 (prin1-to-string (concat "z" (char-to-string key)))
1104 " '"
1105 (prin1-to-string cmd)
1106 ")\n")))
1107 (insert "))\n")
1108 (save-buffer))))
1109
1110 (defun calc-stack-command-p (cmd)
1111 (if (and cmd (symbolp cmd))
1112 (and (fboundp cmd)
1113 (calc-stack-command-p (symbol-function cmd)))
1114 (and (consp cmd)
1115 (eq (car cmd) 'lambda)
1116 (setq cmd (or (assq 'calc-wrapper cmd)
1117 (assq 'calc-slow-wrapper cmd)))
1118 (setq cmd (assq 'calc-enter-result cmd))
1119 (memq (car (nth 3 cmd)) '(cons list))
1120 (eq (car (nth 1 (nth 3 cmd))) 'quote)
1121 (nth 1 (nth 1 (nth 3 cmd))))))
1122
1123
1124 (defun calc-call-last-kbd-macro (arg)
1125 (interactive "P")
1126 (and defining-kbd-macro
1127 (error "Can't execute anonymous macro while defining one"))
1128 (or last-kbd-macro
1129 (error "No kbd macro has been defined"))
1130 (calc-execute-kbd-macro last-kbd-macro arg))
1131
1132 (defun calc-execute-kbd-macro (mac arg &rest prefix)
1133 (if calc-keep-args-flag
1134 (calc-keep-args))
1135 (if (and (vectorp mac) (> (length mac) 0) (stringp (aref mac 0)))
1136 (setq mac (or (aref mac 1)
1137 (aset mac 1 (progn (and (fboundp 'edit-kbd-macro)
1138 (edit-kbd-macro nil))
1139 (edmacro-parse-keys (aref mac 0)))))))
1140 (if (< (prefix-numeric-value arg) 0)
1141 (execute-kbd-macro mac (- (prefix-numeric-value arg)))
1142 (if calc-executing-macro
1143 (execute-kbd-macro mac arg)
1144 (calc-slow-wrapper
1145 (let ((old-stack-whole (copy-sequence calc-stack))
1146 (old-stack-top calc-stack-top)
1147 (old-buffer-size (buffer-size))
1148 (old-refresh-count calc-refresh-count))
1149 (unwind-protect
1150 (let ((calc-executing-macro mac))
1151 (execute-kbd-macro mac arg))
1152 (calc-select-buffer)
1153 (let ((new-stack (reverse calc-stack))
1154 (old-stack (reverse old-stack-whole)))
1155 (while (and new-stack old-stack
1156 (equal (car new-stack) (car old-stack)))
1157 (setq new-stack (cdr new-stack)
1158 old-stack (cdr old-stack)))
1159 (or (equal prefix '(nil))
1160 (calc-record-list (if (> (length new-stack) 1)
1161 (mapcar 'car new-stack)
1162 '(""))
1163 (or (car prefix) "kmac")))
1164 (calc-record-undo (list 'set 'saved-stack-top old-stack-top))
1165 (and old-stack
1166 (calc-record-undo (list 'pop 1 (mapcar 'car old-stack))))
1167 (let ((calc-stack old-stack-whole)
1168 (calc-stack-top 0))
1169 (calc-cursor-stack-index (length old-stack)))
1170 (if (and (= old-buffer-size (buffer-size))
1171 (= old-refresh-count calc-refresh-count))
1172 (let ((buffer-read-only nil))
1173 (delete-region (point) (point-max))
1174 (while new-stack
1175 (calc-record-undo (list 'push 1))
1176 (insert (math-format-stack-value (car new-stack)) "\n")
1177 (setq new-stack (cdr new-stack)))
1178 (calc-renumber-stack))
1179 (while new-stack
1180 (calc-record-undo (list 'push 1))
1181 (setq new-stack (cdr new-stack)))
1182 (calc-refresh))
1183 (calc-record-undo (list 'set 'saved-stack-top 0)))))))))
1184
1185 (defun calc-push-list-in-macro (vals m sels)
1186 (let ((entry (list (car vals) 1 (car sels)))
1187 (mm (+ (or m 1) calc-stack-top)))
1188 (if (> mm 1)
1189 (setcdr (nthcdr (- mm 2) calc-stack)
1190 (cons entry (nthcdr (1- mm) calc-stack)))
1191 (setq calc-stack (cons entry calc-stack)))))
1192
1193 (defun calc-pop-stack-in-macro (n mm)
1194 (if (> mm 1)
1195 (setcdr (nthcdr (- mm 2) calc-stack)
1196 (nthcdr (+ n mm -1) calc-stack))
1197 (setq calc-stack (nthcdr n calc-stack))))
1198
1199
1200 (defun calc-kbd-if ()
1201 (interactive)
1202 (calc-wrapper
1203 (let ((cond (calc-top-n 1)))
1204 (calc-pop-stack 1)
1205 (if (math-is-true cond)
1206 (if defining-kbd-macro
1207 (message "If true.."))
1208 (if defining-kbd-macro
1209 (message "Condition is false; skipping to Z: or Z] ..."))
1210 (calc-kbd-skip-to-else-if t)))))
1211
1212 (defun calc-kbd-else-if ()
1213 (interactive)
1214 (calc-kbd-if))
1215
1216 (defun calc-kbd-skip-to-else-if (else-okay)
1217 (let ((count 0)
1218 ch)
1219 (while (>= count 0)
1220 (setq ch (read-char))
1221 (if (= ch -1)
1222 (error "Unterminated Z[ in keyboard macro"))
1223 (if (= ch ?Z)
1224 (progn
1225 (setq ch (read-char))
1226 (cond ((= ch ?\[)
1227 (setq count (1+ count)))
1228 ((= ch ?\])
1229 (setq count (1- count)))
1230 ((= ch ?\:)
1231 (and (= count 0)
1232 else-okay
1233 (setq count -1)))
1234 ((eq ch 7)
1235 (keyboard-quit))))))
1236 (and defining-kbd-macro
1237 (if (= ch ?\:)
1238 (message "Else...")
1239 (message "End-if...")))))
1240
1241 (defun calc-kbd-end-if ()
1242 (interactive)
1243 (if defining-kbd-macro
1244 (message "End-if...")))
1245
1246 (defun calc-kbd-else ()
1247 (interactive)
1248 (if defining-kbd-macro
1249 (message "Else; skipping to Z] ..."))
1250 (calc-kbd-skip-to-else-if nil))
1251
1252
1253 (defun calc-kbd-repeat ()
1254 (interactive)
1255 (let (count)
1256 (calc-wrapper
1257 (setq count (math-trunc (calc-top-n 1)))
1258 (or (Math-integerp count)
1259 (error "Count must be an integer"))
1260 (if (Math-integer-negp count)
1261 (setq count 0))
1262 (or (integerp count)
1263 (setq count 1000000))
1264 (calc-pop-stack 1))
1265 (calc-kbd-loop count)))
1266
1267 (defun calc-kbd-for (dir)
1268 (interactive "P")
1269 (let (init final)
1270 (calc-wrapper
1271 (setq init (calc-top-n 2)
1272 final (calc-top-n 1))
1273 (or (and (math-anglep init) (math-anglep final))
1274 (error "Initial and final values must be real numbers"))
1275 (calc-pop-stack 2))
1276 (calc-kbd-loop nil init final (and dir (prefix-numeric-value dir)))))
1277
1278 (defun calc-kbd-loop (rpt-count &optional initial final dir)
1279 (interactive "P")
1280 (setq rpt-count (if rpt-count (prefix-numeric-value rpt-count) 1000000))
1281 (let* ((count 0)
1282 (parts nil)
1283 (body "")
1284 (open last-command-char)
1285 (counter initial)
1286 ch)
1287 (or executing-kbd-macro
1288 (message "Reading loop body..."))
1289 (while (>= count 0)
1290 (setq ch (read-char))
1291 (if (= ch -1)
1292 (error "Unterminated Z%c in keyboard macro" open))
1293 (if (= ch ?Z)
1294 (progn
1295 (setq ch (read-char)
1296 body (concat body "Z" (char-to-string ch)))
1297 (cond ((memq ch '(?\< ?\( ?\{))
1298 (setq count (1+ count)))
1299 ((memq ch '(?\> ?\) ?\}))
1300 (setq count (1- count)))
1301 ((and (= ch ?/)
1302 (= count 0))
1303 (setq parts (nconc parts (list (concat (substring body 0 -2)
1304 "Z]")))
1305 body ""))
1306 ((eq ch 7)
1307 (keyboard-quit))))
1308 (setq body (concat body (char-to-string ch)))))
1309 (if (/= ch (cdr (assq open '( (?\< . ?\>) (?\( . ?\)) (?\{ . ?\}) ))))
1310 (error "Mismatched Z%c and Z%c in keyboard macro" open ch))
1311 (or executing-kbd-macro
1312 (message "Looping..."))
1313 (setq body (concat (substring body 0 -2) "Z]"))
1314 (and (not executing-kbd-macro)
1315 (= rpt-count 1000000)
1316 (null parts)
1317 (null counter)
1318 (progn
1319 (message "Warning: Infinite loop! Not executing")
1320 (setq rpt-count 0)))
1321 (or (not initial) dir
1322 (setq dir (math-compare final initial)))
1323 (calc-wrapper
1324 (while (> rpt-count 0)
1325 (let ((part parts))
1326 (if counter
1327 (if (cond ((eq dir 0) (Math-equal final counter))
1328 ((eq dir 1) (Math-lessp final counter))
1329 ((eq dir -1) (Math-lessp counter final)))
1330 (setq rpt-count 0)
1331 (calc-push counter)))
1332 (while (and part (> rpt-count 0))
1333 (execute-kbd-macro (car part))
1334 (if (math-is-true (calc-top-n 1))
1335 (setq rpt-count 0)
1336 (setq part (cdr part)))
1337 (calc-pop-stack 1))
1338 (if (> rpt-count 0)
1339 (progn
1340 (execute-kbd-macro body)
1341 (if counter
1342 (let ((step (calc-top-n 1)))
1343 (calc-pop-stack 1)
1344 (setq counter (calcFunc-add counter step)))
1345 (setq rpt-count (1- rpt-count))))))))
1346 (or executing-kbd-macro
1347 (message "Looping...done"))))
1348
1349 (defun calc-kbd-end-repeat ()
1350 (interactive)
1351 (error "Unbalanced Z> in keyboard macro"))
1352
1353 (defun calc-kbd-end-for ()
1354 (interactive)
1355 (error "Unbalanced Z) in keyboard macro"))
1356
1357 (defun calc-kbd-end-loop ()
1358 (interactive)
1359 (error "Unbalanced Z} in keyboard macro"))
1360
1361 (defun calc-kbd-break ()
1362 (interactive)
1363 (calc-wrapper
1364 (let ((cond (calc-top-n 1)))
1365 (calc-pop-stack 1)
1366 (if (math-is-true cond)
1367 (error "Keyboard macro aborted")))))
1368
1369
1370 (defvar calc-kbd-push-level 0)
1371
1372 ;; The variables var-q0 through var-q9 are the "quick" variables.
1373 (defvar var-q0 nil)
1374 (defvar var-q1 nil)
1375 (defvar var-q2 nil)
1376 (defvar var-q3 nil)
1377 (defvar var-q4 nil)
1378 (defvar var-q5 nil)
1379 (defvar var-q6 nil)
1380 (defvar var-q7 nil)
1381 (defvar var-q8 nil)
1382 (defvar var-q9 nil)
1383
1384 (defun calc-kbd-push (arg)
1385 (interactive "P")
1386 (calc-wrapper
1387 (let* ((defs (and arg (> (prefix-numeric-value arg) 0)))
1388 (var-q0 var-q0)
1389 (var-q1 var-q1)
1390 (var-q2 var-q2)
1391 (var-q3 var-q3)
1392 (var-q4 var-q4)
1393 (var-q5 var-q5)
1394 (var-q6 var-q6)
1395 (var-q7 var-q7)
1396 (var-q8 var-q8)
1397 (var-q9 var-q9)
1398 (calc-internal-prec (if defs 12 calc-internal-prec))
1399 (calc-word-size (if defs 32 calc-word-size))
1400 (calc-angle-mode (if defs 'deg calc-angle-mode))
1401 (calc-simplify-mode (if defs nil calc-simplify-mode))
1402 (calc-algebraic-mode (if arg nil calc-algebraic-mode))
1403 (calc-incomplete-algebraic-mode (if arg nil
1404 calc-incomplete-algebraic-mode))
1405 (calc-symbolic-mode (if defs nil calc-symbolic-mode))
1406 (calc-matrix-mode (if defs nil calc-matrix-mode))
1407 (calc-prefer-frac (if defs nil calc-prefer-frac))
1408 (calc-complex-mode (if defs nil calc-complex-mode))
1409 (calc-infinite-mode (if defs nil calc-infinite-mode))
1410 (count 0)
1411 (body "")
1412 ch)
1413 (if (or executing-kbd-macro defining-kbd-macro)
1414 (progn
1415 (if defining-kbd-macro
1416 (message "Reading body..."))
1417 (while (>= count 0)
1418 (setq ch (read-char))
1419 (if (= ch -1)
1420 (error "Unterminated Z` in keyboard macro"))
1421 (if (= ch ?Z)
1422 (progn
1423 (setq ch (read-char)
1424 body (concat body "Z" (char-to-string ch)))
1425 (cond ((eq ch ?\`)
1426 (setq count (1+ count)))
1427 ((eq ch ?\')
1428 (setq count (1- count)))
1429 ((eq ch 7)
1430 (keyboard-quit))))
1431 (setq body (concat body (char-to-string ch)))))
1432 (if defining-kbd-macro
1433 (message "Reading body...done"))
1434 (let ((calc-kbd-push-level 0))
1435 (execute-kbd-macro (substring body 0 -2))))
1436 (let ((calc-kbd-push-level (1+ calc-kbd-push-level)))
1437 (message "Saving modes; type Z' to restore")
1438 (recursive-edit))))))
1439
1440 (defun calc-kbd-pop ()
1441 (interactive)
1442 (if (> calc-kbd-push-level 0)
1443 (progn
1444 (message "Mode settings restored")
1445 (exit-recursive-edit))
1446 (error "Unbalanced Z' in keyboard macro")))
1447
1448
1449 (defun calc-kbd-report (msg)
1450 (interactive "sMessage: ")
1451 (calc-wrapper
1452 (math-working msg (calc-top-n 1))))
1453
1454 (defun calc-kbd-query (msg)
1455 (interactive "sPrompt: ")
1456 (calc-wrapper
1457 (calc-alg-entry nil (and (not (equal msg "")) msg))))
1458
1459 ;;;; Logical operations.
1460
1461 (defun calcFunc-eq (a b &rest more)
1462 (if more
1463 (let* ((args (cons a (cons b (copy-sequence more))))
1464 (res 1)
1465 (p args)
1466 p2)
1467 (while (and (cdr p) (not (eq res 0)))
1468 (setq p2 p)
1469 (while (and (setq p2 (cdr p2)) (not (eq res 0)))
1470 (setq res (math-two-eq (car p) (car p2)))
1471 (if (eq res 1)
1472 (setcdr p (delq (car p2) (cdr p)))))
1473 (setq p (cdr p)))
1474 (if (eq res 0)
1475 0
1476 (if (cdr args)
1477 (cons 'calcFunc-eq args)
1478 1)))
1479 (or (math-two-eq a b)
1480 (if (and (or (math-looks-negp a) (math-zerop a))
1481 (or (math-looks-negp b) (math-zerop b)))
1482 (list 'calcFunc-eq (math-neg a) (math-neg b))
1483 (list 'calcFunc-eq a b)))))
1484
1485 (defun calcFunc-neq (a b &rest more)
1486 (if more
1487 (let* ((args (cons a (cons b more)))
1488 (res 0)
1489 (all t)
1490 (p args)
1491 p2)
1492 (while (and (cdr p) (not (eq res 1)))
1493 (setq p2 p)
1494 (while (and (setq p2 (cdr p2)) (not (eq res 1)))
1495 (setq res (math-two-eq (car p) (car p2)))
1496 (or res (setq all nil)))
1497 (setq p (cdr p)))
1498 (if (eq res 1)
1499 0
1500 (if all
1501 1
1502 (cons 'calcFunc-neq args))))
1503 (or (cdr (assq (math-two-eq a b) '((0 . 1) (1 . 0))))
1504 (if (and (or (math-looks-negp a) (math-zerop a))
1505 (or (math-looks-negp b) (math-zerop b)))
1506 (list 'calcFunc-neq (math-neg a) (math-neg b))
1507 (list 'calcFunc-neq a b)))))
1508
1509 (defun math-two-eq (a b)
1510 (if (eq (car-safe a) 'vec)
1511 (if (eq (car-safe b) 'vec)
1512 (if (= (length a) (length b))
1513 (let ((res 1))
1514 (while (and (setq a (cdr a) b (cdr b)) (not (eq res 0)))
1515 (if res
1516 (setq res (math-two-eq (car a) (car b)))
1517 (if (eq (math-two-eq (car a) (car b)) 0)
1518 (setq res 0))))
1519 res)
1520 0)
1521 (if (Math-objectp b)
1522 0
1523 nil))
1524 (if (eq (car-safe b) 'vec)
1525 (if (Math-objectp a)
1526 0
1527 nil)
1528 (let ((res (math-compare a b)))
1529 (if (= res 0)
1530 1
1531 (if (and (= res 2) (not (and (Math-scalarp a) (Math-scalarp b))))
1532 nil
1533 0))))))
1534
1535 (defun calcFunc-lt (a b)
1536 (let ((res (math-compare a b)))
1537 (if (= res -1)
1538 1
1539 (if (= res 2)
1540 (if (and (or (math-looks-negp a) (math-zerop a))
1541 (or (math-looks-negp b) (math-zerop b)))
1542 (list 'calcFunc-gt (math-neg a) (math-neg b))
1543 (list 'calcFunc-lt a b))
1544 0))))
1545
1546 (defun calcFunc-gt (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-lt (math-neg a) (math-neg b))
1554 (list 'calcFunc-gt a b))
1555 0))))
1556
1557 (defun calcFunc-leq (a b)
1558 (let ((res (math-compare a b)))
1559 (if (= res 1)
1560 0
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-geq (math-neg a) (math-neg b))
1565 (list 'calcFunc-leq a b))
1566 1))))
1567
1568 (defun calcFunc-geq (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-leq (math-neg a) (math-neg b))
1576 (list 'calcFunc-geq a b))
1577 1))))
1578
1579 (defun calcFunc-rmeq (a)
1580 (if (math-vectorp a)
1581 (math-map-vec 'calcFunc-rmeq a)
1582 (if (assq (car-safe a) calc-tweak-eqn-table)
1583 (if (and (eq (car-safe (nth 2 a)) 'var)
1584 (math-objectp (nth 1 a)))
1585 (nth 1 a)
1586 (nth 2 a))
1587 (if (eq (car-safe a) 'calcFunc-assign)
1588 (nth 2 a)
1589 (if (eq (car-safe a) 'calcFunc-evalto)
1590 (nth 1 a)
1591 (list 'calcFunc-rmeq a))))))
1592
1593 (defun calcFunc-land (a b)
1594 (cond ((Math-zerop a)
1595 a)
1596 ((Math-zerop b)
1597 b)
1598 ((math-is-true a)
1599 b)
1600 ((math-is-true b)
1601 a)
1602 (t (list 'calcFunc-land a b))))
1603
1604 (defun calcFunc-lor (a b)
1605 (cond ((Math-zerop a)
1606 b)
1607 ((Math-zerop b)
1608 a)
1609 ((math-is-true a)
1610 a)
1611 ((math-is-true b)
1612 b)
1613 (t (list 'calcFunc-lor a b))))
1614
1615 (defun calcFunc-lnot (a)
1616 (if (Math-zerop a)
1617 1
1618 (if (math-is-true a)
1619 0
1620 (let ((op (and (= (length a) 3)
1621 (assq (car a) calc-tweak-eqn-table))))
1622 (if op
1623 (cons (nth 2 op) (cdr a))
1624 (list 'calcFunc-lnot a))))))
1625
1626 (defun calcFunc-if (c e1 e2)
1627 (if (Math-zerop c)
1628 e2
1629 (if (and (math-is-true c) (not (Math-vectorp c)))
1630 e1
1631 (or (and (Math-vectorp c)
1632 (math-constp c)
1633 (let ((ee1 (if (Math-vectorp e1)
1634 (if (= (length c) (length e1))
1635 (cdr e1)
1636 (calc-record-why "*Dimension error" e1))
1637 (list e1)))
1638 (ee2 (if (Math-vectorp e2)
1639 (if (= (length c) (length e2))
1640 (cdr e2)
1641 (calc-record-why "*Dimension error" e2))
1642 (list e2))))
1643 (and ee1 ee2
1644 (cons 'vec (math-if-vector (cdr c) ee1 ee2)))))
1645 (list 'calcFunc-if c e1 e2)))))
1646
1647 (defun math-if-vector (c e1 e2)
1648 (and c
1649 (cons (if (Math-zerop (car c)) (car e2) (car e1))
1650 (math-if-vector (cdr c)
1651 (or (cdr e1) e1)
1652 (or (cdr e2) e2)))))
1653
1654 (defun math-normalize-logical-op (a)
1655 (or (and (eq (car a) 'calcFunc-if)
1656 (= (length a) 4)
1657 (let ((a1 (math-normalize (nth 1 a))))
1658 (if (Math-zerop a1)
1659 (math-normalize (nth 3 a))
1660 (if (Math-numberp a1)
1661 (math-normalize (nth 2 a))
1662 (if (and (Math-vectorp (nth 1 a))
1663 (math-constp (nth 1 a)))
1664 (calcFunc-if (nth 1 a)
1665 (math-normalize (nth 2 a))
1666 (math-normalize (nth 3 a)))
1667 (let ((calc-simplify-mode 'none))
1668 (list 'calcFunc-if a1
1669 (math-normalize (nth 2 a))
1670 (math-normalize (nth 3 a)))))))))
1671 a))
1672
1673 (defun calcFunc-in (a b)
1674 (or (and (eq (car-safe b) 'vec)
1675 (let ((bb b))
1676 (while (and (setq bb (cdr bb))
1677 (not (if (memq (car-safe (car bb)) '(vec intv))
1678 (eq (calcFunc-in a (car bb)) 1)
1679 (Math-equal a (car bb))))))
1680 (if bb 1 (and (math-constp a) (math-constp bb) 0))))
1681 (and (eq (car-safe b) 'intv)
1682 (let ((res (math-compare a (nth 2 b))) res2)
1683 (cond ((= res -1)
1684 0)
1685 ((and (= res 0)
1686 (or (/= (nth 1 b) 2)
1687 (Math-lessp (nth 2 b) (nth 3 b))))
1688 (if (memq (nth 1 b) '(2 3)) 1 0))
1689 ((= (setq res2 (math-compare a (nth 3 b))) 1)
1690 0)
1691 ((and (= res2 0)
1692 (or (/= (nth 1 b) 1)
1693 (Math-lessp (nth 2 b) (nth 3 b))))
1694 (if (memq (nth 1 b) '(1 3)) 1 0))
1695 ((/= res 1)
1696 nil)
1697 ((/= res2 -1)
1698 nil)
1699 (t 1))))
1700 (and (Math-equal a b)
1701 1)
1702 (and (math-constp a) (math-constp b)
1703 0)
1704 (list 'calcFunc-in a b)))
1705
1706 (defun calcFunc-typeof (a)
1707 (cond ((Math-integerp a) 1)
1708 ((eq (car a) 'frac) 2)
1709 ((eq (car a) 'float) 3)
1710 ((eq (car a) 'hms) 4)
1711 ((eq (car a) 'cplx) 5)
1712 ((eq (car a) 'polar) 6)
1713 ((eq (car a) 'sdev) 7)
1714 ((eq (car a) 'intv) 8)
1715 ((eq (car a) 'mod) 9)
1716 ((eq (car a) 'date) (if (Math-integerp (nth 1 a)) 10 11))
1717 ((eq (car a) 'var)
1718 (if (memq (nth 2 a) '(var-inf var-uinf var-nan)) 12 100))
1719 ((eq (car a) 'vec) (if (math-matrixp a) 102 101))
1720 (t (math-calcFunc-to-var (car a)))))
1721
1722 (defun calcFunc-integer (a)
1723 (if (Math-integerp a)
1724 1
1725 (if (Math-objvecp a)
1726 0
1727 (list 'calcFunc-integer a))))
1728
1729 (defun calcFunc-real (a)
1730 (if (Math-realp a)
1731 1
1732 (if (Math-objvecp a)
1733 0
1734 (list 'calcFunc-real a))))
1735
1736 (defun calcFunc-constant (a)
1737 (if (math-constp a)
1738 1
1739 (if (Math-objvecp a)
1740 0
1741 (list 'calcFunc-constant a))))
1742
1743 (defun calcFunc-refers (a b)
1744 (if (math-expr-contains a b)
1745 1
1746 (if (eq (car-safe a) 'var)
1747 (list 'calcFunc-refers a b)
1748 0)))
1749
1750 (defun calcFunc-negative (a)
1751 (if (math-looks-negp a)
1752 1
1753 (if (or (math-zerop a)
1754 (math-posp a))
1755 0
1756 (list 'calcFunc-negative a))))
1757
1758 (defun calcFunc-variable (a)
1759 (if (eq (car-safe a) 'var)
1760 1
1761 (if (Math-objvecp a)
1762 0
1763 (list 'calcFunc-variable a))))
1764
1765 (defun calcFunc-nonvar (a)
1766 (if (eq (car-safe a) 'var)
1767 (list 'calcFunc-nonvar a)
1768 1))
1769
1770 (defun calcFunc-istrue (a)
1771 (if (math-is-true a)
1772 1
1773 0))
1774
1775
1776
1777 ;;;; User-programmability.
1778
1779 ;;; Compiling Lisp-like forms to use the math library.
1780
1781 (defun math-do-defmath (func args body)
1782 (require 'calc-macs)
1783 (let* ((fname (intern (concat "calcFunc-" (symbol-name func))))
1784 (doc (if (stringp (car body)) (list (car body))))
1785 (clargs (mapcar 'math-clean-arg args))
1786 (body (math-define-function-body
1787 (if (stringp (car body)) (cdr body) body)
1788 clargs)))
1789 (list 'progn
1790 (if (and (consp (car body))
1791 (eq (car (car body)) 'interactive))
1792 (let ((inter (car body)))
1793 (setq body (cdr body))
1794 (if (or (> (length inter) 2)
1795 (integerp (nth 1 inter)))
1796 (let ((hasprefix nil) (hasmulti nil))
1797 (if (stringp (nth 1 inter))
1798 (progn
1799 (cond ((equal (nth 1 inter) "p")
1800 (setq hasprefix t))
1801 ((equal (nth 1 inter) "m")
1802 (setq hasmulti t))
1803 (t (error
1804 "Can't handle interactive code string \"%s\""
1805 (nth 1 inter))))
1806 (setq inter (cdr inter))))
1807 (if (not (integerp (nth 1 inter)))
1808 (error
1809 "Expected an integer in interactive specification"))
1810 (append (list 'defun
1811 (intern (concat "calc-"
1812 (symbol-name func)))
1813 (if (or hasprefix hasmulti)
1814 '(&optional n)
1815 ()))
1816 doc
1817 (if (or hasprefix hasmulti)
1818 '((interactive "P"))
1819 '((interactive)))
1820 (list
1821 (append
1822 '(calc-slow-wrapper)
1823 (and hasmulti
1824 (list
1825 (list 'setq
1826 'n
1827 (list 'if
1828 'n
1829 (list 'prefix-numeric-value
1830 'n)
1831 (nth 1 inter)))))
1832 (list
1833 (list 'calc-enter-result
1834 (if hasmulti 'n (nth 1 inter))
1835 (nth 2 inter)
1836 (if hasprefix
1837 (list 'append
1838 (list 'quote (list fname))
1839 (list 'calc-top-list-n
1840 (nth 1 inter))
1841 (list 'and
1842 'n
1843 (list
1844 'list
1845 (list
1846 'math-normalize
1847 (list
1848 'prefix-numeric-value
1849 'n)))))
1850 (list 'cons
1851 (list 'quote fname)
1852 (list 'calc-top-list-n
1853 (if hasmulti
1854 'n
1855 (nth 1 inter)))))))))))
1856 (append (list 'defun
1857 (intern (concat "calc-" (symbol-name func)))
1858 args)
1859 doc
1860 (list
1861 inter
1862 (cons 'calc-wrapper body))))))
1863 (append (list 'defun fname clargs)
1864 doc
1865 (math-do-arg-list-check args nil nil)
1866 body))))
1867
1868 (defun math-clean-arg (arg)
1869 (if (consp arg)
1870 (math-clean-arg (nth 1 arg))
1871 arg))
1872
1873 (defun math-do-arg-check (arg var is-opt is-rest)
1874 (if is-opt
1875 (let ((chk (math-do-arg-check arg var nil nil)))
1876 (list (cons 'and
1877 (cons var
1878 (if (cdr chk)
1879 (setq chk (list (cons 'progn chk)))
1880 chk)))))
1881 (and (consp arg)
1882 (let* ((rest (math-do-arg-check (nth 1 arg) var is-opt is-rest))
1883 (qual (car arg))
1884 (qqual (list 'quote qual))
1885 (qual-name (symbol-name qual))
1886 (chk (intern (concat "math-check-" qual-name))))
1887 (if (fboundp chk)
1888 (append rest
1889 (list
1890 (if is-rest
1891 (list 'setq var
1892 (list 'mapcar (list 'quote chk) var))
1893 (list 'setq var (list chk var)))))
1894 (if (fboundp (setq chk (intern (concat "math-" qual-name))))
1895 (append rest
1896 (list
1897 (if is-rest
1898 (list 'mapcar
1899 (list 'function
1900 (list 'lambda '(x)
1901 (list 'or
1902 (list chk 'x)
1903 (list 'math-reject-arg
1904 'x qqual))))
1905 var)
1906 (list 'or
1907 (list chk var)
1908 (list 'math-reject-arg var qqual)))))
1909 (if (and (string-match "\\`not-\\(.*\\)\\'" qual-name)
1910 (fboundp (setq chk (intern
1911 (concat "math-"
1912 (math-match-substring
1913 qual-name 1))))))
1914 (append rest
1915 (list
1916 (if is-rest
1917 (list 'mapcar
1918 (list 'function
1919 (list 'lambda '(x)
1920 (list 'and
1921 (list chk 'x)
1922 (list 'math-reject-arg
1923 'x qqual))))
1924 var)
1925 (list 'and
1926 (list chk var)
1927 (list 'math-reject-arg var qqual)))))
1928 (error "Unknown qualifier `%s'" qual-name))))))))
1929
1930 (defun math-do-arg-list-check (args is-opt is-rest)
1931 (cond ((null args) nil)
1932 ((consp (car args))
1933 (append (math-do-arg-check (car args)
1934 (math-clean-arg (car args))
1935 is-opt is-rest)
1936 (math-do-arg-list-check (cdr args) is-opt is-rest)))
1937 ((eq (car args) '&optional)
1938 (math-do-arg-list-check (cdr args) t nil))
1939 ((eq (car args) '&rest)
1940 (math-do-arg-list-check (cdr args) nil t))
1941 (t (math-do-arg-list-check (cdr args) is-opt is-rest))))
1942
1943 (defconst math-prim-funcs
1944 '( (~= . math-nearly-equal)
1945 (% . math-mod)
1946 (lsh . calcFunc-lsh)
1947 (ash . calcFunc-ash)
1948 (logand . calcFunc-and)
1949 (logandc2 . calcFunc-diff)
1950 (logior . calcFunc-or)
1951 (logxor . calcFunc-xor)
1952 (lognot . calcFunc-not)
1953 (equal . equal) ; need to leave these ones alone!
1954 (eq . eq)
1955 (and . and)
1956 (or . or)
1957 (if . if)
1958 (^ . math-pow)
1959 (expt . math-pow)
1960 ))
1961
1962 (defconst math-prim-vars
1963 '( (nil . nil)
1964 (t . t)
1965 (&optional . &optional)
1966 (&rest . &rest)
1967 ))
1968
1969 (defun math-define-function-body (body env)
1970 (let ((body (math-define-body body env)))
1971 (if (math-body-refers-to body 'math-return)
1972 (list (cons 'catch (cons '(quote math-return) body)))
1973 body)))
1974
1975 ;; The variable math-exp-env is local to math-define-body, but is
1976 ;; used by math-define-exp, which is called (indirectly) by
1977 ;; by math-define-body.
1978 (defvar math-exp-env)
1979
1980 (defun math-define-body (body math-exp-env)
1981 (math-define-list body))
1982
1983 (defun math-define-list (body &optional quote)
1984 (cond ((null body)
1985 nil)
1986 ((and (eq (car body) ':)
1987 (stringp (nth 1 body)))
1988 (cons (let* ((math-read-expr-quotes t)
1989 (exp (math-read-plain-expr (nth 1 body) t)))
1990 (math-define-exp exp))
1991 (math-define-list (cdr (cdr body)))))
1992 (quote
1993 (cons (cond ((consp (car body))
1994 (math-define-list (cdr body) t))
1995 (t
1996 (car body)))
1997 (math-define-list (cdr body))))
1998 (t
1999 (cons (math-define-exp (car body))
2000 (math-define-list (cdr body))))))
2001
2002 (defun math-define-exp (exp)
2003 (cond ((consp exp)
2004 (let ((func (car exp)))
2005 (cond ((memq func '(quote function))
2006 (if (and (consp (nth 1 exp))
2007 (eq (car (nth 1 exp)) 'lambda))
2008 (cons 'quote
2009 (math-define-lambda (nth 1 exp) math-exp-env))
2010 exp))
2011 ((memq func '(let let* for foreach))
2012 (let ((head (nth 1 exp))
2013 (body (cdr (cdr exp))))
2014 (if (memq func '(let let*))
2015 ()
2016 (setq func (cdr (assq func '((for . math-for)
2017 (foreach . math-foreach)))))
2018 (if (not (listp (car head)))
2019 (setq head (list head))))
2020 (macroexpand
2021 (cons func
2022 (cons (math-define-let head)
2023 (math-define-body body
2024 (nconc
2025 (math-define-let-env head)
2026 math-exp-env)))))))
2027 ((and (memq func '(setq setf))
2028 (math-complicated-lhs (cdr exp)))
2029 (if (> (length exp) 3)
2030 (cons 'progn (math-define-setf-list (cdr exp)))
2031 (math-define-setf (nth 1 exp) (nth 2 exp))))
2032 ((eq func 'condition-case)
2033 (cons func
2034 (cons (nth 1 exp)
2035 (math-define-body (cdr (cdr exp))
2036 (cons (nth 1 exp)
2037 math-exp-env)))))
2038 ((eq func 'cond)
2039 (cons func
2040 (math-define-cond (cdr exp))))
2041 ((and (consp func) ; ('spam a b) == force use of plain spam
2042 (eq (car func) 'quote))
2043 (cons func (math-define-list (cdr exp))))
2044 ((symbolp func)
2045 (let ((args (math-define-list (cdr exp)))
2046 (prim (assq func math-prim-funcs)))
2047 (cond (prim
2048 (cons (cdr prim) args))
2049 ((eq func 'floatp)
2050 (list 'eq (car args) '(quote float)))
2051 ((eq func '+)
2052 (math-define-binop 'math-add 0
2053 (car args) (cdr args)))
2054 ((eq func '-)
2055 (if (= (length args) 1)
2056 (cons 'math-neg args)
2057 (math-define-binop 'math-sub 0
2058 (car args) (cdr args))))
2059 ((eq func '*)
2060 (math-define-binop 'math-mul 1
2061 (car args) (cdr args)))
2062 ((eq func '/)
2063 (math-define-binop 'math-div 1
2064 (car args) (cdr args)))
2065 ((eq func 'min)
2066 (math-define-binop 'math-min 0
2067 (car args) (cdr args)))
2068 ((eq func 'max)
2069 (math-define-binop 'math-max 0
2070 (car args) (cdr args)))
2071 ((eq func '<)
2072 (if (and (math-numberp (nth 1 args))
2073 (math-zerop (nth 1 args)))
2074 (list 'math-negp (car args))
2075 (cons 'math-lessp args)))
2076 ((eq func '>)
2077 (if (and (math-numberp (nth 1 args))
2078 (math-zerop (nth 1 args)))
2079 (list 'math-posp (car args))
2080 (list 'math-lessp (nth 1 args) (nth 0 args))))
2081 ((eq func '<=)
2082 (list 'not
2083 (if (and (math-numberp (nth 1 args))
2084 (math-zerop (nth 1 args)))
2085 (list 'math-posp (car args))
2086 (list 'math-lessp
2087 (nth 1 args) (nth 0 args)))))
2088 ((eq func '>=)
2089 (list 'not
2090 (if (and (math-numberp (nth 1 args))
2091 (math-zerop (nth 1 args)))
2092 (list 'math-negp (car args))
2093 (cons 'math-lessp args))))
2094 ((eq func '=)
2095 (if (and (math-numberp (nth 1 args))
2096 (math-zerop (nth 1 args)))
2097 (list 'math-zerop (nth 0 args))
2098 (if (and (integerp (nth 1 args))
2099 (/= (% (nth 1 args) 10) 0))
2100 (cons 'math-equal-int args)
2101 (cons 'math-equal args))))
2102 ((eq func '/=)
2103 (list 'not
2104 (if (and (math-numberp (nth 1 args))
2105 (math-zerop (nth 1 args)))
2106 (list 'math-zerop (nth 0 args))
2107 (if (and (integerp (nth 1 args))
2108 (/= (% (nth 1 args) 10) 0))
2109 (cons 'math-equal-int args)
2110 (cons 'math-equal args)))))
2111 ((eq func '1+)
2112 (list 'math-add (car args) 1))
2113 ((eq func '1-)
2114 (list 'math-add (car args) -1))
2115 ((eq func 'not) ; optimize (not (not x)) => x
2116 (if (eq (car-safe args) func)
2117 (car (nth 1 args))
2118 (cons func args)))
2119 ((and (eq func 'elt) (cdr (cdr args)))
2120 (math-define-elt (car args) (cdr args)))
2121 (t
2122 (macroexpand
2123 (let* ((name (symbol-name func))
2124 (cfunc (intern (concat "calcFunc-" name)))
2125 (mfunc (intern (concat "math-" name))))
2126 (cond ((fboundp cfunc)
2127 (cons cfunc args))
2128 ((fboundp mfunc)
2129 (cons mfunc args))
2130 ((or (fboundp func)
2131 (string-match "\\`calcFunc-.*" name))
2132 (cons func args))
2133 (t
2134 (cons cfunc args)))))))))
2135 (t (cons func (math-define-list (cdr exp))))))) ;;args
2136 ((symbolp exp)
2137 (let ((prim (assq exp math-prim-vars))
2138 (name (symbol-name exp)))
2139 (cond (prim
2140 (cdr prim))
2141 ((memq exp math-exp-env)
2142 exp)
2143 ((string-match "-" name)
2144 exp)
2145 (t
2146 (intern (concat "var-" name))))))
2147 ((integerp exp)
2148 (if (or (<= exp -1000000) (>= exp 1000000))
2149 (list 'quote (math-normalize exp))
2150 exp))
2151 (t exp)))
2152
2153 (defun math-define-cond (forms)
2154 (and forms
2155 (cons (math-define-list (car forms))
2156 (math-define-cond (cdr forms)))))
2157
2158 (defun math-complicated-lhs (body)
2159 (and body
2160 (or (not (symbolp (car body)))
2161 (math-complicated-lhs (cdr (cdr body))))))
2162
2163 (defun math-define-setf-list (body)
2164 (and body
2165 (cons (math-define-setf (nth 0 body) (nth 1 body))
2166 (math-define-setf-list (cdr (cdr body))))))
2167
2168 (defun math-define-setf (place value)
2169 (setq place (math-define-exp place)
2170 value (math-define-exp value))
2171 (cond ((symbolp place)
2172 (list 'setq place value))
2173 ((eq (car-safe place) 'nth)
2174 (list 'setcar (list 'nthcdr (nth 1 place) (nth 2 place)) value))
2175 ((eq (car-safe place) 'elt)
2176 (list 'setcar (list 'nthcdr (nth 2 place) (nth 1 place)) value))
2177 ((eq (car-safe place) 'car)
2178 (list 'setcar (nth 1 place) value))
2179 ((eq (car-safe place) 'cdr)
2180 (list 'setcdr (nth 1 place) value))
2181 (t
2182 (error "Bad place form for setf: %s" place))))
2183
2184 (defun math-define-binop (op ident arg1 rest)
2185 (if rest
2186 (math-define-binop op ident
2187 (list op arg1 (car rest))
2188 (cdr rest))
2189 (or arg1 ident)))
2190
2191 (defun math-define-let (vlist)
2192 (and vlist
2193 (cons (if (consp (car vlist))
2194 (cons (car (car vlist))
2195 (math-define-list (cdr (car vlist))))
2196 (car vlist))
2197 (math-define-let (cdr vlist)))))
2198
2199 (defun math-define-let-env (vlist)
2200 (and vlist
2201 (cons (if (consp (car vlist))
2202 (car (car vlist))
2203 (car vlist))
2204 (math-define-let-env (cdr vlist)))))
2205
2206 (defun math-define-lambda (exp exp-env)
2207 (nconc (list (nth 0 exp) ; 'lambda
2208 (nth 1 exp)) ; arg list
2209 (math-define-function-body (cdr (cdr exp))
2210 (append (nth 1 exp) exp-env))))
2211
2212 (defun math-define-elt (seq idx)
2213 (if idx
2214 (math-define-elt (list 'elt seq (car idx)) (cdr idx))
2215 seq))
2216
2217
2218
2219 ;;; Useful programming macros.
2220
2221 (defmacro math-while (head &rest body)
2222 (let ((body (cons 'while (cons head body))))
2223 (if (math-body-refers-to body 'math-break)
2224 (cons 'catch (cons '(quote math-break) (list body)))
2225 body)))
2226 ;; (put 'math-while 'lisp-indent-hook 1)
2227
2228 (defmacro math-for (head &rest body)
2229 (let ((body (if head
2230 (math-handle-for head body)
2231 (cons 'while (cons t body)))))
2232 (if (math-body-refers-to body 'math-break)
2233 (cons 'catch (cons '(quote math-break) (list body)))
2234 body)))
2235 ;; (put 'math-for 'lisp-indent-hook 1)
2236
2237 (defun math-handle-for (head body)
2238 (let* ((var (nth 0 (car head)))
2239 (init (nth 1 (car head)))
2240 (limit (nth 2 (car head)))
2241 (step (or (nth 3 (car head)) 1))
2242 (body (if (cdr head)
2243 (list (math-handle-for (cdr head) body))
2244 body))
2245 (all-ints (and (integerp init) (integerp limit) (integerp step)))
2246 (const-limit (or (integerp limit)
2247 (and (eq (car-safe limit) 'quote)
2248 (math-realp (nth 1 limit)))))
2249 (const-step (or (integerp step)
2250 (and (eq (car-safe step) 'quote)
2251 (math-realp (nth 1 step)))))
2252 (save-limit (if const-limit limit (make-symbol "<limit>")))
2253 (save-step (if const-step step (make-symbol "<step>"))))
2254 (cons 'let
2255 (cons (append (if const-limit nil (list (list save-limit limit)))
2256 (if const-step nil (list (list save-step step)))
2257 (list (list var init)))
2258 (list
2259 (cons 'while
2260 (cons (if all-ints
2261 (if (> step 0)
2262 (list '<= var save-limit)
2263 (list '>= var save-limit))
2264 (list 'not
2265 (if const-step
2266 (if (or (math-posp step)
2267 (math-posp
2268 (cdr-safe step)))
2269 (list 'math-lessp
2270 save-limit
2271 var)
2272 (list 'math-lessp
2273 var
2274 save-limit))
2275 (list 'if
2276 (list 'math-posp
2277 save-step)
2278 (list 'math-lessp
2279 save-limit
2280 var)
2281 (list 'math-lessp
2282 var
2283 save-limit)))))
2284 (append body
2285 (list (list 'setq
2286 var
2287 (list (if all-ints
2288 '+
2289 'math-add)
2290 var
2291 save-step)))))))))))
2292
2293 (defmacro math-foreach (head &rest body)
2294 (let ((body (math-handle-foreach head body)))
2295 (if (math-body-refers-to body 'math-break)
2296 (cons 'catch (cons '(quote math-break) (list body)))
2297 body)))
2298 ;; (put 'math-foreach 'lisp-indent-hook 1)
2299
2300 (defun math-handle-foreach (head body)
2301 (let ((var (nth 0 (car head)))
2302 (data (nth 1 (car head)))
2303 (body (if (cdr head)
2304 (list (math-handle-foreach (cdr head) body))
2305 body)))
2306 (cons 'let
2307 (cons (list (list var data))
2308 (list
2309 (cons 'while
2310 (cons var
2311 (append body
2312 (list (list 'setq
2313 var
2314 (list 'cdr var)))))))))))
2315
2316
2317 (defun math-body-refers-to (body thing)
2318 (or (equal body thing)
2319 (and (consp body)
2320 (or (math-body-refers-to (car body) thing)
2321 (math-body-refers-to (cdr body) thing)))))
2322
2323 (defun math-break (&optional value)
2324 (throw 'math-break value))
2325
2326 (defun math-return (&optional value)
2327 (throw 'math-return value))
2328
2329
2330
2331
2332
2333 (defun math-composite-inequalities (x op)
2334 (if (memq (nth 1 op) '(calcFunc-eq calcFunc-neq))
2335 (if (eq (car x) (nth 1 op))
2336 (append x (list (math-read-expr-level (nth 3 op))))
2337 (throw 'syntax "Syntax error"))
2338 (list 'calcFunc-in
2339 (nth 2 x)
2340 (if (memq (nth 1 op) '(calcFunc-lt calcFunc-leq))
2341 (if (memq (car x) '(calcFunc-lt calcFunc-leq))
2342 (math-make-intv
2343 (+ (if (eq (car x) 'calcFunc-leq) 2 0)
2344 (if (eq (nth 1 op) 'calcFunc-leq) 1 0))
2345 (nth 1 x) (math-read-expr-level (nth 3 op)))
2346 (throw 'syntax "Syntax error"))
2347 (if (memq (car x) '(calcFunc-gt calcFunc-geq))
2348 (math-make-intv
2349 (+ (if (eq (nth 1 op) 'calcFunc-geq) 2 0)
2350 (if (eq (car x) 'calcFunc-geq) 1 0))
2351 (math-read-expr-level (nth 3 op)) (nth 1 x))
2352 (throw 'syntax "Syntax error"))))))
2353
2354 (provide 'calc-prog)
2355
2356 ;;; arch-tag: 4c5a183b-c9e5-4632-bb3f-e41a764518b0
2357 ;;; calc-prog.el ends here
Unnamed repository; edit this file 'description' to name the repository.