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