Adding find-frame function.

* unwind.c (uw_find_frame): New function.
(uw_late_init): Registered find-frame intrinsic.

* unwind.h (uw_find_frame): Declared.

* lib.h (default_arg_strict): New inline function.
Will not replace nil value with default.

* txr.1: Documented find-frame.

4 files changed, 110 insertions, 2 deletions

diff --git a/lib.h b/lib.h
index e48904a4..aaa87fcb 100644
--- a/lib.h
+++ b/lib.h
@@ -968,6 +968,11 @@ INLINE val default_bool_arg(val arg)
   return if3(missingp(arg), nil, arg);
 }
 
+INLINE val default_arg_strict(val arg, val dfl)
+{
+  return if3(missingp(arg), dfl, arg);
+}
+
 #define list_collect_decl(OUT, PTAIL)           \
   val OUT = nil;                                \
   loc PTAIL = mkcloc(OUT)
diff --git a/txr.1 b/txr.1
index f845c5ea..f1cad225 100644
--- a/txr.1
+++ b/txr.1
@@ -27000,7 +27000,9 @@ and
 .code handle-frame
 are used by the
 .code get-frames
-function to represent information about the currently established
+and
+.code find-frame
+functions to represent information about the currently established
 exception catches (see the
 .code catch
 macro) and handlers
@@ -27093,6 +27095,57 @@ structure may be passed as an argument to the
 .code invoke-catch
 function.
 
+.coNP Function @ find-frame
+.synb
+.mets (find-frame >> [ exception-symbol <> [ frame-type ]])
+.syne
+.desc
+The
+.code find-frame
+function locates the first (innermost) instance of a specific kind of
+exception frame (a catch frame or a handler frame) which is eligible
+for processing an exception of a specific type. If such a frame
+is found, it is returned.  The returned frame object is of the same kind as the
+objects which comprise the list returned by the function
+.codn get-frames .
+If such a frame is not found,
+.code nil
+is returned.
+
+The
+.meta exception-symbol
+argument specifies a match by exception type: the candidate frame
+must specify in its list of matches at least one type which is an exception
+supertype of
+.metn exception-symbol .
+If this argument is omitted, it defaults to
+.code nil
+which finds any handler that matches at least one type. There is no way to
+search for handlers which match an empty set of types; the
+.code find-frame
+function skips such frames.
+
+The
+.meta frame-type
+argument specifies which frame type to find. Useful values for this
+argument are the structure type names
+.code catch-frame
+and
+.code handle-frame
+or the actual structure type objects which these type names denote.
+If any other value is specified, the function returns
+.code nil .
+If the argument is omitted, it defaults to the type of the
+.code catch-frame
+structure. That is to say, by default, the function looks for catch
+frames.
+
+Thus, if
+.code find-frame
+is called with no arguments at all it finds the innermost catch frame,
+if any exists, or else returns
+.codn nil .
+
 .coNP Function @ invoke-catch
 .synb
 .mets (invoke-catch < catch-frame < symbol << argument *)
@@ -27107,7 +27160,9 @@ described by the
 argument, which must be a structure of type
 .code catch-frame
 returned by a call to
-.codn get-frames .
+.code get-frame
+or
+.codn find-frame .
 
 The control transfer is possible only if the catch
 frame represented by
diff --git a/unwind.c b/unwind.c
index 8fe70159..a8df8914 100644
--- a/unwind.c
+++ b/unwind.c
@@ -252,6 +252,52 @@ val uw_get_frames(void)
   return out;
 }
 
+val uw_find_frame(val extype, val frtype)
+{
+  uw_frame_t *ex;
+  uw_frtype_t et;
+
+  extype = default_bool_arg(extype);
+  frtype = default_arg_strict(frtype, catch_frame_type);
+
+  if (symbolp(frtype)) {
+    frtype = find_struct_type(frtype);
+    if (!frtype)
+      return nil;
+  }
+
+  if (frtype == catch_frame_type)
+    et = UW_CATCH;
+  else if (frtype == handle_frame_type)
+    et = UW_HANDLE;
+  else
+    return nil;
+
+  if (frtype != catch_frame_type && frtype != handle_frame_type)
+    return nil;
+
+  for (ex = uw_stack; ex != 0; ex = ex->uw.up) {
+    if (ex->uw.type == et && ex->ca.visible) {
+      val match;
+      for (match = ex->ca.matches; match; match = cdr(match))
+        if (uw_exception_subtype_p(extype, car(match)))
+          break;
+      if (match) {
+        args_decl(args, ARGS_MIN);
+        val fr = make_struct(frtype, nil, args);
+        slotset(fr, types_s, ex->ca.matches);
+        if (et == UW_CATCH)
+          slotset(fr, jump_s, cptr(coerce(mem_t *, ex)));
+        else
+          slotset(fr, fun_s, ex->ha.fun);
+        return fr;
+      }
+    }
+  }
+
+  return nil;
+}
+
 val uw_invoke_catch(val catch_frame, val sym, struct args *args)
 {
   uw_frame_t *ex, *ex_point;
@@ -609,6 +655,7 @@ void uw_late_init(void)
   reg_var(unhandled_hook_s = intern(lit("*unhandled-hook*"),
           user_package), nil);
   reg_fun(intern(lit("get-frames"), user_package), func_n0(uw_get_frames));
+  reg_fun(intern(lit("find-frame"), user_package), func_n2o(uw_find_frame, 0));
   reg_fun(intern(lit("invoke-catch"), user_package),
           func_n2v(uw_invoke_catch));
 }
diff --git a/unwind.h b/unwind.h
index 3dc9c387..97d1026a 100644
--- a/unwind.h
+++ b/unwind.h
@@ -127,6 +127,7 @@ void uw_pop_until(uw_frame_t *);
 uw_frame_t *uw_current_frame(void);
 uw_frame_t *uw_current_exit_point(void);
 val uw_get_frames(void);
+val uw_find_frame(val extype, val frtype);
 val uw_invoke_catch(val catch_frame, val sym, struct args *);
 void uw_init(void);
 void uw_late_init(void);