code.delx.au - gnu-emacs/blob - lisp/calc/calc-prog.el

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