clos: store class definitions in the compiler environment

According to the CLHS:

> If a DEFCLASS form appears as a top level form, [...] the compiler
  must make the class definition available to be returned by FIND-CLASS
  when its environment argument is a value received as the environment
  parameter of a macro.

We already store type definitions in the compiler environment, so we
can just reuse that.

While The metaobject protocol doesn't specify what happens when
compiling DEFCLASS, only what happens when executing it (see
https://franz.com/support/documentation/mop/concepts.html#compile-file),
real life software breaks when we try to create a full class object at
compile time. Therefore, we just create a dummy forward-referenced
class object which contains nothing more than a name.

src/c/clos/instance.d

@@ -14,6 +14,7 @@
 #include <string.h>
 #include <ecl/ecl.h>
 #include <ecl/internal.h>
+#include <ecl/ecl-inl.h>
 
 cl_object
 ecl_allocate_instance(cl_object clas, cl_index size)
@@ -300,13 +301,26 @@ si_copy_instance(cl_object x)
 }
 
 @(defun find-class (name &optional (errorp ECL_T) env)
-  cl_object class, hash;
+  cl_object class = ECL_NIL, hash;
 @
-  hash = ECL_SYM_VAL(the_env, @'si::*class-name-hash-table*');
-  class = ecl_gethash_safe(name, hash, ECL_NIL);
+  if (ECL_CONSP(env)) {
+    env = ecl_car(env);
+    loop_for_in(env) {
+      if (ECL_CONSP(env)) {
+        cl_object record = ECL_CONS_CAR(env);
+        if (ecl_car(record) == @':type' && ecl_cadr(record) == name && ECL_INSTANCEP(ecl_caddr(record))) {
+          class = ecl_caddr(record);
+          break;
+        }
+      }
+    } end_loop_for_in;
+  }
   if (class == ECL_NIL) {
-    if (!Null(errorp))
-      FEerror("No class named ~S.", 1, name);
+    hash = ECL_SYM_VAL(the_env, @'si::*class-name-hash-table*');
+    class = ecl_gethash_safe(name, hash, ECL_NIL);
+  }
+  if (class == ECL_NIL && errorp != ECL_NIL) {
+    FEerror("No class named ~S.", 1, name);
   }
   @(return class);
 @)

src/c/symbols_list.h

@@ -1807,6 +1807,7 @@ cl_symbols[] = {
 {SYS_ "DO-DEFTYPE" ECL_FUN("si_do_deftype", ECL_NAME(si_do_deftype), -4) ECL_VAR(SI_ORDINARY, OBJNULL)},
 {SYS_ "CREATE-TYPE-NAME" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)},
 {SYS_ "*ALIEN-DECLARATIONS*" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_SPECIAL, ECL_NIL)},
+{SYS_ "PROCLAIM-CLASS" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)},
 
 #ifdef ENABLE_DLOPEN
 {SYS_ "LOAD-BINARY" ECL_FUN("si_load_binary", si_load_binary, 4) ECL_VAR(SI_ORDINARY, OBJNULL)},

src/clos/defclass.lsp

@@ -46,15 +46,22 @@
     ;; * The class name may appear in subsequent type declarations.
     ;; * The class name can be used as a specializer in subsequent
     ;;   DEFMETHOD forms.
+    ;; * A class object is installed in the compiler environment so
+    ;;   that FIND-CLASS can find it.
     ;; Doing more at compile time leads to problems with the mop as
     ;; for example validate-superclass methods might not be installed
     ;; at compile time.
-    (si:create-type-name name)
-    (ext:register-with-pde
-     form
-     `(load-defclass ',name ',superclasses
-                     ,(compress-slot-forms slots)
-                     ,(process-class-options options)))))
+    `(progn
+       (eval-when (:compile-toplevel)
+         (si:proclaim-class ',name
+                            (make-instance
+                             (coerce-to-class 'forward-referenced-class)
+                             :name ',name)))
+       ,(ext:register-with-pde
+         form
+         `(load-defclass ',name ',superclasses
+                         ,(compress-slot-forms slots)
+                         ,(process-class-options options))))))
 
 (defun compress-slot-forms (slot-definitions)
   (declare (si::c-local))

src/clos/fixup.lsp

@@ -65,8 +65,13 @@
         ((member name '(CLASS BUILT-IN-CLASS) :test #'eq)
          (error "The kernel CLOS class ~S cannot be changed." name))
         ((classp new-value)
-         (setf (gethash name si:*class-name-hash-table*) new-value))
-        ((null new-value) (remhash name si:*class-name-hash-table*))
+         (if env
+             (si:proclaim-class name new-value env)
+             (setf (gethash name si:*class-name-hash-table*) new-value)))
+        ((null new-value)
+         (if env
+             (si:proclaim-class name nil env)
+             (remhash name si:*class-name-hash-table*)))
         (t (error "~A is not a class." new-value))))
     new-value))
 

src/clos/kernel.lsp

@@ -28,8 +28,8 @@
     (warn "Ignoring class definition for ~S" class)))
 
 (defun setf-find-class (new-value name &optional errorp env)
-  (declare (ignore errorp env))
-  (let ((old-class (find-class name nil)))
+  (declare (ignore errorp))
+  (let ((old-class (find-class name nil env)))
     (cond
       ((and old-class
             (or (typep old-class 'built-in-class)
@@ -38,8 +38,13 @@
          (error "The class associated to the CL specifier ~S cannot be changed."
                 name)))
       ((classp new-value)
-       (setf (gethash name si:*class-name-hash-table*) new-value))
-      ((null new-value) (remhash name si:*class-name-hash-table*))
+       (if env
+           (si:proclaim-class name new-value env)
+           (setf (gethash name si:*class-name-hash-table*) new-value)))
+      ((null new-value)
+       (if env
+           (si:proclaim-class name nil env)
+           (remhash name si:*class-name-hash-table*)))
       (t (error "~A is not a class." new-value))))
   new-value)
 

src/cmp/cmpenv-proclaim.lsp

@@ -121,3 +121,9 @@
           (si:put-sysprop var 'CMP-TYPE type1))
         (warn "The variable name ~s is not a symbol." var))))
 
+(defun si:proclaim-class (name class &optional (env c::*cmp-env-root*))
+  "Add a class definition to the global compiler environment."
+  (si:create-type-name name)
+  (ext:with-backend
+    :c/c++ (cmp-env-register-type name class c::*cmp-env-root*)
+    #-ecl-min :bytecodes #-ecl-min (setf (find-class name) class)))

src/lsp/predlib.lsp

@@ -36,6 +36,14 @@ Builds a new function which accepts any number of arguments but always outputs N
   (ext:fill-array-with-elt *subtypep-cache* nil 0 nil)
   (ext:fill-array-with-elt *upgraded-array-element-type-cache* nil 0 nil))
 
+(defun proclaim-class (name class &optional env)
+  "Add a class definition to the global compiler environment."
+  (declare (ignore env))
+  ;; Default implementation for the bytecodes compiler which doesn't
+  ;; have a separate file-local compiler environment.
+  (si:create-type-name name)
+  (setf (find-class name) class))
+
 (defun create-type-name (name)
   (when (member name *alien-declarations*)
     (error "Symbol ~s is a declaration specifier and cannot be used to name a new type" name)))