/[emacs]/emacs/lisp/calc/calc-prog.el
ViewVC logotype

Diff of /emacs/lisp/calc/calc-prog.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.2 by eliz, Tue Nov 13 07:30:04 2001 UTC revision 1.3 by walters, Wed Nov 14 09:06:43 2001 UTC
# Line 34  Line 34 
34    (calc-wrapper    (calc-wrapper
35     (if (and (integerp arg) (> arg 2))     (if (and (integerp arg) (> arg 2))
36         (calc-enter-result arg "eq" (cons 'calcFunc-eq (calc-top-list-n arg)))         (calc-enter-result arg "eq" (cons 'calcFunc-eq (calc-top-list-n arg)))
37       (calc-binary-op "eq" 'calcFunc-eq arg)))       (calc-binary-op "eq" 'calcFunc-eq arg))))
 )  
38    
39  (defun calc-remove-equal (arg)  (defun calc-remove-equal (arg)
40    (interactive "P")    (interactive "P")
41    (calc-wrapper    (calc-wrapper
42     (calc-unary-op "rmeq" 'calcFunc-rmeq arg))     (calc-unary-op "rmeq" 'calcFunc-rmeq arg)))
 )  
43    
44  (defun calc-not-equal-to (arg)  (defun calc-not-equal-to (arg)
45    (interactive "P")    (interactive "P")
46    (calc-wrapper    (calc-wrapper
47     (if (and (integerp arg) (> arg 2))     (if (and (integerp arg) (> arg 2))
48         (calc-enter-result arg "neq" (cons 'calcFunc-neq (calc-top-list-n arg)))         (calc-enter-result arg "neq" (cons 'calcFunc-neq (calc-top-list-n arg)))
49       (calc-binary-op "neq" 'calcFunc-neq arg)))       (calc-binary-op "neq" 'calcFunc-neq arg))))
 )  
50    
51  (defun calc-less-than (arg)  (defun calc-less-than (arg)
52    (interactive "P")    (interactive "P")
53    (calc-wrapper    (calc-wrapper
54     (calc-binary-op "lt" 'calcFunc-lt arg))     (calc-binary-op "lt" 'calcFunc-lt arg)))
 )  
55    
56  (defun calc-greater-than (arg)  (defun calc-greater-than (arg)
57    (interactive "P")    (interactive "P")
58    (calc-wrapper    (calc-wrapper
59     (calc-binary-op "gt" 'calcFunc-gt arg))     (calc-binary-op "gt" 'calcFunc-gt arg)))
 )  
60    
61  (defun calc-less-equal (arg)  (defun calc-less-equal (arg)
62    (interactive "P")    (interactive "P")
63    (calc-wrapper    (calc-wrapper
64     (calc-binary-op "leq" 'calcFunc-leq arg))     (calc-binary-op "leq" 'calcFunc-leq arg)))
 )  
65    
66  (defun calc-greater-equal (arg)  (defun calc-greater-equal (arg)
67    (interactive "P")    (interactive "P")
68    (calc-wrapper    (calc-wrapper
69     (calc-binary-op "geq" 'calcFunc-geq arg))     (calc-binary-op "geq" 'calcFunc-geq arg)))
 )  
70    
71  (defun calc-in-set (arg)  (defun calc-in-set (arg)
72    (interactive "P")    (interactive "P")
73    (calc-wrapper    (calc-wrapper
74     (calc-binary-op "in" 'calcFunc-in arg))     (calc-binary-op "in" 'calcFunc-in arg)))
 )  
75    
76  (defun calc-logical-and (arg)  (defun calc-logical-and (arg)
77    (interactive "P")    (interactive "P")
78    (calc-wrapper    (calc-wrapper
79     (calc-binary-op "land" 'calcFunc-land arg 1))     (calc-binary-op "land" 'calcFunc-land arg 1)))
 )  
80    
81  (defun calc-logical-or (arg)  (defun calc-logical-or (arg)
82    (interactive "P")    (interactive "P")
83    (calc-wrapper    (calc-wrapper
84     (calc-binary-op "lor" 'calcFunc-lor arg 0))     (calc-binary-op "lor" 'calcFunc-lor arg 0)))
 )  
85    
86  (defun calc-logical-not (arg)  (defun calc-logical-not (arg)
87    (interactive "P")    (interactive "P")
88    (calc-wrapper    (calc-wrapper
89     (calc-unary-op "lnot" 'calcFunc-lnot arg))     (calc-unary-op "lnot" 'calcFunc-lnot arg)))
 )  
90    
91  (defun calc-logical-if ()  (defun calc-logical-if ()
92    (interactive)    (interactive)
93    (calc-wrapper    (calc-wrapper
94     (calc-enter-result 3 "if" (cons 'calcFunc-if (calc-top-list-n 3))))     (calc-enter-result 3 "if" (cons 'calcFunc-if (calc-top-list-n 3)))))
 )  
95    
96    
97    
# Line 115  Line 103 
103     (calc-change-mode 'calc-timing n nil t)     (calc-change-mode 'calc-timing n nil t)
104     (message (if calc-timing     (message (if calc-timing
105                  "Reporting timing of slow commands in Trail."                  "Reporting timing of slow commands in Trail."
106                "Not reporting timing of commands.")))                "Not reporting timing of commands."))))
 )  
107    
108  (defun calc-pass-errors ()  (defun calc-pass-errors ()
109    (interactive)    (interactive)
# Line 129  Line 116 
116          (or (memq (car (car place)) '(error xxxerror))          (or (memq (car (car place)) '(error xxxerror))
117              (error "foo"))              (error "foo"))
118          (setcar (car place) 'xxxerror))          (setcar (car place) 'xxxerror))
119      (error (error "The calc-do function has been modified; unable to patch.")))      (error (error "The calc-do function has been modified; unable to patch."))))
 )  
120    
121  (defun calc-user-define ()  (defun calc-user-define ()
122    (interactive)    (interactive)
# Line 149  Line 135 
135               (old (assq key kmap)))               (old (assq key kmap)))
136          (if old          (if old
137              (setcdr old func)              (setcdr old func)
138            (setcdr kmap (cons (cons key func) (cdr kmap)))))))            (setcdr kmap (cons (cons key func) (cdr kmap))))))))
 )  
139    
140  (defun calc-user-undefine ()  (defun calc-user-undefine ()
141    (interactive)    (interactive)
# Line 163  Line 148 
148                  (assq (upcase key) kmap)                  (assq (upcase key) kmap)
149                  (assq (downcase key) kmap)                  (assq (downcase key) kmap)
150                  (error "No such user key is defined"))                  (error "No such user key is defined"))
151              kmap)))              kmap))))
 )  
