Merge branch 'fix-load-forms' into 'develop'

fix load forms

Closes #562

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

CHANGELOG

@@ -31,12 +31,19 @@
 ** Announcement
 ** Enhancements
 - less cryptic names in backtraces of C-compiled functions
-** Issues fixed
-- The generational and precise garbage collector modes work again
 - ECL can now use precompiled headers to speed up compilation. Use ~(setq
   c::*use-precompiled-headers* nil)~ to disable this feature
 ** Issues fixed
+- the generational and precise garbage collector modes work again
 - ~serve-event~ extension may be used simultaneously from different threads now
+- several Unicode issues have been fixed thanks to Vladimir Sedach
+- encoding issues when reading in the output of the MSVC compiler have been fixed
+- inlining of a local function which closes over a variable no longer leads
+  to miscompilations if a variable with the same name exists at the point
+  where the function is inlined
+- the bytecompiler handles load time forms from literal objects correctly
+  with regards to the evaluation order and to multiple occurrences of the same
+  literal object in a single file
 ** API changes
 - a condition ~ext:timeout~ is defined
 * 20.4.24 changes since 16.1.3

contrib/bytecmp/bytecmp.lsp

@@ -26,17 +26,17 @@
   (when (si::valid-function-name-p thing)
     (setq thing (fdefinition thing)))
   (cond ((null thing))
-	((functionp thing)
+        ((functionp thing)
-	 (si::bc-disassemble thing))
+         (si::bc-disassemble thing))
-	((and (consp thing)
+        ((and (consp thing)
               (member (car thing) '(LAMBDA 'EXT:LAMBDA-BLOCK)))
-	 (disassemble (compile nil thing)))
+         (disassemble (compile nil thing)))
-	(t
+        (t
-	 (error 'simple-type-error
+         (error 'simple-type-error
-		:datum thing
+                :datum thing
-		:expected-type '(OR FUNCTION (SATISFIES SI:VALID-FUNCTION-NAME-P))
+                :expected-type '(OR FUNCTION (SATISFIES SI:VALID-FUNCTION-NAME-P))
-		:format-control "DISASSEMBLE cannot accept ~A."
+                :format-control "DISASSEMBLE cannot accept ~A."
-		:format-arguments (list thing))))
+                :format-arguments (list thing))))
   nil)
 
 (defun bc-compile (name &optional (definition nil def-p) &aux (*print-pretty* nil))
@@ -79,8 +79,8 @@
          (return-from bc-compile (values name nil nil)))))
 
 (defun bc-compile-file-pathname (name &key (output-file name) (type :fasl)
-				 verbose print c-file h-file data-file
+                                        verbose print c-file h-file data-file
-				 shared-data-file system-p load external-format)
+                                        shared-data-file system-p load external-format)
   (declare (ignore load c-file h-file data-file shared-data-file system-p verbose print external-format))
   (let ((extension "fasc"))
     (case type
@@ -89,13 +89,13 @@
     (make-pathname :type extension :defaults output-file)))
 
 (defun bc-compile-file (input
-			&key
+                        &key
-			((:verbose *compile-verbose*) *compile-verbose*)
+                          ((:verbose *compile-verbose*) *compile-verbose*)
-			((:print *compile-print*) *compile-print*)
+                          ((:print *compile-print*) *compile-print*)
-			(load nil)
+                          (load nil)
-			(external-format :default)
+                          (external-format :default)
-			(output-file nil output-file-p)
+                          (output-file nil output-file-p)
-			&allow-other-keys &aux foo)
+                        &allow-other-keys &aux foo)
   (setf output-file (if (and output-file-p (not (eql output-file t)))
                         (pathname output-file)
                         (bc-compile-file-pathname input)))
