diff options
| -rw-r--r-- | lib.c | 2 | ||||
| -rw-r--r-- | share/txr/stdlib/struct.tl | 21 | ||||
| -rw-r--r-- | struct.c | 26 | ||||
| -rw-r--r-- | struct.h | 3 | ||||
| -rw-r--r-- | sysif.c | 7 | ||||
| -rw-r--r-- | tests/012/struct.tl | 3 | ||||
| -rw-r--r-- | txr.1 | 87 | ||||
| -rw-r--r-- | unwind.c | 6 |
8 files changed, 137 insertions, 18 deletions
@@ -8725,7 +8725,7 @@ static void time_init(void) make_struct_type(time_s, nil, nil, list(year_s, month_s, day_s, - hour_s, min_s, sec_s, dst_s, nao), nil, nil, nil); + hour_s, min_s, sec_s, dst_s, nao), nil, nil, nil, nil); } void init(const wchar_t *pn, mem_t *(*oom)(mem_t *, size_t), diff --git a/share/txr/stdlib/struct.tl b/share/txr/stdlib/struct.tl index 189785fc..c9d19e91 100644 --- a/share/txr/stdlib/struct.tl +++ b/share/txr/stdlib/struct.tl @@ -43,7 +43,9 @@ (throwf 'eval-error "~s: ~s isn't a bindable symbol" 'defstruct name)) (unless (proper-listp slot-specs) (throwf 'eval-error "~s: bad slot syntax" 'defstruct)) - (let* ((instance-init-form nil) (instance-fini-form nil) + (let* ((instance-init-form nil) + (instance-postinit-form nil) + (instance-fini-form nil) (slot-init-forms (collect-each ((slot slot-specs)) (tree-case slot ((word name args . body) @@ -78,6 +80,16 @@ (set instance-init-form (cons arg body)) ^(,word nil nil)) + (:postinit + (unless (bindable arg) + (sys:bad-slot-syntax slot)) + (when instance-postinit-form + (throw 'eval-error + "~s: duplicate :postinit" + 'defstruct)) + (set instance-postinit-form + (cons arg body)) + ^(,word nil nil)) (:fini (unless (bindable arg) (sys:bad-slot-syntax slot)) @@ -153,7 +165,12 @@ req-args r-gens) ,*(mapcar (ret ^(if ,@3 (slotset ,arg-sym ',@1 ,@2))) - opt-args o-gens p-gens))))))))))) + opt-args o-gens p-gens)))))) + ,(if instance-postinit-form + ^(lambda (,arg-sym) + ,*(if (cdr instance-postinit-form) + ^((let ((,(car instance-postinit-form) ,arg-sym)) + ,*(cdr instance-postinit-form))))))))))) (defmacro sys:struct-lit (name . plist) ^(make-struct ',name ',plist)) @@ -63,6 +63,7 @@ struct struct_type { val stinitfun; val initfun; val boactor; + val postinitfun; val dvtypes; val *stslot; }; @@ -105,10 +106,10 @@ void struct_init(void) func_n5(make_struct_type_compat)); else reg_fun(intern(lit("make-struct-type"), user_package), - func_n7(make_struct_type)); + func_n8o(make_struct_type, 7)); reg_fun(intern(lit("make-struct-type"), system_package), - func_n7(make_struct_type)); + func_n8(make_struct_type)); reg_fun(intern(lit("find-struct-type"), user_package), func_n1(find_struct_type)); reg_fun(intern(lit("struct-type-p"), user_package), func_n1(struct_type_p)); @@ -197,7 +198,8 @@ static struct struct_type *stype_handle(val *pobj, val ctx) val make_struct_type(val name, val super, val static_slots, val slots, - val static_initfun, val initfun, val boactor) + val static_initfun, val initfun, val boactor, + val postinitfun) { val self = lit("make-struct-type"); @@ -244,6 +246,7 @@ val make_struct_type(val name, val super, st->stinitfun = static_initfun; st->initfun = initfun; st->boactor = boactor; + st->postinitfun = default_bool_arg(postinitfun); st->dvtypes = nil; gc_finalize(stype, struct_type_finalize_f, nil); @@ -290,7 +293,7 @@ val make_struct_type(val name, val super, static val make_struct_type_compat(val name, val super, val slots, val initfun, val boactor) { - return make_struct_type(name, super, nil, slots, nil, initfun, boactor); + return make_struct_type(name, super, nil, slots, nil, initfun, boactor, nil); } val find_struct_type(val sym) @@ -338,6 +341,7 @@ static void struct_type_mark(val obj) gc_mark(st->stinitfun); gc_mark(st->initfun); gc_mark(st->boactor); + gc_mark(st->postinitfun); gc_mark(st->dvtypes); for (stsl = 0; stsl < st->nstslots; stsl++) @@ -354,6 +358,16 @@ static void call_initfun_chain(struct struct_type *st, val strct) } } +static void call_postinitfun_chain(struct struct_type *st, val strct) +{ + if (st) { + if (st->postinitfun) + funcall1(st->postinitfun, strct); + if (st->super) + call_postinitfun_chain(st->super_handle, strct); + } +} + val make_struct(val type, val plist, struct args *args) { val self = lit("make-struct"); @@ -395,6 +409,8 @@ val make_struct(val type, val plist, struct args *args) generic_funcall(st->boactor, args_copy); } + call_postinitfun_chain(st, sinst); + inited = t; uw_unwind { @@ -436,6 +452,8 @@ static void lazy_struct_init(val sinst, struct struct_inst *si) generic_funcall(st->boactor, argv); } + call_postinitfun_chain(st, sinst); + inited = t; uw_unwind { @@ -27,7 +27,8 @@ extern val struct_type_s, meth_s; val make_struct_type(val name, val super, val static_slots, val slots, - val static_initfun, val initfun, val boactor); + val static_initfun, val initfun, val boactor, + val postinitfun); val struct_type_p(val obj); val super(val type); val make_struct(val type, val plist, struct args *); @@ -1173,15 +1173,16 @@ void sysif_init(void) make_struct_type(stat_s, nil, nil, list(dev_s, ino_s, mode_s, nlink_s, uid_s, gid_s, rdev_s, size_s, blksize_s, blocks_s, atime_s, - mtime_s, ctime_s, nao), nil, nil, nil); + mtime_s, ctime_s, nao), nil, nil, nil, nil); #if HAVE_PWUID make_struct_type(passwd_s, nil, nil, list(name_s, passwd_s, uid_s, gid_s, - gecos_s, dir_s, shell_s, nao), nil, nil, nil); + gecos_s, dir_s, shell_s, nao), nil, nil, nil, nil); #endif #if HAVE_GRGID make_struct_type(group_s, nil, nil, - list(name_s, passwd_s, gid_s, mem_s, nao), nil, nil, nil); + list(name_s, passwd_s, gid_s, mem_s, nao), + nil, nil, nil, nil); #endif reg_fun(intern(lit("errno"), user_package), func_n1o(errno_wrap, 0)); diff --git a/tests/012/struct.tl b/tests/012/struct.tl index cc4bd79b..e7c025f4 100644 --- a/tests/012/struct.tl +++ b/tests/012/struct.tl @@ -84,7 +84,8 @@ \ (slotset #:g0004 'x\n \ \ #:g0006)\n \ \ (slotset #:g0004 'y\n \ - \ #:g0007)))") + \ #:g0007))\n \ + \ ())") (defstruct (boa x y) nil (x 0) (y 0)) @@ -18693,6 +18693,20 @@ code of a base structure type, if any, is executed before any initializations specific to a derived structure type. +The +.code :init +initializations are executed before any other +slot initializations. The argument values passed to the +.code new +or +.code lnew +operator or the +.code make-struct +function are not yet stored in the object's slots, +and are not accessible. Initialization code which needs +these values to be stable can be defined with +.codn :postinit . + Initializers in base structures must be careful about assumptions about slot kinds, because derived structures can alter static slots to instance slots or vice versa. To avoid an unwanted initialization being applied to the @@ -18711,6 +18725,35 @@ of an specifier are not surrounded by an implicit .codn block . +.meIP (:postinit <> ( param ) << body-form *) +The +.code :postinit +specifier is very similar to +.codn :init . +There are two differences. The first difference +is that +.codn body-form -s +are evaluated after other initializations have taken +place. The argument material from the +.codn make-struct , +.code new +or +.code lnew +invocation has already been processed and stored +into slots. +The second difference is that +.code :postinit +actions registered at different levels of the type's +inheritance hierarchy are invoked in the opposite +order compared to +.code :init +action. The +.code :postinit +specific to a derived struct type is called before +the +.code :postinit +of its base type. + .meIP (:fini <> ( param ) << body-form *) The .code :fini @@ -19280,6 +19323,7 @@ slot to an object takes place whenever the function is called. .synb .mets (make-struct-type < name < super < static-slots < slots .mets \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ < static-initfun < initfun << boactor ) +.mets \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ < boactor << postinitfun ) .syne .desc The @@ -19374,7 +19418,15 @@ so that the root supertype's .meta initfun is called first and the structure's own specific .meta initfun -is called last. Each function is passed the newly created structure +is called last. These calls occur before the slots are initialized +from the +.meta arg +arguments +or the +.meta slot-init-plist +of +.codn make-struct . +Each function is passed the newly created structure object, and may alter its slots. The @@ -19390,9 +19442,38 @@ is invoked, with the structure as the leftmost argument, and the boa arguments as additional arguments. This takes place after the processing of .meta initfun -functions. The +functions, and after the processing of the +.meta slot-init-plist +specified in the +.code make-struct +call. Note that the .meta boactor -functions of the supertypes are not called. +functions of the supertypes are not called, only the +.meta boactor +specific to the type being constructed. + +The +.meta postinitfun +argument either specifies an initialization function, or is +.codn nil , +which is equivalent to specifying a function which does nothing. +If specified, this function must accept one argument. +The +.meta postinitfun +function is similar to +.metn initfun . +The difference is that +.meta postinitfun +functions are called after all other initialization processing, +rather than before. Unlike +.meta initfun +functions, they are also called in the opposite +in order of inheritance, so that the structure type's +own specific +.meta postinitfun +is called first, and root supertype's +.meta initfun +is called last. .coNP Function @ find-struct-type .synb @@ -873,17 +873,17 @@ void uw_late_init(void) sys_cont_poison_s = intern(lit("cont-poison"), system_package); sys_cont_free_s = intern(lit("cont-free"), system_package); frame_type = make_struct_type(intern(lit("frame"), user_package), - nil, nil, nil, nil, nil, nil); + nil, nil, nil, nil, nil, nil, nil); catch_frame_type = make_struct_type(intern(lit("catch-frame"), user_package), frame_type, nil, list(types_s, jump_s, nao), - nil, nil, nil); + nil, nil, nil, nil); handle_frame_type = make_struct_type(intern(lit("handle-frame"), user_package), frame_type, nil, list(types_s, fun_s, nao), - nil, nil, nil); + nil, nil, nil, nil); 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)); |