152    
153  (defun calc-user-define-formula ()  (defun calc-user-define-formula ()
154    (interactive)    (interactive)
# Line 304  Line 288 
288             (if old             (if old
289                 (setcdr old cmd)                 (setcdr old cmd)
290               (setcdr kmap (cons (cons key cmd) (cdr kmap)))))))               (setcdr kmap (cons (cons key cmd) (cdr kmap)))))))
291     (message ""))     (message "")))
 )  
292    
293  (defun calc-default-formula-arglist (form)  (defun calc-default-formula-arglist (form)
294    (if (consp form)    (if (consp form)
# Line 314  Line 297 
297                    (math-const-var form))                    (math-const-var form))
298                ()                ()
299              (setq arglist (cons (nth 1 form) arglist)))              (setq arglist (cons (nth 1 form) arglist)))
300          (calc-default-formula-arglist-step (cdr form))))          (calc-default-formula-arglist-step (cdr form)))))
 )  
301    
302  (defun calc-default-formula-arglist-step (l)  (defun calc-default-formula-arglist-step (l)
303    (and l    (and l
304         (progn         (progn
305           (calc-default-formula-arglist (car l))           (calc-default-formula-arglist (car l))
306           (calc-default-formula-arglist-step (cdr l))))           (calc-default-formula-arglist-step (cdr l)))))
 )  
307    
308  (defun calc-subsetp (a b)  (defun calc-subsetp (a b)
309    (or (null a)    (or (null a)
310        (and (memq (car a) b)        (and (memq (car a) b)
311             (calc-subsetp (cdr a) b)))             (calc-subsetp (cdr a) b))))
 )  
312    
313  (defun calc-fix-user-formula (f)  (defun calc-fix-user-formula (f)
314    (if (consp f)    (if (consp f)
# Line 356  Line 336 
336                 (cons 'list                 (cons 'list
337                       (cons (list 'quote (car f))                       (cons (list 'quote (car f))
338                             (mapcar 'calc-fix-user-formula (cdr f)))))))                             (mapcar 'calc-fix-user-formula (cdr f)))))))
339      f)      f))
 )  
340    
341  (defun calc-user-define-composition ()  (defun calc-user-define-composition ()
342    (interactive)    (interactive)
# Line 395  Line 374 
374                     (cons (setq entry2 (list (length alist))) (cdr entry))))                     (cons (setq entry2 (list (length alist))) (cdr entry))))
375         (setcdr entry2 (list 'lambda alist (calc-fix-user-formula comp))))         (setcdr entry2 (list 'lambda alist (calc-fix-user-formula comp))))
376       (calc-pop-stack 1)       (calc-pop-stack 1)
377       (calc-do-refresh)))       (calc-do-refresh))))
 )  
378    
379    
380  (defun calc-user-define-kbd-macro (arg)  (defun calc-user-define-kbd-macro (arg)
# Line 443  Line 421 
421               (old (assq key kmap)))               (old (assq key kmap)))
422          (if old          (if old
423              (setcdr old cmd)              (setcdr old cmd)
424            (setcdr kmap (cons (cons key cmd) (cdr kmap)))))))            (setcdr kmap (cons (cons key cmd) (cdr kmap))))))))
 )  
425    
426    
427  (defun calc-edit-user-syntax ()  (defun calc-edit-user-syntax ()
# Line 459  Line 436 
436                                     (t (capitalize (symbol-name lang))))))                                     (t (capitalize (symbol-name lang))))))
437       (calc-write-parse-table (cdr (assq lang calc-user-parse-tables))       (calc-write-parse-table (cdr (assq lang calc-user-parse-tables))
438                               lang)))                               lang)))
439    (calc-show-edit-buffer)    (calc-show-edit-buffer))
 )  
440    
441  (defun calc-finish-user-syntax-edit (lang)  (defun calc-finish-user-syntax-edit (lang)
442    (let ((tab (calc-read-parse-table calc-original-buffer lang))    (let ((tab (calc-read-parse-table calc-original-buffer lang))
# Line 473  Line 449 
449        (if entry        (if entry
450            (setq calc-user-parse-tables            (setq calc-user-parse-tables
451                  (delq entry calc-user-parse-tables)))))                  (delq entry calc-user-parse-tables)))))
452    (switch-to-buffer calc-original-buffer)    (switch-to-buffer calc-original-buffer))
 )  
453    
454  (defun calc-write-parse-table (tab calc-lang)  (defun calc-write-parse-table (tab calc-lang)
455    (let ((p tab))    (let ((p tab))
# Line 484  Line 459 
459                (let ((math-format-hash-args t))                (let ((math-format-hash-args t))
460                  (math-format-flat-expr (cdr (car p)) 0))                  (math-format-flat-expr (cdr (car p)) 0))
461                "\n")                "\n")
462        (setq p (cdr p))))        (setq p (cdr p)))))
 )  
463    
464  (defun calc-write-parse-table-part (p)  (defun calc-write-parse-table-part (p)
465    (while p    (while p
# Line 515  Line 489 
489             (if (nth 2 (car p))             (if (nth 2 (car p))
490                 (calc-write-parse-table-part (list (car (nth 2 (car p)))))                 (calc-write-parse-table-part (list (car (nth 2 (car p)))))
491               (insert " "))))               (insert " "))))
492      (setq p (cdr p)))      (setq p (cdr p))))
 )  
493    
494  (defun calc-read-parse-table (calc-buf calc-lang)  (defun calc-read-parse-table (calc-buf calc-lang)
495    (let ((tab nil))    (let ((tab nil))
# Line 551  Line 524 
524                      (goto-char (+ pos (nth 1 exp)))                      (goto-char (+ pos (nth 1 exp)))
525                      (error (nth 2 exp))))                      (error (nth 2 exp))))
526                (setq tab (nconc tab (list (cons p exp)))))))))                (setq tab (nconc tab (list (cons p exp)))))))))
527      tab)      tab))
 )  
528    
529  (defun calc-fix-token-name (name &optional unquoted)  (defun calc-fix-token-name (name &optional unquoted)
530    (cond ((string-match "\\`\\.\\." name)    (cond ((string-match "\\`\\.\\." name)
# Line 571  Line 543 
543          ((not (string-match "[^ ]" name))          ((not (string-match "[^ ]" name))
544           (search-backward "\"" nil t)           (search-backward "\"" nil t)
545           (error "Blank tokens are not allowed"))           (error "Blank tokens are not allowed"))
546          (t name))          (t name)))
 )  
547    
548  (defun calc-read-parse-table-part (term eterm)  (defun calc-read-parse-table-part (term eterm)
549    (let ((part nil)    (let ((part nil)
# Line 634  Line 605 
605                           (not (eq (car last) quoted))                           (not (eq (car last) quoted))
606                           (setcar last                           (setcar last
607                                   (list '\? (list (car last)) '("$$"))))))))                                   (list '\? (list (car last)) '("$$"))))))))
608      part)      part))
 )  
