;;; Return two values:
;;; MNA: fix-instance-typep-call patch
;;; 1. A list of all the positional (fixed and optional) types.
-;;; 2] The rest type (if any). If keywords allowed, *universal-type*.
-;;; If no keywords or rest then the default-type.
+;;; 2. The &REST type (if any). If keywords allowed, *UNIVERSAL-TYPE*.
+;;; If no keywords or &REST, then the DEFAULT-TYPE.
(defun values-type-types (type &optional (default-type *empty-type*))
(declare (type values-type type))
(values (append (args-type-required type)
;;; A list of all the float formats, in order of decreasing precision.
(eval-when (:compile-toplevel :load-toplevel :execute)
- (defconstant float-formats
+ (defparameter *float-formats*
'(long-float double-float single-float short-float)))
;;; The type of a float format.
-(deftype float-format () `(member ,@float-formats))
+(deftype float-format () `(member ,@*float-formats*))
#!+negative-zero-is-not-zero
(defun make-numeric-type (&key class format (complexp :real) low high
;;; either one is null, return NIL.
(defun float-format-max (f1 f2)
(when (and f1 f2)
- (dolist (f float-formats (error "Bad float format: ~S." f1))
+ (dolist (f *float-formats* (error "bad float format: ~S" f1))
(when (or (eq f f1) (eq f f2))
(return f)))))
-;;; Return the result of an operation on Type1 and Type2 according to
+;;; Return the result of an operation on TYPE1 and TYPE2 according to
;;; the rules of numeric contagion. This is always NUMBER, some float
;;; format (possibly complex) or RATIONAL. Due to rational
;;; canonicalization, there isn't much we can do here with integers or
;;; rational complex numbers.
;;;
-;;; If either argument is not a Numeric-Type, then return NUMBER. This
+;;; If either argument is not a NUMERIC-TYPE, then return NUMBER. This
;;; is useful mainly for allowing types that are technically numbers,
-;;; but not a Numeric-Type.
+;;; but not a NUMERIC-TYPE.
(defun numeric-contagion (type1 type2)
(if (and (numeric-type-p type1) (numeric-type-p type2))
(let ((class1 (numeric-type-class type1))
(return (make-hairy-type :specifier spec)))
(setq res int))))))
\f
+;;;; CONS types
-;;; MNA: cons compound-type patch
-;;; FIXIT: all commented out
+(define-type-class cons)
-; (define-type-class cons)
+(def-type-translator cons (&optional (car-type-spec '*) (cdr-type-spec '*))
+ (make-cons-type (specifier-type car-type-spec)
+ (specifier-type cdr-type-spec)))
-; (def-type-translator cons (&optional car-type cdr-type)
-; (make-cons-type :car-type (specifier-type car-type)
-; :cdr-type (specifier-type cdr-type)))
+(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))))
+ (if (and (member car-eltype '(t *))
+ (member cdr-eltype '(t *)))
+ 'cons
+ `(cons ,car-eltype ,cdr-eltype))))
-; (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 '*))
-; 'cons)
-; (t
-; `(cons ,car-eltype ,cdr-eltype)))))
+(define-type-method (cons :simple-=) (type1 type2)
+ (declare (type cons-type type1 type2))
+ (and (type= (cons-type-car-type type1) (cons-type-car-type type2))
+ (type= (cons-type-cdr-type type1) (cons-type-cdr-type type2))))
-; (define-type-method (cons :simple-=) (type1 type2)
-; (declare (type cons-type type1 type2))
-; (and (type= (cons-type-car-type type1) (cons-type-car-type type2))
-; (type= (cons-type-cdr-type type1) (cons-type-cdr-type type2))))
+(define-type-method (cons :simple-subtypep) (type1 type2)
+ (declare (type cons-type type1 type2))
+ (multiple-value-bind (val-car win-car)
+ (csubtypep (cons-type-car-type type1) (cons-type-car-type type2))
+ (multiple-value-bind (val-cdr win-cdr)
+ (csubtypep (cons-type-cdr-type type1) (cons-type-cdr-type type2))
+ (if (and val-car val-cdr)
+ (values t (and win-car win-cdr))
+ (values nil (or win-car win-cdr))))))
-; (define-type-method (cons :simple-subtypep) (type1 type2)
-; (declare (type cons-type type1 type2))
-; (multiple-value-bind (val-car win-car)
-; (csubtypep (cons-type-car-type type1) (cons-type-car-type type2))
-; (multiple-value-bind (val-cdr win-cdr)
-; (csubtypep (cons-type-cdr-type type1) (cons-type-cdr-type type2))
-; (if (and val-car val-cdr)
-; (values t (and win-car win-cdr))
-; (values nil (or win-car win-cdr))))))
-
-; ;;; CONS :simple-union method -- Internal
-; ;;;
-; ;;; Give up if a precise type in not possible, to avoid returning overly
-; ;;; general types.
-; ;;;
-; (define-type-method (cons :simple-union) (type1 type2)
-; (declare (type cons-type type1 type2))
-; (let ((car-type1 (cons-type-car-type type1))
-; (car-type2 (cons-type-car-type type2))
-; (cdr-type1 (cons-type-cdr-type type1))
-; (cdr-type2 (cons-type-cdr-type type2)))
-; (cond ((type= car-type1 car-type2)
-; (make-cons-type :car-type car-type1
-; :cdr-type (type-union cdr-type1 cdr-type2)))
-; ((type= cdr-type1 cdr-type2)
-; (make-cons-type :car-type (type-union cdr-type1 cdr-type2)
-; :cdr-type cdr-type1)))))
-
-; (define-type-method (cons :simple-intersection) (type1 type2)
-; (declare (type cons-type type1 type2))
-; (multiple-value-bind (int-car win-car)
-; (type-intersection (cons-type-car-type type1) (cons-type-car-type type2))
-; (multiple-value-bind (int-cdr win-cdr)
-; (type-intersection (cons-type-cdr-type type1) (cons-type-cdr-type type2))
-; (values (make-cons-type :car-type int-car :cdr-type int-cdr)
-; (and win-car win-cdr)))))
-
-
-
+;;; Give up if a precise type is not possible, to avoid returning
+;;; overly general types.
+(define-type-method (cons :simple-union) (type1 type2)
+ (declare (type cons-type type1 type2))
+ (let ((car-type1 (cons-type-car-type type1))
+ (car-type2 (cons-type-car-type type2))
+ (cdr-type1 (cons-type-cdr-type type1))
+ (cdr-type2 (cons-type-cdr-type type2)))
+ (cond ((type= car-type1 car-type2)
+ (make-cons-type car-type1
+ (type-union cdr-type1 cdr-type2)))
+ ((type= cdr-type1 cdr-type2)
+ (make-cons-type (type-union cdr-type1 cdr-type2)
+ cdr-type1)))))
+
+(define-type-method (cons :simple-intersection) (type1 type2)
+ (declare (type cons-type type1 type2))
+ (multiple-value-bind (int-car win-car)
+ (type-intersection (cons-type-car-type type1)
+ (cons-type-car-type type2))
+ (multiple-value-bind (int-cdr win-cdr)
+ (type-intersection (cons-type-cdr-type type1)
+ (cons-type-cdr-type type2))
+ (values (make-cons-type int-car int-cdr)
+ (and win-car win-cdr)))))
+\f
;;; Return the type that describes all objects that are in X but not
;;; in Y. If we can't determine this type, then return NIL.
;;;