diff --git a/CHANGELOG b/CHANGELOG index 70cf4ca4..f6795b93 100644 --- a/CHANGELOG +++ b/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 diff --git a/contrib/bytecmp/bytecmp.lsp b/contrib/bytecmp/bytecmp.lsp index 1f55ff13..86bebbae 100755 --- a/contrib/bytecmp/bytecmp.lsp +++ b/contrib/bytecmp/bytecmp.lsp @@ -26,17 +26,17 @@ (when (si::valid-function-name-p thing) (setq thing (fdefinition thing))) (cond ((null thing)) - ((functionp thing) - (si::bc-disassemble thing)) - ((and (consp thing) + ((functionp thing) + (si::bc-disassemble thing)) + ((and (consp thing) (member (car thing) '(LAMBDA 'EXT:LAMBDA-BLOCK))) - (disassemble (compile nil thing))) - (t - (error 'simple-type-error - :datum thing - :expected-type '(OR FUNCTION (SATISFIES SI:VALID-FUNCTION-NAME-P)) - :format-control "DISASSEMBLE cannot accept ~A." - :format-arguments (list thing)))) + (disassemble (compile nil thing))) + (t + (error 'simple-type-error + :datum thing + :expected-type '(OR FUNCTION (SATISFIES SI:VALID-FUNCTION-NAME-P)) + :format-control "DISASSEMBLE cannot accept ~A." + :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 - shared-data-file system-p load external-format) + verbose print c-file h-file data-file + 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 - ((:verbose *compile-verbose*) *compile-verbose*) - ((:print *compile-print*) *compile-print*) - (load nil) - (external-format :default) - (output-file nil output-file-p) - &allow-other-keys &aux foo) + &key + ((:verbose *compile-verbose*) *compile-verbose*) + ((:print *compile-print*) *compile-print*) + (load nil) + (external-format :default) + (output-file nil output-file-p) + &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) - (let ((binary (loop - with *package* = *package* - with *readtable* = *readtable* - with ext:*bytecodes-compiler* = t - for position = (file-position input) - for form = (read input nil :EOF) - until (eq form :EOF) - do (when ext::*source-location* - (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))))) + :external-format external-format) + (let ((binary + (let ((*package* *package*) + (*readtable* *readtable*) + (ext:*bytecodes-compiler* t)) + (si::bc-compile-from-stream input)))) + (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)) diff --git a/src/c/compiler.d b/src/c/compiler.d index 8d731e79..c68fead4 100644 --- a/src/c/compiler.d +++ b/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; - if (c_env->mode != FLAG_LOAD) - return; - if (c_search_constant(env, constant) >= 0) - return; - if (si_need_to_make_load_form_p(constant) == ECL_NIL) + cl_object init, make, created; + if ((c_env->mode != FLAG_LOAD) + || (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_index *p = bytecodes; - for (*(p++) = l; end > start; end--, p++) { + cl_object bytecodes = ecl_alloc_simple_vector(l, ecl_aet_index); + cl_index *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--) { - ECL_STACK_PUSH(env, (cl_object)p[l]); + for (l = bytecodes->vector.dim; l; 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)); - /* reverse the load time forms list to make sure the forms are - * compiled in the right order */ - cl_object p, forms_list = cl_nreverse(c_env->load_time_forms); + /* load_time_forms are collected in a reverse order, so we need to reverse + the list. Forms should not be compiled as top-level forms - to ensure + that we increment the lexical_level. */ + 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; - do { - cl_object r = ECL_CONS_CAR(p); - cl_object constant = pop(&r); - cl_object make_form = pop(&r); - 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); + c_env->lexical_level++; + loop_for_in(p) { + add_load_form(env, ECL_CONS_CAR(p)); + } end_loop_for_in; + c_env->lexical_level--; 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 */ - the_env->c_env = old_c_env; - memset(&new_c_env, 0, sizeof(new_c_env)); + c_restore_env(the_env, &new_c_env, old_c_env); } ECL_UNWIND_PROTECT_END; return the_env->values[0]; @) diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index e714b705..4666ba63 100755 --- a/src/c/symbols_list.h +++ b/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)}, diff --git a/src/doc/manual/standards/arrays.txi b/src/doc/manual/standards/arrays.txi index e158b5ba..184ce0e0 100644 --- a/src/doc/manual/standards/arrays.txi +++ b/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 diff --git a/src/h/external.h b/src/h/external.h index 3392fd57..33aba4ba 100755 --- a/src/h/external.h +++ b/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 */ diff --git a/src/h/internal.h b/src/h/internal.h index 4019dacc..19a47486 100755 --- a/src/h/internal.h +++ b/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; diff --git a/src/tests/config.lsp.in b/src/tests/config.lsp.in index 13b6b571..6d5e91c5 100755 --- a/src/tests/config.lsp.in +++ b/src/tests/config.lsp.in @@ -87,19 +87,23 @@ (progn (ext:chdir *sandbox*) (ext:setenv "TEST_IMAGE" *test-image*) - (ext:run-program *test-image* - `("-norc" - "-eval" "(print (ext:getenv \"ECLDIR\"))" - "-eval" "(ignore-errors (require :cmp))" - "-load" ,(namestring - (merge-pathnames - "tests/doit.lsp" *ecl-sources*)) - "-eval" "(in-package cl-test)" - "-eval" ,(format nil "(2am-ecl:run '~a)" suites) - "-eval" "(ext:exit)") - :input nil - :output t - :error :output)) + (ext:run-program + *test-image* + `("-norc" + "-eval" "(print (ext:getenv \"ECLDIR\"))" + "-eval" "(ext:install-bytecodes-compiler)" + "-eval" ,(if (ext:getenv "BYTECMP") + "t" + "(ignore-errors (ext:install-c-compiler))") + "-load" ,(namestring + (merge-pathnames + "tests/doit.lsp" *ecl-sources*)) + "-eval" "(in-package cl-test)" + "-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~%~}~%" diff --git a/src/tests/normal-tests/compiler.lsp b/src/tests/normal-tests/compiler.lsp index aafc150f..500253e1 100644 --- a/src/tests/normal-tests/compiler.lsp +++ b/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 s5.0030 (make-instance 'compiler-test-class)) - (setf (compiler-test-parent s5.0030) s4.0030) - (setf (compiler-test-children s4.0030) (list s5.0030)))" + (defparameter s4.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-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)) - (with-output-to-string (s) (princ '#1=(1 2 3 #.s4.0030 #1#) s))))") + (let ((*print-circle* t)) + (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 # #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 -;;; represent the fasl data segment. The latter is deallocated -;;; after all top-level forms are evaluated. As compiler processes -;;; them currently if the object is first pushed to the temporary -;;; segment and then we try to add 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. +;;; This test checks whether the same constant is coalesced to the EQ +;;; value among three distinct top-level forms. +;;; +;;; ccmp's COMPILE-FILE produces two vectors VV and VVtemp which represent +;;; the fasl data segment. The latter is deallocated after all top-level +;;; forms are evaluated. As compiler processes them currently if the +;;; object is first pushed to the temporary segment and then we try to add +;;; 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)))