1 ;;;; Tests related to extended sequences.
3 ;;;; This file is impure because we want to be able to define methods
4 ;;;; implementing the extended sequence protocol.
6 ;;;; This software is part of the SBCL system. See the README file for
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
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.
17 (load "test-util.lisp")
18 (load "assertoid.lisp")
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
)
27 (subtypep 'sb-kernel
:extended-sequence
'sb-kernel
:funcallable-instance
)
28 (subtypep 'sb-kernel
:funcallable-instance
'sb-kernel
:extended-sequence
)))
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) ())
40 (deftype bug-1315846-sequence
()
41 'bug-1315846-simple-sequence
)
43 (with-test (:name
(make-sequence deftype
:bug-1315846
))
44 (assert-error (make-sequence 'bug-1315846-sequence
10)
45 sequence
::protocol-unimplemented
))
47 (defclass extended-sequence
(sequence standard-object
) ())
49 (defmethod sequence:length
((sequence extended-sequence
))
52 (defmethod sequence:make-sequence-like
((sequence extended-sequence
) (length t
)
53 &key
&allow-other-keys
)
54 (make-instance 'extended-sequence
))
56 (defmethod (setf sequence
:elt
) ((new-value t
) (sequence extended-sequence
) (index t
))
59 (with-test (:name
(make-sequence :type-specifier class
))
60 (make-sequence (find-class 'extended-sequence
) 3))
62 (with-test (:name
(map make-sequence
:result-creation
))
63 (assert (typep (map 'extended-sequence
#'1+ '(1 2 3)) 'extended-sequence
)))