From 4e1847f77587cbcd312b695ae6f0ef19b51ab055 Mon Sep 17 00:00:00 2001 From: Marius Gerbershagen Date: Fri, 14 Aug 2020 17:26:56 +0200 Subject: [PATCH] clos: don't call make-load-form in the code walker for defmethod Fixes #594. --- contrib/bytecmp/bytecmp.lsp | 8 ++++---- src/c/compiler.d | 22 ++++++++++++++++------ src/clos/method.lsp | 6 +++--- src/cmp/cmputil.lsp | 2 +- 4 files changed, 24 insertions(+), 14 deletions(-) diff --git a/contrib/bytecmp/bytecmp.lsp b/contrib/bytecmp/bytecmp.lsp index 1a233b4d5..1f55ff13e 100755 --- a/contrib/bytecmp/bytecmp.lsp +++ b/contrib/bytecmp/bytecmp.lsp @@ -49,14 +49,14 @@ (warn "COMPILE can not compile C closures") (return-from bc-compile (values definition t nil))) (lexenv (setf definition (si:eval-with-env form lexenv))) - (t (setf definition (si:eval-with-env form nil nil nil t)))))) + (t (setf definition (si:eval-with-env form nil nil nil :execute)))))) (when name (setf (fdefinition name) definition)) (return-from bc-compile (values (or name definition) nil nil))) ((not (null definition)) (unless (member (car definition) '(LAMBDA EXT:LAMBDA-BLOCK)) (format t "~&;;; Error: Not a valid lambda expression: ~s." definition) (return-from bc-compile (values nil t t))) - (setq definition (si:eval-with-env definition nil nil nil t)) + (setq definition (si:eval-with-env definition nil nil nil :execute)) (when name (setf (fdefinition name) definition)) (return-from bc-compile (values (or name definition) nil nil))) ((not (fboundp name)) @@ -72,7 +72,7 @@ (warn "The bytecodes compiler can not compile C closures") (return-from bc-compile (values definition t nil))) (lexenv (setf definition (si:eval-with-env form lexenv))) - (t (setf definition (si:eval-with-env form nil nil nil t)))))) + (t (setf definition (si:eval-with-env form nil nil nil :execute)))))) (when (null definition) (warn "We have lost the original function definition for ~s." name) (return-from bc-compile (values name t nil))) @@ -122,7 +122,7 @@ until (eq form :EOF) do (when ext::*source-location* (rplacd ext:*source-location* position)) - collect (si:eval-with-env form nil nil nil nil)))) + 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))))) diff --git a/src/c/compiler.d b/src/c/compiler.d index a4d028062..8d731e790 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -1630,7 +1630,7 @@ c_load_time_value(cl_env_ptr env, cl_object args, int flags) unlikely_if (Null(args) || cl_cddr(args) != ECL_NIL) FEprogram_error("LOAD-TIME-VALUE: Wrong number of arguments.", 0); value = ECL_CONS_CAR(args); - if (c_env->mode != FLAG_LOAD) { + if (c_env->mode == FLAG_EXECUTE) { value = si_eval_with_env(1, value); } else if (ECL_SYMBOLP(value) || ECL_LISTP(value)) { /* Using the form as constant, we force the system to coalesce multiple @@ -3200,14 +3200,24 @@ si_make_lambda(cl_object name, cl_object rest) } @(defun si::eval-with-env (form &optional (env ECL_NIL) (stepping ECL_NIL) - (compiler_env_p ECL_NIL) (execute ECL_T)) + (compiler_env_p ECL_NIL) (mode @':execute')) volatile cl_compiler_env_ptr old_c_env; struct cl_compiler_env new_c_env; cl_object interpreter_env, compiler_env; @ /* * Compile to bytecodes. + * Parameter mode is interpreted as follows: + * - execute: Execute the compiled form + * - load-toplevel: Compile the form without executing. Calls + * make-load-form for literal objects encountered during + * compilation. + * - compile-toplevel: Compile the form without executing, do not + * call make-load-form. Useful for code walking. */ + if (!(mode == @':execute' || mode == @':load-toplevel' || mode == @':compile-toplevel')) { + FEerror("Invalid mode in SI:EVAL-WITH-ENV", 0); + } if (compiler_env_p == ECL_NIL) { interpreter_env = env; compiler_env = ECL_NIL; @@ -3225,15 +3235,15 @@ si_make_lambda(cl_object name, cl_object rest) } new_c_env.stepping = stepping != ECL_NIL; ECL_UNWIND_PROTECT_BEGIN(the_env) { - if (Null(execute)) { + if (mode == @':execute') { + eval_form(the_env, form); + } else { cl_index handle = asm_begin(the_env); - new_c_env.mode = FLAG_LOAD; + new_c_env.mode = (mode == @':load-toplevel') ? FLAG_LOAD : FLAG_COMPILE; compile_with_load_time_forms(the_env, form, FLAG_VALUES); asm_op(the_env, OP_EXIT); the_env->values[0] = asm_end(the_env, handle, form); the_env->nvalues = 1; - } else { - eval_form(the_env, form); } } ECL_UNWIND_PROTECT_EXIT { /* Clear up */ diff --git a/src/clos/method.lsp b/src/clos/method.lsp index 2866e0a83..49647a8bc 100644 --- a/src/clos/method.lsp +++ b/src/clos/method.lsp @@ -252,9 +252,9 @@ (let ((si::*code-walker* #'code-walker)) ;; Instead of (coerce method-lambda 'function) we use ;; explicitely the bytecodes compiler with an environment, no - ;; stepping, compiler-env-p = t and execute = nil, so that the - ;; form does not get executed. - (si::eval-with-env method-lambda env nil t nil))) + ;; stepping, compiler-env-p = t and mode = :compile-toplevel, + ;; so that the form does not get executed. + (si::eval-with-env method-lambda env nil t :compile-toplevel))) (values call-next-method-p next-method-p-p in-closure-p))) diff --git a/src/cmp/cmputil.lsp b/src/cmp/cmputil.lsp index 03386388a..e9f9d4553 100644 --- a/src/cmp/cmputil.lsp +++ b/src/cmp/cmputil.lsp @@ -357,7 +357,7 @@ (when throw-flag ,error-form)))) (defun cmp-eval (form &optional (env *cmp-env*)) - (handler-case (si::eval-with-env form env nil t t) + (handler-case (si::eval-with-env form env nil t :execute) (serious-condition (c) (when *compiler-break-enable* (invoke-debugger c))