Merge from emacs-24; up to 2014-07-27T01:00:26Z!fgallina@gnu.org

[gnu-emacs] / lisp / calc / calc-prog.el

diff --git a/lisp/calc/calc-prog.el b/lisp/calc/calc-prog.el
index 91017627699bbeeb1a34f22ad08ba8e6bb07dd66..156bf4cd0dbb8df4ef24fed08a020c7890fcc6d2 100644 (file)
--- a/lisp/calc/calc-prog.el
+++ b/lisp/calc/calc-prog.el
@@ -1,7 +1,6 @@
 ;;; calc-prog.el --- user programmability functions for Calc
 
 ;;; calc-prog.el --- user programmability functions for Calc
 

-;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
-;;   2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1990-1993, 2001-2014 Free Software Foundation, Inc.

 
 ;; Author: David Gillespie <daveg@synaptics.com>
 ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
 
 ;; Author: David Gillespie <daveg@synaptics.com>
 ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>


@@ -140,6 +139,7 @@
                                         "calc-"))))
       (let* ((kmap (calc-user-key-map))
             (old (assq key kmap)))
                                         "calc-"))))
       (let* ((kmap (calc-user-key-map))
             (old (assq key kmap)))

+        ;; FIXME: Why not (define-key kmap (vector key) func)?

        (if old
            (setcdr old func)
          (setcdr kmap (cons (cons key func) (cdr kmap))))))))
        (if old
            (setcdr old func)
          (setcdr kmap (cons (cons key func) (cdr kmap))))))))


