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 (gensym "BLOCK"))
  23                     (wrapper (gensym "WRAPPER"))
  24                     (value (gensym "VAL")))
  25              (let ((form
  26                     `(block ,blockname
  27                        ;; Does DX actually help? INLINE should win anyway.
  28                        (dx-flet ((,wrapper (,@elements)
  29                                   (let ((,value ,call-it))
  30                                     (,test ,value
  31                                       (return-from ,blockname
  32                                        ,(if (eq found-result :value)
  33                                             value
  34                                             found-result))))))
  35                          (declare (inline ,wrapper))
  36                          (%map nil #',wrapper ,@sequences)
  37                          ,unfound-result))))
  38                (values (if bind-fun `(let ,bind-fun ,form) form) nil)))))
  39   (macrolet ((defquantifier (name found-test found-result
  40                                   &key doc (unfound-result (not found-result)))
  41                (declare (ignorable doc))
  42                `(progn
  43                 ;; KLUDGE: It would be really nice if we could simply
  44                 ;; do something like this
  45                 ;;  (declaim (inline ,name))
  46                 ;;  (defun ,name (pred first-seq &rest more-seqs)
  47                 ;;    ,doc
  48                 ;;    (flet ((map-me (&rest rest)
  49                 ;;             (let ((pred-value (apply pred rest)))
  50                 ;;               (,found-test pred-value
  51                 ;;                 (return-from ,name
  52                 ;;                   ,found-result)))))
  53                 ;;      (declare (inline map-me))
  54                 ;;      (apply #'map nil #'map-me first-seq more-seqs)
  55                 ;;      ,unfound-result))
  56                 ;; but Python doesn't seem to be smart enough about
  57                 ;; inlining and APPLY to recognize that it can use
  58                 ;; the DEFTRANSFORM for MAP in the resulting inline
  59                 ;; expansion. I don't have any appetite for deep
  60                 ;; compiler hacking right now, so I'll just work
  61                 ;; around the apparent problem by using a compiler
  62                 ;; macro instead. -- WHN 20000410
  63                   (sb-c:define-source-transform ,name (pred &rest sequences)
  64                     (expand pred sequences
  65                             ',found-test ',found-result ',unfound-result))
  66                   #-sb-xc-host ; don't redefine CL builtins!
  67                   (defun ,name (pred first-seq &rest more-seqs)
  68                     ,doc
  69                     (declare (dynamic-extent pred))
  70                     (flet ((map-me (&rest rest)
  71                              (let ((value (apply pred rest)))
  72                                (,found-test value
  73                                  (return-from ,name
  74                                    ,(if (eq found-result :value)
  75                                         'value
  76                                         found-result))))))
  77                       (declare (inline map-me))
  78                       (apply #'%map nil #'map-me first-seq more-seqs)
  79                       ,unfound-result)))))
  80
  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
  89    is non-NIL.")
  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
  99    is non-NIL.")))