From e7429b1ced0c69fa7901f888f8dc25f00fc346a4 Mon Sep 17 00:00:00 2001
From: Justus Winter <justus@g10code.com>
Date: Fri, 18 Nov 2016 13:36:23 +0100
Subject: 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>
---
 tests/gpgscm/init.scm | 62 ++++++++++++++++++++++++++++++++++++++++++++++-----
 1 file changed, 56 insertions(+), 6 deletions(-)

(limited to 'tests/gpgscm/init.scm')

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
 
-- 
cgit v1.2.3