609    
610    
611  (defun calc-user-define-invocation ()  (defun calc-user-define-invocation ()
# Line 643  Line 613 
613    (or last-kbd-macro    (or last-kbd-macro
614        (error "No keyboard macro defined"))        (error "No keyboard macro defined"))
615    (setq calc-invocation-macro last-kbd-macro)    (setq calc-invocation-macro last-kbd-macro)
616    (message "Use `M-# Z' to invoke this macro")    (message "Use `M-# Z' to invoke this macro"))
 )  
617    
618    
619  (defun calc-user-define-edit (prefix)  (defun calc-user-define-edit (prefix)
# Line 746  Line 715 
715                                 (math-format-nice-expr defn (frame-width)))                                 (math-format-nice-expr defn (frame-width)))
716                                "\n"))                                "\n"))
717                       (calc-show-edit-buffer))                       (calc-show-edit-buffer))
718                   (error "That command's definition cannot be edited"))))))                   (error "That command's definition cannot be edited")))))))
 )  
719    
720  (defun calc-finish-macro-edit (def keys)  (defun calc-finish-macro-edit (def keys)
721    (forward-line 1)    (forward-line 1)
# Line 764  Line 732 
732                    (aset (car mac) 0 (if keys true-str (key-description str)))                    (aset (car mac) 0 (if keys true-str (key-description str)))
733                    (aset (car mac) 1 str))                    (aset (car mac) 1 str))
734                (setcar mac str))))                (setcar mac str))))
735        (setcdr def str)))        (setcdr def str))))
 )  
736    
737  ;;; The following are hooks into the MacEdit package from macedit.el.  ;;; The following are hooks into the MacEdit package from macedit.el.
738  (put 'calc-execute-extended-command 'MacEdit-print  (put 'calc-execute-extended-command 'MacEdit-print
739       (function (lambda ()       (function (lambda ()
740                   (setq macro-str (concat "\excalc-" macro-str))))                   (setq macro-str (concat "\excalc-" macro-str)))))
 )  
741    
742  (put 'calcDigit-start 'MacEdit-print  (put 'calcDigit-start 'MacEdit-print
743       (function (lambda ()       (function (lambda ()
# Line 809  Line 775 
775                         (MacEdit-unread-chars ch))                         (MacEdit-unread-chars ch))
776                       (insert "type \"")                       (insert "type \"")
777                       (MacEdit-insert-string str)                       (MacEdit-insert-string str)
778                       (insert "\"\n")))))                       (insert "\"\n"))))))
 )  
779    
780  (defun calc-macro-edit-algebraic ()  (defun calc-macro-edit-algebraic ()
781    (MacEdit-unread-chars key-last)    (MacEdit-unread-chars key-last)
# Line 842  Line 807 
807          (progn          (progn
808            (insert "type \"")            (insert "type \"")
809            (MacEdit-insert-string str)            (MacEdit-insert-string str)
810            (insert "\"\n"))))            (insert "\"\n")))))
 )  
811  (put 'calc-algebraic-entry 'MacEdit-print 'calc-macro-edit-algebraic)  (put 'calc-algebraic-entry 'MacEdit-print 'calc-macro-edit-algebraic)
812  (put 'calc-auto-algebraic-entry 'MacEdit-print 'calc-macro-edit-algebraic)  (put 'calc-auto-algebraic-entry 'MacEdit-print 'calc-macro-edit-algebraic)
813    
# Line 858  Line 822 
822                  (char-to-string (MacEdit-read-char)) "\"\n")                  (char-to-string (MacEdit-read-char)) "\"\n")
823        (if (> (length str) 0)        (if (> (length str) 0)
824            (insert "type \"" str "\"\n"))            (insert "type \"" str "\"\n"))
825        (MacEdit-read-argument)))        (MacEdit-read-argument))))
 )  
826  (put 'calc-store 'MacEdit-print 'calc-macro-edit-variable)  (put 'calc-store 'MacEdit-print 'calc-macro-edit-variable)
827  (put 'calc-store-into 'MacEdit-print 'calc-macro-edit-variable)  (put 'calc-store-into 'MacEdit-print 'calc-macro-edit-variable)
828  (put 'calc-store-neg 'MacEdit-print 'calc-macro-edit-variable)  (put 'calc-store-neg 'MacEdit-print 'calc-macro-edit-variable)
# Line 880  Line 843 
843    
844  (defun calc-macro-edit-variable-2 ()  (defun calc-macro-edit-variable-2 ()
845    (calc-macro-edit-variable)    (calc-macro-edit-variable)
846    (calc-macro-edit-variable t)    (calc-macro-edit-variable t))
 )  
847  (put 'calc-copy-variable 'MacEdit-print 'calc-macro-edit-variable-2)  (put 'calc-copy-variable 'MacEdit-print 'calc-macro-edit-variable-2)
848  (put 'calc-declare-variable 'MacEdit-print 'calc-macro-edit-variable-2)  (put 'calc-declare-variable 'MacEdit-print 'calc-macro-edit-variable-2)
849    
850  (defun calc-macro-edit-quick-digit ()  (defun calc-macro-edit-quick-digit ()
851    (insert "type \"" key-str "\"  # " (symbol-name key-symbol) "\n")    (insert "type \"" key-str "\"  # " (symbol-name key-symbol) "\n"))
 )  
852  (put 'calc-store-quick 'MacEdit-print 'calc-macro-edit-quick-digit)  (put 'calc-store-quick 'MacEdit-print 'calc-macro-edit-quick-digit)
853  (put 'calc-store-into-quick 'MacEdit-print 'calc-macro-edit-quick-digit)  (put 'calc-store-into-quick 'MacEdit-print 'calc-macro-edit-quick-digit)
854  (put 'calc-recall-quick 'MacEdit-print 'calc-macro-edit-quick-digit)  (put 'calc-recall-quick 'MacEdit-print 'calc-macro-edit-quick-digit)
# Line 910  Line 871 
871        (setcar (cdr body)        (setcar (cdr body)
872                (let ((alist (nth 1 (symbol-function func))))                (let ((alist (nth 1 (symbol-function func))))
873                  (calc-fix-user-formula val)))                  (calc-fix-user-formula val)))
874        (put func 'calc-user-defn val)))        (put func 'calc-user-defn val))))
 )  
875    
876  (defun calc-valid-formula-func (func)  (defun calc-valid-formula-func (func)
877    (let ((def (symbol-function func)))    (let ((def (symbol-function func)))
# Line 922  Line 882 
882             (while (and def             (while (and def
883                         (not (eq (car (car def)) 'math-normalize)))                         (not (eq (car (car def)) 'math-normalize)))
884               (setq def (cdr def)))               (setq def (cdr def)))
885             (car def))))             (car def)))))
 )  
886    
887    
888  (defun calc-get-user-defn ()  (defun calc-get-user-defn ()
# Line 953  Line 912 
912                                                                func)))                                                                func)))
913                                                (list defn))))                                                (list defn))))
914                        (calc-enter-result 0 "gdef" defn))                        (calc-enter-result 0 "gdef" defn))
915                    (error "That command is not defined by a formula")))))))                    (error "That command is not defined by a formula"))))))))
 )  
