contrib/code-extras.lisp

   1 ;;;; (See the comments at the head of the file compiler-extras.lisp.)
   2
   3 (in-package "SB-IMPL")
   4
   5 (declaim (optimize (speed 3) (space 1)))
   6
   7 ;;; FIXME: should DEFUN REPLACE in terms of same expansion as
   8 ;;; DEFTRANSFORM
   9 #+nil
  10 (defun replace (..)
  11   (cond ((and (typep seq1 'simple-vector)
  12               (typep seq2 'simple-vector))
  13          (%replace-vector-vector ..))
  14         ((and (typep seq1 'simple-string)
  15               (typep seq2 'simple-string))
  16          (%replace-vector-vector ..))
  17         (t
  18          ..)))
  19
  20 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  21 ;;;; POSITION/FIND stuff
  22
  23 #+sb-xc-host
  24 (eval-when (:compile-toplevel :load-toplevel :execute)
  25   ;; FIXME: Report seq.impure.lisp test failures to cmucl-imp@cons.org.
  26   ;; FIXME: Add BUGS entry for the way that inline expansions offunctions
  27   ;; like FIND cause compiler warnings when the system can't prove that
  28   ;; NIL is never returned; and give (NEED (FIND ..)) workaround.
  29   (error "need to fix FIXMEs"))
  30
  31 ;;; logic to unravel :TEST, :TEST-NOT, and :KEY options in FIND,
  32 ;;; POSITION-IF, etc.
  33 (declaim (inline effective-find-position-test effective-find-position-key))
  34 (defun effective-find-position-test (test test-not)
  35   (cond ((and test test-not)
  36          (error "can't specify both :TEST and :TEST-NOT"))
  37         (test (%coerce-callable-to-function test))
  38         (test-not
  39          ;; (Without DYNAMIC-EXTENT, this is potentially horribly
  40          ;; inefficient, but since the TEST-NOT option is deprecated
  41          ;; anyway, we don't care.)
  42          (complement (%coerce-callable-to-function test-not)))
  43         (t #'eql)))
  44 (defun effective-find-position-key (key)
  45   (if key
  46       (%coerce-callable-to-function key)
  47       #'identity))
  48
  49 ;;; shared guts of out-of-line FIND, POSITION, FIND-IF, and POSITION-IF
  50 (macrolet (;; shared logic for defining %FIND-POSITION and
  51            ;; %FIND-POSITION-IF in terms of various inlineable cases
  52            ;; of the expression defined in FROB and VECTOR*-FROB
  53            (frobs ()
  54              `(etypecase sequence-arg
  55                 (list (frob sequence-arg from-end))
  56                 (vector
  57                  (with-array-data ((sequence sequence-arg :offset-var offset)
  58                                    (start start)
  59                                    (end (or end (length sequence-arg))))
  60                    (multiple-value-bind (f p)
  61                        (macrolet ((frob2 () '(if from-end
  62                                                  (frob sequence t)
  63                                                  (frob sequence nil))))
  64                          (typecase sequence
  65                            (simple-vector (frob2))
  66                            (simple-string (frob2))
  67                            (t (vector*-frob sequence))))
  68                      (declare (type (or index null) p))
  69                      (values f (and p (the index (+ p offset))))))))))
  70   (defun %find-position (item sequence-arg from-end start end key test)
  71     (macrolet ((frob (sequence from-end)
  72                  `(%find-position item ,sequence
  73                                   ,from-end start end key test))
  74                (vector*-frob (sequence)
  75                  `(%find-position-vector-macro item ,sequence
  76                                                from-end start end key test)))
  77       (frobs)))
  78   (defun %find-position-if (predicate sequence-arg from-end start end key)
  79     (macrolet ((frob (sequence from-end)
  80                  `(%find-position-if predicate ,sequence
  81                                      ,from-end start end key))
  82                (vector*-frob (sequence)
  83                  `(%find-position-if-vector-macro predicate ,sequence
  84                                                   from-end start end key)))
  85       (frobs))))
  86
  87 ;;; the user interface to FIND and POSITION: Get all our ducks in a row,
  88 ;;; then call %FIND-POSITION
  89 (declaim (inline find position))
  90 (macrolet ((def-find-position (fun-name values-index)
  91              `(defun ,fun-name (item
  92                                 sequence
  93                                 &key
  94                                 from-end
  95                                 (start 0)
  96                                 end
  97                                 key
  98                                 test
  99                                 test-not)
 100                 (nth-value
 101                  ,values-index
 102                  (%find-position item
 103                                  sequence
 104                                  from-end
 105                                  start
 106                                  end
 107                                  (effective-find-position-key key)
 108                                  (effective-find-position-test test
 109                                                                test-not))))))
 110   (def-find-position find 0)
 111   (def-find-position position 1))
 112
 113 ;;; the user interface to FIND-IF and POSITION-IF, entirely analogous
 114 ;;; to the interface to FIND and POSITION
 115 (declaim (inline find-if position-if))
 116 (macrolet ((def-find-position-if (fun-name values-index)
 117              `(defun ,fun-name (predicate sequence
 118                                 &key from-end (start 0) end key)
 119                 (nth-value
 120                  ,values-index
 121                  (%find-position-if (%coerce-callable-to-function predicate)
 122                                     sequence
 123                                     from-end
 124                                     start
 125                                     end
 126                                     (effective-find-position-key key))))))
 127
 128   (def-find-position-if find-if 0)
 129   (def-find-position-if position-if 1))
 130
 131 ;;; the deprecated functions FIND-IF-NOT and POSITION-IF-NOT
 132 (macrolet ((def-find-position-if-not (fun-name values-index)
 133              `(defun ,fun-name (predicate sequence
 134                                 &key from-end (start 0) end key)
 135                 (nth-value
 136                  ,values-index
 137                  (%find-position-if (complement (%coerce-callable-to-function
 138                                                  predicate))
 139                                     sequence
 140                                     from-end
 141                                     start
 142                                     end
 143                                     (effective-find-position-key key))))))
 144   (def-find-position-if-not find-if-not 0)
 145   (def-find-position-if-not position-if-not 1))
 146 ;;; FIXME: Remove uses of these deprecated functions, and of :TEST-NOT too.
 147