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