gpgscm: Better error reporting.

* tests/gpgscm/ffi.scm: Move the customized exception handling and
atexit logic...
* tests/gpgscm/init.scm: ... here.
(throw): Record the current history.
(throw'): New function that is history-aware.
(rethrow): New function.
(*error-hook*): Use the new throw'.
* tests/gpgscm/main.c (load): Fix error handling.
(main): Save and use the 'sc->retcode' as exit code.
* tests/gpgscm/repl.scm (repl): Print call history.
* tests/gpgscm/scheme.c (_Error_1): Make a snapshot of the history,
use it to provide a accurate location of the expression causing the
error at runtime, and hand the history trace to the '*error-hook*'.
(opexe_5): Tag all lists at parse time with the current location.
* tests/gpgscm/tests.scm: Update calls to 'throw', use 'rethrow'.

Signed-off-by: Justus Winter <justus@g10code.com>

6 files changed, 122 insertions, 62 deletions

diff --git a/tests/gpgscm/ffi.scm b/tests/gpgscm/ffi.scm
index c5f373c17..b62fd1f8a 100644
--- a/tests/gpgscm/ffi.scm
+++ b/tests/gpgscm/ffi.scm
@@ -47,39 +47,3 @@
 
 ;; Low-level mechanism to terminate the process.
 (ffi-define (_exit status))
-
-;; High-level mechanism to terminate the process is to throw an error
-;; of the form (*interpreter-exit* status).  This gives automatic
-;; resource management a chance to clean up.
-(define *interpreter-exit* (gensym))
-(define (throw . x)
-  (cond
-   ((more-handlers?)
-    (apply (pop-handler) x))
-   ((and (= 2 (length x)) (equal? *interpreter-exit* (car x)))
-    (*run-atexit-handlers*)
-    (_exit (cadr x)))
-   (else
-    (apply error x))))
-(set! *error-hook* throw)
-
-;; Terminate the process returning STATUS to the parent.
-(define (exit status)
-  (throw *interpreter-exit* status))
-
-;; A list of functions run at interpreter shutdown.
-(define *atexit-handlers* (list))
-
-;; Execute all these functions.
-(define (*run-atexit-handlers*)
-  (unless (null? *atexit-handlers*)
-	  (let ((proc (car *atexit-handlers*)))
-	    ;; Drop proc from the list so that it will not get
-	    ;; executed again even if it raises an exception.
-	    (set! *atexit-handlers* (cdr *atexit-handlers*))
-	    (proc)
-	    (*run-atexit-handlers*))))
-
-;; Register a function to be run at interpreter shutdown.
-(define (atexit proc)
-  (set! *atexit-handlers* (cons proc *atexit-handlers*)))
diff --git a/tests/gpgscm/init.scm b/tests/gpgscm/init.scm
index b03eb437b..04f088ca2 100644
--- a/tests/gpgscm/init.scm
+++ b/tests/gpgscm/init.scm
@@ -567,7 +567,7 @@
 ;    "Catch" establishes a scope spanning multiple call-frames until
 ;    another "catch" is encountered.  Within the recovery expression
 ;    the thrown exception is bound to *error*.  Errors can be rethrown
-;    using (apply throw *error*).
+;    using (rethrow *error*).
 ;
 ;    Exceptions are thrown with:
 ;
@@ -588,10 +588,30 @@
 (define (more-handlers?)
      (pair? *handlers*))
 
-(define (throw . x)
-     (if (more-handlers?)
-          (apply (pop-handler) x)
-          (apply error x)))
+;; This throws an exception.
+(define (throw message . args)
+  (throw' message args (cdr (*vm-history*))))
+
+;; This is used by the vm to throw exceptions.
+(define (throw' message args history)
+  (cond
+   ((more-handlers?)
+    ((pop-handler) message args history))
+   ((and args (= 2 (length args)) (equal? *interpreter-exit* (car args)))
+    (*run-atexit-handlers*)
+    (quit (cadr args)))
+   (else
+    (display message)
+    (if args (begin
+	      (display ": ")
+	      (write args)))
+    (newline)
+    (vm-history-print history)
+    (quit 1))))
+
+;; Convenience function to rethrow the error.
+(define (rethrow e)
+  (apply throw' e))
 
 (macro (catch form)
      (let ((label (gensym)))
@@ -601,8 +621,38 @@
                     (pop-handler)
                     ,label)))))
 
-(define *error-hook* throw)
+;; Make the vm use throw'.
+(define *error-hook* throw')
+
+
+
+;; High-level mechanism to terminate the process is to throw an error
+;; of the form (*interpreter-exit* status).  This gives automatic
+;; resource management a chance to clean up.
+(define *interpreter-exit* (gensym))
+
+;; Terminate the process returning STATUS to the parent.
+(define (exit status)
+  (throw "interpreter exit" *interpreter-exit* status))
+
+;; A list of functions run at interpreter shutdown.
+(define *atexit-handlers* (list))
+
+;; Execute all these functions.
+(define (*run-atexit-handlers*)
+  (unless (null? *atexit-handlers*)
+	  (let ((proc (car *atexit-handlers*)))
+	    ;; Drop proc from the list so that it will not get
+	    ;; executed again even if it raises an exception.
+	    (set! *atexit-handlers* (cdr *atexit-handlers*))
+	    (proc)
+	    (*run-atexit-handlers*))))
+
+;; Register a function to be run at interpreter shutdown.
+(define (atexit proc)
+  (set! *atexit-handlers* (cons proc *atexit-handlers*)))
 
+
 
 ;;;;; Definition of MAKE-ENVIRONMENT, to be used with two-argument EVAL
 
diff --git a/tests/gpgscm/main.c b/tests/gpgscm/main.c
index 2f77ac5aa..c96dcf189 100644
--- a/tests/gpgscm/main.c
+++ b/tests/gpgscm/main.c
@@ -150,7 +150,10 @@ load (scheme *sc, char *file_name,
 
         h = fopen (qualified_name, "r");
         if (h)
-          break;
+          {
+            err = 0;
+            break;
+          }
 
         if (n > 1)
           {
@@ -170,23 +173,23 @@ load (scheme *sc, char *file_name,
         fprintf (stderr,
                  "Consider using GPGSCM_PATH to specify the location "
                  "of the Scheme library.\n");
-      return err;
+      goto leave;
     }
   if (verbose > 1)
     fprintf (stderr, "Loading %s...\n", qualified_name);
   scheme_load_named_file (sc, h, qualified_name);
   fclose (h);
 
-  if (sc->retcode)
+  if (sc->retcode && sc->nesting)
     {
-      if (sc->nesting)
-        fprintf (stderr, "%s: Unbalanced parenthesis\n", qualified_name);
-      return gpg_error (GPG_ERR_GENERAL);
+      fprintf (stderr, "%s: Unbalanced parenthesis\n", qualified_name);
+      err = gpg_error (GPG_ERR_GENERAL);
     }
 
+ leave:
   if (file_name != qualified_name)
     free (qualified_name);
-  return 0;
+  return err;
 }
 
 
@@ -194,6 +197,7 @@ load (scheme *sc, char *file_name,
 int
 main (int argc, char **argv)
 {
+  int retcode;
   gpg_error_t err;
   char *argv0;
   ARGPARSE_ARGS pargs;
@@ -291,8 +295,9 @@ main (int argc, char **argv)
         log_fatal ("%s: %s", script, gpg_strerror (err));
     }
 
+  retcode = sc->retcode;
   scheme_load_string (sc, "(*run-atexit-handlers*)");
   scheme_deinit (sc);
   xfree (sc);
-  return EXIT_SUCCESS;
+  return retcode;
 }
diff --git a/tests/gpgscm/repl.scm b/tests/gpgscm/repl.scm
index 78b8151a0..84454dc7c 100644
--- a/tests/gpgscm/repl.scm
+++ b/tests/gpgscm/repl.scm
@@ -34,7 +34,14 @@
 			      (read (open-input-string next)))))
 	       (if (not (eof-object? c))
 		   (begin
-		     (catch (echo "Error:" *error*)
+		     (catch (begin
+			      (display (car *error*))
+			      (when (and (cadr *error*)
+					 (not (null? (cadr *error*))))
+				    (display ": ")
+				    (write (cadr *error*)))
+			      (newline)
+			      (vm-history-print (caddr *error*)))
 			    (echo "    ===>" (eval c environment)))
 		     (exit (loop ""))))
 	       (exit (loop next)))))))))
