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