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