(multiple-value-bind (required optional restp rest keyp keys allowp aux)
(parse-lambda-list lambda-list)
(when aux
- (error "&Aux in a FUNCTION or VALUES type: ~S." lambda-list))
+ (error "&AUX in a FUNCTION or VALUES type: ~S." lambda-list))
(setf (args-type-required result) (mapcar #'specifier-type required))
(setf (args-type-optional result) (mapcar #'specifier-type optional))
(setf (args-type-rest result) (if restp (specifier-type rest) nil))
(error "Keyword type description is not a two-list: ~S." key))
(let ((kwd (first key)))
(when (find kwd (key-info) :key #'key-info-name)
- (error "Repeated keyword ~S in lambda list: ~S." kwd lambda-list))
+ (error "~@<repeated keyword ~S in lambda list: ~2I~_~S~:>"
+ kwd lambda-list))
(key-info (make-key-info :name kwd
:type (specifier-type (second key))))))
(setf (args-type-keywords result) (key-info)))
(make-member-type :members (members))))
t))))
-;;; We don't need a :COMPLEX-UNION, since the only interesting case is a union
-;;; type, and the member/union interaction is handled by the union type
-;;; method.
+;;; We don't need a :COMPLEX-UNION, since the only interesting case is
+;;; a union type, and the member/union interaction is handled by the
+;;; union type method.
(!define-type-method (member :simple-union) (type1 type2)
(let ((mem1 (member-type-members type1))
(mem2 (member-type-members type2)))
(!define-type-method (member :simple-=) (type1 type2)
(let ((mem1 (member-type-members type1))
(mem2 (member-type-members type2)))
- (values (and (subsetp mem1 mem2) (subsetp mem2 mem1))
+ (values (and (subsetp mem1 mem2)
+ (subsetp mem2 mem1))
t)))
(!define-type-method (member :complex-=) (type1 type2)
;;;; ;; reasonable behavior
;;;; (ASSERT (SUBTYPEP 'KEYWORD 'SYMBOL))
;;;; Without understanding a little about the semantics of AND, we'd
-;;;; get (SUBTYPEP 'KEYWORD 'SYMBOL)=>NIL,NIL, which is unreasonable.)
+;;;; get (SUBTYPEP 'KEYWORD 'SYMBOL)=>NIL,NIL and, for entirely
+;;;; parallel reasons, (SUBTYPEP 'RATIO 'NUMBER)=>NIL,NIL. That's
+;;;; not so good..)
;;;;
;;;; We still follow the example of CMU CL to some extent, by punting
;;;; (to the opaque HAIRY-TYPE) on sufficiently complicated types
;;; the intersection type in some other way.
(defun make-intersection-type-or-something (types)
(declare (list types))
+ (/show0 "entering MAKE-INTERSECTION-TYPE-OR-SOMETHING")
(cond ((null types)
*universal-type*)
((null (cdr types))
(%make-intersection-type (some #'type-enumerable types) types))))
(!define-type-class intersection)
+
+;;; A few intersection types have special names. The others just get
+;;; mechanically unparsed.
+(!define-type-method (intersection :unparse) (type)
+ (declare (type ctype type))
+ (/show0 "entering INTERSECTION :UNPARSE")
+ (or (find type '(ratio bignum keyword) :key #'specifier-type :test #'type=)
+ `(and ,@(mapcar #'type-specifier (intersection-type-types type)))))
+
+;;; shared machinery for type equality: true if every type in the set
+;;; TYPES1 matches a type in the set TYPES2 and vice versa
+(defun type=-set (types1 types2)
+ (/show0 "entering TYPE=-SET")
+ (flet (;; true if every type in the set X matches a type in the set Y
+ (type<=-set (x y)
+ (declare (type list x y))
+ (every (lambda (xelement)
+ (position xelement y :test #'type=))
+ x)))
+ (values (and (type<=-set types1 types2)
+ (type<=-set types2 types1))
+ t)))
+
+;;; Two intersection types are equal if their subtypes are equal sets.
+;;;
+;;; FIXME: Might it be better to use
+;;; (AND (SUBTYPEP X Y) (SUBTYPEP Y X))
+;;; instead, since SUBTYPEP is the usual relationship that we care
+;;; most about, so it would be good to leverage any ingenuity there
+;;; in this more obscure method?
+(!define-type-method (intersection :simple-=) (type1 type2)
+ (/show0 "entering INTERSECTION :SIMPLE-=")
+ (type=-set (intersection-type-types type1)
+ (intersection-type-types type2)))
+
+(!define-type-method (intersection :simple-subtypep) (type1 type2)
+ (declare (type list type1 type2))
+ (/show0 "entering INTERSECTION :SIMPLE-SUBTYPEP")
+ (some (lambda (t1)
+ (every (lambda (t2)
+ (csubtypep t1 t2))
+ type2))
+ type1))
+
+(!define-type-method (intersection :complex-subtypep-arg1) (type1 type2)
+ (/show0 "entering INTERSECTION :COMPLEX-SUBTYPEP-ARG1")
+ (values (any-type-op csubtypep
+ type2
+ (intersection-type-types type1)
+ :list-first t)
+ t))
+
+(!define-type-method (intersection :complex-subtypep-arg2) (type1 type2)
+ (/show0 "entering INTERSECTION :COMPLEX-SUBTYPEP-ARG2")
+ (values (every-type-op csubtypep type1 (intersection-type-types type2))
+ t))
+
+;;; Return a new type list where pairs of types whose intersections
+;;; can be represented simply have been replaced by the simple
+;;; representation.
+(defun simplify-intersection-type-types (%types)
+ (/show0 "entering SIMPLE-INTERSECTION-TYPE-TYPES")
+ (do* ((types (copy-list %types)) ; (to undestructivize the algorithm below)
+ (i-types types (cdr i-types))
+ (i-type (car i-types) (car i-types)))
+ ((null i-types))
+ (do* ((pre-j-types i-types (cdr pre-j-types))
+ (j-types (cdr pre-j-types) (cdr pre-j-types))
+ (j-type (car j-types) (car j-types)))
+ ((null j-types))
+ (multiple-value-bind (isect win) (type-intersection i-type j-type)
+ (when win
+ ;; Overwrite I-TYPES with the intersection, and delete
+ ;; J-TYPES from the list.
+ (setf (car i-types) isect
+ (cdr pre-j-types) (cdr j-types)))))
+ (/show0 "leaving SIMPLE-INTERSECTION-TYPE-TYPES")
+ types))
+
+(!define-type-method (intersection :simple-intersection :complex-intersection)
+ (type1 type2)
+ (/show0 "entering INTERSECTION :SIMPLE-INTERSECTION :COMPLEX-INTERSECTION")
+ (let ((type1types (intersection-type-types type1))
+ (type2types (if (intersection-type-p type2)
+ (intersection-type-types type2)
+ (list type2))))
+ (make-intersection-type-or-something
+ (simplify-intersection-type-types
+ (append type1types type2types)))))
+
+#|
+(!def-type-translator and (&rest type-specifiers)
+ ;; Note: Between the behavior of SIMPLIFY-INTERSECTION-TYPE (which
+ ;; will reduce to a 1-element list any list of types which CMU CL
+ ;; could've represented) and MAKE-INTERSECTION-TYPE-OR-SOMETHING
+ ;; (which knows to treat a 1-element intersection as the element
+ ;; itself) we should recover CMU CL's behavior for anything which it
+ ;; could handle usefully (i.e. could without punting to HAIRY-TYPE).
+ (/show0 "entering type translator for AND")
+ (make-intersection-type-or-something
+ (simplify-intersection-type-types
+ (mapcar #'specifier-type type-specifiers))))
+|#
+;;; (REMOVEME once INTERSECTION-TYPE works.)
+(!def-type-translator and (&whole spec &rest types)
+ (let ((res *wild-type*))
+ (dolist (type types res)
+ (let ((ctype (specifier-type type)))
+ (multiple-value-bind (int win) (type-intersection res ctype)
+ (unless win
+ (return (make-hairy-type :specifier spec)))
+ (setq res int))))))
\f
;;;; union types
(!define-type-class union)
-;;; If LIST, then return that, otherwise the OR of the component types.
+;;; The LIST type has a special name. Other union types
+;;; just get mechanically unparsed.
(!define-type-method (union :unparse) (type)
(declare (type ctype type))
(if (type= type (specifier-type 'list))
'list
`(or ,@(mapcar #'type-specifier (union-type-types type)))))
-;;; Two union types are equal if every type in one is equal to some
-;;; type in the other.
+;;; Two union types are equal if their subtypes are equal sets.
(!define-type-method (union :simple-=) (type1 type2)
- (let ((types1 (union-type-types type1))
- (types2 (union-type-types type2)))
- (values (and (dolist (type1 types1 t)
- (unless (any-type-op type= type1 types2)
- (return nil)))
- (dolist (type2 types2 t)
- (unless (any-type-op type= type2 types1)
- (return nil))))
- t)))
+ (type=-set (union-type-types type1)
+ (union-type-types type2)))
;;; Similarly, a union type is a subtype of another if every element
;;; of TYPE1 is a subtype of some element of TYPE2.
+;;;
+;;; KLUDGE: This definition seems redundant, here in UNION-TYPE and
+;;; similarly in INTERSECTION-TYPE, with the logic in the
+;;; corresponding :COMPLEX-SUBTYPEP-ARG1 and :COMPLEX-SUBTYPEP-ARG2
+;;; methods. Ideally there's probably some way to make the
+;;; :SIMPLE-SUBTYPEP method default to the :COMPLEX-SUBTYPEP-FOO
+;;; methods in such a way that this definition could go away, but I
+;;; don't grok the system well enough to tell whether it's simple to
+;;; arrange this. -- WHN 2000-02-03
(!define-type-method (union :simple-subtypep) (type1 type2)
(let ((types2 (union-type-types type2)))
(values (dolist (type1 (union-type-types type1) t)
(setq res (type-union res t2)))))
(!define-type-method (union :simple-intersection :complex-intersection)
- (type1 type2)
+ (type1 type2)
(let ((res *empty-type*)
(win t))
(dolist (type (union-type-types type2) (values res win))
(reduce #'type-union
(mapcar #'specifier-type type-specifiers)
:initial-value *empty-type*))
-
-;;; (Destructively) replace pairs of types which have simple
-;;; intersections with their simple intersection.
-(defun simplify-intersection-type-types (types)
- (do* ((i-types types (cdr i-types))
- (i-type (car i-types) (car i-types)))
- ((null i-types))
- (do* ((pre-j-types i-types (cdr pre-j-types))
- (j-types (cdr pre-j-types) (cdr pre-j-types))
- (j-type (car j-types) (car j-types)))
- ((null j-types))
- (multiple-value-bind (isect win) (type-intersection i-type j-type)
- (when win
- ;; Overwrite I-TYPES with the intersection, and delete
- ;; J-TYPES from the list.
- (setf (car i-types) isect
- (cdr pre-j-types) (cdr j-types))))))
- types)
-
-(!def-type-translator and (&rest type-specifiers)
- ;; Note: Between the behavior of SIMPLIFY-INTERSECTION-TYPE (which
- ;; will reduce to a 1-element list any list of types which CMU CL
- ;; could've represented) and MAKE-INTERSECTION-TYPE-OR-SOMETHING
- ;; (which knows to treat a 1-element intersection as the element
- ;; itself) we should recover CMU CL's behavior for anything which it
- ;; could handle usefully (i.e. could without punting to HAIRY-TYPE).
- (make-intersection-type-or-something
- (simplify-intersection-type-types
- (mapcar #'specifier-type type-specifiers))))
\f
;;;; CONS types
(declaim (special *current-path*))
-;;; We bind print level and length when printing out messages so that we don't
-;;; dump huge amounts of garbage.
+;;; We bind print level and length when printing out messages so that
+;;; we don't dump huge amounts of garbage.
+;;;
+;;; FIXME: It's not possible to get the defaults right for everyone.
+;;; So: Should these variables be in the SB-EXT package? Or should we
+;;; just get rid of them completely and just use the bare
+;;; CL:*PRINT-FOO* variables instead?
(declaim (type (or unsigned-byte null)
*compiler-error-print-level*
*compiler-error-print-length*
(setq *last-message-count* 0))
;;; Print out the message, with appropriate context if we can find it.
-;;; If If the context is different from the context of the last
-;;; message we printed, then we print the context. If the original
-;;; source is different from the source we are working on, then we
-;;; print the current source in addition to the original source.
+;;; If the context is different from the context of the last message
+;;; we printed, then we print the context. If the original source is
+;;; different from the source we are working on, then we print the
+;;; current source in addition to the original source.
;;;
;;; We suppress printing of messages identical to the previous, but
;;; record the number of times that the message is repeated.
(defun print-compiler-condition (condition)
(declare (type condition condition))
- (let (;; These different classes of conditions have different effects
- ;; on the return codes of COMPILE-FILE, so it's nice for users to be
- ;; able to pick them out by lexical search through the output.
+ (let (;; These different classes of conditions have different
+ ;; effects on the return codes of COMPILE-FILE, so it's nice
+ ;; for users to be able to pick them out by lexical search
+ ;; through the output.
(what (etypecase condition
(style-warning 'style-warning)
(warning 'warning)
(defvar *warnings-p*)
;;; condition handlers established by the compiler. We re-signal the
-;;; condition, if it is not handled, we increment our warning counter
-;;; and print the error message.
+;;; condition, then if it isn't handled, we increment our warning
+;;; counter and print the error message.
(defun compiler-error-handler (condition)
(signal condition)
(incf *compiler-error-count*)
projects / sbcl.git / commitdiff