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 |
|
|
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) |
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) |
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) |
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) |
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) |
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) |
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) |
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) |
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 () |
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)) |
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)) |
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 |
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)) |
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) |
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) |
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 () |
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) |
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) |
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 () |
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) |
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 |
|
|
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) |
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) |
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))) |
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 () |
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 () |
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)) |
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) |
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))) |
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))) |
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 () |
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) |
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 () |
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") |
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") |
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) |
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) |
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 () |
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) |
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 |
|
|
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 |
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) |
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))) |
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))) |
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))) |
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))) |
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) |
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) |
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) |
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) |
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) |
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) |
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) |
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) |
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) |
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 |
|
|
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 |
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) |
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) |
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) |
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) |
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) |
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 |
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 |
|
|
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) |
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))) |
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) |
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 |
|
|
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 |