1 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; This software is derived from the CMU CL system, which was
5 ;;;; written at Carnegie Mellon University and released into the
6 ;;;; public domain. The software is in the public domain and is
7 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
8 ;;;; files for more information.
10 (in-package "SB!IMPL")
14 ;;; We borrow the logic from (MAP NIL ..) to handle iteration over
15 ;;; arbitrary sequence arguments, both in the full call case and in
16 ;;; the open code case.
17 (flet ((expand (pred sequences test found-result unfound-result
)
18 (unless (proper-list-of-length-p sequences
1 call-arguments-limit
)
19 (return-from expand
(values nil t
))) ; give up
20 (binding* ((elements (make-gensym-list (length sequences
)))
21 ((bind-fun call-it
) (funarg-bind/call-forms pred elements
))
22 (blockname (sb!xc
:gensym
"BLOCK"))
23 (wrapper (sb!xc
:gensym
"WRAPPER"))
24 (value (sb!xc
:gensym
"VAL")))
27 (dx-flet ((,wrapper
(,@elements
)
29 (sb!c
::check-tag-existence
0)))
30 (let ((,value
,call-it
))
32 (return-from ,blockname
33 ,(if (eq found-result
:value
)
36 (declare (inline ,wrapper
))
37 (%map nil
#',wrapper
,@sequences
)
39 (values (if bind-fun
`(let ,bind-fun
,form
) form
) nil
)))))
40 (macrolet ((defquantifier (name found-test found-result
41 &key doc
(unfound-result (not found-result
)))
42 (declare (ignorable doc
))
44 ;; KLUDGE: It would be really nice if we could simply
45 ;; do something like this
46 ;; (declaim (inline ,name))
47 ;; (defun ,name (pred first-seq &rest more-seqs)
49 ;; (flet ((map-me (&rest rest)
50 ;; (let ((pred-value (apply pred rest)))
51 ;; (,found-test pred-value
54 ;; (declare (inline map-me))
55 ;; (apply #'map nil #'map-me first-seq more-seqs)
57 ;; but Python doesn't seem to be smart enough about
58 ;; inlining and APPLY to recognize that it can use
59 ;; the DEFTRANSFORM for MAP in the resulting inline
60 ;; expansion. I don't have any appetite for deep
61 ;; compiler hacking right now, so I'll just work
62 ;; around the apparent problem by using a compiler
63 ;; macro instead. -- WHN 20000410
64 (sb!c
:define-source-transform
,name
(pred &rest sequences
)
65 (expand pred sequences
66 ',found-test
',found-result
',unfound-result
))
67 #-sb-xc-host
; don't redefine CL builtins!
68 (defun ,name
(pred first-seq
&rest more-seqs
)
70 (flet ((map-me (&rest rest
)
71 (let ((value (apply pred rest
)))
74 ,(if (eq found-result
:value
)
77 (declare (inline map-me
))
78 (apply #'%map nil
#'map-me first-seq more-seqs
)
81 (defquantifier some when
:value
:unfound-result nil
82 :doc
"Apply PREDICATE to the 0-indexed elements of the sequences, then
83 possibly to those with index 1, and so on. Return the first
84 non-NIL value encountered, or NIL if the end of any sequence is reached.")
85 (defquantifier every unless nil
86 :doc
"Apply PREDICATE to the 0-indexed elements of the sequences, then
87 possibly to those with index 1, and so on. Return NIL as soon
88 as any invocation of PREDICATE returns NIL, or T if every invocation
90 (defquantifier notany when nil
91 :doc
"Apply PREDICATE to the 0-indexed elements of the sequences, then
92 possibly to those with index 1, and so on. Return NIL as soon
93 as any invocation of PREDICATE returns a non-NIL value, or T if the end
94 of any sequence is reached.")
95 (defquantifier notevery unless t
96 :doc
"Apply PREDICATE to 0-indexed elements of the sequences, then
97 possibly to those with index 1, and so on. Return T as soon
98 as any invocation of PREDICATE returns NIL, or NIL if every invocation