916    
917    
918  (defun calc-user-define-permanent ()  (defun calc-user-define-permanent ()
# Line 1051  Line 1009 
1009                     (prin1-to-string cmd)                     (prin1-to-string cmd)
1010                     ")\n")))                     ")\n")))
1011       (insert "))\n")       (insert "))\n")
1012       (save-buffer)))       (save-buffer))))
 )  
1013    
1014  (defun calc-stack-command-p (cmd)  (defun calc-stack-command-p (cmd)
1015    (if (and cmd (symbolp cmd))    (if (and cmd (symbolp cmd))
# Line 1065  Line 1022 
1022           (setq cmd (assq 'calc-enter-result cmd))           (setq cmd (assq 'calc-enter-result cmd))
1023           (memq (car (nth 3 cmd)) '(cons list))           (memq (car (nth 3 cmd)) '(cons list))
1024           (eq (car (nth 1 (nth 3 cmd))) 'quote)           (eq (car (nth 1 (nth 3 cmd))) 'quote)
1025           (nth 1 (nth 1 (nth 3 cmd)))))           (nth 1 (nth 1 (nth 3 cmd))))))
 )  
1026    
1027    
1028  (defun calc-call-last-kbd-macro (arg)  (defun calc-call-last-kbd-macro (arg)
# Line 1075  Line 1031 
1031         (error "Can't execute anonymous macro while defining one"))         (error "Can't execute anonymous macro while defining one"))
1032    (or last-kbd-macro    (or last-kbd-macro
1033        (error "No kbd macro has been defined"))        (error "No kbd macro has been defined"))
1034    (calc-execute-kbd-macro last-kbd-macro arg)    (calc-execute-kbd-macro last-kbd-macro arg))
 )  
1035    
1036  (defun calc-execute-kbd-macro (mac arg &rest prefix)  (defun calc-execute-kbd-macro (mac arg &rest prefix)
1037    (if (and (vectorp mac) (> (length mac) 0) (stringp (aref mac 0)))    (if (and (vectorp mac) (> (length mac) 0) (stringp (aref mac 0)))
# Line 1127  Line 1082 
1082                   (calc-record-undo (list 'push 1))                   (calc-record-undo (list 'push 1))
1083                   (setq new-stack (cdr new-stack)))                   (setq new-stack (cdr new-stack)))
1084                 (calc-refresh))                 (calc-refresh))
1085               (calc-record-undo (list 'set 'saved-stack-top 0))))))))               (calc-record-undo (list 'set 'saved-stack-top 0)))))))))
 )  
1086    
1087  (defun calc-push-list-in-macro (vals m sels)  (defun calc-push-list-in-macro (vals m sels)
1088    (let ((entry (list (car vals) 1 (car sels)))    (let ((entry (list (car vals) 1 (car sels)))
# Line 1136  Line 1090 
1090      (if (> mm 1)      (if (> mm 1)
1091          (setcdr (nthcdr (- mm 2) calc-stack)          (setcdr (nthcdr (- mm 2) calc-stack)
1092                  (cons entry (nthcdr (1- mm) calc-stack)))                  (cons entry (nthcdr (1- mm) calc-stack)))
1093        (setq calc-stack (cons entry calc-stack))))        (setq calc-stack (cons entry calc-stack)))))
 )  
1094    
1095  (defun calc-pop-stack-in-macro (n mm)  (defun calc-pop-stack-in-macro (n mm)
1096    (if (> mm 1)    (if (> mm 1)
1097        (setcdr (nthcdr (- mm 2) calc-stack)        (setcdr (nthcdr (- mm 2) calc-stack)
1098                (nthcdr (+ n mm -1) calc-stack))                (nthcdr (+ n mm -1) calc-stack))
1099      (setq calc-stack (nthcdr n calc-stack)))      (setq calc-stack (nthcdr n calc-stack))))
 )  
1100    
1101    
1102  (defun calc-kbd-if ()  (defun calc-kbd-if ()
# Line 1157  Line 1109 
1109               (message "If true..."))               (message "If true..."))
1110         (if defining-kbd-macro         (if defining-kbd-macro
1111             (message "Condition is false; skipping to Z: or Z] ..."))             (message "Condition is false; skipping to Z: or Z] ..."))
1112         (calc-kbd-skip-to-else-if t))))         (calc-kbd-skip-to-else-if t)))))
 )  
1113    
1114  (defun calc-kbd-else-if ()  (defun calc-kbd-else-if ()
1115    (interactive)    (interactive)
1116    (calc-kbd-if)    (calc-kbd-if))
 )  
1117    
1118  (defun calc-kbd-skip-to-else-if (else-okay)  (defun calc-kbd-skip-to-else-if (else-okay)
1119    (let ((count 0)    (let ((count 0)
# Line 1188  Line 1138 
1138      (and defining-kbd-macro      (and defining-kbd-macro
1139           (if (= ch ?\:)           (if (= ch ?\:)
1140               (message "Else...")               (message "Else...")
1141             (message "End-if..."))))             (message "End-if...")))))
 )  
1142    
1143  (defun calc-kbd-end-if ()  (defun calc-kbd-end-if ()
1144    (interactive)    (interactive)
1145    (if defining-kbd-macro    (if defining-kbd-macro
1146        (message "End-if..."))        (message "End-if...")))
 )  
1147    
1148  (defun calc-kbd-else ()  (defun calc-kbd-else ()
1149    (interactive)    (interactive)
1150    (if defining-kbd-macro    (if defining-kbd-macro
1151        (message "Else; skipping to Z] ..."))        (message "Else; skipping to Z] ..."))
1152    (calc-kbd-skip-to-else-if nil)    (calc-kbd-skip-to-else-if nil))
 )  
1153    
1154    
1155  (defun calc-kbd-repeat ()  (defun calc-kbd-repeat ()
# Line 1217  Line 1164 
1164       (or (integerp count)       (or (integerp count)
1165           (setq count 1000000))           (setq count 1000000))
1166       (calc-pop-stack 1))       (calc-pop-stack 1))
1167      (calc-kbd-loop count))      (calc-kbd-loop count)))
 )  
1168    
1169  (defun calc-kbd-for (dir)  (defun calc-kbd-for (dir)
1170    (interactive "P")    (interactive "P")
# Line 1229  Line 1175 
1175       (or (and (math-anglep init) (math-anglep final))       (or (and (math-anglep init) (math-anglep final))
1176           (error "Initial and final values must be real numbers"))           (error "Initial and final values must be real numbers"))
1177       (calc-pop-stack 2))       (calc-pop-stack 2))
1178      (calc-kbd-loop nil init final (and dir (prefix-numeric-value dir))))      (calc-kbd-loop nil init final (and dir (prefix-numeric-value dir)))))
 )  
