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