code.delx.au - gnu-emacs/blob - lisp/calc/calc-prog.el

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