diff --git a/code/type.lisp b/code/type.lisp index 45022470d78516a63775735f72eba140a9aa4b92..535f766525bcb894db45542ccddc9e088db7b4ef 100644 --- a/code/type.lisp +++ b/code/type.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/type.lisp,v 1.48 2002/12/07 16:54:54 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/type.lisp,v 1.49 2003/02/03 15:19:38 toy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -2371,21 +2371,31 @@ (:print-function %print-type)) ;; ;; The car element type. - (car-type *wild-type* :type ctype) + (car-type *universal-type* :type ctype) ;; ;; The cdr element type. - (cdr-type *wild-type* :type ctype)) + (cdr-type *universal-type* :type ctype)) (define-type-class cons) (def-type-translator cons (&optional car-type cdr-type) - (make-cons-type :car-type (specifier-type car-type) - :cdr-type (specifier-type cdr-type))) + (let ((car-spec (specifier-type car-type)) + (cdr-spec (specifier-type cdr-type))) + ;; (cons nil x) and (cons x nil) are the empty type. + ;; + ;; A type '* is the same as T. Smash it to type T. + (if (or (eq car-spec *empty-type*) (eq cdr-spec *empty-type*)) + *empty-type* + (make-cons-type :car-type (if (eq car-spec *wild-type*) *universal-type* car-spec) + :cdr-type (if (eq cdr-spec *wild-type*) *universal-type* cdr-spec))))) (define-type-method (cons :unparse) (type) (let ((car-eltype (type-specifier (cons-type-car-type type))) (cdr-eltype (type-specifier (cons-type-cdr-type type)))) - (cond ((and (eq car-eltype '*) (eq cdr-eltype '*)) + ;; We test for '* just in case it snuck through somehow; it's not + ;; supposed to happen though. + (cond ((or (and (eq car-eltype '*) (eq cdr-eltype '*)) + (and (eq car-eltype t) (eq cdr-eltype t))) 'cons) (t `(cons ,car-eltype ,cdr-eltype)))))