some cleanups related to the type hackathon in 0.6.11.13..
..restored :TYPE declaration for FORMAT slot in NUMERIC-TYPE
..restored :TYPE declaration for TYPES slot in COMPOUND-TYPE
..moved LIST, CONS, and NULL to a more logical point in
*BUILT-IN-CLASSES*
..rearranged CTYPE, ANY/TYPE, and EVERY/TYPE to share code
..added tests related to CTYPE of COMPOUND-TYPE
..redid INTERSECTION :SIMPLE-SUBTYPEP to share EVERY/TYPE too
added tests for ANY/TYPE and EVERY/TYPE, fixed EVERY/TYPE
moved SWAPPED-ARGS-FUN earlier to facilitate inlining, putting
it in SB!INT so it can go in early-extensions.lisp
deleted unused LETF and LETF*
#<Closure Over Function "DEFUN (SETF MACRO-FUNCTION)" {480E21B1}> was defined in a non-null environment.
58:
- (SUBTYPEP '(AND ZILCH INTEGER) 'ZILCH)
- => NIL, NIL
+ (SUBTYPEP '(AND ZILCH INTEGER) 'ZILCH) => NIL, NIL
+ Note: I looked into fixing this in 0.6.11.15, but gave up. The
+ problem seems to be that there are two relevant type methods for
+ the subtypep operation, HAIRY :COMPLEX-SUBTYPEP-ARG2 and
+ INTERSECTION :COMPLEX-SUBTYPEP-ARG1, and only the first is
+ called. This could be fixed, but type dispatch is messy and
+ confusing enough already, I don't want to complicate it further.
+ Perhaps someday we can make CLOS cross-compiled (instead of compiled
+ after bootstrapping) so that we don't need to have the type system
+ available before CLOS, and then we can rewrite the type methods to
+ CLOS methods, and then expressing the solutions to stuff like this
+ should become much more straightforward. -- WHN 2001-03-14
59:
CL:*DEFAULT-PATHNAME-DEFAULTS* doesn't behave as ANSI suggests (reflecting
(I haven't tried to investigate this bug enough to guess whether
there might be any user-level symptoms.)
+86:
+ The system doesn't know how to reduce
+ (specifier-type '(intersection (or number vector) real)),
+ it just ends up as a HAIRY-TYPE. Smarter INTERSECTION2 methods for
+ UNION-TYPE might help.
+
+87:
+ Despite what the manual says, (DECLAIM (SPEED 0)) doesn't cause
+ things to be byte compiled. This seems to be true in cmucl-2.4.19,
+ too: (COMPILE-FILE .. :BYTE-COMPILE T) causes byte-compilation,
+ but ordinary COMPILE-FILE of a file containing (DECLAIM (SPEED 0))
+ does not.
+
KNOWN BUGS RELATED TO THE IR1 INTERPRETER
"SIMPLE-PROGRAM-ERROR" "SIMPLE-STYLE-WARNING"
"STYLE-WARN"
- ;; miscellaneous non-standard but widely useful user-level
- ;; functions..
+ ;; bootstrapping magic, to make things happen both in
+ ;; the cross-compilation host compiler's environment and
+ ;; in the cross-compiler's environment
+ "DEF!MACRO" "DEF!METHOD" "DEF!STRUCT" "DEF!TYPE"
+
+ ;; miscellaneous non-standard but handy user-level functions..
"ASSQ" "DELQ" "MEMQ" "POSQ" "NEQ"
"%FIND-PACKAGE-OR-LOSE" "FIND-UNDELETED-PACKAGE-OR-LOSE"
"SANE-PACKAGE"
"CIRCULAR-LIST-P"
+ "SWAPPED-ARGS-FUN"
;; ..and macros..
"COLLECT"
"DO-ANONYMOUS" "DOHASH" "DOVECTOR"
"NAMED-LET"
- "LETF" "LETF*"
"ONCE-ONLY"
"DEFENUM"
"DEFPRINTER"
- "DEF!MACRO" "DEF!METHOD" "DEF!STRUCT" "DEF!TYPE"
;; ..and DEFTYPEs..
"INDEX"
array sequence
generic-string generic-vector generic-array mutable-sequence
mutable-collection generic-sequence collection))
+ (list
+ :translation (or cons (member nil))
+ :inherits (sequence mutable-sequence mutable-collection
+ generic-sequence collection))
+ (cons
+ :codes (#.sb!vm:list-pointer-type)
+ :translation cons
+ :inherits (list sequence
+ mutable-sequence mutable-collection
+ generic-sequence collection))
+ (null
+ :translation (member nil)
+ :inherits (list sequence
+ mutable-sequence mutable-collection
+ generic-sequence collection symbol)
+ :direct-superclasses (list symbol))
(generic-number :state :read-only)
(number :translation number :inherits (generic-number))
(complex
(rational
:translation rational
:inherits (real number generic-number))
-
- ;; FIXME: moved LIST, CONS, and NULL here to help with translation
- ;; of RATIO now that sbcl-0.6.11.13 has real INTERSECTION-TYPE;
- ;; but it would be tidier to move them further back, if possible,
- ;; so that all the numeric types are in an uninterrupted sequence
- (list
- :translation (or cons (member nil))
- :inherits (sequence mutable-sequence mutable-collection
- generic-sequence collection))
- (cons
- :codes (#.sb!vm:list-pointer-type)
- :translation cons
- :inherits (list sequence
- mutable-sequence mutable-collection
- generic-sequence collection))
- (null
- :translation (member nil)
- :inherits (list sequence
- mutable-sequence mutable-collection
- generic-sequence collection symbol)
- :direct-superclasses (list symbol))
-
(ratio
:translation (and rational (not integer))
:inherits (rational real number generic-number)
;; a constant as long as the new value is EQL to the old
;; value.)
))
+
+;;; Return a function like FUN, but expecting its (two) arguments in
+;;; the opposite order that FUN does.
+(declaim (inline swapped-args-fun))
+(defun swapped-args-fun (fun)
+ (declare (type function fun))
+ (lambda (x y)
+ (funcall fun y x)))
\f
;;;; DEFPRINTER
;; to do with #'FORMAT), or NIL if not specified or not a float.
;; Formats which don't exist in a given implementation don't appear
;; here.
- (format nil
- ;; FIXME: suppressed because of cold init problems under
- ;; hacked type system in sbcl-0.6.11.13, should be restored
- #+nil :type #+nil (or float-format null))
+ (format nil :type (or float-format null))
;; Is this a complex numeric type? Null if unknown (only in NUMBER).
;;
;; FIXME: I'm bewildered by FOO-P names for things not intended to
(defstruct (compound-type (:include ctype)
(:constructor nil)
(:copier nil))
- (types nil
- ;; FIXME: This type declaration was suppresed as a temporary
- ;; hack to work around sbcl-0.6.11.13 cold init problems.
- ;; Restore it.
- #+nil :type #+nil list
- :read-only t))
+ (types nil :type list :read-only t))
;;; A UNION-TYPE represents a use of the OR type specifier which we
;;; couldn't canonicalize to something simpler. Canonical form:
(type=-set (intersection-type-types type1)
(intersection-type-types type2)))
-(!define-type-method (intersection :simple-subtypep) (type1 type2)
- (let ((certain? t))
- (dolist (t1 (intersection-type-types type1) (values nil certain?))
- (multiple-value-bind (subtypep validp)
- (intersection-complex-subtypep-arg2 t1 type2)
- (cond ((not validp)
- (setf certain? nil))
- (subtypep
- (return (values t t))))))))
-
-(!define-type-method (intersection :complex-subtypep-arg1) (type1 type2)
- (any/type (swapped-args-fun #'csubtypep)
- type2
- (intersection-type-types type1)))
-
-(defun intersection-complex-subtypep-arg2 (type1 type2)
- (every/type #'csubtypep type1 (intersection-type-types type2)))
+(flet ((intersection-complex-subtypep-arg1 (type1 type2)
+ (any/type (swapped-args-fun #'csubtypep)
+ type2
+ (intersection-type-types type1))))
+ (!define-type-method (intersection :simple-subtypep) (type1 type2)
+ (every/type #'intersection-complex-subtypep-arg1
+ type1
+ (intersection-type-types type2)))
+ (!define-type-method (intersection :complex-subtypep-arg1) (type1 type2)
+ (intersection-complex-subtypep-arg1 type1 type2)))
+
(!define-type-method (intersection :complex-subtypep-arg2) (type1 type2)
- (intersection-complex-subtypep-arg2 type1 type2))
+ (every/type #'csubtypep type1 (intersection-type-types type2)))
(!def-type-translator and (&whole whole &rest type-specifiers)
(apply #'type-intersection
;;; types. For STRUCTURE- types, we require that the type be defined
;;; in both the current and compiler environments, and that the
;;; INCLUDES be the same.
+;;;
+;;; KLUDGE: This should probably be a type method instead of a big
+;;; ETYPECASE. But then the type method system should probably be CLOS
+;;; too, and until that happens wedging more stuff into it might be
+;;; messy. So I've left it a big ETYPECASE. -- 2001-03-16
(defun ctypep (obj type)
(declare (type ctype type))
(etypecase type
(values nil nil))
(values nil t)))
(compound-type
+ ;; REMOVEME: old version
+ #|
(let ((certain? t))
(etypecase type
- ;; FIXME: The cases here are very similar to #'EVERY/TYPE and
- ;; #'ANY/TYPE. It would be good to fix them so that they
- ;; share the same code. (That will require making sure that
- ;; the two-value return convention for CTYPEP really is
- ;; exactly compatible with the two-value convention the
- ;; quantifier/TYPE functions operate on, and probably also
- ;; making sure that things are inlined and defined early
- ;; enough that consing can be avoided.)
(union-type
(dolist (mem (union-type-types type) (values nil certain?))
(multiple-value-bind (val win) (ctypep obj mem)
(multiple-value-bind (val win) (ctypep obj mem)
(if win
(unless val (return (values nil t)))
- (setf certain? nil))))))))
+ (setf certain? nil)))))))
+ |#
+ (let ((types (compound-type-types type)))
+ (etypecase type
+ (intersection-type (every/type #'ctypep obj types))
+ (union-type (any/type #'ctypep obj types)))))
(function-type
(values (functionp obj) t))
(unknown-type
;;; sort of like ANY and EVERY, except:
;;; * We handle two-VALUES predicate functions like SUBTYPEP. (And
-;;; if the result is uncertain, then we return (VALUES NIL NIL).)
+;;; if the result is uncertain, then we return (VALUES NIL NIL),
+;;; just like SUBTYPEP.)
;;; * THING is just an atom, and we apply OP (an arity-2 function)
;;; successively to THING and each element of LIST.
(defun any/type (op thing list)
(declare (type function op))
(let ((certain? t))
(dolist (i list (values nil certain?))
- (multiple-value-bind (sub-value sub-certain?)
- (funcall op thing i)
- (unless sub-certain? (setf certain? nil))
- (when sub-value (return (values t t)))))))
+ (multiple-value-bind (sub-value sub-certain?) (funcall op thing i)
+ (if sub-certain?
+ (when sub-value (return (values t t)))
+ (setf certain? nil))))))
(defun every/type (op thing list)
(declare (type function op))
- (dolist (i list (values t t))
- (multiple-value-bind (sub-value sub-certain?)
- (funcall op thing i)
- (unless sub-certain? (return (values nil nil)))
- (unless sub-value (return (values nil t))))))
-
-;;; Return a function like FUN, but expecting its (two) arguments in
-;;; the opposite order that FUN does.
-;;;
-;;; (This looks like a sort of general utility, but currently it's
-;;; used only in the implementation of the type system, so it's
-;;; internal to SB-KERNEL. -- WHN 2001-02-13)
-(declaim (inline swapped-args-fun))
-(defun swapped-args-fun (fun)
- (declare (type function fun))
- (lambda (x y)
- (funcall fun y x)))
+ (let ((certain? t))
+ (dolist (i list (if certain? (values t t) (values nil nil)))
+ (multiple-value-bind (sub-value sub-certain?) (funcall op thing i)
+ (if sub-certain?
+ (unless sub-value (return (values nil t)))
+ (setf certain? nil))))))
;;; Look for a nice intersection for types that intersect only when
;;; one is a hierarchical subtype of the other.
(assert (csubtypep *empty-type* ctype))
(assert (csubtypep ctype *universal-type*))))
-(/show "done with identities-should-be-identities block")
+(/show "finished with identities-should-be-identities block")
(assert (sb-xc:subtypep 'simple-vector 'vector))
(assert (sb-xc:subtypep 'simple-vector 'simple-array))
nil))
|#)
+;;; tests of 2-value quantifieroids FOO/TYPE
+(macrolet ((2= (v1 v2 expr2)
+ (let ((x1 (gensym))
+ (x2 (gensym)))
+ `(multiple-value-bind (,x1 ,x2) ,expr2
+ (unless (and (eql ,x1 ,v1) (eql ,x2 ,v2))
+ (error "mismatch for EXPR2=~S" ',expr2))))))
+ (flet (;; SUBTYPEP running in the cross-compiler
+ (xsubtypep (x y)
+ (csubtypep (specifier-type x)
+ (specifier-type y))))
+ (2= t t (any/type #'xsubtypep 'fixnum '(real integer)))
+ (2= t t (any/type #'xsubtypep 'fixnum '(real cons)))
+ (2= nil t (any/type #'xsubtypep 'fixnum '(cons vector)))
+ (2= nil nil (any/type #'xsubtypep 'fixnum '(cons some-unknown-type-foo)))
+ (2= nil nil (any/type #'xsubtypep 'fixnum '(some-unknown-type-foo cons)))
+ (2= t t (any/type #'xsubtypep 'fixnum '(some-unknown-type-foo real)))
+ (2= t t (any/type #'xsubtypep 'fixnum '(real some-unknown-type-foo)))
+ (2= nil t (any/type #'xsubtypep 'fixnum '()))
+ (2= t t (every/type #'xsubtypep 'fixnum '()))
+ (2= nil nil (every/type #'xsubtypep 'fixnum '(real some-unknown-type-foo)))
+ (2= nil nil (every/type #'xsubtypep 'fixnum '(some-unknown-type-foo real)))
+ (2= nil t (every/type #'xsubtypep 'fixnum '(some-unknown-type-foo cons)))
+ (2= nil t (every/type #'xsubtypep 'fixnum '(cons some-unknown-type-foo)))
+ (2= t t (every/type #'xsubtypep 'fixnum '(real integer)))
+ (2= nil t (every/type #'xsubtypep 'fixnum '(real cons)))
+ (2= nil t (every/type #'xsubtypep 'fixnum '(cons vector)))))
+
;;; various dead bugs
(assert (union-type-p (type-intersection (specifier-type 'list)
(specifier-type '(or list vector)))))
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+(in-package "CL-USER")
+
+(locally
+ (declare (notinline mapcar))
+ (mapcar (lambda (args)
+ (destructuring-bind (obj type-spec result) args
+ (flet ((matches-result? (x)
+ (eq (if x t nil) result)))
+ (assert (matches-result? (typep obj type-spec)))
+ (assert (matches-result? (sb-kernel:ctypep
+ obj
+ (sb-kernel:specifier-type
+ type-spec)))))))
+ '((nil (or null vector) t)
+ (nil (or number vector) nil)
+ (12 (or null vector) nil)
+ (12 (and (or number vector) real) t))))
+
+
\ No newline at end of file
;;; versions, and a string like "0.6.5.12" is used for versions which
;;; aren't released but correspond only to CVS tags or snapshots.
-"0.6.11.14"
+"0.6.11.15"
projects / sbcl.git / commitdiff