lisp/calc/calc-prog.el

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