From f55a50575bfe83ad320612833811640e5d8f8f12 Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Sat, 3 Oct 2015 17:16:51 -0700
Subject: New umeth and umethod macro and function.

* share/txr/stdlib/struct.tl (umeth): New macro.

* struct.c (struct_init): Registered umethod intrinsic.
(umethod_fun): New static function.
(umethod): New function.

* txr.1: Documented.
---
 share/txr/stdlib/struct.tl |  3 ++
 struct.c                   | 27 ++++++++++++++++
 struct.h                   |  1 +
 txr.1                      | 81 ++++++++++++++++++++++++++++++++++++++++++++++
 4 files changed, 112 insertions(+)

diff --git a/share/txr/stdlib/struct.tl b/share/txr/stdlib/struct.tl
index ce3f156e..fb9365f2 100644
--- a/share/txr/stdlib/struct.tl
+++ b/share/txr/stdlib/struct.tl
@@ -175,3 +175,6 @@
 
 (defmacro meth (obj slot)
   ^(method ,obj ',slot))
+
+(defmacro umeth (slot)
+  ^(umethod ',slot))
diff --git a/struct.c b/struct.c
index 30f0ad15..1456b3b1 100644
--- a/struct.c
+++ b/struct.c
@@ -126,6 +126,7 @@ void struct_init(void)
   reg_fun(intern(lit("struct-type"), user_package), func_n1(struct_type));
   reg_fun(intern(lit("method"), user_package), func_n2(method));
   reg_fun(intern(lit("super-method"), user_package), func_n2(super_method));
+  reg_fun(intern(lit("umethod"), user_package), func_n1(umethod));
 }
 
 static noreturn void no_such_struct(val ctx, val sym)
@@ -691,6 +692,32 @@ val super_method(val strct, val slotsym)
   return func_f0v(cons(super_slot, strct), method_fun);
 }
 
+static val umethod_fun(val sym, struct args *args)
+{
+  val self = lit("umethod");
+
+  if (args->argc == 0) {
+    uw_throwf(error_s, lit("~a: object argument required to call ~s"),
+              self, env, nao);
+  } else {
+    val strct = args->arg[0];
+    struct struct_inst *si = struct_handle(strct, self);
+
+    if (symbolp(sym)) {
+      loc ptr = lookup_slot(strct, si, sym);
+      if (!nullocp(ptr))
+        return generic_funcall(deref(ptr), args);
+    }
+
+    no_such_slot(self, si->type, sym);
+  }
+}
+
+val umethod(val slot)
+{
+  return func_f0v(slot, umethod_fun);
+}
+
 static void struct_inst_print(val obj, val out, val pretty)
 {
   struct struct_inst *si = coerce(struct struct_inst *, obj->co.handle);
diff --git a/struct.h b/struct.h
index 7e4009c3..612c47db 100644
--- a/struct.h
+++ b/struct.h
@@ -43,4 +43,5 @@ val structp(val obj);
 val struct_type(val strct);
 val method(val strct, val slotsym);
 val super_method(val strct, val slotsym);
+val umethod(val slot);
 void struct_init(void);
diff --git a/txr.1 b/txr.1
index 2fbad601..0300f7c7 100644
--- a/txr.1
+++ b/txr.1
@@ -18250,6 +18250,56 @@ in a function slot.
                  increment #<function: type 0>)
 .cble
 
+.coNP Macro @ umeth
+.synb
+.mets (umeth << slot )
+.syne
+.desc
+The
+.code umeth
+macro binds the symbol
+.meta slot
+to a function and returns that function.
+
+When that function is called, it expects at least one argument.
+The leftmost argument must be an object of struct type.
+
+The slot named
+.meta slot
+is retrieved from that object, and is expected to be a function.
+That function is called with the same arguments.
+
+The syntax can be understood as a translation to a call of the
+.code umethod
+function:
+
+.cblk
+  (umeth s)  <-->  (umethod 's)
+.cble
+
+The macro merely provides the syntactic sugar of not having to quote the
+symbol.
+
+.TP* Example:
+
+.cblk
+   ;; seal and dog are variables which hold structures of
+   ;; different types. Both have a method called bark.
+
+   (let ((bark-fun (umeth bark)))
+     (bark-fun dog)     ;; same effect as dog.(bark)
+     (bark-fun seal))   ;; same effect as seal.(bark)
+.cble
+
+The
+.code u
+in
+.code umeth
+stands for "unbound". The function produced by
+.code umeth
+is not bound to any specific object; it binds to an object whenever it is
+invoked by retrieving the actual method from the object's slot at call time.
+
 .coNP Function @ make-struct-type
 .synb
 .mets (make-struct-type < name < super < static-slots < slots
@@ -18610,6 +18660,37 @@ the supertype's static slot, passing to that function
 as the leftmost argument, followed by the function's
 own arguments.
 
+.coNP Function @ umethod
+.synb
+.mets (umethod << slot-name )
+.syne
+.desc
+The
+.code umethod
+returns a function which represents the set of all methods named by
+the slot
+.meta slot-name
+in all structure types, including ones not yet defined.
+The
+.meta slot-name
+argument must be a symbol.
+
+This function must be called with at least one argument. The leftmost
+argument must be an object of structure type, which has a slot named
+.meta slot-name .
+The function will retrieve the value of the slot from that object,
+expecting it to be a function, and calls it, passing to it all of its
+arguments.
+
+Note: the
+.code umethod
+name stands for "unbound method". Unlike the
+.code method
+function,
+.code umethod
+doesn't return a method whose leftmost argument is already bound to
+an object; the binding occurs at call time.
+
 .coNP Function @ slot-p
 .synb
 .mets (slot-p < type << name )
-- 
cgit v1.2.3