diff options
| -rw-r--r-- | Makefile | 2 | ||||
| -rw-r--r-- | args.c | 9 | ||||
| -rw-r--r-- | args.h | 1 | ||||
| -rw-r--r-- | eval.c | 3 | ||||
| -rw-r--r-- | eval.h | 2 | ||||
| -rw-r--r-- | gc.c | 5 | ||||
| -rw-r--r-- | lib.c | 5 | ||||
| -rw-r--r-- | lib.h | 6 | ||||
| -rw-r--r-- | lisplib.c | 24 | ||||
| -rw-r--r-- | parser.l | 5 | ||||
| -rw-r--r-- | parser.y | 23 | ||||
| -rw-r--r-- | share/txr/stdlib/place.tl | 11 | ||||
| -rw-r--r-- | share/txr/stdlib/struct.tl | 57 | ||||
| -rw-r--r-- | struct.c | 450 | ||||
| -rw-r--r-- | struct.h | 39 |
15 files changed, 636 insertions, 6 deletions
@@ -47,7 +47,7 @@ EXTRA_OBJS-y := OBJS := txr.o lex.yy.o y.tab.o match.o lib.o regex.o gc.o unwind.o stream.o OBJS += arith.o hash.o utf8.o filter.o eval.o parser.o rand.o combi.o sysif.o -OBJS += args.o lisplib.o cadr.o +OBJS += args.o lisplib.o cadr.o struct.o OBJS-$(debug_support) += debug.o OBJS-$(have_syslog) += syslog.o OBJS-$(have_glob) += glob.o @@ -87,6 +87,15 @@ struct args *args_copy_zap(struct args *to, struct args *from) return to; } +struct args *args_cat_zap(struct args *to, struct args *from) +{ + to->list = from->list; + memcpy(to->arg + to->fill, from->arg, sizeof *from->arg * from->fill); + to->fill += from->fill; + memset(from->arg, 0, sizeof *to->arg * to->fill); + return to; +} + val args_copy_to_list(struct args *args) { list_collect_decl (out, ptail); @@ -163,4 +163,5 @@ INLINE void args_clear(struct args *args) val args_get_checked(val name, struct args *args, cnum *arg_index); struct args *args_copy(struct args *to, struct args *from); struct args *args_copy_zap(struct args *to, struct args *from); +struct args *args_cat_zap(struct args *to, struct args *from); val args_copy_to_list(struct args *args); @@ -90,7 +90,7 @@ val gen_s, gun_s, generate_s, rest_s, plus_s; val promise_s, promise_forced_s, promise_inprogress_s, force_s; val op_s, ap_s, identity_s, apf_s, ipf_s; val ret_s, aret_s; -val hash_lit_s, hash_construct_s, qref_s; +val hash_lit_s, hash_construct_s, struct_lit_s, qref_s; val vector_lit_s, vector_list_s; val macro_time_s, with_saved_vars_s, macrolet_s; val defsymacro_s, symacrolet_s, prof_s; @@ -4018,6 +4018,7 @@ void eval_init(void) rest_s = intern(lit("rest"), user_package); hash_lit_s = intern(lit("hash-construct"), system_package); hash_construct_s = intern(lit("hash-construct"), user_package); + struct_lit_s = intern(lit("struct-lit"), system_package); qref_s = intern(lit("qref"), user_package); vector_lit_s = intern(lit("vector-lit"), system_package); vector_list_s = intern(lit("vector-list"), user_package); @@ -25,7 +25,7 @@ */ extern val dwim_s, lambda_s, vector_lit_s, vector_list_s; -extern val hash_lit_s, hash_construct_s, qref_s; +extern val hash_lit_s, hash_construct_s, struct_lit_s, qref_s; extern val eval_error_s; extern val last_form_evaled, last_form_expanded; @@ -236,7 +236,6 @@ static void finalize(val obj) case CHR: case NUM: case LIT: - case SYM: case PKG: case FUN: case LCONS: @@ -244,6 +243,10 @@ static void finalize(val obj) case ENV: case FLNUM: return; + case SYM: + free(obj->s.slot_cache); + obj->s.slot_cache = 0; + return; case STR: free(obj->st.str); obj->st.str = 0; @@ -64,6 +64,7 @@ #include "syslog.h" #include "glob.h" #include "cadr.h" +#include "struct.h" #include "txr.h" #define max(a, b) ((a) > (b) ? (a) : (b)) @@ -3728,6 +3729,7 @@ val make_sym(val name) obj->s.type = SYM; obj->s.name = name; obj->s.package = nil; + obj->s.slot_cache = 0; return obj; } @@ -6560,6 +6562,8 @@ val copy(val seq) return copy_hash(seq); if (seq->co.cls == random_state_s) return make_random_state(seq); + if (structp(seq)) + return copy_struct(seq); /* fallthrough */ default: type_mismatch(lit("copy: cannot copy object of type ~s"), @@ -7660,6 +7664,7 @@ void init(const wchar_t *pn, mem_t *(*oom)(mem_t *, size_t), glob_init(); #endif cadr_init(); + struct_init(); gc_state(gc_save); } @@ -99,10 +99,16 @@ struct string { val alloc; }; +#define SLOT_CACHE_SIZE 32 + +typedef cnum slot_cache_line_t[2]; +typedef slot_cache_line_t *slot_cache_t; + struct sym { obj_common; val name; val package; + slot_cache_t slot_cache; }; struct package { @@ -166,6 +166,29 @@ static val path_test_instantiate(val set_fun) return nil; } +static val struct_set_entries(val dlt, val fun) +{ + val name[] = { + lit("defstruct"), lit("qref"), lit("new"), nil + }; + + set_dlt_entries(dlt, name, fun); + + if (fun) + sethash(dlt, struct_lit_s, fun); + else + remhash(dlt, struct_lit_s); + + return nil; +} + +static val struct_instantiate(val set_fun) +{ + funcall1(set_fun, nil); + load(format(nil, lit("~a/struct.tl"), stdlib_path, nao)); + return nil; +} + val dlt_register(val dlt, val (*instantiate)(val), val (*set_entries)(val, val)) @@ -183,6 +206,7 @@ void lisplib_init(void) dlt_register(dl_table, txr_case_instantiate, txr_case_set_entries); dlt_register(dl_table, with_resources_instantiate, with_resources_set_entries); dlt_register(dl_table, path_test_instantiate, path_test_set_entries); + dlt_register(dl_table, struct_instantiate, struct_set_entries); } val lisplib_try_load(val sym) @@ -679,6 +679,11 @@ UONLY {U2}{U}|{U3}{U}{U}|{U4}{U}{U}{U} return HASH_H; } +<NESTED,BRACED>#S { + yylval->lineno = yyextra->lineno; + return HASH_S; +} + <NESTED>\.\. { yylval->lineno = yyextra->lineno; return DOTDOT; @@ -26,6 +26,7 @@ %{ +#include <stddef.h> #include <stdio.h> #include <assert.h> #include <limits.h> @@ -36,6 +37,7 @@ #include <wchar.h> #include <signal.h> #include "config.h" +#include ALLOCA_H #include "lib.h" #include "signal.h" #include "unwind.h" @@ -43,9 +45,13 @@ #include "utf8.h" #include "match.h" #include "hash.h" +#include "struct.h" #include "eval.h" #include "stream.h" #include "y.tab.h" +#include "gc.h" +#include "args.h" +#include "cadr.h" #include "parser.h" static val sym_helper(parser_t *parser, wchar_t *lexeme, val meta_allowed); @@ -94,7 +100,7 @@ int yyparse(scanner_t *, parser_t *); %token <lineno> UNTIL COLL OUTPUT REPEAT REP SINGLE FIRST LAST EMPTY %token <lineno> MOD MODLAST DEFINE TRY CATCH FINALLY %token <lineno> ERRTOK /* deliberately not used in grammar */ -%token <lineno> HASH_BACKSLASH HASH_SLASH DOTDOT HASH_H +%token <lineno> HASH_BACKSLASH HASH_SLASH DOTDOT HASH_H HASH_S %token <lineno> WORDS WSPLICE QWORDS QWSPLICE %token <lineno> SECRET_ESCAPE_R SECRET_ESCAPE_E @@ -110,7 +116,7 @@ int yyparse(scanner_t *, parser_t *); %type <val> output_clause define_clause try_clause catch_clauses_opt %type <val> if_clause elif_clauses_opt else_clause_opt %type <val> line elems_opt elems clause_parts_h additional_parts_h -%type <val> text texts elem var var_op modifiers vector hash +%type <val> text texts elem var var_op modifiers vector hash struct %type <val> list exprs exprs_opt expr n_exprs r_exprs n_expr n_exprs_opt %type <val> out_clauses out_clauses_opt out_clause %type <val> repeat_clause repeat_parts_opt o_line @@ -720,6 +726,17 @@ hash : HASH_H list { if (unquotes_occur($2, 0)) num($1)); } ; +struct : HASH_S list { if (unquotes_occur($2, 0)) + $$ = rlcp(cons(struct_lit_s, $2), + num($1)); + else + { args_decl(args, 0); + val strct = make_struct(first($2), + rest($2), + args); + $$ = rlcp(strct, num($1)); } } + ; + list : '(' n_exprs ')' { $$ = rl($2, num($1)); } | '(' ')' { $$ = nil; } | '(' LAMBDOT n_expr ')' { $$ = $3; } @@ -800,6 +817,7 @@ n_expr : SYMTOK { $$ = symhlpr($1, t); } | list { $$ = $1; } | vector { $$ = $1; } | hash { $$ = $1; } + | struct { $$ = $1; } | lisp_regex { $$ = $1; } | chrlit { $$ = $1; } | strlit { $$ = $1; } @@ -1451,6 +1469,7 @@ void yybadtoken(parser_t *parser, int tok, val context) case HASH_BACKSLASH: problem = lit("#\\"); break; case HASH_SLASH: problem = lit("#/"); break; case HASH_H: problem = lit("#H"); break; + case HASH_S: problem = lit("#S"); break; case WORDS: problem = lit("#\""); break; case WSPLICE: problem = lit("#*\""); break; case QWORDS: problem = lit("#`"); break; diff --git a/share/txr/stdlib/place.tl b/share/txr/stdlib/place.tl index 270baace..256f8592 100644 --- a/share/txr/stdlib/place.tl +++ b/share/txr/stdlib/place.tl @@ -592,6 +592,17 @@ ^(macrolet ((,deleter () ^(makunbound ,',sym-expr))) ,*body))) +(defplace (slot struct sym) body + (getter setter + (with-gensyms (struct-sym) + ^(rlet ((,struct-sym ,struct)) + (macrolet ((,getter () ^(slot ,',struct-sym ,',sym)) + (,setter (val) ^(slotset ,',struct-sym ,',sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(slotset ,',struct ,',sym ,val))) + ,body))) + (defmacro define-modify-macro (name lambda-list function) (let ((cleaned-lambda-list (mapcar [iffi consp car] (remql : lambda-list)))) diff --git a/share/txr/stdlib/struct.tl b/share/txr/stdlib/struct.tl new file mode 100644 index 00000000..9030a90a --- /dev/null +++ b/share/txr/stdlib/struct.tl @@ -0,0 +1,57 @@ +(defmacro defstruct (name-spec super . slot-specs) + (tree-bind (name args) (tree-case name-spec + ((atom . args) (list atom args)) + (atom (list atom nil))) + (unless (bindable name) + (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 ((slot-init-forms (collect-each ((slot slot-specs)) + (tree-case slot + ((sym init-form) slot) + (sym (list sym nil)))))) + (whenlet ((bad [find-if [notf bindable] slot-init-forms car])) + (throwf 'eval-error "~s: slot name ~s isn't a bindable symbol" + 'defstruct (car bad))) + (let ((arg-sym (gensym))) + ^(make-struct-type ',name ',super ',[mapcar car slot-init-forms] + (lambda (,arg-sym) + ,*(mapcar (aret ^(slotset ,arg-sym ',@1 ,@2)) slot-init-forms)) + ,(if args + (let ((gens (mapcar (ret (gensym)) args))) + ^(lambda (,arg-sym ,*gens) + ,*(mapcar (ret ^(slotset ,arg-sym ',@1 ,@2)) + args gens))))))))) + +(defmacro sys:struct-lit (name . plist) + ^(make-struct ',name ',plist)) + +(defmacro qref (:whole 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] :)) + (((dw sym . args) . more) + (if (eq dw 'dwim) ^(qref [(slot ,obj ',sym) ,*args] ,*more) :)) + (((sym . args)) + (let ((osym (gensym))) + ^(let ((,osym ,obj)) + (call (slot ,osym ',sym) ,osym ,*args)))) + (((sym . args) . more) + (let ((osym (gensym))) + ^(qref (let ((,osym ,obj)) + (call (slot ,osym ',sym) ,osym ,*args)) ,*more))) + ((sym) ^(slot ,obj ',sym)) + ((sym . more) ^(qref (slot ,obj ',sym) ,*more)) + (obj (throwf 'eval-error "~s: bad syntax: ~s" 'qref refs)))) + +(defmacro new (spec . pairs) + (let ((qpairs (mappend (aret ^(',@1 ,@2)) (tuples 2 pairs)))) + (tree-case spec + ((atom . args) ^(make-struct ',atom (list ,*qpairs) ,*args)) + (atom ^(make-struct ',atom (list ,*qpairs)))))) + +(defmacro meth (obj slot) + ^(method ,obj ',slot)) diff --git a/struct.c b/struct.c new file mode 100644 index 00000000..5a13e11b --- /dev/null +++ b/struct.c @@ -0,0 +1,450 @@ +/* Copyright 2015 + * Kaz Kylheku <kaz@kylheku.com> + * Vancouver, Canada + * All rights reserved. + * + * Redistribution of this software in source and binary forms, with or without + * modification, is permitted provided that the following two conditions are met. + * + * Use of this software in any manner constitutes agreement with the disclaimer + * which follows the two conditions. + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in + * the documentation and/or other materials provided with the + * distribution. + * + * THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR IMPLIED + * WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. IN NO EVENT SHALL THE + * COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DAMAGES, HOWEVER CAUSED, + * AND UNDER ANY THEORY OF LIABILITY, ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + */ + +#include <stddef.h> +#include <stdio.h> +#include <string.h> +#include <dirent.h> +#include <stdarg.h> +#include <stdlib.h> +#include <setjmp.h> +#include <limits.h> +#include <signal.h> +#include "config.h" +#include ALLOCA_H +#include "lib.h" +#include "hash.h" +#include "eval.h" +#include "signal.h" +#include "unwind.h" +#include "stream.h" +#include "gc.h" +#include "args.h" +#include "cadr.h" +#include "struct.h" + +#define max(a, b) ((a) > (b) ? (a) : (b)) + +struct struct_type { + val name; + cnum id; + cnum nslots; + val super; + struct struct_type *super_handle; + val slots; + val initfun; + val boactor; +}; + +struct struct_inst { + val type; + cnum id; + val slot[1]; +}; + +val struct_type_s; + +static cnum struct_id_counter; +static val struct_type_hash; +static val slot_hash; + +static struct cobj_ops struct_type_ops; +static struct cobj_ops struct_inst_ops; + +void struct_init(void) +{ + protect(&struct_type_hash, &slot_hash, convert(val *, 0)); + struct_type_s = intern(lit("struct-type"), user_package); + struct_type_hash = make_hash(nil, nil, nil); + slot_hash = make_hash(nil, nil, t); + reg_fun(intern(lit("make-struct-type"), user_package), + func_n5(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)); + reg_fun(intern(lit("super"), user_package), func_n1(super)); + reg_fun(intern(lit("make-struct"), user_package), func_n2v(make_struct)); + reg_fun(intern(lit("copy-struct"), user_package), func_n1(copy_struct)); + reg_fun(intern(lit("slot"), user_package), func_n2(slot)); + reg_fun(intern(lit("slotset"), user_package), func_n3(slotset)); + 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)); +} + +static noreturn void no_such_struct(val ctx, val sym) +{ + uw_throwf(error_s, lit("~a: ~s does not name a struct type"), + ctx, sym, nao); +} + +val make_struct_type(val name, val super, val slots, val initfun, val boactor) +{ + val self = lit("make-struct-type"); + + if (super && symbolp(super)) { + val supertype = gethash(struct_type_hash, super); + if (!super) + no_such_struct(self, super); + super = supertype; + } else if (super) { + class_check(super, struct_type_s); + } + + if (!bindable(name)) { + uw_throwf(error_s, lit("~a: name ~s is not a bindable symbol"), + self, name, nao); + } else if (!all_satisfy(slots, func_n1(bindable), nil)) { + uw_throwf(error_s, lit("~a: slots must be bindable symbols"), + self, nao); + } else if (!eql(length(uniq(slots)), length(slots))) { + uw_throwf(error_s, lit("~a: slot names must not repeat"), + self, nao); + } else if (struct_id_counter == NUM_MAX) { + uw_throwf(error_s, lit("~a: struct ID overflow"), self, nao); + } else { + struct struct_type *st = coerce(struct struct_type *, + chk_malloc(sizeof *st)); + struct struct_type *su = if3(super, + coerce(struct struct_type *, + cobj_handle(super, struct_type_s)), 0); + val super_slots = if2(su, su->slots); + val all_slots = uniq(append2(super_slots, slots)); + val stype = cobj(coerce(mem_t *, st), struct_type_s, &struct_type_ops); + val id = num_fast(++struct_id_counter); + val slot; + cnum sl; + + st->name = name; + st->id = c_num(id); + st->nslots = c_num(length(all_slots)); + st->slots = all_slots; + st->super = super; + st->super_handle = su; + st->initfun = initfun; + st->boactor = boactor; + + sethash(struct_type_hash, name, stype); + + for (sl = 0, slot = all_slots; slot; sl++, slot = cdr(slot)) + sethash(slot_hash, cons(car(slot), id), num_fast(sl)); + + return stype; + } +} + +val find_struct_type(val sym) +{ + return gethash(struct_type_hash, sym); +} + +val struct_type_p(val obj) +{ + return tnil(typeof(obj) == struct_type_s); +} + +val super(val type) +{ + if (type && symbolp(type)) { + val stype = find_struct_type(type); + if (!stype) + no_such_struct(lit("super"), type); + return super(stype); + } else { + struct struct_type *st = coerce(struct struct_type *, + cobj_handle(type, struct_type_s)); + return st->super; + } +} + +static void struct_type_print(val obj, val out, val pretty) +{ + struct struct_type *st = coerce(struct struct_type *, obj->co.handle); + format(out, lit("#<struct-type ~s>"), st->name, nao); +} + +static void struct_type_free(val obj) +{ + struct struct_type *st = coerce(struct struct_type *, obj->co.handle); + val id = num(st->id); + val slot; + + for (slot = st->slots; slot; slot = cdr(slot)) + remhash(slot_hash, cons(car(slot), id)); + + free(st); +} + +static void struct_type_mark(val obj) +{ + struct struct_type *st = coerce(struct struct_type *, obj->co.handle); + gc_mark(st->name); + gc_mark(st->super); + gc_mark(st->slots); + gc_mark(st->initfun); + gc_mark(st->boactor); +} + +static void call_initfun_chain(struct struct_type *st, val strct) +{ + if (st) { + if (st->super) + call_initfun_chain(st->super_handle, strct); + if (st->initfun) + funcall1(st->initfun, strct); + } +} + +val make_struct(val type, val plist, struct args *args) +{ + val self = lit("make-struct"); + + if (symbolp(type)) { + val typeobj = gethash(struct_type_hash, type); + if (!typeobj) + uw_throwf(error_s, lit("~a: ~s doesn't name a struct type"), + self, type, nao); + return make_struct(typeobj, plist, args); + } else { + struct struct_type *st = coerce(struct struct_type *, + cobj_handle(type, struct_type_s)); + cnum nslots = st->nslots, sl; + size_t size = offsetof(struct struct_inst, slot) + sizeof (val) * nslots; + struct struct_inst *si = coerce(struct struct_inst *, chk_malloc(size)); + val sinst; + + if (args_more(args, 0) && !st->boactor) { + free(si); + uw_throwf(error_s, + lit("~a: args present, but ~s has no boa constructor"), + self, type, nao); + } + + for (sl = 0; sl < nslots; sl++) + si->slot[sl] = nil; + si->type = nil; + si->id = st->id; + + + sinst = cobj(coerce(mem_t *, si), st->name, &struct_inst_ops); + + si->type = type; + + call_initfun_chain(st, sinst); + + if (args_more(args, 0)) { + args_decl(args_copy, max(args->fill + 1, ARGS_MIN)); + args_add(args_copy, sinst); + args_cat_zap(args_copy, args); + generic_funcall(st->boactor, args_copy); + } + + for (; plist; plist = cddr(plist)) + slotset(sinst, car(plist), cadr(plist)); + + return sinst; + } +} + +static struct struct_inst *struct_handle(val obj, val ctx) +{ + if (cobjp(obj) && obj->co.ops == &struct_inst_ops) + return coerce(struct struct_inst *, obj->co.handle); + no_such_struct(ctx, obj); +} + +val copy_struct(val strct) +{ + const val self = lit("copy-struct"); + val copy; + struct struct_inst *si = struct_handle(strct, self); + struct struct_type *st = coerce(struct struct_type *, si->type->co.handle); + cnum nslots = st->nslots; + size_t size = offsetof(struct struct_inst, slot) + sizeof (val) * nslots; + struct struct_inst *si_copy = coerce(struct struct_inst *, chk_malloc(size)); + memcpy(si_copy, si, size); + copy = cobj(coerce(mem_t *, si_copy), st->name, &struct_inst_ops); + gc_hint(strct); + return copy; +} + +static val *lookup_slot(struct struct_inst *si, val sym) +{ + slot_cache_t slot_cache = sym->s.slot_cache; + cnum id = si->id; + + if (slot_cache != 0) { + cnum *cacheline = slot_cache[id % SLOT_CACHE_SIZE]; + cnum clid = cacheline[0]; + + if (clid == id) { + return &si->slot[cacheline[1]]; + } else { + val key = cons(sym, num_fast(id)); + val sl = gethash(slot_hash, key); + cnum slnum = coerce(cnum, sl) >> TAG_SHIFT; + if (sl) { + cacheline[0] = si->id; + cacheline[1] = slnum; + return &si->slot[slnum]; + } + } + } else { + slot_cache = coerce(slot_cache_t, + chk_calloc(SLOT_CACHE_SIZE, + sizeof (slot_cache_line_t))); + cnum *cacheline = slot_cache[id % SLOT_CACHE_SIZE]; + val key = cons(sym, num_fast(id)); + val sl = gethash(slot_hash, key); + cnum slnum = coerce(cnum, sl) >> TAG_SHIFT; + + sym->s.slot_cache = slot_cache; + + if (sl) { + cacheline[0] = si->id; + cacheline[1] = slnum; + return &si->slot[slnum]; + } + } + + return 0; +} + +static noreturn void no_such_slot(val ctx, val type, val slot) +{ + uw_throwf(error_s, lit("~a: ~s has no slot named ~s"), + ctx, type, slot, nao); +} + +val slot(val strct, val sym) +{ + const val self = lit("slot"); + struct struct_inst *si = struct_handle(strct, self); + + if (symbolp(sym)) { + val *ptr = lookup_slot(si, sym); + if (ptr) + return *ptr; + } + + no_such_slot(self, si->type, sym); +} + +val slotset(val strct, val sym, val newval) +{ + const val self = lit("slotset"); + struct struct_inst *si = struct_handle(strct, self); + + if (symbolp(sym)) { + val *ptr = lookup_slot(si, sym); + if (ptr) { + set(mkloc(*ptr, strct), newval); + return newval; + } + } + + no_such_slot(self, si->type, sym); +} + +val structp(val obj) +{ + return tnil(cobjp(obj) && obj->co.ops == &struct_inst_ops); +} + +val struct_type(val strct) +{ + const val self = lit("struct-type"); + struct struct_inst *si = struct_handle(strct, self); + return si->type; +} + +static val method_fun(val env, varg args) +{ + cons_bind (fun, strct, env); + args_decl(args_copy, max(args->fill + 1, ARGS_MIN)); + args_add(args_copy, strct); + args_cat_zap(args_copy, args); + return generic_funcall(fun, args_copy); +} + +val method(val strct, val slotsym) +{ + return func_f0v(cons(slot(strct, slotsym), strct), method_fun); +} + +static void struct_inst_print(val obj, val out, val pretty) +{ + struct struct_inst *si = coerce(struct struct_inst *, obj->co.handle); + struct struct_type *st = coerce(struct struct_type *, si->type->co.handle); + val save_mode = test_set_indent_mode(out, num_fast(indent_off), + num_fast(indent_data)); + val save_indent, slots; + cnum sl, nslots = st->nslots; + + put_string(lit("#S("), out); + obj_print_impl(st->name, out, pretty); + save_indent = inc_indent(out, one); + + for (slots = st->slots, sl = 0; sl < nslots; sl++, slots = cdr(slots)) { + if (sl == 0) + put_char(chr(' '), out); + else + width_check(out, chr(' ')); + obj_print_impl(car(slots), out, pretty); + put_char(chr(' '), out); + obj_print_impl(si->slot[sl], out, pretty); + } + put_char(chr(')'), out); + set_indent_mode(out, save_mode); + set_indent(out, save_indent); +} + +static void struct_inst_mark(val obj) +{ + struct struct_inst *si = coerce(struct struct_inst *, obj->co.handle); + struct struct_type *st = coerce(struct struct_type *, si->type->co.handle); + cnum sl, nslots = st->nslots; + + for (sl = 0; sl < nslots; sl++) + gc_mark(si->slot[sl]); + gc_mark(si->type); +} + +static struct cobj_ops struct_type_ops = { + eq, + struct_type_print, + struct_type_free, + struct_type_mark, + cobj_hash_op +}; + +static struct cobj_ops struct_inst_ops = { + eq, + struct_inst_print, + cobj_destroy_free_op, + struct_inst_mark, + cobj_hash_op +}; diff --git a/struct.h b/struct.h new file mode 100644 index 00000000..193c605d --- /dev/null +++ b/struct.h @@ -0,0 +1,39 @@ +/* Copyright 2015 + * Kaz Kylheku <kaz@kylheku.com> + * Vancouver, Canada + * All rights reserved. + * + * Redistribution of this software in source and binary forms, with or without + * modification, is permitted provided that the following two conditions are met. + * + * Use of this software in any manner constitutes agreement with the disclaimer + * which follows the two conditions. + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in + * the documentation and/or other materials provided with the + * distribution. + * + * THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR IMPLIED + * WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. IN NO EVENT SHALL THE + * COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DAMAGES, HOWEVER CAUSED, + * AND UNDER ANY THEORY OF LIABILITY, ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + */ + +extern val struct_type_s; +val make_struct_type(val name, val super, val slots, val initfun, val boactor); +val struct_type_p(val obj); +val super(val type); +val make_struct(val type, val plist, struct args *); +val copy_struct(val strct); +val find_struct_type(val sym); +val slot(val strct, val sym); +val slotset(val strct, val sym, val newval); +val structp(val obj); +val struct_type(val strct); +val method(val strct, val obj); +void struct_init(void); |