@@ -112,20 +112,15 @@
         (t
          (with-open-file (sout output-file :direction :output :if-exists :supersede
                                :if-does-not-exist :create
-			       :external-format external-format)
+                               :external-format external-format)
-	   (let ((binary (loop
+           (let ((binary
-			    with *package* = *package*
+                  (let ((*package* *package*)
-			    with *readtable* = *readtable*
+                        (*readtable* *readtable*)
-			    with ext:*bytecodes-compiler* = t
+                        (ext:*bytecodes-compiler* t))
-			    for position = (file-position input)
+                    (si::bc-compile-from-stream input))))
-			    for form = (read input nil :EOF)
+             (sys:with-ecl-io-syntax
-			    until (eq form :EOF)
+                 (write binary :stream sout :circle t :escape t :readably t :pretty nil))
-			    do (when ext::*source-location*
+             (terpri sout)))))
-				 (rplacd ext:*source-location* position))
-			    collect (si:eval-with-env form nil nil nil :load-toplevel))))
-	     (sys:with-ecl-io-syntax
-		 (write binary :stream sout :circle t :escape t :readably t :pretty nil))
-	     (terpri sout)))))
   (when load
     (load output-file :verbose *compile-verbose*))
   (values output-file nil nil))

src/c/compiler.d

@@ -19,7 +19,7 @@
 
     takes two words of memory: one for the operator and one for the argument.
     The interpreter is written with this assumption in mind, but it should be
-    easily modifed, because arguments are retrieved with "next_arg" and
+    easily modified, because arguments are retrieved with "next_arg" and
     operators with "next_op".  Parts which will require a careful modification
     are marked with flag [1].
 */
