Integration with setjmp/longjmp.

Defining libpng bindings, with longjmp catching, is
now possible.

* autoload.c (ffi_set_entries): Add setjmp symbol, which is
a new macro in stdlib/ffi.tl.

* ffi.c (jmp_buf_s): New symbol variable.
(mk_jmp_buf, rt_setjmp, longjmp_wrap): New functions.
(ffi_init): Initialize jmp_buf_s. Register
sys:rt-setjmp and longjmp intrinsics.

* ffi.h (jmp_buf_s): Declared.

* stdlib/ffi.h (setjmp): New macro. Rather than introducing
a new special operator, we use a run-time support function
called sys:rt-setjmp, which takes functional arguments.

* unwind.[ch] (uw_snapshot, uw_restore): New functions.
The rt_setjmp function needs these to restore our unwind
frame stack into a sane state after catching a longjmp,
which bails without unwinding it, leaving the pointers
referring to frames that no longer exist.

* tests/017/setjmp.tl,
* tests/017/setjmp.expected: New files.

* txr.1: Documented.

9 files changed, 315 insertions, 1 deletions

diff --git a/autoload.c b/autoload.c
index fef8ab0d..a939cbfc 100644
--- a/autoload.c
+++ b/autoload.c
@@ -575,7 +575,7 @@ static val ffi_set_entries(val fun)
     lit("deffi-union"), lit("typedef"), lit("sizeof"),
     lit("alignof"), lit("offsetof"), lit("arraysize"), lit("elemsize"),
     lit("elemtype"), lit("ffi"), lit("carray-ref"), lit("carray-sub"),
-    lit("sub-buf"), lit("znew"),
+    lit("sub-buf"), lit("znew"), lit("setjmp"),
     nil
   };
   autoload_set(al_fun, name, fun);
diff --git a/ffi.c b/ffi.c
index 0a858f7a..d9bd38c3 100644
--- a/ffi.c
+++ b/ffi.c
@@ -37,6 +37,7 @@
 #include <signal.h>
 #include <wchar.h>
 #include <time.h>
+#include <setjmp.h>
 #include "config.h"
 #if HAVE_INTMAX_T
 #include <stdint.h>
@@ -154,6 +155,8 @@ val align_s, pack_s;
 
 val bool_s;
 
+val jmp_buf_s;
+
 val ffi_type_s, ffi_call_desc_s, ffi_closure_s;
 
 static val ffi_typedef_hash, ffi_struct_tag_hash;
@@ -7315,6 +7318,39 @@ static val dyn_size(val type, val obj)
   return num(tft->dynsize(tft, obj, self));
 }
 
