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