diff --git a/src/c/compiler.d b/src/c/compiler.d index fd77049aa..e67cd2b21 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -2198,34 +2198,6 @@ c_values(cl_env_ptr env, cl_object args, int flags) { return FLAG_VALUES; } -static int -need_to_make_load_form_p(cl_object o) -{ - switch (ecl_t_of(o)) { - case t_character: - case t_fixnum: - case t_bignum: - case t_ratio: - case t_singlefloat: - case t_doublefloat: - case t_longfloat: - case t_complex: - case t_symbol: - case t_pathname: -#ifdef ECL_UNICODE - case t_string: -#endif - case t_base_string: - case t_bitvector: - return 0; - case t_list: - if (Null(o)) return 0; - default: - return _ecl_funcall3(@'clos::need-to-make-load-form-p', o, ECL_NIL) - != ECL_NIL; - } -} - static void maybe_make_load_forms(cl_env_ptr env, cl_object constant) { @@ -2235,7 +2207,7 @@ maybe_make_load_forms(cl_env_ptr env, cl_object constant) return; if (c_search_constant(env, constant) >= 0) return; - if (!need_to_make_load_form_p(constant)) + if (si_need_to_make_load_form_p(constant) == ECL_NIL) return; make = _ecl_funcall2(@'make-load-form', constant); init = (env->nvalues > 1)? env->values[1] : ECL_NIL; @@ -2665,6 +2637,89 @@ c_listA(cl_env_ptr env, cl_object args, int flags) ------------------------------------------------------------ */ +/* + Determine whether the form can be externalized using the lisp + printer or we should rather use MAKE-LOAD-FORM. +*/ +cl_object +si_need_to_make_load_form_p(cl_object object) +{ + cl_object load_form_cache = ECL_NIL; + cl_object waiting_objects = ecl_list1(object); + cl_type type = t_start; + + loop: + if (waiting_objects == ECL_NIL) + return ECL_NIL; + object = pop(&waiting_objects); + type = ecl_t_of(object); + /* For simple, atomic objects we just return NIL. There is no need + to call MAKE-LOAD-FORM on them. */ + switch (type) { + case t_character: + case t_fixnum: + case t_bignum: + case t_ratio: + case t_singlefloat: + case t_doublefloat: + case t_longfloat: + case t_complex: +#ifdef ECL_COMPLEX_FLOAT + case t_csfloat: + case t_cdfloat: + case t_clfloat: +#endif + case t_symbol: + case t_pathname: +#ifdef ECL_UNICODE + case t_string: +#endif + case t_base_string: + case t_bitvector: + goto loop; + case t_list: + if (Null(object)) goto loop; + default: + ; + } + /* For compound objects we set up a cache and run through the + objects content looking for components that might require + MAKE-LOAD-FORM to be externalized. The cache is used to solve the + problem of circularity and of EQ references. */ + if (ecl_member_eq(object, load_form_cache)) + goto loop; + push(object, &load_form_cache); + switch (type) { + case t_array: + case t_vector: + if (object->array.elttype == ecl_aet_object) { + cl_index i = 0; + for(; iarray.dim; i++) { + push(object->array.self.t[i], &waiting_objects); + } + } + goto loop; + case t_list: + push(ECL_CONS_CAR(object), &waiting_objects); + push(ECL_CONS_CDR(object), &waiting_objects); + goto loop; + case t_bclosure: { + cl_object bc = object->bclosure.code;; + push(object->bclosure.lex, &waiting_objects); + push(bc->bytecodes.data, &waiting_objects); + push(bc->bytecodes.name, &waiting_objects); + goto loop; + } + case t_bytecodes: + push(object->bytecodes.data, &waiting_objects); + push(object->bytecodes.name, &waiting_objects); + goto loop; + default: + return ECL_T; + } + _ecl_unexpected_return(); +} + /* Handles special declarations, removes declarations from body */ diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index f185cf9ea..31c199798 100755 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1214,6 +1214,7 @@ cl_symbols[] = { {SYS_ "MEMQ", SI_ORDINARY, si_memq, 2, OBJNULL}, {SYS_ "MKDIR", SI_ORDINARY, si_mkdir, 2, OBJNULL}, {EXT_ "MKSTEMP", EXT_ORDINARY, si_mkstemp, 1, OBJNULL}, +{SYS_ "NEED-TO-MAKE-LOAD-FORM-P", SI_ORDINARY, si_need_to_make_load_form_p, 1, OBJNULL}, {SYS_ "RMDIR", SI_ORDINARY, si_rmdir, 1, OBJNULL}, {EXT_ "MAKE-PIPE", EXT_ORDINARY, si_make_pipe, 0, OBJNULL}, /* package extensions */ @@ -1776,7 +1777,6 @@ cl_symbols[] = { {CLOS_ "VALIDATE-SUPERCLASS", CLOS_ORDINARY, NULL, -1, OBJNULL}, {CLOS_ "WRITER-METHOD-CLASS", CLOS_ORDINARY, NULL, -1, OBJNULL}, {SYS_ "CLEAR-GFUN-HASH", SI_ORDINARY, si_clear_gfun_hash, 1, OBJNULL}, -{CLOS_ "NEED-TO-MAKE-LOAD-FORM-P", CLOS_ORDINARY, ECL_NAME(clos_need_to_make_load_form_p), 2, OBJNULL}, {CLOS_ "LOAD-DEFCLASS", CLOS_ORDINARY, ECL_NAME(clos_load_defclass), 4, OBJNULL}, {CLOS_ "DOCSTRING", CLOS_ORDINARY, NULL, -1, OBJNULL}, {CLOS_ "SAFE-INSTANCE-REF", CLOS_ORDINARY, clos_safe_instance_ref, 2, OBJNULL}, diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h index 5ab3f6299..6d4a64366 100644 --- a/src/c/symbols_list2.h +++ b/src/c/symbols_list2.h @@ -1214,6 +1214,7 @@ cl_symbols[] = { {SYS_ "MEMQ","si_memq",2}, {SYS_ "MKDIR","si_mkdir",2}, {EXT_ "MKSTEMP","si_mkstemp",1}, +{SYS_ "NEED-TO-MAKE-LOAD-FORM-P","si_need_to_make_load_form_p",1}, {SYS_ "RMDIR","si_rmdir",1}, {EXT_ "MAKE-PIPE","si_make_pipe",0}, /* package extensions */ @@ -1776,7 +1777,6 @@ cl_symbols[] = { {CLOS_ "VALIDATE-SUPERCLASS",NULL,-1}, {CLOS_ "WRITER-METHOD-CLASS",NULL,-1}, {SYS_ "CLEAR-GFUN-HASH","si_clear_gfun_hash",1}, -{CLOS_ "NEED-TO-MAKE-LOAD-FORM-P","ECL_NAME(clos_need_to_make_load_form_p)",2}, {CLOS_ "LOAD-DEFCLASS","ECL_NAME(clos_load_defclass)",4}, {CLOS_ "DOCSTRING",NULL,-1}, {CLOS_ "SAFE-INSTANCE-REF","clos_safe_instance_ref",2}, diff --git a/src/clos/print.lsp b/src/clos/print.lsp index a5b713b77..ea3925169 100644 --- a/src/clos/print.lsp +++ b/src/clos/print.lsp @@ -51,57 +51,12 @@ (primitive-nil)) initialization-form))))))) -(defun need-to-make-load-form-p (object env) - "Return T if the object cannot be externalized using the lisp -printer and we should rather use MAKE-LOAD-FORM." - (declare (ignore env)) - (let ((*load-form-cache* nil)) - (declare (special *load-form-cache*)) - (labels ((recursive-test (object) - (loop - ;; For simple, atomic objects we just return NIL. There is no need to - ;; call MAKE-LOAD-FORM on them - (when (typep object '(or character number symbol pathname string bit-vector)) - (return nil)) - ;; For complex objects we set up a cache and run through the - ;; objects content looking for data that might require - ;; MAKE-LOAD-FORM to be externalized. The cache is used to - ;; solve the problem of circularity and of EQ references. - (unless *load-form-cache* - (setf *load-form-cache* (make-hash-table :size 128 :test #'eq))) - (when (gethash object *load-form-cache*) - (return nil)) - (setf (gethash object *load-form-cache*) t) - (cond ((arrayp object) - (unless (subtypep (array-element-type object) '(or character number)) - (dotimes (i (array-total-size object)) - (recursive-test (row-major-aref object i)))) - (return nil)) - ((consp object) - (recursive-test (car object)) - (setf object (rest object))) - ((compiled-function-p object) - (multiple-value-bind (lex code data name) - (si::bc-split object) - (when (or (null data) - (null code) - (recursive-test lex) - (recursive-test code) - (recursive-test name)) - (throw 'need-to-make-load-form t)) - (setf object data))) - (t - (throw 'need-to-make-load-form t)))))) - (catch 'need-to-make-load-form - (recursive-test object) - nil)))) - (defmethod make-load-form ((object t) &optional env) (flet ((maybe-quote (object) (if (or (consp object) (symbolp object)) (list 'quote object) object))) - (unless (need-to-make-load-form-p object env) + (unless (si::need-to-make-load-form-p object) (return-from make-load-form (maybe-quote object))) (typecase object (compiled-function @@ -121,7 +76,7 @@ printer and we should rather use MAKE-LOAD-FORM." :initial-contents ',(loop for i from 0 below (array-total-size object) collect (let ((x (row-major-aref object i))) - (if (need-to-make-load-form-p x env) + (if (si::need-to-make-load-form-p x) (progn (push `(setf (row-major-aref ,object ,i) ',x) init-forms) 0) @@ -140,7 +95,7 @@ printer and we should rather use MAKE-LOAD-FORM." :rehash-size ,(hash-table-rehash-size object) :rehash-threshold ,(hash-table-rehash-threshold object) :test ',(hash-table-test object)))) - (if (need-to-make-load-form-p content env) + (if (si::need-to-make-load-form-p content) (values make-form `(dolist (i ',(loop for key being each hash-key in object diff --git a/src/cmp/cmpwt.lsp b/src/cmp/cmpwt.lsp index 5930b1644..76f3b412b 100644 --- a/src/cmp/cmpwt.lsp +++ b/src/cmp/cmpwt.lsp @@ -155,7 +155,7 @@ (add-object 0 :duplicate t :permanent t)) (defun add-load-form (object location) - (unless (clos::need-to-make-load-form-p object *cmp-env*) + (unless (si::need-to-make-load-form-p object) (return-from add-load-form)) (unless (eq *compiler-phase* 't1) (cmperr "Unable to internalize complex object ~A in ~a phase." object *compiler-phase*)) diff --git a/src/cmp/proclamations.lsp b/src/cmp/proclamations.lsp index 5748adfec..91f19a05f 100644 --- a/src/cmp/proclamations.lsp +++ b/src/cmp/proclamations.lsp @@ -1451,7 +1451,7 @@ (proclamation clos::associate-methods-to-gfun (function-name *) generic-function) #+clos -(proclamation clos::need-to-make-load-form-p (t t) gen-bool :pure) +(proclamation si::need-to-make-load-form-p (t) gen-bool :pure) #+clos (proclamation clos::load-defclass (t t t t) t) diff --git a/src/cmp/sysfun.lsp b/src/cmp/sysfun.lsp index 5959a5763..c82881ef1 100644 --- a/src/cmp/sysfun.lsp +++ b/src/cmp/sysfun.lsp @@ -1035,8 +1035,6 @@ clos:extract-specializer-names ;; predlib.lsp si::subclassp si::of-class-p - ;; print.lsp - clos::need-to-make-load-form-p ;; slotvalue.lsp slot-makunbound ;; std-slot-value.lsp diff --git a/src/h/external.h b/src/h/external.h index b984374a2..572c7e7d0 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -522,6 +522,7 @@ extern ECL_API cl_object cl_grab_rest_args(ecl_va_list args); /* compiler.c */ extern ECL_API cl_object si_macrolet_function(cl_object form, cl_object env); +extern ECL_API cl_object si_need_to_make_load_form_p(cl_object object); extern ECL_API cl_object si_process_lambda_list(cl_object lambda_list, cl_object context); extern ECL_API cl_object si_process_lambda(cl_object lambda); extern ECL_API cl_object si_make_lambda(cl_object name, cl_object body); @@ -2207,9 +2208,6 @@ extern ECL_API cl_object cl_slot_boundp(cl_object object, cl_object slot); extern ECL_API cl_object cl_slot_makunbound(cl_object object, cl_object slot); extern ECL_API cl_object cl_slot_exists_p(cl_object object, cl_object slot); -/* print.lsp */ -extern ECL_API cl_object clos_need_to_make_load_form_p(cl_object o, cl_object env); - /* defclass.lsp */ extern ECL_API cl_object clos_load_defclass(cl_object name, cl_object superclasses, cl_object slots, cl_object options); diff --git a/src/tests/normal-tests/compiler.lsp b/src/tests/normal-tests/compiler.lsp index 7a9a2a7ce..4f8931650 100644 --- a/src/tests/normal-tests/compiler.lsp +++ b/src/tests/normal-tests/compiler.lsp @@ -655,7 +655,7 @@ (subst 3 l l) (make-instance 'compiler-test-class) (subst (make-instance 'compiler-test-class) 3 l))) - collect (clos::need-to-make-load-form-p object nil)) + collect (si::need-to-make-load-form-p object)) '(nil nil t t)))) ;;; Date: 18/05/2005