diff options
| -rw-r--r-- | share/txr/stdlib/struct.tl | 7 | ||||
| -rw-r--r-- | struct.c | 46 | ||||
| -rw-r--r-- | struct.h | 1 | ||||
| -rw-r--r-- | txr.1 | 81 |
4 files changed, 135 insertions, 0 deletions
diff --git a/share/txr/stdlib/struct.tl b/share/txr/stdlib/struct.tl index 7213d9eb..34e9bb07 100644 --- a/share/txr/stdlib/struct.tl +++ b/share/txr/stdlib/struct.tl @@ -193,3 +193,10 @@ (defmacro umeth (slot) ^(umethod ',slot)) + +(defmacro defmeth (type-sym name arglist . body) + ^(progn + (static-slot-ensure (find-struct-type ',type-sym) ',name + (lambda ,arglist + (block ,name ,*body))) + ',name)) @@ -62,6 +62,7 @@ struct struct_type { val stinitfun; val initfun; val boactor; + val dvtypes; val *stslot; }; @@ -119,6 +120,8 @@ void struct_init(void) reg_fun(intern(lit("static-slot"), user_package), func_n2(static_slot)); reg_fun(intern(lit("static-slot-set"), user_package), func_n3(static_slot_set)); + reg_fun(intern(lit("static-slot-ensure"), user_package), + func_n4o(static_slot_ensure, 3)); reg_fun(intern(lit("call-super-method"), user_package), func_n2v(call_super_method)); reg_fun(intern(lit("call-super-fun"), user_package), @@ -211,6 +214,7 @@ val make_struct_type(val name, val super, st->stinitfun = static_initfun; st->initfun = initfun; st->boactor = boactor; + st->dvtypes = nil; gc_finalize(stype, struct_type_finalize_f, nil); @@ -241,6 +245,9 @@ val make_struct_type(val name, val super, sethash(struct_type_hash, name, stype); + if (super) + mpush(stype, mkloc(su->dvtypes, super)); + call_stinitfun_chain(st, stype); return stype; @@ -305,6 +312,7 @@ static void struct_type_mark(val obj) gc_mark(st->stinitfun); gc_mark(st->initfun); gc_mark(st->boactor); + gc_mark(st->dvtypes); for (stsl = 0; stsl < st->nstslots; stsl++) gc_mark(st->stslot[stsl]); @@ -657,6 +665,44 @@ val static_slot_set(val stype, val sym, val newval) no_such_slot(lit("static-slot-set"), stype, sym); } +val static_slot_ensure(val stype, val sym, val newval, val no_error_p) +{ + val self = lit("static-slot-ensure"); + struct struct_type *st = coerce(struct struct_type *, + cobj_handle(stype, struct_type_s)); + + if (!bindable(sym)) + uw_throwf(error_s, lit("~a: ~s isn't a valid slot name"), + self, sym, nao); + + no_error_p = default_bool_arg(no_error_p); + + { + loc ptr = lookup_static_slot(stype, st, sym); + if (!nullocp(ptr)) + return set(ptr, newval); + } + + if (!no_error_p && memq(sym, st->slots)) + uw_throwf(error_s, lit("~a: ~s is an instance slot of ~s"), + self, sym, stype, nao); + + st->stslot = coerce(val *, chk_realloc(coerce(mem_t *, st->stslot), + sizeof *st->stslot * (st->nstslots + 1))); + st->stslot[st->nstslots] = newval; + set(mkloc(st->slots, stype), append2(st->slots, cons(sym, nil))); + sethash(slot_hash, cons(sym, num_fast(st->id)), + num(st->nstslots++ + STATIC_SLOT_BASE)); + + { + val iter; + for (iter = st->dvtypes; iter; iter = cdr(iter)) + static_slot_ensure(car(iter), sym, newval, t); + } + + return newval; +} + static val call_super_method(val inst, val sym, struct args *args) { val type = struct_type(inst); @@ -40,6 +40,7 @@ val slot(val strct, val sym); val slotset(val strct, val sym, val newval); val static_slot(val stype, val sym); val static_slot_set(val stype, val sym, val newval); +val static_slot_ensure(val stype, val sym, val newval, val no_error_p); val slotp(val type, val sym); val static_slot_p(val type, val sym); val structp(val obj); @@ -18246,6 +18246,40 @@ syntax. (new (point 1) x 5 y 5) -> #S(point x 1 y 5) .cble +.coNP Macro @ defmeth +.synb +.mets (defmeth < type-name < name <> param-list << body-form *) +.syne +.desc +The +.code defmeth +macro installs a function into the static slot named by the symbol +.meta name +in the struct type indicated by +.metn type-name . + +If the structure type doesn't already have such a static slot, it is +first added, as if by the +.code static-slot-ensure +function, subject to the same checks. + +If the function has at least one argument, it can be used as a method. In that +situation, the leftmost argument passes the structure instance on which the +method is being invoked. + +The function takes the arguments specified +by the +.meta param-list +symbols, and its body consists of the +.metn body-form -s. + +The +.metn body-form -s +are placed into a +.code block +named +.codn name . + .coNP Macro @ new .synb .mets (new >> { name | >> ( name << arg *)} >> { slot << init-form }*) @@ -19108,6 +19142,53 @@ argument must be a structure type, and .meta name must be a static slot of this type. +.coNP Function @ static-slot-ensure +.synb +.mets (static-slot-ensure < type < name < new-value <> [ no-error-p ]) +.syne +.desc +The +.code static-slot-ensure +function is similar to +.codn static-slot-set . + +It +.meta new-value +into the static slot named by symbol +.meta name +of the structure type +.metn type , +if there already exists such a static slot. + +If the slot does not exist, it is first added to +the struct type, provided that +.meta name +is a bindable symbol. Moreover, +the struct type must not already have +an instance slot by that name, +unless the +.meta no-error-p +parameter is specified and true. +If the +.meta no-error-p +parameter is true, then the function does +not throw an error and does not create a +static slot. + +The function returns +.metn new-value . + +Note: if structure types already exist which are derived from +.metn type , +.code static-slot-ensure +is recursively invoked on each derived type to ensure that these +types also have this static slot and it is given the specified value. The +.meta no-error-p +parameter is +.code nil +in these recursive calls, so that the static slot is only added +to those structures which do not already have an instance slot. + .coNP Function @ call-super-method .synb .mets (call-super-method < struct-obj < name << argument *) |