X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftypedefs.lisp;h=e652fc48ccb955a710caa74e2aec51e1dbad533f;hb=82cd148d729c241e79c8df04b700beec1b7c55de;hp=1139ab6978357d5657c2abc35bd637769d021d93;hpb=0b5610d8a220a4b20cbeac958953ca4d67c00038;p=sbcl.git diff --git a/src/code/typedefs.lisp b/src/code/typedefs.lisp index 1139ab6..e652fc4 100644 --- a/src/code/typedefs.lisp +++ b/src/code/typedefs.lisp @@ -27,7 +27,7 @@ ;;; Define the translation from a type-specifier to a type structure for ;;; some particular type. Syntax is identical to DEFTYPE. (defmacro !def-type-translator (name arglist &body body) - (check-type name symbol) + (declare (type symbol name)) ;; FIXME: Now that the T%CL hack is ancient history and we just use CL ;; instead, we can probably return to using PARSE-DEFMACRO here. ;; @@ -41,44 +41,63 @@ ;; package!) (multiple-value-bind (whole wholeless-arglist) (if (eq '&whole (car arglist)) - (values (cadr arglist) (cddr arglist)) - (values (gensym) arglist)) - (multiple-value-bind (forms decls) (parse-body body nil) + (values (cadr arglist) (cddr arglist)) + (values (sb!xc:gensym) arglist)) + (multiple-value-bind (forms decls) + (parse-body body :doc-string-allowed nil) `(progn - (!cold-init-forms - (setf (info :type :translator ',name) - (lambda (,whole) - (block ,name - (destructuring-bind ,wholeless-arglist - (rest ,whole) ; discarding NAME - ,@decls - ,@forms))))) - ',name)))) + (!cold-init-forms + (let ((fun (lambda (,whole) + (block ,name + (destructuring-bind ,wholeless-arglist + (rest ,whole) ; discarding NAME + ,@decls + ,@forms))))) + #-sb-xc-host + (setf (%simple-fun-arglist (the simple-fun fun)) ',wholeless-arglist) + (setf (info :type :translator ',name) fun))) + ',name)))) ;;; DEFVARs for these come later, after we have enough stuff defined. (declaim (special *wild-type* *universal-type* *empty-type*)) +(defvar *type-random-state*) + ;;; the base class for the internal representation of types (def!struct (ctype (:conc-name type-) - (:constructor nil) - (:make-load-form-fun make-type-load-form) - #-sb-xc-host (:pure t)) - ;; The class of this type. + (:constructor nil) + (:make-load-form-fun make-type-load-form) + #-sb-xc-host (:pure t)) + ;; the class of this type ;; ;; FIXME: It's unnecessarily confusing to have a structure accessor ;; named TYPE-CLASS-INFO which is an accessor for the CTYPE structure ;; even though the TYPE-CLASS structure also exists in the system. ;; Rename this slot: TYPE-CLASS or ASSOCIATED-TYPE-CLASS or something. - (class-info (required-argument) :type type-class) - ;; True if this type has a fixed number of members, and as such could - ;; possibly be completely specified in a MEMBER type. This is used by the - ;; MEMBER type methods. - (enumerable nil :type (member t nil) :read-only t) - ;; an arbitrary hash code used in EQ-style hashing of identity (since EQ - ;; hashing can't be done portably) - (hash-value (random (1+ most-positive-fixnum)) - :type (and fixnum unsigned-byte) - :read-only t)) + (class-info (missing-arg) :type type-class) + ;; True if this type has a fixed number of members, and as such + ;; could possibly be completely specified in a MEMBER type. This is + ;; used by the MEMBER type methods. + (enumerable nil :read-only t) + ;; an arbitrary hash code used in EQ-style hashing of identity + ;; (since EQ hashing can't be done portably) + (hash-value (random #.(ash 1 15) + (if (boundp '*type-random-state*) + *type-random-state* + (setf *type-random-state* + (make-random-state)))) + :type (and fixnum unsigned-byte) + :read-only t) + ;; Can this object contain other types? A global property of our + ;; implementation (which unfortunately seems impossible to enforce + ;; with assertions or other in-the-code checks and constraints) is + ;; that subclasses which don't contain other types correspond to + ;; disjoint subsets (except of course for the NAMED-TYPE T, which + ;; covers everything). So NUMBER-TYPE is disjoint from CONS-TYPE is + ;; is disjoint from MEMBER-TYPE and so forth. But types which can + ;; contain other types, like HAIRY-TYPE and INTERSECTION-TYPE, can + ;; violate this rule. + (might-contain-other-types-p nil :read-only t)) (def!method print-object ((ctype ctype) stream) (print-unreadable-object (ctype stream :type t) (prin1 (type-specifier ctype) stream))) @@ -88,60 +107,26 @@ (declare (type ctype type)) `(specifier-type ',(type-specifier type))) -;;;; utilities - -;;; sort of like ANY and EVERY, except: -;;; * We handle two-VALUES predicate functions like SUBTYPEP. (And -;;; if the result is uncertain, then we return (VALUES NIL NIL).) -;;; * THING is just an atom, and we apply OP (an arity-2 function) -;;; successively to THING and each element of LIST. -(defun any/type (op thing list) - (declare (type function op)) - (let ((certain? t)) - (dolist (i list (values nil certain?)) - (multiple-value-bind (sub-value sub-certain?) - (funcall op thing i) - (unless sub-certain? (setf certain? nil)) - (when sub-value (return (values t t))))))) -(defun every/type (op thing list) - (declare (type function op)) - (dolist (i list (values t t)) - (multiple-value-bind (sub-value sub-certain?) - (funcall op thing i) - (unless sub-certain? (return (values nil nil))) - (unless sub-value (return (values nil t)))))) - -;;; Return a function like FUN, but expecting its (two) arguments in -;;; the opposite order that FUN does. -;;; -;;; (This looks like a sort of general utility, but currently it's -;;; used only in the implementation of the type system, so it's -;;; internal to SB-KERNEL. -- WHN 2001-02-13) -(declaim (inline swapped-args-fun)) -(defun swapped-args-fun (fun) - (declare (type function fun)) - (lambda (x y) - (funcall fun y x))) - -;;; Compute the intersection for types that intersect only when one is a -;;; hierarchical subtype of the other. -(defun vanilla-intersection (type1 type2) - (multiple-value-bind (stp1 win1) (csubtypep type1 type2) - (multiple-value-bind (stp2 win2) (csubtypep type2 type1) - (cond (stp1 (values type1 t)) - (stp2 (values type2 t)) - ((and win1 win2) (values *empty-type* t)) - (t - (values type1 nil)))))) +;;;; miscellany -(defun vanilla-union (type1 type2) +;;; Look for nice relationships for types that have nice relationships +;;; only when one is a hierarchical subtype of the other. +(defun hierarchical-intersection2 (type1 type2) + (multiple-value-bind (subtypep1 win1) (csubtypep type1 type2) + (multiple-value-bind (subtypep2 win2) (csubtypep type2 type1) + (cond (subtypep1 type1) + (subtypep2 type2) + ((and win1 win2) *empty-type*) + (t nil))))) +(defun hierarchical-union2 (type1 type2) (cond ((csubtypep type1 type2) type2) - ((csubtypep type2 type1) type1) - (t nil))) + ((csubtypep type2 type1) type1) + (t nil))) -;;; Hash two things (types) down to 8 bits. In CMU CL this was an EQ hash, but -;;; since it now needs to run in vanilla ANSI Common Lisp at cross-compile -;;; time, it's now based on the CTYPE-HASH-VALUE field instead. +;;; Hash two things (types) down to 8 bits. In CMU CL this was an EQ +;;; hash, but since it now needs to run in vanilla ANSI Common Lisp at +;;; cross-compile time, it's now based on the CTYPE-HASH-VALUE field +;;; instead. ;;; ;;; FIXME: This was a macro in CMU CL, and is now an INLINE function. Is ;;; it important for it to be INLINE, or could be become an ordinary @@ -150,8 +135,17 @@ (declaim (ftype (function (ctype ctype) (unsigned-byte 8)) type-cache-hash)) (defun type-cache-hash (type1 type2) (logand (logxor (ash (type-hash-value type1) -3) - (type-hash-value type2)) - #xFF)) + (type-hash-value type2)) + #xFF)) +#!-sb-fluid (declaim (inline type-list-cache-hash)) +(declaim (ftype (function (list) (unsigned-byte 8)) type-list-cache-hash)) +(defun type-list-cache-hash (types) + (logand #xFF + (loop with res fixnum = 0 + for type in types + for hash = (type-hash-value type) + do (setq res (logxor res hash)) + finally (return res)))) ;;;; cold loading initializations