lisp/calc/calc-prog.el

   1 ;;; calc-prog.el --- user programmability functions for Calc
   2
   3 ;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
   4 ;;   2005, 2006, 2007, 2008 Free Software Foundation, Inc.
   5
   6 ;; Author: David Gillespie <daveg@synaptics.com>
   7 ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 3, or (at your option)
  14 ;; any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  24 ;; Boston, MA 02110-1301, USA.
  25
  26 ;;; Commentary:
  27
  28 ;;; Code:
  29
  30 ;; This file is autoloaded from calc-ext.el.
  31
  32 (require 'calc-ext)
  33 (require 'calc-macs)
  34
  35 ;; Declare functions which are defined elsewhere.
  36 (declare-function edmacro-format-keys "edmacro" (macro &optional verbose))
  37 (declare-function edmacro-parse-keys "edmacro" (string &optional need-vector))
  38 (declare-function math-read-expr-level "calc-aent" (exp-prec &optional exp-term))
  39
  40
  41 (defun calc-equal-to (arg)
  42   (interactive "P")
  43   (calc-wrapper
  44    (if (and (integerp arg) (> arg 2))
  45        (calc-enter-result arg "eq" (cons 'calcFunc-eq (calc-top-list-n arg)))
  46      (calc-binary-op "eq" 'calcFunc-eq arg))))
  47
  48 (defun calc-remove-equal (arg)
  49   (interactive "P")
  50   (calc-wrapper
  51    (calc-unary-op "rmeq" 'calcFunc-rmeq arg)))
  52
  53 (defun calc-not-equal-to (arg)
  54   (interactive "P")
  55   (calc-wrapper
  56    (if (and (integerp arg) (> arg 2))
  57        (calc-enter-result arg "neq" (cons 'calcFunc-neq (calc-top-list-n arg)))
  58      (calc-binary-op "neq" 'calcFunc-neq arg))))
  59
  60 (defun calc-less-than (arg)
  61   (interactive "P")
  62   (calc-wrapper
  63    (calc-binary-op "lt" 'calcFunc-lt arg)))
  64
  65 (defun calc-greater-than (arg)
  66   (interactive "P")
  67   (calc-wrapper
  68    (calc-binary-op "gt" 'calcFunc-gt arg)))
  69
  70 (defun calc-less-equal (arg)
  71   (interactive "P")
  72   (calc-wrapper
  73    (calc-binary-op "leq" 'calcFunc-leq arg)))
  74
  75 (defun calc-greater-equal (arg)
  76   (interactive "P")
  77   (calc-wrapper
  78    (calc-binary-op "geq" 'calcFunc-geq arg)))
  79
  80 (defun calc-in-set (arg)
  81   (interactive "P")
  82   (calc-wrapper
  83    (calc-binary-op "in" 'calcFunc-in arg)))
  84
  85 (defun calc-logical-and (arg)
  86   (interactive "P")
  87   (calc-wrapper
  88    (calc-binary-op "land" 'calcFunc-land arg 1)))
  89
  90 (defun calc-logical-or (arg)
  91   (interactive "P")
  92   (calc-wrapper
  93    (calc-binary-op "lor" 'calcFunc-lor arg 0)))
  94
  95 (defun calc-logical-not (arg)
  96   (interactive "P")
  97   (calc-wrapper
  98    (calc-unary-op "lnot" 'calcFunc-lnot arg)))
  99
 100 (defun calc-logical-if ()
 101   (interactive)
 102   (calc-wrapper
 103    (calc-enter-result 3 "if" (cons 'calcFunc-if (calc-top-list-n 3)))))
 104
 105
 106
 107
 108
 109 (defun calc-timing (n)
 110   (interactive "P")
 111   (calc-wrapper
 112    (calc-change-mode 'calc-timing n nil t)
 113    (message (if calc-timing
 114                 "Reporting timing of slow commands in Trail"
 115               "Not reporting timing of commands"))))
 116
 117 (defun calc-pass-errors ()
 118   (interactive)
 119   ;; The following two cases are for the new, optimizing byte compiler
 120   ;; or the standard 18.57 byte compiler, respectively.
 121   (condition-case err
 122       (let ((place (aref (nth 2 (nth 2 (symbol-function 'calc-do))) 15)))
 123         (or (memq (car-safe (car-safe place)) '(error xxxerror))
 124             (setq place (aref (nth 2 (nth 2 (symbol-function 'calc-do))) 27)))
 125         (or (memq (car (car place)) '(error xxxerror))
 126             (error "foo"))
 127         (setcar (car place) 'xxxerror))
 128     (error (error "The calc-do function has been modified; unable to patch"))))
 129
 130 (defun calc-user-define ()
 131   (interactive)
 132   (message "Define user key: z-")
 133   (let ((key (read-char)))
 134     (if (= (calc-user-function-classify key) 0)
 135         (error "Can't redefine \"?\" key"))
 136     (let ((func (intern (completing-read (concat "Set key z "
 137                                                  (char-to-string key)
 138                                                  " to command: ")
 139                                          obarray
 140                                          'commandp
 141                                          t
 142                                          "calc-"))))
 143       (let* ((kmap (calc-user-key-map))
 144              (old (assq key kmap)))
 145         (if old
 146             (setcdr old func)
 147           (setcdr kmap (cons (cons key func) (cdr kmap))))))))
 148
 149 (defun calc-user-undefine ()
 150   (interactive)
 151   (message "Undefine user key: z-")
 152   (let ((key (read-char)))
 153     (if (= (calc-user-function-classify key) 0)
 154         (error "Can't undefine \"?\" key"))
 155     (let* ((kmap (calc-user-key-map)))
 156       (delq (or (assq key kmap)
 157                 (assq (upcase key) kmap)
 158                 (assq (downcase key) kmap)
 159                 (error "No such user key is defined"))
 160             kmap))))
 161
 162
 163 ;; math-integral-cache-state is originally declared in calcalg2.el,
 164 ;; it is used in calc-user-define-variable.
 165 (defvar math-integral-cache-state)
 166
 167 ;; calc-user-formula-alist is local to calc-user-define-formula,
 168 ;; calc-user-define-compostion and calc-finish-formula-edit,
 169 ;; but is used by calc-fix-user-formula.
 170 (defvar calc-user-formula-alist)
 171
 172 (defun calc-user-define-formula ()
 173   (interactive)
 174   (calc-wrapper
 175    (let* ((form (calc-top 1))
 176           (arglist nil)
 177           (is-lambda (and (eq (car-safe form) 'calcFunc-lambda)
 178                           (>= (length form) 2)))
 179           odef key keyname cmd cmd-base cmd-base-default
 180           func calc-user-formula-alist is-symb)
 181      (if is-lambda
 182          (setq arglist (mapcar (function (lambda (x) (nth 1 x)))
 183                                (nreverse (cdr (reverse (cdr form)))))
 184                form (nth (1- (length form)) form))
 185        (calc-default-formula-arglist form)
 186        (setq arglist (sort arglist 'string-lessp)))
 187      (message "Define user key: z-")
 188      (setq key (read-char))
 189      (if (= (calc-user-function-classify key) 0)
 190          (error "Can't redefine \"?\" key"))
 191      (setq key (and (not (memq key '(13 32))) key)
 192            keyname (and key
 193                         (if (or (and (<= ?0 key) (<= key ?9))
 194                                 (and (<= ?a key) (<= key ?z))
 195                                 (and (<= ?A key) (<= key ?Z)))
 196                             (char-to-string key)
 197                           (format "%03d" key)))
 198            odef (assq key (calc-user-key-map)))
 199      (unless keyname
 200        (setq keyname (format "%05d" (abs (% (random) 10000)))))
 201      (while
 202          (progn
 203            (setq cmd-base-default (concat "User-" keyname))
 204            (setq cmd (completing-read
 205                       (concat "Define M-x command name (default calc-"
 206                               cmd-base-default
 207                               "): ")
 208                       obarray 'commandp nil
 209                       (if (and odef (symbolp (cdr odef)))
 210                           (symbol-name (cdr odef))
 211                         "calc-")))
 212            (if (or (string-equal cmd "")
 213                    (string-equal cmd "calc-"))
 214                (setq cmd (concat "calc-User-" keyname)))
 215            (setq cmd-base (and (string-match "\\`calc-\\(.+\\)\\'" cmd)
 216                                (math-match-substring cmd 1)))
 217            (setq cmd (intern cmd))
 218            (and cmd
 219                 (fboundp cmd)
 220                 odef
 221                 (not
 222                  (y-or-n-p
 223                   (if (get cmd 'calc-user-defn)
 224                       (concat "Replace previous definition for "
 225                               (symbol-name cmd) "? ")
 226                     "That name conflicts with a built-in Emacs function.  Replace this function? "))))))
 227      (while
 228          (progn
 229            (setq cmd-base-default
 230                  (if cmd-base
 231                      (if (string-match
 232                           "\\`User-.+" cmd-base)
 233                          (concat
 234                           "User"
 235                           (substring cmd-base 5))
 236                        cmd-base)
 237                    (concat "User" keyname)))
 238            (setq func
 239                  (concat "calcFunc-"
 240                          (completing-read
 241                           (concat "Define algebraic function name (default "
 242                                   cmd-base-default "): ")
 243                           (mapcar (lambda (x) (substring x 9))
 244                                   (all-completions "calcFunc-"
 245                                                    obarray))
 246                           (lambda (x)
 247                             (fboundp
 248                              (intern (concat "calcFunc-" x))))
 249                           nil)))
 250            (setq func
 251                  (if (string-equal func "calcFunc-")
 252                      (intern (concat "calcFunc-" cmd-base-default))
 253                    (intern func)))
 254            (and func
 255                 (fboundp func)
 256                 (not (fboundp cmd))
 257                 odef
 258                 (not
 259                  (y-or-n-p
 260                   (if (get func 'calc-user-defn)
 261                       (concat "Replace previous definition for "
 262                               (symbol-name func) "? ")
 263                     "That name conflicts with a built-in Emacs function.  Replace this function? "))))))
 264
 265      (if (not func)
 266          (setq func (intern (concat "calcFunc-User"
 267                                     (or keyname
 268                                         (and cmd (symbol-name cmd))
 269                                         (format "%05d" (% (random) 10000)))))))
 270
 271      (if is-lambda
 272          (setq calc-user-formula-alist arglist)
 273        (while
 274            (progn
 275              (setq calc-user-formula-alist
 276                    (read-from-minibuffer "Function argument list: "
 277                                          (if arglist
 278                                              (prin1-to-string arglist)
 279                                            "()")
 280                                          minibuffer-local-map
 281                                          t))
 282              (and (not (calc-subsetp calc-user-formula-alist arglist))
 283                   (not (y-or-n-p
 284                         "Okay for arguments that don't appear in formula to be ignored? "))))))
 285      (setq is-symb (and calc-user-formula-alist
 286                         func
 287                         (y-or-n-p
 288                          "Leave it symbolic for non-constant arguments? ")))
 289      (setq calc-user-formula-alist
 290            (mapcar (function (lambda (x)
 291                                (or (cdr (assq x '((nil . arg-nil)
 292                                                   (t . arg-t))))
 293                                    x))) calc-user-formula-alist))
 294      (if cmd
 295          (progn
 296            (require 'calc-macs)
 297            (fset cmd
 298                  (list 'lambda
 299                        '()
 300                        '(interactive)
 301                        (list 'calc-wrapper
 302                              (list 'calc-enter-result
 303                                    (length calc-user-formula-alist)
 304                                    (let ((name (symbol-name (or func cmd))))
 305                                      (and (string-match
 306                                            "\\([^-][^-]?[^-]?[^-]?\\)[^-]*\\'"
 307                                            name)
 308                                           (math-match-substring name 1)))
 309                                    (list 'cons
 310                                          (list 'quote func)
 311                                          (list 'calc-top-list-n
 312                                                (length calc-user-formula-alist)))))))
 313            (put cmd 'calc-user-defn t)))
 314      (let ((body (list 'math-normalize (calc-fix-user-formula form))))
 315        (fset func
 316              (append
 317               (list 'lambda calc-user-formula-alist)
 318               (and is-symb
 319                    (mapcar (function (lambda (v)
 320                                        (list 'math-check-const v t)))
 321                            calc-user-formula-alist))
 322               (list body))))
 323      (put func 'calc-user-defn form)
 324      (setq math-integral-cache-state nil)
 325      (if key
 326          (let* ((kmap (calc-user-key-map))
 327                 (old (assq key kmap)))
 328            (if old
 329                (setcdr old cmd)
 330              (setcdr kmap (cons (cons key cmd) (cdr kmap)))))))
 331    (message "")))
 332
 333 (defun calc-default-formula-arglist (form)
 334   (if (consp form)
 335       (if (eq (car form) 'var)
 336           (if (or (memq (nth 1 form) arglist)
 337                   (math-const-var form))
 338               ()
 339             (setq arglist (cons (nth 1 form) arglist)))
 340         (calc-default-formula-arglist-step (cdr form)))))
 341
 342 (defun calc-default-formula-arglist-step (l)
 343   (and l
 344        (progn
 345          (calc-default-formula-arglist (car l))
 346          (calc-default-formula-arglist-step (cdr l)))))
 347
 348 (defun calc-subsetp (a b)
 349   (or (null a)
 350       (and (memq (car a) b)
 351            (calc-subsetp (cdr a) b))))
 352
 353 (defun calc-fix-user-formula (f)
 354   (if (consp f)
 355       (let (temp)
 356         (cond ((and (eq (car f) 'var)
 357                     (memq (setq temp (or (cdr (assq (nth 1 f) '((nil . arg-nil)
 358                                                                 (t . arg-t))))
 359                                          (nth 1 f)))
 360                           calc-user-formula-alist))
 361                temp)
 362               ((or (math-constp f) (eq (car f) 'var))
 363                (list 'quote f))
 364               ((and (eq (car f) 'calcFunc-eval)
 365                     (= (length f) 2))
 366                (list 'let '((calc-simplify-mode nil))
 367                      (list 'math-normalize (calc-fix-user-formula (nth 1 f)))))
 368               ((and (eq (car f) 'calcFunc-evalsimp)
 369                     (= (length f) 2))
 370                (list 'math-simplify (calc-fix-user-formula (nth 1 f))))
 371               ((and (eq (car f) 'calcFunc-evalextsimp)
 372                     (= (length f) 2))
 373                (list 'math-simplify-extended
 374                      (calc-fix-user-formula (nth 1 f))))
 375               (t
 376                (cons 'list
 377                      (cons (list 'quote (car f))
 378                            (mapcar 'calc-fix-user-formula (cdr f)))))))
 379     f))
 380
 381 (defun calc-user-define-composition ()
 382   (interactive)
 383   (calc-wrapper
 384    (if (eq calc-language 'unform)
 385        (error "Can't define formats for unformatted mode"))
 386    (let* ((comp (calc-top 1))
 387           (func (intern
 388                  (concat "calcFunc-"
 389                          (completing-read "Define format for which function: "
 390                                           (mapcar (lambda (x) (substring x 9))
 391                                                   (all-completions "calcFunc-"
 392                                                                    obarray))
 393                                           (lambda (x)
 394                                             (fboundp
 395                                              (intern (concat "calcFunc-" x))))))))
 396           (comps (get func 'math-compose-forms))
 397           entry entry2
 398           (arglist nil)
 399           (calc-user-formula-alist nil))
 400      (if (math-zerop comp)
 401          (if (setq entry (assq calc-language comps))
 402              (put func 'math-compose-forms (delq entry comps)))
 403        (calc-default-formula-arglist comp)
 404        (setq arglist (sort arglist 'string-lessp))
 405        (while
 406            (progn
 407              (setq calc-user-formula-alist
 408                    (read-from-minibuffer "Composition argument list: "
 409                                          (if arglist
 410                                              (prin1-to-string arglist)
 411                                            "()")
 412                                          minibuffer-local-map
 413                                          t))
 414              (and (not (calc-subsetp calc-user-formula-alist arglist))
 415                   (y-or-n-p
 416                    "Okay for arguments that don't appear in formula to be invisible? "))))
 417        (or (setq entry (assq calc-language comps))
 418            (put func 'math-compose-forms
 419                 (cons (setq entry (list calc-language)) comps)))
 420        (or (setq entry2 (assq (length calc-user-formula-alist) (cdr entry)))
 421            (setcdr entry
 422                    (cons (setq entry2
 423                                (list (length calc-user-formula-alist))) (cdr entry))))
 424        (setcdr entry2
 425                (list 'lambda calc-user-formula-alist (calc-fix-user-formula comp))))
 426      (calc-pop-stack 1)
 427      (calc-do-refresh))))
 428
 429
 430 (defun calc-user-define-kbd-macro (arg)
 431   (interactive "P")
 432   (or last-kbd-macro
 433       (error "No keyboard macro defined"))
 434   (message "Define last kbd macro on user key: z-")
 435   (let ((key (read-char)))
 436     (if (= (calc-user-function-classify key) 0)
 437         (error "Can't redefine \"?\" key"))
 438     (let ((cmd (intern (completing-read "Full name for new command: "
 439                                         obarray
 440                                         'commandp
 441                                         nil
 442                                         (concat "calc-User-"
 443                                                 (if (or (and (>= key ?a)
 444                                                              (<= key ?z))
 445                                                         (and (>= key ?A)
 446                                                              (<= key ?Z))
 447                                                         (and (>= key ?0)
 448                                                              (<= key ?9)))
 449                                                     (char-to-string key)
 450                                                   (format "%03d" key)))))))
 451       (and (fboundp cmd)
 452            (not (let ((f (symbol-function cmd)))
 453                   (or (stringp f)
 454                       (and (consp f)
 455                            (eq (car-safe (nth 3 f))
 456                                'calc-execute-kbd-macro)))))
 457            (error "Function %s is already defined and not a keyboard macro"
 458                   cmd))
 459       (put cmd 'calc-user-defn t)
 460       (fset cmd (if (< (prefix-numeric-value arg) 0)
 461                     last-kbd-macro
 462                   (list 'lambda
 463                         '(arg)
 464                         '(interactive "P")
 465                         (list 'calc-execute-kbd-macro
 466                               (vector (key-description last-kbd-macro)
 467                                       last-kbd-macro)
 468                               'arg
 469                               (format "z%c" key)))))
 470       (let* ((kmap (calc-user-key-map))
 471              (old (assq key kmap)))
 472         (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 (save-excursion
 573                           (set-buffer calc-buf)
 574                           (let ((calc-user-parse-tables nil)
 575                                 (calc-language nil)
 576                                 (math-expr-opers (math-standard-ops))
 577                                 (calc-hashes-used 0))
 578                             (math-read-expr
 579                              (if (string-match ",[ \t]*\\'" str)
 580                                  (substring str 0 (match-beginning 0))
 581                                str))))))
 582               (if (eq (car-safe exp) 'error)
 583                   (progn
 584                     (goto-char (+ pos (nth 1 exp)))
 585                     (error (nth 2 exp))))
 586               (setq tab (nconc tab (list (cons p exp)))))))))
 587     tab))
 588
 589 (defun calc-fix-token-name (name &optional unquoted)
 590   (cond ((string-match "\\`\\.\\." name)
 591          (concat "\\dots" (substring name 2)))
 592         ((and (equal name "{") (memq calc-lang '(tex latex eqn)))
 593          "(")
 594         ((and (equal name "}") (memq calc-lang '(tex latex eqn)))
 595          ")")
 596         ((and (equal name "&") (memq calc-lang '(tex latex)))
 597          ",")
 598         ((equal name "#")
 599          (search-backward "#")
 600          (error "Token '#' is reserved"))
 601         ((and unquoted (string-match "#" name))
 602          (error "Tokens containing '#' must be quoted"))
 603         ((not (string-match "[^ ]" name))
 604          (search-backward "\"" nil t)
 605          (error "Blank tokens are not allowed"))
 606         (t name)))
 607
 608 (defun calc-read-parse-table-part (term eterm)
 609   (let ((part nil)
 610         (quoted nil))
 611     (while (progn
 612              (skip-chars-forward "\n\t ")
 613              (if (eobp) (error "Expected '%s'" eterm))
 614              (not (looking-at term)))
 615       (cond ((looking-at "%%")
 616              (end-of-line))
 617             ((looking-at "{[\n\t ]")
 618              (forward-char 2)
 619              (let ((p (calc-read-parse-table-part "}" "}")))
 620                (or (looking-at "[+*?]")
 621                    (error "Expected '+', '*', or '?'"))
 622                (let ((sym (intern (buffer-substring (point) (1+ (point))))))
 623                  (forward-char 1)
 624                  (looking-at "[^\n\t ]*")
 625                  (let ((sep (buffer-substring (point) (match-end 0))))
 626                    (goto-char (match-end 0))
 627                    (and (eq sym '\?) (> (length sep) 0)
 628                         (not (equal sep "$")) (not (equal sep "."))
 629                         (error "Separator not allowed with { ... }?"))
 630                    (if (string-match "\\`\"" sep)
 631                        (setq sep (read-from-string sep)))
 632                    (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 "")
1290          (open last-command-char)
1291          (counter initial)
1292          ch)
1293     (or executing-kbd-macro
1294         (message "Reading loop body..."))
1295     (while (>= count 0)
1296       (setq ch (read-char))
1297       (if (= ch -1)
1298           (error "Unterminated Z%c in keyboard macro" open))
1299       (if (= ch ?Z)
1300           (progn
1301             (setq ch (read-char)
1302                   body (concat body "Z" (char-to-string 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 (concat (substring body 0 -2)
1310                                                           "Z]")))
1311                          body ""))
1312                   ((eq ch 7)
1313                    (keyboard-quit))))
1314         (setq body (concat body (char-to-string 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 (concat (substring body 0 -2) "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 "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 "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)) (list (car body))))
1798          (clargs (mapcar 'math-clean-arg args))
1799          (body (math-define-function-body
1800                 (if (stringp (car body)) (cdr body) body)
1801                 clargs)))
1802     (list 'progn
1803           (if (and (consp (car body))
1804                    (eq (car (car body)) 'interactive))
1805               (let ((inter (car body)))
1806                 (setq body (cdr body))
1807                 (if (or (> (length inter) 2)
1808                         (integerp (nth 1 inter)))
1809                     (let ((hasprefix nil) (hasmulti nil))
1810                       (if (stringp (nth 1 inter))
1811                           (progn
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                       (if (not (integerp (nth 1 inter)))
1821                           (error
1822                            "Expected an integer in interactive specification"))
1823                       (append (list 'defun
1824                                     (intern (concat "calc-"
1825                                                     (symbol-name func)))
1826                                     (if (or hasprefix hasmulti)
1827                                         '(&optional n)
1828                                       ()))
1829                               doc
1830                               (if (or hasprefix hasmulti)
1831                                   '((interactive "P"))
1832                                 '((interactive)))
1833                               (list
1834                                (append
1835                                 '(calc-slow-wrapper)
1836                                 (and hasmulti
1837                                      (list
1838                                       (list 'setq
1839                                             'n
1840                                             (list 'if
1841                                                   'n
1842                                                   (list 'prefix-numeric-value
1843                                                         'n)
1844                                                   (nth 1 inter)))))
1845                                 (list
1846                                  (list 'calc-enter-result
1847                                        (if hasmulti 'n (nth 1 inter))
1848                                        (nth 2 inter)
1849                                        (if hasprefix
1850                                            (list 'append
1851                                                  (list 'quote (list fname))
1852                                                  (list 'calc-top-list-n
1853                                                        (nth 1 inter))
1854                                                  (list 'and
1855                                                        'n
1856                                                        (list
1857                                                         'list
1858                                                         (list
1859                                                          'math-normalize
1860                                                          (list
1861                                                           'prefix-numeric-value
1862                                                           'n)))))
1863                                          (list 'cons
1864                                                (list 'quote fname)
1865                                                (list 'calc-top-list-n
1866                                                      (if hasmulti
1867                                                          'n
1868                                                        (nth 1 inter)))))))))))
1869                   (append (list 'defun
1870                                 (intern (concat "calc-" (symbol-name func)))
1871                                 args)
1872                           doc
1873                           (list
1874                            inter
1875                            (cons 'calc-wrapper body))))))
1876           (append (list 'defun fname clargs)
1877                   doc
1878                   (math-do-arg-list-check args nil nil)
1879                   body))))
1880
1881 (defun math-clean-arg (arg)
1882   (if (consp arg)
1883       (math-clean-arg (nth 1 arg))
1884     arg))
1885
1886 (defun math-do-arg-check (arg var is-opt is-rest)
1887   (if is-opt
1888       (let ((chk (math-do-arg-check arg var nil nil)))
1889         (list (cons 'and
1890                     (cons var
1891                           (if (cdr chk)
1892                               (setq chk (list (cons 'progn chk)))
1893                             chk)))))
1894     (and (consp arg)
1895          (let* ((rest (math-do-arg-check (nth 1 arg) var is-opt is-rest))
1896                 (qual (car arg))
1897                 (qqual (list 'quote qual))
1898                 (qual-name (symbol-name qual))
1899                 (chk (intern (concat "math-check-" qual-name))))
1900            (if (fboundp chk)
1901                (append rest
1902                        (list
1903                         (if is-rest
1904                             (list 'setq var
1905                                   (list 'mapcar (list 'quote chk) var))
1906                           (list 'setq var (list chk var)))))
1907              (if (fboundp (setq chk (intern (concat "math-" qual-name))))
1908                  (append rest
1909                          (list
1910                           (if is-rest
1911                               (list 'mapcar
1912                                     (list 'function
1913                                           (list 'lambda '(x)
1914                                                 (list 'or
1915                                                       (list chk 'x)
1916                                                       (list 'math-reject-arg
1917                                                             'x qqual))))
1918                                     var)
1919                             (list 'or
1920                                   (list chk var)
1921                                   (list 'math-reject-arg var qqual)))))
1922                (if (and (string-match "\\`not-\\(.*\\)\\'" qual-name)
1923                         (fboundp (setq chk (intern
1924                                             (concat "math-"
1925                                                     (math-match-substring
1926                                                      qual-name 1))))))
1927                    (append rest
1928                            (list
1929                             (if is-rest
1930                                 (list 'mapcar
1931                                       (list 'function
1932                                             (list 'lambda '(x)
1933                                                   (list 'and
1934                                                         (list chk 'x)
1935                                                         (list 'math-reject-arg
1936                                                               'x qqual))))
1937                                       var)
1938                               (list 'and
1939                                     (list chk var)
1940                                     (list 'math-reject-arg var qqual)))))
1941                  (error "Unknown qualifier `%s'" qual-name))))))))
1942
1943 (defun math-do-arg-list-check (args is-opt is-rest)
1944   (cond ((null args) nil)
1945         ((consp (car args))
1946          (append (math-do-arg-check (car args)
1947                                     (math-clean-arg (car args))
1948                                     is-opt is-rest)
1949                  (math-do-arg-list-check (cdr args) is-opt is-rest)))
1950         ((eq (car args) '&optional)
1951          (math-do-arg-list-check (cdr args) t nil))
1952         ((eq (car args) '&rest)
1953          (math-do-arg-list-check (cdr args) nil t))
1954         (t (math-do-arg-list-check (cdr args) is-opt is-rest))))
1955
1956 (defconst math-prim-funcs
1957   '( (~= . math-nearly-equal)
1958      (% . math-mod)
1959      (lsh . calcFunc-lsh)
1960      (ash . calcFunc-ash)
1961      (logand . calcFunc-and)
1962      (logandc2 . calcFunc-diff)
1963      (logior . calcFunc-or)
1964      (logxor . calcFunc-xor)
1965      (lognot . calcFunc-not)
1966      (equal . equal)   ; need to leave these ones alone!
1967      (eq . eq)
1968      (and . and)
1969      (or . or)
1970      (if . if)
1971      (^ . math-pow)
1972      (expt . math-pow)
1973    ))
1974
1975 (defconst math-prim-vars
1976   '( (nil . nil)
1977      (t . t)
1978      (&optional . &optional)
1979      (&rest . &rest)
1980    ))
1981
1982 (defun math-define-function-body (body env)
1983   (let ((body (math-define-body body env)))
1984     (if (math-body-refers-to body 'math-return)
1985         (list (cons 'catch (cons '(quote math-return) body)))
1986       body)))
1987
1988 ;; The variable math-exp-env is local to math-define-body, but is
1989 ;; used by math-define-exp, which is called (indirectly) by
1990 ;; by math-define-body.
1991 (defvar math-exp-env)
1992
1993 (defun math-define-body (body math-exp-env)
1994   (math-define-list body))
1995
1996 (defun math-define-list (body &optional quote)
1997   (cond ((null body)
1998          nil)
1999         ((and (eq (car body) ':)
2000               (stringp (nth 1 body)))
2001          (cons (let* ((math-read-expr-quotes t)
2002                       (exp (math-read-plain-expr (nth 1 body) t)))
2003                  (math-define-exp exp))
2004                (math-define-list (cdr (cdr body)))))
2005         (quote
2006          (cons (cond ((consp (car body))
2007                       (math-define-list (cdr body) t))
2008                      (t
2009                       (car body)))
2010                (math-define-list (cdr body))))
2011         (t
2012          (cons (math-define-exp (car body))
2013                (math-define-list (cdr body))))))
2014
2015 (defun math-define-exp (exp)
2016   (cond ((consp exp)
2017          (let ((func (car exp)))
2018            (cond ((memq func '(quote function))
2019                   (if (and (consp (nth 1 exp))
2020                            (eq (car (nth 1 exp)) 'lambda))
2021                       (cons 'quote
2022                             (math-define-lambda (nth 1 exp) math-exp-env))
2023                     exp))
2024                  ((memq func '(let let* for foreach))
2025                   (let ((head (nth 1 exp))
2026                         (body (cdr (cdr exp))))
2027                     (if (memq func '(let let*))
2028                         ()
2029                       (setq func (cdr (assq func '((for . math-for)
2030                                                    (foreach . math-foreach)))))
2031                       (if (not (listp (car head)))
2032                           (setq head (list head))))
2033                     (macroexpand
2034                      (cons func
2035                            (cons (math-define-let head)
2036                                  (math-define-body body
2037                                                    (nconc
2038                                                     (math-define-let-env head)
2039                                                     math-exp-env)))))))
2040                  ((and (memq func '(setq setf))
2041                        (math-complicated-lhs (cdr exp)))
2042                   (if (> (length exp) 3)
2043                       (cons 'progn (math-define-setf-list (cdr exp)))
2044                     (math-define-setf (nth 1 exp) (nth 2 exp))))
2045                  ((eq func 'condition-case)
2046                   (cons func
2047                         (cons (nth 1 exp)
2048                               (math-define-body (cdr (cdr exp))
2049                                                 (cons (nth 1 exp)
2050                                                       math-exp-env)))))
2051                  ((eq func 'cond)
2052                   (cons func
2053                         (math-define-cond (cdr exp))))
2054                  ((and (consp func)   ; ('spam a b) == force use of plain spam
2055                        (eq (car func) 'quote))
2056                   (cons func (math-define-list (cdr exp))))
2057                  ((symbolp func)
2058                   (let ((args (math-define-list (cdr exp)))
2059                         (prim (assq func math-prim-funcs)))
2060                     (cond (prim
2061                            (cons (cdr prim) args))
2062                           ((eq func 'floatp)
2063                            (list 'eq (car args) '(quote float)))
2064                           ((eq func '+)
2065                            (math-define-binop 'math-add 0
2066                                               (car args) (cdr args)))
2067                           ((eq func '-)
2068                            (if (= (length args) 1)
2069                                (cons 'math-neg args)
2070                              (math-define-binop 'math-sub 0
2071                                                 (car args) (cdr args))))
2072                           ((eq func '*)
2073                            (math-define-binop 'math-mul 1
2074                                               (car args) (cdr args)))
2075                           ((eq func '/)
2076                            (math-define-binop 'math-div 1
2077                                               (car args) (cdr args)))
2078                           ((eq func 'min)
2079                            (math-define-binop 'math-min 0
2080                                               (car args) (cdr args)))
2081                           ((eq func 'max)
2082                            (math-define-binop 'math-max 0
2083                                               (car args) (cdr args)))
2084                           ((eq func '<)
2085                            (if (and (math-numberp (nth 1 args))
2086                                     (math-zerop (nth 1 args)))
2087                                (list 'math-negp (car args))
2088                              (cons 'math-lessp args)))
2089                           ((eq func '>)
2090                            (if (and (math-numberp (nth 1 args))
2091                                     (math-zerop (nth 1 args)))
2092                                (list 'math-posp (car args))
2093                              (list 'math-lessp (nth 1 args) (nth 0 args))))
2094                           ((eq func '<=)
2095                            (list 'not
2096                                  (if (and (math-numberp (nth 1 args))
2097                                           (math-zerop (nth 1 args)))
2098                                      (list 'math-posp (car args))
2099                                    (list 'math-lessp
2100                                          (nth 1 args) (nth 0 args)))))
2101                           ((eq func '>=)
2102                            (list 'not
2103                                  (if (and (math-numberp (nth 1 args))
2104                                           (math-zerop (nth 1 args)))
2105                                      (list 'math-negp (car args))
2106                                    (cons 'math-lessp args))))
2107                           ((eq func '=)
2108                            (if (and (math-numberp (nth 1 args))
2109                                     (math-zerop (nth 1 args)))
2110                                (list 'math-zerop (nth 0 args))
2111                              (if (and (integerp (nth 1 args))
2112                                       (/= (% (nth 1 args) 10) 0))
2113                                  (cons 'math-equal-int args)
2114                                (cons 'math-equal args))))
2115                           ((eq func '/=)
2116                            (list 'not
2117                                  (if (and (math-numberp (nth 1 args))
2118                                           (math-zerop (nth 1 args)))
2119                                      (list 'math-zerop (nth 0 args))
2120                                    (if (and (integerp (nth 1 args))
2121                                             (/= (% (nth 1 args) 10) 0))
2122                                        (cons 'math-equal-int args)
2123                                      (cons 'math-equal args)))))
2124                           ((eq func '1+)
2125                            (list 'math-add (car args) 1))
2126                           ((eq func '1-)
2127                            (list 'math-add (car args) -1))
2128                           ((eq func 'not)   ; optimize (not (not x)) => x
2129                            (if (eq (car-safe args) func)
2130                                (car (nth 1 args))
2131                              (cons func args)))
2132                           ((and (eq func 'elt) (cdr (cdr args)))
2133                            (math-define-elt (car args) (cdr args)))
2134                           (t
2135                            (macroexpand
2136                             (let* ((name (symbol-name func))
2137                                    (cfunc (intern (concat "calcFunc-" name)))
2138                                    (mfunc (intern (concat "math-" name))))
2139                               (cond ((fboundp cfunc)
2140                                      (cons cfunc args))
2141                                     ((fboundp mfunc)
2142                                      (cons mfunc args))
2143                                     ((or (fboundp func)
2144                                          (string-match "\\`calcFunc-.*" name))
2145                                      (cons func args))
2146                                     (t
2147                                      (cons cfunc args)))))))))
2148                  (t (cons func (math-define-list (cdr exp))))))) ;;args
2149         ((symbolp exp)
2150          (let ((prim (assq exp math-prim-vars))
2151                (name (symbol-name exp)))
2152            (cond (prim
2153                   (cdr prim))
2154                  ((memq exp math-exp-env)
2155                   exp)
2156                  ((string-match "-" name)
2157                   exp)
2158                  (t
2159                   (intern (concat "var-" name))))))
2160         ((integerp exp)
2161          (if (or (<= exp -1000000) (>= exp 1000000))
2162              (list 'quote (math-normalize exp))
2163            exp))
2164         (t exp)))
2165
2166 (defun math-define-cond (forms)
2167   (and forms
2168        (cons (math-define-list (car forms))
2169              (math-define-cond (cdr forms)))))
2170
2171 (defun math-complicated-lhs (body)
2172   (and body
2173        (or (not (symbolp (car body)))
2174            (math-complicated-lhs (cdr (cdr body))))))
2175
2176 (defun math-define-setf-list (body)
2177   (and body
2178        (cons (math-define-setf (nth 0 body) (nth 1 body))
2179              (math-define-setf-list (cdr (cdr body))))))
2180
2181 (defun math-define-setf (place value)
2182   (setq place (math-define-exp place)
2183         value (math-define-exp value))
2184   (cond ((symbolp place)
2185          (list 'setq place value))
2186         ((eq (car-safe place) 'nth)
2187          (list 'setcar (list 'nthcdr (nth 1 place) (nth 2 place)) value))
2188         ((eq (car-safe place) 'elt)
2189          (list 'setcar (list 'nthcdr (nth 2 place) (nth 1 place)) value))
2190         ((eq (car-safe place) 'car)
2191          (list 'setcar (nth 1 place) value))
2192         ((eq (car-safe place) 'cdr)
2193          (list 'setcdr (nth 1 place) value))
2194         (t
2195          (error "Bad place form for setf: %s" place))))
2196
2197 (defun math-define-binop (op ident arg1 rest)
2198   (if rest
2199       (math-define-binop op ident
2200                          (list op arg1 (car rest))
2201                          (cdr rest))
2202     (or arg1 ident)))
2203
2204 (defun math-define-let (vlist)
2205   (and vlist
2206        (cons (if (consp (car vlist))
2207                  (cons (car (car vlist))
2208                        (math-define-list (cdr (car vlist))))
2209                (car vlist))
2210              (math-define-let (cdr vlist)))))
2211
2212 (defun math-define-let-env (vlist)
2213   (and vlist
2214        (cons (if (consp (car vlist))
2215                  (car (car vlist))
2216                (car vlist))
2217              (math-define-let-env (cdr vlist)))))
2218
2219 (defun math-define-lambda (exp exp-env)
2220   (nconc (list (nth 0 exp)   ; 'lambda
2221                (nth 1 exp))  ; arg list
2222          (math-define-function-body (cdr (cdr exp))
2223                                     (append (nth 1 exp) exp-env))))
2224
2225 (defun math-define-elt (seq idx)
2226   (if idx
2227       (math-define-elt (list 'elt seq (car idx)) (cdr idx))
2228     seq))
2229
2230
2231
2232 ;;; Useful programming macros.
2233
2234 (defmacro math-while (head &rest body)
2235   (let ((body (cons 'while (cons head body))))
2236     (if (math-body-refers-to body 'math-break)
2237         (cons 'catch (cons '(quote math-break) (list body)))
2238       body)))
2239 ;; (put 'math-while 'lisp-indent-hook 1)
2240
2241 (defmacro math-for (head &rest body)
2242   (let ((body (if head
2243                   (math-handle-for head body)
2244                 (cons 'while (cons t body)))))
2245     (if (math-body-refers-to body 'math-break)
2246         (cons 'catch (cons '(quote math-break) (list body)))
2247       body)))
2248 ;; (put 'math-for 'lisp-indent-hook 1)
2249
2250 (defun math-handle-for (head body)
2251   (let* ((var (nth 0 (car head)))
2252          (init (nth 1 (car head)))
2253          (limit (nth 2 (car head)))
2254          (step (or (nth 3 (car head)) 1))
2255          (body (if (cdr head)
2256                    (list (math-handle-for (cdr head) body))
2257                  body))
2258          (all-ints (and (integerp init) (integerp limit) (integerp step)))
2259          (const-limit (or (integerp limit)
2260                           (and (eq (car-safe limit) 'quote)
2261                                (math-realp (nth 1 limit)))))
2262          (const-step (or (integerp step)
2263                          (and (eq (car-safe step) 'quote)
2264                               (math-realp (nth 1 step)))))
2265          (save-limit (if const-limit limit (make-symbol "<limit>")))
2266          (save-step (if const-step step (make-symbol "<step>"))))
2267     (cons 'let
2268           (cons (append (if const-limit nil (list (list save-limit limit)))
2269                         (if const-step nil (list (list save-step step)))
2270                         (list (list var init)))
2271                 (list
2272                  (cons 'while
2273                        (cons (if all-ints
2274                                  (if (> step 0)
2275                                      (list '<= var save-limit)
2276                                    (list '>= var save-limit))
2277                                (list 'not
2278                                      (if const-step
2279                                          (if (or (math-posp step)
2280                                                  (math-posp
2281                                                   (cdr-safe step)))
2282                                              (list 'math-lessp
2283                                                    save-limit
2284                                                    var)
2285                                            (list 'math-lessp
2286                                                  var
2287                                                  save-limit))
2288                                        (list 'if
2289                                              (list 'math-posp
2290                                                    save-step)
2291                                              (list 'math-lessp
2292                                                    save-limit
2293                                                    var)
2294                                              (list 'math-lessp
2295                                                    var
2296                                                    save-limit)))))
2297                              (append body
2298                                      (list (list 'setq
2299                                                  var
2300                                                  (list (if all-ints
2301                                                            '+
2302                                                          'math-add)
2303                                                        var
2304                                                        save-step)))))))))))
2305
2306 (defmacro math-foreach (head &rest body)
2307   (let ((body (math-handle-foreach head body)))
2308     (if (math-body-refers-to body 'math-break)
2309         (cons 'catch (cons '(quote math-break) (list body)))
2310       body)))
2311 ;; (put 'math-foreach 'lisp-indent-hook 1)
2312
2313 (defun math-handle-foreach (head body)
2314   (let ((var (nth 0 (car head)))
2315         (data (nth 1 (car head)))
2316         (body (if (cdr head)
2317                   (list (math-handle-foreach (cdr head) body))
2318                 body)))
2319     (cons 'let
2320           (cons (list (list var data))
2321                 (list
2322                  (cons 'while
2323                        (cons var
2324                              (append body
2325                                      (list (list 'setq
2326                                                  var
2327                                                  (list 'cdr var)))))))))))
2328
2329
2330 (defun math-body-refers-to (body thing)
2331   (or (equal body thing)
2332       (and (consp body)
2333            (or (math-body-refers-to (car body) thing)
2334                (math-body-refers-to (cdr body) thing)))))
2335
2336 (defun math-break (&optional value)
2337   (throw 'math-break value))
2338
2339 (defun math-return (&optional value)
2340   (throw 'math-return value))
2341
2342
2343
2344
2345
2346 (defun math-composite-inequalities (x op)
2347   (if (memq (nth 1 op) '(calcFunc-eq calcFunc-neq))
2348       (if (eq (car x) (nth 1 op))
2349           (append x (list (math-read-expr-level (nth 3 op))))
2350         (throw 'syntax "Syntax error"))
2351     (list 'calcFunc-in
2352           (nth 2 x)
2353           (if (memq (nth 1 op) '(calcFunc-lt calcFunc-leq))
2354               (if (memq (car x) '(calcFunc-lt calcFunc-leq))
2355                   (math-make-intv
2356                    (+ (if (eq (car x) 'calcFunc-leq) 2 0)
2357                       (if (eq (nth 1 op) 'calcFunc-leq) 1 0))
2358                    (nth 1 x) (math-read-expr-level (nth 3 op)))
2359                 (throw 'syntax "Syntax error"))
2360             (if (memq (car x) '(calcFunc-gt calcFunc-geq))
2361                 (math-make-intv
2362                  (+ (if (eq (nth 1 op) 'calcFunc-geq) 2 0)
2363                     (if (eq (car x) 'calcFunc-geq) 1 0))
2364                  (math-read-expr-level (nth 3 op)) (nth 1 x))
2365               (throw 'syntax "Syntax error"))))))
2366
2367 (provide 'calc-prog)
2368
2369 ;;; arch-tag: 4c5a183b-c9e5-4632-bb3f-e41a764518b0
2370 ;;; calc-prog.el ends here