@@ -549,6 +549,9 @@ c_new_env(cl_env_ptr the_env, cl_compiler_env_ptr new, cl_object env,
     new->stepping = 0;
     new->lexical_level = 0;
     new->load_time_forms = ECL_NIL;
+    new->ltf_being_created = ECL_NIL;
+    new->ltf_defer_init_until = ECL_T;
+    new->ltf_locations = ECL_NIL;
     new->env_depth = 0;
     new->macros = CDR(env);
     new->variables = CAR(env);
@@ -568,6 +571,19 @@ c_new_env(cl_env_ptr the_env, cl_compiler_env_ptr new, cl_object env,
   new->env_size = 0;
 }
 
+static void
+c_restore_env(cl_env_ptr the_env, cl_compiler_env_ptr new_c_env, cl_compiler_env_ptr old_c_env)
+{
+  if (new_c_env->env_depth == 0) {
+    /* Clear created constants (they cannot be printed) */
+    loop_for_in(new_c_env->ltf_locations) {
+      cl_index loc = ecl_fixnum(ECL_CONS_CAR(new_c_env->ltf_locations));
+      new_c_env->constants->vector.self.t[loc] = ecl_make_fixnum(0);
+    } end_loop_for_in;
+  }
+  the_env->c_env = old_c_env;
+}
+
 static cl_object
 c_tag_ref(cl_env_ptr env, cl_object the_tag, cl_object the_type)
 {
@@ -2198,17 +2214,39 @@ c_values(cl_env_ptr env, cl_object args, int flags) {
   return FLAG_VALUES;
 }
 
+static void
+defer_load_object(cl_env_ptr env, cl_object place, cl_object created)
+{
+  const cl_compiler_ptr c_env = env->c_env;
+  if (c_env->ltf_defer_init_until == ECL_T) {
+    FEerror("Circular dependency in load time forms involving ~S.", 1, ECL_CONS_CAR(place));
+  }
+  if (c_env->ltf_defer_init_until != ECL_NIL
+      && ecl_member_eq(c_env->ltf_defer_init_until, created)) {
+    /* We are already deferring the init form long enough, nothing to do. */
+    return;
+  }
+  c_env->ltf_defer_init_until = place;
+}
+
 static void
 maybe_make_load_forms(cl_env_ptr env, cl_object constant)
 {
   const cl_compiler_ptr c_env = env->c_env;
-  cl_object init, make;
+  cl_object init, make, created;
-  if (c_env->mode != FLAG_LOAD)
+  if ((c_env->mode != FLAG_LOAD)
-    return;
+      || (si_need_to_make_load_form_p(constant) == ECL_NIL))
-  if (c_search_constant(env, constant) >= 0)
-    return;
-  if (si_need_to_make_load_form_p(constant) == ECL_NIL)
     return;
+  created = c_env->ltf_being_created;
+  /* If we are compiling a creation form for another load time form, defer the
+   * init form until after this creation form has been compiled. */
+  loop_for_in(created) {
+    cl_object place = ECL_CONS_CAR(created);
+    if (ECL_CONS_CAR(place) == constant) {
+      defer_load_object(env, place, created);
+      return;
+    }
+  } end_loop_for_in;
   make = _ecl_funcall2(@'make-load-form', constant);
   init = (env->nvalues > 1)? env->values[1] : ECL_NIL;
   push(cl_list(3, constant, make, init), &c_env->load_time_forms);
@@ -2376,6 +2414,9 @@ eval_nontrivial_form(cl_env_ptr env, cl_object form) {
                                        ECL_NIL, /* displacement */
                                        ECL_NIL);
   new_c_env.load_time_forms = ECL_NIL;
+  new_c_env.ltf_being_created = ECL_NIL;
+  new_c_env.ltf_defer_init_until = ECL_T;
+  new_c_env.ltf_locations = ECL_NIL;
   new_c_env.env_depth = 0;
   new_c_env.env_size = 0;
   env->c_env = &new_c_env;
@@ -2420,72 +2461,113 @@ execute_each_form(cl_env_ptr env, cl_object body)
   return FLAG_VALUES;
 }
 
-static cl_index *
+static cl_object
 save_bytecodes(cl_env_ptr env, cl_index start, cl_index end)
 {
-#ifdef GBC_BOEHM
   cl_index l = end - start;
-  cl_index *bytecodes = ecl_alloc_atomic((l + 1) * sizeof(cl_index));
+  cl_object bytecodes = ecl_alloc_simple_vector(l, ecl_aet_index);
-  cl_index *p = bytecodes;
+  cl_index *p;
-  for (*(p++) = l; end > start; end--, p++) {
+  for (p = bytecodes->vector.self.index; end > start; end--, p++) {
     *p = (cl_index)ECL_STACK_POP_UNSAFE(env);
   }
   return bytecodes;
-#else
-#error "Pointer references outside of recognizable object"
-#endif
 }
 
 static void
-restore_bytecodes(cl_env_ptr env, cl_index *bytecodes)
+restore_bytecodes(cl_env_ptr env, cl_object bytecodes)
 {
-  cl_index *p = bytecodes;
+  cl_index *p = bytecodes->vector.self.index;
   cl_index l;
-  for (l = *p; l; l--) {
+  for (l = bytecodes->vector.dim; l; l--) {
-    ECL_STACK_PUSH(env, (cl_object)p[l]);
+    ECL_STACK_PUSH(env, (cl_object)p[l-1]);
   }
   ecl_dealloc(bytecodes);
 }
 
+static cl_index
+add_load_form(cl_env_ptr env, cl_object object)
+{
+  const cl_compiler_ptr c_env = env->c_env;
+  cl_object constant = pop(&object);
+  cl_object make_form = pop(&object);
+  cl_object init_form = pop(&object);
+  cl_object deferred_init_forms;
+  cl_index loc = c_register_constant(env, constant);
+  {
+    cl_object previous_locs = c_env->ltf_locations;
+    loop_for_in(previous_locs) {
+      if (ecl_fixnum(ECL_CONS_CAR(previous_locs)) == loc) {
+        /* We already compiled this load time form, nothing to do */
+        return loc;
+      }
+    } end_loop_for_in;
+  }
+  /* compile the MAKE-FORM */
+  /* c_env->ltf_being_created holds a list with the constant whose
+   * creation form is being compiled as first element... */
+  push(ecl_list1(constant), &c_env->ltf_being_created);
+  compile_with_load_time_forms(env, make_form, FLAG_REG0);
+  asm_op2(env, OP_CSET, loc);
+  /* ... and bytecodes for init forms which need to be deferred
+   * until the creation form has been evaluated in the following
+   * elements */
+  deferred_init_forms = ECL_CONS_CDR(pop(&c_env->ltf_being_created));
+  /* save the location of the created constant. This also serves as an
+   * indicator that we already compiled the load form for constant and
+   * don't need to do that again if we encouter constant in any other
+   * load time forms. */
+  push(ecl_make_fixnum(loc), &c_env->ltf_locations);
+  /* compile the INIT-FORM ... */
+  if (init_form != ECL_NIL) {
+    cl_index handle_init = current_pc(env);
+    cl_object old_init_until = c_env->ltf_defer_init_until;
+    c_env->ltf_defer_init_until = ECL_NIL;
+    compile_with_load_time_forms(env, init_form, FLAG_IGNORE);
+    /* ... and if it needs to be deferred, add it to c_env->ltf_being_created */
+    if (c_env->ltf_defer_init_until != ECL_NIL
+        && c_env->ltf_defer_init_until != object) {
+      cl_object bytecodes_init = save_bytecodes(env, handle_init, current_pc(env));
+      cl_object l = si_memq(c_env->ltf_defer_init_until, c_env->ltf_being_created);
+      if (l != ECL_NIL) {
+        cl_object constant_and_inits = ECL_CONS_CAR(l);
+        ECL_RPLACD(constant_and_inits,
+                   CONS(bytecodes_init, ECL_CONS_CDR(constant_and_inits)));
+      }
+    }
+    c_env->ltf_defer_init_until = old_init_until;
+  }
+  /* restore bytecodes for deferred init-forms. This comes after
+   * compiling the init form for constant since we are required to
+   * evaluate init forms as soon as possible. */
+  loop_for_in(deferred_init_forms) {
+    restore_bytecodes(env, ECL_CONS_CAR(deferred_init_forms));
+  } end_loop_for_in;
+  return loc;
+}
+
+
+/* First we compile the form as usual. If some constants need to be built,
+ * insert the code _before_ the actual forms; to do that we first save the
+ * bytecodes for the form, and then we compile forms that build constants;
+ * only after that we restore bytecodes of the compiled form. */
 static int
 compile_with_load_time_forms(cl_env_ptr env, cl_object form, int flags)
 {
-  /*
-   * First compile the form as usual.
-   */
   const cl_compiler_ptr c_env = env->c_env;
   cl_index handle = asm_begin(env);
   int output_flags = compile_form(env, form, flags);
-  /*
-   * If some constants need to be built, we insert the
-   * code _before_ the actual forms;
-   */
   if (c_env->load_time_forms != ECL_NIL) {
-    cl_index *bytecodes = save_bytecodes(env, handle, current_pc(env));
+    /* load_time_forms are collected in a reverse order, so we need to reverse
-    /* reverse the load time forms list to make sure the forms are
+       the list. Forms should not be compiled as top-level forms - to ensure
-     * compiled in the right order */
+       that we increment the lexical_level. */
-    cl_object p, forms_list = cl_nreverse(c_env->load_time_forms);
+    cl_object bytecodes = save_bytecodes(env, handle, current_pc(env));
+    cl_object p = cl_nreverse(c_env->load_time_forms);
     c_env->load_time_forms = ECL_NIL;
-    p = forms_list;
+    c_env->lexical_level++;
-    do {
+    loop_for_in(p) {
-      cl_object r = ECL_CONS_CAR(p);
+      add_load_form(env, ECL_CONS_CAR(p));
-      cl_object constant = pop(&r);
+    } end_loop_for_in;
-      cl_object make_form = pop(&r);
+    c_env->lexical_level--;
-      cl_object init_form = pop(&r);
-      cl_index loc = c_register_constant(env, constant);
-      compile_with_load_time_forms(env, make_form, FLAG_REG0);
-      asm_op2(env, OP_CSET, loc);
-      compile_with_load_time_forms(env, init_form, FLAG_IGNORE);
-      ECL_RPLACA(p, ecl_make_fixnum(loc));
-      p = ECL_CONS_CDR(p);
-    } while (p != ECL_NIL);
-    p = forms_list;
-    do {
-      cl_index loc = ecl_fixnum(ECL_CONS_CAR(p));
-      /* Clear created constants (they cannot be printed) */
-      c_env->constants->vector.self.t[loc] = ecl_make_fixnum(0);
-      p = ECL_CONS_CDR(p);
-    } while (p != ECL_NIL);
     restore_bytecodes(env, bytecodes);
   }
   return output_flags;
@@ -2704,7 +2786,7 @@ si_need_to_make_load_form_p(cl_object object)
     push(ECL_CONS_CDR(object), &waiting_objects);
     goto loop;
   case t_bclosure: {
-    cl_object bc = object->bclosure.code;;
+    cl_object bc = object->bclosure.code;
     push(object->bclosure.lex, &waiting_objects);
     push(bc->bytecodes.data, &waiting_objects);
     push(bc->bytecodes.name, &waiting_objects);
@@ -3143,7 +3225,7 @@ ecl_make_lambda(cl_env_ptr env, cl_object name, cl_object lambda) {
   output->bytecodes.name = name;
 
   old_c_env->load_time_forms = env->c_env->load_time_forms;
-  env->c_env = old_c_env;
+  c_restore_env(env, &new_c_env, old_c_env);
 
   ecl_bds_unwind1(env);
 
@@ -3187,21 +3269,57 @@ si_make_lambda(cl_object name, cl_object rest)
 {
   cl_object lambda;
   const cl_env_ptr the_env = ecl_process_env();
-  volatile cl_compiler_env_ptr old_c_env = the_env->c_env;
+  cl_compiler_env_ptr old_c_env = the_env->c_env;
   struct cl_compiler_env new_c_env;
 
   c_new_env(the_env, &new_c_env, ECL_NIL, 0);
   ECL_UNWIND_PROTECT_BEGIN(the_env) {
     lambda = ecl_make_lambda(the_env, name, rest);
   } ECL_UNWIND_PROTECT_EXIT {
-    the_env->c_env = old_c_env;
+    c_restore_env(the_env, &new_c_env, old_c_env);
   } ECL_UNWIND_PROTECT_END;
   @(return lambda);
 }
 
+cl_object
+si_bc_compile_from_stream(cl_object input)
+{
+  /* Compile all forms read from input stream to bytecodes */
+  cl_env_ptr the_env = ecl_process_env();
+  cl_compiler_env_ptr old_c_env;
+  struct cl_compiler_env new_c_env;
+  cl_object bytecodes = ECL_NIL;
+  old_c_env = the_env->c_env;
+  c_new_env(the_env, &new_c_env, ECL_NIL, 0);
+  new_c_env.mode = FLAG_LOAD;
+
+  ECL_UNWIND_PROTECT_BEGIN(the_env) {
+    while (TRUE) {
+      cl_object position, form, source_location;
+      cl_index handle;
+      position = ecl_file_position(input);
+      form = cl_read(3, input, ECL_NIL, @':eof');
+      if (form == @':eof')
+        break;
+      source_location = ECL_SYM_VAL(the_env, @'ext::*source-location*');
+      if (source_location != ECL_NIL)
+        cl_rplacd(source_location, position);
+
+      handle = asm_begin(the_env);
+      compile_with_load_time_forms(the_env, form, FLAG_VALUES);
+      asm_op(the_env, OP_EXIT);
+      push(asm_end(the_env, handle, form), &bytecodes);
+    }
+  } ECL_UNWIND_PROTECT_EXIT {
+    c_restore_env(the_env, &new_c_env, old_c_env);
+  } ECL_UNWIND_PROTECT_END;
+
+  return cl_nreverse(bytecodes);
+}
+
 @(defun si::eval-with-env (form &optional (env ECL_NIL) (stepping ECL_NIL)
                            (compiler_env_p ECL_NIL) (mode @':execute'))
-  volatile cl_compiler_env_ptr old_c_env;
+  cl_compiler_env_ptr old_c_env;
   struct cl_compiler_env new_c_env;
   cl_object interpreter_env, compiler_env;
 @
@@ -3246,9 +3364,7 @@ si_make_lambda(cl_object name, cl_object rest)
       the_env->nvalues = 1;
     }
   } ECL_UNWIND_PROTECT_EXIT {
-    /* Clear up */
+    c_restore_env(the_env, &new_c_env, old_c_env);
-    the_env->c_env = old_c_env;
-    memset(&new_c_env, 0, sizeof(new_c_env));
   } ECL_UNWIND_PROTECT_END;
   return the_env->values[0];
 @)

src/c/symbols_list.h

@@ -1154,6 +1154,7 @@ cl_symbols[] = {
 {SYS_ "ASET" ECL_FUN("si_aset", si_aset, -2) ECL_VAR(SI_ORDINARY, OBJNULL)},
 {SYS_ "BASE-CHAR-P" ECL_FUN("si_base_char_p", si_base_char_p, 1) ECL_VAR(SI_ORDINARY, OBJNULL)},
 {SYS_ "BASE-STRING-P" ECL_FUN("si_base_string_p", si_base_string_p, 1) ECL_VAR(SI_ORDINARY, OBJNULL)},
+{SYS_ "BC-COMPILE-FROM-STREAM" ECL_FUN("si_bc_compile_from_stream", si_bc_compile_from_stream, 1) ECL_VAR(SI_ORDINARY, OBJNULL)},
 {SYS_ "BC-DISASSEMBLE" ECL_FUN("si_bc_disassemble", si_bc_disassemble, 1) ECL_VAR(SI_ORDINARY, OBJNULL)},
 {SYS_ "BC-SPLIT" ECL_FUN("si_bc_split", si_bc_split, 1) ECL_VAR(SI_ORDINARY, OBJNULL)},
 {SYS_ "BC-JOIN" ECL_FUN("si_bc_join", si_bc_join, 4) ECL_VAR(SI_ORDINARY, OBJNULL)},

src/doc/manual/standards/arrays.txi

@@ -114,7 +114,7 @@ Creating array and vectors
 @cppdef ecl_alloc_simple_vector
 @cppdef si_make_vector
 @cppdef si_make_array
-@deftypefun cl_object ecl_alloc_simple_vector (cl_elttype element_type, cl_index length);
+@deftypefun cl_object ecl_alloc_simple_vector (cl_index length, cl_elttype element_type);
 @deftypefunx cl_object si_make_vector (cl_object element_type, cl_object length, cl_object adjustablep, cl_object fill_pointerp, cl_object displaced_to, cl_object displacement);
 @deftypefunx cl_object si_make_array (cl_object element_type, cl_object dimensions, cl_object adjustablep, cl_object fill_pointerp, cl_object displaced_to, cl_object displacement);
 
@@ -136,7 +136,7 @@ Finally, the function @coderef{si_make_array} does a similar job to @coderef{si_
 Create one-dimensional @code{base-string} with room for 11 characters:
 
 @example
-cl_object s = ecl_alloc_simple_vector(ecl_aet_bc, 11);
+cl_object s = ecl_alloc_simple_vector(11, ecl_aet_bc);
 @end example
 
 Create a one-dimensional @code{array} with a fill pointer

src/h/external.h

@@ -531,6 +531,8 @@ extern ECL_API cl_object si_function_block_name(cl_object name);
 extern ECL_API cl_object si_valid_function_name_p(cl_object name);
 extern ECL_API cl_object si_process_declarations _ECL_ARGS((cl_narg narg, cl_object body, ...));
 
+extern ECL_API cl_object si_bc_compile_from_stream (cl_object input);
+
 extern ECL_API cl_object si_eval_with_env _ECL_ARGS((cl_narg narg, cl_object form, ...));
 
 /* interpreter.c */

src/h/internal.h

@@ -113,6 +113,12 @@ struct cl_compiler_env {
         cl_fixnum lexical_level;        /* =0 if toplevel form */
         cl_object constants;            /* Constants for this form */
         cl_object load_time_forms;      /* Constants that have to be rebuilt */
+        cl_object ltf_being_created;    /* Load time objects being compiled */
+        cl_object ltf_defer_init_until; /* Defer evaluation of current
+                                         * load time init form until
+                                         * this object has been created */
+        cl_object ltf_locations;        /* Locations of constants externalized
+                                         * with make-load-form */
         cl_object lex_env;              /* Lexical env. for eval-when */
         cl_object code_walker;          /* Value of SI:*CODE-WALKER* */
         cl_index env_depth;

src/tests/config.lsp.in

@@ -87,19 +87,23 @@
        (progn
          (ext:chdir *sandbox*)
          (ext:setenv "TEST_IMAGE" *test-image*)
-         (ext:run-program *test-image*
+         (ext:run-program
-                          `("-norc"
+          *test-image*
-                            "-eval" "(print (ext:getenv \"ECLDIR\"))"
+          `("-norc"
-                            "-eval" "(ignore-errors (require :cmp))"
+            "-eval" "(print (ext:getenv \"ECLDIR\"))"
-                            "-load" ,(namestring
+            "-eval" "(ext:install-bytecodes-compiler)"
-                                      (merge-pathnames
+            "-eval" ,(if (ext:getenv "BYTECMP")
-                                       "tests/doit.lsp" *ecl-sources*))
+                         "t"
-                            "-eval" "(in-package cl-test)"
+                         "(ignore-errors (ext:install-c-compiler))")
-                            "-eval" ,(format nil "(2am-ecl:run '~a)" suites)
+            "-load" ,(namestring
-                            "-eval" "(ext:exit)")
+                      (merge-pathnames
-                          :input nil
+                       "tests/doit.lsp" *ecl-sources*))
-                          :output t
+            "-eval" "(in-package cl-test)"
-                          :error :output))
+            "-eval" ,(format nil "(2am-ecl:run '~a)" suites)
+            "-eval" "(ext:exit)")
+          :input nil
+          :output t
+          :error :output))
     (ext:chdir *here*)
     #+ (or)
     (format t "~%Known fails: ~%~{~a~%~}~%"

src/tests/normal-tests/compiler.lsp

@@ -739,16 +739,16 @@
       (with-compiler ("make-load-form.lsp")
         "(in-package cl-test)"
         "(eval-when (:compile-toplevel)
-      (defparameter s4.0030 (make-instance 'compiler-test-class))
+           (defparameter s4.0030 (make-instance 'compiler-test-class))
-      (defparameter s5.0030 (make-instance 'compiler-test-class))
+           (defparameter s5.0030 (make-instance 'compiler-test-class))
-      (setf (compiler-test-parent s5.0030) s4.0030)
+           (setf (compiler-test-parent s5.0030) s4.0030)
-      (setf (compiler-test-children s4.0030) (list s5.0030)))"
+           (setf (compiler-test-children s4.0030) (list s5.0030)))"
         "(defparameter a.0030 '#.s5.0030)"
         "(defparameter b.0030 '#.s4.0030)"
         "(defparameter c.0030 '#.s5.0030)"
         "(defun foo.0030 ()
-       (let ((*print-circle* t))
+           (let ((*print-circle* t))
-         (with-output-to-string (s) (princ '#1=(1 2 3 #.s4.0030 #1#) s))))")
+             (with-output-to-string (s) (princ '#1=(1 2 3 #.s4.0030 #1#) s))))")
     (declare (ignore output))
     (load file)
     (delete-file "make-load-form.lsp")
@@ -757,7 +757,8 @@
     (is (and (search "#1=(1 2 3 #<a CL-TEST::COMPILER-TEST-CLASS" str)
              (search "> #1#)" str))))
   (is (eq (compiler-test-parent a.0030) b.0030))
-  (is (eq (first (compiler-test-children b.0030)) a.0030)))
+  (is (eq (first (compiler-test-children b.0030)) a.0030))
+  (is (eq a.0030 c.0030)))
 
 ;;; Date: 9/06/2006 (Pascal Costanza)
 ;;; Fixed: 13/06/2006 (juanjo)
@@ -1707,14 +1708,16 @@
 ;;; URL: https://gitlab.com/embeddable-common-lisp/ecl/-/issues/565
 ;;; Description
 ;;;
-;;;     COMPILE-FILE produces two vectors VV and VVtemp which
+;;;     This test checks whether the same constant is coalesced to the EQ
-;;;     represent the fasl data segment. The latter is deallocated
+;;;     value among three distinct top-level forms.
-;;;     after all top-level forms are evaluated. As compiler processes
+;;;
-;;;     them currently if the object is first pushed to the temporary
+;;;     ccmp's COMPILE-FILE produces two vectors VV and VVtemp which represent
-;;;     segment and then we try to add it to the permanent segment we
+;;;     the fasl data segment. The latter is deallocated after all top-level
-;;;     have two versions of the same objects which are not EQ. File
+;;;     forms are evaluated. As compiler processes them currently if the
-;;;     src/cmp/cmpwt.lsp has an appropriate FIXME in the ADD-OBJECT
+;;;     object is first pushed to the temporary segment and then we try to add
-;;;     function definition.
+;;;     it to the permanent segment we have two versions of the same objects
+;;;     which are not EQ. File src/cmp/cmpwt.lsp has an appropriate FIXME in
+;;;     the ADD-OBJECT function definition.
 (test cmp.0076.make-load-form-non-eq
   (multiple-value-bind (file output)
       (with-compiler ("make-temp.lsp")
@@ -1745,8 +1748,6 @@
     (delete-file file))
   (multiple-value-bind (x a b) (foo)
     (is (eq x a) "~a is not eq to ~a" x a)
-    ;; This test passes because B toplevel form is compiled after the
-    ;; function FOO. Included here for completness.
     (is (eq x b) "~a is not eq to ~a" x b)
     (is (eq a b) "~a is not eq to ~a" a b)))