Merge branch 'find-class-compiler-env' into 'develop'

Store class definitions in the compiler environment

See merge request embeddable-common-lisp/ecl!364

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)))