#\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\{
#\| #\} #\~))
-;;; FIXME: Would type inference be able to get more traction on this
-;;; if it were defined as (AND SYMBOL (SATISFIES KEYWORDP))?
(sb!xc:deftype keyword ()
- #!+sb-doc
- "Type for any keyword symbol."
- '(satisfies keywordp))
+ ;; Defining this as (AND SYMBOL ..) lets (SUBTYPEP 'KEYWORD 'SYMBOL)=>T,T.
+ '(and symbol (satisfies keywordp)))
(sb!xc:deftype eql (n) `(member ,n))
;;; Has the type system been properly initialized? (I.e. is it OK to
;;; use it?)
(defvar *type-system-initialized* #+sb-xc-host nil) ; (set in cold load)
+
+;;; Use experimental type functionality?
+;;;
+;;; REMOVEME: Eventually the new type functionality should be stable
+;;; enough that nothing depends on this, and we can remove it again.
+(defvar *xtype?*)
+(!cold-init-forms (setf *xtype?* nil))
\f
;;; Return the type structure corresponding to a type specifier. We
;;; pick off structure types as a special case.
"Return the fdefn object for NAME. If it doesn't already exist and CREATE
is non-NIL, create a new (unbound) one."
(declare (values (or fdefn null)))
- (unless (or (symbolp name)
- (and (consp name)
- (eq (car name) 'setf)
- (let ((cdr (cdr name)))
- (and (consp cdr)
- (symbolp (car cdr))
- (null (cdr cdr))))))
+ (unless (legal-function-name-p name)
(error 'simple-type-error
:datum name
:expected-type '(or symbol list)
(first types))
(;; if potentially too hairy
(some (lambda (type)
- (or (union-type-p type)
- (hairy-type-p type)))
+ ;; Allowing irreducible union types into intersection
+ ;; types leads to issues of canonicalization. Those might
+ ;; be soluble but it would be nicer just to avoid them
+ ;; entirely by punting to HAIRY-TYPE. -- WHN 2001-03-02
+ (union-type-p type))
types)
;; (CMU CL punted to HAIRY-TYPE like this for all AND-based
;; types. We don't want to do that for simple intersection
(append (type-components type1)
(type-components type2)))))
-(!def-type-translator foo-type (&rest type-specifiers)
+(!def-type-translator and (&whole whole &rest type-specifiers)
;; Note: Between the behavior of SIMPLIFY-INTERSECTION-TYPE (which
;; will reduce to a 1-element list any list of types which CMU CL
;; could've represented) and MAKE-INTERSECTION-TYPE-OR-SOMETHING
;; (which knows to treat a 1-element intersection as the element
;; itself) we should recover CMU CL's behavior for anything which it
;; could handle usefully (i.e. could without punting to HAIRY-TYPE).
- (/show0 "entering type translator for AND/FOO-TYPE")
- (make-intersection-type-or-something
- (mapcar #'specifier-type type-specifiers)))
-;;; (REMOVEME once INTERSECTION-TYPE works.)
-
-(!def-type-translator and (&whole spec &rest types)
- (let ((res *wild-type*))
- (dolist (type types res)
- (let ((ctype (specifier-type type)))
- (multiple-value-bind (int win) (type-intersection res ctype)
- (unless win
- (return (make-hairy-type :specifier spec)))
- (setq res int))))))
+ (/show0 "entering type translator for AND")
+ (if *xtype?*
+ (make-intersection-type-or-something
+ (mapcar #'specifier-type type-specifiers))
+ (let ((res *wild-type*))
+ (dolist (type-specifier type-specifiers res)
+ (let ((ctype (specifier-type type-specifier)))
+ (multiple-value-bind (int win) (type-intersection res ctype)
+ (unless win
+ (return (make-hairy-type :specifier whole)))
+ (setq res int)))))))
\f
;;;; union types
(defconstant random-fixnum-max
(1- (ash 1 (- random-chunk-length random-integer-extra-bits))))
-(sb!xc:defstruct (random-state (:constructor %make-random-state))
+(sb!xc:defstruct (random-state (:constructor %make-random-state)
+ (:copier nil)) ; since shallow copy is wrong
(state (init-random-state) :type (simple-array (unsigned-byte 32) (627))))
of the default random state. If STATE is a random state, then return a
copy of it. If STATE is T then return a random state generated from
the universal time."
+ (/show0 "entering !RANDOM-COLD-INIT")
(flet ((copy-random-state (state)
+ (/show0 "entering COPY-RANDOM-STATE")
(let ((state (random-state-state state))
(new-state
(make-array 627 :element-type '(unsigned-byte 32))))
+ (/show0 "made NEW-STATE, about to DOTIMES")
(dotimes (i 627)
(setf (aref new-state i) (aref state i)))
+ (/show0 "falling through to %MAKE-RANDOM-STATE")
(%make-random-state :state new-state))))
- (cond ((not state) (copy-random-state *random-state*))
- ((random-state-p state) (copy-random-state state))
- ((eq state t)
- (%make-random-state :state (init-random-state
- (logand (get-universal-time)
- #xffffffff))))
- ;; FIXME: should be TYPE-ERROR?
- (t (error "Argument is not a RANDOM-STATE, T or NIL: ~S" state)))))
+ (/show0 "at head of ETYPECASE in MAKE-RANDOM-STATE")
+ (etypecase state
+ (null
+ (/show0 "NULL case")
+ (copy-random-state *random-state*))
+ (random-state
+ (/show0 "RANDOM-STATE-P clause")
+ (copy-random-state state))
+ ((member t)
+ (/show0 "T clause")
+ (%make-random-state :state (init-random-state
+ (logand (get-universal-time)
+ #xffffffff)))))))
\f
;;;; random entries
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
+;;; FIXME: Many of the functions in this file could probably be
+;;; byte-compiled, since they're one-pass, cons-heavy code.
+
(in-package "SB!C")
\f
;;;; type predicate translation
(member ,@(remove nil members))))))))
(t
(once-only ((n-obj object))
- `(or ,@(mapcar #'(lambda (x)
- `(typep ,n-obj ',(type-specifier x)))
+ `(or ,@(mapcar (lambda (x)
+ `(typep ,n-obj ',(type-specifier x)))
types)))))))
;;; Do source transformation for TYPEP of a known intersection type.
(defun source-transform-intersection-typep (object type)
- ;; FIXME: This is just a placeholder; we should define a better
- ;; version by analogy with SOURCE-TRANSFORM-UNION-TYPEP.
- (declare (ignore object type))
- nil)
+ (once-only ((n-obj object))
+ `(and ,@(mapcar (lambda (x)
+ `(typep ,n-obj ',(type-specifier x)))
+ (intersection-type-types type)))))
;;; If necessary recurse to check the cons type.
(defun source-transform-cons-typep (object type)
(assert (typep 11 '(and)))
(assert (not (typep 11 '(or))))
+;;; bug 12: type system didn't grok nontrivial intersections
+(assert (subtypep '(and symbol (satisfies keywordp)) 'symbol))
+(assert (not (subtypep '(and symbol (satisfies keywordp)) 'null)))
+#| ; "we gotta target, but you gotta be patient": 0.6.11.11 work in progress
+(assert (subtypep 'keyword 'symbol))
+(assert (not (subtypep 'symbol 'keyword)))
+(assert (subtypep 'ratio 'real))
+(assert (subtypep 'ratio 'number))
+|#
+
;;; success
(quit :unix-status 104)
;;; versions, and a string like "0.6.5.12" is used for versions which
;;; aren't released but correspond only to CVS tags or snapshots.
-"0.6.11.10"
+"0.6.11.11"
projects / sbcl.git / commitdiff