Lines Matching defs:cl
0 ;;; cl-extra.el --- Common Lisp features, part 2 -*-byte-compile-dynamic: t;-*-
33 ;; rewrite of Cesar Quiroz's original cl.el package of December 1986.
42 (require 'cl)
90 (defun cl-mapcar-many (cl-func cl-seqs)
91 (if (cdr (cdr cl-seqs))
92 (let* ((cl-res nil)
93 (cl-n (apply 'min (mapcar 'length cl-seqs)))
94 (cl-i 0)
95 (cl-args (copy-sequence cl-seqs))
96 cl-p1 cl-p2)
97 (setq cl-seqs (copy-sequence cl-seqs))
98 (while (< cl-i cl-n)
99 (setq cl-p1 cl-seqs cl-p2 cl-args)
100 (while cl-p1
101 (setcar cl-p2
102 (if (consp (car cl-p1))
103 (prog1 (car (car cl-p1))
104 (setcar cl-p1 (cdr (car cl-p1))))
105 (aref (car cl-p1) cl-i)))
106 (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2)))
107 (push (apply cl-func cl-args) cl-res)
108 (setq cl-i (1+ cl-i)))
109 (nreverse cl-res))
110 (let ((cl-res nil)
111 (cl-x (car cl-seqs))
112 (cl-y (nth 1 cl-seqs)))
113 (let ((cl-n (min (length cl-x) (length cl-y)))
114 (cl-i -1))
115 (while (< (setq cl-i (1+ cl-i)) cl-n)
116 (push (funcall cl-func
117 (if (consp cl-x) (pop cl-x) (aref cl-x cl-i))
118 (if (consp cl-y) (pop cl-y) (aref cl-y cl-i)))
119 cl-res)))
120 (nreverse cl-res))))
122 (defun map (cl-type cl-func cl-seq &rest cl-rest)
126 (let ((cl-res (apply 'mapcar* cl-func cl-seq cl-rest)))
127 (and cl-type (coerce cl-res cl-type))))
129 (defun maplist (cl-func cl-list &rest cl-rest)
134 (if cl-rest
135 (let ((cl-res nil)
136 (cl-args (cons cl-list (copy-sequence cl-rest)))
137 cl-p)
138 (while (not (memq nil cl-args))
139 (push (apply cl-func cl-args) cl-res)
140 (setq cl-p cl-args)
141 (while cl-p (setcar cl-p (cdr (pop cl-p)) )))
142 (nreverse cl-res))
143 (let ((cl-res nil))
144 (while cl-list
145 (push (funcall cl-func cl-list) cl-res)
146 (setq cl-list (cdr cl-list)))
147 (nreverse cl-res))))
149 (defun cl-mapc (cl-func cl-seq &rest cl-rest)
152 (if cl-rest
153 (progn (apply 'map nil cl-func cl-seq cl-rest)
154 cl-seq)
155 (mapc cl-func cl-seq)))
157 (defun mapl (cl-func cl-list &rest cl-rest)
160 (if cl-rest
161 (apply 'maplist cl-func cl-list cl-rest)
162 (let ((cl-p cl-list))
163 (while cl-p (funcall cl-func cl-p) (setq cl-p (cdr cl-p)))))
164 cl-list)
166 (defun mapcan (cl-func cl-seq &rest cl-rest)
169 (apply 'nconc (apply 'mapcar* cl-func cl-seq cl-rest)))
171 (defun mapcon (cl-func cl-list &rest cl-rest)
174 (apply 'nconc (apply 'maplist cl-func cl-list cl-rest)))
176 (defun some (cl-pred cl-seq &rest cl-rest)
180 (if (or cl-rest (nlistp cl-seq))
181 (catch 'cl-some
183 (function (lambda (&rest cl-x)
184 (let ((cl-res (apply cl-pred cl-x)))
185 (if cl-res (throw 'cl-some cl-res)))))
186 cl-seq cl-rest) nil)
187 (let ((cl-x nil))
188 (while (and cl-seq (not (setq cl-x (funcall cl-pred (pop cl-seq))))))
189 cl-x)))
191 (defun every (cl-pred cl-seq &rest cl-rest)
194 (if (or cl-rest (nlistp cl-seq))
195 (catch 'cl-every
197 (function (lambda (&rest cl-x)
198 (or (apply cl-pred cl-x) (throw 'cl-every nil))))
199 cl-seq cl-rest) t)
200 (while (and cl-seq (funcall cl-pred (car cl-seq)))
201 (setq cl-seq (cdr cl-seq)))
202 (null cl-seq)))
204 (defun notany (cl-pred cl-seq &rest cl-rest)
207 (not (apply 'some cl-pred cl-seq cl-rest)))
209 (defun notevery (cl-pred cl-seq &rest cl-rest)
212 (not (apply 'every cl-pred cl-seq cl-rest)))
215 (defalias 'cl-map-keymap 'map-keymap)
217 (defun cl-map-keymap-recursively (cl-func-rec cl-map &optional cl-base)
218 (or cl-base
219 (setq cl-base (copy-sequence [0])))
222 (lambda (cl-key cl-bind)
223 (aset cl-base (1- (length cl-base)) cl-key)
224 (if (keymapp cl-bind)
225 (cl-map-keymap-recursively
226 cl-func-rec cl-bind
227 (vconcat cl-base (list 0)))
228 (funcall cl-func-rec cl-base cl-bind))))
229 cl-map))
231 (defun cl-map-intervals (cl-func &optional cl-what cl-prop cl-start cl-end)
232 (or cl-what (setq cl-what (current-buffer)))
233 (if (bufferp cl-what)
234 (let (cl-mark cl-mark2 (cl-next t) cl-next2)
235 (with-current-buffer cl-what
236 (setq cl-mark (copy-marker (or cl-start (point-min))))
237 (setq cl-mark2 (and cl-end (copy-marker cl-end))))
238 (while (and cl-next (or (not cl-mark2) (< cl-mark cl-mark2)))
239 (setq cl-next (if cl-prop (next-single-property-change
240 cl-mark cl-prop cl-what)
241 (next-property-change cl-mark cl-what))
242 cl-next2 (or cl-next (with-current-buffer cl-what
244 (funcall cl-func (prog1 (marker-position cl-mark)
245 (set-marker cl-mark cl-next2))
246 (if cl-mark2 (min cl-next2 cl-mark2) cl-next2)))
247 (set-marker cl-mark nil) (if cl-mark2 (set-marker cl-mark2 nil)))
248 (or cl-start (setq cl-start 0))
249 (or cl-end (setq cl-end (length cl-what)))
250 (while (< cl-start cl-end)
251 (let ((cl-next (or (if cl-prop (next-single-property-change
252 cl-start cl-prop cl-what)
253 (next-property-change cl-start cl-what))
254 cl-end)))
255 (funcall cl-func cl-start (min cl-next cl-end))
256 (setq cl-start cl-next)))))
258 (defun cl-map-overlays (cl-func &optional cl-buffer cl-start cl-end cl-arg)
259 (or cl-buffer (setq cl-buffer (current-buffer)))
263 (let (cl-ovl)
264 (with-current-buffer cl-buffer
265 (setq cl-ovl (overlay-lists))
266 (if cl-start (setq cl-start (copy-marker cl-start)))
267 (if cl-end (setq cl-end (copy-marker cl-end))))
268 (setq cl-ovl (nconc (car cl-ovl) (cdr cl-ovl)))
269 (while (and cl-ovl
270 (or (not (overlay-start (car cl-ovl)))
271 (and cl-end (>= (overlay-start (car cl-ovl)) cl-end))
272 (and cl-start (<= (overlay-end (car cl-ovl)) cl-start))
273 (not (funcall cl-func (car cl-ovl) cl-arg))))
274 (setq cl-ovl (cdr cl-ovl)))
275 (if cl-start (set-marker cl-start nil))
276 (if cl-end (set-marker cl-end nil)))
279 (let ((cl-mark (with-current-buffer cl-buffer
280 (copy-marker (or cl-start (point-min)))))
281 (cl-mark2 (and cl-end (with-current-buffer cl-buffer
282 (copy-marker cl-end))))
283 cl-pos cl-ovl)
285 (and (setq cl-pos (marker-position cl-mark))
286 (< cl-pos (or cl-mark2 (point-max)))
288 (set-buffer cl-buffer)
289 (setq cl-ovl (overlays-at cl-pos))
290 (set-marker cl-mark (next-overlay-change cl-pos)))))
291 (while (and cl-ovl
292 (or (/= (overlay-start (car cl-ovl)) cl-pos)
293 (not (and (funcall cl-func (car cl-ovl) cl-arg)
294 (set-marker cl-mark nil)))))
295 (setq cl-ovl (cdr cl-ovl))))
296 (set-marker cl-mark nil) (if cl-mark2 (set-marker cl-mark2 nil)))))
299 (defun cl-set-frame-visible-p (frame val)
306 (defvar cl-progv-save)
307 (defun cl-progv-before (syms values)
311 (car syms)) cl-progv-save)
316 (defun cl-progv-after ()
317 (while cl-progv-save
318 (if (consp (car cl-progv-save))
319 (set (car (car cl-progv-save)) (cdr (car cl-progv-save)))
320 (makunbound (car cl-progv-save)))
321 (pop cl-progv-save)))
436 ((vectorp state) (cl-copy-tree state t))
437 ((integerp state) (vector 'cl-random-state-tag -1 30 state))
438 (t (make-random-state (cl-random-time)))))
443 (eq (aref object 0) 'cl-random-state-tag)))
448 (defun cl-finite-do (func a b)
463 (defun cl-float-limits ()
467 (while (cl-finite-do '* x x) (setq x (* x x)))
468 (while (cl-finite-do '* x (/ x 2)) (setq x (* x (/ x 2))))
469 (while (cl-finite-do '+ x x) (setq x (+ x x)))
472 (while (and (cl-finite-do '+ x y) (/= (+ x y) x))
557 (defalias 'cl-copy-tree 'copy-tree)
562 (defun get* (sym tag &optional def) ; See compiler macro in cl-macs.el
576 (setplist '--cl-getf-symbol-- plist)
577 (or (get '--cl-getf-symbol-- tag)
586 (defun cl-set-getf (plist tag val)
591 (defun cl-do-remf (plist tag)
596 (defun cl-remprop (sym tag)
602 (cl-do-remf plist tag))))
603 (defalias 'remprop 'cl-remprop)
611 (defun cl-not-hash-table (x &optional y &rest z)
612 (signal 'wrong-type-argument (list 'cl-hash-table-p (or y x))))
614 (defvar cl-builtin-gethash (symbol-function 'gethash))
615 (defvar cl-builtin-remhash (symbol-function 'remhash))
616 (defvar cl-builtin-clrhash (symbol-function 'clrhash))
617 (defvar cl-builtin-maphash (symbol-function 'maphash))
619 (defalias 'cl-gethash 'gethash)
620 (defalias 'cl-puthash 'puthash)
621 (defalias 'cl-remhash 'remhash)
622 (defalias 'cl-clrhash 'clrhash)
623 (defalias 'cl-maphash 'maphash)
625 (defalias 'cl-make-hash-table 'make-hash-table)
626 (defalias 'cl-hash-table-p 'hash-table-p)
627 (defalias 'cl-hash-table-count 'hash-table-count)
631 (defun cl-prettyprint (form)
643 (cl-do-prettyprint)))
645 (defun cl-do-prettyprint ()
651 (looking-at "(cl-block-wrapper ")))
661 (cl-do-prettyprint)
662 (or skip (looking-at ")") (cl-do-prettyprint))
663 (or (not two) (looking-at ")") (cl-do-prettyprint))
668 (cl-do-prettyprint))
672 (defvar cl-macroexpand-cmacs nil)
673 (defvar cl-closure-vars nil)
675 (defun cl-macroexpand-all (form &optional env)
679 (and cl-macroexpand-cmacs
684 (cl-macroexpand-all (cons 'progn (cddr form)) env)
688 (let ((exp (cl-macroexpand-all (caar lets) env)))
690 (cons exp (cl-macroexpand-body (cdar lets) env)))
691 (let ((exp (cl-macroexpand-all (car lets) env)))
696 (nreverse res) (cl-macroexpand-body (cddr form) env)))))
699 (mapcar (function (lambda (x) (cl-macroexpand-body x env)))
702 (list* (car form) (nth 1 form) (cl-macroexpand-all (nth 2 form) env)
705 (cons (car x) (cl-macroexpand-body (cdr x) env))))
709 (let ((body (cl-macroexpand-body (cddadr form) env)))
710 (if (and cl-closure-vars (eq (car form) 'function)
711 (cl-expr-contains-any body cl-closure-vars))
712 (let* ((new (mapcar 'gensym cl-closure-vars))
713 (sub (pairlis cl-closure-vars new)) (decls nil))
717 (put (car (last cl-closure-vars)) 'used t)
719 (list 'list '(quote lambda) '(quote (&rest --cl-rest--)))
730 cl-closure-vars)
731 '((quote --cl-rest--)))))))
735 (eq (cadr (caddr found)) 'cl-labels-args)))
736 (cl-macroexpand-all (cadr (caddr (cadddr found))) env)
739 (list* (car form) (nth 1 form) (cl-macroexpand-body (cddr form) env)))
741 (cl-macroexpand-all (nth 1 form) env))
743 (let* ((args (cl-macroexpand-body (cdr form) env)) (p args))
745 (if p (cl-macroexpand-all (cons 'setf args)) (cons 'setq args))))
747 (cl-macroexpand-all (list* 'funcall
751 (t (cons (car form) (cl-macroexpand-body (cdr form) env)))))
753 (defun cl-macroexpand-body (body &optional env)
754 (mapcar (function (lambda (x) (cl-macroexpand-all x env))) body))
756 (defun cl-prettyexpand (form &optional full)
758 (let ((cl-macroexpand-cmacs full) (cl-compiling-file full)
760 (setq form (cl-macroexpand-all form
763 (prog1 (cl-prettyprint form)
768 (run-hooks 'cl-extra-load-hook)
771 ;;; cl-extra.el ends here