[Sbcl-commits] CVS: sbcl/tests mop.impure-cload.lisp,NONE,1.1 clos.impure-cload.lisp,1.6,1.7

[Christophe R. <cr...@us...>]

Update of /cvsroot/sbcl/sbcl/tests
In directory sc8-pr-cvs1:/tmp/cvs-serv8055/tests

Modified Files:
	clos.impure-cload.lisp 
Added Files:
	mop.impure-cload.lisp 
Log Message:
0.pre8.116:
	Fix for :DEFAULT-INITARGS with side-effects (detected by Paul 
	Dietz' tests, fix from Gerd Moellmann)
	... ctor needed to be smarter about the separation between 
		locations and initarg equality
	Also really add the hyperobject tests (logically part of 
	sbcl-0.pre8.115)


--- NEW FILE: mop.impure-cload.lisp ---
;;;; miscellaneous side-effectful tests of the MOP

;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; While most of SBCL is derived from the CMU CL system, the test
;;;; files (like this one) were written from scratch after the fork
;;;; from CMU CL.
;;;; 
;;;; This software is in the public domain and is provided with
;;;; absolutely no warranty. See the COPYING and CREDITS files for
;;;; more information.

;;;; Note that the MOP is not in an entirely supported state.
;;;; However, this seems a good a way as any of ensuring that we have
;;;; no regressions.

(defpackage "MOP-TEST"
  (:use "CL" "SB-MOP"))

(in-package "MOP-TEST")

;;; A distilled test case from cmucl-imp for Kevin Rosenberg's
;;; hyperobject.  Fix from Gerd Moellmann.
(defclass hyperobject-class (standard-class)
  ((user-name :initarg :user-name :type string :initform nil
	      :accessor user-name
	      :documentation "User name for class")))

(defclass hyperobject-dsd (standard-direct-slot-definition)
  ())

(defclass hyperobject-esd (standard-effective-slot-definition)
  ((vc :initform 42)))

(defmethod validate-superclass ((class hyperobject-class)
				(superclass standard-class))
  t)

(defmethod compute-effective-slot-definition :around
    ((cl hyperobject-class) name dsds)
  (let ((ia (sb-pcl::compute-effective-slot-definition-initargs cl dsds)))
    (apply #'make-instance 'hyperobject-esd ia)))

(defmethod (setf slot-value-using-class) :around
    (new-value (cl hyperobject-class) obj (slot hyperobject-esd))
  (format t "~s ~s ~s~%" cl obj slot)
  (slot-value slot 'vc))

(defclass hyperobject ()
  ()
  (:metaclass hyperobject-class))

(defclass person (hyperobject)
  ((name :initarg :name :accessor person-name))
  (:metaclass hyperobject-class))


(eval '(make-instance 'person :name t))

;;; success
(sb-ext:quit :unix-status 104)
Index: clos.impure-cload.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/clos.impure-cload.lisp,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -d -r1.6 -r1.7
--- clos.impure-cload.lisp	22 Apr 2003 15:11:01 -0000	1.6
+++ clos.impure-cload.lisp	28 Apr 2003 12:23:58 -0000	1.7
@@ -71,7 +71,7 @@
 ;;; etc., but we should be able to define it).
 
 ;;; the ctor MAKE-INSTANCE optimizer used not to handle duplicate
-;;; initargs.
+;;; initargs...
 (defclass dinitargs-class1 ()
   ((a :initarg :a)))
 (assert (= (slot-value (make-instance 'dinitargs-class1 :a 1 :a 2) 'a) 1))
@@ -79,6 +79,14 @@
 (defclass dinitargs-class2 ()
   ((b :initarg :b1 :initarg :b2)))
 (assert (= (slot-value (make-instance 'dinitargs-class2 :b2 3 :b1 4) 'b) 3))
+;;; ... or default-initargs when the location was already initialized
+(defvar *definitargs-counter* 0)
+(defclass definitargs-class ()
+  ((a :initarg :a :initarg :a2))
+  (:default-initargs :a2 (incf *definitargs-counter*)))
+(assert (= (slot-value (make-instance 'definitargs-class) 'a) 1))
+(assert (= (slot-value (make-instance 'definitargs-class :a 0) 'a) 0))
+(assert (= *definitargs-counter* 2))
 
 ;;; success
 (sb-ext:quit :unix-status 104)