1179    
1180  (defun calc-kbd-loop (rpt-count &optional initial final dir)  (defun calc-kbd-loop (rpt-count &optional initial final dir)
1181    (interactive "P")    (interactive "P")
# Line 1301  Line 1246 
1246                       (setq counter (calcFunc-add counter step)))                       (setq counter (calcFunc-add counter step)))
1247                   (setq rpt-count (1- rpt-count))))))))                   (setq rpt-count (1- rpt-count))))))))
1248      (or executing-kbd-macro      (or executing-kbd-macro
1249          (message "Looping...done")))          (message "Looping...done"))))
 )  
1250    
1251  (defun calc-kbd-end-repeat ()  (defun calc-kbd-end-repeat ()
1252    (interactive)    (interactive)
1253    (error "Unbalanced Z> in keyboard macro")    (error "Unbalanced Z> in keyboard macro"))
 )  
1254    
1255  (defun calc-kbd-end-for ()  (defun calc-kbd-end-for ()
1256    (interactive)    (interactive)
1257    (error "Unbalanced Z) in keyboard macro")    (error "Unbalanced Z) in keyboard macro"))
 )  
1258    
1259  (defun calc-kbd-end-loop ()  (defun calc-kbd-end-loop ()
1260    (interactive)    (interactive)
1261    (error "Unbalanced Z} in keyboard macro")    (error "Unbalanced Z} in keyboard macro"))
 )  
1262    
1263  (defun calc-kbd-break ()  (defun calc-kbd-break ()
1264    (interactive)    (interactive)
# Line 1325  Line 1266 
1266     (let ((cond (calc-top-n 1)))     (let ((cond (calc-top-n 1)))
1267       (calc-pop-stack 1)       (calc-pop-stack 1)
1268       (if (math-is-true cond)       (if (math-is-true cond)
1269           (error "Keyboard macro aborted."))))           (error "Keyboard macro aborted.")))))
 )  
1270    
1271    
1272  (defun calc-kbd-push (arg)  (defun calc-kbd-push (arg)
# Line 1383  Line 1323 
1323               (execute-kbd-macro (substring body 0 -2))))               (execute-kbd-macro (substring body 0 -2))))
1324         (let ((calc-kbd-push-level (1+ calc-kbd-push-level)))         (let ((calc-kbd-push-level (1+ calc-kbd-push-level)))
1325           (message "Saving modes; type Z' to restore")           (message "Saving modes; type Z' to restore")
1326           (recursive-edit)))))           (recursive-edit))))))
 )  
1327  (setq calc-kbd-push-level 0)  (setq calc-kbd-push-level 0)
1328    
1329  (defun calc-kbd-pop ()  (defun calc-kbd-pop ()
# Line 1393  Line 1332 
1332        (progn        (progn
1333          (message "Mode settings restored")          (message "Mode settings restored")
1334          (exit-recursive-edit))          (exit-recursive-edit))
1335      (error "Unbalanced Z' in keyboard macro"))      (error "Unbalanced Z' in keyboard macro")))
 )  
1336    
1337    
1338  (defun calc-kbd-report (msg)  (defun calc-kbd-report (msg)
# Line 1402  Line 1340 
1340    (calc-wrapper    (calc-wrapper
1341     (let ((executing-kbd-macro nil)     (let ((executing-kbd-macro nil)
1342           (defining-kbd-macro nil))           (defining-kbd-macro nil))
1343       (math-working msg (calc-top-n 1))))       (math-working msg (calc-top-n 1)))))
 )  
1344    
1345  (defun calc-kbd-query (msg)  (defun calc-kbd-query (msg)
1346    (interactive "sPrompt: ")    (interactive "sPrompt: ")
1347    (calc-wrapper    (calc-wrapper
1348     (let ((executing-kbd-macro nil)     (let ((executing-kbd-macro nil)
1349           (defining-kbd-macro nil))           (defining-kbd-macro nil))
1350       (calc-alg-entry nil (and (not (equal msg "")) msg))))       (calc-alg-entry nil (and (not (equal msg "")) msg)))))
 )  
1351    
1352    
1353    
# Line 1443  Line 1379 
1379          (if (and (or (math-looks-negp a) (math-zerop a))          (if (and (or (math-looks-negp a) (math-zerop a))
1380                   (or (math-looks-negp b) (math-zerop b)))                   (or (math-looks-negp b) (math-zerop b)))
1381              (list 'calcFunc-eq (math-neg a) (math-neg b))              (list 'calcFunc-eq (math-neg a) (math-neg b))
1382            (list 'calcFunc-eq a b))))            (list 'calcFunc-eq a b)))))
 )  
1383    
1384  (defun calcFunc-neq (a b &rest more)  (defun calcFunc-neq (a b &rest more)
1385    (if more    (if more
# Line 1468  Line 1403 
1403          (if (and (or (math-looks-negp a) (math-zerop a))          (if (and (or (math-looks-negp a) (math-zerop a))
1404                   (or (math-looks-negp b) (math-zerop b)))                   (or (math-looks-negp b) (math-zerop b)))
1405              (list 'calcFunc-neq (math-neg a) (math-neg b))              (list 'calcFunc-neq (math-neg a) (math-neg b))
1406            (list 'calcFunc-neq a b))))            (list 'calcFunc-neq a b)))))
 )  
1407    
1408  (defun math-two-eq (a b)  (defun math-two-eq (a b)
1409    (if (eq (car-safe a) 'vec)    (if (eq (car-safe a) 'vec)
# Line 1495  Line 1429 
1429              1              1
1430            (if (and (= res 2) (not (and (Math-scalarp a) (Math-scalarp b))))            (if (and (= res 2) (not (and (Math-scalarp a) (Math-scalarp b))))
1431                nil                nil
1432              0)))))              0))))))
 )  
1433    
1434  (defun calcFunc-lt (a b)  (defun calcFunc-lt (a b)
1435    (let ((res (math-compare a b)))    (let ((res (math-compare a b)))
# Line 1507  Line 1440 
1440                     (or (math-looks-negp b) (math-zerop b)))                     (or (math-looks-negp b) (math-zerop b)))
1441                (list 'calcFunc-gt (math-neg a) (math-neg b))                (list 'calcFunc-gt (math-neg a) (math-neg b))
1442              (list 'calcFunc-lt a b))              (list 'calcFunc-lt a b))
1443          0)))          0))))
 )  
1444    
1445  (defun calcFunc-gt (a b)  (defun calcFunc-gt (a b)
1446    (let ((res (math-compare a b)))    (let ((res (math-compare a b)))
# Line 1519  Line 1451 
1451                     (or (math-looks-negp b) (math-zerop b)))                     (or (math-looks-negp b) (math-zerop b)))
1452                (list 'calcFunc-lt (math-neg a) (math-neg b))                (list 'calcFunc-lt (math-neg a) (math-neg b))
1453              (list 'calcFunc-gt a b))              (list 'calcFunc-gt a b))
1454          0)))          0))))
 )  
1455    
1456  (defun calcFunc-leq (a b)  (defun calcFunc-leq (a b)
1457    (let ((res (math-compare a b)))    (let ((res (math-compare a b)))
# Line 1531  Line 1462 
1462                     (or (math-looks-negp b) (math-zerop b)))                     (or (math-looks-negp b) (math-zerop b)))
1463                (list 'calcFunc-geq (math-neg a) (math-neg b))                (list 'calcFunc-geq (math-neg a) (math-neg b))
1464              (list 'calcFunc-leq a b))              (list 'calcFunc-leq a b))
1465          1)))          1))))
 )  
1466    
1467  (defun calcFunc-geq (a b)  (defun calcFunc-geq (a b)
1468    (let ((res (math-compare a b)))    (let ((res (math-compare a b)))
# Line 1543  Line 1473 
1473                     (or (math-looks-negp b) (math-zerop b)))                     (or (math-looks-negp b) (math-zerop b)))
1474                (list 'calcFunc-leq (math-neg a) (math-neg b))                (list 'calcFunc-leq (math-neg a) (math-neg b))
1475              (list 'calcFunc-geq a b))              (list 'calcFunc-geq a b))
1476          1)))          1))))
 )  
1477    
1478  (defun calcFunc-rmeq (a)  (defun calcFunc-rmeq (a)
1479    (if (math-vectorp a)    (if (math-vectorp a)
# Line 1558  Line 1487 
1487            (nth 2 a)            (nth 2 a)
1488          (if (eq (car-safe a) 'calcFunc-evalto)          (if (eq (car-safe a) 'calcFunc-evalto)
1489              (nth 1 a)              (nth 1 a)
1490            (list 'calcFunc-rmeq a)))))            (list 'calcFunc-rmeq a))))))
 )  
1491    
1492  (defun calcFunc-land (a b)  (defun calcFunc-land (a b)
1493    (cond ((Math-zerop a)    (cond ((Math-zerop a)
# Line 1570  Line 1498 
1498           b)           b)
1499          ((math-is-true b)          ((math-is-true b)
1500           a)           a)
1501          (t (list 'calcFunc-land a b)))          (t (list 'calcFunc-land a b))))
 )  
1502    
1503  (defun calcFunc-lor (a b)  (defun calcFunc-lor (a b)
1504    (cond ((Math-zerop a)    (cond ((Math-zerop a)
# Line 1582  Line 1509 
1509           a)           a)
1510          ((math-is-true b)          ((math-is-true b)
1511           b)           b)
1512          (t (list 'calcFunc-lor a b)))          (t (list 'calcFunc-lor a b))))
 )  
1513    
1514  (defun calcFunc-lnot (a)  (defun calcFunc-lnot (a)
1515    (if (Math-zerop a)    (if (Math-zerop a)
# Line 1594  Line 1520 
1520                       (assq (car a) calc-tweak-eqn-table))))                       (assq (car a) calc-tweak-eqn-table))))
1521          (if op          (if op
1522              (cons (nth 2 op) (cdr a))              (cons (nth 2 op) (cdr a))
1523            (list 'calcFunc-lnot a)))))            (list 'calcFunc-lnot a))))))
 )  
1524    
1525  (defun calcFunc-if (c e1 e2)  (defun calcFunc-if (c e1 e2)
1526    (if (Math-zerop c)    (if (Math-zerop c)
# Line 1616  Line 1541 
1541                              (list e2))))                              (list e2))))
1542                   (and ee1 ee2                   (and ee1 ee2
1543                        (cons 'vec (math-if-vector (cdr c) ee1 ee2)))))                        (cons 'vec (math-if-vector (cdr c) ee1 ee2)))))
1544            (list 'calcFunc-if c e1 e2))))            (list 'calcFunc-if c e1 e2)))))
 )  
1545    
1546  (defun math-if-vector (c e1 e2)  (defun math-if-vector (c e1 e2)
1547    (and c    (and c
1548         (cons (if (Math-zerop (car c)) (car e2) (car e1))         (cons (if (Math-zerop (car c)) (car e2) (car e1))
1549               (math-if-vector (cdr c)               (math-if-vector (cdr c)
1550                               (or (cdr e1) e1)                               (or (cdr e1) e1)
1551                               (or (cdr e2) e2))))                               (or (cdr e2) e2)))))
 )  
1552    
1553  (defun math-normalize-logical-op (a)  (defun math-normalize-logical-op (a)
1554    (or (and (eq (car a) 'calcFunc-if)    (or (and (eq (car a) 'calcFunc-if)
# Line 1644  Line 1567 
1567                       (list 'calcFunc-if a1                       (list 'calcFunc-if a1
1568                             (math-normalize (nth 2 a))                             (math-normalize (nth 2 a))
1569                             (math-normalize (nth 3 a)))))))))                             (math-normalize (nth 3 a)))))))))
1570        a)        a))
 )  
1571    
1572  (defun calcFunc-in (a b)  (defun calcFunc-in (a b)
1573    (or (and (eq (car-safe b) 'vec)    (or (and (eq (car-safe b) 'vec)
# Line 1678  Line 1600 
1600             1)             1)
1601        (and (math-constp a) (math-constp b)        (and (math-constp a) (math-constp b)
1602             0)             0)
1603        (list 'calcFunc-in a b))        (list 'calcFunc-in a b)))
 )  
1604    
1605  (defun calcFunc-typeof (a)  (defun calcFunc-typeof (a)
1606    (cond ((Math-integerp a) 1)    (cond ((Math-integerp a) 1)
# Line 1695  Line 1616 
1616          ((eq (car a) 'var)          ((eq (car a) 'var)
1617           (if (memq (nth 2 a) '(var-inf var-uinf var-nan)) 12 100))           (if (memq (nth 2 a) '(var-inf var-uinf var-nan)) 12 100))
1618          ((eq (car a) 'vec) (if (math-matrixp a) 102 101))          ((eq (car a) 'vec) (if (math-matrixp a) 102 101))
1619          (t (math-calcFunc-to-var func)))          (t (math-calcFunc-to-var func))))
 )  
