From 467a8e5dba8bfa2598ca8e22c1204dc173ce556f Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Sat, 3 Mar 2001 18:25:29 +0000 Subject: [PATCH] 0.6.11.11: reduced code duplication code in FDEFINITION-OBJECT defined *XTYPE?* to help support ongoing type experiments started conditionally fully enabling INTERSECTION-TYPE allowed HAIRY-TYPE elements in INTERSECTION-TYPEs after all, since otherwise INTERSECTION-TYPE can't fix bug 12 redefined KEYWORD type as (AND SYMBOL (SATISFIES KEYWORDP)) added tests for bug 12 fixedness --- src/code/deftypes-for-target.lisp | 7 ++----- src/code/early-type.lisp | 7 +++++++ src/code/fdefinition.lisp | 8 +------- src/code/late-type.lisp | 33 +++++++++++++++++---------------- src/code/random.lisp | 3 ++- src/code/target-random.lisp | 25 +++++++++++++++++-------- src/compiler/typetran.lisp | 15 +++++++++------ tests/type.impure.lisp | 10 ++++++++++ version.lisp-expr | 2 +- 9 files changed, 66 insertions(+), 44 deletions(-) diff --git a/src/code/deftypes-for-target.lisp b/src/code/deftypes-for-target.lisp index 20f9a7a..63574ff 100644 --- a/src/code/deftypes-for-target.lisp +++ b/src/code/deftypes-for-target.lisp @@ -67,12 +67,9 @@ #\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)) diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp index 6d18adc..ff5252d 100644 --- a/src/code/early-type.lisp +++ b/src/code/early-type.lisp @@ -14,6 +14,13 @@ ;;; 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)) ;;; Return the type structure corresponding to a type specifier. We ;;; pick off structure types as a special case. diff --git a/src/code/fdefinition.lisp b/src/code/fdefinition.lisp index 30bab6f..5be9930 100644 --- a/src/code/fdefinition.lisp +++ b/src/code/fdefinition.lisp @@ -55,13 +55,7 @@ "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) diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index dbeff6a..edd81f7 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -1631,8 +1631,11 @@ (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 @@ -1747,26 +1750,24 @@ (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))))))) ;;;; union types diff --git a/src/code/random.lisp b/src/code/random.lisp index 863b5cc..d0d672d 100644 --- a/src/code/random.lisp +++ b/src/code/random.lisp @@ -24,5 +24,6 @@ (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)))) diff --git a/src/code/target-random.lisp b/src/code/target-random.lisp index 46b33d7..9937cd7 100644 --- a/src/code/target-random.lisp +++ b/src/code/target-random.lisp @@ -61,21 +61,30 @@ 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))))))) ;;;; random entries diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp index f5ade91..276aa8c 100644 --- a/src/compiler/typetran.lisp +++ b/src/compiler/typetran.lisp @@ -12,6 +12,9 @@ ;;;; 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") ;;;; type predicate translation @@ -295,16 +298,16 @@ (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) diff --git a/tests/type.impure.lisp b/tests/type.impure.lisp index 6ec22b9..1dbf49c 100644 --- a/tests/type.impure.lisp +++ b/tests/type.impure.lisp @@ -85,5 +85,15 @@ (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) diff --git a/version.lisp-expr b/version.lisp-expr index 917aaac..086487c 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -15,4 +15,4 @@ ;;; 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" -- 1.7.10.4