Merge branch 'fix-571' into 'develop'

Fix 571

Closes #571

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

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(; i<object->array.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
 */

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},

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},

src/clos/method.lsp

@@ -251,8 +251,7 @@
         ;; explicitely the bytecodes compiler with an environment, no
         ;; stepping, compiler-env-p = t and execute = nil, so that the
         ;; form does not get executed.
-        ;; FIXME: Why is execute t then?
+        (si::eval-with-env method-lambda env nil t nil)))
-        (si::eval-with-env method-lambda env nil t t)))
     (values call-next-method-p
             next-method-p-p
             in-closure-p)))

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

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

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)

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

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

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
@@ -1744,3 +1744,14 @@
           (is (eq (peer* v1) v2))
           (is (eq (peer* v2) v1)))))))
 
+;;; Date 2020-03-13
+;;; URL: https://gitlab.com/embeddable-common-lisp/ecl/-/issues/571
+;;; Description
+;;;
+;;;     LOAD-TIME-VALUE inside a DEFMETHOD is evaluated at the
+;;;     compilation time.
+(test cmp.0078.defmethod-not-eager
+  (finishes (with-compiler ("aux-compiler.0078.lsp")
+              `(defclass class () ())
+              `(defmethod method ()
+                 (load-time-value (find-class class))))))