1620    
1621  (defun calcFunc-integer (a)  (defun calcFunc-integer (a)
1622    (if (Math-integerp a)    (if (Math-integerp a)
1623        1        1
1624      (if (Math-objvecp a)      (if (Math-objvecp a)
1625          0          0
1626        (list 'calcFunc-integer a)))        (list 'calcFunc-integer a))))
 )  
1627    
1628  (defun calcFunc-real (a)  (defun calcFunc-real (a)
1629    (if (Math-realp a)    (if (Math-realp a)
1630        1        1
1631      (if (Math-objvecp a)      (if (Math-objvecp a)
1632          0          0
1633        (list 'calcFunc-real a)))        (list 'calcFunc-real a))))
 )  
1634    
1635  (defun calcFunc-constant (a)  (defun calcFunc-constant (a)
1636    (if (math-constp a)    (if (math-constp a)
1637        1        1
1638      (if (Math-objvecp a)      (if (Math-objvecp a)
1639          0          0
1640        (list 'calcFunc-constant a)))        (list 'calcFunc-constant a))))
 )  
1641    
1642  (defun calcFunc-refers (a b)  (defun calcFunc-refers (a b)
1643    (if (math-expr-contains a b)    (if (math-expr-contains a b)
1644        1        1
1645      (if (eq (car-safe a) 'var)      (if (eq (car-safe a) 'var)
1646          (list 'calcFunc-refers a b)          (list 'calcFunc-refers a b)
1647        0))        0)))
 )  
1648    
1649  (defun calcFunc-negative (a)  (defun calcFunc-negative (a)
1650    (if (math-looks-negp a)    (if (math-looks-negp a)
# Line 1736  Line 1652 
1652      (if (or (math-zerop a)      (if (or (math-zerop a)
1653              (math-posp a))              (math-posp a))
1654          0          0
1655        (list 'calcFunc-negative a)))        (list 'calcFunc-negative a))))
 )  
1656    
1657  (defun calcFunc-variable (a)  (defun calcFunc-variable (a)
1658    (if (eq (car-safe a) 'var)    (if (eq (car-safe a) 'var)
1659        1        1
1660      (if (Math-objvecp a)      (if (Math-objvecp a)
1661          0          0
1662        (list 'calcFunc-variable a)))        (list 'calcFunc-variable a))))
 )  
1663    
1664  (defun calcFunc-nonvar (a)  (defun calcFunc-nonvar (a)
1665    (if (eq (car-safe a) 'var)    (if (eq (car-safe a) 'var)
1666        (list 'calcFunc-nonvar a)        (list 'calcFunc-nonvar a)
1667      1)      1))
 )  
1668    
1669  (defun calcFunc-istrue (a)  (defun calcFunc-istrue (a)
1670    (if (math-is-true a)    (if (math-is-true a)
1671        1        1
1672      0)      0))
 )  
1673    
1674    
1675    
# Line 1851  Line 1763 
1763            (append (list 'defun fname clargs)            (append (list 'defun fname clargs)
1764                    doc                    doc
1765                    (math-do-arg-list-check args nil nil)                    (math-do-arg-list-check args nil nil)
1766                    body)))                    body))))
 )  
1767    
1768  (defun math-clean-arg (arg)  (defun math-clean-arg (arg)
1769    (if (consp arg)    (if (consp arg)
1770        (math-clean-arg (nth 1 arg))        (math-clean-arg (nth 1 arg))
1771      arg)      arg))
 )  
1772    
1773  (defun math-do-arg-check (arg var is-opt is-rest)  (defun math-do-arg-check (arg var is-opt is-rest)
1774    (if is-opt    (if is-opt
# Line 1915  Line 1825 
1825                                (list 'and                                (list 'and
1826                                      (list chk var)                                      (list chk var)
1827                                      (list 'math-reject-arg var qqual)))))                                      (list 'math-reject-arg var qqual)))))
1828                   (error "Unknown qualifier `%s'" qual-name)))))))                   (error "Unknown qualifier `%s'" qual-name))))))))
 )  
1829    
1830  (defun math-do-arg-list-check (args is-opt is-rest)  (defun math-do-arg-list-check (args is-opt is-rest)
1831    (cond ((null args) nil)    (cond ((null args) nil)
# Line 1929  Line 1838 
1838           (math-do-arg-list-check (cdr args) t nil))           (math-do-arg-list-check (cdr args) t nil))
1839          ((eq (car args) '&rest)          ((eq (car args) '&rest)
1840           (math-do-arg-list-check (cdr args) nil t))           (math-do-arg-list-check (cdr args) nil t))
1841          (t (math-do-arg-list-check (cdr args) is-opt is-rest)))          (t (math-do-arg-list-check (cdr args) is-opt is-rest))))
 )  
1842    
1843  (defconst math-prim-funcs  (defconst math-prim-funcs
1844    '( (~= . math-nearly-equal)    '( (~= . math-nearly-equal)
# Line 1949  Line 1857 
1857       (if . if)       (if . if)
1858       (^ . math-pow)       (^ . math-pow)
1859       (expt . math-pow)       (expt . math-pow)
1860     )     ))
 )  
1861    
1862  (defconst math-prim-vars  (defconst math-prim-vars
1863    '( (nil . nil)    '( (nil . nil)
1864       (t . t)       (t . t)
1865       (&optional . &optional)       (&optional . &optional)
1866       (&rest . &rest)       (&rest . &rest)
1867     )     ))
 )  
1868    
1869  (defun math-define-function-body (body env)  (defun math-define-function-body (body env)
1870    (let ((body (math-define-body body env)))    (let ((body (math-define-body body env)))
1871      (if (math-body-refers-to body 'math-return)      (if (math-body-refers-to body 'math-return)
1872          (list (cons 'catch (cons '(quote math-return) body)))          (list (cons 'catch (cons '(quote math-return) body)))
1873        body))        body)))
 )  
1874    
1875  (defun math-define-body (body exp-env)  (defun math-define-body (body exp-env)
1876    (math-define-list body)    (math-define-list body))
 )  
1877    
1878  (defun math-define-list (body &optional quote)  (defun math-define-list (body &optional quote)
1879    (cond ((null body)    (cond ((null body)
# Line 1988  Line 1892 
1892                 (math-define-list (cdr body))))                 (math-define-list (cdr body))))
1893          (t          (t
1894           (cons (math-define-exp (car body))           (cons (math-define-exp (car body))
1895                 (math-define-list (cdr body)))))                 (math-define-list (cdr body))))))
 )  
1896    
1897  (defun math-define-exp (exp)  (defun math-define-exp (exp)
1898    (cond ((consp exp)    (cond ((consp exp)
# Line 2140  Line 2043 
2043           (if (or (<= exp -1000000) (>= exp 1000000))           (if (or (<= exp -1000000) (>= exp 1000000))
2044               (list 'quote (math-normalize exp))               (list 'quote (math-normalize exp))
2045             exp))             exp))
2046          (t exp))          (t exp)))
 )  
2047    
2048  (defun math-define-cond (forms)  (defun math-define-cond (forms)
2049    (and forms    (and forms
2050         (cons (math-define-list (car forms))         (cons (math-define-list (car forms))
2051               (math-define-cond (cdr forms))))               (math-define-cond (cdr forms)))))
 )  
2052    
2053  (defun math-complicated-lhs (body)  (defun math-complicated-lhs (body)
2054    (and body    (and body
2055         (or (not (symbolp (car body)))         (or (not (symbolp (car body)))
2056             (math-complicated-lhs (cdr (cdr body)))))             (math-complicated-lhs (cdr (cdr body))))))
 )  
