From fd183e575f19d88f50564ecc7ad005932709aa8e Mon Sep 17 00:00:00 2001 From: Daniel Kochmanski Date: Tue, 13 Feb 2018 12:43:32 +0100 Subject: [PATCH] Better error messages, bc-compile improvements bc-compile is more conforming now (we validate definition and name, also our closure compilation is a bit better, still broken though). Also improve some error messages and add periods at the end. --- contrib/bytecmp/bytecmp.lsp | 68 ++++++++++++++++++++++--------------- src/c/compiler.d | 6 ++-- src/c/error.d | 2 +- src/c/interpreter.d | 2 +- 4 files changed, 45 insertions(+), 33 deletions(-) diff --git a/contrib/bytecmp/bytecmp.lsp b/contrib/bytecmp/bytecmp.lsp index cc268092b..4e51aaa7d 100755 --- a/contrib/bytecmp/bytecmp.lsp +++ b/contrib/bytecmp/bytecmp.lsp @@ -35,31 +35,44 @@ (error 'simple-type-error :datum thing :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)))) nil) -(defun bc-compile (name &optional (def nil supplied-p) &aux form) - (cond ((and supplied-p def) - (when (functionp def) - (unless (function-lambda-expression def) - (return-from bc-compile (values def nil nil))) - (setf def (function-lambda-expression def))) - (setq form (if name - `(progn (setf (symbol-function ',name) #',def) ',name) - `(setq GAZONK #',def)))) - ((not (fboundp name)) - (error "Symbol ~s is unbound." name)) - ((typep (setf def (symbol-function name)) 'standard-generic-function) - (warn "COMPILE can not compile generic functions yet") - (return-from bc-compile (values def t nil))) - ((null (setq form (function-lambda-expression def))) - (warn "We have lost the original function definition for ~s. Compilation failed" - name) - (return-from bc-compile (values def t nil))) - (t - (setq form `(progn (setf (symbol-function ',name) #',form) ',name)))) - (values (eval form) nil nil)) +(defun bc-compile (name &optional (definition nil def-p) &aux (*print-pretty* nil)) + (check-type name (or (satisfies si:valid-function-name-p) nil)) + (when def-p (check-type definition (or function cons))) + (cond ((functionp definition) + (multiple-value-bind (form lexenv) (function-lambda-expression definition) + (when form + (if lexenv + (setf definition (si:eval-with-env form lexenv)) + (setf definition (si:eval-with-env form nil nil nil t))))) + (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)) + (when name (setf (fdefinition name) definition)) + (return-from bc-compile (values (or name definition) nil nil))) + ((not (fboundp name)) + (error "Function name ~s is unbound." name)) + ((typep (fdefinition name) 'standard-generic-function) + (warn "COMPILE can not compile generic functions yet.") + (return-from bc-compile (values name t nil))) + (T + (multiple-value-bind (form lexenv) + (function-lambda-expression (fdefinition name)) + (when form + (if lexenv + (setf definition (si:eval-with-env form lexenv)) + (setf definition (si:eval-with-env form nil nil nil t))))) + (when (null definition) + (warn "We have lost the original function definition for ~s." name) + (return-from bc-compile (values name t nil))) + (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 @@ -83,7 +96,7 @@ (pathname output-file) (bc-compile-file-pathname input))) (when *compile-verbose* - (format t "~&;;; Compiling ~A" input)) + (format t "~&;;; Compiling ~A." input)) (cond ((not (streamp input)) (let* ((ext:*source-location* (cons (truename input) 0)) (*compile-file-pathname* (pathname (merge-pathnames input))) @@ -129,11 +142,10 @@ #-ecl-min (progn -#+(and dlopen (not windows)) -(sys::autoload "SYS:cmp" 'compile-file 'compile 'compile-file-pathname 'disassemble) -#-(and dlopen (not windows)) -(install-bytecodes-compiler) -) + #+(and dlopen (not windows)) + (sys::autoload "SYS:cmp" 'compile-file 'compile 'compile-file-pathname 'disassemble) + #-(and dlopen (not windows)) + (install-bytecodes-compiler)) (provide '#:BYTECMP) diff --git a/src/c/compiler.d b/src/c/compiler.d index ceeb79bb1..327138d44 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -967,12 +967,12 @@ c_funcall(cl_env_ptr env, cl_object args, int flags) { cl_object kind = ECL_CONS_CAR(name); if (kind == @'function') { if (cl_list_length(name) != ecl_make_fixnum(2)) - FEprogram_error("FUNCALL: Invalid function name ~S", 1, name); + FEprogram_error("FUNCALL: Invalid function name ~S.", 1, name); return c_call(env, CONS(CADR(name), args), flags); } if (kind == @'quote') { if (cl_list_length(name) != ecl_make_fixnum(2)) - FEprogram_error("FUNCALL: Invalid function name ~S", 1, name); + FEprogram_error("FUNCALL: Invalid function name ~S.", 1, name); return c_call(env, CONS(CADR(name), args), flags | FLAG_GLOBAL); } } @@ -2971,7 +2971,7 @@ ecl_make_lambda(cl_env_ptr env, cl_object name, cl_object lambda) { /* Transform (SETF fname) => fname */ if (!Null(name) && Null(si_valid_function_name_p(name))) - FEprogram_error("LAMBDA: Not a valid function name ~S",1,name); + FEprogram_error("LAMBDA: Not a valid function name ~S.",1,name); /* We register as special variable a symbol which is not * to be used. We use this to mark the boundary of a function diff --git a/src/c/error.d b/src/c/error.d index bbd5e7322..d0dc16881 100644 --- a/src/c/error.d +++ b/src/c/error.d @@ -436,7 +436,7 @@ void FEinvalid_function_name(cl_object fname) { cl_error(9, @'simple-type-error', @':format-control', - make_constant_base_string("Not a valid function name ~D"), + make_constant_base_string("Not a valid function name ~D."), @':format-arguments', cl_list(1, fname), @':expected-type', cl_list(2, @'satisfies', @'si::valid-function-name-p'), @':datum', fname); diff --git a/src/c/interpreter.d b/src/c/interpreter.d index aef65a296..ed707d6ef 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -209,7 +209,7 @@ close_around(cl_object fun, cl_object lex) { cl_object v; if (Null(lex)) return fun; if (ecl_t_of(fun) != t_bytecodes) - FEerror("!!!", 0); + FEerror("Internal error: close_around should be called on t_bytecodes.", 0); v = ecl_alloc_object(t_bclosure); v->bclosure.code = fun; v->bclosure.lex = lex;