(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 d60b277bca6250f99f378235b15b60010c772ac5..bfd21e27d05ba253c2d1297c6bb858bc4ae32860 100644 (file)
--- a/lisp/emacs-lisp/cl-extra.el
+++ b/lisp/emacs-lisp/cl-extra.el
@@ -1,9 +1,8 @@
-;;; cl-extra.el --- Common Lisp extensions for GNU Emacs Lisp (part two)
+;;; 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>
 
 ;; Author: Dave Gillespie <daveg@synaptics.com>

-;; Version: 2.02

 ;; Keywords: extensions
 
 ;; This file is part of GNU Emacs.
 ;; Keywords: extensions
 
 ;; This file is part of GNU Emacs.


@@ -19,8 +18,9 @@
 ;; GNU General Public License for more details.
 
 ;; You should have received a copy of the GNU General Public License
 ;; GNU General Public License for more details.
 
 ;; You should have received a copy of the GNU General Public License

-;; along with GNU Emacs; see the file COPYING.  If not, write to
-;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.

 
 ;;; Commentary:
 
 
 ;;; Commentary:
 


@@ -31,32 +31,17 @@
 ;; This package was written by Dave Gillespie; it is a complete
 ;; rewrite of Cesar Quiroz's original cl.el package of December 1986.
 ;;
 ;; This package was written by Dave Gillespie; it is a complete
 ;; rewrite of Cesar Quiroz's original cl.el package of December 1986.
 ;;

-;; This package works with Emacs 18, Emacs 19, and Lucid Emacs 19.
-;;

 ;; Bug reports, comments, and suggestions are welcome!
 
 ;; This file contains portions of the Common Lisp extensions
 ;; package which are autoloaded since they are relatively obscure.
 
 ;; Bug reports, comments, and suggestions are welcome!
 
 ;; This file contains portions of the Common Lisp extensions
 ;; package which are autoloaded since they are relatively obscure.
 

-;; See cl.el for Change Log.
-
-

 ;;; Code:
 
 (or (memq 'cl-19 features)
     (error "Tried to load `cl-extra' before `cl'!"))
 
 
 ;;; Code:
 
 (or (memq 'cl-19 features)
     (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)))))
-
-(defvar cl-emacs-type)
-
-

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


@@ -83,12 +68,13 @@ strings case-insensitively."
   (cond ((eq x y) t)
        ((stringp x)
         (and (stringp y) (= (length x) (length y))
   (cond ((eq x y) t)
        ((stringp x)
         (and (stringp y) (= (length x) (length y))

-             (or (equal x y)
-                 (equal (downcase x) (downcase y)))))   ; lazy but simple!
+             (or (string-equal x y)
+                 (string-equal (downcase x) (downcase y)))))   ; lazy but simple!

        ((numberp x)
         (and (numberp y) (= x y)))
        ((consp x)
        ((numberp x)
         (and (numberp y) (= x y)))
        ((consp x)

-        (while (and (consp x) (consp y) (equalp (cl-pop x) (cl-pop y))))
+        (while (and (consp x) (consp y) (equalp (car x) (car y)))
+          (setq x (cdr x) y (cdr y)))

         (and (not (consp x)) (equalp x y)))
        ((vectorp x)
         (and (vectorp y) (= (length x) (length y))
         (and (not (consp x)) (equalp x y)))
        ((vectorp x)
         (and (vectorp y) (= (length x) (length y))


@@ -118,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)


@@ -127,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))))
 


@@ -149,22 +135,22 @@ 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))))
 

