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 |
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) |
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))) |
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)) |
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 |