Changeset 13185 for trunk/abcl/src/org

Timestamp:

01/26/11 08:39:54 (12 years ago)

Author:

ehuelsmann

Message:

Fix #119: Incorrect dynamic environment for evaluation of :CLASS
allocation slot initforms.

File:

• trunk/abcl/src/org/armedbear/lisp/clos.lisp (modified) (4 diffs)

trunk/abcl/src/org/armedbear/lisp/clos.lisp

@@ -166 +166 @@
             (writers ())
             (other-options ())
-      (non-std-options ()))
+            (non-std-options ()))
         (do ((olist (cdr spec) (cddr olist)))
             ((null olist))
@@ -175 +175 @@
                       "duplicate slot option :INITFORM for slot named ~S"
                       name))
-             (setq initfunction
-                   `(function (lambda () ,(cadr olist))))
-             (setq initform `',(cadr olist)))
+             (setq initfunction t)
+             (setq initform (cadr olist)))
             (:initarg
              (push-on-end (cadr olist) initargs))
@@ -211 +210 @@
              (push-on-end `(setf ,(cadr olist)) writers))
             (t
-       (push-on-end `(quote ,(car olist)) non-std-options)
+             (push-on-end `(quote ,(car olist)) non-std-options)
              (push-on-end (cadr olist) non-std-options))))
         `(list
           :name ',name
           ,@(when initfunction
-              `(:initform ,initform
-                          :initfunction ,initfunction))
+              `(:initform ',initform
+                :initfunction ,(if (eq allocation :class)
+                                   ;; CLHS specifies the initform for a
+                                   ;; class allocation level slot needs
+                                   ;; to be evaluated in the dynamic
+                                   ;; extent of the DEFCLASS form
+                                   (let ((var (gensym)))
+                                     `(let ((,var ,initform))
+                                        (lambda () ,var)))
+                                 `(lambda () ,initform))))
           ,@(when initargs `(:initargs ',initargs))
           ,@(when readers `(:readers ',readers))
@@ -1313 +1320 @@
              (setf object (cadr object)))
            (intern-eql-specializer object)))
-  ((and (consp specializer)
+        ((and (consp specializer)
               (eq (car specializer) 'java:jclass))
          (let ((jclass (eval specializer)))
-     (java::ensure-java-class jclass)))
+           (java::ensure-java-class jclass)))
         (t
          (error "Unknown specializer: ~S" specializer))))