diff options
| -rw-r--r-- | share/txr/stdlib/struct.tl | 4 | ||||
| -rw-r--r-- | struct.c | 25 | ||||
| -rw-r--r-- | struct.h | 1 | ||||
| -rw-r--r-- | tests/012/oop.expected | 3 | ||||
| -rw-r--r-- | tests/012/oop.tl | 10 | ||||
| -rw-r--r-- | txr.1 | 90 |
6 files changed, 115 insertions, 18 deletions
diff --git a/share/txr/stdlib/struct.tl b/share/txr/stdlib/struct.tl index 9f643662..ecd1db5d 100644 --- a/share/txr/stdlib/struct.tl +++ b/share/txr/stdlib/struct.tl @@ -230,8 +230,8 @@ (list ,*args))))) (atom ^(make-lazy-struct ',atom (lambda () (list (list ,*qpairs)))))))) -(defmacro meth (obj slot) - ^(method ,obj ',slot)) +(defmacro meth (obj slot . bound-args) + ^[(fun method) ,obj ',slot ,*bound-args]) (defmacro usl (slot) ^(uslot ',slot)) @@ -151,7 +151,7 @@ void struct_init(void) reg_fun(intern(lit("static-slot-p"), user_package), func_n2(static_slot_p)); reg_fun(intern(lit("structp"), user_package), func_n1(structp)); 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("method"), user_package), func_n2v(method_args)); reg_fun(intern(lit("super-method"), user_package), func_n2(super_method)); reg_fun(intern(lit("uslot"), user_package), func_n1(uslot)); reg_fun(intern(lit("umethod"), user_package), func_n1v(umethod)); @@ -1106,11 +1106,34 @@ static val method_fun(val env, varg args) return generic_funcall(fun, args_copy); } +static val method_args_fun(val env, varg args) +{ + cons_bind (curried_args, fun_strct, env); + cons_bind (fun, strct, fun_strct); + cnum ca_len = c_num(length(curried_args)); + args_decl(args_call, max(args->fill + 1 + ca_len, ARGS_MIN)); + args_add(args_call, strct); + args_add_list(args_call, curried_args); + args_normalize(args_call, ca_len + 1); + args_cat_zap(args_call, args); + return generic_funcall(fun, args_call); +} + val method(val strct, val slotsym) { return func_f0v(cons(slot(strct, slotsym), strct), method_fun); } +val method_args(val strct, val slotsym, struct args *args) +{ + if (!args_more(args, 0)) + return func_f0v(cons(slot(strct, slotsym), strct), method_fun); + else + return func_f0v(cons(args_get_list(args), + cons(slot(strct, slotsym), strct)), method_args_fun); +} + + val super_method(val strct, val slotsym) { val super_slot = static_slot(super(struct_type(strct)), slotsym); @@ -50,6 +50,7 @@ val static_slot_p(val type, val sym); val structp(val obj); val struct_type(val strct); val method(val strct, val slotsym); +val method_args(val strct, val slotsym, struct args *); val super_method(val strct, val slotsym); val uslot(val slot); val umethod(val slot, struct args *); diff --git a/tests/012/oop.expected b/tests/012/oop.expected index 433a51d2..970434d9 100644 --- a/tests/012/oop.expected +++ b/tests/012/oop.expected @@ -12,6 +12,9 @@ canine collie poodle colliecanine +collie +collie +collie #S(b a 1 b 2 c 3) #S(d a nil b -2 c 3) (10 20 300 42 42) diff --git a/tests/012/oop.tl b/tests/012/oop.tl index 52fe30bb..34808af2 100644 --- a/tests/012/oop.tl +++ b/tests/012/oop.tl @@ -43,6 +43,16 @@ (mapcar (umeth print *stdout*) (list (new collie) (new dog))) (put-line) +(let* ((ssl (gun (make-string-output-stream))) + (s1 (pop ssl)) + (s2 (pop ssl)) + (s3 (pop ssl)) + (d (new collie))) + [(meth d print s1)] + [(meth d print s2)] + [(meth d print s3)] + (tprint [mapcar get-string-from-stream (list s1 s2 s3)])) + (defstruct b nil (:instance a 1) (:instance b 2) @@ -20889,11 +20889,16 @@ leftmost argument, so that the function has access to the object. .coNP Macro @ meth .synb -.mets (meth < struct << slot ) +.mets (meth < struct < slot << curried-expr *) .syne .desc The .code meth +macro allows indirection upon a method-like function stored +in a function slot. + +The +.code meth macro binds .meta struct as the leftmost argument of the function stored in @@ -20903,16 +20908,49 @@ That is to say, it returns a function .meta f such that .cblk -.meti >> ( f < arg ... ) +.meti >> [ f < arg ... ] .cble calls .cblk -.meti >> ( struct.slot < struct < arg ... ) +.meti >> [ struct.slot < struct < arg ... ] .cble except that .meta struct is evaluated only once. +If one or more +.meta curried-expr +expressions are present, their values are bound inside +.meta f +also, and when +.meta f +is invoked, these are passed to the function stored in the slot. +Thus if +.meta f +is produced by +.code "(meth struct slot c1 c2 c3 ...)" +then +.cblk +.meti >> [ f < arg ... ] +.cble +calls +.cblk +.meti >> [ struct.slot < struct < c1v < c2v < c3v ... arg ... ] +.cble +.cble +except that +.meta struct +is evaluated only once, and +.metn c1v , +.meta c2v +and +.meta c3v +are the values of expressions +.codn c1 , +.code c2 +and +.codn c3 . + The argument .meta struct must be an expression which evaluates to a struct. @@ -20927,10 +20965,20 @@ function: (meth a b) <--> (method a 'b) .cble -The -.code meth -macro allows indirection upon a method-like function stored -in a function slot. +If +.meta curried-arg +expressions are present, the translation may be be understood +as: + +.cblk + (meth a b c1 c2 ...) <--> [(fun method) a 'b c1 c2 ...] +.cble + +In other words the +.meta curried-arg +expressions are evaluated under the +.code dwim +operator evaluation rules. .TP* Example: @@ -21547,14 +21595,20 @@ The return value is .coNP Function @ method .synb -.mets (method < struct-obj << slot-name ) +.mets (method < struct-obj < slot-name << curried-arg *) .syne .desc The .code method -function retrieves a function from a structure's slot -and binds that function's left argument to the -structure. +function retrieves a function +.meta m +from a structure's slot +and returns a new function which binds that function's +left argument. If +.meta curried-arg +arguments are present, then they are also stored in +the returned function. These are the +.IR "curried arguments" . The .meta struct-obj @@ -21564,13 +21618,19 @@ must be a symbol denoting a slot in that structure. The slot must hold a function of at least one argument. -The +The function +.meta f +which .code method -function returns a function which, when invoked, -calls the function previously retrieved from the object's +function returns, when invoked, +calls the function +.meta m +previously retrieved from the object's slot, passing to that function .meta struct-obj -as the leftmost argument, followed by the function's +as the leftmost argument, followed by the curried +arguments, followed by all of +.metn f 's own arguments. Note: the |