diff options
| -rw-r--r-- | share/txr/stdlib/struct.tl | 3 | ||||
| -rw-r--r-- | struct.c | 27 | ||||
| -rw-r--r-- | struct.h | 1 | ||||
| -rw-r--r-- | txr.1 | 81 |
4 files changed, 112 insertions, 0 deletions
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)) @@ -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); @@ -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); @@ -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 ) |