From aebfebbdd07fd27ac32befb345711db9ab3e091f Mon Sep 17 00:00:00 2001 From: gerd <gerd> Date: Wed, 16 Apr 2003 13:07:50 +0000 Subject: [PATCH] Further speed-up of the type system. Avoid compiler notes. The type system is now as fast as it were before. * src/code/type.lisp: Collect type-class and structure definitions at the beginning of the file to avoid compiler notes and get slot accessor inlining. (with-types-array, *ctype-arrays*): Removed. (simplify-unions): Rewritten simplify-union-types. (simplify-intersections): Rewritten simplify-intersection-types. (%type-union2): Removed, inlined in type-union2. (%type-intersection2): Removed, inlined in type-intersection2. --- code/type.lisp | 834 ++++++++++++++++++++++--------------------------- 1 file changed, 376 insertions(+), 458 deletions(-) diff --git a/code/type.lisp b/code/type.lisp index 94837b62f..da6e4ca84 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.54 2003/04/15 23:07:10 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/type.lisp,v 1.55 2003/04/16 13:07:50 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -35,16 +35,318 @@ (with-cold-load-init-forms) -;;; ### Remaining incorrectnesses: +;;; Structures & Type Classes + +(define-type-class values) +(define-type-class function) +(define-type-class constant values) +(define-type-class named) +(define-type-class hairy) +(define-type-class negation) +(define-type-class number) +(define-type-class array) +(define-type-class member) +(define-type-class union) +(define-type-class intersection) +(define-type-class alien) +(define-type-class cons) + +;;; The Args-Type structure is used both to represent Values types and +;;; and Function types. +;;; +(defstruct (args-type (:include ctype) + (:print-function %print-type)) + ;; + ;; Lists of the type for each required and optional argument. + (required nil :type list) + (optional nil :type list) + ;; + ;; The type for the rest arg. NIL if there is no rest arg. + (rest nil :type (or ctype null)) + ;; + ;; True if keyword arguments are specified. + (keyp nil :type boolean) + ;; + ;; List of key-info structures describing the keyword arguments. + (keywords nil :type list) + ;; + ;; True if other keywords are allowed. + (allowp nil :type boolean)) + +(defstruct (key-info (:pure t)) + ;; + ;; The keyword. + (name (required-argument) :type symbol) + ;; + ;; Type of this argument. + (type (required-argument) :type ctype)) + +(defstruct (values-type + (:include args-type + (:class-info (type-class-or-lose 'values))) + (:print-function %print-type))) + +(declaim (freeze-type values-type)) + +(defstruct (function-type + (:include args-type + (:class-info (type-class-or-lose 'function))) + (:print-function %print-type)) + ;; + ;; True if the arguments are unrestrictive, i.e. *. + (wild-args nil :type boolean) + ;; + ;; Type describing the return values. This is a values type + ;; when multiple values were specified for the return. + (returns (required-argument) :type ctype)) + +;;; The CONSTANT-TYPE structure represents a use of the CONSTANT-ARGUMENT "type +;;; specifier", which is only meaningful in function argument type specifiers +;;; used within the compiler. +;;; +(defstruct (constant-type (:include ctype + (:class-info (type-class-or-lose 'constant))) + (:print-function %print-type)) + ;; + ;; The type which the argument must be a constant instance of for this type + ;; specifier to win. + (type (required-argument) :type ctype)) + +;;; The NAMED-TYPE is used to represent *, T and NIL. These types must be +;;; super or sub types of all types, not just classes and * & NIL aren't +;;; classes anyway, so it wouldn't make much sense to make them built-in +;;; classes. +;;; +(defstruct (named-type (:include ctype + (:class-info (type-class-or-lose 'named))) + (:print-function %print-type)) + (name nil :type symbol)) + +;;; The Hairy-Type represents anything too wierd to be described reasonably or +;;; to be useful, such as AND, NOT and SATISFIES and unknown types. We just +;;; remember the original type spec. +;;; +(defstruct (hairy-type (:include ctype + (:class-info (type-class-or-lose 'hairy)) + (:enumerable t)) + (:print-function %print-type) + (:pure nil)) + ;; + ;; The Common Lisp type-specifier. + (specifier nil :type t)) + +(defstruct (negation-type (:include ctype + (:class-info (type-class-or-lose 'negation)) + ;; FIXME: is this right? It's + ;; what they had before, anyway + (:enumerable t)) + (:copier nil) + (:pure nil)) + (type (required-argument) :type ctype)) + +;;; An UNKNOWN-TYPE is a type not known to the type system (not yet defined). +;;; We make this distinction since we don't want to complain about types that +;;; are hairy but defined. +;;; +(defstruct (unknown-type (:include hairy-type))) + +;;; The Numeric-Type is used to represent all numeric types, including things +;;; such as FIXNUM. +(defstruct (numeric-type (:include ctype + (:class-info (type-class-or-lose 'number))) + (:constructor %make-numeric-type) + (:print-function %print-type)) + ;; + ;; The kind of numeric type we have. NIL if not specified (just NUMBER or + ;; COMPLEX). + (class nil :type (member integer rational float nil)) + ;; + ;; Format for a float type. NIL if not specified or not a float. Formats + ;; which don't exist in a given implementation don't appear here. + (format nil :type (or float-format null)) + ;; + ;; Is this a complex numeric type? Null if unknown (only in NUMBER.) + (complexp :real :type (member :real :complex nil)) + ;; + ;; The upper and lower bounds on the value. If null, there is no bound. If + ;; a list of a number, the bound is exclusive. Integer types never have + ;; exclusive bounds. + (low nil :type (or number cons null)) + (high nil :type (or number cons null))) + +(defun type-bound-number (x) + (if (consp x) + (destructuring-bind (result) x result) + x)) + +(defun make-numeric-type (&key class format (complexp :real) low high + enumerable) + ;; if interval is empty + (if (and low + high + (if (or (consp low) (consp high)) ; if either bound is exclusive + (>= (type-bound-number low) (type-bound-number high)) + (> low high))) + *empty-type* + (multiple-value-bind (canonical-low canonical-high) + (case class + (integer + ;; INTEGER types always have their LOW and HIGH bounds + ;; represented as inclusive, not exclusive values. + (values (if (consp low) + (1+ (type-bound-number low)) + low) + (if (consp high) + (1- (type-bound-number high)) + high))) + #+negative-zero-is-not-zero + (float + ;; Canonicalize a low bound of (-0.0) to 0.0, and a high + ;; bound of (+0.0) to -0.0. + (values (if (and (consp low) + (floatp (car low)) + (zerop (car low)) + (minusp (float-sign (car low)))) + (float 0.0 (car low)) + low) + (if (and (consp high) + (floatp (car high)) + (zerop (car high)) + (plusp (float-sign (car high)))) + (float -0.0 (car high)) + high))) + (t + ;; no canonicalization necessary + (values low high))) + (when (and (eq class 'rational) + (integerp canonical-low) + (integerp canonical-high) + (= canonical-low canonical-high)) + (setf class 'integer)) + (%make-numeric-type :class class + :format format + :complexp complexp + :low canonical-low + :high canonical-high + :enumerable enumerable)))) + +(defun modified-numeric-type (base + &key + (class (numeric-type-class base)) + (format (numeric-type-format base)) + (complexp (numeric-type-complexp base)) + (low (numeric-type-low base)) + (high (numeric-type-high base)) + (enumerable (numeric-type-enumerable base))) + (make-numeric-type :class class + :format format + :complexp complexp + :low low + :high high + :enumerable enumerable)) + +;;; The Array-Type is used to represent all array types, including things such +;;; as SIMPLE-STRING. ;;; -;;; Type-Union (and the OR type) doesn't properly canonicalize an exhaustive -;;; partition or coalesce contiguous ranges of numeric types. +(defstruct (array-type (:include ctype + (:class-info (type-class-or-lose 'array))) + (:print-function %print-type)) + ;; + ;; The dimensions of the array. * if unspecified. If a dimension is + ;; unspecified, it is *. + (dimensions '* :type (or list (member *))) + ;; + ;; Is this not a simple array type? + (complexp :maybe :type (member t nil :maybe)) + ;; + ;; The element type as originally specified. + (element-type (required-argument) :type ctype) + ;; + ;; The element type as it is specialized in this implementation. + (specialized-element-type *wild-type* :type ctype)) + +;;; The Member-Type represents uses of the MEMBER type specifier. We bother +;;; with this at this level because MEMBER types are fairly important and union +;;; and intersection are well defined. + +(defstruct (member-type (:include ctype + (:class-info (type-class-or-lose 'member)) + (:enumerable t)) + (:print-function %print-type) + (:pure nil)) + ;; + ;; The things in the set, with no duplications. + (members nil :type list)) + +;;; The Union-Type represents uses of the OR type specifier which can't be +;;; canonicalized to something simpler. Canonical form: ;;; -;;; There are all sorts of nasty problems with open bounds on float types (and -;;; probably float types in general.) +;;; 1] There is never more than one Member-Type component. +;;; 2] There are never any Union-Type components. ;;; -;;; ratio and bignum are not recognized as numeric types. +(defstruct (union-type (:include ctype + (:class-info (type-class-or-lose 'union))) + (:constructor %make-union-type (enumerable types)) + (:print-function %print-type)) + ;; + ;; The types in the union. + (types nil :type list :read-only t)) + +(defun make-union-type (types) + (declare (list types)) + (%make-union-type (every #'type-enumerable types) types)) +(defstruct (intersection-type + (:include ctype + (:class-info (type-class-or-lose 'intersection))) + (:constructor make-intersection-type (enumerable types)) + (:print-function %print-type)) + (types nil :type list :read-only t)) + +(defstruct (alien-type-type + (:include ctype + (:class-info (type-class-or-lose 'alien))) + (:print-function %print-type) + (:constructor %make-alien-type-type (alien-type))) + (alien-type nil :type alien-type)) + +;;; The Cons-Type is used to represent cons types. +;;; +(defun type-*-to-t (type) + (if (type= type *wild-type*) + *universal-type* + type)) + +(defstruct (cons-type (:include ctype + (:class-info (type-class-or-lose 'cons))) + (:constructor + ;; ANSI says that for CAR and CDR subtype + ;; specifiers '* is equivalent to T. In order + ;; to avoid special cases in SUBTYPEP and + ;; possibly elsewhere, we slam all CONS-TYPE + ;; objects into canonical form w.r.t. this + ;; equivalence at creation time. + %make-cons-type (car-raw-type + cdr-raw-type + &aux + (car-type (type-*-to-t car-raw-type)) + (cdr-type (type-*-to-t cdr-raw-type)))) + (:print-function %print-type) + (:copier nil)) + ;; the CAR and CDR element types (to support ANSI (CONS FOO BAR) types) + ;; + ;; FIXME: Most or all other type structure slots could also be :READ-ONLY. + (car-type (required-argument) :type ctype :read-only t) + (cdr-type (required-argument) :type ctype :read-only t)) + +(defun make-cons-type (car-type cdr-type) + (if (or (eq car-type *empty-type*) + (eq cdr-type *empty-type*)) + *empty-type* + (%make-cons-type car-type cdr-type))) + + + ;;; (defvar *use-implementation-types* t "*Use-Implementation-Types* is a semi-public flag which determines how @@ -226,39 +528,6 @@ ;;; annotated function or values types. -;;; The Args-Type structure is used both to represent Values types and -;;; and Function types. -;;; -(defstruct (args-type (:include ctype) - (:print-function %print-type)) - ;; - ;; Lists of the type for each required and optional argument. - (required nil :type list) - (optional nil :type list) - ;; - ;; The type for the rest arg. NIL if there is no rest arg. - (rest nil :type (or ctype null)) - ;; - ;; True if keyword arguments are specified. - (keyp nil :type boolean) - ;; - ;; List of key-info structures describing the keyword arguments. - (keywords nil :type list) - ;; - ;; True if other keywords are allowed. - (allowp nil :type boolean)) - -(defstruct (key-info (:pure t)) - ;; - ;; The keyword. - (name (required-argument) :type symbol) - ;; - ;; Type of this argument. - (type (required-argument) :type ctype)) - - -(define-type-class values) - (define-type-method (values :simple-subtypep :complex-subtypep-arg1) (type1 type2) (declare (ignore type2)) @@ -269,17 +538,9 @@ (declare (ignore type1)) (error "Subtypep is illegal on this type:~% ~S" (type-specifier type2))) -(defstruct (values-type - (:include args-type - (:class-info (type-class-or-lose 'values))) - (:print-function %print-type))) - -(declaim (freeze-type values-type)) - (define-type-method (values :unparse) (type) (cons 'values (unparse-args-types type))) - ;;; TYPE=-LIST -- Internal ;;; ;;; Return true if List1 and List2 have the same elements in the same @@ -320,20 +581,6 @@ (values-type-optional type2)) (values (and req-val opt-val) (and req-win opt-win)))))))) -(define-type-class function) - -(defstruct (function-type - (:include args-type - (:class-info (type-class-or-lose 'function))) - (:print-function %print-type)) - ;; - ;; True if the arguments are unrestrictive, i.e. *. - (wild-args nil :type boolean) - ;; - ;; Type describing the return values. This is a values type - ;; when multiple values were specified for the return. - (returns (required-argument) :type ctype)) - ;;; A flag that we can bind to cause complex function types to be unparsed as ;;; FUNCTION. Useful when we want a type that we can pass to TYPEP. ;;; @@ -350,7 +597,6 @@ (type-specifier (function-type-returns type))))) - ;;; Since all function types are equivalent to FUNCTION, they are all subtypes ;;; of each other. ;;; @@ -424,20 +670,6 @@ (values (equalp type1 type2) t)) -(define-type-class constant values) - -;;; The CONSTANT-TYPE structure represents a use of the CONSTANT-ARGUMENT "type -;;; specifier", which is only meaningful in function argument type specifiers -;;; used within the compiler. -;;; -(defstruct (constant-type (:include ctype - (:class-info (type-class-or-lose 'constant))) - (:print-function %print-type)) - ;; - ;; The type which the argument must be a constant instance of for this type - ;; specifier to win. - (type (required-argument) :type ctype)) - (define-type-method (constant :unparse) (type) `(constant-argument ,(type-specifier (constant-type-type type)))) @@ -875,7 +1107,6 @@ ;;; thus is not a UNION type unless there is no other way to represent the ;;; result. ;;; - (defun type-union (&rest input-types) (%type-union input-types)) @@ -883,130 +1114,39 @@ :hash-function (lambda (x) (logand (sxhash x) #xff))) ((input-types equal)) - (let ((simplified (simplify-union-types input-types))) + (let ((simplified (simplify-unions input-types))) (cond ((null simplified) *empty-type*) ((null (cdr simplified)) (car simplified)) (t (make-union-type simplified))))) -;;; -;;; FIXME: Recode the simplification of union and intersection types, -;;; so that it doesn't have the somewhat twisted cycle TYPE-UNION -> -;;; SIMPLIFY-UNION-TYPES -> TYPE-UNION2 -> TYPE-UNION. -;;; -(defvar *ctype-arrays*) -(cold-load-init (setq *ctype-arrays* nil)) - -(defmacro with-types-array ((var) &body body) - `(let ((,var (or (pop *ctype-arrays*) - (make-array 10 :fill-pointer 0 :adjustable t - :element-type 'ctype)))) - (setf (fill-pointer ,var) 0) - (locally ,@body) - (prog1 (loop for tp across ,var collect tp) - (push ,var *ctype-arrays*)))) - -(defun simplify-union-types (types) - (with-types-array (result) - (labels ((accumulate1 (type) - (dotimes (i (length result) (vector-push-extend type result)) - (let ((simple (type-union2 type (aref result i)))) - (when simple - (setf (aref result i) (vector-pop result)) - (return (accumulate simple)))))) - (accumulate (type) - (if (union-type-p type) - (map nil #'accumulate1 (union-type-types type)) - (accumulate1 type)))) - (dolist (type types) - (accumulate type))))) - -(defun %type-union2 (type1 type2) - ;; As in %TYPE-INTERSECTION2, it seems to be a good idea to give - ;; both argument orders a chance at COMPLEX-INTERSECTION2. Unlike - ;; %TYPE-INTERSECTION2, though, I don't have a specific case which - ;; demonstrates this is actually necessary. Also unlike - ;; %TYPE-INTERSECTION2, there seems to be no need to distinguish - ;; between not finding a method and having a method return NIL. - (flet ((1way (x y) - (invoke-type-method :simple-union :complex-union - x y - :default nil))) - (or (1way type1 type2) - (1way type2 type1)))) +(defun simplify-unions (types) + (when types + (multiple-value-bind (first rest) + (if (union-type-p (car types)) + (values (car (union-type-types (car types))) + (append (cdr (union-type-types (car types))) + (cdr types))) + (values (car types) (cdr types))) + (let ((rest (simplify-unions rest)) u) + (dolist (r rest (cons first rest)) + (when (setq u (type-union2 first r)) + (return (simplify-unions (nsubstitute u r rest))))))))) (defun-cached (type-union2 :hash-function type-cache-hash :hash-bits 8 :init-form cold-load-init) ((type1 eq) (type2 eq)) (declare (type ctype type1 type2)) - (cond ((eq type1 type2) - type1) + (cond ((eq type1 type2) type1) ((csubtypep type1 type2) type2) ((csubtypep type2 type1) type1) - ((or (union-type-p type1) - (union-type-p type2)) - ;; Unions of UNION-TYPE should have the UNION-TYPE-TYPES - ;; values broken out and united separately. The full TYPE-UNION - ;; function knows how to do this, so let it handle it. - (type-union type1 type2)) - (t - ;; the ordinary case: we dispatch to type methods - (%type-union2 type1 type2)))) - -(defun %type-intersection2 (type1 type2) - ;; We want to give both argument orders a chance at - ;; COMPLEX-INTERSECTION2. Without that, the old CMU CL type - ;; methods could give noncommutative results, e.g. - ;; (TYPE-INTERSECTION2 *EMPTY-TYPE* SOME-HAIRY-TYPE) - ;; => NIL, NIL - ;; (TYPE-INTERSECTION2 SOME-HAIRY-TYPE *EMPTY-TYPE*) - ;; => #<NAMED-TYPE NIL>, T - ;; We also need to distinguish between the case where we found a - ;; type method, and it returned NIL, and the case where we fell - ;; through without finding any type method. An example of the first - ;; case is the intersection of a HAIRY-TYPE with some ordinary type. - ;; An example of the second case is the intersection of two - ;; completely-unrelated types, e.g. CONS and NUMBER, or SYMBOL and - ;; ARRAY. - ;; - ;; (Why yes, CLOS probably *would* be nicer..) - (flet ((1way (x y) - (invoke-type-method :simple-intersection :complex-intersection - x y - :default :no-type-method-found))) - (let ((xy (1way type1 type2))) - (or (and (not (eql xy :no-type-method-found)) xy) - (let ((yx (1way type2 type1))) - (or (and (not (eql yx :no-type-method-found)) yx) - (cond ((and (eql xy :no-type-method-found) - (eql yx :no-type-method-found)) - *empty-type*) - (t - (assert (and (not xy) (not yx))) ; else handled above - nil)))))))) - -(defun-cached (type-intersection2 :hash-function type-cache-hash - :hash-bits 8 - :values 1 - :default nil - :init-form cold-load-init) - ((type1 eq) (type2 eq)) - (declare (type ctype type1 type2)) - (cond ((eq type1 type2) - ;; FIXME: For some reason, this doesn't catch e.g. type1 = - ;; type2 = (SPECIFIER-TYPE - ;; 'SOME-UNKNOWN-TYPE). Investigate. - CSR, 2002-04-10 - type1) - ((or (intersection-type-p type1) - (intersection-type-p type2)) - ;; Intersections of INTERSECTION-TYPE should have the - ;; INTERSECTION-TYPE-TYPES values broken out and intersected - ;; separately. The full TYPE-INTERSECTION function knows how - ;; to do that, so let it handle it. - (type-intersection type1 type2)) (t - ;; the ordinary case: we dispatch to type methods - (%type-intersection2 type1 type2)))) + (flet ((1way (x y) + (invoke-type-method :simple-union :complex-union + x y + :default nil))) + (or (1way type1 type2) + (1way type2 type1)))))) ;;; Return as restrictive and simple a type as we can discover that is ;;; no more restrictive than the intersection of TYPE1 and TYPE2. At @@ -1031,7 +1171,7 @@ :hash-function (lambda (x) (logand (sxhash x) #xff))) ((input-types equal)) - (let ((simplified (simplify-intersection-types input-types))) + (let ((simplified (simplify-intersections input-types))) ;(declare (type (vector ctype) simplified)) ;; We want to have a canonical representation of types (or failing ;; that, punt to HAIRY-TYPE). Canonical representation would have @@ -1056,20 +1196,52 @@ (some #'type-enumerable simplified) simplified)))))) -(defun simplify-intersection-types (types) - (with-types-array (result) - (labels ((accumulate1 (type) - (dotimes (i (length result) (vector-push-extend type result)) - (let ((simple (type-intersection2 type (aref result i)))) - (when simple - (setf (aref result i) (vector-pop result)) - (return (accumulate simple)))))) - (accumulate (type) - (if (intersection-type-p type) - (map nil #'accumulate1 (intersection-type-types type)) - (accumulate1 type)))) - (dolist (type types) - (accumulate type))))) +(defun simplify-intersections (types) + (when types + (multiple-value-bind (first rest) + (if (intersection-type-p (car types)) + (values (car (intersection-type-types (car types))) + (append (cdr (intersection-type-types (car types))) + (cdr types))) + (values (car types) (cdr types))) + (let ((rest (simplify-intersections rest)) u) + (dolist (r rest (cons first rest)) + (when (setq u (type-intersection2 first r)) + (return (simplify-intersections (nsubstitute u r rest))))))))) + +(defun-cached (type-intersection2 :hash-function type-cache-hash + :hash-bits 8 + :init-form cold-load-init) + ((type1 eq) (type2 eq)) + (declare (type ctype type1 type2)) + (cond ((eq type1 type2) + ;; FIXME: For some reason, this doesn't catch e.g. type1 = + ;; type2 = (SPECIFIER-TYPE + ;; 'SOME-UNKNOWN-TYPE). Investigate. - CSR, 2002-04-10 + type1) + ((or (intersection-type-p type1) + (intersection-type-p type2)) + ;; Intersections of INTERSECTION-TYPE should have the + ;; INTERSECTION-TYPE-TYPES values broken out and intersected + ;; separately. The full TYPE-INTERSECTION function knows how + ;; to do that, so let it handle it. + (type-intersection type1 type2)) + (t + (flet ((1way (x y) + (invoke-type-method :simple-intersection + :complex-intersection + x y + :default :no-type-method-found))) + (let ((xy (1way type1 type2))) + (or (and (not (eql xy :no-type-method-found)) xy) + (let ((yx (1way type2 type1))) + (or (and (not (eql yx :no-type-method-found)) yx) + (cond ((and (eql xy :no-type-method-found) + (eql yx :no-type-method-found)) + *empty-type*) + (t + (assert (and (not xy) (not yx))) + nil)))))))))) (defun maybe-distribute-one-union (union-type types) (let* ((intersection (apply #'type-intersection types)) @@ -1204,18 +1376,6 @@ ;;;; Builtin types. -;;; The NAMED-TYPE is used to represent *, T and NIL. These types must be -;;; super or sub types of all types, not just classes and * & NIL aren't -;;; classes anyway, so it wouldn't make much sense to make them built-in -;;; classes. -;;; -(defstruct (named-type (:include ctype - (:class-info (type-class-or-lose 'named))) - (:print-function %print-type)) - (name nil :type symbol)) - -(define-type-class named) - (defvar *wild-type*) (defvar *empty-type*) (defvar *universal-type*) @@ -1324,21 +1484,6 @@ ;;;; Hairy and unknown types: -;;; The Hairy-Type represents anything too wierd to be described reasonably or -;;; to be useful, such as AND, NOT and SATISFIES and unknown types. We just -;;; remember the original type spec. -;;; -(defstruct (hairy-type (:include ctype - (:class-info (type-class-or-lose 'hairy)) - (:enumerable t)) - (:print-function %print-type) - (:pure nil)) - ;; - ;; The Common Lisp type-specifier. - (specifier nil :type t)) - -(define-type-class hairy) - (define-type-method (hairy :unparse) (x) (hairy-type-specifier x)) @@ -1397,17 +1542,6 @@ ;;;; Negation Types -(defstruct (negation-type (:include ctype - (:class-info (type-class-or-lose 'negation)) - ;; FIXME: is this right? It's - ;; what they had before, anyway - (:enumerable t)) - (:copier nil) - (:pure nil)) - (type (required-argument) :type ctype)) - -(define-type-class negation) - (define-type-method (negation :unparse) (x) `(not ,(type-specifier (negation-type-type x)))) @@ -1642,12 +1776,6 @@ (t (error "Weird CONS type ~S" not-type))))) (t (make-negation-type :type not-type))))) -;;; An UNKNOWN-TYPE is a type not known to the type system (not yet defined). -;;; We make this distinction since we don't want to complain about types that -;;; are hairy but defined. -;;; -(defstruct (unknown-type (:include hairy-type))) - ;;;; Numeric types. @@ -1662,103 +1790,6 @@ (deftype float-format () `(member ,@float-formats)) -;;; The Numeric-Type is used to represent all numeric types, including things -;;; such as FIXNUM. -(defstruct (numeric-type (:include ctype - (:class-info (type-class-or-lose 'number))) - (:constructor %make-numeric-type) - (:print-function %print-type)) - ;; - ;; The kind of numeric type we have. NIL if not specified (just NUMBER or - ;; COMPLEX). - (class nil :type (member integer rational float nil)) - ;; - ;; Format for a float type. NIL if not specified or not a float. Formats - ;; which don't exist in a given implementation don't appear here. - (format nil :type (or float-format null)) - ;; - ;; Is this a complex numeric type? Null if unknown (only in NUMBER.) - (complexp :real :type (member :real :complex nil)) - ;; - ;; The upper and lower bounds on the value. If null, there is no bound. If - ;; a list of a number, the bound is exclusive. Integer types never have - ;; exclusive bounds. - (low nil :type (or number cons null)) - (high nil :type (or number cons null))) - -(defun type-bound-number (x) - (if (consp x) - (destructuring-bind (result) x result) - x)) - -(defun make-numeric-type (&key class format (complexp :real) low high - enumerable) - ;; if interval is empty - (if (and low - high - (if (or (consp low) (consp high)) ; if either bound is exclusive - (>= (type-bound-number low) (type-bound-number high)) - (> low high))) - *empty-type* - (multiple-value-bind (canonical-low canonical-high) - (case class - (integer - ;; INTEGER types always have their LOW and HIGH bounds - ;; represented as inclusive, not exclusive values. - (values (if (consp low) - (1+ (type-bound-number low)) - low) - (if (consp high) - (1- (type-bound-number high)) - high))) - #+negative-zero-is-not-zero - (float - ;; Canonicalize a low bound of (-0.0) to 0.0, and a high - ;; bound of (+0.0) to -0.0. - (values (if (and (consp low) - (floatp (car low)) - (zerop (car low)) - (minusp (float-sign (car low)))) - (float 0.0 (car low)) - low) - (if (and (consp high) - (floatp (car high)) - (zerop (car high)) - (plusp (float-sign (car high)))) - (float -0.0 (car high)) - high))) - (t - ;; no canonicalization necessary - (values low high))) - (when (and (eq class 'rational) - (integerp canonical-low) - (integerp canonical-high) - (= canonical-low canonical-high)) - (setf class 'integer)) - (%make-numeric-type :class class - :format format - :complexp complexp - :low canonical-low - :high canonical-high - :enumerable enumerable)))) - -(defun modified-numeric-type (base - &key - (class (numeric-type-class base)) - (format (numeric-type-format base)) - (complexp (numeric-type-complexp base)) - (low (numeric-type-low base)) - (high (numeric-type-high base)) - (enumerable (numeric-type-enumerable base))) - (make-numeric-type :class class - :format format - :complexp complexp - :low low - :high high - :enumerable enumerable)) - -(define-type-class number) - (define-type-method (number :simple-=) (type1 type2) (values (and (eq (numeric-type-class type1) (numeric-type-class type2)) @@ -2482,28 +2513,6 @@ ;;;; Array types: -;;; The Array-Type is used to represent all array types, including things such -;;; as SIMPLE-STRING. -;;; -(defstruct (array-type (:include ctype - (:class-info (type-class-or-lose 'array))) - (:print-function %print-type)) - ;; - ;; The dimensions of the array. * if unspecified. If a dimension is - ;; unspecified, it is *. - (dimensions '* :type (or list (member *))) - ;; - ;; Is this not a simple array type? - (complexp :maybe :type (member t nil :maybe)) - ;; - ;; The element type as originally specified. - (element-type (required-argument) :type ctype) - ;; - ;; The element type as it is specialized in this implementation. - (specialized-element-type *wild-type* :type ctype)) - -(define-type-class array) - ;;; Specialized-Element-Type-Maybe -- Internal ;;; ;;; What this does depends on the setting of the @@ -2753,22 +2762,6 @@ ;;;; Member types. -;;; The Member-Type represents uses of the MEMBER type specifier. We bother -;;; with this at this level because MEMBER types are fairly important and union -;;; and intersection are well defined. - -(defstruct (member-type (:include ctype - (:class-info (type-class-or-lose 'member)) - (:enumerable t)) - (:print-function %print-type) - (:pure nil)) - ;; - ;; The things in the set, with no duplications. - (members nil :type list)) - - -(define-type-class member) - (define-type-method (member :unparse) (type) (let ((members (member-type-members type))) (cond @@ -2862,26 +2855,6 @@ ;;;; Union types: -;;; The Union-Type represents uses of the OR type specifier which can't be -;;; canonicalized to something simpler. Canonical form: -;;; -;;; 1] There is never more than one Member-Type component. -;;; 2] There are never any Union-Type components. -;;; -(defstruct (union-type (:include ctype - (:class-info (type-class-or-lose 'union))) - (:constructor %make-union-type (enumerable types)) - (:print-function %print-type)) - ;; - ;; The types in the union. - (types nil :type list :read-only t)) - -(defun make-union-type (types) - (declare (list types)) - (%make-union-type (every #'type-enumerable types) types)) - -(define-type-class union) - (define-type-method (union :unparse) (type) (declare (type ctype type)) (cond @@ -2971,15 +2944,6 @@ ;;;; Intersection Types -(defstruct (intersection-type - (:include ctype - (:class-info (type-class-or-lose 'intersection))) - (:constructor make-intersection-type (enumerable types)) - (:print-function %print-type)) - (types nil :type list :read-only t)) - -(define-type-class intersection) - (define-type-method (intersection :unparse) (type) (declare (type ctype type)) (or (find type '(ratio keyword) :key #'specifier-type :test #'type=) @@ -3074,15 +3038,6 @@ ;;;; Alien-type types -(defstruct (alien-type-type - (:include ctype - (:class-info (type-class-or-lose 'alien))) - (:print-function %print-type) - (:constructor %make-alien-type-type (alien-type))) - (alien-type nil :type alien-type)) - -(define-type-class alien) - (define-type-method (alien :unparse) (type) `(alien ,(unparse-alien-type (alien-type-type-alien-type type)))) @@ -3121,43 +3076,6 @@ ;;;; Cons types: -;;; The Cons-Type is used to represent cons types. -;;; -(defun type-*-to-t (type) - (if (type= type *wild-type*) - *universal-type* - type)) - -(defstruct (cons-type (:include ctype - (:class-info (type-class-or-lose 'cons))) - (:constructor - ;; ANSI says that for CAR and CDR subtype - ;; specifiers '* is equivalent to T. In order - ;; to avoid special cases in SUBTYPEP and - ;; possibly elsewhere, we slam all CONS-TYPE - ;; objects into canonical form w.r.t. this - ;; equivalence at creation time. - %make-cons-type (car-raw-type - cdr-raw-type - &aux - (car-type (type-*-to-t car-raw-type)) - (cdr-type (type-*-to-t cdr-raw-type)))) - (:print-function %print-type) - (:copier nil)) - ;; the CAR and CDR element types (to support ANSI (CONS FOO BAR) types) - ;; - ;; FIXME: Most or all other type structure slots could also be :READ-ONLY. - (car-type (required-argument) :type ctype :read-only t) - (cdr-type (required-argument) :type ctype :read-only t)) - -(defun make-cons-type (car-type cdr-type) - (if (or (eq car-type *empty-type*) - (eq cdr-type *empty-type*)) - *empty-type* - (%make-cons-type car-type cdr-type))) - -(define-type-class cons) - (def-type-translator cons (&optional (car-type-spec '*) (cdr-type-spec '*)) (let ((car-type (specifier-type car-type-spec)) (cdr-type (specifier-type cdr-type-spec))) -- GitLab