Trac/ticket/479/mevenson/20210116a

abcl-prove.asd

@@ -1,6 +1,6 @@
 ;;; -*- Mode: LISP; Syntax: COMMON-LISP -*-
 (defsystem :abcl-prove
-  :version "1.8.0"
+  :version "1.8.1"
   :defsystem-depends-on (prove-asdf)
   :depends-on (prove)
   :perform (test-op (o c)
@@ -12,6 +12,7 @@
                              (:test-file "byte-vectors")
                              (:test-file "compiler-stack-inconsistency")
                              (:test-file "compiler")
+                             (:test-file "clos")
                              (:test-file "decode-float")
                              (:test-file "disassemble")
                              (:test-file "format-dollar")

src/org/armedbear/lisp/clos.lisp

@@ -545,7 +545,7 @@
          (incf length)
          (push (slot-definition-name slot) instance-slots))
         (:class
-         (unless (slot-definition-location slot)
+         (unless (ignore-errors (slot-definition-location slot))
            (let ((allocation-class (slot-definition-allocation-class slot)))
              (if (eq allocation-class class)
                  ;; We initialize class slots here so they can be

t/clos.lisp

@@ -0,0 +1,20 @@
+(in-package :cl-user)
+
+;;; <https://abcl.org/trac/ticket/479>
+(prove:plan 1)
+(let ((file
+        (asdf:system-relative-pathname
+         :abcl
+         "t/eg/clos-unbound-use-mop.lisp")))
+  (prove:ok 
+   (handler-case
+       (load file)
+     (t (e)
+       (prove:diag (format nil "Failed to load ~a: ~a" file e))
+       nil))
+   "Testing compilation of slot class allocation finalization"))
+
+(prove:finalize)
+
+
+

t/eg/clos-unbound-use-mop.lisp

@@ -0,0 +1,39 @@
+(use-package :mop)
+
+(defclass test-direct-slot-definition
+          (standard-direct-slot-definition)
+  ())
+
+(defclass test-effective-slot-definition
+          (standard-effective-slot-definition)
+  ())
+
+(defclass test-class (standard-class) ())
+
+(defmethod validate-superclass
+           ((class test-class)
+            (superclass standard-class))
+  t)
+
+(defmethod direct-slot-definition-class
+           ((class test-class) &rest initargs)
+  (declare (ignore initargs))
+  (find-class 'test-direct-slot-definition))
+
+(defmethod effective-slot-definition-class
+           ((class test-class) &rest initargs)
+  (declare (ignore initargs))
+  (find-class 'test-effective-slot-definition))
+
+(defclass test-object ()
+  ((some-slot :accessor some-slot
+              :initarg :some-slot
+              :initform 'some-slot
+              :type symbol
+              :allocation :class
+              :documentation "a slot"))
+  (:metaclass test-class))
+
+(unless (mop:class-finalized-p (find-class 'test-object))
+  (finalize-inheritance (find-class 'test-object)))
+