@@ -171,17 +171,17 @@
   (interactive)
   (calc-wrapper
    (let* ((form (calc-top 1))
   (interactive)
   (calc-wrapper
    (let* ((form (calc-top 1))

-         (arglist nil)
+         (math-arglist nil)

          (is-lambda (and (eq (car-safe form) 'calcFunc-lambda)
                          (>= (length form) 2)))
          odef key keyname cmd cmd-base cmd-base-default
           func calc-user-formula-alist is-symb)
      (if is-lambda
          (is-lambda (and (eq (car-safe form) 'calcFunc-lambda)
                          (>= (length form) 2)))
          odef key keyname cmd cmd-base cmd-base-default
           func calc-user-formula-alist is-symb)
      (if is-lambda

-        (setq arglist (mapcar (function (lambda (x) (nth 1 x)))
+        (setq math-arglist (mapcar (function (lambda (x) (nth 1 x)))

                               (nreverse (cdr (reverse (cdr form)))))
               form (nth (1- (length form)) form))
        (calc-default-formula-arglist form)
                               (nreverse (cdr (reverse (cdr form)))))
               form (nth (1- (length form)) form))
        (calc-default-formula-arglist form)

-       (setq arglist (sort arglist 'string-lessp)))
+       (setq math-arglist (sort math-arglist 'string-lessp)))

      (message "Define user key: z-")
      (setq key (read-char))
      (if (= (calc-user-function-classify key) 0)
      (message "Define user key: z-")
      (setq key (read-char))
      (if (= (calc-user-function-classify key) 0)


@@ -267,17 +267,17 @@
                                        (format "%05d" (% (random) 10000)))))))
 
      (if is-lambda
                                        (format "%05d" (% (random) 10000)))))))
 
      (if is-lambda

-        (setq calc-user-formula-alist arglist)
+        (setq calc-user-formula-alist math-arglist)

        (while
           (progn
             (setq calc-user-formula-alist
                    (read-from-minibuffer "Function argument list: "
        (while
           (progn
             (setq calc-user-formula-alist
                    (read-from-minibuffer "Function argument list: "

-                                         (if arglist
-                                             (prin1-to-string arglist)
+                                         (if math-arglist
+                                             (prin1-to-string math-arglist)

                                            "()")
                                          minibuffer-local-map
                                          t))
                                            "()")
                                          minibuffer-local-map
                                          t))

-            (and (not (calc-subsetp calc-user-formula-alist arglist))
+            (and (not (calc-subsetp calc-user-formula-alist math-arglist))

                  (not (y-or-n-p
                        "Okay for arguments that don't appear in formula to be ignored? "))))))
      (setq is-symb (and calc-user-formula-alist
                  (not (y-or-n-p
                        "Okay for arguments that don't appear in formula to be ignored? "))))))
      (setq is-symb (and calc-user-formula-alist


@@ -323,19 +323,20 @@
      (if key
         (let* ((kmap (calc-user-key-map))
                (old (assq key kmap)))
      (if key
         (let* ((kmap (calc-user-key-map))
                (old (assq key kmap)))

+           ;; FIXME: Why not (define-key kmap (vector key) cmd)?

           (if old
               (setcdr old cmd)
             (setcdr kmap (cons (cons key cmd) (cdr kmap)))))))
    (message "")))
 
           (if old
               (setcdr old cmd)
             (setcdr kmap (cons (cons key cmd) (cdr kmap)))))))
    (message "")))
 

-(defvar arglist)                   ; dynamically bound in all callers
+(defvar math-arglist)              ; dynamically bound in all callers

 (defun calc-default-formula-arglist (form)
   (if (consp form)
       (if (eq (car form) 'var)
 (defun calc-default-formula-arglist (form)
   (if (consp form)
       (if (eq (car form) 'var)

-         (if (or (memq (nth 1 form) arglist)
+         (if (or (memq (nth 1 form) math-arglist)

                  (math-const-var form))
              ()
                  (math-const-var form))
              ()

-           (setq arglist (cons (nth 1 form) arglist)))
+           (setq math-arglist (cons (nth 1 form) math-arglist)))

        (calc-default-formula-arglist-step (cdr form)))))
 
 (defun calc-default-formula-arglist-step (l)
        (calc-default-formula-arglist-step (cdr form)))))
 
 (defun calc-default-formula-arglist-step (l)


@@ -394,23 +395,23 @@
                                              (intern (concat "calcFunc-" x))))))))
          (comps (get func 'math-compose-forms))
          entry entry2
                                              (intern (concat "calcFunc-" x))))))))
          (comps (get func 'math-compose-forms))
          entry entry2

-         (arglist nil)
+         (math-arglist nil)

          (calc-user-formula-alist nil))
      (if (math-zerop comp)
         (if (setq entry (assq calc-language comps))
             (put func 'math-compose-forms (delq entry comps)))
        (calc-default-formula-arglist comp)
          (calc-user-formula-alist nil))
      (if (math-zerop comp)
         (if (setq entry (assq calc-language comps))
             (put func 'math-compose-forms (delq entry comps)))
        (calc-default-formula-arglist comp)

-       (setq arglist (sort arglist 'string-lessp))
+       (setq math-arglist (sort math-arglist 'string-lessp))

        (while
           (progn
             (setq calc-user-formula-alist
                    (read-from-minibuffer "Composition argument list: "
        (while
           (progn
             (setq calc-user-formula-alist
                    (read-from-minibuffer "Composition argument list: "

-                                         (if arglist
-                                             (prin1-to-string arglist)
+                                         (if math-arglist
+                                             (prin1-to-string math-arglist)

                                            "()")
                                          minibuffer-local-map
                                          t))
                                            "()")
                                          minibuffer-local-map
                                          t))

-            (and (not (calc-subsetp calc-user-formula-alist arglist))
+            (and (not (calc-subsetp calc-user-formula-alist math-arglist))

                  (y-or-n-p
                   "Okay for arguments that don't appear in formula to be invisible? "))))
        (or (setq entry (assq calc-language comps))
                  (y-or-n-p
                   "Okay for arguments that don't appear in formula to be invisible? "))))
        (or (setq entry (assq calc-language comps))


@@ -468,6 +469,7 @@
                              (format "z%c" key)))))
       (let* ((kmap (calc-user-key-map))
             (old (assq key kmap)))
                              (format "z%c" key)))))
       (let* ((kmap (calc-user-key-map))
             (old (assq key kmap)))

+        ;; FIXME: Why not (define-key kmap (vector key) func)?

        (if old
            (setcdr old cmd)
          (setcdr kmap (cons (cons key cmd) (cdr kmap))))))))
        (if old
            (setcdr old cmd)
          (setcdr kmap (cons (cons key cmd) (cdr kmap))))))))


