[Emacs-diffs] Changes to emacs/lisp/emacs-lisp/cl-extra.el

[Miles Bader]

Index: emacs/lisp/emacs-lisp/cl-extra.el
diff -c emacs/lisp/emacs-lisp/cl-extra.el:1.22 
emacs/lisp/emacs-lisp/cl-extra.el:1.23
*** emacs/lisp/emacs-lisp/cl-extra.el:1.22      Sat Jun  8 18:32:06 2002
--- emacs/lisp/emacs-lisp/cl-extra.el   Fri Sep 27 18:32:48 2002
***************
*** 42,54 ****
      (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)
--- 42,47 ----
***************
*** 111,117 ****
                          (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)
          (setq cl-i (1+ cl-i)))
        (nreverse cl-res))
      (let ((cl-res nil)
--- 104,110 ----
                          (setcar cl-p1 (cdr (car cl-p1))))
                      (aref (car cl-p1) cl-i)))
            (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2)))
!         (push (apply cl-func cl-args) cl-res)
          (setq cl-i (1+ cl-i)))
        (nreverse cl-res))
      (let ((cl-res nil)
***************
*** 120,128 ****
        (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)))
                   cl-res)))
        (nreverse cl-res))))
  
--- 113,121 ----
        (let ((cl-n (min (length cl-x) (length cl-y)))
            (cl-i -1))
        (while (< (setq cl-i (1+ cl-i)) cl-n)
!         (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))))
  
***************
*** 142,154 ****
            (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)
          (setq cl-p cl-args)
!         (while cl-p (setcar cl-p (cdr (cl-pop cl-p)) )))
        (nreverse cl-res))
      (let ((cl-res nil))
        (while cl-list
!       (cl-push (funcall cl-func cl-list) cl-res)
        (setq cl-list (cdr cl-list)))
        (nreverse cl-res))))
  
--- 135,147 ----
            (cl-args (cons cl-list (copy-sequence cl-rest)))
            cl-p)
        (while (not (memq nil cl-args))
!         (push (apply cl-func cl-args) cl-res)
          (setq cl-p cl-args)
!         (while cl-p (setcar cl-p (cdr (pop cl-p)) )))
        (nreverse cl-res))
      (let ((cl-res nil))
        (while cl-list
!       (push (funcall cl-func cl-list) cl-res)
        (setq cl-list (cdr cl-list)))
        (nreverse cl-res))))
  
***************
*** 186,192 ****
                             (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))))))
        cl-x)))
  
  (defun every (cl-pred cl-seq &rest cl-rest)
--- 179,185 ----
                             (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 (pop cl-seq))))))
        cl-x)))
  
  (defun every (cl-pred cl-seq &rest cl-rest)
***************
*** 318,345 ****
  (defvar cl-progv-save)
  (defun cl-progv-before (syms values)
    (while syms
!     (cl-push (if (boundp (car syms))
                 (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)))))
  
  (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)))
  
  
  ;;; Numbers.
  
  (defun gcd (&rest args)
    "Return the greatest common divisor of the arguments."
!   (let ((a (abs (or (cl-pop args) 0))))
      (while args
!       (let ((b (abs (cl-pop args))))
        (while (> b 0) (setq b (% a (setq a b))))))
      a))
  
--- 311,338 ----
  (defvar cl-progv-save)
  (defun cl-progv-before (syms values)
    (while syms
!     (push (if (boundp (car syms))
                 (cons (car syms) (symbol-value (car syms)))
               (car syms)) cl-progv-save)
      (if values
!       (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)))
!     (pop cl-progv-save)))
  
  
  ;;; Numbers.
  
  (defun gcd (&rest args)
    "Return the greatest common divisor of the arguments."
!   (let ((a (abs (or (pop args) 0))))
      (while args
!       (let ((b (abs (pop args))))
        (while (> b 0) (setq b (% a (setq a b))))))
      a))
  
***************
*** 347,355 ****
    "Return the least common multiple of the arguments."
    (if (memq 0 args)
        0
!     (let ((a (abs (or (cl-pop args) 1))))
        (while args
!       (let ((b (abs (cl-pop args))))
          (setq a (* (/ a (gcd a b)) b))))
        a)))
  
--- 340,348 ----
    "Return the least common multiple of the arguments."
    (if (memq 0 args)
        0
!     (let ((a (abs (or (pop args) 1))))
        (while args
!       (let ((b (abs (pop args))))
          (setq a (* (/ a (gcd a b)) b))))
        a)))
  
***************
*** 522,528 ****
             (if end
                 (let ((res nil))
                   (while (>= (setq end (1- end)) start)
!                    (cl-push (cl-pop seq) res))
                   (nreverse res))
               (copy-sequence seq)))
            (t
--- 515,521 ----
             (if end
                 (let ((res nil))
                   (while (>= (setq end (1- end)) start)
!                    (push (pop seq) res))
                   (nreverse res))
               (copy-sequence seq)))
            (t
***************
*** 613,734 ****
  
  
  ;;; Hash tables.
  
! (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)))
! 
  (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)))
- 
- ;; These variables are just kept for compatibility with code
- ;; byte-compiled by Emacs-20.
  (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))
  
! (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)))
! 
  
  ;;; Some debugging aids.
  
--- 606,631 ----
  
  
  ;;; Hash tables.
+ ;; This is just kept for compatibility with code byte-compiled by Emacs-20.
  
! ;; 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))))
  
  (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.
  
***************
*** 788,794 ****
             (cl-macroexpand-all (cons 'progn (cddr form)) env)
           (let ((letf nil) (res nil) (lets (cadr form)))
             (while lets
!              (cl-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)))
--- 685,691 ----
             (cl-macroexpand-all (cons 'progn (cddr form)) env)
           (let ((letf nil) (res nil) (lets (cadr form)))
             (while 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)))
***************
*** 817,823 ****
                          (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))
                     (put (car (last cl-closure-vars)) 'used t)
                     (append
                      (list 'list '(quote lambda) '(quote (&rest --cl-rest--)))
--- 714,720 ----
                          (sub (pairlis cl-closure-vars new)) (decls nil))
                     (while (or (stringp (car body))
                                (eq (car-safe (car body)) 'interactive))
!                      (push (list 'quote (pop body)) decls))
                     (put (car (last cl-closure-vars)) 'used t)
                     (append
                      (list 'list '(quote lambda) '(quote (&rest --cl-rest--)))