/[emacs]/emacs/lisp/emacs-lisp/cl-extra.el
ViewVC logotype

Diff of /emacs/lisp/emacs-lisp/cl-extra.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.22 by walters, Sat Jun 8 22:32:06 2002 UTC revision 1.22.2.1 by miles, Fri Apr 4 06:20:16 2003 UTC
# Line 42  Line 42 
42      (error "Tried to load `cl-extra' before `cl'!"))      (error "Tried to load `cl-extra' before `cl'!"))
43    
44    
 ;;; 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)))))  
   
45  ;;; Type coercion.  ;;; Type coercion.
46    
47  (defun coerce (x type)  (defun coerce (x type)
# Line 111  strings case-insensitively." Line 104  strings case-insensitively."
104                            (setcar cl-p1 (cdr (car cl-p1))))                            (setcar cl-p1 (cdr (car cl-p1))))
105                        (aref (car cl-p1) cl-i)))                        (aref (car cl-p1) cl-i)))
106              (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2)))              (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2)))
107            (cl-push (apply cl-func cl-args) cl-res)            (push (apply cl-func cl-args) cl-res)
108            (setq cl-i (1+ cl-i)))            (setq cl-i (1+ cl-i)))
109          (nreverse cl-res))          (nreverse cl-res))
110      (let ((cl-res nil)      (let ((cl-res nil)
# Line 120  strings case-insensitively." Line 113  strings case-insensitively."
113        (let ((cl-n (min (length cl-x) (length cl-y)))        (let ((cl-n (min (length cl-x) (length cl-y)))
114              (cl-i -1))              (cl-i -1))
115          (while (< (setq cl-i (1+ cl-i)) cl-n)          (while (< (setq cl-i (1+ cl-i)) cl-n)
116            (cl-push (funcall cl-func            (push (funcall cl-func
117                              (if (consp cl-x) (cl-pop cl-x) (aref cl-x cl-i))                              (if (consp cl-x) (pop cl-x) (aref cl-x cl-i))
118                              (if (consp cl-y) (cl-pop cl-y) (aref cl-y cl-i)))                              (if (consp cl-y) (pop cl-y) (aref cl-y cl-i)))
119                     cl-res)))                     cl-res)))
120        (nreverse cl-res))))        (nreverse cl-res))))
121    
# Line 142  the elements themselves." Line 135  the elements themselves."
135              (cl-args (cons cl-list (copy-sequence cl-rest)))              (cl-args (cons cl-list (copy-sequence cl-rest)))
136              cl-p)              cl-p)
137          (while (not (memq nil cl-args))          (while (not (memq nil cl-args))
138            (cl-push (apply cl-func cl-args) cl-res)            (push (apply cl-func cl-args) cl-res)
139            (setq cl-p cl-args)            (setq cl-p cl-args)
140            (while cl-p (setcar cl-p (cdr (cl-pop cl-p)) )))            (while cl-p (setcar cl-p (cdr (pop cl-p)) )))
141          (nreverse cl-res))          (nreverse cl-res))
142      (let ((cl-res nil))      (let ((cl-res nil))
143        (while cl-list        (while cl-list
144          (cl-push (funcall cl-func cl-list) cl-res)          (push (funcall cl-func cl-list) cl-res)
145          (setq cl-list (cdr cl-list)))          (setq cl-list (cdr cl-list)))
146        (nreverse cl-res))))        (nreverse cl-res))))
147    
# Line 186  If so, return the true (non-nil) value r Line 179  If so, return the true (non-nil) value r
179                               (if cl-res (throw 'cl-some cl-res)))))                               (if cl-res (throw 'cl-some cl-res)))))
180                 cl-seq cl-rest) nil)                 cl-seq cl-rest) nil)
181      (let ((cl-x nil))      (let ((cl-x nil))
182        (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))))))
183        cl-x)))        cl-x)))
184    
185  (defun every (cl-pred cl-seq &rest cl-rest)  (defun every (cl-pred cl-seq &rest cl-rest)
# Line 318  If so, return the true (non-nil) value r Line 311  If so, return the true (non-nil) value r
311  (defvar cl-progv-save)  (defvar cl-progv-save)
312  (defun cl-progv-before (syms values)  (defun cl-progv-before (syms values)
313    (while syms    (while syms
314      (cl-push (if (boundp (car syms))      (push (if (boundp (car syms))
315                   (cons (car syms) (symbol-value (car syms)))                   (cons (car syms) (symbol-value (car syms)))
316                 (car syms)) cl-progv-save)                 (car syms)) cl-progv-save)
317      (if values      (if values
318          (set (cl-pop syms) (cl-pop values))          (set (pop syms) (pop values))
319        (makunbound (cl-pop syms)))))        (makunbound (pop syms)))))
320    
321  (defun cl-progv-after ()  (defun cl-progv-after ()
322    (while cl-progv-save    (while cl-progv-save
323      (if (consp (car cl-progv-save))      (if (consp (car cl-progv-save))
324          (set (car (car cl-progv-save)) (cdr (car cl-progv-save)))          (set (car (car cl-progv-save)) (cdr (car cl-progv-save)))
325        (makunbound (car cl-progv-save)))        (makunbound (car cl-progv-save)))
326      (cl-pop cl-progv-save)))      (pop cl-progv-save)))
327    
328    
329  ;;; Numbers.  ;;; Numbers.
330    
331  (defun gcd (&rest args)  (defun gcd (&rest args)
332    "Return the greatest common divisor of the arguments."    "Return the greatest common divisor of the arguments."
333    (let ((a (abs (or (cl-pop args) 0))))    (let ((a (abs (or (pop args) 0))))
334      (while args      (while args
335        (let ((b (abs (cl-pop args))))        (let ((b (abs (pop args))))
336          (while (> b 0) (setq b (% a (setq a b))))))          (while (> b 0) (setq b (% a (setq a b))))))
337      a))      a))
338    
# Line 347  If so, return the true (non-nil) value r Line 340  If so, return the true (non-nil) value r
340    "Return the least common multiple of the arguments."    "Return the least common multiple of the arguments."
341    (if (memq 0 args)    (if (memq 0 args)
342        0        0
343      (let ((a (abs (or (cl-pop args) 1))))      (let ((a (abs (or (pop args) 1))))
344        (while args        (while args
345          (let ((b (abs (cl-pop args))))          (let ((b (abs (pop args))))
346            (setq a (* (/ a (gcd a b)) b))))            (setq a (* (/ a (gcd a b)) b))))
347        a)))        a)))
348    
# Line 522  If START or END is negative, it counts f Line 515  If START or END is negative, it counts f
515               (if end               (if end
516                   (let ((res nil))                   (let ((res nil))
517                     (while (>= (setq end (1- end)) start)                     (while (>= (setq end (1- end)) start)
518                       (cl-push (cl-pop seq) res))                       (push (pop seq) res))
519                     (nreverse res))                     (nreverse res))
520                 (copy-sequence seq)))                 (copy-sequence seq)))
521              (t              (t
# Line 613  PROPLIST is a list of the sort returned Line 606  PROPLIST is a list of the sort returned
606    
607    
608  ;;; Hash tables.  ;;; Hash tables.
609    ;; This is just kept for compatibility with code byte-compiled by Emacs-20.
610    
611  (defun cl-make-hash-table (&rest cl-keys)  ;; No idea if this might still be needed.
   "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)))  
   
612  (defun cl-not-hash-table (x &optional y &rest z)  (defun cl-not-hash-table (x &optional y &rest z)
613    (signal 'wrong-type-argument (list 'cl-hash-table-p (or y x))))    (signal 'wrong-type-argument (list 'cl-hash-table-p (or y x))))
614    
 (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.  
615  (defvar cl-builtin-gethash (symbol-function 'gethash))  (defvar cl-builtin-gethash (symbol-function 'gethash))
616  (defvar cl-builtin-remhash (symbol-function 'remhash))  (defvar cl-builtin-remhash (symbol-function 'remhash))
617  (defvar cl-builtin-clrhash (symbol-function 'clrhash))  (defvar cl-builtin-clrhash (symbol-function 'clrhash))
618  (defvar cl-builtin-maphash (symbol-function 'maphash))  (defvar cl-builtin-maphash (symbol-function 'maphash))
619    
620  (defun cl-gethash (key table &optional def)  (defalias 'cl-gethash 'gethash)
621    "Look up KEY in HASH-TABLE; return corresponding value, or DEFAULT."  (defalias 'cl-puthash 'puthash)
622    (if (consp table)  (defalias 'cl-remhash 'remhash)
623        (let ((found (cl-hash-lookup key table)))  (defalias 'cl-clrhash 'clrhash)
624          (if (car found) (cdr (car found)) def))  (defalias 'cl-maphash 'maphash)
625      (gethash key table def)))  ;; These three actually didn't exist in Emacs-20.
626    (defalias 'cl-make-hash-table 'make-hash-table)
627  (defun cl-puthash (key val table)  (defalias 'cl-hash-table-p 'hash-table-p)
628    (if (consp table)  (defalias 'cl-hash-table-count 'hash-table-count)
       (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)))  
   
629    
630  ;;; Some debugging aids.  ;;; Some debugging aids.
631    
# Line 788  This also does some trivial optimization Line 685  This also does some trivial optimization
685               (cl-macroexpand-all (cons 'progn (cddr form)) env)               (cl-macroexpand-all (cons 'progn (cddr form)) env)
686             (let ((letf nil) (res nil) (lets (cadr form)))             (let ((letf nil) (res nil) (lets (cadr form)))
687               (while lets               (while lets
688                 (cl-push (if (consp (car lets))                 (push (if (consp (car lets))
689                              (let ((exp (cl-macroexpand-all (caar lets) env)))                              (let ((exp (cl-macroexpand-all (caar lets) env)))
690                                (or (symbolp exp) (setq letf t))                                (or (symbolp exp) (setq letf t))
691                                (cons exp (cl-macroexpand-body (cdar lets) env)))                                (cons exp (cl-macroexpand-body (cdar lets) env)))
# Line 817  This also does some trivial optimization Line 714  This also does some trivial optimization
714                            (sub (pairlis cl-closure-vars new)) (decls nil))                            (sub (pairlis cl-closure-vars new)) (decls nil))
715                       (while (or (stringp (car body))                       (while (or (stringp (car body))
716                                  (eq (car-safe (car body)) 'interactive))                                  (eq (car-safe (car body)) 'interactive))
717                         (cl-push (list 'quote (cl-pop body)) decls))                         (push (list 'quote (pop body)) decls))
718                       (put (car (last cl-closure-vars)) 'used t)                       (put (car (last cl-closure-vars)) 'used t)
719                       (append                       (append
720                        (list 'list '(quote lambda) '(quote (&rest --cl-rest--)))                        (list 'list '(quote lambda) '(quote (&rest --cl-rest--)))

Legend:
Removed from v.1.22  
changed lines
  Added in v.1.22.2.1

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26