@@ -1793,89 +1795,63 @@ Redefine the corresponding command."
 (defun math-do-defmath (func args body)
   (require 'calc-macs)
   (let* ((fname (intern (concat "calcFunc-" (symbol-name func))))
 (defun math-do-defmath (func args body)
   (require 'calc-macs)
   (let* ((fname (intern (concat "calcFunc-" (symbol-name func))))

-        (doc (if (stringp (car body)) (list (car body))))
+        (doc (if (stringp (car body))
+                 (prog1 (list (car body))
+                   (setq body (cdr body)))))

         (clargs (mapcar 'math-clean-arg args))
         (clargs (mapcar 'math-clean-arg args))

-        (body (math-define-function-body
-               (if (stringp (car body)) (cdr body) body)
-               clargs)))
-    (list 'progn
-         (if (and (consp (car body))
-                  (eq (car (car body)) 'interactive))
-             (let ((inter (car body)))
-               (setq body (cdr body))
-               (if (or (> (length inter) 2)
-                       (integerp (nth 1 inter)))
-                   (let ((hasprefix nil) (hasmulti nil))
-                     (if (stringp (nth 1 inter))
-                         (progn
-                           (cond ((equal (nth 1 inter) "p")
-                                  (setq hasprefix t))
-                                 ((equal (nth 1 inter) "m")
-                                  (setq hasmulti t))
-                                 (t (error
-                                     "Can't handle interactive code string \"%s\""
-                                     (nth 1 inter))))
-                           (setq inter (cdr inter))))
-                     (if (not (integerp (nth 1 inter)))
-                         (error
-                          "Expected an integer in interactive specification"))
-                     (append (list 'defun
-                                   (intern (concat "calc-"
-                                                   (symbol-name func)))
-                                   (if (or hasprefix hasmulti)
-                                       '(&optional n)
-                                     ()))
-                             doc
-                             (if (or hasprefix hasmulti)
-                                 '((interactive "P"))
-                               '((interactive)))
-                             (list
-                              (append
-                               '(calc-slow-wrapper)
-                               (and hasmulti
-                                    (list
-                                     (list 'setq
-                                           'n
-                                           (list 'if
-                                                 'n
-                                                 (list 'prefix-numeric-value
-                                                       'n)
-                                                 (nth 1 inter)))))
-                               (list
-                                (list 'calc-enter-result
-                                      (if hasmulti 'n (nth 1 inter))
-                                      (nth 2 inter)
-                                      (if hasprefix
-                                          (list 'append
-                                                (list 'quote (list fname))
-                                                (list 'calc-top-list-n
-                                                      (nth 1 inter))
-                                                (list 'and
-                                                      'n
-                                                      (list
-                                                       'list
-                                                       (list
-                                                        'math-normalize
-                                                        (list
-                                                         'prefix-numeric-value
-                                                         'n)))))
-                                        (list 'cons
-                                              (list 'quote fname)
-                                              (list 'calc-top-list-n
-                                                    (if hasmulti
-                                                        'n
-                                                      (nth 1 inter)))))))))))
-                 (append (list 'defun
-                               (intern (concat "calc-" (symbol-name func)))
-                               args)
-                         doc
-                         (list
-                          inter
-                          (cons 'calc-wrapper body))))))
-         (append (list 'defun fname clargs)
-                 doc
-                 (math-do-arg-list-check args nil nil)
-                 body))))
+        (inter (if (and (consp (car body))
+                        (eq (car (car body)) 'interactive))
+                   (prog1 (car body)
+                     (setq body (cdr body))))))
+    (setq body (math-define-function-body body clargs))
+    `(progn
+       ,(if inter
+           (if (or (> (length inter) 2)
+                   (integerp (nth 1 inter)))
+               (let ((hasprefix nil) (hasmulti nil))
+                 (when (stringp (nth 1 inter))
+                   (cond ((equal (nth 1 inter) "p")
+                          (setq hasprefix t))
+                         ((equal (nth 1 inter) "m")
+                          (setq hasmulti t))
+                         (t (error
+                             "Can't handle interactive code string \"%s\""
+                             (nth 1 inter))))
+                   (setq inter (cdr inter)))
+                 (unless (integerp (nth 1 inter))
+                   (error "Expected an integer in interactive specification"))
+                 `(defun ,(intern (concat "calc-" (symbol-name func)))
+                    ,(if (or hasprefix hasmulti) '(&optional n) ())
+                    ,@doc
+                    (interactive ,@(if (or hasprefix hasmulti) '("P")))
+                    (calc-slow-wrapper
+                     ,@(if hasmulti
+                           `((setq n (if n
+                                         (prefix-numeric-value n)
+                                       ,(nth 1 inter)))))
+                     (calc-enter-result
+                      ,(if hasmulti 'n (nth 1 inter))
+                      ,(nth 2 inter)
+                      ,(if hasprefix
+                           `(append '(,fname)
+                                    (calc-top-list-n ,(nth 1 inter))
+                                    (and n
+                                         (list
+                                          (math-normalize
+                                           (prefix-numeric-value n)))))
+                         `(cons ',fname
+                                (calc-top-list-n
+                                 ,(if hasmulti
+                                      'n
+                                    (nth 1 inter)))))))))
+             `(defun ,(intern (concat "calc-" (symbol-name func))) ,clargs
+                ,@doc
+                ,inter
+                (calc-wrapper ,@body))))
+       (defun ,fname ,clargs
+        ,@doc
+        ,@(math-do-arg-list-check args nil nil)
+        ,@body))))

 
 (defun math-clean-arg (arg)
   (if (consp arg)
 
 (defun math-clean-arg (arg)
   (if (consp arg)


@@ -1888,56 +1864,42 @@ Redefine the corresponding command."
        (list (cons 'and
                    (cons var
                          (if (cdr chk)
        (list (cons 'and
                    (cons var
                          (if (cdr chk)

-                             (setq chk (list (cons 'progn chk)))
+                             `((progn ,@chk))

                            chk)))))
                            chk)))))

-    (and (consp arg)
-        (let* ((rest (math-do-arg-check (nth 1 arg) var is-opt is-rest))
-               (qual (car arg))
-               (qqual (list 'quote qual))
-               (qual-name (symbol-name qual))
-               (chk (intern (concat "math-check-" qual-name))))
-          (if (fboundp chk)
-              (append rest
-                      (list
+    (when (consp arg)
+      (let* ((rest (math-do-arg-check (nth 1 arg) var is-opt is-rest))
+            (qual (car arg))
+            (qual-name (symbol-name qual))
+            (chk (intern (concat "math-check-" qual-name))))
+       (if (fboundp chk)
+           (append rest
+                   (if is-rest
+                       `((setq ,var (mapcar ',chk ,var)))
+                     `((setq ,var (,chk ,var)))))
+         (if (fboundp (setq chk (intern (concat "math-" qual-name))))
+             (append rest
+                     (if is-rest
+                         `((mapcar #'(lambda (x)
+                                       (or (,chk x)
+                                           (math-reject-arg x ',qual)))
+                                   ,var))
+                       `((or (,chk ,var)
+                             (math-reject-arg ,var ',qual)))))
+           (if (and (string-match "\\`not-\\(.*\\)\\'" qual-name)
+                    (fboundp (setq chk (intern
+                                        (concat "math-"
+                                                (math-match-substring
+                                                 qual-name 1))))))
+               (append rest

                        (if is-rest
                        (if is-rest

-                           (list 'setq var
-                                 (list 'mapcar (list 'quote chk) var))
-                         (list 'setq var (list chk var)))))
-            (if (fboundp (setq chk (intern (concat "math-" qual-name))))
-                (append rest
-                        (list
-                         (if is-rest
-                             (list 'mapcar
-                                   (list 'function
-                                         (list 'lambda '(x)
-                                               (list 'or
-                                                     (list chk 'x)
-                                                     (list 'math-reject-arg
-                                                           'x qqual))))
-                                   var)
-                           (list 'or
-                                 (list chk var)
-                                 (list 'math-reject-arg var qqual)))))
-              (if (and (string-match "\\`not-\\(.*\\)\\'" qual-name)
-                       (fboundp (setq chk (intern
-                                           (concat "math-"
-                                                   (math-match-substring
-                                                    qual-name 1))))))
-                  (append rest
-                          (list
-                           (if is-rest
-                               (list 'mapcar
-                                     (list 'function
-                                           (list 'lambda '(x)
-                                                 (list 'and
-                                                       (list chk 'x)
-                                                       (list 'math-reject-arg
-                                                             'x qqual))))
-                                     var)
-                             (list 'and
-                                   (list chk var)
-                                   (list 'math-reject-arg var qqual)))))
-                (error "Unknown qualifier `%s'" qual-name))))))))
+                           `((mapcar #'(lambda (x)
+                                         (and (,chk x)
+                                              (math-reject-arg x ',qual)))
+                                     ,var))
+                         `((and
+                            (,chk ,var)
+                            (math-reject-arg ,var ',qual)))))
+             (error "Unknown qualifier `%s'" qual-name))))))))

 
 (defun math-do-arg-list-check (args is-opt is-rest)
   (cond ((null args) nil)
 
 (defun math-do-arg-list-check (args is-opt is-rest)
   (cond ((null args) nil)


@@ -1981,7 +1943,7 @@ Redefine the corresponding command."
 (defun math-define-function-body (body env)
   (let ((body (math-define-body body env)))
     (if (math-body-refers-to body 'math-return)
 (defun math-define-function-body (body env)
   (let ((body (math-define-body body env)))
     (if (math-body-refers-to body 'math-return)

-       (list (cons 'catch (cons '(quote math-return) body)))
+       `((catch 'math-return ,@body))

       body)))
 
 ;; The variable math-exp-env is local to math-define-body, but is
       body)))
 
 ;; The variable math-exp-env is local to math-define-body, but is


@@ -2365,5 +2327,4 @@ Redefine the corresponding command."
 
 (provide 'calc-prog)
 
 
 (provide 'calc-prog)
 

-;; arch-tag: 4c5a183b-c9e5-4632-bb3f-e41a764518b0

 ;;; calc-prog.el ends here
 ;;; calc-prog.el ends here