lisp/calc/calc-prog.el

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