lisp/calc/calc-prog.el

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