cgit.sxemacs.org Git - packages/blob - xemacs-packages/calc/calc-prog.el

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