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

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