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 (load "test-util.lisp")
  18 (load "assertoid.lisp")
  19
  20 (with-test (:name (sb-kernel:extended-sequence subtypep :relations))
  21   (flet ((test-case (type1 type2)
  22            (assert (equal '(nil t)
  23                           (multiple-value-list (subtypep type1 type2))))))
  24     (subtypep 'sb-kernel:extended-sequence 'sb-kernel:instance)
  25     (subtypep 'sb-kernel:instance 'sb-kernel:extended-sequence)
  26
  27     (subtypep 'sb-kernel:extended-sequence 'sb-kernel:funcallable-instance)
  28     (subtypep 'sb-kernel:funcallable-instance 'sb-kernel:extended-sequence)))
  29
  30 ;;; For the following situation:
  31 ;;; - result type is a type specifier designating a DEFTYPEd type
  32 ;;; - the type expands to a the name of a user-defined sequence class
  33 ;;; - not all mandatory sequence protocol methods are define for the
  34 ;;;   user-define sequence class
  35 ;;; MAKE-SEQUENCE used to signal a SIMPLE-TYPE-ERROR referring to the
  36 ;;; unexpanded type specifier, instead of signaling a
  37 ;;; SEQUENCE:PROTOCOL-UNIMPLEMENTED error.
  38 (defclass bug-1315846-simple-sequence (sequence) ())
  39
  40 (deftype bug-1315846-sequence ()
  41   'bug-1315846-simple-sequence)
  42
  43 (with-test (:name (make-sequence :result-type deftype :bug-1315846))
  44   (assert-error (make-sequence 'bug-1315846-sequence 10)
  45                 sequence::protocol-unimplemented))
  46
  47 (with-test (:name (map :result-type deftype :bug-1315846))
  48   (assert-error (map 'bug-1315846-sequence #'1+ '(1 2 3))
  49                 sequence::protocol-unimplemented))
  50
  51 (with-test (:name (merge :result-type deftype :bug-1315846))
  52   (assert-error (merge 'bug-1315846-sequence (list 1 2 3) (list 4 5 6) #'<)
  53                 sequence::protocol-unimplemented))
  54
  55 (with-test (:name (concatenate :result-type deftype :bug-1315846))
  56   (assert-error (concatenate 'bug-1315846-sequence '(1 2) '(3 4))
  57                 sequence::protocol-unimplemented))
  58
  59 (defclass extended-sequence (sequence standard-object) ())
  60
  61 (defmethod sequence:length ((sequence extended-sequence))
  62   3)
  63
  64 (defmethod sequence:make-sequence-like ((sequence extended-sequence) (length t)
  65                                         &key &allow-other-keys)
  66   (make-instance 'extended-sequence))
  67
  68 (defmethod (setf sequence:elt) ((new-value t) (sequence extended-sequence) (index t))
  69   new-value)
  70
  71 (with-test (:name (map :result-creation))
  72   (assert (typep (map 'extended-sequence #'1+ '(1 2 3)) 'extended-sequence)))
  73
  74 (with-test (:name (make-sequence :result-type class))
  75   (assert (typep (make-sequence (find-class 'extended-sequence) 3)
  76                  'extended-sequence)))
  77
  78 (with-test (:name (map :result-type class))
  79   (assert (typep (map (find-class 'extended-sequence)
  80                       #'1+ '(1 2 3))
  81                  'extended-sequence)))
  82
  83 (with-test (:name (merge :result-type class))
  84   (assert (typep (merge (find-class 'extended-sequence)
  85                         (list 1 2 3) (list 4 5 6) #'<)
  86                  'extended-sequence)))
  87
  88 (with-test (:name (concatenate :result-type class))
  89   (assert (typep (concatenate (find-class 'extended-sequence) '(1 2) '(3 4))
  90                  'extended-sequence)))