diff --git a/tests/gpgscm/scheme.c b/tests/gpgscm/scheme.c
index 60b5a4111..3abe12a81 100644
--- a/tests/gpgscm/scheme.c
+++ b/tests/gpgscm/scheme.c
@@ -2656,6 +2656,7 @@ static INLINE pointer slot_value_in_env(pointer slot)
 
 static pointer _Error_1(scheme *sc, const char *s, pointer a) {
      const char *str = s;
+     pointer history;
 #if USE_ERROR_HOOK
      pointer x;
      pointer hdl=sc->ERROR_HOOK;
@@ -2663,19 +2664,34 @@ static pointer _Error_1(scheme *sc, const char *s, pointer a) {
 
 #if SHOW_ERROR_LINE
      char sbuf[STRBUFFSIZE];
+#endif
+
+     history = history_flatten(sc);
 
+#if SHOW_ERROR_LINE
      /* make sure error is not in REPL */
      if (sc->load_stack[sc->file_i].kind & port_file &&
          sc->load_stack[sc->file_i].rep.stdio.file != stdin) {
-       int ln = sc->load_stack[sc->file_i].rep.stdio.curr_line;
-       const char *fname = sc->load_stack[sc->file_i].rep.stdio.filename;
+       pointer tag;
+       const char *fname;
+       int ln;
+
+       if (history != sc->NIL && has_tag(car(history))
+	   && (tag = get_tag(sc, car(history)))
+	   && is_string(car(tag)) && is_integer(cdr(tag))) {
+	 fname = string_value(car(tag));
+	 ln = ivalue_unchecked(cdr(tag));
+       } else {
+	 fname = sc->load_stack[sc->file_i].rep.stdio.filename;
+	 ln = sc->load_stack[sc->file_i].rep.stdio.curr_line;
+       }
 
        /* should never happen */
        if(!fname) fname = "<unknown>";
 
        /* we started from 0 */
        ln++;
-       snprintf(sbuf, STRBUFFSIZE, "(%s : %i) %s", fname, ln, s);
+       snprintf(sbuf, STRBUFFSIZE, "%s:%i: %s", fname, ln, s);
 
        str = (const char*)sbuf;
      }
@@ -2684,11 +2700,15 @@ static pointer _Error_1(scheme *sc, const char *s, pointer a) {
 #if USE_ERROR_HOOK
      x=find_slot_in_env(sc,sc->envir,hdl,1);
     if (x != sc->NIL) {
+	 sc->code = cons(sc, cons(sc, sc->QUOTE,
+				  cons(sc, history, sc->NIL)),
+			 sc->NIL);
          if(a!=0) {
-               sc->code = cons(sc, cons(sc, sc->QUOTE, cons(sc,(a), sc->NIL)), sc->NIL);
+	   sc->code = cons(sc, cons(sc, sc->QUOTE, cons(sc, a, sc->NIL)),
+	                   sc->code);
          } else {
-               sc->code = sc->NIL;
-         }
+	   sc->code = cons(sc, sc->F, sc->code);
+	 }
          sc->code = cons(sc, mk_string(sc, str), sc->code);
          setimmutable(car(sc->code));
          sc->code = cons(sc, slot_value_in_env(x), sc->code);
@@ -4808,6 +4828,19 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) {
                     Error_0(sc,"syntax error: illegal dot expression");
                } else {
                     sc->nesting_stack[sc->file_i]++;
+#if USE_TAGS && SHOW_ERROR_LINE
+		    {
+		      const char *filename =
+			sc->load_stack[sc->file_i].rep.stdio.filename;
+		      int lineno =
+			sc->load_stack[sc->file_i].rep.stdio.curr_line;
+
+		      s_save(sc, OP_TAG_VALUE,
+			     cons(sc, mk_string(sc, filename),
+				  cons(sc, mk_integer(sc, lineno), sc->NIL)),
+			     sc->NIL);
+		    }
+#endif
                     s_save(sc,OP_RDLIST, sc->NIL, sc->NIL);
                     s_thread_to(sc,OP_RDSEXPR);
                }
diff --git a/tests/gpgscm/tests.scm b/tests/gpgscm/tests.scm
index bd51819d2..bec19223d 100644
--- a/tests/gpgscm/tests.scm
+++ b/tests/gpgscm/tests.scm
@@ -130,7 +130,8 @@
   (let ((result (call-with-io what "")))
     (if (= 0 (:retcode result))
 	(:stdout result)
-	(throw (list what "failed:" (:stderr result))))))
+	(throw (string-append (stringify what) " failed")
+	       (:stderr result)))))
 
 (define (call-popen command input-string)
   (let ((result (call-with-io command input-string)))
@@ -246,7 +247,7 @@
 	(let ((,result-sym
 	       ,(if (= 1 (length (cadr form)))
 		    `(catch (begin (close ,(caaadr form))
-				   (apply throw *error*))
+				   (rethrow *error*))
 			    ,@(cddr form))
 		    `(letfd ,(cdadr form) ,@(cddr form)))))
 	  (close ,(caaadr form))
@@ -257,7 +258,7 @@
     `(let* ((,cwd-sym (getcwd))
 	    (_ (if ,(cadr form) (chdir ,(cadr form))))
 	    (,result-sym (catch (begin (chdir ,cwd-sym)
-				       (apply throw *error*))
+				       (rethrow *error*))
 				,@(cddr form))))
        (chdir ,cwd-sym)
        ,result-sym)))
@@ -281,7 +282,7 @@
 	    (_ (chdir ,tmp-sym))
 	    (,result-sym (catch (begin (chdir ,cwd-sym)
 				       (unlink-recursively ,tmp-sym)
-				       (apply throw *error*))
+				       (rethrow *error*))
 				,@(cdr form))))
        (chdir ,cwd-sym)
        (unlink-recursively ,tmp-sym)
@@ -312,7 +313,7 @@
 	(let ((,result-sym
 	       ,(if (= 1 (length (cadr form)))
 		    `(catch (begin (remove-temporary-file ,(caadr form))
-				   (apply throw *error*))
+				   (rethrow *error*))
 			    ,@(cddr form))
 		    `(lettmp ,(cdadr form) ,@(cddr form)))))
 	  (remove-temporary-file ,(caadr form))