From 5164d4bba99fa9d486ceb3aa65c6c7b136702a11 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Sun, 8 Jun 2003 18:43:53 +0000 Subject: [PATCH] 0.8.0.51: Fix TYPE-OF bugs from Paul Dietz' test suite ... attempt to return reasonable intersections of the relevant built-in-types for non-negative integers --- package-data-list.lisp-expr | 2 +- src/code/pred.lisp | 42 +++++++++++++++++++++++++++++------------- src/pcl/methods.lisp | 4 ++++ version.lisp-expr | 2 +- 4 files changed, 35 insertions(+), 15 deletions(-) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index c78b852..193f46e 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1316,7 +1316,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "*TYPE-SYSTEM-INITIALIZED*" "FIND-LAYOUT" "DSD-NAME" "%TYPEP" "DD-RAW-INDEX" "DD-NAME" "CLASSOID-SUBCLASSES" - "CLASSOID-LAYOUT" "CLASSOID-NAME" + "CLASSOID-LAYOUT" "CLASSOID-NAME" "CLASSOID-P" "DD-RAW-LENGTH" "NOTE-NAME-DEFINED" "%CODE-CODE-SIZE" "DD-SLOTS" "DD-INCLUDE" "SLOT-SETTER-LAMBDA-FORM" diff --git a/src/code/pred.lisp b/src/code/pred.lisp index dd6ccb2..bb71bac 100644 --- a/src/code/pred.lisp +++ b/src/code/pred.lisp @@ -113,19 +113,35 @@ (defun type-of (object) #!+sb-doc "Return the type of OBJECT." - (if (typep object '(or function array complex)) - (type-specifier (ctype-of object)) - (let* ((classoid (layout-classoid (layout-of object))) - (name (classoid-name classoid))) - (if (typep object 'instance) - (case name - (sb!alien-internals:alien-value - `(sb!alien:alien - ,(sb!alien-internals:unparse-alien-type - (sb!alien-internals:alien-value-type object)))) - (t - (classoid-proper-name classoid))) - name)))) + (typecase object + (fixnum + (cond + ((<= 0 object 1) 'bit) + ((< object 0) 'fixnum) + (t '(integer 0 #.sb!xc:most-positive-fixnum)))) + (integer + (if (>= object 0) + '(integer #.(1+ sb!xc:most-positive-fixnum)) + 'bignum)) + (standard-char 'standard-char) + ((member t) 'boolean) + (keyword 'keyword) + ((or array complex) (type-specifier (ctype-of object))) + (t + (let* ((classoid (layout-classoid (layout-of object))) + (name (classoid-name classoid))) + (if (typep object 'instance) + (case name + (sb!alien-internals:alien-value + `(sb!alien:alien + ,(sb!alien-internals:unparse-alien-type + (sb!alien-internals:alien-value-type object)))) + (t + (let ((pname (classoid-proper-name classoid))) + (if (classoid-p pname) + (classoid-pcl-class pname) + pname)))) + name))))) ;;;; equality predicates diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index 437e146..855c907 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -1485,6 +1485,10 @@ (set-dfun gf dfun cache info) ; lest the cache be freed twice (update-dfun gf dfun cache info)))))) +(defmethod (setf class-name) :before (new-value (class class)) + (let ((classoid (find-classoid (class-name class)))) + (setf (classoid-name classoid) new-value))) + (defmethod function-keywords ((method standard-method)) (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords) (analyze-lambda-list (if (consp method) diff --git a/version.lisp-expr b/version.lisp-expr index 6bd8474..4e37d89 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.8.0.50" +"0.8.0.51" -- 1.7.10.4