Skip to content
Snippets Groups Projects
Commit f847c099 authored by gerd's avatar gerd
Browse files

Various problems with TYPE-OF found by Paul Dietz.

	* src/pcl/methods.lisp (setf class-name) <before>: New method
	setting the kernel class' name.

	* src/code/pred.lisp (type-of): Don't return list function types.
	Return boolean for t, (integer n n) for integers, keyword for
	keywords, standard-char for standard characters.  Return
	the CLOS class for classes not having a proper name.
parent 9d611502
No related branches found
No related tags found
No related merge requests found
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain. ;;; Carnegie Mellon University, and has been placed in the public domain.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pred.lisp,v 1.58 2003/04/27 14:52:27 toy Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pred.lisp,v 1.59 2003/06/06 12:22:33 gerd Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -130,19 +130,29 @@ ...@@ -130,19 +130,29 @@
;;; ;;;
(defun type-of (object) (defun type-of (object)
"Return the type of OBJECT." "Return the type of OBJECT."
(if (typep object '(or function array complex)) (typecase object
(type-specifier (ctype-of object)) ((or array complex)
(let* ((class (layout-class (layout-of object))) (type-specifier (ctype-of object)))
(name (%class-name class))) (integer
(if (%instancep object) `(integer ,object ,object))
(case name ((member t)
(alien-internals:alien-value 'boolean)
`(alien:alien (keyword
,(alien-internals:unparse-alien-type 'keyword)
(alien-internals:alien-value-type object)))) (standard-char
(t 'standard-char)
(class-proper-name class))) (t
name)))) (let* ((class (layout-class (layout-of object)))
(name (%class-name class)))
(if (%instancep object)
(if (eq name 'alien-internals:alien-value)
`(alien:alien ,(alien-internals:unparse-alien-type
(alien-internals:alien-value-type object)))
(let ((proper-name (class-proper-name class)))
(if (kernel::class-p proper-name)
(%class-pcl-class proper-name)
proper-name)))
name)))))
;;;; UPGRADED-ARRAY-ELEMENT-TYPE -- public ;;;; UPGRADED-ARRAY-ELEMENT-TYPE -- public
......
...@@ -99,6 +99,10 @@ New in this release: ...@@ -99,6 +99,10 @@ New in this release:
- FIND-METHOD signaling an error when called with specializers - FIND-METHOD signaling an error when called with specializers
not corresponding to the number of required arguments of the not corresponding to the number of required arguments of the
supplied generic function. supplied generic function.
- TYPE-OF returning KEYWORD for keywords, STANDARD-CHAR for
standard characters, BOOLEAN for T, (INTEGER <N> <N>) for
integers N, non-list types for functions, and CLOS classes for
instances whose class doesn't have a proper name.
* Numerous bugfixes: * Numerous bugfixes:
- NSET-EXCLUSIVE-OR returns the same results as SET-EXCLUSIVE-OR - NSET-EXCLUSIVE-OR returns the same results as SET-EXCLUSIVE-OR
...@@ -117,7 +121,6 @@ New in this release: ...@@ -117,7 +121,6 @@ New in this release:
it now has an extra argument that describes the nature of the it now has an extra argument that describes the nature of the
error or warning. error or warning.
* Numerous improvements to the PCL implementation of CLOS: * Numerous improvements to the PCL implementation of CLOS:
- Gerd's PCL has been added, which fixes numerous bugs and ANSI/ - Gerd's PCL has been added, which fixes numerous bugs and ANSI/
AMOP non-compliances, and adds various new optimizations (also AMOP non-compliances, and adds various new optimizations (also
......
...@@ -26,7 +26,7 @@ ...@@ -26,7 +26,7 @@
;;; ;;;
(file-comment (file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/methods.lisp,v 1.38 2003/06/05 08:33:45 gerd Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/methods.lisp,v 1.39 2003/06/06 12:22:32 gerd Exp $")
(in-package :pcl) (in-package :pcl)
...@@ -1539,3 +1539,6 @@ ...@@ -1539,3 +1539,6 @@
(declare (ignore nreq nopt keysp restp)) (declare (ignore nreq nopt keysp restp))
(values keywords allow-other-keys-p))) (values keywords allow-other-keys-p)))
(defmethod (setf class-name) :before (new-name (class class))
(let ((kernel-class (kernel::find-class (class-name class))))
(setf (kernel:%class-name kernel-class) new-name)))
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment