From e418eeb8e77226ae28aa4311a013d8afccac3987 Mon Sep 17 00:00:00 2001 From: jgarcia Date: Thu, 22 May 2008 11:15:58 +0000 Subject: [PATCH] Improved presentation of interpreted forms in the backtraces. These forms can now be inspected. --- src/CHANGELOG | 22 ++++++++++++++++++++++ src/c/cfun.d | 2 +- src/c/compiler.d | 3 ++- src/c/disassembler.d | 5 ++++- src/c/symbols_list.h | 2 ++ src/c/symbols_list2.h | 2 ++ src/lsp/config.lsp.in | 2 +- src/lsp/top.lsp | 21 ++++++++++++++++++++- 8 files changed, 54 insertions(+), 5 deletions(-) diff --git a/src/CHANGELOG b/src/CHANGELOG index cdd8320ad..1497e39b9 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -113,6 +113,28 @@ ECL 0.9k: macroexpanding a form, this error is printed out and COMPILE-FILE returns (VALUES NIL T T). Formerly this error would be ignored. + - Interpreted forms now appear as SI:BYTECODES in the backtrace. It is + possible to inspect these forms using :lambda-expression + > (cos 'a) + In function COS, the value of argument is + A + which is not of expected type NUMBER + Broken at SI:BYTECODES.Available restarts: + 1. (USE-VALUE) Supply a new value of type NUMBER. + Broken at SI:BYTECODES. + >> :b + Backtrace: SI:BYTECODES > si:bytecodes + >> :disassemble + Evaluated form: + 0 PUSH 'A + 2 CALLG 1,COS + 5 EXIT + >> :lambda-expression + (COS 'A) + Similarly, :lambda-expression also works for other functions that keep + this information. + + * CLOS: - When caching generic function calls, ECL now uses a thread-local hash table diff --git a/src/c/cfun.d b/src/c/cfun.d index b4f678c05..498a42a6c 100644 --- a/src/c/cfun.d +++ b/src/c/cfun.d @@ -114,7 +114,7 @@ cl_function_lambda_expression(cl_object fun) output = Cnil; else if (name == Cnil) output = cl_cons(@'lambda', output); - else + else if (name != @'si::bytecodes') output = @list*(3, @'ext::lambda-block', name, output); break; case t_cfun: diff --git a/src/c/compiler.d b/src/c/compiler.d index 6f5cfd167..bcf191fa3 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -2568,7 +2568,8 @@ si_make_lambda(cl_object name, cl_object rest) compile_form(form, FLAG_VALUES); asm_op(OP_EXIT); bytecodes = asm_end(handle); - bytecodes->bytecodes.name = @'eval'; + bytecodes->bytecodes.name = @'si::bytecodes'; + bytecodes->bytecodes.definition = form; } CL_UNWIND_PROTECT_EXIT { /* Clear up */ ENV = old_c_env; diff --git a/src/c/disassembler.d b/src/c/disassembler.d index 5fbb9a0eb..03380f7b2 100644 --- a/src/c/disassembler.d +++ b/src/c/disassembler.d @@ -69,8 +69,11 @@ disassemble_lambda(cl_object bytecodes) { bds_bind(@'*print-pretty*', Cnil); - if (bytecodes->bytecodes.name == OBJNULL) + if (bytecodes->bytecodes.name == OBJNULL || + bytecodes->bytecodes.name == @'si::bytecodes') { + print_noarg("\nEvaluated form:"); goto NO_ARGS; + } /* Name of LAMBDA */ print_arg("\nName:\t\t", bytecodes->bytecodes.name); diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 739cad663..a4c66a8f9 100644 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1697,5 +1697,7 @@ cl_symbols[] = { {SYS_ "PROPERTY-LIST", SI_ORDINARY, NULL, 1, OBJNULL}, +{SYS_ "BYTECODES", SI_ORDINARY, NULL, 1, OBJNULL}, + /* Tag for end of list */ {NULL, CL_ORDINARY, NULL, -1, OBJNULL}}; diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h index 40b69c039..962c73fc1 100644 --- a/src/c/symbols_list2.h +++ b/src/c/symbols_list2.h @@ -1697,5 +1697,7 @@ cl_symbols[] = { {SYS_ "PROPERTY-LIST",NULL}, +{SYS_ "BYTECODES",NULL}, + /* Tag for end of list */ {NULL,NULL}}; diff --git a/src/lsp/config.lsp.in b/src/lsp/config.lsp.in index 52372eccb..227244f1a 100644 --- a/src/lsp/config.lsp.in +++ b/src/lsp/config.lsp.in @@ -46,7 +46,7 @@ Returns, as a string, the location of the machine on which ECL runs." (defun lisp-implementation-version () "Args:() Returns the version of your ECL as a string." - "@PACKAGE_VERSION@ (CVS 2008-05-20 14:05)") + "@PACKAGE_VERSION@ (CVS 2008-05-22 13:14)") (defun machine-type () "Args: () diff --git a/src/lsp/top.lsp b/src/lsp/top.lsp index 943d210d6..08c4e32cc 100644 --- a/src/lsp/top.lsp +++ b/src/lsp/top.lsp @@ -241,6 +241,13 @@ rebinds this variable to NIL when control enters a break loop.") ~@ Disassemble the current function. Currently, only interpreted functions~@ can be disassembled.~%") + ((:le :lambda-expression) tpl-lambda-expression-command nil + ":l(ambda-)e(expression) Show lisp code for current function" + ":lambda-expression [Break command]~@ + :le [Abbreviation]~@ + ~@ + Show the lisp code of the current function. Only works for interpreted~@ + functions.~%") ((:v :variables) tpl-variables-command nil ":v(ariables) Show local variables, functions, blocks, and tags" ":variables &optional no-values [Break command]~@ @@ -557,6 +564,18 @@ under certain conditions; see file 'Copyright' for details.") (format t " Function cannot be disassembled.~%")) (values))) +(defun tpl-lambda-expression-command (&optional no-values) + (let*((*print-level* 2) + (*print-length* 4) + (*print-pretty* t) + (*print-readably* nil) + (function (ihs-fun *ihs-current*)) + (le (function-lambda-expression function))) + (if le + (pprint le) + (format t " No source code available for this function.~%")) + (values))) + (defun reconstruct-bytecodes-lambda-list (data) (declare (si::c-local data)) (let ((output '())) @@ -740,7 +759,7 @@ under certain conditions; see file 'Copyright' for details.") (when (and (consp fname) (eq 'SETF (car fname))) (setq fname (second fname))) (or (eq fname 'EVAL) - (eq fname 'EVAL-WITH-ENV) + (eq fname 'BYTECODES) (and (not (member (symbol-package fname) *break-hidden-packages* :TEST #'eq)) (not (null fname))