Lines Matching defs:cl
0 ;;; cl-macs.el --- Common Lisp macros -*-byte-compile-dynamic: t;-*-
34 ;; rewrite of Cesar Quiroz's original cl.el package of December 1986.
43 ;; See cl.el for Change Log.
48 (or (memq 'cl-19 features)
49 (error "Tried to load `cl-macs' before `cl'!"))
52 (defmacro cl-pop2 (place)
55 (put 'cl-pop2 'edebug-form-spec 'edebug-sexps)
57 (defvar cl-optimize-safety)
58 (defvar cl-optimize-speed)
61 ;;; This kludge allows macros which use cl-transform-function-property
66 (or (fboundp 'cl-transform-function-property)
67 (defalias 'cl-transform-function-property
71 (car (or features (setq features (list 'cl-kludge))))))
76 (defvar cl-old-bc-file-form nil)
78 (defun cl-compile-time-init ()
79 (run-hooks 'cl-hack-bytecomp-hook))
85 (defconst cl-simple-funcs '(car cdr nth aref elt if and or + - 1+ 1- min max
87 (defconst cl-safe-funcs '(* / % length memq list vector vectorp
91 (defun cl-simple-expr-p (x &optional size)
95 (or (memq (car x) cl-simple-funcs)
100 (setq size (cl-simple-expr-p (car x) size))))
104 (defun cl-simple-exprs-p (xs)
105 (while (and xs (cl-simple-expr-p (car xs)))
110 (defun cl-safe-expr-p (x)
113 (or (memq (car x) cl-simple-funcs)
114 (memq (car x) cl-safe-funcs)
117 (while (and (setq x (cdr x)) (cl-safe-expr-p (car x))))
121 (defun cl-const-expr-p (x)
130 (defun cl-const-exprs-p (xs)
131 (while (and xs (cl-const-expr-p (car xs)))
135 (defun cl-const-expr-val (x)
136 (and (eq (cl-const-expr-p x) t) (if (consp x) (nth 1 x) x)))
138 (defun cl-expr-access-order (x v)
139 (if (cl-const-expr-p x) v
142 (while (setq x (cdr x)) (setq v (cl-expr-access-order (car x) v)))
147 (defun cl-expr-contains (x y)
152 (setq sum (+ sum (or (cl-expr-contains (pop x) y) 0))))
156 (defun cl-expr-contains-any (x y)
157 (while (and y (not (cl-expr-contains x (car y)))) (pop y))
161 (defun cl-expr-depends-p (x y)
162 (and (not (cl-const-expr-p x))
163 (or (not (cl-safe-expr-p x)) (cl-expr-contains-any x y))))
195 (let* ((res (cl-transform-lambda (cons args body) name))
205 (let* ((res (cl-transform-lambda (cons args body) name))
214 (let* ((res (cl-transform-lambda (cdr func) 'cl-none))
219 (defun cl-transform-function-property (func prop form)
220 (let ((res (cl-transform-lambda form func)))
228 (defvar cl-macro-environment nil)
232 (defun cl-transform-lambda (form bind-block)
242 (if (setq bind-defs (cadr (memq '&cl-defs args)))
243 (setq args (delq '&cl-defs (delq bind-defs args))
245 (if (setq bind-enquote (memq '&cl-quote args))
246 (setq args (delq '&cl-quote args)))
250 (list '&aux (list v 'cl-macro-environment))))))
256 (or (eq bind-block 'cl-none)
261 (cl-do-arglist args nil (- (length simple-args)
272 ;; orig-args can contain &cl-defs (an internal CL
274 (let ((x (memq '&cl-defs orig-args)))
281 (defun cl-do-arglist (args expr &optional num) ; uses bind-*
292 (safety (if (cl-compiling-file) cl-optimize-safety 3))
297 (setq restarg (make-symbol "--cl-rest--"))
301 (push (list (cl-pop2 args) restarg) bind-lets))
314 (cl-do-arglist
319 (list 'list (and (not (eq bind-block 'cl-none))
327 (if (cddr arg) (cl-do-arglist (nth 2 arg) (list 'and restarg t)))
333 (cl-do-arglist (car arg)
337 (let ((arg (cl-pop2 args)))
338 (if (consp arg) (cl-do-arglist arg restarg)))
343 (and (not (eq bind-block 'cl-none))
359 (let* ((temp (or (nth 2 arg) (make-symbol "--cl-var--")))
361 (cl-do-arglist temp look)
362 (cl-do-arglist varg
366 (cl-do-arglist
373 (if (eq (cl-const-expr-p def) t)
376 (list nil (cl-const-expr-val def)))
382 (let* ((var (make-symbol "--cl-keys--"))
407 (cl-do-arglist (caar args)
409 (cl-do-arglist (caar args) (cadr (pop args))))
410 (cl-do-arglist (pop args) nil))))
413 (defun cl-arglist-args (args)
419 (if (eq arg '&cl-defs) (pop args)
422 (setq res (nconc res (cl-arglist-args arg))))))
427 (bind-defs nil) (bind-block 'cl-none))
428 (cl-do-arglist (or args '(&aux)) expr)
436 (defvar cl-not-toplevel nil)
445 (if (and (fboundp 'cl-compiling-file) (cl-compiling-file)
446 (not cl-not-toplevel) (not (boundp 'for-effect))) ; horrible kludge
448 (cl-not-toplevel t))
450 (if comp (cons 'progn (mapcar 'cl-compile-time-too body))
456 (defun cl-compile-time-too (form)
461 (cons 'progn (mapcar 'cl-compile-time-too (cdr form))))
472 (if (cl-compiling-file)
473 (let* ((temp (gentemp "--cl-load-time--"))
500 (let* ((temp (if (cl-simple-expr-p expr 3) expr (make-symbol "--cl-var--")))
538 (let* ((temp (if (cl-simple-expr-p expr 3) expr (make-symbol "--cl-var--")))
551 (cl-make-type-test temp (car c))))
575 (if (cl-safe-expr-p (cons 'progn body)) (cons 'progn body)
576 (list 'cl-block-wrapper
577 (list* 'catch (list 'quote (intern (format "--cl-block-%s--" name)))
580 (defvar cl-active-block-names nil)
582 (put 'cl-block-wrapper 'byte-compile 'cl-byte-compile-block)
583 (defun cl-byte-compile-block (cl-form)
586 (let* ((cl-entry (cons (nth 1 (nth 1 (nth 1 cl-form))) nil))
587 (cl-active-block-names (cons cl-entry cl-active-block-names))
588 (cl-body (byte-compile-top-level
589 (cons 'progn (cddr (nth 1 cl-form))))))
590 (if (cdr cl-entry)
591 (byte-compile-form (list 'catch (nth 1 (nth 1 cl-form)) cl-body))
592 (byte-compile-form cl-body))))
593 (byte-compile-form (nth 1 cl-form))))
595 (put 'cl-block-throw 'byte-compile 'cl-byte-compile-throw)
596 (defun cl-byte-compile-throw (cl-form)
597 (let ((cl-found (assq (nth 1 (nth 1 cl-form)) cl-active-block-names)))
598 (if cl-found (setcdr cl-found t)))
599 (byte-compile-normal-call (cons 'throw (cdr cl-form))))
612 (let ((name2 (intern (format "--cl-block-%s--" name))))
613 (list 'cl-block-throw (list 'quote name2) result)))
650 (setq args (append args '(cl-end-loop)))
651 (while (not (eq (car args) 'cl-end-loop)) (cl-parse-loop-clause))
659 (ands (cl-loop-build-ands (nreverse loop-body)))
664 (list 'block '--cl-finish--
668 (return-from --cl-finish--
671 '--cl-map loop-map-form))
681 (setq body (list (cl-loop-let (pop loop-bindings) body t)))
686 (setq body (list (cl-loop-let lets body nil))))))
691 (defun cl-parse-loop-clause () ; uses args, loop-*
712 (setq loop-result-explicit (or (cl-pop2 args) '(quote nil)))
726 ;; these vars get added to the cl-macro-environment.
727 (let ((var (or (pop args) (gensym "--cl-var--"))))
745 (cl-pop2 args)))
748 (cl-pop2 args)))
749 (step (and (eq (car args) 'by) (cl-pop2 args)))
750 (end-var (and (not (cl-const-expr-p end))
751 (make-symbol "--cl-var--")))
752 (step-var (and (not (cl-const-expr-p step))
753 (make-symbol "--cl-var--"))))
771 var (make-symbol "--cl-var--"))))
783 (let ((step (cl-pop2 args)))
795 (then (if (eq (car args) 'then) (cl-pop2 args) start)))
802 (make-symbol "--cl-var--")))
810 (make-symbol "--cl-var--")))
815 (let ((temp-vec (make-symbol "--cl-vec--"))
816 (temp-idx (make-symbol "--cl-idx--")))
832 (seq (cl-pop2 args))
833 (temp-seq (make-symbol "--cl-seq--"))
837 (cadr (cl-pop2 args))
839 (make-symbol "--cl-idx--"))))
843 (let ((temp-len (make-symbol "--cl-len--")))
864 (let* ((table (cl-pop2 args))
869 (cadr (cl-pop2 args))
871 (make-symbol "--cl-var--"))))
875 `(maphash (lambda (,var ,other) . --cl-map) ,table))))
879 (let ((ob (and (memq (car args) '(in of)) (cl-pop2 args))))
881 `(mapatoms (lambda (,var) . --cl-map) ,ob))))
886 (cond ((eq (car args) 'from) (setq from (cl-pop2 args)))
887 ((eq (car args) 'to) (setq to (cl-pop2 args)))
888 (t (setq buf (cl-pop2 args)))))
890 `(cl-map-extents
891 (lambda (,var ,(make-symbol "--cl-var--"))
892 (progn . --cl-map) nil)
897 (var1 (make-symbol "--cl-var1--"))
898 (var2 (make-symbol "--cl-var2--")))
900 (cond ((eq (car args) 'from) (setq from (cl-pop2 args)))
901 ((eq (car args) 'to) (setq to (cl-pop2 args)))
903 (setq prop (cl-pop2 args)))
904 (t (setq buf (cl-pop2 args)))))
909 `(cl-map-intervals
910 (lambda (,var1 ,var2) . --cl-map)
915 (let ((map (cl-pop2 args))
920 (cadr (cl-pop2 args))
922 (make-symbol "--cl-var--"))))
927 'cl-map-keymap-recursively 'map-keymap)
928 (lambda (,var ,other) . --cl-map) ,map))))
931 (let ((temp (make-symbol "--cl-var--")))
942 (let ((scr (and (memq (car args) '(in of)) (cl-pop2 args)))
943 (temp (make-symbol "--cl-var--")))
956 (get word 'cl-loop-for-handler))))
969 (cl-loop-let (nreverse loop-for-sets) 'setq ands)
977 (let ((temp (make-symbol "--cl-var--")))
983 (var (cl-loop-handle-accum nil 'nreverse)))
992 (var (cl-loop-handle-accum nil 'nreverse)))
1007 (var (cl-loop-handle-accum "")))
1012 (var (cl-loop-handle-accum [])))
1017 (var (cl-loop-handle-accum 0)))
1022 (var (cl-loop-handle-accum 0)))
1027 (temp (if (cl-simple-expr-p what) what (make-symbol "--cl-var--")))
1028 (var (cl-loop-handle-accum nil))
1038 (and (eq (car args) '=) (cl-pop2 args)))
1051 (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-flag--")))
1056 (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-flag--")))
1062 (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-flag--")))
1063 (or loop-result-var (setq loop-result-var (make-symbol "--cl-var--")))
1071 (cl-parse-loop-clause)
1072 (cl-loop-build-ands (nreverse loop-body))))
1075 (progn (pop args) (cl-parse-loop-clause)))
1076 (cl-loop-build-ands (nreverse loop-body))))
1082 (if (cl-expr-contains form 'it)
1083 (let ((temp (make-symbol "--cl-var--")))
1097 (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-var--")))
1098 (or loop-result-var (setq loop-result-var (make-symbol "--cl-var--")))
1103 (let ((handler (and (symbolp word) (get word 'cl-loop-handler))))
1107 (progn (pop args) (cl-parse-loop-clause)))))
1109 (defun cl-loop-let (specs body par) ; uses loop-*
1117 (or (cl-const-expr-p (cadar p))
1118 (let ((temp (make-symbol "--cl-var--")))
1128 (make-symbol "--cl-var--")))
1143 (defun cl-loop-handle-accum (def &optional func) ; uses args, loop-*
1145 (let ((var (cl-pop2 args)))
1152 (push (list (list (setq loop-accum-var (make-symbol "--cl-var--")) def))
1158 (defun cl-loop-build-ands (clauses)
1188 (cl-expand-do-loop steps endtest body nil))
1194 (cl-expand-do-loop steps endtest body t))
1196 (defun cl-expand-do-loop (steps endtest body star)
1223 (let ((temp (make-symbol "--cl-dolist-temp--")))
1240 (let ((temp (make-symbol "--cl-dotimes-temp--")))
1285 (list 'let '((cl-progv-save nil))
1287 (list* 'progn (list 'cl-progv-before symbols values) body)
1288 '(cl-progv-after))))
1305 (cdr (assq (car x) cl-macro-environment)))
1310 (if (and (cl-compiling-file)
1324 (let ((vars nil) (sets nil) (cl-macro-environment cl-macro-environment))
1328 ;; vars get added to the cl-macro-environment.
1329 (let ((var (gensym "--cl-var--")))
1333 (push (list (car (pop bindings)) 'lambda '(&rest cl-labels-args)
1335 'cl-labels-args))
1336 cl-macro-environment)))
1337 (cl-macroexpand-all (list* 'lexical-let vars (cons (cons 'setq sets) body))
1338 cl-macro-environment)))
1352 (res (cl-transform-lambda (cdar bindings) name)))
1354 (cl-macroexpand-all (cons 'progn body)
1356 cl-macro-environment))))))
1368 (cl-macroexpand-all (cons 'progn body)
1371 cl-macro-environment)))))
1373 (defvar cl-closure-vars nil)
1379 (let* ((cl-closure-vars cl-closure-vars)
1383 (push (make-symbol (format "--cl-%s--" (car x)))
1384 cl-closure-vars)
1385 (set (car cl-closure-vars) [bad-lexical-ref])
1386 (list (car x) (cadr x) (car cl-closure-vars))))
1389 (cl-macroexpand-all
1395 (list '(defun . cl-defun-expander))
1396 cl-macro-environment))))
1397 (if (not (get (car (last cl-closure-vars)) 'used))
1428 (defun cl-defun-expander (func &rest rest)
1446 (let ((temp (make-symbol "--cl-var--")) (n -1))
1465 (let* ((temp (make-symbol "--cl-var--")) (n 0))
1483 (defvar cl-proclaim-history t) ; for future compilers
1484 (defvar cl-declare-stack t) ; for future compilers
1486 (defun cl-do-proclaim (spec hist)
1487 (and hist (listp cl-proclaim-history) (push spec cl-proclaim-history))
1512 (if speed (setq cl-optimize-speed (car speed)
1514 (if safety (setq cl-optimize-safety (car safety)
1529 ;;; Process any proclamations made before cl-macs was loaded.
1530 (defvar cl-proclaims-deferred)
1531 (let ((p (reverse cl-proclaims-deferred)))
1532 (while p (cl-do-proclaim (pop p) t))
1533 (setq cl-proclaims-deferred nil))
1536 (if (cl-compiling-file)
1538 (if (listp cl-declare-stack) (push (car specs) cl-declare-stack))
1539 (cl-do-proclaim (pop specs) nil)))
1560 (list (cl-transform-function-property
1612 (make-symbol ,(format "--cl-%s--" (car p1))))
1622 (make-symbol ,(format "--cl-%s--" store-var)))
1625 (mapcar (lambda (_) (make-symbol "--cl-var--"))
1689 (defsetf buffer-substring cl-set-buffer-substring)
1720 (defsetf frame-visible-p cl-set-frame-visible-p)
1777 ;;; available while compiling cl-macs, we fake it by referring to the global
1778 ;;; variable cl-macro-environment directly.
1785 (method (get-setf-method form cl-macro-environment)))
1787 (cl-setf-make-apply (nth 3 method) (cadr func) (car method))
1788 (cl-setf-make-apply (nth 4 method) (cadr func) (car method)))))
1790 (defun cl-setf-make-apply (form func temps)
1792 (list* 'progn (cl-setf-make-apply (cadr form) func temps) (cddr form))
1798 (let ((method (get-setf-method place cl-macro-environment))
1799 (n-temp (make-symbol "--cl-nthcdr-n--"))
1800 (store-temp (make-symbol "--cl-nthcdr-store--")))
1805 (list 'cl-set-nthcdr n-temp (nth 4 method)
1811 (let ((method (get-setf-method place cl-macro-environment))
1812 (tag-temp (make-symbol "--cl-getf-tag--"))
1813 (def-temp (make-symbol "--cl-getf-def--"))
1814 (store-temp (make-symbol "--cl-getf-store--")))
1819 (list 'cl-set-getf (nth 4 method)
1825 (let ((method (get-setf-method place cl-macro-environment))
1826 (from-temp (make-symbol "--cl-substring-from--"))
1827 (to-temp (make-symbol "--cl-substring-to--"))
1828 (store-temp (make-symbol "--cl-substring-store--")))
1833 (list 'cl-set-substring (nth 4 method)
1844 (let ((temp (make-symbol "--cl-setf--")))
1852 (let ((cl-macro-environment env))
1872 (defun cl-setf-do-modify (place opt-expr)
1873 (let* ((method (get-setf-method place cl-macro-environment))
1878 (cl-safe-expr-p opt-expr))
1879 (cl-setf-simple-store-p (car (nth 2 method))
1881 (simple (and optimize (consp place) (cl-simple-exprs-p (cdr place)))))
1883 (if (or simple (cl-const-expr-p (car values)))
1890 (defun cl-setf-do-store (spec val)
1893 (if (or (cl-const-expr-p val)
1894 (and (cl-simple-expr-p val) (eq (cl-expr-contains form sym) 1))
1895 (cl-setf-simple-store-p sym form))
1899 (defun cl-setf-simple-store-p (sym form)
1900 (and (consp form) (eq (cl-expr-contains form sym) 1)
1920 (let* ((method (cl-setf-do-modify (car args) (nth 1 args)))
1921 (store (cl-setf-do-store (nth 1 method) (nth 1 args))))
1932 (if (or (not (symbolp (car p))) (cl-expr-depends-p (nth 1 p) vars))
1947 (defun cl-do-pop (place)
1948 (if (cl-simple-expr-p place)
1950 (let* ((method (cl-setf-do-modify place t))
1951 (temp (make-symbol "--cl-pop--")))
1957 (cl-setf-do-store (nth 1 method) (list 'cdr temp)))))))
1963 (let* ((method (cl-setf-do-modify place t))
1964 (tag-temp (and (not (cl-const-expr-p tag)) (make-symbol "--cl-remf-tag--")))
1965 (val-temp (and (not (cl-simple-expr-p place))
1966 (make-symbol "--cl-remf-place--")))
1975 (cl-setf-do-store (nth 1 method) (list 'cddr tval))
1977 (list 'cl-do-remf tval ttag)))))
1989 (let ((method (cl-setf-do-modify place 'unsafe)))
1992 ,(cl-setf-do-store (nth 1 method) `(shiftf ,@args))))))))
2008 (temp (make-symbol "--cl-rotatef--"))
2011 (let ((method (cl-setf-do-modify (pop places) 'unsafe)))
2014 (cl-setf-do-store (nth 1 method) form))))))
2015 (let ((method (cl-setf-do-modify (car places) 'unsafe)))
2017 (cl-setf-do-store (nth 1 method) form) nil)))))
2039 (method (cl-setf-do-modify place 'no-opt))
2040 (save (make-symbol "--cl-letf-save--"))
2042 (make-symbol "--cl-letf-bound--")))
2043 (temp (and (not (cl-const-expr-p value)) (cdr bindings)
2044 (make-symbol "--cl-letf-val--"))))
2061 (cons (cl-setf-do-store (nth 1 method)
2067 (cl-setf-do-store (nth 1 method) save)
2071 (cl-setf-do-store (nth 1 method) save))))
2099 (let* ((method (cl-setf-do-modify place (cons 'list args)))
2102 (cl-setf-do-store (nth 1 method)
2112 (if (and (cl-safe-expr-p arg1) (cl-simple-expr-p place) (symbolp func))
2114 (let* ((method (cl-setf-do-modify place (cons 'list args)))
2115 (temp (and (not (cl-const-expr-p arg1)) (make-symbol "--cl-arg1--")))
2118 (cl-setf-do-store (nth 1 method)
2128 (let ((place (make-symbol "--cl-place--")))
2132 (cl-arglist-args arglist)))))
2154 (safety (if (cl-compiling-file) cl-optimize-safety 3))
2156 (tag (intern (format "cl-struct-%s" name)))
2157 (tag-symbol (intern (format "cl-struct-%s-tags" name)))
2167 (setq descs (cons '(cl-tag-slot)
2203 (setq descs (nconc (make-list (car args) '(cl-skip-slot))
2210 'cl-x 'cl-s 'cl-n) t))
2211 (or type (and include (not (get include 'cl-struct-print)))
2216 'cl-s))))))
2218 (let ((inc-type (get include 'cl-struct-type))
2219 (old-descs (get include 'cl-struct-slots)))
2229 (setq descs (append old-descs (delq (assq 'cl-tag-slot descs) descs))
2231 named (assq 'cl-tag-slot descs))
2236 (intern (format "cl-struct-%s-tags" incl)))
2238 (setq incl (get incl 'cl-struct-include)))))
2245 (or named (setq descs (delq (assq 'cl-tag-slot descs) descs)))
2249 (length (memq (assq 'cl-tag-slot descs)
2252 (list 'and '(vectorp cl-x)
2253 (list '>= '(length cl-x) (length descs))
2254 (list 'memq (list 'aref 'cl-x pos)
2257 (list 'memq '(car-safe cl-x) tag-symbol)
2258 (list 'and '(consp cl-x)
2259 (list 'memq (list 'nth pos 'cl-x)
2269 (if (memq slot '(cl-tag-slot cl-skip-slot))
2272 (push (and (eq slot 'cl-tag-slot) (list 'quote tag))
2280 'defsubst* accessor '(cl-x)
2287 (list (if (eq type 'vector) (list 'aref 'cl-x pos)
2288 (if (= pos 0) '(car cl-x)
2289 (list 'nth pos 'cl-x)))))) forms)
2291 (push (list 'define-setf-method accessor '(cl-x)
2295 ;; If cl is loaded only for compilation,
2296 ;; the call to cl-struct-setf-expander would
2300 (list 'cl-struct-setf-expander 'cl-x
2307 (list (list 'princ (format " %s" slot) 'cl-s)
2308 (list 'prin1 (list accessor 'cl-x) 'cl-s)))))))
2313 (progn (push (list 'defsubst* predicate '(cl-x)
2328 (anames (cl-arglist-args args))
2332 (list* '&cl-defs (list 'quote (cons nil descs)) args)
2334 (if (cl-safe-expr-p (cons 'progn (mapcar 'second descs)))
2336 (if print-auto (nconc print-func (list '(princ ")" cl-s) t)))
2340 (list 'lambda '(cl-x cl-s cl-n)
2345 (list 'put (list 'quote name) '(quote cl-struct-slots)
2347 (list 'put (list 'quote name) '(quote cl-struct-type)
2349 (list 'put (list 'quote name) '(quote cl-struct-include)
2351 (list 'put (list 'quote name) '(quote cl-struct-print)
2361 (defun cl-struct-setf-expander (x name accessor pred-form pos)
2362 (let* ((temp (make-symbol "--cl-x--")) (store (make-symbol "--cl-store--")))
2366 (list (list 'or (subst temp 'cl-x pred-form)
2370 (list (if (eq (car (get name 'cl-struct-type)) 'vector)
2389 (cl-transform-function-property
2390 name 'cl-deftype-handler (cons (list* '&cl-defs ''('*) arglist) body))))
2392 (defun cl-make-type-test (val type)
2394 (cond ((get type 'cl-deftype-handler)
2395 (cl-make-type-test val (funcall (get type 'cl-deftype-handler))))
2409 (cond ((get (car type) 'cl-deftype-handler)
2410 (cl-make-type-test val (apply (get (car type) 'cl-deftype-handler)
2413 (delq t (list 'and (cl-make-type-test val (car type))
2422 (mapcar (function (lambda (x) (cl-make-type-test val x)))
2432 (eval (cl-make-type-test 'object type)))
2437 (and (or (not (cl-compiling-file))
2438 (< cl-optimize-speed 3) (= cl-optimize-safety 3))
2439 (let* ((temp (if (cl-simple-expr-p form 3)
2440 form (make-symbol "--cl-var--")))
2441 (body (list 'or (cl-make-type-test temp type)
2454 (and (or (not (cl-compiling-file))
2455 (< cl-optimize-speed 3) (= cl-optimize-safety 3))
2459 (and (not (cl-const-expr-p x))
2465 (list 'signal '(quote cl-assertion-failed)
2492 (cl-transform-function-property
2493 func 'cl-compiler-macro
2495 (cons '--cl-whole-arg-- args)) body))
2498 '(quote cl-byte-compile-compiler-macro)))))
2504 (not (setq handler (get func 'cl-compiler-macro)))
2513 (defun cl-byte-compile-compiler-macro (form)
2525 (let* ((argns (cl-arglist-args args)) (p argns)
2527 (unsafe (not (cl-safe-expr-p pbody))))
2528 (while (and p (eq (cl-expr-contains args (car p)) 1)) (pop p))
2533 (list* '&whole 'cl-whole '&cl-quote args)
2534 (cons '&cl-quote args))
2535 (list* 'cl-defsubst-expand (list 'quote argns)
2537 (not (or unsafe (cl-expr-access-order pbody argns)))
2538 (and (memq '&key args) 'cl-whole) unsafe argns)))
2541 (defun cl-defsubst-expand (argns body simple whole unsafe &rest argvs)
2542 (if (and whole (not (cl-safe-expr-p (cons 'progn argvs)))) whole
2543 (if (cl-simple-exprs-p argvs) (setq simple t))
2547 (if (or simple (cl-const-expr-p argv))
2556 ;;; Note that cl.el arranges to force cl-macs to be loaded at compile-time,
2561 (cond ((eq (cl-const-expr-p a) t)
2562 (let ((val (cl-const-expr-val a)))
2566 ((eq (cl-const-expr-p b) t)
2567 (let ((val (cl-const-expr-val b)))
2571 ((cl-simple-expr-p a 5)
2575 ((and (cl-safe-expr-p a)
2576 (cl-simple-expr-p b 5))
2584 (cl-const-expr-val (nth 1 keys)))))
2592 (cl-const-expr-val (nth 1 keys)))))
2595 ((and (eq (cl-const-expr-p a) t) (or (null keys) (eq test 'eql)))
2596 (if (floatp-safe (cl-const-expr-val a))
2601 (if (and (cl-simple-expr-p a) (cl-simple-expr-p list)
2619 (if (cl-const-expr-p type)
2620 (let ((res (cl-make-type-test val (cl-const-expr-val type))))
2621 (if (or (memq (cl-expr-contains res val) '(nil 1))
2622 (cl-simple-expr-p val)) res
2623 (let ((temp (make-symbol "--cl-var--")))
2630 (put (car y) 'byte-compile 'cl-byte-compile-compiler-macro)
2631 (put (car y) 'cl-compiler-macro
2652 cl-set-elt revappend nreconc gethash))
2666 (run-hooks 'cl-macs-load-hook)
2673 ;;; cl-macs.el ends here