diff options
| -rw-r--r-- | share/txr/stdlib/struct.tl | 41 | ||||
| -rw-r--r-- | struct.c | 51 | ||||
| -rw-r--r-- | struct.h | 7 |
3 files changed, 89 insertions, 10 deletions
diff --git a/share/txr/stdlib/struct.tl b/share/txr/stdlib/struct.tl index 7de81ae9..3605e7ee 100644 --- a/share/txr/stdlib/struct.tl +++ b/share/txr/stdlib/struct.tl @@ -136,6 +136,10 @@ (let ((arg-sym (gensym)) (type-sym (gensym))) (register-tentative-def ^(struct-type . ,name)) + (each ((s stat-slots)) + (register-tentative-def ^(sys:slot . ,s))) + (each ((s inst-slots)) + (register-tentative-def ^(sys:slot . ,s))) ^(sys:make-struct-type ',name ',super ',stat-slots ',inst-slots ,(if (or func-si-forms val-si-forms) @@ -186,28 +190,46 @@ (defmacro sys:struct-lit (name . plist) ^(sys:make-struct-lit ',name ',plist)) -(defmacro qref (:whole form obj . refs) +(defun sys:check-slot (form slot) + (unless (or (sys:slot-types slot) + (sys:static-slot-types slot)) + (compile-defr-warning form ^(sys:slot . ,slot) + "symbol ~s isn't the name of a struct slot" + slot)) + slot) + +(defmacro qref (:form form obj . refs) (when (null refs) (throwf 'eval-error "~s: bad syntax" 'qref)) (tree-case refs (() ()) (((dw sym . args)) - (if (eq dw 'dwim) ^[(slot ,obj ',sym) ,*args] :)) + (if (eq dw 'dwim) + ^[(slot ,obj ',(sys:check-slot form sym)) ,*args] + :)) (((dw sym . args) . more) - (if (eq dw 'dwim) ^(qref [(slot ,obj ',sym) ,*args] ,*more) :)) + (if (eq dw 'dwim) + ^(qref [(slot ,obj ',(sys:check-slot form sym)) ,*args] ,*more) + :)) (((sym . args)) (let ((osym (gensym))) + (sys:check-slot form sym) ^(slet ((,osym ,obj)) (call (slot ,osym ',sym) ,osym ,*args)))) (((sym . args) . more) (let ((osym (gensym))) + (sys:check-slot form sym) ^(qref (slet ((,osym ,obj)) (call (slot ,osym ',sym) ,osym ,*args)) ,*more))) - ((sym) ^(slot ,obj ',sym)) - ((sym . more) ^(qref (slot ,obj ',sym) ,*more)) + ((sym) + (sys:check-slot form sym) + ^(slot ,obj ',sym)) + ((sym . more) + (sys:check-slot form sym) + ^(qref (slot ,obj ',sym) ,*more)) (obj (throwf 'eval-error "~s: bad syntax: ~s" 'qref refs)))) -(defmacro uref (:whole form . args) +(defmacro uref (. args) (cond ((null args) (throwf 'eval-error "~s: bad syntax" 'uref)) ((null (cdr args)) @@ -241,10 +263,12 @@ (defmacro meth (obj slot . bound-args) ^[(fun method) ,obj ',slot ,*bound-args]) -(defmacro usl (slot) +(defmacro usl (:form form slot) + (sys:check-slot form slot) ^(uslot ',slot)) -(defmacro umeth (slot . bound-args) +(defmacro umeth (:form form slot . bound-args) + (sys:check-slot form slot) ^[(fun umethod) ',slot ,*bound-args]) (defun sys:defmeth (type-sym name fun) @@ -258,6 +282,7 @@ ((not (find-struct-type type-sym)) (compile-defr-warning form ^(struct-type . ,type-sym) "definition of struct ~s not seen here" type-sym))) + (register-tentative-def ^(sys:slot . ,name)) ^(sys:defmeth ',type-sym ',name (lambda ,arglist (block ,name ,*body)))) @@ -90,11 +90,14 @@ struct struct_inst { }; val struct_type_s, meth_s, print_s, make_struct_lit_s; +val slot_s, static_slot_s; static cnum struct_id_counter; static val struct_type_hash; static val slot_hash; static val struct_type_finalize_f; +static val slot_type_hash; +static val static_slot_type_hash; static val struct_type_finalize(val obj); static_forward(struct cobj_ops struct_type_ops); @@ -107,14 +110,20 @@ static val call_super_fun(val type, val sym, struct args *); void struct_init(void) { - protect(&struct_type_hash, &slot_hash, &struct_type_finalize_f, + protect(&struct_type_hash, &slot_hash, &slot_type_hash, + &static_slot_type_hash, &struct_type_finalize_f, convert(val *, 0)); struct_type_s = intern(lit("struct-type"), user_package); meth_s = intern(lit("meth"), user_package); print_s = intern(lit("print"), user_package); make_struct_lit_s = intern(lit("make-struct-lit"), system_package); + slot_s = intern(lit("slot"), system_package); + static_slot_s = intern(lit("static-slot"), system_package); struct_type_hash = make_hash(nil, nil, nil); slot_hash = make_hash(nil, nil, t); + slot_type_hash = make_hash(nil, nil, nil); + slot_type_hash = make_hash(nil, nil, nil); + static_slot_type_hash = make_hash(nil, nil, nil); struct_type_finalize_f = func_n1(struct_type_finalize); if (opt_compat && opt_compat <= 117) @@ -167,6 +176,8 @@ void struct_init(void) reg_fun(intern(lit("uslot"), user_package), func_n1(uslot)); reg_fun(intern(lit("umethod"), user_package), func_n1v(umethod)); reg_fun(intern(lit("slots"), user_package), func_n1(slots)); + reg_fun(intern(lit("slot-types"), system_package), func_n1(slot_types)); + reg_fun(intern(lit("static-slot-types"), system_package), func_n1(static_slot_types)); } static noreturn void no_such_struct(val ctx, val sym) @@ -326,8 +337,10 @@ val make_struct_type(val name, val super, ss->store = nil; } sethash(slot_hash, cons(slot, id), num(n + STATIC_SLOT_BASE)); + static_slot_type_reg(slot, name); } else { sethash(slot_hash, cons(slot, id), num_fast(sl++)); + slot_type_reg(slot, name); } if (sl >= STATIC_SLOT_BASE) @@ -1103,6 +1116,7 @@ static val static_slot_ens_rec(val stype, val sym, val newval, sethash(slot_hash, cons(sym, num_fast(st->id)), num(st->nstslots++ + STATIC_SLOT_BASE)); + static_slot_type_reg(sym, st->name); } { @@ -1545,6 +1559,41 @@ val get_slot_syms(val package, val is_current, val method_only) return result_hash; } +val slot_types(val slot) +{ + return gethash(slot_type_hash, slot); +} + +val static_slot_types(val slot) +{ + return gethash(static_slot_type_hash, slot); +} + +val slot_type_reg(val slot, val strct) +{ + val typelist = gethash(slot_type_hash, slot); + + if (!memq(strct, typelist)) { + sethash(slot_type_hash, slot, cons(strct, typelist)); + uw_purge_deferred_warning(cons(slot_s, slot)); + } + + return slot; +} + +val static_slot_type_reg(val slot, val strct) +{ + val typelist = gethash(static_slot_type_hash, slot); + + if (!memq(strct, typelist)) { + sethash(slot_type_hash, slot, cons(strct, typelist)); + uw_purge_deferred_warning(cons(static_slot_s, slot)); + uw_purge_deferred_warning(cons(slot_s, slot)); + } + + return slot; +} + static_def(struct cobj_ops struct_type_ops = cobj_ops_init(eq, struct_type_print, struct_type_destroy, struct_type_mark, cobj_hash_op)) @@ -25,7 +25,8 @@ * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ -extern val struct_type_s, meth_s, make_struct_lit_s; +extern val struct_type_s, meth_s, print_s, make_struct_lit_s; +extern val slot_s, static_slot_s; val make_struct_type(val name, val super, val static_slots, val slots, val static_initfun, val initfun, val boactor, @@ -64,4 +65,8 @@ val uslot(val slot); val umethod(val slot, struct args *); val method_name(val fun); val get_slot_syms(val package, val is_current, val method_only); +val slot_types(val slot); +val static_slot_types(val slot); +val slot_type_reg(val slot, val strct); +val static_slot_type_reg(val slot, val strct); void struct_init(void); |