(ewoc-create, ewoc-map, ewoc-locate, ewoc-invalidate, ewoc-collect):

[gnu-emacs] / lisp / emacs-lisp / cl-extra.el

diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el
index 1784d65a9b65560ef4af09b8917e484d913b7af0..bfd21e27d05ba253c2d1297c6bb858bc4ae32860 100644 (file)
--- a/lisp/emacs-lisp/cl-extra.el
+++ b/lisp/emacs-lisp/cl-extra.el
@@ -1,6 +1,6 @@
 ;;; cl-extra.el --- Common Lisp features, part 2 -*-byte-compile-dynamic: t;-*-
 
 ;;; cl-extra.el --- Common Lisp features, part 2 -*-byte-compile-dynamic: t;-*-
 

-;; Copyright (C) 1993 Free Software Foundation, Inc.
+;; Copyright (C) 1993,2000,2003  Free Software Foundation, Inc.

 
 ;; Author: Dave Gillespie <daveg@synaptics.com>
 ;; Keywords: extensions
 
 ;; Author: Dave Gillespie <daveg@synaptics.com>
 ;; Keywords: extensions


@@ -42,13 +42,6 @@
     (error "Tried to load `cl-extra' before `cl'!"))
 
 
     (error "Tried to load `cl-extra' before `cl'!"))
 
 

-;;; We define these here so that this file can compile without having
-;;; loaded the cl.el file already.
-
-(defmacro cl-push (x place) (list 'setq place (list 'cons x place)))
-(defmacro cl-pop (place)
-  (list 'car (list 'prog1 place (list 'setq place (list 'cdr place)))))
-

 ;;; Type coercion.
 
 (defun coerce (x type)
 ;;; Type coercion.
 
 (defun coerce (x type)


@@ -111,7 +104,7 @@ strings case-insensitively."
                          (setcar cl-p1 (cdr (car cl-p1))))
                      (aref (car cl-p1) cl-i)))
            (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2)))
                          (setcar cl-p1 (cdr (car cl-p1))))
                      (aref (car cl-p1) cl-i)))
            (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2)))

-         (cl-push (apply cl-func cl-args) cl-res)
+         (push (apply cl-func cl-args) cl-res)

          (setq cl-i (1+ cl-i)))
        (nreverse cl-res))
     (let ((cl-res nil)
          (setq cl-i (1+ cl-i)))
        (nreverse cl-res))
     (let ((cl-res nil)


@@ -120,9 +113,9 @@ strings case-insensitively."
       (let ((cl-n (min (length cl-x) (length cl-y)))
            (cl-i -1))
        (while (< (setq cl-i (1+ cl-i)) cl-n)
       (let ((cl-n (min (length cl-x) (length cl-y)))
            (cl-i -1))
        (while (< (setq cl-i (1+ cl-i)) cl-n)

-         (cl-push (funcall cl-func
-                           (if (consp cl-x) (cl-pop cl-x) (aref cl-x cl-i))
-                           (if (consp cl-y) (cl-pop cl-y) (aref cl-y cl-i)))
+         (push (funcall cl-func
+                           (if (consp cl-x) (pop cl-x) (aref cl-x cl-i))
+                           (if (consp cl-y) (pop cl-y) (aref cl-y cl-i)))

                   cl-res)))
       (nreverse cl-res))))
 
                   cl-res)))
       (nreverse cl-res))))
 


@@ -142,13 +135,13 @@ the elements themselves."
            (cl-args (cons cl-list (copy-sequence cl-rest)))
            cl-p)
        (while (not (memq nil cl-args))
            (cl-args (cons cl-list (copy-sequence cl-rest)))
            cl-p)
        (while (not (memq nil cl-args))

-         (cl-push (apply cl-func cl-args) cl-res)
+         (push (apply cl-func cl-args) cl-res)

          (setq cl-p cl-args)
          (setq cl-p cl-args)

-         (while cl-p (setcar cl-p (cdr (cl-pop cl-p)) )))
+         (while cl-p (setcar cl-p (cdr (pop cl-p)) )))

        (nreverse cl-res))
     (let ((cl-res nil))
       (while cl-list
        (nreverse cl-res))
     (let ((cl-res nil))
       (while cl-list

-       (cl-push (funcall cl-func cl-list) cl-res)
+       (push (funcall cl-func cl-list) cl-res)

        (setq cl-list (cdr cl-list)))
       (nreverse cl-res))))
 
        (setq cl-list (cdr cl-list)))
       (nreverse cl-res))))
 


