Debugger lists available restarts. New lisp & C functions for correctable type errors with useful restarts.

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()

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;

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}};
 

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}};
 

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

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 */
 

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

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