procyberian/emacs
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

(cl-push, cl-pop): Remove. Use pop and push throughout the file instead.

Browse source 
(cl-hash-lookup): Remove.
(cl-make-hash-table, cl-hash-table-p, cl-gethash, cl-puthash)
(cl-remhash, cl-clrhash, cl-maphash, cl-hash-table-count): Simplify.
This commit is contained in:
Stefan Monnier 2002-09-27 22:32:48 +00:00
parent ca50d9e6f3
commit abfb2fe607
1 changed files with 30 additions and 133 deletions
Download patch file Download diff file Expand all files Collapse all files

163
lisp/emacs-lisp/cl-extra.el
View file

@ -42,13 +42,6 @@
(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)
@ -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)))
(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)
@ -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)
(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))))
@ -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-push (apply cl-func cl-args) cl-res)
(push (apply cl-func cl-args) cl-res)
(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
(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))))
@ -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))
(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)
@ -318,28 +311,28 @@ If so, return the true (non-nil) value returned by PREDICATE."
(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
(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)))
(cl-pop cl-progv-save)))
(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))))
(let ((a (abs (or (pop args) 0))))
(while args
(let ((b (abs (cl-pop args))))
(let ((b (abs (pop args))))
(while (> b 0) (setq b (% a (setq a b))))))
a))
@ -347,9 +340,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
(let ((a (abs (or (cl-pop args) 1))))
(let ((a (abs (or (pop args) 1))))
(while args
(let ((b (abs (cl-pop args))))
(let ((b (abs (pop args))))
(setq a (* (/ a (gcd a b)) b))))
a)))
@ -522,7 +515,7 @@ If START or END is negative, it counts from the end."
(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
@ -613,122 +606,26 @@ PROPLIST is a list of the sort returned by `symbol-plist'."
;;; 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-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)))
(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,7 +685,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-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)))
@ -817,7 +714,7 @@ 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))
(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--)))