src/code/quantifiers.lisp

   1 ;;;; This software is part of the SBCL system. See the README file for
   2 ;;;; more information.
   3 ;;;;
   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.
   9
  10 (in-package "SB!IMPL")
  11
  12 ;;;; quantifiers
  13
  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")))
  25              (let ((form
  26                     `(block ,blockname
  27                        ;; Does DX actually help? INLINE should win anyway.
  28                        (dx-flet ((,wrapper (,@elements)
  29                                   (declare (optimize
  30                                             (sb!c::check-tag-existence 0)))
  31                                   (let ((,value ,call-it))
  32                                     (,test ,value
  33                                       (return-from ,blockname
  34                                        ,(if (eq found-result :value)
  35                                             value
  36                                             found-result))))))
  37                          (declare (inline ,wrapper))
  38                          (%map nil #',wrapper ,@sequences)
  39                          ,unfound-result))))
  40                (values (if bind-fun `(let ,bind-fun ,form) form) nil)))))
  41   (macrolet ((defquantifier (name found-test found-result
  42                                   &key doc (unfound-result (not found-result)))
  43                (declare (ignorable doc))
  44                `(progn
  45                 ;; KLUDGE: It would be really nice if we could simply
  46                 ;; do something like this
  47                 ;;  (declaim (inline ,name))
  48                 ;;  (defun ,name (pred first-seq &rest more-seqs)
  49                 ;;    ,doc
  50                 ;;    (flet ((map-me (&rest rest)
  51                 ;;             (let ((pred-value (apply pred rest)))
  52                 ;;               (,found-test pred-value
  53                 ;;                 (return-from ,name
  54                 ;;                   ,found-result)))))
  55                 ;;      (declare (inline map-me))
  56                 ;;      (apply #'map nil #'map-me first-seq more-seqs)
  57                 ;;      ,unfound-result))
  58                 ;; but Python doesn't seem to be smart enough about
  59                 ;; inlining and APPLY to recognize that it can use
  60                 ;; the DEFTRANSFORM for MAP in the resulting inline
  61                 ;; expansion. I don't have any appetite for deep
  62                 ;; compiler hacking right now, so I'll just work
  63                 ;; around the apparent problem by using a compiler
  64                 ;; macro instead. -- WHN 20000410
  65                   (sb!c:define-source-transform ,name (pred &rest sequences)
  66                     (expand pred sequences
  67                             ',found-test ',found-result ',unfound-result))
  68                   #-sb-xc-host ; don't redefine CL builtins!
  69                   (defun ,name (pred first-seq &rest more-seqs)
  70                     #!+sb-doc ,doc
  71                     (flet ((map-me (&rest rest)
  72                              (let ((value (apply pred rest)))
  73                                (,found-test value
  74                                  (return-from ,name
  75                                    ,(if (eq found-result :value)
  76                                         'value
  77                                         found-result))))))
  78                       (declare (inline map-me))
  79                       (apply #'%map nil #'map-me first-seq more-seqs)
  80                       ,unfound-result)))))
  81
  82   (defquantifier some when :value :unfound-result nil
  83    :doc "Apply PREDICATE to the 0-indexed elements of the sequences, then
  84    possibly to those with index 1, and so on. Return the first
  85    non-NIL value encountered, or NIL if the end of any sequence is reached.")
  86   (defquantifier every unless nil
  87    :doc "Apply PREDICATE to the 0-indexed elements of the sequences, then
  88    possibly to those with index 1, and so on. Return NIL as soon
  89    as any invocation of PREDICATE returns NIL, or T if every invocation
  90    is non-NIL.")
  91   (defquantifier notany when nil
  92    :doc "Apply PREDICATE to the 0-indexed elements of the sequences, then
  93    possibly to those with index 1, and so on. Return NIL as soon
  94    as any invocation of PREDICATE returns a non-NIL value, or T if the end
  95    of any sequence is reached.")
  96   (defquantifier notevery unless t
  97    :doc "Apply PREDICATE to 0-indexed elements of the sequences, then
  98    possibly to those with index 1, and so on. Return T as soon
  99    as any invocation of PREDICATE returns NIL, or NIL if every invocation
 100    is non-NIL.")))