/[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.2.1 by miles, Fri Apr 4 06:20:16 2003 UTC revision 1.22.2.2 by miles, Tue Oct 14 23:32:20 2003 UTC
# Line 1  Line 1 
1  ;;; cl-extra.el --- Common Lisp features, part 2 -*-byte-compile-dynamic: t;-*-  ;;; cl-extra.el --- Common Lisp features, part 2 -*-byte-compile-dynamic: t;-*-
2    
3  ;; Copyright (C) 1993,2000  Free Software Foundation, Inc.  ;; Copyright (C) 1993,2000,2003  Free Software Foundation, Inc.
4    
5  ;; Author: Dave Gillespie <daveg@synaptics.com>  ;; Author: Dave Gillespie <daveg@synaptics.com>
6  ;; Keywords: extensions  ;; Keywords: extensions
# 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)))
# Line 733  This also does some trivial optimization Line 718  This also does some trivial optimization
718                                       '((quote --cl-rest--)))))))                                       '((quote --cl-rest--)))))))
719                   (list (car form) (list* 'lambda (cadadr form) body))))                   (list (car form) (list* 'lambda (cadadr form) body))))
720             (let ((found (assq (cadr form) env)))             (let ((found (assq (cadr form) env)))
721               (if (eq (cadr (caddr found)) 'cl-labels-args)               (if (and found (ignore-errors
722                                  (eq (cadr (caddr found)) 'cl-labels-args)))
723                   (cl-macroexpand-all (cadr (caddr (cadddr found))) env)                   (cl-macroexpand-all (cadr (caddr (cadddr found))) env)
724                 form))))                 form))))
725          ((memq (car form) '(defun defmacro))          ((memq (car form) '(defun defmacro))
# Line 763  This also does some trivial optimization Line 749  This also does some trivial optimization
749    
750  (run-hooks 'cl-extra-load-hook)  (run-hooks 'cl-extra-load-hook)
751    
752    ;;; arch-tag: bcd03437-0871-43fb-a8f1-ad0e0b5427ed
753  ;;; cl-extra.el ends here  ;;; cl-extra.el ends here

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

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