lisp/calc/calc-prog.el

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