lisp/calc/calc-prog.el

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