diff options
| author | Stefan Monnier | 2002-09-27 22:32:48 +0000 |
|---|---|---|
| committer | Stefan Monnier | 2002-09-27 22:32:48 +0000 |
| commit | abfb2fe607a22b4b5964191185bc2f84c578e69b (patch) | |
| tree | 2aa1ade9371d128e63f01562ef310b45fbee860f | |
| parent | ca50d9e6f39531a2bb2afe1515cab2050f670328 (diff) | |
| download | emacs-abfb2fe607a22b4b5964191185bc2f84c578e69b.tar.gz emacs-abfb2fe607a22b4b5964191185bc2f84c578e69b.zip | |
(cl-push, cl-pop): Remove. Use pop and push throughout the file instead.
(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.
| -rw-r--r-- | lisp/emacs-lisp/cl-extra.el | 163 |
1 files changed, 30 insertions, 133 deletions
diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index ac206a84afd..aa6b4f9ae48 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el | |||
| @@ -42,13 +42,6 @@ | |||
| 42 | (error "Tried to load `cl-extra' before `cl'!")) | 42 | (error "Tried to load `cl-extra' before `cl'!")) |
| 43 | 43 | ||
| 44 | 44 | ||
| 45 | ;;; We define these here so that this file can compile without having | ||
| 46 | ;;; loaded the cl.el file already. | ||
| 47 | |||
| 48 | (defmacro cl-push (x place) (list 'setq place (list 'cons x place))) | ||
| 49 | (defmacro cl-pop (place) | ||
| 50 | (list 'car (list 'prog1 place (list 'setq place (list 'cdr place))))) | ||
| 51 | |||
| 52 | ;;; Type coercion. | 45 | ;;; Type coercion. |
| 53 | 46 | ||
| 54 | (defun coerce (x type) | 47 | (defun coerce (x type) |
| @@ -111,7 +104,7 @@ strings case-insensitively." | |||
| 111 | (setcar cl-p1 (cdr (car cl-p1)))) | 104 | (setcar cl-p1 (cdr (car cl-p1)))) |
| 112 | (aref (car cl-p1) cl-i))) | 105 | (aref (car cl-p1) cl-i))) |
| 113 | (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2))) | 106 | (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2))) |
| 114 | (cl-push (apply cl-func cl-args) cl-res) | 107 | (push (apply cl-func cl-args) cl-res) |
| 115 | (setq cl-i (1+ cl-i))) | 108 | (setq cl-i (1+ cl-i))) |
| 116 | (nreverse cl-res)) | 109 | (nreverse cl-res)) |
| 117 | (let ((cl-res nil) | 110 | (let ((cl-res nil) |
| @@ -120,9 +113,9 @@ strings case-insensitively." | |||
| 120 | (let ((cl-n (min (length cl-x) (length cl-y))) | 113 | (let ((cl-n (min (length cl-x) (length cl-y))) |
| 121 | (cl-i -1)) | 114 | (cl-i -1)) |
| 122 | (while (< (setq cl-i (1+ cl-i)) cl-n) | 115 | (while (< (setq cl-i (1+ cl-i)) cl-n) |
| 123 | (cl-push (funcall cl-func | 116 | (push (funcall cl-func |
| 124 | (if (consp cl-x) (cl-pop cl-x) (aref cl-x cl-i)) | 117 | (if (consp cl-x) (pop cl-x) (aref cl-x cl-i)) |
| 125 | (if (consp cl-y) (cl-pop cl-y) (aref cl-y cl-i))) | 118 | (if (consp cl-y) (pop cl-y) (aref cl-y cl-i))) |
| 126 | cl-res))) | 119 | cl-res))) |
| 127 | (nreverse cl-res)))) | 120 | (nreverse cl-res)))) |
| 128 | 121 | ||
| @@ -142,13 +135,13 @@ the elements themselves." | |||
| 142 | (cl-args (cons cl-list (copy-sequence cl-rest))) | 135 | (cl-args (cons cl-list (copy-sequence cl-rest))) |
| 143 | cl-p) | 136 | cl-p) |
| 144 | (while (not (memq nil cl-args)) | 137 | (while (not (memq nil cl-args)) |
| 145 | (cl-push (apply cl-func cl-args) cl-res) | 138 | (push (apply cl-func cl-args) cl-res) |
| 146 | (setq cl-p cl-args) | 139 | (setq cl-p cl-args) |
| 147 | (while cl-p (setcar cl-p (cdr (cl-pop cl-p)) ))) | 140 | (while cl-p (setcar cl-p (cdr (pop cl-p)) ))) |
| 148 | (nreverse cl-res)) | 141 | (nreverse cl-res)) |
| 149 | (let ((cl-res nil)) | 142 | (let ((cl-res nil)) |
| 150 | (while cl-list | 143 | (while cl-list |
| 151 | (cl-push (funcall cl-func cl-list) cl-res) | 144 | (push (funcall cl-func cl-list) cl-res) |
| 152 | (setq cl-list (cdr cl-list))) | 145 | (setq cl-list (cdr cl-list))) |
| 153 | (nreverse cl-res)))) | 146 | (nreverse cl-res)))) |
| 154 | 147 | ||
| @@ -186,7 +179,7 @@ If so, return the true (non-nil) value returned by PREDICATE." | |||
| 186 | (if cl-res (throw 'cl-some cl-res))))) | 179 | (if cl-res (throw 'cl-some cl-res))))) |
| 187 | cl-seq cl-rest) nil) | 180 | cl-seq cl-rest) nil) |
| 188 | (let ((cl-x nil)) | 181 | (let ((cl-x nil)) |
| 189 | (while (and cl-seq (not (setq cl-x (funcall cl-pred (cl-pop cl-seq)))))) | 182 | (while (and cl-seq (not (setq cl-x (funcall cl-pred (pop cl-seq)))))) |
| 190 | cl-x))) | 183 | cl-x))) |
| 191 | 184 | ||
| 192 | (defun every (cl-pred cl-seq &rest cl-rest) | 185 | (defun every (cl-pred cl-seq &rest cl-rest) |
| @@ -318,28 +311,28 @@ If so, return the true (non-nil) value returned by PREDICATE." | |||
| 318 | (defvar cl-progv-save) | 311 | (defvar cl-progv-save) |
| 319 | (defun cl-progv-before (syms values) | 312 | (defun cl-progv-before (syms values) |
| 320 | (while syms | 313 | (while syms |
| 321 | (cl-push (if (boundp (car syms)) | 314 | (push (if (boundp (car syms)) |
| 322 | (cons (car syms) (symbol-value (car syms))) | 315 | (cons (car syms) (symbol-value (car syms))) |
| 323 | (car syms)) cl-progv-save) | 316 | (car syms)) cl-progv-save) |
| 324 | (if values | 317 | (if values |
| 325 | (set (cl-pop syms) (cl-pop values)) | 318 | (set (pop syms) (pop values)) |
| 326 | (makunbound (cl-pop syms))))) | 319 | (makunbound (pop syms))))) |
| 327 | 320 | ||
| 328 | (defun cl-progv-after () | 321 | (defun cl-progv-after () |
| 329 | (while cl-progv-save | 322 | (while cl-progv-save |
| 330 | (if (consp (car cl-progv-save)) | 323 | (if (consp (car cl-progv-save)) |
| 331 | (set (car (car cl-progv-save)) (cdr (car cl-progv-save))) | 324 | (set (car (car cl-progv-save)) (cdr (car cl-progv-save))) |
| 332 | (makunbound (car cl-progv-save))) | 325 | (makunbound (car cl-progv-save))) |
| 333 | (cl-pop cl-progv-save))) | 326 | (pop cl-progv-save))) |
| 334 | 327 | ||
| 335 | 328 | ||
| 336 | ;;; Numbers. | 329 | ;;; Numbers. |
| 337 | 330 | ||
| 338 | (defun gcd (&rest args) | 331 | (defun gcd (&rest args) |
| 339 | "Return the greatest common divisor of the arguments." | 332 | "Return the greatest common divisor of the arguments." |
| 340 | (let ((a (abs (or (cl-pop args) 0)))) | 333 | (let ((a (abs (or (pop args) 0)))) |
| 341 | (while args | 334 | (while args |
| 342 | (let ((b (abs (cl-pop args)))) | 335 | (let ((b (abs (pop args)))) |
| 343 | (while (> b 0) (setq b (% a (setq a b)))))) | 336 | (while (> b 0) (setq b (% a (setq a b)))))) |
| 344 | a)) | 337 | a)) |
| 345 | 338 | ||
| @@ -347,9 +340,9 @@ If so, return the true (non-nil) value returned by PREDICATE." | |||
| 347 | "Return the least common multiple of the arguments." | 340 | "Return the least common multiple of the arguments." |
| 348 | (if (memq 0 args) | 341 | (if (memq 0 args) |
| 349 | 0 | 342 | 0 |
| 350 | (let ((a (abs (or (cl-pop args) 1)))) | 343 | (let ((a (abs (or (pop args) 1)))) |
| 351 | (while args | 344 | (while args |
| 352 | (let ((b (abs (cl-pop args)))) | 345 | (let ((b (abs (pop args)))) |
| 353 | (setq a (* (/ a (gcd a b)) b)))) | 346 | (setq a (* (/ a (gcd a b)) b)))) |
| 354 | a))) | 347 | a))) |
| 355 | 348 | ||
| @@ -522,7 +515,7 @@ If START or END is negative, it counts from the end." | |||
| 522 | (if end | 515 | (if end |
| 523 | (let ((res nil)) | 516 | (let ((res nil)) |
| 524 | (while (>= (setq end (1- end)) start) | 517 | (while (>= (setq end (1- end)) start) |
| 525 | (cl-push (cl-pop seq) res)) | 518 | (push (pop seq) res)) |
| 526 | (nreverse res)) | 519 | (nreverse res)) |
| 527 | (copy-sequence seq))) | 520 | (copy-sequence seq))) |
| 528 | (t | 521 | (t |
| @@ -613,122 +606,26 @@ PROPLIST is a list of the sort returned by `symbol-plist'." | |||
| 613 | 606 | ||
| 614 | 607 | ||
| 615 | ;;; Hash tables. | 608 | ;;; Hash tables. |
| 609 | ;; This is just kept for compatibility with code byte-compiled by Emacs-20. | ||
| 616 | 610 | ||
| 617 | (defun cl-make-hash-table (&rest cl-keys) | 611 | ;; No idea if this might still be needed. |
| 618 | "Make an empty Common Lisp-style hash-table. | ||
| 619 | Keywords supported: :test :size | ||
| 620 | The Common Lisp keywords :rehash-size and :rehash-threshold are ignored." | ||
| 621 | (let ((cl-test (or (car (cdr (memq :test cl-keys))) 'eql)) | ||
| 622 | (cl-size (or (car (cdr (memq :size cl-keys))) 20))) | ||
| 623 | (make-hash-table :size cl-size :test cl-size))) | ||
| 624 | |||
| 625 | (defun cl-hash-table-p (x) | ||
| 626 | "Return t if OBJECT is a hash table." | ||
| 627 | (or (hash-table-p x) | ||
| 628 | (eq (car-safe x) 'cl-hash-table-tag))) | ||
| 629 | |||
| 630 | (defun cl-not-hash-table (x &optional y &rest z) | 612 | (defun cl-not-hash-table (x &optional y &rest z) |
| 631 | (signal 'wrong-type-argument (list 'cl-hash-table-p (or y x)))) | 613 | (signal 'wrong-type-argument (list 'cl-hash-table-p (or y x)))) |
| 632 | 614 | ||
| 633 | (defun cl-hash-lookup (key table) | ||
| 634 | (or (eq (car-safe table) 'cl-hash-table-tag) (cl-not-hash-table table)) | ||
| 635 | (let* ((array (nth 2 table)) (test (car (cdr table))) (str key) sym) | ||
| 636 | (if (symbolp array) (setq str nil sym (symbol-value array)) | ||
| 637 | (while (or (consp str) (and (vectorp str) (> (length str) 0))) | ||
| 638 | (setq str (elt str 0))) | ||
| 639 | (cond ((stringp str) (if (eq test 'equalp) (setq str (downcase str)))) | ||
| 640 | ((symbolp str) (setq str (symbol-name str))) | ||
| 641 | ((and (numberp str) (> str -8000000) (< str 8000000)) | ||
| 642 | (or (integerp str) (setq str (truncate str))) | ||
| 643 | (setq str (aref ["0" "1" "2" "3" "4" "5" "6" "7" "8" "9" "10" | ||
| 644 | "11" "12" "13" "14" "15"] (logand str 15)))) | ||
| 645 | (t (setq str "*"))) | ||
| 646 | (setq sym (symbol-value (intern-soft str array)))) | ||
| 647 | (list (and sym (cond ((or (eq test 'eq) | ||
| 648 | (and (eq test 'eql) (not (numberp key)))) | ||
| 649 | (assq key sym)) | ||
| 650 | ((memq test '(eql equal)) (assoc key sym)) | ||
| 651 | (t (assoc* key sym :test test)))) | ||
| 652 | sym str))) | ||
| 653 | |||
| 654 | ;; These variables are just kept for compatibility with code | ||
| 655 | ;; byte-compiled by Emacs-20. | ||
| 656 | (defvar cl-builtin-gethash (symbol-function 'gethash)) | 615 | (defvar cl-builtin-gethash (symbol-function 'gethash)) |
| 657 | (defvar cl-builtin-remhash (symbol-function 'remhash)) | 616 | (defvar cl-builtin-remhash (symbol-function 'remhash)) |
| 658 | (defvar cl-builtin-clrhash (symbol-function 'clrhash)) | 617 | (defvar cl-builtin-clrhash (symbol-function 'clrhash)) |
| 659 | (defvar cl-builtin-maphash (symbol-function 'maphash)) | 618 | (defvar cl-builtin-maphash (symbol-function 'maphash)) |
| 660 | 619 | ||
| 661 | (defun cl-gethash (key table &optional def) | 620 | (defalias 'cl-gethash 'gethash) |
| 662 | "Look up KEY in HASH-TABLE; return corresponding value, or DEFAULT." | 621 | (defalias 'cl-puthash 'puthash) |
| 663 | (if (consp table) | 622 | (defalias 'cl-remhash 'remhash) |
| 664 | (let ((found (cl-hash-lookup key table))) | 623 | (defalias 'cl-clrhash 'clrhash) |
| 665 | (if (car found) (cdr (car found)) def)) | 624 | (defalias 'cl-maphash 'maphash) |
| 666 | (gethash key table def))) | 625 | ;; These three actually didn't exist in Emacs-20. |
| 667 | 626 | (defalias 'cl-make-hash-table 'make-hash-table) | |
| 668 | (defun cl-puthash (key val table) | 627 | (defalias 'cl-hash-table-p 'hash-table-p) |
| 669 | (if (consp table) | 628 | (defalias 'cl-hash-table-count 'hash-table-count) |
| 670 | (let ((found (cl-hash-lookup key table))) | ||
| 671 | (if (car found) (setcdr (car found) val) | ||
| 672 | (if (nth 2 found) | ||
| 673 | (progn | ||
| 674 | (if (> (nth 3 table) (* (length (nth 2 table)) 3)) | ||
| 675 | (let ((new-table (make-vector (nth 3 table) 0))) | ||
| 676 | (mapatoms (function | ||
| 677 | (lambda (sym) | ||
| 678 | (set (intern (symbol-name sym) new-table) | ||
| 679 | (symbol-value sym)))) | ||
| 680 | (nth 2 table)) | ||
| 681 | (setcar (cdr (cdr table)) new-table))) | ||
| 682 | (set (intern (nth 2 found) (nth 2 table)) | ||
| 683 | (cons (cons key val) (nth 1 found)))) | ||
| 684 | (set (nth 2 table) (cons (cons key val) (nth 1 found)))) | ||
| 685 | (setcar (cdr (cdr (cdr table))) (1+ (nth 3 table))))) | ||
| 686 | (funcall 'puthash key val table)) val) | ||
| 687 | |||
| 688 | (defun cl-remhash (key table) | ||
| 689 | "Remove KEY from HASH-TABLE." | ||
| 690 | (if (consp table) | ||
| 691 | (let ((found (cl-hash-lookup key table))) | ||
| 692 | (and (car found) | ||
| 693 | (let ((del (delq (car found) (nth 1 found)))) | ||
| 694 | (setcar (cdr (cdr (cdr table))) (1- (nth 3 table))) | ||
| 695 | (if (nth 2 found) (set (intern (nth 2 found) (nth 2 table)) del) | ||
| 696 | (set (nth 2 table) del)) t))) | ||
| 697 | (prog1 (not (eq (gethash key table '--cl--) '--cl--)) | ||
| 698 | (remhash key table)))) | ||
| 699 | |||
| 700 | (defun cl-clrhash (table) | ||
| 701 | "Clear HASH-TABLE." | ||
| 702 | (if (consp table) | ||
| 703 | (progn | ||
| 704 | (or (cl-hash-table-p table) (cl-not-hash-table table)) | ||
| 705 | (if (symbolp (nth 2 table)) (set (nth 2 table) nil) | ||
| 706 | (setcar (cdr (cdr table)) (make-vector (length (nth 2 table)) 0))) | ||
| 707 | (setcar (cdr (cdr (cdr table))) 0)) | ||
| 708 | (clrhash table)) | ||
| 709 | nil) | ||
| 710 | |||
| 711 | (defun cl-maphash (cl-func cl-table) | ||
| 712 | "Call FUNCTION on keys and values from HASH-TABLE." | ||
| 713 | (or (cl-hash-table-p cl-table) (cl-not-hash-table cl-table)) | ||
| 714 | (if (consp cl-table) | ||
| 715 | (mapatoms (function (lambda (cl-x) | ||
| 716 | (setq cl-x (symbol-value cl-x)) | ||
| 717 | (while cl-x | ||
| 718 | (funcall cl-func (car (car cl-x)) | ||
| 719 | (cdr (car cl-x))) | ||
| 720 | (setq cl-x (cdr cl-x))))) | ||
| 721 | (if (symbolp (nth 2 cl-table)) | ||
| 722 | (vector (nth 2 cl-table)) (nth 2 cl-table))) | ||
| 723 | (maphash cl-func cl-table))) | ||
| 724 | |||
| 725 | (defun cl-hash-table-count (table) | ||
| 726 | "Return the number of entries in HASH-TABLE." | ||
| 727 | (or (cl-hash-table-p table) (cl-not-hash-table table)) | ||
| 728 | (if (consp table) | ||
| 729 | (nth 3 table) | ||
| 730 | (hash-table-count table))) | ||
| 731 | |||
| 732 | 629 | ||
| 733 | ;;; Some debugging aids. | 630 | ;;; Some debugging aids. |
| 734 | 631 | ||
| @@ -788,7 +685,7 @@ This also does some trivial optimizations to make the form prettier." | |||
| 788 | (cl-macroexpand-all (cons 'progn (cddr form)) env) | 685 | (cl-macroexpand-all (cons 'progn (cddr form)) env) |
| 789 | (let ((letf nil) (res nil) (lets (cadr form))) | 686 | (let ((letf nil) (res nil) (lets (cadr form))) |
| 790 | (while lets | 687 | (while lets |
| 791 | (cl-push (if (consp (car lets)) | 688 | (push (if (consp (car lets)) |
| 792 | (let ((exp (cl-macroexpand-all (caar lets) env))) | 689 | (let ((exp (cl-macroexpand-all (caar lets) env))) |
| 793 | (or (symbolp exp) (setq letf t)) | 690 | (or (symbolp exp) (setq letf t)) |
| 794 | (cons exp (cl-macroexpand-body (cdar lets) env))) | 691 | (cons exp (cl-macroexpand-body (cdar lets) env))) |
| @@ -817,7 +714,7 @@ This also does some trivial optimizations to make the form prettier." | |||
| 817 | (sub (pairlis cl-closure-vars new)) (decls nil)) | 714 | (sub (pairlis cl-closure-vars new)) (decls nil)) |
| 818 | (while (or (stringp (car body)) | 715 | (while (or (stringp (car body)) |
| 819 | (eq (car-safe (car body)) 'interactive)) | 716 | (eq (car-safe (car body)) 'interactive)) |
| 820 | (cl-push (list 'quote (cl-pop body)) decls)) | 717 | (push (list 'quote (pop body)) decls)) |
| 821 | (put (car (last cl-closure-vars)) 'used t) | 718 | (put (car (last cl-closure-vars)) 'used t) |
| 822 | (append | 719 | (append |
| 823 | (list 'list '(quote lambda) '(quote (&rest --cl-rest--))) | 720 | (list 'list '(quote lambda) '(quote (&rest --cl-rest--))) |