mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2025-12-05 18:30:24 -08:00
Code Issues Projects Releases Packages Wiki Activity

predlib: cosmetic cleanup

Browse source 
Fix comment depth (;; -> ;;;) and simplify a few expressions.
This commit is contained in:
Daniel Kochmański 2025-08-23 14:10:56 +02:00
parent ef5d534af2
commit 6de56d977f
1 changed files with 155 additions and 141 deletions
Download patch file Download diff file Expand all files Collapse all files

296
src/lsp/predlib.lsp
View file

@ -8,7 +8,7 @@
;;;; ;;;;
;;;; See file 'LICENSE' for the copyright details. ;;;; See file 'LICENSE' for the copyright details.
;;;; predicate routines ;;;; Predicate routines.
(in-package "SYSTEM") (in-package "SYSTEM")
@ -129,16 +129,16 @@ MOST-POSITIVE-FIXNUM inclusive. Other integers are bignums."
(deftype bignum () (deftype bignum ()
'(OR (INTEGER * (#.most-negative-fixnum)) (INTEGER (#.most-positive-fixnum) *))) '(OR (INTEGER * (#.most-negative-fixnum)) (INTEGER (#.most-positive-fixnum) *)))
(deftype ext::byte8 () '(INTEGER 0 255)) (deftype ext:byte8 () '(INTEGER 0 255))
(deftype ext::integer8 () '(INTEGER -128 127)) (deftype ext:integer8 () '(INTEGER -128 127))
(deftype ext::byte16 () '(INTEGER 0 #xFFFF)) (deftype ext:byte16 () '(INTEGER 0 #xFFFF))
(deftype ext::integer16 () '(INTEGER #x-8000 #x7FFF)) (deftype ext:integer16 () '(INTEGER #x-8000 #x7FFF))
(deftype ext::byte32 () '(INTEGER 0 #xFFFFFFFF)) (deftype ext:byte32 () '(INTEGER 0 #xFFFFFFFF))
(deftype ext::integer32 () '(INTEGER #x-80000000 #x7FFFFFFF)) (deftype ext:integer32 () '(INTEGER #x-80000000 #x7FFFFFFF))
(deftype ext::byte64 () '(INTEGER 0 #xFFFFFFFFFFFFFFFF)) (deftype ext:byte64 () '(INTEGER 0 #xFFFFFFFFFFFFFFFF))
(deftype ext::integer64 () '(INTEGER #x-8000000000000000 #x7FFFFFFFFFFFFFFF)) (deftype ext:integer64 () '(INTEGER #x-8000000000000000 #x7FFFFFFFFFFFFFFF))
(deftype ext::cl-fixnum () '(SIGNED-BYTE #.CL-FIXNUM-BITS)) (deftype ext:cl-fixnum () '(SIGNED-BYTE #.CL-FIXNUM-BITS))
(deftype ext::cl-index () '(UNSIGNED-BYTE #.CL-FIXNUM-BITS)) (deftype ext:cl-index () '(UNSIGNED-BYTE #.CL-FIXNUM-BITS))
(deftype real (&optional (start '* start-p) (end '*)) (deftype real (&optional (start '* start-p) (end '*))
(if start-p (if start-p
@ -311,9 +311,9 @@ and is not adjustable."
'(or string-stream '(or string-stream
#+clos-streams gray:fundamental-stream)) #+clos-streams gray:fundamental-stream))
;;************************************************************ ;;; ----------------------------------------------------------------------------
;; TYPEP ;;; TYPEP
;;************************************************************ ;;; ----------------------------------------------------------------------------
(defun simple-array-p (x) (defun simple-array-p (x)
(and (arrayp x) (and (arrayp x)
@ -448,9 +448,11 @@ and is not adjustable."
'#.(append '(NIL BASE-CHAR #+unicode CHARACTER BIT EXT:BYTE8 EXT:INTEGER8) '#.(append '(NIL BASE-CHAR #+unicode CHARACTER BIT EXT:BYTE8 EXT:INTEGER8)
#+:uint16-t '(EXT:BYTE16 EXT:INTEGER16) #+:uint16-t '(EXT:BYTE16 EXT:INTEGER16)
#+:uint32-t '(EXT:BYTE32 EXT:INTEGER32) #+:uint32-t '(EXT:BYTE32 EXT:INTEGER32)
(when (< 32 cl-fixnum-bits 64) '(EXT::CL-INDEX FIXNUM)) (when (< 32 cl-fixnum-bits 64)
'(EXT::CL-INDEX FIXNUM))
#+:uint64-t '(EXT:BYTE64 EXT:INTEGER64) #+:uint64-t '(EXT:BYTE64 EXT:INTEGER64)
(when (< 64 cl-fixnum-bits) '(EXT::CL-INDEX FIXNUM)) (when (< 64 cl-fixnum-bits)
'(EXT::CL-INDEX FIXNUM))
'(SINGLE-FLOAT DOUBLE-FLOAT LONG-FLOAT) '(SINGLE-FLOAT DOUBLE-FLOAT LONG-FLOAT)
#+complex-float '(si:complex-single-float #+complex-float '(si:complex-single-float
si:complex-double-float si:complex-double-float
@ -700,13 +702,13 @@ For example (flatten-function-types '(function (symbol) symbol)) ->
flattened-type)) flattened-type))
type))))) type)))))
;;************************************************************ ;;; ----------------------------------------------------------------------------
;; NORMALIZE-TYPE ;;; NORMALIZE-TYPE
;;************************************************************ ;;; ----------------------------------------------------------------------------
;; NORMALIZE-TYPE normalizes the type using the DEFTYPE definitions. ;;; NORMALIZE-TYPE normalizes the type using the DEFTYPE definitions.
;; The result is a pair of values ;;; The result is a pair of values
;; VALUE-1 = normalized type name or object ;;; VALUE-1 = normalized type name or object
;; VALUE-2 = normalized type arguments or nil ;;; VALUE-2 = normalized type arguments or nil
(defun normalize-type (type env &aux tp i fd) (defun normalize-type (type env &aux tp i fd)
;; Loops until the car of type has no DEFTYPE definition. ;; Loops until the car of type has no DEFTYPE definition.
(cond ((symbolp type) (cond ((symbolp type)
@ -736,9 +738,9 @@ For example (flatten-function-types '(function (symbol) symbol)) ->
(expand-deftype (funcall fn (cons base args) env) env) (expand-deftype (funcall fn (cons base args) env) env)
type)))) type))))
;;************************************************************ ;;; ----------------------------------------------------------------------------
;; COERCE ;;; COERCE
;;************************************************************ ;;; ----------------------------------------------------------------------------
(defun coerce (object type &aux aux) (defun coerce (object type &aux aux)
"Args: (x type) "Args: (x type)
@ -878,7 +880,7 @@ if not possible."
;; ;;
(defun find-registered-tag (type &optional (test #'equal)) (defun find-registered-tag (type &optional (test #'equal))
(declare (si::c-local)) (declare (si::c-local))
(let* ((pos (assoc type *elementary-types* :test test))) (let ((pos (assoc type *elementary-types* :test test)))
(and pos (cdr pos)))) (and pos (cdr pos))))
;;; Make and register a new tag for a certain type. ;;; Make and register a new tag for a certain type.
@ -957,14 +959,14 @@ if not possible."
(values (logandc2 supertype-tag (logior disjoint-tag subtype-tag)) (values (logandc2 supertype-tag (logior disjoint-tag subtype-tag))
subtype-tag))) subtype-tag)))
;; A new type is to be registered, which is not simply a composition of ;;; A new type is to be registered, which is not simply a composition of
;; previous types. A new tag has to be created, and all supertypes are to be ;;; previous types. A new tag has to be created, and all supertypes are to be
;; tagged. Here we have to distinguish two possibilities: first, a supertype ;;; tagged. Here we have to distinguish two possibilities: first, a supertype
;; may belong to the same family (intervals, arrays, etc); second, some ;;; may belong to the same family (intervals, arrays, etc); second, some
;; supertypes may be basic types (NUMBER is a supertype for (INTEGER 0 2), ;;; supertypes may be basic types (NUMBER is a supertype for (INTEGER 0 2),
;; for instance). The first possibility is detected with the comparison ;;; for instance). The first possibility is detected with the comparison
;; procedure, TYPE-<=; the second possibility is detected by means of tags. ;;; procedure, TYPE-<=; the second possibility is detected by means of tags.
;; ;;;
(defun register-type (type in-our-family-p type-<=) (defun register-type (type in-our-family-p type-<=)
(declare (si::c-local) (declare (si::c-local)
(optimize (safety 0)) (optimize (safety 0))
@ -972,17 +974,22 @@ if not possible."
(or (find-registered-tag type) (or (find-registered-tag type)
(make-registered-tag type in-our-family-p type-<=))) (make-registered-tag type in-our-family-p type-<=)))
;;---------------------------------------------------------------------- ;;; ----------------------------------------------------------------------------
;; MEMBER types. We register this object in a separate list, *MEMBER-TYPES*, ;;; MEMBER types.
;; and tag all types to which it belongs. We need to treat three cases ;;;
;; separately ;;; We register this object in a separate list, *MEMBER-TYPES*, and tag all
;; - Ordinary types, via simple-member-type, check the objects ;;; types to which it belongs. We need to treat three cases separately:
;; against all pre-registered types, adding their tags. ;;;
;; - Ordinary numbers, are translated into intervals. ;;; 1. Ordinary types, via simple-member-type, check the objects against all
;; - Floating point zeros, have to be treated separately. This ;;; pre-registered types, adding their tags.
;; is done by assigning a special tag to -0.0 and translating ;;;
;; (MEMBER 0.0) = (AND (float-type 0.0 0.0) (NOT (MEMBER -0.0))) ;;; 2. Ordinary numbers, are translated into intervals.
;; ;;;
;;; 3. Floating point zeros, have to be treated separately. This
;;; is done by assigning a special tag to -0.0 and translating
;;;
;;; (MEMBER 0.0) = (AND (float-type 0.0 0.0) (NOT (MEMBER -0.0)))
;;;
(defun register-member-type (object) (defun register-member-type (object)
;(declare (si::c-local)) ;(declare (si::c-local))
(let ((pos (assoc object *member-types*))) (let ((pos (assoc object *member-types*)))
@ -1002,7 +1009,7 @@ if not possible."
(defun simple-member-type (object) (defun simple-member-type (object)
(declare (si::c-local) (declare (si::c-local)
(ext:assume-no-errors)) (ext:assume-no-errors))
(let* ((tag (new-type-tag))) (let ((tag (new-type-tag)))
(maybe-save-types) (maybe-save-types)
(setq *member-types* (acons object tag *member-types*)) (setq *member-types* (acons object tag *member-types*))
(dolist (i *elementary-types*) (dolist (i *elementary-types*)
@ -1011,9 +1018,8 @@ if not possible."
(setf (cdr i) (logior tag (cdr i)))))) (setf (cdr i) (logior tag (cdr i))))))
tag)) tag))
;; We convert number into intervals, so that (AND INTEGER (NOT (EQL ;;; We convert number into intervals, so that (AND INTEGER (NOT (EQL 10))) is
;; 10))) is detected as a subtype of (OR (INTEGER * 9) (INTEGER 11 ;;; detected as a subtype of (OR (INTEGER * 9) (INTEGER 11 *)).
;; *)).
(defun number-member-type (object) (defun number-member-type (object)
(let* ((base-type (if (integerp object) 'INTEGER (type-of object))) (let* ((base-type (if (integerp object) 'INTEGER (type-of object)))
(type (list base-type object object))) (type (list base-type object object)))
@ -1030,25 +1036,25 @@ if not possible."
(push (cons type tag) *elementary-types*) (push (cons type tag) *elementary-types*)
tag) tag)
;;---------------------------------------------------------------------- ;;; ----------------------------------------------------------------------------
;; SATISFIES types. Here we should signal some error which is caught ;;; SATISFIES types. Here we should signal some error which is caught somewhere
;; somewhere up, to denote failure of the decision procedure. ;;; up, to denote failure of the decision procedure.
;; ;;;
(defun register-satisfies-type (type) (defun register-satisfies-type (type)
(declare (si::c-local) (declare (si::c-local)
(ignore type)) (ignore type))
(throw '+canonical-type-failure+ 'satisfies)) (throw '+canonical-type-failure+ 'satisfies))
;;---------------------------------------------------------------------- ;;; ----------------------------------------------------------------------------
;; CLOS classes and structures. ;;; CLOS classes and structures.
;; ;;;
(defun register-class (class env) (defun register-class (class env)
(declare (si::c-local) (declare (si::c-local)
(notinline class-name)) (notinline class-name))
(or (find-registered-tag class) (or (find-registered-tag class)
;; We do not need to register classes which belong to the core type ;; We do not need to register classes which belong to the core type
;; system of LISP (ARRAY, NUMBER, etc). ;; system of LISP (ARRAY, NUMBER, etc).
(let* ((name (class-name class))) (let ((name (class-name class)))
(and name (and name
(eq class (find-class name 'nil)) (eq class (find-class name 'nil))
(or (find-registered-tag name) (or (find-registered-tag name)
@ -1066,9 +1072,9 @@ if not possible."
(setq c2 (find-class c2 nil))) (setq c2 (find-class c2 nil)))
(and c1 c2 (si::subclassp c1 c2)))))) (and c1 c2 (si::subclassp c1 c2))))))
;;---------------------------------------------------------------------- ;;; ----------------------------------------------------------------------------
;; ARRAY types. ;;; ARRAY types.
;; ;;;
(defun register-array-type (type env) (defun register-array-type (type env)
(declare (si::c-local)) (declare (si::c-local))
(multiple-value-bind (array-class elt-type dimensions) (multiple-value-bind (array-class elt-type dimensions)
@ -1090,12 +1096,12 @@ if not possible."
#'array-type-p #'array-type-<=))))) #'array-type-p #'array-type-<=)))))
(register-type type #'array-type-p #'array-type-<=))))) (register-type type #'array-type-p #'array-type-<=)))))
;; ;;;
;; We look for the most specialized type which is capable of containing ;;; We look for the most specialized type which is capable of containing this
;; this object. LIST always contains 'T, so that this procedure never ;;; object. LIST always contains 'T, so that this procedure never fails. It is
;; fails. It is faster than UPGRADED-... because we use the tags of types ;;; faster than UPGRADED-... because we use the tags of types that have been
;; that have been already registered. ;;; already registered.
;; ;;;
(defun fast-upgraded-array-element-type (type env) (defun fast-upgraded-array-element-type (type env)
(declare (si::c-local)) (declare (si::c-local))
(cond ((eql type '*) '*) (cond ((eql type '*) '*)
@ -1106,12 +1112,13 @@ if not possible."
(when (fast-subtypep type other-type env) (when (fast-subtypep type other-type env)
(return other-type)))))) (return other-type))))))
;; ;;;
;; This canonicalizes the array type into the form ;;; This canonicalizes the array type into the form
;; ({COMPLEX-ARRAY | SIMPLE-ARRAY} {elt-type | '*} {'* | (['*]*)}) ;;;
;; ;;; ({COMPLEX-ARRAY | SIMPLE-ARRAY} {elt-type | '*} {'* | (['*]*)})
;; ELT-TYPE is the upgraded element type of the input. ;;;
;; ;;; ELT-TYPE is the upgraded element type of the input.
;;;
(defun parse-array-type (input env) (defun parse-array-type (input env)
(declare (si::c-local)) (declare (si::c-local))
(let* ((type input) (let* ((type input)
@ -1132,10 +1139,10 @@ if not possible."
(error "Wrong dimension size in array type ~S." input))))) (error "Wrong dimension size in array type ~S." input)))))
(values name elt-type dims))) (values name elt-type dims)))
;; ;;;
;; This function checks whether the array type T1 is a subtype of the array ;;; This function checks whether the array type T1 is a subtype of the array
;; type T2. ;;; type T2.
;; ;;;
(defun array-type-<= (t1 t2) (defun array-type-<= (t1 t2)
(unless (and (eq (first t1) (first t2)) (unless (and (eq (first t1) (first t2))
(eq (second t1) (second t2))) (eq (second t1) (second t2)))
@ -1157,16 +1164,18 @@ if not possible."
(and (consp type) (and (consp type)
(member (first type) '(COMPLEX-ARRAY SIMPLE-ARRAY)))) (member (first type) '(COMPLEX-ARRAY SIMPLE-ARRAY))))
;;---------------------------------------------------------------------- ;;; ----------------------------------------------------------------------------
;; INTERVALS: ;;; INTERVALS:
;; ;;;
;; Arbitrary intervals may be defined as the union or intersection of ;;; Arbitrary intervals may be defined as the union or intersection of intervals
;; semi-infinite intervals, of the form (number-type b *), where B is ;;; that are semi-infinite, of the form (NUMBER-TYPE B *), where B is either a
;; either a real number, a list with one real number or *. ;;; real number, a list with one real number or a symbol *.
;; ;;;
;; Any other interval, may be defined using these. For instance ;;; Any other interval, may be defined using these. For instance:
;; (INTEGER 0 2) = (AND (INTEGER 0 *) (NOT (INTEGER (2) *))) ;;;
;; (SHORT-FLOAT (0.2) (2)) = (AND (SHORT-FLOAT (0.2) *) (NOT (SHORT-FLOAT 2 *))) ;;; (INTEGER 0 2) = (AND (INTEGER 0 *) (NOT (INTEGER (2) *)))
;;; (SHORT-FLOAT (0.2) (2)) = (AND (SHORT-FLOAT (0.2) *) (NOT (SHORT-FLOAT 2 *)))
;;;
(defun numeric-range-p (type) (defun numeric-range-p (type)
(and (consp type) (and (consp type)
@ -1232,17 +1241,20 @@ if not possible."
(t (t
(<= b1 b2)))) (<= b1 b2))))
;;---------------------------------------------------------------------- ;;; ----------------------------------------------------------------------------
;; COMPLEX types. We do not need to register anything, because all ;;; COMPLEX types.
;; possibilities have been covered by the definitions above. We only have to ;;;
;; bring the type to canonical form, which is a union of all specialized ;;; We do not need to register anything, because all possibilities have been
;; complex types that can store an element of the corresponding type. ;;; covered by the definitions above. We only have to bring the type to
;; ;;; canonical form, which is a union of all specialized complex types that can
;; Don't be tempted to do "better" than that. CANONICAL-COMPLEX-TYPE ;;; store an element of the corresponding type.
;; yields results for use of SUBTYPEP which has clearly specified to ;;;
;; return true when: T1 is a subtype of T2 or when the upgraded type ;;; Don't be tempted to do "better" than that. CANONICAL-COMPLEX-TYPE yields
;; specifiers refer to the same sets of objects. TYPEP has a different ;;; results for use of SUBTYPEP which has clearly specified to return true when:
;; specification and TYPECASE should use it. -- jd 2019-04-19 ;;; T1 is a subtype of T2 or when the upgraded type specifiers refer to the same
;;; sets of objects. TYPEP has a different specification and TYPECASE should use
;;; it. -- jd 2019-04-19
;;;
(defun canonical-complex-type (complex-type) (defun canonical-complex-type (complex-type)
(declare (si::c-local)) (declare (si::c-local))
;; UPGRADE-COMPLEX-PART-TYPE signals condition when REAL-TYPE is not a ;; UPGRADE-COMPLEX-PART-TYPE signals condition when REAL-TYPE is not a
@ -1290,22 +1302,29 @@ if not possible."
(t (t
(throw '+canonical-type-failure+ 'CONS))))) (throw '+canonical-type-failure+ 'CONS)))))
;;---------------------------------------------------------------------- ;;; ----------------------------------------------------------------------------
;; FIND-BUILT-IN-TAG ;;; FIND-BUILT-IN-TAG
;; ;;;
;; This function computes the tags for all builtin types. We used to ;;; This function computes the tags for all builtin types. We used to do this
;; do this computation and save it. However, for most cases it seems ;;; computation and save it. However, for most cases it seems faster if we just
;; faster if we just repeat it every time we need it, because the list of ;;; repeat it every time we need it, because the list of *elementary-types* is
;; *elementary-types* is kept smaller and *highest-type-tag* may be just ;;; kept smaller and *highest-type-tag* may be just a fixnum.
;; a fixnum. ;;;
;; ;;; Note 1: There is some redundancy between this and the built-in classes
;; Note 1: There is some redundancy between this and the built-in ;;; definitions. REGISTER-CLASS knows this and calls FIND-BUILT-IN-TAG, which
;; classes definitions. REGISTER-CLASS knows this and calls ;;; has priority. This is because some built-in classes are also interpreted as
;; FIND-BUILT-IN-TAG, which has priority. This is because some built-in ;;; intervals, arrays, etc.
;; classes are also interpreted as intervals, arrays, etc. ;;;
;; ;;; Note 2: All built in types listed here have to be symbols.
;; Note 2: All built in types listed here have to be symbols. ;;;
;; ;;; Note 3: Each element of +BUILT-IN-TYPE-LIST+ is:
;;;
;;; (TYPE-NAME &optional ALIAS-TO SUPERTYPE)
;;;
;;; Note 4: The function FIND-BUILT-IN-TAG is always called _after_ the function
;;; FIND-REGISTERED-TAG. This invariant implies that FIND-BUILT-IN-TAG won't add
;;; the same TYPE twice to *ELEMENTARY-TYPES*.
;;;
#+ecl-min #+ecl-min
(defconstant +built-in-type-list+ (defconstant +built-in-type-list+
'((SYMBOL) '((SYMBOL)
@ -1380,8 +1399,7 @@ if not possible."
(EXT:ANSI-STREAM (OR BROADCAST-STREAM CONCATENATED-STREAM ECHO-STREAM (EXT:ANSI-STREAM (OR BROADCAST-STREAM CONCATENATED-STREAM ECHO-STREAM
FILE-STREAM STRING-STREAM SYNONYM-STREAM TWO-WAY-STREAM FILE-STREAM STRING-STREAM SYNONYM-STREAM TWO-WAY-STREAM
EXT:SEQUENCE-STREAM)) EXT:SEQUENCE-STREAM))
(STREAM (OR EXT:ANSI-STREAM (STREAM (OR EXT:ANSI-STREAM #+clos-streams GRAY:FUNDAMENTAL-STREAM))
#+clos-streams GRAY:FUNDAMENTAL-STREAM))
(EXT:VIRTUAL-STREAM (OR STRING-STREAM #+clos-streams GRAY:FUNDAMENTAL-STREAM)) (EXT:VIRTUAL-STREAM (OR STRING-STREAM #+clos-streams GRAY:FUNDAMENTAL-STREAM))
(READTABLE) (READTABLE)
@ -1434,13 +1452,13 @@ if not possible."
(when (zerop (logandc2 minimal-supertype-tag other-tag)) (when (zerop (logandc2 minimal-supertype-tag other-tag))
(setf (cdr type) (logior tag other-tag)))))) (setf (cdr type) (logior tag other-tag))))))
;;---------------------------------------------------------------------- ;;; ----------------------------------------------------------------------------
;; CANONICALIZE (removed) ;;; CANONICALIZE (removed)
;; ;;;
;; This function takes a type tag and produces a more or less human ;;; This function takes a type tag and produces a more or less human
;; readable representation of the type in terms of elementary types, ;;; readable representation of the type in terms of elementary types,
;; intervals, arrays and classes. ;;; intervals, arrays and classes.
;; ;;;
#+ (or) #+ (or)
(defun canonicalize (type env) (defun canonicalize (type env)
(with-type-database () (with-type-database ()
@ -1460,14 +1478,14 @@ if not possible."
(push (car i) out))) (push (car i) out)))
(values tag `(OR ,@out))))) (values tag `(OR ,@out)))))
;;---------------------------------------------------------------------- ;;; ----------------------------------------------------------------------------
;; (CANONICAL-TYPE TYPE ENV) ;;; (CANONICAL-TYPE TYPE)
;; ;;;
;; This function registers all types mentioned in the given expression, ;;; This function registers all types mentioned in the given expression, and
;; and outputs a code corresponding to the represented type. This ;;; outputs a code corresponding to the represented type. This function has side
;; function has side effects: it destructively modifies the content of ;;; effects: it destructively modifies the content of *ELEMENTARY-TYPES* and
;; *ELEMENTARY-TYPES* and *MEMBER-TYPES*. ;;; *MEMBER-TYPES*.
;; ;;;
(defun canonical-type (type env) (defun canonical-type (type env)
(declare (notinline clos::classp)) (declare (notinline clos::classp))
(when env (when env
@ -1491,11 +1509,8 @@ if not possible."
(NOT (lognot (canonical-type (second type) env))) (NOT (lognot (canonical-type (second type) env)))
((EQL MEMBER) (apply #'logior (mapcar #'register-member-type (rest type)))) ((EQL MEMBER) (apply #'logior (mapcar #'register-member-type (rest type))))
(SATISFIES (register-satisfies-type type)) (SATISFIES (register-satisfies-type type))
((INTEGER #+short-float SHORT-FLOAT ((INTEGER RATIO
SINGLE-FLOAT #+short-float SHORT-FLOAT SINGLE-FLOAT DOUBLE-FLOAT LONG-FLOAT)
DOUBLE-FLOAT
RATIO
LONG-FLOAT)
(canonical-interval-type type)) (canonical-interval-type type))
((FLOAT) ((FLOAT)
(canonical-type `(OR #+short-float (canonical-type `(OR #+short-float
@ -1526,11 +1541,10 @@ if not possible."
;;(FUNCTION (register-function-type type)) ;;(FUNCTION (register-function-type type))
;;(VALUES (register-values-type type)) ;;(VALUES (register-values-type type))
(FUNCTION (canonical-type 'FUNCTION env)) (FUNCTION (canonical-type 'FUNCTION env))
(t (let ((expander (get-sysprop (first type) 'DEFTYPE-DEFINITION))) (t (ext:if-let ((expander (get-sysprop (first type) 'DEFTYPE-DEFINITION)))
(if expander (canonical-type (funcall expander type env) env)
(canonical-type (funcall expander type env) env) (unless (assoc (first type) *elementary-types*)
(unless (assoc (first type) *elementary-types*) (throw '+canonical-type-failure+ nil))))))
(throw '+canonical-type-failure+ nil)))))))
((clos::classp type) ((clos::classp type)
(register-class type env)) (register-class type env))
((and (fboundp 'function-type-p) (function-type-p type)) ((and (fboundp 'function-type-p) (function-type-p type))