+static val mk_jmp_buf(void)
+{
+  val uchar_type = gethash(ffi_typedef_hash, uchar_s);
+  return carray_blank(num_fast(sizeof (jmp_buf)), uchar_type);
+}
+
+static val rt_setjmp(val jmp, val try_fun, val longjmp_fun)
+{
+  val self = lit("setjmp");
+  val uchar_type = gethash(ffi_typedef_hash, uchar_s);
+  mem_t *ptr = carray_ptr(jmp, uchar_type, self);
+  jmp_buf *jbptr = coerce(jmp_buf *, ptr);
+  int res = 0;
+  uw_snapshot_t uws = uw_snapshot();
+
+  if ((res = setjmp(*jbptr)) == 0) {
+    return funcall(try_fun);
+  } else {
+    uw_restore(&uws);
+    return funcall1(longjmp_fun, num(res));
+  }
+}
+
+static val longjmp_wrap(val jmp, val ret)
+{
+  val self = lit("longjmp");
+  val uchar_type = gethash(ffi_typedef_hash, uchar_s);
+  mem_t *ptr = carray_ptr(jmp, uchar_type, self);
+  jmp_buf *jbptr = coerce(jmp_buf *, ptr);
+  int ri = c_int(ret, self);
+  longjmp(*jbptr, ri);
+}
+
 void ffi_init(void)
 {
   prot1(&ffi_typedef_hash);
@@ -7386,6 +7422,7 @@ void ffi_init(void)
   align_s = intern(lit("align"), user_package);
   pack_s = intern(lit("pack"), user_package);
   bool_s = intern(lit("bool"), user_package);
+  jmp_buf_s = intern(lit("jmp-buf"), user_package);
   ffi_type_s = intern(lit("ffi-type"), user_package);
   ffi_call_desc_s = intern(lit("ffi-call-desc"), user_package);
   ffi_closure_s = intern(lit("ffi-closure"), user_package);
@@ -7516,6 +7553,9 @@ void ffi_init(void)
   reg_fun(intern(lit("get-obj"), user_package), func_n2o(get_obj, 1));
   reg_fun(intern(lit("fill-obj"), user_package), func_n3o(fill_obj, 2));
   reg_fun(intern(lit("dyn-size"), system_package), func_n2(dyn_size));
+  reg_fun(jmp_buf_s, func_n0(mk_jmp_buf));
+  reg_fun(intern(lit("rt-setjmp"), system_package), func_n3(rt_setjmp));
+  reg_fun(intern(lit("longjmp"), user_package), func_n2(longjmp_wrap));
   ffi_typedef_hash = make_hash(hash_weak_none, nil);
   ffi_struct_tag_hash = make_hash(hash_weak_none, nil);
   ffi_init_types();
diff --git a/ffi.h b/ffi.h
index 6cc27d69..d9d478eb 100644
--- a/ffi.h
+++ b/ffi.h
@@ -72,6 +72,8 @@ extern val align_s;
 
 extern val bool_s;
 
+extern val jmp_buf_s;
+
 extern val ffi_type_s, ffi_call_desc_s, ffi_closure_s;
 
 extern struct cobj_class *carray_cls;
diff --git a/stdlib/ffi.tl b/stdlib/ffi.tl
index ea561091..b7a29110 100644
--- a/stdlib/ffi.tl
+++ b/stdlib/ffi.tl
@@ -167,3 +167,10 @@
             'znew))
   (let ((qpairs (mappend (aret ^(',@1 ,@2)) (tuples 2 pairs))))
     ^(make-zstruct (ffi ,type) ,*qpairs)))
+
+(defmacro setjmp (:form f jmp-buf longjmp-var try-expr . longjmp-exprs)
+  (unless (bindable longjmp-var)
+    (compile-error f "~s is not a bindable symbol" longjmp-var))
+  ^(sys:rt-setjmp ,jmp-buf
+                  (lambda () ,try-expr)
+                  (lambda (,longjmp-var) ,*longjmp-exprs)))
diff --git a/tests/017/setjmp.expected b/tests/017/setjmp.expected
new file mode 100644
index 00000000..3d7a5493
--- /dev/null
+++ b/tests/017/setjmp.expected
@@ -0,0 +1,4 @@
+setjmp
+result 42
+libpng longjmp
+libpng error 42
diff --git a/tests/017/setjmp.tl b/tests/017/setjmp.tl
new file mode 100644
index 00000000..6cb64b5a
--- /dev/null
+++ b/tests/017/setjmp.tl
@@ -0,0 +1,46 @@
+;; test local setjmp
+(let ((jb (jmp-buf)))
+  (setjmp jb result
+    (progn (put-line "setjmp")
+           (longjmp jb 42))
+    (put-line `result @result`)))
+
+(defun png-fake-output ()
+  (put-string "libpng longjmp\nlibpng error 42\n")
+  (exit))
+
+(unless (ignerr (dlopen "libpng.so"))
+  (png-fake-output))
+
+;; needed by png-set-longjmp-fn API
+(defvarl libc (dlopen nil))
+(defvarl longjmp-addr (dlsym libc "longjmp"))
+
+(typedef png-structp (cptr png))
+
+(with-dyn-lib "libpng.so"
+  (deffi png-get-header-ver "png_get_header_ver" str (png-structp))
+  (deffi png-create-read-struct "png_create_read_struct" png-structp (str cptr cptr cptr))
+  (deffi png-set-longjmp-fn "png_set_longjmp_fn" (carray uchar) (png-structp (cptr dlsym) size-t))
+  (deffi png-longjmp "png_longjmp" void (png-structp int)))
+
+(defvar png-ver (png-get-header-ver cptr-null))
+
+;; In the png.h header, png_setjmp is a macro only; you cannot
+;; #undef it to get to a function. So we write the macro in
+;; the same way as a Lisp macro, in terms of png-set-longjmp-fn,
+;; whereby we pass the longjmp function, and sizeof (jmp_buf).
+(defmacro png-setjmp (png-ptr)
+  (let ((jmpbuf-size (load-time (len (jmp-buf)))))
+    ^(png-set-longjmp-fn ,png-ptr longjmp-addr ,jmpbuf-size)))
+
+;;; Test
+
+;; get png handle
+(defvar png (png-create-read-struct png-ver cptr-null cptr-null cptr-null))
+
+;; get jmp_buf from png handle, setjmp it, longjmp to it.
+(setjmp (png-setjmp png) err
+  (progn (put-line "libpng longjmp")
+         (png-longjmp png 42))
+  (put-line `libpng error @err`))
diff --git a/txr.1 b/txr.1
index 4364caab..e47a1dd8 100644
--- a/txr.1
+++ b/txr.1
@@ -88914,6 +88914,196 @@ indicates a byte offset into the
 .code carray
 object's storage, not an array index.
 
+.NP* C Non-Local Jumps
+
+\*(TL supports interfacing with modules that make use of the C
+.code setjmp
+and
+.code longjmp
+feature across their boundaries. It is possible to save a jump
+location in Lisp code with the
+.code setjmp
+macro, such that a foreign function can perform a
+.code longjmp
+to that saved context.
+
+The jump context buffer, known as the type
+.code jmp_buf
+in C, is modelled as a
+.code carray
+object whose element type is
+.codn uchar .
+The function
+.code jmp-buf
+returns such an object.  Foreign functions that return a pointer to a
+.code jmp_buf
+may be suitably defined via
+.code deffi
+such that the pointer is mapped to a
+.code carray
+object whose element type is
+.codn uchar .
+The resulting object will then be usable as a jump buffer.
+
+The features described here are unsafe. When used in certain incorrect ways,
+the behavior is undefined.
+
+Using the
+.code setjmp
+macro and
+.code longjmp
+function as control primitives in Lisp code not interacting with foreign
+functions is strongly discouraged.
+
+There are situations in which the foreign function calling mechanism allocates
+temporary dynamic memory for converting between Lisp and C objects.  These
+situations occur when objects are referenced by pointers, and so are are
+outside of the stack-based argument space. In such a situation, if the foreign
+function performs a
+.code longjmp
+terminating in a
+.code setjmp
+macro in Lisp code, that temporary storage will leak.
+
+.coNP Function @ jmp-buf
+.synb
+.mets (jmp-buf)
+.syne
+.desc
+The
+.code jmp-buf
+function returns a new
+.code carray
+object suitable for use as a jump buffer with the
+.code setjmp
+macro and
+.code longjmp
+function.
+
+.coNP Function @ longjmp
+.synb
+.mets (longjmp < jmp-buf << value )
+.syne
+.desc
+The
+.code longjmp
+function restores the context saved into the
+.meta jmp-buf
+object by the
+.code setjmp
+macro.  If that macro already terminated, the behavior is undefined.
+
+The
+.meta value
+must be an integer in range of the FFI type
+.codn int .
+That value will be observed in the
+.code setjmp
+form, as described.
+If
+.meta value
+is
+.code 0
+(zero) the value
+.code 1
+is used instead. This is a behavior of the underlying
+.code longjmp
+C library function.
+
+Note: a context abandoned via
+.code longjmp
+will not perform unwinding, similarly to
+.codn sys:abscond* .
+The form which is abandoned by
+.code longjmp
+should not be using scoped management of resources that relies on
+.code unwind-protect
+for clean-up.
+
+.coNP Macro @ setjmp
+.synb
+.mets (setjmp < jmp-buf < result-var < main-form << longjmp-form *)
+.syne
+.desc
+The
+.code setjmp
+macro saves the jump context into the
+.meta jmp-buf
+object, and evaluates the
+.meta main-form
+expression.
+
+If the
+.meta main-form
+expression terminates normally then the value
+it produces becomes the result of
+.codn setjmp ,
+which terminates.
+
+If the
+.meta main-form
+performs a
+.code longjmp
+to the context saved in
+.codn jmp-buf ,
+then that form is abruptly terminated, without
+performing any unwinding.
+Then, the zero or more
+.metn longjmp-form s
+are evaluated. The
+.code setjmp
+form terminates, yielding the value of the last
+.meta longjmp-form
+or else
+.codn nil .
+
+The
+.codn longjmp-form s
+are evaluated in a scope in which the
+.code result-var
+symbol is bound as a variable, taking on the
+integer value passed to
+.codn longjmp ,
+which is never zero.
+
+The
+.meta jmp-buf
+argument must be a
+.code carray
+object suitable for use as a jump buffer.
+
+The
+.code result-var
+argument must be a bindable symbol.
+
+Once
+.code setjmp
+terminates, the contents of
+.meta jmp-buf
+become indeterminate. Any
+.code longjmp
+attempt using an indeterminate
+.code jmp-buf
+is undefined behavior.
+
+.TP* Example:
+
+.verb
+  (let ((jb (jmp-buf)))
+    (setjmp jb result
+      (progn (put-line "setjmp")     ;; "setjmp" is printed
+             (longjmp jb 42))
+      (put-line `result is: @result`)))  ;; "result is: 42" is printed
+.brev
+
+.IP
+Note: this example is for illustration only. Using
+.code setjmp
+and
+.code longjmp
+as Lisp control flow constructs in code not interacting with foreign
+functions is strongly discouraged.
+
 .SH* LISP COMPILATION
 
 .SS* Overview
diff --git a/unwind.c b/unwind.c
index 300576cf..ef6589b1 100644
--- a/unwind.c
+++ b/unwind.c
@@ -202,6 +202,22 @@ static void uw_abscond_to_exit_point(void)
   }
 }
 
+uw_snapshot_t uw_snapshot(void)
+{
+  uw_snapshot_t snap = {
+    dyn_env, uw_stack, uw_menv_stack
+  };
+
+  return snap;
+}
+
+void uw_restore(const uw_snapshot_t *psnap)
+{
+  dyn_env = psnap->de;
+  uw_stack = psnap->stack;
+  uw_menv_stack = psnap->menv_stack;
+}
+
 void uw_push_block(uw_frame_t *fr, val tag)
 {
   memset(fr, 0, sizeof *fr);
diff --git a/unwind.h b/unwind.h
index a10e241b..eda4b9f5 100644
--- a/unwind.h
+++ b/unwind.h
@@ -383,7 +383,16 @@ union uw_frame {
 #endif
 } UW_FRAME_ALIGN;
 
+typedef struct {
+  val de;
+  uw_frame_t *stack;
+  uw_frame_t *menv_stack;
+} uw_snapshot_t;
+
 extern val catch_frame_s;
+
+uw_snapshot_t uw_snapshot(void);
+void uw_restore(const uw_snapshot_t *);
 void uw_push_block(uw_frame_t *, val tag);
 void uw_push_match_env(uw_frame_t *);
 val uw_get_func(val sym);