From 6044a3ac0bcca2f650f76f665a0cf30b8d8e3beb Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Thu, 25 Jan 2001 14:42:00 +0000 Subject: [PATCH] 0.6.10.6: defined INTERSECTION-TYPE by analogy with UNION-TYPE (aiming to fix bug #12) renamed PUNT blocknames in type methods to PUNT-TYPE-METHOD renamed PUNT-IF-TOO-LONG to PUNT-PRINT-IF-TOO-LONG --- package-data-list.lisp-expr | 2 +- src/code/early-print.lisp | 2 +- src/code/early-type.lisp | 5 +++-- src/code/late-type.lisp | 50 +++++++++++++++++++++++++++++++++++++------ src/code/print.lisp | 10 ++++----- src/code/typedefs.lisp | 4 ++-- src/compiler/globaldb.lisp | 3 ++- version.lisp-expr | 2 +- 8 files changed, 58 insertions(+), 20 deletions(-) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 9ea843f..762ce26 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1061,7 +1061,7 @@ is a good idea, but see SB-SYS for blurring of boundaries." "PACKAGE-INTERNAL-SYMBOLS" "PACKAGE-EXTERNAL-SYMBOLS" "PARSE-DEFMACRO" "PARSE-LAMBDA-LIST" "PARSE-UNKNOWN-TYPE" "PARSE-UNKNOWN-TYPE-SPECIFIER" - "PATHNAME-DESIGNATOR" "PUNT-IF-TOO-LONG" + "PATHNAME-DESIGNATOR" "PUNT-PRINT-IF-TOO-LONG" "READER-PACKAGE-ERROR" #!+gengc "*SAVED-STATE-CHAIN*" "SCALE-DOUBLE-FLOAT" "SCALE-LONG-FLOAT" diff --git a/src/code/early-print.lisp b/src/code/early-print.lisp index 5dd2e92..6f7d9e6 100644 --- a/src/code/early-print.lisp +++ b/src/code/early-print.lisp @@ -33,7 +33,7 @@ (let ((*current-level* (1+ *current-level*))) (,flet-name))))))) -(defmacro punt-if-too-long (index stream) +(defmacro punt-print-if-too-long (index stream) #!+sb-doc "Punt if INDEX is equal or larger then *PRINT-LENGTH* (and *PRINT-READABLY* is NIL) by outputting \"...\" and returning from the block named NIL." diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp index c4fe88a..1b34a4e 100644 --- a/src/code/early-type.lisp +++ b/src/code/early-type.lisp @@ -84,8 +84,9 @@ form))) ;;; A HAIRY-TYPE represents anything too weird to be described -;;; reasonably or to be useful, such as AND, NOT and SATISFIES and -;;; unknown types. We just remember the original type spec. +;;; reasonably or to be useful, such as NOT, SATISFIES, unknown types, +;;; and unreasonably complicated types involving AND. We just remember +;;; the original type spec. (defstruct (hairy-type (:include ctype (class-info (type-class-or-lose 'hairy)) (enumerable t)) diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 576c771..e9c4a67 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -1503,7 +1503,7 @@ t)) (!define-type-method (member :complex-subtypep-arg1) (type1 type2) - (block PUNT + (block punt-type-method (values (every-type-op ctypep type2 (member-type-members type1) :list-first t) t))) @@ -1530,13 +1530,13 @@ t))) (!define-type-method (member :complex-intersection) (type1 type2) - (block PUNT + (block punt-type-method (collect ((members)) (let ((mem2 (member-type-members type2))) (dolist (member mem2) (multiple-value-bind (val win) (ctypep member type1) (unless win - (return-from PUNT (values type2 nil))) + (return-from punt-type-method (values type2 nil))) (when val (members member)))) (values (cond ((subsetp mem2 (members)) type2) @@ -1575,6 +1575,42 @@ (make-member-type :members (remove-duplicates members)) *empty-type*)) +;;;; intersection types +;;;; +;;;; Until version 0.6.10.6, SBCL followed the original CMU CL approach +;;;; of punting on all AND types, not just the unreasonably complicated +;;;; ones. The change was motivated by trying to get the KEYWORD type +;;;; to behave sensibly: +;;;; ;; reasonable definition +;;;; (DEFTYPE KEYWORD () '(AND SYMBOL (SATISFIES KEYWORDP))) +;;;; ;; reasonable behavior +;;;; (ASSERT (SUBTYPEP 'KEYWORD 'SYMBOL)) +;;;; Without understanding a little about the semantics of AND, we'd +;;;; get (SUBTYPEP 'KEYWORD 'SYMBOL)=>NIL,NIL, which is unreasonable.) +;;;; +;;;; We still follow the example of CMU CL to some extent, by punting +;;;; (to the opaque HAIRY-TYPE) on sufficiently complicated types +;;;; involving AND. + +;;; Make a union type from the specifier types; or punt (to opaque +;;; HAIRY-TYPE) if the class looks as though it might get too hairy. +(defun make-intersection-type (types) + (declare (list types)) + ;; "If potentially too hairy.." + ;; + ;; (CMU CL punted for all AND-based types, and we'd like to avoid + ;; any really unreasonable cases which might have motivated them to + ;; do this, while still being reasonably effective on simple + ;; intersection types like KEYWORD.) + (if (any (lambda (type) + (or (union-type-p type) + (hairy-type-p type))) + types) + (make-hairy-type :specifier (mapcar #'type-specifier types)) + (%make-intersection-type (some #'type-enumerable types) types))) + +(!define-type-class intersection) + ;;;; union types ;;; Make a union type from the specifier types, setting ENUMERABLE in @@ -1595,7 +1631,7 @@ ;;; Two union types are equal if every type in one is equal to some ;;; type in the other. (!define-type-method (union :simple-=) (type1 type2) - (block PUNT + (block punt-type-method (let ((types1 (union-type-types type1)) (types2 (union-type-types type2))) (values (and (dolist (type1 types1 t) @@ -1609,7 +1645,7 @@ ;;; Similarly, a union type is a subtype of another if every element ;;; of TYPE1 is a subtype of some element of TYPE2. (!define-type-method (union :simple-subtypep) (type1 type2) - (block PUNT + (block punt-type-method (let ((types2 (union-type-types type2))) (values (dolist (type1 (union-type-types type1) t) (unless (any-type-op csubtypep type1 types2) @@ -1617,13 +1653,13 @@ t)))) (!define-type-method (union :complex-subtypep-arg1) (type1 type2) - (block PUNT + (block punt-type-method (values (every-type-op csubtypep type2 (union-type-types type1) :list-first t) t))) (!define-type-method (union :complex-subtypep-arg2) (type1 type2) - (block PUNT + (block punt-type-method (values (any-type-op csubtypep type1 (union-type-types type2)) t))) (!define-type-method (union :complex-union) (type1 type2) diff --git a/src/code/print.lisp b/src/code/print.lisp index 7b4d3fe..d715bf1 100644 --- a/src/code/print.lisp +++ b/src/code/print.lisp @@ -925,7 +925,7 @@ (let ((length 0) (list list)) (loop - (punt-if-too-long length stream) + (punt-print-if-too-long length stream) (output-object (pop list) stream) (unless list (return)) @@ -958,7 +958,7 @@ (dotimes (i (length vector)) (unless (zerop i) (write-char #\space stream)) - (punt-if-too-long i stream) + (punt-print-if-too-long i stream) (output-object (aref vector i) stream)) (write-string ")" stream))))) @@ -1020,13 +1020,13 @@ (dotimes (i dimension) (unless (zerop i) (write-char #\space stream)) - (punt-if-too-long i stream) + (punt-print-if-too-long i stream) (sub-output-array-guts array dimensions stream index) (incf index count))) (write-char #\) stream))))) -;;; a trivial non-generic-function placeholder for PRINT-OBJECT, for use -;;; until CLOS is set up (at which time it will be replaced with +;;; a trivial non-generic-function placeholder for PRINT-OBJECT, for +;;; use until CLOS is set up (at which time it will be replaced with ;;; the real generic function implementation) (defun print-object (instance stream) (default-structure-print instance stream *current-level*)) diff --git a/src/code/typedefs.lisp b/src/code/typedefs.lisp index b160271..0d76fe9 100644 --- a/src/code/typedefs.lisp +++ b/src/code/typedefs.lisp @@ -106,7 +106,7 @@ (,n-uncertain nil)) (dolist (,n-this ,list (if ,n-uncertain - (return-from PUNT ,default) + (return-from punt-type-method ,default) nil)) (multiple-value-bind (,n-val ,n-win) ,(if list-first @@ -126,7 +126,7 @@ ,(if list-first `(,op ,n-this ,n-thing) `(,op ,n-thing ,n-this)) - (unless ,n-win (return-from PUNT ,default)) + (unless ,n-win (return-from punt-type-method ,default)) (unless ,n-val (return nil))))))) ;;; Compute the intersection for types that intersect only when one is a diff --git a/src/compiler/globaldb.lisp b/src/compiler/globaldb.lisp index 7204f6f..e2f4340 100644 --- a/src/compiler/globaldb.lisp +++ b/src/compiler/globaldb.lisp @@ -372,7 +372,8 @@ (declare (ignorable ,type-var ,class-var ,value-var)) ,@body - (unless (zerop (logand ,n-info compact-info-entry-last)) + (unless (zerop (logand ,n-info + compact-info-entry-last)) (return-from ,PUNT)))))))))))))) ;;; Return code to iterate over a volatile info environment. diff --git a/version.lisp-expr b/version.lisp-expr index e5b2320..bd39bec 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.10.5" +"0.6.10.6" -- 1.7.10.4