gpgscm: Better error reporting.
authorJustus Winter <justus@g10code.com>
Fri, 18 Nov 2016 12:36:23 +0000 (13:36 +0100)
committerJustus Winter <justus@g10code.com>
Thu, 8 Dec 2016 16:22:50 +0000 (17:22 +0100)
* 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>
tests/gpgscm/ffi.scm
tests/gpgscm/init.scm
tests/gpgscm/main.c
tests/gpgscm/repl.scm
tests/gpgscm/scheme.c
tests/gpgscm/tests.scm

index c5f373c..b62fd1f 100644 (file)
 
 ;; 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*)))
index b03eb43..04f088c 100644 (file)
 ;    "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:
 ;
 (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)))
                     (pop-handler)
                     ,label)))))
 
-(define *error-hook* throw)
+;; Make the vm use throw'.
+(define *error-hook* throw')
+
+\f
+
+;; 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*)))
 
+\f
 
 ;;;;; Definition of MAKE-ENVIRONMENT, to be used with two-argument EVAL
 
index 2f77ac5..c96dcf1 100644 (file)
@@ -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;
 }
 
 \f
@@ -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;
 }
index 78b8151..84454dc 100644 (file)
                              (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)))))))))
index 60b5a41..3abe12a 100644 (file)
@@ -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);
                }
index bd51819..bec1922 100644 (file)
   (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)))
        (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))
     `(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)))
            (_ (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)
        (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))