From d42cc3de9019fb0ddac38186a5adcdff3e5753b1 Mon Sep 17 00:00:00 2001 From: jgarcia Date: Sun, 29 Oct 2006 07:41:20 +0000 Subject: [PATCH] Debugger lists available restarts. New lisp & C functions for correctable type errors with useful restarts. --- src/CHANGELOG | 7 +++-- src/c/number.d | 21 ++++++++----- src/c/symbols_list.h | 2 ++ src/c/symbols_list2.h | 2 ++ src/c/typespec.d | 9 ++++++ src/h/external.h | 1 + src/lsp/assert.lsp | 15 ++++++++++ src/lsp/top.lsp | 68 ++++++++++++++++++------------------------- 8 files changed, 77 insertions(+), 48 deletions(-) diff --git a/src/CHANGELOG b/src/CHANGELOG index 9b0f073b5..ae60bc2a0 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -137,13 +137,16 @@ ECL 1.0: - Support for hierarchical package names, as in Allegro Common-Lisp. + - The debugger now prints a list of available restarts. + - C functions which disappear: si_set_compiled_function_name(), si_extended_string_concatenate() - Lisp functions which disappear: si:set-compiled-function-name, - si:extended-string-concatenate. + si:extended-string-concatenate, si:wrong-type-argument. - - New C functions: ecl_stream_to_handle(), ecl_base_char_code(). + - New C functions: ecl_stream_to_handle(), ecl_base_char_code(), + ecl_type_error(). - Functions renamed: backup_fopen() -> ecl_backup_fopen() char_code() -> ecl_char_code() diff --git a/src/c/number.d b/src/c/number.d index 014ac5788..b9fa864d2 100644 --- a/src/c/number.d +++ b/src/c/number.d @@ -198,8 +198,9 @@ cl_object make_complex(cl_object r, cl_object i) { cl_object c; - cl_type ti = type_of(i); - + cl_type ti; + AGAIN: + ti = type_of(i); /* Both R and I are promoted to a common type */ switch (type_of(r)) { case t_fixnum: @@ -229,7 +230,8 @@ make_complex(cl_object r, cl_object i) break; #endif default: - FEtype_error_real(i); + i = ecl_type_error(@'complex',"imaginary part", i, @'real'); + goto AGAIN; } break; #ifdef ECL_SHORT_FLOAT @@ -253,7 +255,8 @@ make_complex(cl_object r, cl_object i) break; #endif default: - FEtype_error_real(i); + i = ecl_type_error(@'complex',"imaginary part", i, @'real'); + goto AGAIN; } break; #endif @@ -280,7 +283,8 @@ make_complex(cl_object r, cl_object i) break; #endif default: - FEtype_error_real(i); + i = ecl_type_error(@'complex',"imaginary part", i, @'real'); + goto AGAIN; } break; case t_doublefloat: @@ -301,7 +305,8 @@ make_complex(cl_object r, cl_object i) break; #endif default: - FEtype_error_real(i); + i = ecl_type_error(@'complex',"imaginary part", i, @'real'); + goto AGAIN; } break; #ifdef ECL_LONG_FLOAT @@ -311,7 +316,9 @@ make_complex(cl_object r, cl_object i) break; #endif default: - FEtype_error_real(r); + r = ecl_type_error(@'complex',"real part", r, @'real'); + goto AGAIN; + } c = cl_alloc_object(t_complex); c->complex.real = r; diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 2244bb4ba..c9bc583b2 100644 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1655,6 +1655,8 @@ cl_symbols[] = { {SYS_ "PACKAGE-CHILDREN", SI_ORDINARY, NULL, -1, OBJNULL}, #endif +{SYS_ "WRONG-TYPE-ARGUMENT", 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 a58a1fd23..87714d7b5 100644 --- a/src/c/symbols_list2.h +++ b/src/c/symbols_list2.h @@ -1655,6 +1655,8 @@ cl_symbols[] = { {SYS_ "PACKAGE-CHILDREN",NULL}, #endif +{SYS_ "WRONG-TYPE-ARGUMENT",NULL}, + /* Tag for end of list */ {NULL,NULL}}; diff --git a/src/c/typespec.d b/src/c/typespec.d index f6717763f..4245465a5 100644 --- a/src/c/typespec.d +++ b/src/c/typespec.d @@ -104,6 +104,15 @@ FEtype_error_stream(cl_object strm) FEwrong_type_argument(@'stream', strm); } +cl_object +ecl_type_error(cl_object function, const char *place, cl_object o, + cl_object type) +{ + return funcall(5, @'si::wrong-type-argument', o, type, + (*place? make_constant_base_string(place) : Cnil), + function); +} + /**********************************************************************/ void diff --git a/src/h/external.h b/src/h/external.h index 3f22a25cc..f18a5092d 100644 --- a/src/h/external.h +++ b/src/h/external.h @@ -1430,6 +1430,7 @@ extern void FEcircular_list(cl_object x) /*__attribute__((noreturn))*/; extern void FEtype_error_index(cl_object seq, cl_object ndx) /*__attribute__((noreturn))*/; extern void FEtype_error_string(cl_object x) /*__attribute__((noreturn))*/; extern void FEdivision_by_zero(cl_object x, cl_object y) /*__attribute__((noreturn))*/; +extern cl_object ecl_type_error(cl_object function, const char *place, cl_object o, cl_object type); /* unixfsys.c */ diff --git a/src/lsp/assert.lsp b/src/lsp/assert.lsp index bda089d56..76167fe7c 100644 --- a/src/lsp/assert.lsp +++ b/src/lsp/assert.lsp @@ -14,6 +14,21 @@ (format *query-io* "~&Type a form to be evaluated:~%") (list (eval (read *query-io*)))) +(defun wrong-type-argument (object type &optional place function) + (tagbody again + (restart-case + (error 'simple-type-error + :format-control "In ~:[an anonymous function~;~:*function ~A~], ~:[found object~;~:*the value of ~A is~]~%~8t~S~%which is not of expected type ~A" + :format-arguments (list function place object type)) + (store-value (value) + :report (lambda (stream) + (format stream "Supply a new value ~@[of ~A~]." place)) + :interactive read-evaluated-form + (setf object value) + (unless (typep object type) + (go again))))) + object) + (defmacro check-type (place type &optional type-string) "Args: (check-type place typespec [string-form]) Signals a continuable error, if the value of PLACE is not of the specified diff --git a/src/lsp/top.lsp b/src/lsp/top.lsp index 10bed437d..693263a16 100644 --- a/src/lsp/top.lsp +++ b/src/lsp/top.lsp @@ -452,9 +452,9 @@ under certain conditions; see file 'Copyright' for details.") (cond ((null c) (if (eq name :newline) ; special handling for Newline. nil - `(tpl-unknown-command ',name))) - ((eq (third c) :restart) - `(invoke-restart-interactively ,(second c))) + `(tpl-unknown-command ',name))) + ((eq (third c) :restart) + `(invoke-restart-interactively ,(second c))) ((eq (third c) :eval) `(,(second c) . ,(tpl-parse-forms line))) ((eq (third c) :string) @@ -863,7 +863,6 @@ package." )) (defun default-debugger (condition) - (declare (si::c-local)) (unless *break-enable* (throw *quit-tag* nil)) (let*((*standard-input* *debug-io*) @@ -876,47 +875,38 @@ package." (*break-env* nil)) (when (listen *debug-io*) (clear-input *debug-io*)) - (princ *break-message*) - ; restart commands - ; - (let ((commands (adjoin (restart-commands condition) (adjoin break-commands *tpl-commands*)))) - ;(print commands) - (tpl :commands commands)))) + ;; Like in SBCL, the error message is output through *error-output* + ;; The rest of the interaction is performed through *debug-io* + (princ *break-message* *error-output*) + ;; Here we show a list of restarts and invoke the toplevel with + ;; an extended set of commands which includes invoking the associated + ;; restarts. + (let* ((restarts (compute-restarts condition)) + (restart-commands (list "Restart commands"))) + (format t (if restarts "Available restarts:~%" "No restarts available.~%")) + (loop for restart in restarts + and i from 1 + do (let ((user-command (format nil "r~D" i)) + (name (format nil "~@[(~A) ~]" (restart-name restart))) + (helpstring (princ-to-string restart))) + (push (list + (list (intern (string-upcase user-command) :keyword)) + restart :restart + (format nil ":~A~16T~A~24T~A" user-command helpstring name) + (format nil ":~A~48T~A~& ~&~A~A" (string-downcase user-command) "[Restart command]" name helpstring)) + restart-commands) + (format t "~D. ~A~A~%" i name restart))) + (tpl :commands + (adjoin (nreverse restart-commands) + (adjoin break-commands *tpl-commands*)))))) -(defun restart-commands (condition) - "Builds a list of restart commands that can be invoked from the debugger" - `("Restart commands" - ,@(mapcar - (lambda (iterator-restart) - (let* - ((iterator (first iterator-restart)) - (restart (second iterator-restart)) - (user-command (format nil "r~A" iterator)) - (helpstring (princ-to-string restart))) - (list - (list (intern (string-upcase user-command) :keyword)) - restart :restart - (format nil ":~A~16T~A~24T~A" user-command helpstring (string (restart-name restart)) ) - (format nil ":~A~48T~A~& ~&~A~&Restarts program using~&(INVOKE-RESTART-INTERACTIVELY '~A)" (string-downcase user-command) "[Restart command]" helpstring (restart-name restart) )))) - (enumerate (compute-restarts condition))))) - -(defun enumerate (list) - "Given a list of (a b c) returns a list of ((1 a) (2 b) (3 c))" - (declare (si::c-local)) - (let - ((iterator 0) - (result nil)) - (dolist (item list) - (incf iterator) - (setf result (cons (list iterator item) result))) - (reverse result))) - (defun invoke-debugger (condition) (when *debugger-hook* (let* ((old-hook *debugger-hook*) (*debugger-hook* nil)) (funcall old-hook condition old-hook))) - (default-debugger condition)) + (locally (declare (notinline default-debugger)) + (default-debugger condition))) (defun safe-eval (form env err-value) (catch 'si::protect-tag