-(defun mapc (cl-func cl-seq &rest cl-rest)
+(defun cl-mapc (cl-func cl-seq &rest cl-rest)

   "Like `mapcar', but does not accumulate values returned by the function."
   (if cl-rest
   "Like `mapcar', but does not accumulate values returned by the function."
   (if cl-rest

-      (apply 'map nil cl-func cl-seq cl-rest)
-    (mapcar cl-func cl-seq))
-  cl-seq)
+      (progn (apply 'map nil cl-func cl-seq cl-rest)
+            cl-seq)
+    (mapc cl-func cl-seq)))

 
 (defun mapl (cl-func cl-list &rest cl-rest)
   "Like `maplist', but does not accumulate values returned by the function."
 
 (defun mapl (cl-func cl-list &rest cl-rest)
   "Like `maplist', but does not accumulate values returned by the function."


@@ -193,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)


@@ -217,35 +203,19 @@ 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 (eq cl-emacs-type 'lucid) (funcall 'map-keymap cl-func 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
 
 (defun cl-map-keymap-recursively (cl-func-rec cl-map &optional cl-base)
   (or cl-base

-      (setq cl-base (copy-sequence (if (eq cl-emacs-type 18) "0" [0]))))
-  (cl-map-keymap
+      (setq cl-base (copy-sequence [0])))
+  (map-keymap

    (function
     (lambda (cl-key cl-bind)
       (aset cl-base (1- (length cl-base)) cl-key)
       (if (keymapp cl-bind)
          (cl-map-keymap-recursively
           cl-func-rec cl-bind
    (function
     (lambda (cl-key cl-bind)
       (aset cl-base (1- (length cl-base)) cl-key)
       (if (keymapp cl-bind)
          (cl-map-keymap-recursively
           cl-func-rec cl-bind

-          (funcall (if (eq cl-emacs-type 18) 'concat 'vconcat)
-                   cl-base (list 0)))
+          (vconcat cl-base (list 0)))

        (funcall cl-func-rec cl-base cl-bind))))
    cl-map))
 
        (funcall cl-func-rec cl-base cl-bind))))
    cl-map))
 


@@ -253,17 +223,15 @@ If so, return the true (non-nil) value returned by PREDICATE."
   (or cl-what (setq cl-what (current-buffer)))
   (if (bufferp cl-what)
       (let (cl-mark cl-mark2 (cl-next t) cl-next2)
   (or cl-what (setq cl-what (current-buffer)))
   (if (bufferp cl-what)
       (let (cl-mark cl-mark2 (cl-next t) cl-next2)

-       (save-excursion
-         (set-buffer cl-what)
+       (with-current-buffer cl-what

          (setq cl-mark (copy-marker (or cl-start (point-min))))
          (setq cl-mark2 (and cl-end (copy-marker cl-end))))
        (while (and cl-next (or (not cl-mark2) (< cl-mark cl-mark2)))
          (setq cl-mark (copy-marker (or cl-start (point-min))))
          (setq cl-mark2 (and cl-end (copy-marker cl-end))))
        (while (and cl-next (or (not cl-mark2) (< cl-mark cl-mark2)))

-         (setq cl-next (and (fboundp 'next-property-change)
-                            (if cl-prop (next-single-property-change
-                                         cl-mark cl-prop cl-what)
-                              (next-property-change cl-mark cl-what)))
-               cl-next2 (or cl-next (save-excursion
-                                      (set-buffer cl-what) (point-max))))
+         (setq cl-next (if cl-prop (next-single-property-change
+                                    cl-mark cl-prop cl-what)
+                         (next-property-change cl-mark cl-what))
+               cl-next2 (or cl-next (with-current-buffer cl-what
+                                      (point-max))))

          (funcall cl-func (prog1 (marker-position cl-mark)
                             (set-marker cl-mark cl-next2))
                   (if cl-mark2 (min cl-next2 cl-mark2) cl-next2)))
          (funcall cl-func (prog1 (marker-position cl-mark)
                             (set-marker cl-mark cl-next2))
                   (if cl-mark2 (min cl-next2 cl-mark2) cl-next2)))


@@ -271,10 +239,9 @@ If so, return the true (non-nil) value returned by PREDICATE."
     (or cl-start (setq cl-start 0))
     (or cl-end (setq cl-end (length cl-what)))
     (while (< cl-start cl-end)
     (or cl-start (setq cl-start 0))
     (or cl-end (setq cl-end (length cl-what)))
     (while (< cl-start cl-end)

-      (let ((cl-next (or (and (fboundp 'next-property-change)
-                             (if cl-prop (next-single-property-change
-                                          cl-start cl-prop cl-what)
-                               (next-property-change cl-start cl-what)))
+      (let ((cl-next (or (if cl-prop (next-single-property-change
+                                     cl-start cl-prop cl-what)
+                          (next-property-change cl-start cl-what))

                         cl-end)))
        (funcall cl-func cl-start (min cl-next cl-end))
        (setq cl-start cl-next)))))
                         cl-end)))
        (funcall cl-func cl-start (min cl-next cl-end))
        (setq cl-start cl-next)))))


@@ -285,8 +252,7 @@ If so, return the true (non-nil) value returned by PREDICATE."
 
       ;; This is the preferred algorithm, though overlay-lists is undocumented.
       (let (cl-ovl)
 
       ;; This is the preferred algorithm, though overlay-lists is undocumented.
       (let (cl-ovl)

-       (save-excursion
-         (set-buffer cl-buffer)
+       (with-current-buffer cl-buffer

          (setq cl-ovl (overlay-lists))
          (if cl-start (setq cl-start (copy-marker cl-start)))
          (if cl-end (setq cl-end (copy-marker cl-end))))
          (setq cl-ovl (overlay-lists))
          (if cl-start (setq cl-start (copy-marker cl-start)))
          (if cl-end (setq cl-end (copy-marker cl-end))))


@@ -301,10 +267,10 @@ If so, return the true (non-nil) value returned by PREDICATE."
        (if cl-end (set-marker cl-end nil)))
 
     ;; This alternate algorithm fails to find zero-length overlays.
        (if cl-end (set-marker cl-end nil)))
 
     ;; This alternate algorithm fails to find zero-length overlays.

-    (let ((cl-mark (save-excursion (set-buffer cl-buffer)
-                                  (copy-marker (or cl-start (point-min)))))
-         (cl-mark2 (and cl-end (save-excursion (set-buffer cl-buffer)
-                                               (copy-marker cl-end))))
+    (let ((cl-mark (with-current-buffer cl-buffer
+                    (copy-marker (or cl-start (point-min)))))
+         (cl-mark2 (and cl-end (with-current-buffer cl-buffer
+                                 (copy-marker cl-end))))

          cl-pos cl-ovl)
       (while (save-excursion
               (and (setq cl-pos (marker-position cl-mark))
          cl-pos cl-ovl)
       (while (save-excursion
               (and (setq cl-pos (marker-position cl-mark))


@@ -331,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))
 


@@ -360,30 +326,23 @@ 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)))
 
 (defun isqrt (a)
   "Return the integer square root of the argument."
   (if (and (integerp a) (> a 0))
          (setq a (* (/ a (gcd a b)) b))))
       a)))
 
 (defun isqrt (a)
   "Return the integer square root of the argument."
   (if (and (integerp a) (> a 0))

-      (let ((g (cond ((>= a 1000000) 10000) ((>= a 10000) 1000)
-                    ((>= a 100) 100) (t 10)))
+      (let ((g (cond ((<= a 100) 10) ((<= a 10000) 100)
+                    ((<= a 1000000) 1000) (t a)))

            g2)
        (while (< (setq g2 (/ (+ g (/ a g)) 2)) g)
          (setq g g2))
        g)
     (if (eq a 0) 0 (signal 'arith-error nil))))
 
            g2)
        (while (< (setq g2 (/ (+ g (/ a g)) 2)) g)
          (setq g g2))
        g)
     (if (eq a 0) 0 (signal 'arith-error nil))))
 

-(defun cl-expt (x y)
-  "Return X raised to the power of Y.  Works only for integer arguments."
-  (if (<= y 0) (if (= y 0) 1 (if (memq x '(-1 1)) x 0))
-    (* (if (= (% y 2) 0) 1 x) (cl-expt (* x x) (/ y 2)))))
-(or (and (fboundp 'expt) (subrp (symbol-function 'expt)))
-    (defalias 'expt 'cl-expt))
-

 (defun floor* (x &optional y)
   "Return a list of the floor of X and the fractional part of X.
 With two arguments, return floor and remainder of their quotient."
 (defun floor* (x &optional y)
   "Return a list of the floor of X and the fractional part of X.
 With two arguments, return floor and remainder of their quotient."


@@ -542,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


@@ -585,25 +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.
-Constrast 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)
-(or (and (fboundp 'copy-tree) (subrp (symbol-function 'copy-tree)))
-    (defalias 'copy-tree 'cl-copy-tree))
+(defalias 'cl-copy-tree 'copy-tree)

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


@@ -622,7 +563,13 @@ argument VECP, this copies vectors as well as conses."
 PROPLIST is a list of the sort returned by `symbol-plist'."
   (setplist '--cl-getf-symbol-- plist)
   (or (get '--cl-getf-symbol-- tag)
 PROPLIST is a list of the sort returned by `symbol-plist'."
   (setplist '--cl-getf-symbol-- plist)
   (or (get '--cl-getf-symbol-- tag)

-      (and def (get* '--cl-getf-symbol-- tag def))))
+      ;; Originally we called get* here,
+      ;; but that fails, because get* has a compiler macro
+      ;; definition that uses getf!
+      (when def
+       (while (and plist (not (eq (car plist) tag)))
+         (setq plist (cdr (cdr plist))))
+       (if plist (car (cdr plist)) def))))

 
 (defun cl-set-getf (plist tag val)
   (let ((p plist))
 
 (defun cl-set-getf (plist tag val)
   (let ((p plist))


@@ -640,148 +587,31 @@ PROPLIST is a list of the sort returned by `symbol-plist'."
     (if (and plist (eq tag (car plist)))
        (progn (setplist sym (cdr (cdr plist))) t)
       (cl-do-remf plist tag))))
     (if (and plist (eq tag (car plist)))
        (progn (setplist sym (cdr (cdr plist))) t)
       (cl-do-remf plist tag))))

-(or (and (fboundp 'remprop) (subrp (symbol-function 'remprop)))
-    (defalias 'remprop 'cl-remprop))
+(defalias 'remprop 'cl-remprop)

 
 
 
 ;;; Hash tables.
 
 
 
 ;;; Hash tables.

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

 
 

-(defun make-hash-table (&rest cl-keys)
-  "Make an empty Common Lisp-style hash-table.
-If :test is `eq', this can use Lucid Emacs built-in hash-tables.
-In non-Lucid Emacs, or with non-`eq' test, this internally uses a-lists.
-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)))
-    (if (and (eq cl-test 'eq) (fboundp 'make-hashtable))
-       (funcall 'make-hashtable cl-size)
-      (list 'cl-hash-table-tag cl-test
-           (if (> cl-size 1) (make-vector cl-size 0)
-             (let ((sym (make-symbol "--hashsym--"))) (set sym nil) sym))
-           0))))
-
-(defvar cl-lucid-hash-tag
-  (if (and (fboundp 'make-hashtable) (vectorp (make-hashtable 1)))
-      (aref (make-hashtable 1) 0) (make-symbol "--cl-hash-tag--")))
-
-(defun hash-table-p (x)
-  "Return t if OBJECT is a hash table."
-  (or (eq (car-safe x) 'cl-hash-table-tag)
-      (and (vectorp x) (= (length x) 4) (eq (aref x 0) cl-lucid-hash-tag))
-      (and (fboundp 'hashtablep) (funcall 'hashtablep x))))
-
+;; No idea if this might still be needed.

 (defun cl-not-hash-table (x &optional y &rest z)
 (defun cl-not-hash-table (x &optional y &rest z)

-  (signal 'wrong-type-argument (list '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)))
-
-(defvar cl-builtin-gethash
-  (if (and (fboundp 'gethash) (subrp (symbol-function 'gethash)))
-      (symbol-function 'gethash) 'cl-not-hash-table))
-(defvar cl-builtin-remhash
-  (if (and (fboundp 'remhash) (subrp (symbol-function 'remhash)))
-      (symbol-function 'remhash) 'cl-not-hash-table))
-(defvar cl-builtin-clrhash
-  (if (and (fboundp 'clrhash) (subrp (symbol-function 'clrhash)))
-      (symbol-function 'clrhash) 'cl-not-hash-table))
-(defvar cl-builtin-maphash
-  (if (and (fboundp 'maphash) (subrp (symbol-function 'maphash)))
-      (symbol-function 'maphash) 'cl-not-hash-table))
-
-(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))
-    (funcall cl-builtin-gethash key table def)))
-(defalias 'gethash 'cl-gethash)
-
-(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 (funcall cl-builtin-gethash key table '--cl--) '--cl--))
-      (funcall cl-builtin-remhash key table))))
-(defalias 'remhash 'cl-remhash)
-
-(defun cl-clrhash (table)
-  "Clear HASH-TABLE."
-  (if (consp table)
-      (progn
-       (or (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))
-    (funcall cl-builtin-clrhash table))
-  nil)
-(defalias 'clrhash 'cl-clrhash)
-
-(defun cl-maphash (cl-func cl-table)
-  "Call FUNCTION on keys and values from HASH-TABLE."
-  (or (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)))
-    (funcall cl-builtin-maphash cl-func cl-table)))
-(defalias 'maphash 'cl-maphash)
-
-(defun hash-table-count (table)
-  "Return the number of entries in HASH-TABLE."
-  (or (hash-table-p table) (cl-not-hash-table table))
-  (if (consp table) (nth 3 table) (funcall 'hashtable-fullness table)))
-
+  (signal 'wrong-type-argument (list 'cl-hash-table-p (or y x))))
+
+(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.
 


@@ -841,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)))


@@ -870,25 +700,28 @@ 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)))
                                             cl-closure-vars)
                                     '((quote --cl-rest--)))))))
                 (list (car form) (list* 'lambda (cadadr form) body))))
                              (nconc (mapcar (function
                                              (lambda (x)
                                                (list 'list '(quote quote) x)))
                                             cl-closure-vars)
                                     '((quote --cl-rest--)))))))
                 (list (car form) (list* 'lambda (cadadr form) body))))

-          form))
+          (let ((found (assq (cadr form) env)))
+            (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))
         (list* (car form) (nth 1 form) (cl-macroexpand-body (cddr form) env)))
        ((and (eq (car form) 'progn) (not (cddr form)))
        ((memq (car form) '(defun defmacro))
         (list* (car form) (nth 1 form) (cl-macroexpand-body (cddr form) env)))
        ((and (eq (car form) 'progn) (not (cddr form)))


@@ -916,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