lisp/calc/calc-prog.el

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