[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] Changes to emacs/lisp/emacs-lisp/cl-extra.el
From: |
Miles Bader |
Subject: |
[Emacs-diffs] Changes to emacs/lisp/emacs-lisp/cl-extra.el |
Date: |
Fri, 04 Apr 2003 01:21:57 -0500 |
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--)))
[Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Emacs-diffs] Changes to emacs/lisp/emacs-lisp/cl-extra.el,
Miles Bader <=