From b1cf56806db83cba388a9a1d6155593e8381ca02 Mon Sep 17 00:00:00 2001 From: Marius Gerbershagen Date: Sun, 15 Feb 2026 15:55:18 +0100 Subject: [PATCH] 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 | 24 +++++++++++++++++++----- src/c/symbols_list.h | 1 + src/clos/defclass.lsp | 19 +++++++++++++------ src/clos/fixup.lsp | 9 +++++++-- src/clos/kernel.lsp | 13 +++++++++---- src/cmp/cmpenv-proclaim.lsp | 6 ++++++ src/lsp/predlib.lsp | 8 ++++++++ 7 files changed, 63 insertions(+), 17 deletions(-) diff --git a/src/c/clos/instance.d b/src/c/clos/instance.d index babcacfa9..198f9fe8e 100644 --- a/src/c/clos/instance.d +++ b/src/c/clos/instance.d @@ -14,6 +14,7 @@ #include #include #include +#include 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); @) diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 8a1e5bb0d..ff77ac41c 100644 --- a/src/c/symbols_list.h +++ b/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)}, diff --git a/src/clos/defclass.lsp b/src/clos/defclass.lsp index 13d826cf7..a4ddd575e 100644 --- a/src/clos/defclass.lsp +++ b/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)) diff --git a/src/clos/fixup.lsp b/src/clos/fixup.lsp index 4993a8ed4..9113c52d7 100644 --- a/src/clos/fixup.lsp +++ b/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)) diff --git a/src/clos/kernel.lsp b/src/clos/kernel.lsp index c6f43826a..2734beb61 100644 --- a/src/clos/kernel.lsp +++ b/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) diff --git a/src/cmp/cmpenv-proclaim.lsp b/src/cmp/cmpenv-proclaim.lsp index 9e8fdafd4..6394b4502 100644 --- a/src/cmp/cmpenv-proclaim.lsp +++ b/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))) diff --git a/src/lsp/predlib.lsp b/src/lsp/predlib.lsp index bcd7c7fe2..ac2b2c550 100644 --- a/src/lsp/predlib.lsp +++ b/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)))