tests/extended-sequences.impure.lisp

   1 ;;;; Tests related to extended sequences.
   2
   3 ;;;; This file is impure because we want to be able to define methods
   4 ;;;; implementing the extended sequence protocol.
   5
   6 ;;;; This software is part of the SBCL system. See the README file for
   7 ;;;; more information.
   8 ;;;;
   9 ;;;; While most of SBCL is derived from the CMU CL system, the test
  10 ;;;; files (like this one) were written from scratch after the fork
  11 ;;;; from CMU CL.
  12 ;;;;
  13 ;;;; This software is in the public domain and is provided with
  14 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  15 ;;;; more information.
  16
  17 (with-test (:name (sb-kernel:extended-sequence subtypep :relations))
  18   (flet ((test-case (type1 type2)
  19            (assert (equal '(nil t)
  20                           (multiple-value-list (subtypep type1 type2))))))
  21     (subtypep 'sb-kernel:extended-sequence 'sb-kernel:instance)
  22     (subtypep 'sb-kernel:instance 'sb-kernel:extended-sequence)
  23
  24     (subtypep 'sb-kernel:extended-sequence 'sb-kernel:funcallable-instance)
  25     (subtypep 'sb-kernel:funcallable-instance 'sb-kernel:extended-sequence)))
  26
  27 ;;; For the following situation:
  28 ;;; - result type is a type specifier designating a DEFTYPEd type
  29 ;;; - the type expands to a the name of a user-defined sequence class
  30 ;;; - not all mandatory sequence protocol methods are define for the
  31 ;;;   user-define sequence class
  32 ;;; MAKE-SEQUENCE used to signal a SIMPLE-TYPE-ERROR referring to the
  33 ;;; unexpanded type specifier, instead of signaling a
  34 ;;; SEQUENCE:PROTOCOL-UNIMPLEMENTED error.
  35 (defclass bug-1315846-simple-sequence (sequence) ())
  36
  37 (deftype bug-1315846-sequence ()
  38   'bug-1315846-simple-sequence)
  39
  40 (with-test (:name (make-sequence :result-type deftype :bug-1315846))
  41   (assert-error (make-sequence 'bug-1315846-sequence 10)
  42                 sequence::protocol-unimplemented))
  43
  44 (with-test (:name (map :result-type deftype :bug-1315846))
  45   (assert-error (map 'bug-1315846-sequence #'1+ '(1 2 3))
  46                 sequence::protocol-unimplemented))
  47
  48 (with-test (:name (merge :result-type deftype :bug-1315846))
  49   (assert-error (merge 'bug-1315846-sequence (list 1 2 3) (list 4 5 6) #'<)
  50                 sequence::protocol-unimplemented))
  51
  52 (with-test (:name (concatenate :result-type deftype :bug-1315846))
  53   (assert-error (concatenate 'bug-1315846-sequence '(1 2) '(3 4))
  54                 sequence::protocol-unimplemented))
  55
  56 (defclass extended-sequence (sequence standard-object) ())
  57
  58 (defmethod sequence:length ((sequence extended-sequence))
  59   3)
  60
  61 (defmethod sequence:make-sequence-like ((sequence extended-sequence) (length t)
  62                                         &key &allow-other-keys)
  63   (make-instance 'extended-sequence))
  64
  65 (defmethod (setf sequence:elt) ((new-value t) (sequence extended-sequence) (index t))
  66   new-value)
  67
  68 (with-test (:name (map :result-creation))
  69   (assert (typep (map 'extended-sequence #'1+ '(1 2 3)) 'extended-sequence)))
  70
  71 (with-test (:name (make-sequence :result-type class))
  72   (assert (typep (make-sequence (find-class 'extended-sequence) 3)
  73                  'extended-sequence)))
  74
  75 (with-test (:name (map :result-type class))
  76   (assert (typep (map (find-class 'extended-sequence)
  77                       #'1+ '(1 2 3))
  78                  'extended-sequence)))
  79
  80 (with-test (:name (merge :result-type class))
  81   (assert (typep (merge (find-class 'extended-sequence)
  82                         (list 1 2 3) (list 4 5 6) #'<)
  83                  'extended-sequence)))
  84
  85 (with-test (:name (concatenate :result-type class))
  86   (assert (typep (concatenate (find-class 'extended-sequence) '(1 2) '(3 4))
  87                  'extended-sequence)))
  88
  89 (with-test (:name (:list-iterator :from-end))
  90   (checked-compile-and-assert (:allow-notes nil)
  91    `(lambda (x)
  92       (sb-sequence:with-sequence-iterator-functions (next stop value)
  93           (x :from-end t)
  94         (loop until (stop) collect (value) do (next))))
  95    (('(a b c d)) '(d c b a) :test #'equal)))
  96
  97 (defclass my-list (sequence standard-object)
  98   ((%nilp :initarg :nilp :initform nil :accessor nilp)
  99    (%kar :initarg :kar :accessor kar)
 100    (%kdr :initarg :kdr :accessor kdr)))
 101
 102 (defun my-list (&rest elems)
 103   (if (null elems)
 104       (load-time-value (make-instance 'my-list :nilp t) t)
 105       (make-instance 'my-list
 106         :kar (first elems) :kdr (apply #'my-list (rest elems)))))
 107
 108 (defmethod sequence:length ((sequence my-list))
 109   (if (nilp sequence)
 110       0
 111       (1+ (length (kdr sequence)))))
 112
 113 (defmethod sequence:make-sequence-iterator
 114     ((sequence my-list) &key from-end start end)
 115   (declare (ignore from-end))
 116   (let* ((index (or start 0))
 117          (iterator (loop for i from 0
 118                          for iterator = sequence then (kdr iterator)
 119                          until (= i index)
 120                          finally (return iterator)))
 121          (limit (if end
 122                     (loop for i from index
 123                           for limit = iterator then (kdr limit)
 124                           until (= i end)
 125                           finally (return limit))
 126                     (my-list))))
 127     (values iterator limit nil
 128             (lambda (sequence iterator from-end)
 129               (declare (ignore sequence from-end))
 130               (incf index)
 131               (kdr iterator))
 132             (lambda (sequence iterator limit from-end)
 133               (declare (ignore sequence from-end))
 134               (eq iterator limit))
 135             (lambda (sequence iterator)
 136               (declare (ignore sequence))
 137               (kar iterator))
 138             (lambda (new sequence iterator)
 139               (declare (ignore sequence))
 140               (setf (kar iterator) new))
 141             (lambda (sequence iterator)
 142               (declare (ignore sequence iterator))
 143               index)
 144             (lambda (sequence iterator)
 145               (declare (ignore sequence))
 146               iterator))))
 147
 148 (with-test (:name :map-into)
 149   (assert (equal (coerce (map-into (my-list 1 2 3) #'identity '(4 5 6)) 'list)
 150                  '(4 5 6))))
 151
 152 (with-test (:name (write-sequence :user-defined-sequence))
 153   (let ((sequence (my-list #\a #\b #\c)))
 154     (assert (string= "abc"
 155                      (with-output-to-string (stream)
 156                        (write-sequence sequence stream))))))
 157
 158 (with-test (:name (read-sequence :user-defined-sequence))
 159   (let ((sequence (my-list #\a #\b #\c #\d)))
 160     (with-input-from-string (stream "wxyz")
 161       (let ((position (read-sequence sequence stream :start 1 :end 3)))
 162         (assert (eql 3 position))
 163         (assert (equal '(#\a #\w #\x #\d) (coerce sequence 'list)))))))
 164
 165 ;;; example code from "User-extensible sequences in Common Lisp"
 166 ;;; (Rhodes, 2007)
 167
 168 (defclass queue (sequence standard-object)
 169   ((%data :accessor %queue-data) (%pointer :accessor %queue-pointer)))
 170 (defmethod initialize-instance :after ((o queue) &key)
 171   (let ((head (list nil)))
 172     (setf (%queue-data o) head (%queue-pointer o) head)))
 173 (defgeneric enqueue (data queue)
 174   (:argument-precedence-order queue data)
 175   (:method (data (o queue))
 176     (setf (cdr (%queue-pointer o)) (list data) (%queue-pointer o) (cdr (%queue-pointer o)))
 177     o))
 178 (defgeneric dequeue (queue)
 179   (:method ((o queue))
 180     (prog1 (cadr (%queue-data o))
 181       (setf (cdr (%queue-data o)) (cddr (%queue-data o))))))
 182
 183 (defclass funcallable-queue (queue sb-mop:funcallable-standard-object)
 184   ()
 185   (:metaclass sb-mop:funcallable-standard-class))
 186 (defmethod initialize-instance :after ((o funcallable-queue) &key)
 187   (flet ((fun (&optional (new nil new-p)) (if new-p (enqueue new o) (dequeue o))))
 188     (sb-mop:set-funcallable-instance-function o #'fun)))
 189
 190 (defmethod sequence:length ((o queue)) (length (cdr (%queue-data o))))
 191 (defmethod sequence:elt ((o queue) index) (elt (cdr (%queue-data o)) index))
 192 (defmethod (setf sequence:elt) (new-value (o queue) index) (setf (elt (cdr (%queue-data o)) index) new-value))
 193 (defmethod sequence:make-sequence-like ((o queue) length &key (initial-element nil iep) (initial-contents nil icp))
 194   (let ((result (make-instance (class-of o))))
 195     (cond
 196       ((and iep icp)
 197        (error "supplied both ~S and ~S to ~S" :initial-element :initial-contents 'make-sequence-like))
 198       (icp (unless (= (length initial-contents) length)
 199              (error "length mismatch in ~S" 'make-sequence-like))
 200            (setf (cdr (%queue-data result)) (coerce initial-contents 'list)
 201                  (%queue-pointer result) (last (%queue-data result))))
 202       (t (setf (cdr (%queue-data result)) (make-list length :initial-element initial-element)
 203                (%queue-pointer result) (last (%queue-data result)))))
 204     result))
 205 (defmethod sequence:adjust-sequence ((o queue) length &key initial-element (initial-contents nil icp))
 206   (cond
 207     ((= length 0)
 208      (setf (cdr (%queue-data o)) nil (%queue-pointer o) (%queue-data o)))
 209     (t (sequence:adjust-sequence (%queue-data o) (1+ length) :initial-element initial-element)
 210        (setf (%queue-pointer o) (last (%queue-data o)))
 211        (when icp (replace (%queue-data o) initial-contents :start1 1)) o)))
 212 (defmethod sequence:make-simple-sequence-iterator ((q queue) &rest args &key from-end start end)
 213   (declare (ignore from-end start end))
 214   (apply #'sequence:make-simple-sequence-iterator (cdr (%queue-data q)) args))
 215 (defmethod sequence:iterator-step ((q queue) iterator from-end)
 216   (sequence:iterator-step (cdr (%queue-data q)) iterator from-end))
 217 (defmethod sequence:iterator-endp ((q queue) iterator limit from-end)
 218   (sequence:iterator-endp (cdr (%queue-data q)) iterator limit from-end))
 219 (defmethod sequence:iterator-element ((q queue) iterator)
 220   (sequence:iterator-element (cdr (%queue-data q)) iterator))
 221 (defmethod (setf sequence:iterator-element) (new-value (q queue) iterator)
 222   (setf (sequence:iterator-element (cdr (%queue-data q)) iterator) new-value))
 223 (defmethod sequence:iterator-index ((q queue) iterator)
 224   (sequence:iterator-index (cdr (%queue-data q)) iterator))
 225 (defmethod sequence:iterator-copy ((q queue) iterator)
 226   (sequence:iterator-copy (cdr (%queue-data q)) iterator))
 227
 228 (with-test (:name (:ilc2007 :fig4a))
 229   (assert (= (length (coerce '(1 2 3 4) 'queue)) 4)))
 230 (with-test (:name (:ilc2007 :fig4b))
 231   (assert (= (count 1 (coerce '(1 2 3) 'queue)) 1)))
 232 (with-test (:name (:ilc2007 :fig4c))
 233   (let ((result (remove-if-not #'oddp (coerce '(1 2 3) 'funcallable-queue))))
 234     (assert (typep result 'funcallable-queue))
 235     (assert (eql (type-of result) 'funcallable-queue))
 236     (assert (= (length result) 2))
 237     (assert (= (funcall result) 1))
 238     (assert (= (funcall result) 3))
 239     (assert (= (length result) 0))))
 240 (with-test (:name (:ilc2007 :fig4d))
 241   (let ((result (remove-duplicates (coerce '(1 2 3 4 5) 'queue) :end 4
 242                                    :key #'oddp :from-end t)))
 243     (assert (typep result 'queue))
 244     (assert (eql (type-of result) 'queue))
 245     (assert (= (length result) 3))
 246     (assert (equal (coerce result 'list) '(1 2 5)))))