/[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.23 by monnier, Fri Sep 27 22:32:48 2002 UTC revision 1.24 by monnier, Sun May 4 00:44:25 2003 UTC
# Line 203  If so, return the true (non-nil) value r Line 203  If so, return the true (non-nil) value r
203    (not (apply 'every cl-pred cl-seq cl-rest)))    (not (apply 'every cl-pred cl-seq cl-rest)))
204    
205  ;;; Support for `loop'.  ;;; Support for `loop'.
206  (defun cl-map-keymap (cl-func cl-map)  (defalias 'cl-map-keymap 'map-keymap)
   (while (symbolp cl-map) (setq cl-map (symbol-function cl-map)))  
   (if (listp cl-map)  
       (let ((cl-p cl-map))  
         (while (consp (setq cl-p (cdr cl-p)))  
           (cond ((consp (car cl-p))  
                  (funcall cl-func (car (car cl-p)) (cdr (car cl-p))))  
                 ((or (vectorp (car cl-p)) (char-table-p (car cl-p)))  
                  (cl-map-keymap cl-func (car cl-p)))  
                 ((eq (car cl-p) 'keymap)  
                  (setq cl-p nil)))))  
     (let ((cl-i -1))  
       (while (< (setq cl-i (1+ cl-i)) (length cl-map))  
         (if (aref cl-map cl-i)  
             (funcall cl-func cl-i (aref cl-map cl-i)))))))  
207    
208  (defun cl-map-keymap-recursively (cl-func-rec cl-map &optional cl-base)  (defun cl-map-keymap-recursively (cl-func-rec cl-map &optional cl-base)
209    (or cl-base    (or cl-base
210        (setq cl-base (copy-sequence [0])))        (setq cl-base (copy-sequence [0])))
211    (cl-map-keymap    (map-keymap
212     (function     (function
213      (lambda (cl-key cl-bind)      (lambda (cl-key cl-bind)
214        (aset cl-base (1- (length cl-base)) cl-key)        (aset cl-base (1- (length cl-base)) cl-key)
# Line 721  This also does some trivial optimization Line 707  This also does some trivial optimization
707                        (sublis sub (nreverse decls))                        (sublis sub (nreverse decls))
708                        (list                        (list
709                         (list* 'list '(quote apply)                         (list* 'list '(quote apply)
710                                (list 'list '(quote quote)                                (list 'function
711                                      (list 'function                                      (list* 'lambda
712                                            (list* 'lambda                                             (append new (cadadr form))
713                                                   (append new (cadadr form))                                             (sublis sub body)))
                                                  (sublis sub body))))  
714                                (nconc (mapcar (function                                (nconc (mapcar (function
715                                                (lambda (x)                                                (lambda (x)
716                                                  (list 'list '(quote quote) x)))                                                  (list 'list '(quote quote) x)))

Legend:
Removed from v.1.23  
changed lines
  Added in v.1.24

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