2057    
2058  (defun math-define-setf-list (body)  (defun math-define-setf-list (body)
2059    (and body    (and body
2060         (cons (math-define-setf (nth 0 body) (nth 1 body))         (cons (math-define-setf (nth 0 body) (nth 1 body))
2061               (math-define-setf-list (cdr (cdr body)))))               (math-define-setf-list (cdr (cdr body))))))
 )  
2062    
2063  (defun math-define-setf (place value)  (defun math-define-setf (place value)
2064    (setq place (math-define-exp place)    (setq place (math-define-exp place)
# Line 2175  Line 2074 
2074          ((eq (car-safe place) 'cdr)          ((eq (car-safe place) 'cdr)
2075           (list 'setcdr (nth 1 place) value))           (list 'setcdr (nth 1 place) value))
2076          (t          (t
2077           (error "Bad place form for setf: %s" place)))           (error "Bad place form for setf: %s" place))))
 )  
2078    
2079  (defun math-define-binop (op ident arg1 rest)  (defun math-define-binop (op ident arg1 rest)
2080    (if rest    (if rest
2081        (math-define-binop op ident        (math-define-binop op ident
2082                           (list op arg1 (car rest))                           (list op arg1 (car rest))
2083                           (cdr rest))                           (cdr rest))
2084      (or arg1 ident))      (or arg1 ident)))
 )  
2085    
2086  (defun math-define-let (vlist)  (defun math-define-let (vlist)
2087    (and vlist    (and vlist
# Line 2192  Line 2089 
2089                   (cons (car (car vlist))                   (cons (car (car vlist))
2090                         (math-define-list (cdr (car vlist))))                         (math-define-list (cdr (car vlist))))
2091                 (car vlist))                 (car vlist))
2092               (math-define-let (cdr vlist))))               (math-define-let (cdr vlist)))))
 )  
2093    
2094  (defun math-define-let-env (vlist)  (defun math-define-let-env (vlist)
2095    (and vlist    (and vlist
2096         (cons (if (consp (car vlist))         (cons (if (consp (car vlist))
2097                   (car (car vlist))                   (car (car vlist))
2098                 (car vlist))                 (car vlist))
2099               (math-define-let-env (cdr vlist))))               (math-define-let-env (cdr vlist)))))
 )  
2100    
2101  (defun math-define-lambda (exp exp-env)  (defun math-define-lambda (exp exp-env)
2102    (nconc (list (nth 0 exp)   ; 'lambda    (nconc (list (nth 0 exp)   ; 'lambda
2103                 (nth 1 exp))  ; arg list                 (nth 1 exp))  ; arg list
2104           (math-define-function-body (cdr (cdr exp))           (math-define-function-body (cdr (cdr exp))
2105                                      (append (nth 1 exp) exp-env)))                                      (append (nth 1 exp) exp-env))))
 )  
2106    
2107  (defun math-define-elt (seq idx)  (defun math-define-elt (seq idx)
2108    (if idx    (if idx
2109        (math-define-elt (list 'elt seq (car idx)) (cdr idx))        (math-define-elt (list 'elt seq (car idx)) (cdr idx))
2110      seq)      seq))
 )  
2111    
2112    
2113    
# Line 2224  Line 2117 
2117    (let ((body (cons 'while (cons head body))))    (let ((body (cons 'while (cons head body))))
2118      (if (math-body-refers-to body 'math-break)      (if (math-body-refers-to body 'math-break)
2119          (cons 'catch (cons '(quote math-break) (list body)))          (cons 'catch (cons '(quote math-break) (list body)))
2120        body))        body)))
 )  
2121    
2122    
2123  (defmacro math-for (head &rest body)  (defmacro math-for (head &rest body)
# Line 2234  Line 2126 
2126                  (cons 'while (cons t body)))))                  (cons 'while (cons t body)))))
2127      (if (math-body-refers-to body 'math-break)      (if (math-body-refers-to body 'math-break)
2128          (cons 'catch (cons '(quote math-break) (list body)))          (cons 'catch (cons '(quote math-break) (list body)))
2129        body))        body)))
 )  
2130    
2131  (defun math-handle-for (head body)  (defun math-handle-for (head body)
2132    (let* ((var (nth 0 (car head)))    (let* ((var (nth 0 (car head)))
# Line 2291  Line 2182 
2182                                                             '+                                                             '+
2183                                                           'math-add)                                                           'math-add)
2184                                                         var                                                         var
2185                                                         save-step))))))))))                                                         save-step)))))))))))
 )  
2186    
2187    
2188  (defmacro math-foreach (head &rest body)  (defmacro math-foreach (head &rest body)
2189    (let ((body (math-handle-foreach head body)))    (let ((body (math-handle-foreach head body)))
2190      (if (math-body-refers-to body 'math-break)      (if (math-body-refers-to body 'math-break)
2191          (cons 'catch (cons '(quote math-break) (list body)))          (cons 'catch (cons '(quote math-break) (list body)))
2192        body))        body)))
 )  
2193    
2194    
2195  (defun math-handle-foreach (head body)  (defun math-handle-foreach (head body)
# Line 2317  Line 2206 
2206                               (append body                               (append body
2207                                       (list (list 'setq                                       (list (list 'setq
2208                                                   var                                                   var
2209                                                   (list 'cdr var))))))))))                                                   (list 'cdr var)))))))))))
 )  
2210    
2211    
2212  (defun math-body-refers-to (body thing)  (defun math-body-refers-to (body thing)
2213    (or (equal body thing)    (or (equal body thing)
2214        (and (consp body)        (and (consp body)
2215             (or (math-body-refers-to (car body) thing)             (or (math-body-refers-to (car body) thing)
2216                 (math-body-refers-to (cdr body) thing))))                 (math-body-refers-to (cdr body) thing)))))
 )  
2217    
2218  (defun math-break (&optional value)  (defun math-break (&optional value)
2219    (throw 'math-break value)    (throw 'math-break value))
 )  
2220    
2221  (defun math-return (&optional value)  (defun math-return (&optional value)
2222    (throw 'math-return value)    (throw 'math-return value))
 )  
2223    
2224    
2225    
# Line 2359  Line 2244 
2244                   (+ (if (eq (nth 1 op) 'calcFunc-geq) 2 0)                   (+ (if (eq (nth 1 op) 'calcFunc-geq) 2 0)
2245                      (if (eq (car x) 'calcFunc-geq) 1 0))                      (if (eq (car x) 'calcFunc-geq) 1 0))
2246                   (math-read-expr-level (nth 3 op)) (nth 1 x))                   (math-read-expr-level (nth 3 op)) (nth 1 x))
2247                (throw 'syntax "Syntax error")))))                (throw 'syntax "Syntax error"))))))
 )  
2248    
2249    ;;; calc-prog.el ends here

Legend:
Removed from v.1.2  
changed lines
  Added in v.1.3

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26