@@ -186,7 +179,7 @@ If so, return the true (non-nil) value returned by PREDICATE."
                             (if cl-res (throw 'cl-some cl-res)))))
               cl-seq cl-rest) nil)
     (let ((cl-x nil))
                             (if cl-res (throw 'cl-some cl-res)))))
               cl-seq cl-rest) nil)
     (let ((cl-x nil))

-      (while (and cl-seq (not (setq cl-x (funcall cl-pred (cl-pop cl-seq))))))
+      (while (and cl-seq (not (setq cl-x (funcall cl-pred (pop cl-seq))))))

       cl-x)))
 
 (defun every (cl-pred cl-seq &rest cl-rest)
       cl-x)))
 
 (defun every (cl-pred cl-seq &rest cl-rest)


@@ -210,26 +203,12 @@ If so, return the true (non-nil) value returned by PREDICATE."
   (not (apply 'every cl-pred cl-seq cl-rest)))
 
 ;;; Support for `loop'.
   (not (apply 'every cl-pred cl-seq cl-rest)))
 
 ;;; Support for `loop'.

-(defun cl-map-keymap (cl-func cl-map)
-  (while (symbolp cl-map) (setq cl-map (symbol-function cl-map)))
-  (if (listp cl-map)
-      (let ((cl-p cl-map))
-       (while (consp (setq cl-p (cdr cl-p)))
-         (cond ((consp (car cl-p))
-                (funcall cl-func (car (car cl-p)) (cdr (car cl-p))))
-               ((vectorp (car cl-p))
-                (cl-map-keymap cl-func (car cl-p)))
-               ((eq (car cl-p) 'keymap)
-                (setq cl-p nil)))))
-    (let ((cl-i -1))
-      (while (< (setq cl-i (1+ cl-i)) (length cl-map))
-       (if (aref cl-map cl-i)
-           (funcall cl-func cl-i (aref cl-map cl-i)))))))
+(defalias 'cl-map-keymap 'map-keymap)

 
 (defun cl-map-keymap-recursively (cl-func-rec cl-map &optional cl-base)
   (or cl-base
       (setq cl-base (copy-sequence [0])))
 
 (defun cl-map-keymap-recursively (cl-func-rec cl-map &optional cl-base)
   (or cl-base
       (setq cl-base (copy-sequence [0])))

-  (cl-map-keymap
+  (map-keymap

    (function
     (lambda (cl-key cl-bind)
       (aset cl-base (1- (length cl-base)) cl-key)
    (function
     (lambda (cl-key cl-bind)
       (aset cl-base (1- (length cl-base)) cl-key)


@@ -318,28 +297,28 @@ If so, return the true (non-nil) value returned by PREDICATE."
 (defvar cl-progv-save)
 (defun cl-progv-before (syms values)
   (while syms
 (defvar cl-progv-save)
 (defun cl-progv-before (syms values)
   (while syms

-    (cl-push (if (boundp (car syms))
+    (push (if (boundp (car syms))

                 (cons (car syms) (symbol-value (car syms)))
               (car syms)) cl-progv-save)
     (if values
                 (cons (car syms) (symbol-value (car syms)))
               (car syms)) cl-progv-save)
     (if values

-       (set (cl-pop syms) (cl-pop values))
-      (makunbound (cl-pop syms)))))
+       (set (pop syms) (pop values))
+      (makunbound (pop syms)))))

 
 (defun cl-progv-after ()
   (while cl-progv-save
     (if (consp (car cl-progv-save))
        (set (car (car cl-progv-save)) (cdr (car cl-progv-save)))
       (makunbound (car cl-progv-save)))
 
 (defun cl-progv-after ()
   (while cl-progv-save
     (if (consp (car cl-progv-save))
        (set (car (car cl-progv-save)) (cdr (car cl-progv-save)))
       (makunbound (car cl-progv-save)))

-    (cl-pop cl-progv-save)))
+    (pop cl-progv-save)))

 
 
 ;;; Numbers.
 
 (defun gcd (&rest args)
   "Return the greatest common divisor of the arguments."
 
 
 ;;; Numbers.
 
 (defun gcd (&rest args)
   "Return the greatest common divisor of the arguments."

-  (let ((a (abs (or (cl-pop args) 0))))
+  (let ((a (abs (or (pop args) 0))))

     (while args
     (while args

-      (let ((b (abs (cl-pop args))))
+      (let ((b (abs (pop args))))

        (while (> b 0) (setq b (% a (setq a b))))))
     a))
 
        (while (> b 0) (setq b (% a (setq a b))))))
     a))
 


@@ -347,9 +326,9 @@ If so, return the true (non-nil) value returned by PREDICATE."
   "Return the least common multiple of the arguments."
   (if (memq 0 args)
       0
   "Return the least common multiple of the arguments."
   (if (memq 0 args)
       0

-    (let ((a (abs (or (cl-pop args) 1))))
+    (let ((a (abs (or (pop args) 1))))

       (while args
       (while args

-       (let ((b (abs (cl-pop args))))
+       (let ((b (abs (pop args))))

          (setq a (* (/ a (gcd a b)) b))))
       a)))
 
          (setq a (* (/ a (gcd a b)) b))))
       a)))
 


@@ -522,7 +501,7 @@ If START or END is negative, it counts from the end."
             (if end
                 (let ((res nil))
                   (while (>= (setq end (1- end)) start)
             (if end
                 (let ((res nil))
                   (while (>= (setq end (1- end)) start)

-                    (cl-push (cl-pop seq) res))
+                    (push (pop seq) res))

                   (nreverse res))
               (copy-sequence seq)))
            (t
                   (nreverse res))
               (copy-sequence seq)))
            (t


@@ -565,24 +544,7 @@ If START or END is negative, it counts from the end."
     (setq list (cdr list)))
   (if (numberp sublist) (equal sublist list) (eq sublist list)))
 
     (setq list (cdr list)))
   (if (numberp sublist) (equal sublist list) (eq sublist list)))
 

-(defun cl-copy-tree (tree &optional vecp)
-  "Make a copy of TREE.
-If TREE is a cons cell, this recursively copies both its car and its cdr.
-Contrast to copy-sequence, which copies only along the cdrs.  With second
-argument VECP, this copies vectors as well as conses."
-  (if (consp tree)
-      (let ((p (setq tree (copy-list tree))))
-       (while (consp p)
-         (if (or (consp (car p)) (and vecp (vectorp (car p))))
-             (setcar p (cl-copy-tree (car p) vecp)))
-         (or (listp (cdr p)) (setcdr p (cl-copy-tree (cdr p) vecp)))
-         (cl-pop p)))
-    (if (and vecp (vectorp tree))
-       (let ((i (length (setq tree (copy-sequence tree)))))
-         (while (>= (setq i (1- i)) 0)
-           (aset tree i (cl-copy-tree (aref tree i) vecp))))))
-  tree)
-(defalias 'copy-tree 'cl-copy-tree)
+(defalias 'cl-copy-tree 'copy-tree)

 
 
 ;;; Property lists.
 
 
 ;;; Property lists.


@@ -630,115 +592,26 @@ PROPLIST is a list of the sort returned by `symbol-plist'."
 
 
 ;;; Hash tables.
 
 
 ;;; Hash tables.

+;; This is just kept for compatibility with code byte-compiled by Emacs-20.

 
 

-(defun cl-make-hash-table (&rest cl-keys)
-  "Make an empty Common Lisp-style hash-table.
-Keywords supported:  :test :size
-The Common Lisp keywords :rehash-size and :rehash-threshold are ignored."
-  (let ((cl-test (or (car (cdr (memq :test cl-keys))) 'eql))
-       (cl-size (or (car (cdr (memq :size cl-keys))) 20)))
-    (make-hash-table :size cl-size :test cl-size)))
-
-(defun cl-hash-table-p (x)
-  "Return t if OBJECT is a hash table."
-  (or (hash-table-p x)
-      (eq (car-safe x) 'cl-hash-table-tag)))
-
+;; No idea if this might still be needed.

 (defun cl-not-hash-table (x &optional y &rest z)
   (signal 'wrong-type-argument (list 'cl-hash-table-p (or y x))))
 
 (defun cl-not-hash-table (x &optional y &rest z)
   (signal 'wrong-type-argument (list 'cl-hash-table-p (or y x))))
 

-(defun cl-hash-lookup (key table)
-  (or (eq (car-safe table) 'cl-hash-table-tag) (cl-not-hash-table table))
-  (let* ((array (nth 2 table)) (test (car (cdr table))) (str key) sym)
-    (if (symbolp array) (setq str nil sym (symbol-value array))
-      (while (or (consp str) (and (vectorp str) (> (length str) 0)))
-       (setq str (elt str 0)))
-      (cond ((stringp str) (if (eq test 'equalp) (setq str (downcase str))))
-           ((symbolp str) (setq str (symbol-name str)))
-           ((and (numberp str) (> str -8000000) (< str 8000000))
-            (or (integerp str) (setq str (truncate str)))
-            (setq str (aref ["0" "1" "2" "3" "4" "5" "6" "7" "8" "9" "10"
-                             "11" "12" "13" "14" "15"] (logand str 15))))
-           (t (setq str "*")))
-      (setq sym (symbol-value (intern-soft str array))))
-    (list (and sym (cond ((or (eq test 'eq)
-                             (and (eq test 'eql) (not (numberp key))))
-                         (assq key sym))
-                        ((memq test '(eql equal)) (assoc key sym))
-                        (t (assoc* key sym :test test))))
-         sym str)))
-
-(defun cl-gethash (key table &optional def)
-  "Look up KEY in HASH-TABLE; return corresponding value, or DEFAULT."
-  (if (consp table)
-      (let ((found (cl-hash-lookup key table)))
-       (if (car found) (cdr (car found)) def))
-    (gethash key table def)))
-
-(defun cl-puthash (key val table)
-  (if (consp table)
-      (let ((found (cl-hash-lookup key table)))
-       (if (car found) (setcdr (car found) val)
-         (if (nth 2 found)
-             (progn
-               (if (> (nth 3 table) (* (length (nth 2 table)) 3))
-                   (let ((new-table (make-vector (nth 3 table) 0)))
-                     (mapatoms (function
-                                (lambda (sym)
-                                  (set (intern (symbol-name sym) new-table)
-                                       (symbol-value sym))))
-                               (nth 2 table))
-                     (setcar (cdr (cdr table)) new-table)))
-               (set (intern (nth 2 found) (nth 2 table))
-                    (cons (cons key val) (nth 1 found))))
-           (set (nth 2 table) (cons (cons key val) (nth 1 found))))
-         (setcar (cdr (cdr (cdr table))) (1+ (nth 3 table)))))
-    (funcall 'puthash key val table)) val)
-
-(defun cl-remhash (key table)
-  "Remove KEY from HASH-TABLE."
-  (if (consp table)
-      (let ((found (cl-hash-lookup key table)))
-       (and (car found)
-            (let ((del (delq (car found) (nth 1 found))))
-              (setcar (cdr (cdr (cdr table))) (1- (nth 3 table)))
-              (if (nth 2 found) (set (intern (nth 2 found) (nth 2 table)) del)
-                (set (nth 2 table) del)) t)))
-    (prog1 (not (eq (gethash key table '--cl--) '--cl--))
-      (remhash key table))))
-
-(defun cl-clrhash (table)
-  "Clear HASH-TABLE."
-  (if (consp table)
-      (progn
-       (or (cl-hash-table-p table) (cl-not-hash-table table))
-       (if (symbolp (nth 2 table)) (set (nth 2 table) nil)
-         (setcar (cdr (cdr table)) (make-vector (length (nth 2 table)) 0)))
-       (setcar (cdr (cdr (cdr table))) 0))
-    (clrhash table))
-  nil)
-
-(defun cl-maphash (cl-func cl-table)
-  "Call FUNCTION on keys and values from HASH-TABLE."
-  (or (cl-hash-table-p cl-table) (cl-not-hash-table cl-table))
-  (if (consp cl-table)
-      (mapatoms (function (lambda (cl-x)
-                           (setq cl-x (symbol-value cl-x))
-                           (while cl-x
-                             (funcall cl-func (car (car cl-x))
-                                      (cdr (car cl-x)))
-                             (setq cl-x (cdr cl-x)))))
-               (if (symbolp (nth 2 cl-table))
-                   (vector (nth 2 cl-table)) (nth 2 cl-table)))
-    (maphash cl-func cl-table)))
-
-(defun cl-hash-table-count (table)
-  "Return the number of entries in HASH-TABLE."
-  (or (cl-hash-table-p table) (cl-not-hash-table table))
-  (if (consp table)
-      (nth 3 table)
-    (hash-table-count table)))
-
+(defvar cl-builtin-gethash (symbol-function 'gethash))
+(defvar cl-builtin-remhash (symbol-function 'remhash))
+(defvar cl-builtin-clrhash (symbol-function 'clrhash))
+(defvar cl-builtin-maphash (symbol-function 'maphash))
+
+(defalias 'cl-gethash 'gethash)
+(defalias 'cl-puthash 'puthash)
+(defalias 'cl-remhash 'remhash)
+(defalias 'cl-clrhash 'clrhash)
+(defalias 'cl-maphash 'maphash)
+;; These three actually didn't exist in Emacs-20.
+(defalias 'cl-make-hash-table 'make-hash-table)
+(defalias 'cl-hash-table-p 'hash-table-p)
+(defalias 'cl-hash-table-count 'hash-table-count)

 
 ;;; Some debugging aids.
 
 
 ;;; Some debugging aids.
 


@@ -798,7 +671,7 @@ This also does some trivial optimizations to make the form prettier."
             (cl-macroexpand-all (cons 'progn (cddr form)) env)
           (let ((letf nil) (res nil) (lets (cadr form)))
             (while lets
             (cl-macroexpand-all (cons 'progn (cddr form)) env)
           (let ((letf nil) (res nil) (lets (cadr form)))
             (while lets

-              (cl-push (if (consp (car lets))
+              (push (if (consp (car lets))

                            (let ((exp (cl-macroexpand-all (caar lets) env)))
                              (or (symbolp exp) (setq letf t))
                              (cons exp (cl-macroexpand-body (cdar lets) env)))
                            (let ((exp (cl-macroexpand-all (caar lets) env)))
                              (or (symbolp exp) (setq letf t))
                              (cons exp (cl-macroexpand-body (cdar lets) env)))


@@ -827,18 +700,17 @@ This also does some trivial optimizations to make the form prettier."
                          (sub (pairlis cl-closure-vars new)) (decls nil))
                     (while (or (stringp (car body))
                                (eq (car-safe (car body)) 'interactive))
                          (sub (pairlis cl-closure-vars new)) (decls nil))
                     (while (or (stringp (car body))
                                (eq (car-safe (car body)) 'interactive))

-                      (cl-push (list 'quote (cl-pop body)) decls))
+                      (push (list 'quote (pop body)) decls))

                     (put (car (last cl-closure-vars)) 'used t)
                     (append
                      (list 'list '(quote lambda) '(quote (&rest --cl-rest--)))
                      (sublis sub (nreverse decls))
                      (list
                       (list* 'list '(quote apply)
                     (put (car (last cl-closure-vars)) 'used t)
                     (append
                      (list 'list '(quote lambda) '(quote (&rest --cl-rest--)))
                      (sublis sub (nreverse decls))
                      (list
                       (list* 'list '(quote apply)

-                             (list 'list '(quote quote)
-                                   (list 'function
-                                         (list* 'lambda
-                                                (append new (cadadr form))
-                                                (sublis sub body))))
+                             (list 'function
+                                   (list* 'lambda
+                                          (append new (cadadr form))
+                                          (sublis sub body)))

                              (nconc (mapcar (function
                                              (lambda (x)
                                                (list 'list '(quote quote) x)))
                              (nconc (mapcar (function
                                              (lambda (x)
                                                (list 'list '(quote quote) x)))


@@ -846,7 +718,8 @@ This also does some trivial optimizations to make the form prettier."
                                     '((quote --cl-rest--)))))))
                 (list (car form) (list* 'lambda (cadadr form) body))))
           (let ((found (assq (cadr form) env)))
                                     '((quote --cl-rest--)))))))
                 (list (car form) (list* 'lambda (cadadr form) body))))
           (let ((found (assq (cadr form) env)))

-            (if (eq (cadr (caddr found)) 'cl-labels-args)
+            (if (and found (ignore-errors
+                             (eq (cadr (caddr found)) 'cl-labels-args)))

                 (cl-macroexpand-all (cadr (caddr (cadddr found))) env)
               form))))
        ((memq (car form) '(defun defmacro))
                 (cl-macroexpand-all (cadr (caddr (cadddr found))) env)
               form))))
        ((memq (car form) '(defun defmacro))


@@ -876,4 +749,5 @@ This also does some trivial optimizations to make the form prettier."
 
 (run-hooks 'cl-extra-load-hook)
 
 
 (run-hooks 'cl-extra-load-hook)
 

+;;; arch-tag: bcd03437-0871-43fb-a8f1-ad0e0b5427ed

 ;;; cl-extra.el ends here
 ;;; cl-extra.el ends here