"Fossies" - the Fresh Open Source Software Archive

Member "txr-218/struct.c" (20 Jun 2019, 48099 Bytes) of package /linux/misc/txr-218.tar.bz2:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) C and C++ source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "struct.c" see the Fossies "Dox" file reference documentation and the latest Fossies "Diffs" side-by-side code changes report: 217_vs_218.

    1 /* Copyright 2015-2019
    2  * Kaz Kylheku <kaz@kylheku.com>
    3  * Vancouver, Canada
    4  * All rights reserved.
    5  *
    6  * Redistribution and use in source and binary forms, with or without
    7  * modification, are permitted provided that the following conditions are met:
    8  *
    9  * 1. Redistributions of source code must retain the above copyright notice, this
   10  *    list of conditions and the following disclaimer.
   11  *
   12  * 2. Redistributions in binary form must reproduce the above copyright notice,
   13  *    this list of conditions and the following disclaimer in the documentation
   14  *    and/or other materials provided with the distribution.
   15  *
   16  * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
   17  * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
   18  * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
   19  * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
   20  * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
   21  * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
   22  * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
   23  * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
   24  * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
   25  * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
   26  */
   27 
   28 #include <stddef.h>
   29 #include <stdio.h>
   30 #include <string.h>
   31 #include <stdarg.h>
   32 #include <stdlib.h>
   33 #include <limits.h>
   34 #include <signal.h>
   35 #include <assert.h>
   36 #include "config.h"
   37 #include "alloca.h"
   38 #include "lib.h"
   39 #include "hash.h"
   40 #include "eval.h"
   41 #include "signal.h"
   42 #include "unwind.h"
   43 #include "stream.h"
   44 #include "gc.h"
   45 #include "args.h"
   46 #include "cadr.h"
   47 #include "txr.h"
   48 #include "lisplib.h"
   49 #include "struct.h"
   50 
   51 #define max(a, b) ((a) > (b) ? (a) : (b))
   52 #define nelem(array) (sizeof (array) / sizeof (array)[0])
   53 #define uptopow2_0(v) ((v) - 1)
   54 #define uptopow2_1(v) (uptopow2_0(v) | uptopow2_0(v) >> 1)
   55 #define uptopow2_2(v) (uptopow2_1(v) | uptopow2_1(v) >> 2)
   56 #define uptopow2_3(v) (uptopow2_2(v) | uptopow2_2(v) >> 4)
   57 #define uptopow2_4(v) (uptopow2_3(v) | uptopow2_3(v) >> 8)
   58 #define uptopow2_5(v) (uptopow2_4(v) | uptopow2_4(v) >> 16)
   59 #define uptopow2(v) (uptopow2_5(v) + 1)
   60 
   61 #define STATIC_SLOT_BASE 0x10000000
   62 
   63 
   64 struct stslot {
   65   val home_type;
   66   cnum home_offs;
   67   val *home;
   68   val store;
   69 };
   70 
   71 #define stslot_loc(s) mkloc(*(s)->home, (s)->home_type)
   72 #define stslot_place(s) (*(s)->home)
   73 
   74 struct struct_type {
   75   val self;
   76   val name;
   77   cnum id;
   78   cnum nslots;
   79   cnum nstslots;
   80   struct stslot *eqmslot;
   81   val super;
   82   struct struct_type *super_handle;
   83   val slots;
   84   val stinitfun;
   85   val initfun;
   86   val boactor;
   87   val postinitfun;
   88   val dvtypes;
   89   struct stslot *stslot;
   90 };
   91 
   92 struct struct_inst {
   93   struct struct_type *type;
   94   cnum id : sizeof (cnum) * CHAR_BIT - TAG_SHIFT;
   95   unsigned lazy : 1;
   96   unsigned dirty : 1;
   97   val slot[1];
   98 };
   99 
  100 val struct_type_s, meth_s, print_s, make_struct_lit_s;
  101 val init_k, postinit_k;
  102 val slot_s, derived_s;
  103 
  104 static val struct_type_hash;
  105 static val slot_hash;
  106 static val struct_type_finalize_f;
  107 static val slot_type_hash;
  108 static val static_slot_type_hash;
  109 
  110 static val struct_type_finalize(val obj);
  111 static_forward(struct cobj_ops struct_type_ops);
  112 
  113 static struct stslot *lookup_static_slot_desc(struct struct_type *st, val sym);
  114 static val make_struct_type_compat(val name, val super, val slots,
  115                                    val initfun, val boactor);
  116 static val call_super_method(val inst, val sym, struct args *);
  117 static val call_super_fun(val type, val sym, struct args *);
  118 
  119 void struct_init(void)
  120 {
  121   protect(&struct_type_hash, &slot_hash, &slot_type_hash,
  122           &static_slot_type_hash, &struct_type_finalize_f,
  123           convert(val *, 0));
  124   struct_type_s = intern(lit("struct-type"), user_package);
  125   meth_s = intern(lit("meth"), user_package);
  126   print_s = intern(lit("print"), user_package);
  127   make_struct_lit_s = intern(lit("make-struct-lit"), system_package);
  128   init_k = intern(lit("init"), keyword_package);
  129   postinit_k = intern(lit("postinit"), keyword_package);
  130   slot_s = intern(lit("slot"), user_package);
  131   derived_s = intern(lit("derived"), user_package);
  132   struct_type_hash = make_hash(nil, nil, nil);
  133   slot_hash = make_hash(nil, nil, t);
  134   slot_type_hash = make_hash(nil, nil, nil);
  135   slot_type_hash = make_hash(nil, nil, nil);
  136   static_slot_type_hash = make_hash(nil, nil, nil);
  137   struct_type_finalize_f = func_n1(struct_type_finalize);
  138 
  139   if (opt_compat && opt_compat <= 117)
  140     reg_fun(intern(lit("make-struct-type"), user_package),
  141             func_n5(make_struct_type_compat));
  142   else
  143     reg_fun(intern(lit("make-struct-type"), user_package),
  144             func_n8o(make_struct_type, 7));
  145 
  146   reg_fun(intern(lit("make-struct-type"), system_package),
  147           func_n8(make_struct_type));
  148   reg_fun(intern(lit("find-struct-type"), user_package),
  149           func_n1(find_struct_type));
  150   reg_fun(intern(lit("struct-type-p"), user_package), func_n1(struct_type_p));
  151   reg_fun(intern(lit("struct-get-initfun"), user_package), func_n1(struct_get_initfun));
  152   reg_fun(intern(lit("struct-set-initfun"), user_package), func_n2(struct_set_initfun));
  153   reg_fun(intern(lit("struct-get-postinitfun"), user_package), func_n1(struct_get_postinitfun));
  154   reg_fun(intern(lit("struct-set-postinitfun"), user_package), func_n2(struct_set_postinitfun));
  155   reg_fun(intern(lit("super"), user_package), func_n1(super));
  156   reg_fun(intern(lit("make-struct"), user_package), func_n2v(make_struct));
  157   reg_fun(intern(lit("struct-from-plist"), user_package), func_n1v(struct_from_plist));
  158   reg_fun(intern(lit("struct-from-args"), user_package), func_n1v(struct_from_args));
  159   reg_fun(intern(lit("make-lazy-struct"), user_package),
  160           func_n2(make_lazy_struct));
  161   reg_fun(make_struct_lit_s, func_n2(make_struct_lit));
  162   reg_fun(intern(lit("allocate-struct"), user_package), func_n1(allocate_struct));
  163   reg_fun(intern(lit("copy-struct"), user_package), func_n1(copy_struct));
  164   reg_fun(intern(lit("replace-struct"), user_package), func_n2(replace_struct));
  165   reg_fun(intern(lit("clear-struct"), user_package), func_n2o(clear_struct, 1));
  166   reg_fun(intern(lit("reset-struct"), user_package), func_n1(reset_struct));
  167   reg_fun(slot_s, func_n2(slot));
  168   reg_fun(intern(lit("slotset"), user_package), func_n3(slotset));
  169   reg_fun(intern(lit("static-slot"), user_package), func_n2(static_slot));
  170   reg_fun(intern(lit("static-slot-set"), user_package),
  171           func_n3(static_slot_set));
  172   reg_fun(intern(lit("test-dirty"), user_package), func_n1(test_dirty));
  173   reg_fun(intern(lit("test-clear-dirty"), user_package), func_n1(test_clear_dirty));
  174   reg_fun(intern(lit("clear-dirty"), user_package), func_n1(clear_dirty));
  175   reg_fun(intern(lit("static-slot-ensure"), user_package),
  176           func_n4o(static_slot_ensure, 3));
  177   reg_fun(intern(lit("static-slot-home"), user_package),
  178           func_n2(static_slot_home));
  179   reg_fun(intern(lit("call-super-method"), user_package),
  180           func_n2v(call_super_method));
  181   reg_fun(intern(lit("call-super-fun"), user_package),
  182           func_n2v(call_super_fun));
  183   reg_fun(intern(lit("slotp"), user_package), func_n2(slotp));
  184   if (opt_compat && opt_compat <= 118)
  185     reg_fun(intern(lit("slot-p"), user_package), func_n2(slotp));
  186   reg_fun(intern(lit("static-slot-p"), user_package), func_n2(static_slot_p));
  187   reg_fun(intern(lit("structp"), user_package), func_n1(structp));
  188   reg_fun(intern(lit("struct-type"), user_package), func_n1(struct_type));
  189   reg_fun(intern(lit("struct-type-name"), user_package), func_n1(struct_type_name));
  190   reg_fun(intern(lit("method"), user_package), func_n2v(method_args));
  191   reg_fun(intern(lit("super-method"), user_package), func_n2(super_method));
  192   reg_fun(intern(lit("uslot"), user_package), func_n1(uslot));
  193   reg_fun(intern(lit("umethod"), user_package), func_n1v(umethod));
  194   reg_fun(intern(lit("slots"), user_package), func_n1(slots));
  195   reg_fun(intern(lit("slot-types"), system_package), func_n1(slot_types));
  196   reg_fun(intern(lit("static-slot-types"), system_package), func_n1(static_slot_types));
  197 }
  198 
  199 static noreturn void no_such_struct(val ctx, val sym)
  200 {
  201   uw_throwf(error_s, lit("~a: ~s does not name a struct type"),
  202             ctx, sym, nao);
  203 }
  204 
  205 static val struct_type_finalize(val obj)
  206 {
  207   struct struct_type *st = coerce(struct struct_type *, obj->co.handle);
  208   val id = num(st->id);
  209   val iter;
  210 
  211   for (iter = st->slots; iter; iter = cdr(iter)) {
  212     val slot = car(iter);
  213     slot_cache_t slot_cache = slot->s.slot_cache;
  214     int i, j;
  215 
  216     remhash(slot_hash, cons(slot, id));
  217 
  218     if (slot_cache != 0)
  219       for (i = 0; i < SLOT_CACHE_SIZE; i++)
  220         for (j = 0; j < 4; j++)
  221           if (slot_cache[i][j].id == st->id) {
  222             slot_cache[i][j].id = 0;
  223             slot_cache[i][j].slot = 0;
  224           }
  225   }
  226 
  227   return nil;
  228 }
  229 
  230 static void call_stinitfun_chain(struct struct_type *st, val stype)
  231 {
  232   if (st) {
  233     if (st->super && opt_compat && opt_compat <= 151)
  234       call_stinitfun_chain(st->super_handle, stype);
  235     if (st->stinitfun)
  236       funcall1(st->stinitfun, stype);
  237   }
  238 }
  239 
  240 static struct struct_type *stype_handle(val *pobj, val ctx)
  241 {
  242   val obj = *pobj;
  243 
  244   switch (type(obj)) {
  245   case SYM:
  246     {
  247       val stype = find_struct_type(obj);
  248       if (!stype)
  249         no_such_struct(ctx, obj);
  250       *pobj = stype;
  251       return coerce(struct struct_type *, cobj_handle(ctx, stype,
  252                                                       struct_type_s));
  253     }
  254   case COBJ:
  255     if (obj->co.cls == struct_type_s)
  256       return coerce(struct struct_type *, obj->co.handle);
  257     /* fallthrough */
  258   default:
  259     uw_throwf(error_s, lit("~a: ~s isn't a struct type"),
  260               ctx, obj, nao);
  261   }
  262 }
  263 
  264 static void static_slot_home_fixup(struct struct_type *st)
  265 {
  266   cnum i;
  267   for (i = 0; i < st->nstslots; i++) {
  268     struct stslot *s = &st->stslot[i];
  269     if (s->home_type == st->self) {
  270       s->home = &s->store;
  271     } else {
  272       struct struct_type *shome = coerce(struct struct_type *,
  273                                          s->home_type->co.handle);
  274       *s = shome->stslot[s->home_offs];
  275       s->store = nil;
  276     }
  277   }
  278 }
  279 
  280 val make_struct_type(val name, val super,
  281                      val static_slots, val slots,
  282                      val static_initfun, val initfun, val boactor,
  283                      val postinitfun)
  284 {
  285   val self = lit("make-struct-type");
  286 
  287   if (super && symbolp(super)) {
  288     val supertype = find_struct_type(super);
  289     if (!supertype)
  290       no_such_struct(self, super);
  291     super = supertype;
  292   } else if (super) {
  293     class_check(self, super, struct_type_s);
  294   }
  295 
  296   if (!bindable(name)) {
  297     uw_throwf(error_s, lit("~a: name ~s is not a bindable symbol"),
  298               self, name, nao);
  299   } else if (!all_satisfy(slots, func_n1(bindable), nil)) {
  300     uw_throwf(error_s, lit("~a: slots must be bindable symbols"),
  301               self, nao);
  302   } else if (!eql(length(uniq(slots)), length(slots))) {
  303     uw_throwf(error_s, lit("~a: slot names must not repeat"),
  304               self, nao);
  305   } else {
  306     struct struct_type *st = coerce(struct struct_type *,
  307                                     chk_malloc(sizeof *st));
  308     struct struct_type *su = if3(super, stype_handle(&super, self), 0);
  309     val id = num_fast(coerce(ucnum, st) / (uptopow2(sizeof *st) / 2));
  310     val super_slots = if2(su, su->slots);
  311     val all_slots = uniq(append2(super_slots, append2(static_slots, slots)));
  312     cnum stsl_upb = c_num(plus(length(static_slots),
  313                                num(if3(su, su->nstslots, 0))));
  314     val stype = cobj(coerce(mem_t *, st), struct_type_s, &struct_type_ops);
  315     val iter;
  316     cnum sl, stsl;
  317     struct stslot null_ptr = { nil, 0, 0, nil };
  318 
  319     st->self = stype;
  320     st->name = name;
  321     st->id = c_num(id);
  322     st->nslots = st->nstslots = 0;
  323     st->eqmslot = 0;
  324     st->slots = all_slots;
  325     st->super = super;
  326     st->stslot = 0;
  327     st->super_handle = su;
  328     st->stinitfun = static_initfun;
  329     st->initfun = initfun;
  330     st->boactor = boactor;
  331     st->postinitfun = default_null_arg(postinitfun);
  332     st->dvtypes = nil;
  333 
  334     gc_finalize(stype, struct_type_finalize_f, nil);
  335 
  336     st->stslot = coerce(struct stslot *,
  337                         chk_manage_vec(0, 0, stsl_upb, sizeof *st->stslot,
  338                                        coerce(mem_t *, &null_ptr)));
  339 
  340     for (sl = 0, stsl = STATIC_SLOT_BASE, iter = all_slots;
  341          iter;
  342          iter = cdr(iter))
  343     {
  344       val slot = car(iter);
  345       val new_tslot_p = memq(slot, static_slots);
  346       int inherited_p = !new_tslot_p && !memq(slot, slots);
  347       val ts_p = if3(inherited_p,
  348                      static_slot_p(super, slot),
  349                      memq(slot, static_slots));
  350 
  351       if (ts_p) {
  352         cnum n = stsl++ - STATIC_SLOT_BASE;
  353         struct stslot *ss = &st->stslot[n];
  354         val key = if2(su, cons(slot, num_fast(su->id)));
  355         val msl = if2(su, gethash(slot_hash, key));
  356         cnum m = (coerce(cnum, msl) >> TAG_SHIFT) - STATIC_SLOT_BASE;
  357 
  358         if (!inherited_p || (opt_compat && opt_compat <= 151)) {
  359           ss->home_type = stype;
  360           ss->home_offs = n;
  361           ss->home = &ss->store;
  362           ss->store = if2(msl, stslot_place(&su->stslot[m]));
  363         } else {
  364           *ss = su->stslot[m];
  365           ss->store = nil;
  366         }
  367         sethash(slot_hash, cons(slot, id), num(n + STATIC_SLOT_BASE));
  368         static_slot_type_reg(slot, name);
  369       } else {
  370         sethash(slot_hash, cons(slot, id), num_fast(sl++));
  371         slot_type_reg(slot, name);
  372       }
  373 
  374       if (sl >= STATIC_SLOT_BASE)
  375         uw_throwf(error_s, lit("~a: too many instance slots"), self, nao);
  376 
  377       if (stsl >= NUM_MAX)
  378         uw_throwf(error_s, lit("~a: too many static slots"), self, nao);
  379     }
  380 
  381     stsl -= STATIC_SLOT_BASE;
  382     st->stslot = coerce(struct stslot *,
  383                         chk_manage_vec(coerce(mem_t *, st->stslot), stsl_upb,
  384                                        stsl, sizeof *st->stslot,
  385                                        coerce(mem_t *, &null_ptr)));
  386     st->nslots = sl;
  387     st->nstslots = stsl;
  388     static_slot_home_fixup(st);
  389 
  390     sethash(struct_type_hash, name, stype);
  391 
  392     if (super)
  393       mpush(stype, mkloc(su->dvtypes, super));
  394 
  395     call_stinitfun_chain(st, stype);
  396 
  397     uw_purge_deferred_warning(cons(struct_type_s, name));
  398 
  399     if (su) {
  400       struct stslot *dvmeth = lookup_static_slot_desc(su, derived_s);
  401       if (dvmeth)
  402         funcall2(stslot_place(dvmeth), su->self, stype);
  403     }
  404 
  405     return stype;
  406   }
  407 }
  408 
  409 static val make_struct_type_compat(val name, val super, val slots,
  410                                    val initfun, val boactor)
  411 {
  412   return make_struct_type(name, super, nil, slots, nil, initfun, boactor, nil);
  413 }
  414 
  415 val find_struct_type(val sym)
  416 {
  417   uses_or2;
  418   return or2(gethash(struct_type_hash, sym),
  419              if2(lisplib_try_load(sym),
  420                  gethash(struct_type_hash, sym)));
  421 }
  422 
  423 val struct_type_p(val obj)
  424 {
  425   return tnil(typeof(obj) == struct_type_s);
  426 }
  427 
  428 val struct_get_initfun(val type)
  429 {
  430   struct struct_type *st = stype_handle(&type, lit("struct-get-initfun"));
  431   return st->initfun;
  432 }
  433 
  434 val struct_set_initfun(val type, val fun)
  435 {
  436   struct struct_type *st = stype_handle(&type, lit("struct-set-initfun"));
  437   set(mkloc(st->initfun, type), fun);
  438   return fun;
  439 }
  440 
  441 val struct_get_postinitfun(val type)
  442 {
  443   struct struct_type *st = stype_handle(&type, lit("struct-get-postinitfun"));
  444   return st->postinitfun;
  445 }
  446 
  447 val struct_set_postinitfun(val type, val fun)
  448 {
  449   struct struct_type *st = stype_handle(&type, lit("struct-set-postinitfun"));
  450   set(mkloc(st->postinitfun, type),  fun);
  451   return fun;
  452 }
  453 
  454 val super(val type)
  455 {
  456   if (structp(type)) {
  457     struct struct_inst *si = coerce(struct struct_inst *, type->co.handle);
  458     return si->type->super;
  459   } else {
  460     struct struct_type *st = stype_handle(&type, lit("super"));
  461     return st->super;
  462   }
  463 }
  464 
  465 static void struct_type_print(val obj, val out, val pretty, struct strm_ctx *c)
  466 {
  467   struct struct_type *st = coerce(struct struct_type *, obj->co.handle);
  468   (void) c;
  469   format(out, lit("#<struct-type ~s>"), st->name, nao);
  470 }
  471 
  472 static void struct_type_destroy(val obj)
  473 {
  474   struct struct_type *st = coerce(struct struct_type *, obj->co.handle);
  475   free(st->stslot);
  476   free(st);
  477 }
  478 
  479 static void struct_type_mark(val obj)
  480 {
  481   struct struct_type *st = coerce(struct struct_type *, obj->co.handle);
  482   cnum stsl;
  483 
  484   gc_mark(st->name);
  485   gc_mark(st->super);
  486   gc_mark(st->slots);
  487   gc_mark(st->stinitfun);
  488   gc_mark(st->initfun);
  489   gc_mark(st->boactor);
  490   gc_mark(st->postinitfun);
  491   gc_mark(st->dvtypes);
  492 
  493   for (stsl = 0; stsl < st->nstslots; stsl++) {
  494     struct stslot *sl = &st->stslot[stsl];
  495 
  496     if (sl->home_type == st->self)
  497       gc_mark(sl->store);
  498     else
  499       assert (sl->store == nil);
  500   }
  501 }
  502 
  503 static void call_initfun_chain(struct struct_type *st, val strct)
  504 {
  505   if (st) {
  506     if (st->super)
  507       call_initfun_chain(st->super_handle, strct);
  508     if (st->initfun)
  509       funcall1(st->initfun, strct);
  510   }
  511 }
  512 
  513 static void call_postinitfun_chain(struct struct_type *st, val strct)
  514 {
  515   if (st) {
  516     int derived_first = (opt_compat && opt_compat <= 148);
  517 
  518     if (derived_first && st->postinitfun)
  519       funcall1(st->postinitfun, strct);
  520     if (st->super)
  521       call_postinitfun_chain(st->super_handle, strct);
  522     if (!derived_first && st->postinitfun)
  523       funcall1(st->postinitfun, strct);
  524   }
  525 }
  526 
  527 val allocate_struct(val type)
  528 {
  529   val self = lit("allocate-struct");
  530   struct struct_type *st = stype_handle(&type, self);
  531   cnum nslots = st->nslots;
  532   size_t size = offsetof(struct struct_inst, slot) + sizeof (val) * nslots;
  533   struct struct_inst *si = coerce(struct struct_inst *, chk_calloc(1, size));
  534   si->type = st;
  535   si->id = st->id;
  536   si->lazy = 0;
  537   si->dirty = 1;
  538   bug_unless (type == st->self);
  539   return cobj(coerce(mem_t *, si), st->name, &struct_inst_ops);
  540 }
  541 
  542 static val make_struct_impl(val self, val type,
  543                             struct args *plist, struct args *args)
  544 {
  545   struct struct_type *st = stype_handle(&type, self);
  546   cnum nslots = st->nslots, sl;
  547   size_t size = offsetof(struct struct_inst, slot) + sizeof (val) * nslots;
  548   struct struct_inst *si = coerce(struct struct_inst *, chk_malloc(size));
  549   val sinst;
  550   volatile val inited = nil;
  551 
  552   if (args_more(args, 0) && !st->boactor) {
  553     free(si);
  554     uw_throwf(error_s,
  555               lit("~a: args present, but ~s has no boa constructor"),
  556               self, type, nao);
  557   }
  558 
  559   for (sl = 0; sl < nslots; sl++)
  560     si->slot[sl] = nil;
  561   si->type = st;
  562   si->id = st->id;
  563   si->lazy = 0;
  564   si->dirty = 1;
  565 
  566   sinst = cobj(coerce(mem_t *, si), st->name, &struct_inst_ops);
  567 
  568   bug_unless (type == st->self);
  569 
  570   uw_simple_catch_begin;
  571 
  572   call_initfun_chain(st, sinst);
  573 
  574   {
  575     cnum index = 0;
  576     while (args_more(plist, index)) {
  577       val slot = args_get(plist, &index);
  578       val value = args_get(plist, &index);
  579       slotset(sinst, slot, value);
  580     }
  581   }
  582 
  583   if (args_more(args, 0)) {
  584     args_decl(args_copy, max(args->fill + 1, ARGS_MIN));
  585     args_add(args_copy, sinst);
  586     args_cat_zap(args_copy, args);
  587     generic_funcall(st->boactor, args_copy);
  588   }
  589 
  590   call_postinitfun_chain(st, sinst);
  591 
  592   inited = t;
  593 
  594   uw_unwind {
  595     if (!inited)
  596       gc_call_finalizers(sinst);
  597   }
  598 
  599   uw_catch_end;
  600 
  601   return sinst;
  602 }
  603 
  604 val make_struct(val type, val plist, struct args *boa)
  605 {
  606   args_decl_list(pargs, ARGS_MIN, plist);
  607   return make_struct_impl(lit("make-struct"), type, pargs, boa);
  608 }
  609 
  610 val struct_from_plist(val type, struct args *plist)
  611 {
  612   args_decl(boa, 0);
  613   return make_struct_impl(lit("struct-from-plist"), type, plist, boa);
  614 }
  615 
  616 val struct_from_args(val type, struct args *boa)
  617 {
  618   args_decl(pargs, 0);
  619   return make_struct_impl(lit("struct-from-args"), type, pargs, boa);
  620 }
  621 
  622 static void lazy_struct_init(val sinst, struct struct_inst *si)
  623 {
  624   val self = lit("make-lazy-struct");
  625   struct struct_type *st = si->type;
  626   volatile val inited = nil;
  627   val cell = funcall(si->slot[0]);
  628   cons_bind (plist, args, cell);
  629 
  630   si->slot[0] = nil;
  631 
  632   if (args && !st->boactor) {
  633     uw_throwf(error_s,
  634               lit("~a: args present, but ~s has no boa constructor"),
  635               self, type, nao);
  636   }
  637 
  638   uw_simple_catch_begin;
  639 
  640   call_initfun_chain(st, sinst);
  641 
  642   for (; plist; plist = cddr(plist))
  643     slotset(sinst, car(plist), cadr(plist));
  644 
  645   if (args) {
  646     args_decl_list(argv, ARGS_MIN, cons(sinst, args));
  647     generic_funcall(st->boactor, argv);
  648   }
  649 
  650   call_postinitfun_chain(st, sinst);
  651 
  652   inited = t;
  653 
  654   uw_unwind {
  655     if (!inited)
  656       gc_call_finalizers(sinst);
  657   }
  658 
  659   uw_catch_end;
  660 }
  661 
  662 INLINE void check_init_lazy_struct(val sinst, struct struct_inst *si)
  663 {
  664   if (si->lazy) {
  665     si->lazy = 0;
  666     lazy_struct_init(sinst, si);
  667   }
  668 }
  669 
  670 val make_lazy_struct(val type, val argfun)
  671 {
  672   val self = lit("make-lazy-struct");
  673   struct struct_type *st = stype_handle(&type, self);
  674   cnum nslots = st->nslots, sl;
  675   cnum nalloc = nslots ? nslots : 1;
  676   size_t size = offsetof(struct struct_inst, slot) + sizeof (val) * nalloc;
  677   struct struct_inst *si = coerce(struct struct_inst *, chk_malloc(size));
  678   val sinst;
  679 
  680   for (sl = 0; sl < nslots; sl++)
  681     si->slot[sl] = nil;
  682   si->type = st;
  683   si->id = st->id;
  684   si->lazy = 1;
  685 
  686   sinst = cobj(coerce(mem_t *, si), st->name, &struct_inst_ops);
  687 
  688   bug_unless (type == st->self);
  689 
  690   si->slot[0] = argfun;
  691 
  692   return sinst;
  693 }
  694 
  695 val make_struct_lit(val type, val plist)
  696 {
  697   args_decl(args, 0);
  698   val strct;
  699 
  700   if (opt_compat && opt_compat <= 154) {
  701     strct = make_struct(type, plist, args);
  702   } else {
  703     strct = make_struct(type, nil, args);
  704     for (; plist; plist = cddr(plist))
  705       slotset(strct, car(plist), cadr(plist));
  706   }
  707 
  708   return strct;
  709 }
  710 
  711 static struct struct_inst *struct_handle(val obj, val ctx)
  712 {
  713   if (cobjp(obj) && obj->co.ops == &struct_inst_ops)
  714     return coerce(struct struct_inst *, obj->co.handle);
  715   uw_throwf(error_s, lit("~a: ~s isn't a structure"),
  716             ctx, obj, nao);
  717 }
  718 
  719 static struct struct_inst *struct_handle_for_slot(val obj, val ctx, val slot)
  720 {
  721   if (cobjp(obj) && obj->co.ops == &struct_inst_ops)
  722     return coerce(struct struct_inst *, obj->co.handle);
  723   uw_throwf(error_s, lit("~a: attempt to access slot ~s of non-structure ~s"),
  724             ctx, slot, obj, nao);
  725 }
  726 
  727 val copy_struct(val strct)
  728 {
  729   const val self = lit("copy-struct");
  730   val copy;
  731   struct struct_inst *si = struct_handle(strct, self);
  732   struct struct_type *st = si->type;
  733   cnum nslots = st->nslots;
  734   size_t size = offsetof(struct struct_inst, slot) + sizeof (val) * nslots;
  735   struct struct_inst *si_copy = coerce(struct struct_inst *, chk_malloc(size));
  736   check_init_lazy_struct(strct, si);
  737   memcpy(si_copy, si, size);
  738   copy = cobj(coerce(mem_t *, si_copy), st->name, &struct_inst_ops);
  739   gc_hint(strct);
  740   return copy;
  741 }
  742 
  743 val clear_struct(val strct, val value)
  744 {
  745   const val self = lit("clear-struct");
  746   struct struct_inst *si = struct_handle(strct, self);
  747   struct struct_type *st = si->type;
  748   val clear_val = default_null_arg(value);
  749   cnum i;
  750 
  751   check_init_lazy_struct(strct, si);
  752 
  753   for (i = 0; i < st->nslots; i++)
  754     si->slot[i] = clear_val;
  755 
  756   setcheck(strct, clear_val);
  757 
  758   return strct;
  759 }
  760 
  761 val replace_struct(val target, val source)
  762 {
  763   const val self = lit("replace-struct");
  764 
  765   if (target != source) {
  766     struct struct_inst *tsi = struct_handle(target, self);
  767     struct struct_inst *ssi = struct_handle(source, self);
  768     struct struct_type *sst = ssi->type;
  769     cnum nslots = sst->nslots;
  770     size_t size = offsetof(struct struct_inst, slot) + sizeof (val) * nslots;
  771     struct struct_inst *ssi_copy = coerce(struct struct_inst *, chk_malloc(size));
  772 
  773     check_init_lazy_struct(source, ssi);
  774     check_init_lazy_struct(target, tsi);
  775 
  776     memcpy(ssi_copy, ssi, size);
  777     free(tsi);
  778     target->co.handle = coerce(mem_t *, ssi_copy);
  779     target->co.cls = source->co.cls;
  780     mut(target);
  781   }
  782 
  783   return target;
  784 }
  785 
  786 val reset_struct(val strct)
  787 {
  788   const val self = lit("reset-struct");
  789   struct struct_inst *si = struct_handle(strct, self);
  790   struct struct_type *st = si->type;
  791   cnum i;
  792   volatile val inited = nil;
  793   int compat_190 = opt_compat && opt_compat <= 190;
  794 
  795   check_init_lazy_struct(strct, si);
  796 
  797   uw_simple_catch_begin;
  798 
  799   for (i = 0; i < st->nslots; i++)
  800     si->slot[i] = nil;
  801 
  802   call_initfun_chain(st, strct);
  803 
  804   if (!compat_190)
  805     call_postinitfun_chain(st, strct);
  806 
  807   inited = t;
  808 
  809   uw_unwind {
  810     if (!inited && !compat_190)
  811       gc_call_finalizers(strct);
  812   }
  813 
  814   uw_catch_end;
  815 
  816   return strct;
  817 }
  818 
  819 static int cache_set_lookup(slot_cache_entry_t *set, cnum id)
  820 {
  821   if (set[0].id == id)
  822     return set[0].slot;
  823 
  824   if (set[1].id == id) {
  825     slot_cache_entry_t tmp = set[0];
  826     set[0] = set[1];
  827     set[1] = tmp;
  828     return set[0].slot;
  829   }
  830 
  831   if (set[2].id == id) {
  832     slot_cache_entry_t tmp = set[1];
  833     set[1] = set[2];
  834     set[2] = tmp;
  835     return set[1].slot;
  836   }
  837 
  838   if (set[3].id == id) {
  839     slot_cache_entry_t tmp = set[2];
  840     set[2] = set[3];
  841     set[3] = tmp;
  842     return set[2].slot;
  843   }
  844 
  845   return -1;
  846 }
  847 
  848 static void cache_set_insert(slot_cache_entry_t *set, cnum id, cnum slot)
  849 {
  850   int entry;
  851 
  852   if (set[0].id == 0)
  853     entry = 0;
  854   else if (set[1].id == 0)
  855     entry = 1;
  856   else if (set[2].id == 0)
  857     entry = 2;
  858   else
  859     entry = 3;
  860 
  861   set[entry].id = id;
  862   set[entry].slot = slot;
  863 }
  864 
  865 static loc lookup_slot(val inst, struct struct_inst *si, val sym)
  866 {
  867   slot_cache_t slot_cache = sym->s.slot_cache;
  868   cnum id = si->id;
  869 
  870   if (slot_cache != 0) {
  871     slot_cache_set_t *set = &slot_cache[id % SLOT_CACHE_SIZE];
  872     cnum slot = cache_set_lookup(*set, id);
  873 
  874     if (slot >= STATIC_SLOT_BASE) {
  875       struct struct_type *st = si->type;
  876       struct stslot *stsl = &st->stslot[slot - STATIC_SLOT_BASE];
  877       return stslot_loc(stsl);
  878     } else if (slot >= 0) {
  879       check_init_lazy_struct(inst, si);
  880       return mkloc(si->slot[slot], inst);
  881     } else {
  882       val key = cons(sym, num_fast(id));
  883       val sl = gethash(slot_hash, key);
  884       cnum slnum = coerce(cnum, sl) >> TAG_SHIFT;
  885       if (sl) {
  886         cache_set_insert(*set, id, slnum);
  887         if (slnum >= STATIC_SLOT_BASE) {
  888           struct struct_type *st = si->type;
  889           struct stslot *stsl = &st->stslot[slnum - STATIC_SLOT_BASE];
  890           return stslot_loc(stsl);
  891         }
  892         check_init_lazy_struct(inst, si);
  893         return mkloc(si->slot[slnum], inst);
  894       }
  895     }
  896   } else {
  897     slot_cache = coerce(slot_cache_t,
  898                         chk_calloc(SLOT_CACHE_SIZE,
  899                                    sizeof (slot_cache_set_t)));
  900     slot_cache_set_t *set = &slot_cache[id % SLOT_CACHE_SIZE];
  901     val key = cons(sym, num_fast(id));
  902     val sl = gethash(slot_hash, key);
  903     cnum slnum = coerce(cnum, sl) >> TAG_SHIFT;
  904 
  905     sym->s.slot_cache = slot_cache;
  906 
  907     if (sl) {
  908       cache_set_insert(*set, id, slnum);
  909       if (slnum >= STATIC_SLOT_BASE) {
  910         struct struct_type *st = si->type;
  911         struct stslot *stsl = &st->stslot[slnum - STATIC_SLOT_BASE];
  912         return stslot_loc(stsl);
  913       }
  914       check_init_lazy_struct(inst, si);
  915       return mkloc(si->slot[slnum], inst);
  916     }
  917   }
  918 
  919   return nulloc;
  920 }
  921 
  922 static struct stslot *lookup_static_slot_desc(struct struct_type *st, val sym)
  923 {
  924   slot_cache_t slot_cache = sym->s.slot_cache;
  925   cnum id = st->id;
  926 
  927   if (slot_cache != 0) {
  928     slot_cache_set_t *set = &slot_cache[id % SLOT_CACHE_SIZE];
  929     cnum slot = cache_set_lookup(*set, id);
  930 
  931     if (slot >= STATIC_SLOT_BASE) {
  932       return &st->stslot[slot - STATIC_SLOT_BASE];
  933     } else if (slot < 0) {
  934       val key = cons(sym, num_fast(id));
  935       val sl = gethash(slot_hash, key);
  936       cnum slnum = coerce(cnum, sl) >> TAG_SHIFT;
  937       if (sl) {
  938         cache_set_insert(*set, id, slnum);
  939         if (slnum >= STATIC_SLOT_BASE)
  940           return &st->stslot[slnum - STATIC_SLOT_BASE];
  941       }
  942     }
  943   } else {
  944     slot_cache = coerce(slot_cache_t,
  945                         chk_calloc(SLOT_CACHE_SIZE,
  946                                    sizeof (slot_cache_set_t)));
  947     slot_cache_set_t *set = &slot_cache[id % SLOT_CACHE_SIZE];
  948     val key = cons(sym, num_fast(id));
  949     val sl = gethash(slot_hash, key);
  950     cnum slnum = coerce(cnum, sl) >> TAG_SHIFT;
  951 
  952     sym->s.slot_cache = slot_cache;
  953 
  954     if (sl) {
  955       cache_set_insert(*set, id, slnum);
  956       if (slnum >= STATIC_SLOT_BASE)
  957         return &st->stslot[slnum - STATIC_SLOT_BASE];
  958     }
  959   }
  960 
  961   return 0;
  962 }
  963 
  964 static loc lookup_static_slot(struct struct_type *st, val sym)
  965 {
  966   struct stslot *stsl = lookup_static_slot_desc(st, sym);
  967   return stsl ? stslot_loc(stsl) : nulloc;
  968 }
  969 
  970 static loc lookup_slot_load(val inst, struct struct_inst *si, val sym)
  971 {
  972   loc ptr = lookup_slot(inst, si, sym);
  973   if (nullocp(ptr)) {
  974     lisplib_try_load(sym);
  975     return lookup_slot(inst, si, sym);
  976   }
  977   return ptr;
  978 }
  979 
  980 static loc lookup_static_slot_load(struct struct_type *st, val sym)
  981 {
  982   loc ptr = lookup_static_slot(st, sym);
  983   if (nullocp(ptr)) {
  984     lisplib_try_load(sym);
  985     return lookup_static_slot(st, sym);
  986   }
  987   return ptr;
  988 }
  989 
  990 static struct stslot *lookup_static_slot_desc_load(struct struct_type *st,
  991                                                    val sym)
  992 {
  993   struct stslot *stsl = lookup_static_slot_desc(st, sym);
  994   if (stsl == 0) {
  995     lisplib_try_load(sym);
  996     return lookup_static_slot_desc(st, sym);
  997   }
  998   return stsl;
  999 }
 1000 
 1001 static noreturn void no_such_slot(val ctx, val type, val slot)
 1002 {
 1003   uw_throwf(error_s, lit("~a: ~s has no slot named ~s"),
 1004             ctx, type, slot, nao);
 1005 }
 1006 
 1007 static noreturn void no_such_static_slot(val ctx, val type, val slot)
 1008 {
 1009   uw_throwf(error_s, lit("~a: ~s has no static slot named ~s"),
 1010             ctx, type, slot, nao);
 1011 }
 1012 
 1013 val slot(val strct, val sym)
 1014 {
 1015   const val self = lit("slot");
 1016   struct struct_inst *si = struct_handle_for_slot(strct, self, sym);
 1017 
 1018   if (sym && symbolp(sym)) {
 1019     loc ptr = lookup_slot_load(strct, si, sym);
 1020     if (!nullocp(ptr))
 1021       return deref(ptr);
 1022   }
 1023 
 1024   no_such_slot(self, si->type->self, sym);
 1025 }
 1026 
 1027 val maybe_slot(val strct, val sym)
 1028 {
 1029   const val self = lit("slot");
 1030   struct struct_inst *si = struct_handle_for_slot(strct, self, sym);
 1031 
 1032   if (sym && symbolp(sym)) {
 1033     loc ptr = lookup_slot_load(strct, si, sym);
 1034     if (!nullocp(ptr))
 1035       return deref(ptr);
 1036   }
 1037 
 1038   return nil;
 1039 }
 1040 
 1041 val slotset(val strct, val sym, val newval)
 1042 {
 1043   const val self = lit("slotset");
 1044   struct struct_inst *si = struct_handle_for_slot(strct, self, sym);
 1045 
 1046   if (sym && symbolp(sym)) {
 1047     loc ptr = lookup_slot(strct, si, sym);
 1048     if (!nullocp(ptr)) {
 1049       if (!si->dirty) {
 1050         if (valptr(ptr) >= &si->slot[0] &&
 1051             valptr(ptr) < &si->slot[si->type->nslots])
 1052         {
 1053           si->dirty = 1;
 1054         }
 1055       }
 1056       return set(ptr, newval);
 1057     }
 1058   }
 1059 
 1060   no_such_slot(self, si->type->self, sym);
 1061 }
 1062 
 1063 val static_slot(val stype, val sym)
 1064 {
 1065   val self = lit("static-slot");
 1066   struct struct_type *st = stype_handle(&stype, self);
 1067 
 1068   if (symbolp(sym)) {
 1069     loc ptr = lookup_static_slot_load(st, sym);
 1070     if (!nullocp(ptr))
 1071       return deref(ptr);
 1072   }
 1073 
 1074   no_such_static_slot(self, stype, sym);
 1075 }
 1076 
 1077 val static_slot_set(val stype, val sym, val newval)
 1078 {
 1079   val self = lit("static-slot-set");
 1080   struct struct_type *st = stype_handle(&stype, self);
 1081 
 1082   if (symbolp(sym)) {
 1083     loc ptr = lookup_static_slot(st, sym);
 1084     if (!nullocp(ptr)) {
 1085       if (st->eqmslot == coerce(struct stslot *, -1))
 1086         st->eqmslot = 0;
 1087       return set(ptr, newval);
 1088     }
 1089   }
 1090 
 1091   no_such_static_slot(self, stype, sym);
 1092 }
 1093 
 1094 val test_dirty(val strct)
 1095 {
 1096   const val self = lit("test-dirty");
 1097   struct struct_inst *si = struct_handle(strct, self);
 1098   return tnil(si->dirty);
 1099 }
 1100 
 1101 val test_clear_dirty(val strct)
 1102 {
 1103   const val self = lit("test-clear-dirty");
 1104   struct struct_inst *si = struct_handle(strct, self);
 1105   val ret = tnil(si->dirty);
 1106   si->dirty = 0;
 1107   return ret;
 1108 }
 1109 
 1110 val clear_dirty(val strct)
 1111 {
 1112   const val self = lit("clear-dirty");
 1113   struct struct_inst *si = struct_handle(strct, self);
 1114   si->dirty = 0;
 1115   return strct;
 1116 }
 1117 
 1118 static void static_slot_home_fixup_rec(struct struct_type *st)
 1119 {
 1120   static_slot_home_fixup(st);
 1121 
 1122   {
 1123     val iter;
 1124 
 1125     for (iter = st->dvtypes; iter; iter = cdr(iter)) {
 1126       val stype = car(iter);
 1127       struct struct_type *st = coerce(struct struct_type *, stype->co.handle);
 1128       static_slot_home_fixup_rec(st);
 1129     }
 1130   }
 1131 }
 1132 
 1133 static void static_slot_rewrite_rec(struct struct_type *st,
 1134                                     struct stslot *from,
 1135                                     struct stslot *to)
 1136 {
 1137   cnum i;
 1138   val iter;
 1139 
 1140   for (iter = st->dvtypes; iter; iter = cdr(iter)) {
 1141     val stype = car(iter);
 1142     struct struct_type *st = coerce(struct struct_type *, stype->co.handle);
 1143     static_slot_rewrite_rec(st, from, to);
 1144   }
 1145 
 1146   for (i = 0; i < st->nstslots; i++) {
 1147     struct stslot *s = &st->stslot[i];
 1148 
 1149     if (s->home_type == from->home_type &&
 1150         s->home == from->home &&
 1151         s->home_offs == from->home_offs)
 1152     {
 1153       *s = *to;
 1154     }
 1155   }
 1156 }
 1157 
 1158 
 1159 static val static_slot_ens_rec(val stype, val sym, val newval,
 1160                                val no_error_p, val self,
 1161                                struct stslot *inh_stsl)
 1162 {
 1163   struct struct_type *st = stype_handle(&stype, self);
 1164   struct stslot *stsl = lookup_static_slot_desc(st, sym);
 1165 
 1166   if (!bindable(sym))
 1167     uw_throwf(error_s, lit("~a: ~s isn't a valid slot name"),
 1168               self, sym, nao);
 1169 
 1170   no_error_p = default_null_arg(no_error_p);
 1171 
 1172   if (st->eqmslot == coerce(struct stslot *, -1))
 1173     st->eqmslot = 0;
 1174 
 1175   if (stsl != 0 && opt_compat && opt_compat <= 151) {
 1176     set(stslot_loc(stsl), newval);
 1177   } else if (stsl != 0 && inh_stsl != 0) {
 1178     return newval;
 1179   } else if (stsl != 0 && stsl->home_type == stype) {
 1180     set(stslot_loc(stsl), newval);
 1181     return newval;
 1182   } else if (stsl == 0 && memq(sym, st->slots)) {
 1183     if (!no_error_p)
 1184       uw_throwf(error_s, lit("~a: ~s is an instance slot of ~s"),
 1185                 self, sym, stype, nao);
 1186     return newval;
 1187   } else if (stsl != 0) {
 1188     struct stslot to;
 1189     to.store = nil;
 1190     to.home_type = stype;
 1191     to.home = &stsl->store;
 1192     to.home_offs = stsl - st->stslot;
 1193     static_slot_rewrite_rec(st, stsl, &to);
 1194     set(stslot_loc(stsl), newval);
 1195     return newval;
 1196   } else {
 1197     struct stslot null_ptr = { nil, 0, 0, nil };
 1198 
 1199     if (st->nstslots >= NUM_MAX)
 1200       uw_throwf(error_s, lit("~a: too many static slots"), self, nao);
 1201 
 1202     st->stslot = coerce(struct stslot *,
 1203                         chk_manage_vec(coerce(mem_t *, st->stslot),
 1204                                        st->nstslots, st->nstslots + 1,
 1205                                        sizeof *st->stslot,
 1206                                        coerce(mem_t *, &null_ptr)));
 1207     static_slot_home_fixup_rec(st);
 1208     set(mkloc(st->slots, stype), append2(st->slots, cons(sym, nil)));
 1209     stsl = &st->stslot[st->nstslots];
 1210 
 1211     if (inh_stsl == 0) {
 1212       stsl->home_type = stype;
 1213       stsl->home_offs = st->nstslots;
 1214       stsl->home = &stsl->store;
 1215       set(stslot_loc(stsl), newval);
 1216       if (!opt_compat || opt_compat > 151)
 1217         inh_stsl = stsl;
 1218     } else {
 1219       stsl->store = nil;
 1220       stsl->home_type = inh_stsl->home_type;
 1221       stsl->home_offs = inh_stsl->home_offs;
 1222       stsl->home = inh_stsl->home;
 1223     }
 1224 
 1225     sethash(slot_hash, cons(sym, num_fast(st->id)),
 1226             num(st->nstslots++ + STATIC_SLOT_BASE));
 1227     static_slot_type_reg(sym, st->name);
 1228   }
 1229 
 1230   {
 1231     val iter;
 1232 
 1233     for (iter = st->dvtypes; iter; iter = cdr(iter))
 1234       static_slot_ens_rec(car(iter), sym, newval, t, self, inh_stsl);
 1235 
 1236     return newval;
 1237   }
 1238 }
 1239 
 1240 val static_slot_ensure(val stype, val sym, val newval, val no_error_p)
 1241 {
 1242   val self = lit("static-slot-ensure");
 1243   val res;
 1244 
 1245   if (!bindable(sym))
 1246     uw_throwf(error_s, lit("~a: ~s isn't a valid slot name"),
 1247               self, sym, nao);
 1248 
 1249   no_error_p = default_null_arg(no_error_p);
 1250   res = static_slot_ens_rec(stype, sym, newval, no_error_p, self, 0);
 1251 
 1252   if (trace_loaded) {
 1253     struct struct_type *st = stype_handle(&stype, self);
 1254     val name = list(meth_s, st->name, sym, nao);
 1255     trace_check(name);
 1256   }
 1257 
 1258   return res;
 1259 }
 1260 
 1261 val static_slot_home(val stype, val sym)
 1262 {
 1263   val self = lit("static-slot-home");
 1264   struct struct_type *st = stype_handle(&stype, self);
 1265   struct stslot *stsl = lookup_static_slot_desc_load(st, sym);
 1266   if (stsl) {
 1267     val home = stsl->home_type;
 1268     struct struct_type *sh = stype_handle(&home, self);
 1269     return sh->name;
 1270   }
 1271   no_such_static_slot(self, stype, sym);
 1272 }
 1273 
 1274 static val call_super_method(val inst, val sym, struct args *args)
 1275 {
 1276   val type = struct_type(inst);
 1277   val suptype = super(type);
 1278 
 1279   if (suptype) {
 1280     val meth = static_slot(suptype, sym);
 1281     args_decl(args_copy, max(args->fill + 1, ARGS_MIN));
 1282     args_add(args_copy, inst);
 1283     args_cat_zap(args_copy, args);
 1284     return generic_funcall(meth, args_copy);
 1285   }
 1286 
 1287   uw_throwf(error_s, lit("call-super-method: ~s has no supertype"),
 1288             suptype, nao);
 1289 }
 1290 
 1291 static val call_super_fun(val type, val sym, struct args *args)
 1292 {
 1293   val self = lit("call-super-fun");
 1294   struct struct_type *st = stype_handle(&type, self);
 1295   val suptype = st->super;
 1296 
 1297   if (suptype) {
 1298     val fun = static_slot(suptype, sym);
 1299     return generic_funcall(fun, args);
 1300   }
 1301 
 1302   uw_throwf(error_s, lit("~a: ~s has no supertype"),
 1303             self, type, nao);
 1304 }
 1305 
 1306 val slotp(val type, val sym)
 1307 {
 1308   struct struct_type *st = stype_handle(&type, lit("slotp"));
 1309   return tnil(memq(sym, st->slots));
 1310 }
 1311 
 1312 val static_slot_p(val type, val sym)
 1313 {
 1314   struct struct_type *st = stype_handle(&type, lit("static-slot-p"));
 1315 
 1316   if (memq(sym, st->slots)) {
 1317     val key = cons(sym, num_fast(st->id));
 1318     val sl = gethash(slot_hash, key);
 1319     cnum slnum = coerce(cnum, sl) >> TAG_SHIFT;
 1320 
 1321     if (sl && slnum >= STATIC_SLOT_BASE)
 1322       return t;
 1323   }
 1324 
 1325   return nil;
 1326 }
 1327 
 1328 val slots(val stype)
 1329 {
 1330   struct struct_type *st = stype_handle(&stype, lit("slots"));
 1331   return st->slots;
 1332 }
 1333 
 1334 val structp(val obj)
 1335 {
 1336   return tnil(cobjp(obj) && obj->co.ops == &struct_inst_ops);
 1337 }
 1338 
 1339 val struct_type(val strct)
 1340 {
 1341   const val self = lit("struct-type");
 1342   struct struct_inst *si = struct_handle(strct, self);
 1343   return si->type->self;
 1344 }
 1345 
 1346 val struct_type_name(val stype)
 1347 {
 1348   struct struct_type *st = stype_handle(&stype, lit("struct-type-name"));
 1349   return st->name;
 1350 }
 1351 
 1352 static val method_fun(val env, varg args)
 1353 {
 1354   cons_bind (fun, strct, env);
 1355   args_decl(args_copy, max(args->fill + 1, ARGS_MIN));
 1356   args_add(args_copy, strct);
 1357   args_cat_zap(args_copy, args);
 1358   return generic_funcall(fun, args_copy);
 1359 }
 1360 
 1361 static val method_args_fun(val env, varg args)
 1362 {
 1363   cons_bind (curried_args, fun_strct, env);
 1364   cons_bind (fun, strct, fun_strct);
 1365   cnum ca_len = c_num(length(curried_args));
 1366   args_decl(args_call, max(args->fill + 1 + ca_len, ARGS_MIN));
 1367   args_add(args_call, strct);
 1368   args_add_list(args_call, curried_args);
 1369   args_normalize_exact(args_call, ca_len + 1);
 1370   args_cat_zap(args_call, args);
 1371   return generic_funcall(fun, args_call);
 1372 }
 1373 
 1374 val method(val strct, val slotsym)
 1375 {
 1376   return func_f0v(cons(slot(strct, slotsym), strct), method_fun);
 1377 }
 1378 
 1379 val method_args(val strct, val slotsym, struct args *args)
 1380 {
 1381   if (!args_more(args, 0))
 1382     return func_f0v(cons(slot(strct, slotsym), strct), method_fun);
 1383   else
 1384     return func_f0v(cons(args_get_list(args),
 1385                          cons(slot(strct, slotsym), strct)), method_args_fun);
 1386 }
 1387 
 1388 
 1389 val super_method(val strct, val slotsym)
 1390 {
 1391   val super_slot = static_slot(super(struct_type(strct)), slotsym);
 1392   return func_f0v(cons(super_slot, strct), method_fun);
 1393 }
 1394 
 1395 static val uslot_fun(val sym, val strct)
 1396 {
 1397   val self = lit("uslot");
 1398   struct struct_inst *si = struct_handle_for_slot(strct, self, sym);
 1399 
 1400   if (sym && symbolp(sym)) {
 1401     loc ptr = lookup_slot(strct, si, sym);
 1402     if (!nullocp(ptr))
 1403       return deref(ptr);
 1404   }
 1405 
 1406   no_such_slot(self, si->type->self, sym);
 1407 }
 1408 
 1409 val uslot(val slot)
 1410 {
 1411   return func_f1(slot, uslot_fun);
 1412 }
 1413 
 1414 static val umethod_fun(val sym, struct args *args)
 1415 {
 1416   val self = lit("umethod");
 1417 
 1418   if (!args_more(args, 0)) {
 1419     uw_throwf(error_s, lit("~a: object argument required to call ~s"),
 1420               self, env, nao);
 1421   } else {
 1422     val strct = args_at(args, 0);
 1423 
 1424     struct struct_inst *si = struct_handle_for_slot(strct, self, sym);
 1425 
 1426     if (sym && symbolp(sym)) {
 1427       loc ptr = lookup_slot(strct, si, sym);
 1428       if (!nullocp(ptr))
 1429         return generic_funcall(deref(ptr), args);
 1430     }
 1431 
 1432     no_such_slot(self, si->type->self, sym);
 1433   }
 1434 }
 1435 
 1436 static val umethod_args_fun(val env, struct args *args)
 1437 {
 1438   val self = lit("umethod");
 1439   cons_bind (sym, curried_args, env);
 1440 
 1441   if (!args_more(args, 0)) {
 1442     uw_throwf(error_s, lit("~a: object argument required to call ~s"),
 1443               self, env, nao);
 1444   } else {
 1445     cnum ca_len = c_num(length(curried_args));
 1446     cnum index = 0;
 1447     val strct = args_get(args, &index);
 1448     args_decl(args_call, max(args->fill + ca_len, ARGS_MIN));
 1449     args_add(args_call, strct);
 1450     args_add_list(args_call, curried_args);
 1451     args_normalize_exact(args_call, ca_len + 1);
 1452     args_cat_zap_from(args_call, args, index);
 1453 
 1454     struct struct_inst *si = struct_handle_for_slot(strct, self, sym);
 1455 
 1456     if (sym && symbolp(sym)) {
 1457       loc ptr = lookup_slot(strct, si, sym);
 1458       if (!nullocp(ptr))
 1459         return generic_funcall(deref(ptr), args_call);
 1460     }
 1461 
 1462     no_such_slot(self, si->type->self, sym);
 1463   }
 1464 }
 1465 
 1466 val umethod(val slot, struct args *args)
 1467 {
 1468   if (!args_more(args, 0))
 1469     return func_f0v(slot, umethod_fun);
 1470   else
 1471     return func_f0v(cons(slot, args_get_list(args)), umethod_args_fun);
 1472 }
 1473 
 1474 static void struct_inst_print(val obj, val out, val pretty,
 1475                               struct strm_ctx *ctx)
 1476 {
 1477   struct struct_inst *si = coerce(struct struct_inst *, obj->co.handle);
 1478   struct struct_type *st = si->type;
 1479   val save_mode = test_neq_set_indent_mode(out, num_fast(indent_foff),
 1480                                            num_fast(indent_data));
 1481   val save_indent, iter, once;
 1482   int force_br = 0;
 1483   int compat = opt_compat && opt_compat <= 154;
 1484 
 1485   if (!compat || pretty) {
 1486     loc ptr = lookup_static_slot_load(st, print_s);
 1487     if (!nullocp(ptr)) {
 1488       if (compat)
 1489         funcall2(deref(ptr), obj, out);
 1490       else if (funcall3(deref(ptr), obj, out, pretty) != colon_k)
 1491         return;
 1492     }
 1493   }
 1494 
 1495   put_string(lit("#S("), out);
 1496   obj_print_impl(st->name, out, pretty, ctx);
 1497   save_indent = inc_indent(out, one);
 1498 
 1499   for (iter = st->slots, once = t; iter; iter = cdr(iter)) {
 1500     val sym = car(iter);
 1501     if (!static_slot_p(st->self, sym)) {
 1502       if (once) {
 1503         put_char(chr(' '), out);
 1504         once = nil;
 1505       } else {
 1506         if (width_check(out, chr(' ')))
 1507           force_br = 1;
 1508       }
 1509       obj_print_impl(sym, out, pretty, ctx);
 1510       put_char(chr(' '), out);
 1511       obj_print_impl(slot(obj, sym), out, pretty, ctx);
 1512     }
 1513   }
 1514   put_char(chr(')'), out);
 1515   if (force_br)
 1516     force_break(out);
 1517   set_indent_mode(out, save_mode);
 1518   set_indent(out, save_indent);
 1519 }
 1520 
 1521 static void struct_inst_mark(val obj)
 1522 {
 1523   struct struct_inst *si = coerce(struct struct_inst *, obj->co.handle);
 1524   struct struct_type *st = si->type;
 1525   cnum sl, nslots = st->nslots;
 1526 
 1527   if (si->lazy)
 1528     nslots = 1;
 1529 
 1530   for (sl = 0; sl < nslots; sl++)
 1531     gc_mark(si->slot[sl]);
 1532   gc_mark(st->self);
 1533 }
 1534 
 1535 static val struct_inst_equal(val left, val right)
 1536 {
 1537   struct struct_inst *ls = coerce(struct struct_inst *, left->co.handle);
 1538   struct struct_inst *rs = coerce(struct struct_inst *, right->co.handle);
 1539   struct struct_type *st = ls->type;
 1540   cnum nslots = st->nslots, sl;
 1541 
 1542   if (st != rs->type)
 1543     return nil;
 1544 
 1545   check_init_lazy_struct(left, ls);
 1546   check_init_lazy_struct(right, rs);
 1547 
 1548   for (sl = 0; sl < nslots; sl++)
 1549     if (!equal(ls->slot[sl], rs->slot[sl]))
 1550       return nil;
 1551 
 1552   gc_hint(left);
 1553   gc_hint(right);
 1554   return t;
 1555 }
 1556 
 1557 static ucnum struct_inst_hash(val obj, int *count, ucnum seed)
 1558 {
 1559   struct struct_inst *si = coerce(struct struct_inst *, obj->co.handle);
 1560   struct struct_type *st = si->type;
 1561   cnum nslots = st->nslots, sl;
 1562   ucnum out = equal_hash(st->self, count, seed);
 1563 
 1564   check_init_lazy_struct(obj, si);
 1565 
 1566   for (sl = 0; sl < nslots; sl++) {
 1567     cnum hash = equal_hash(si->slot[sl], count, seed);
 1568     out += hash;
 1569     out &= NUM_MAX;
 1570   }
 1571 
 1572   return out;
 1573 }
 1574 
 1575 static val get_equal_method(struct struct_type *st)
 1576 {
 1577   if (st->eqmslot == coerce(struct stslot *, -1)) {
 1578     return nil;
 1579   } else if (st->eqmslot) {
 1580     struct stslot *stsl = st->eqmslot;
 1581     return stslot_place(stsl);
 1582   } else {
 1583     struct stslot *stsl = lookup_static_slot_desc(st, equal_s);
 1584     if (stsl != 0) {
 1585       st->eqmslot = stsl;
 1586       return stslot_place(stsl);
 1587     }
 1588     st->eqmslot = coerce(struct stslot *, -1);
 1589     return nil;
 1590   }
 1591 }
 1592 
 1593 static val struct_inst_equalsub(val obj)
 1594 {
 1595   struct struct_inst *si = coerce(struct struct_inst *, obj->co.handle);
 1596   struct struct_type *st = si->type;
 1597   val equal_method = get_equal_method(st);
 1598   if (equal_method) {
 1599     val sub = funcall1(equal_method, obj);
 1600     if (nilp(sub)) {
 1601       uw_throwf(error_s, lit("equal method on type ~s returned nil"),
 1602                 st->self, nao);
 1603     }
 1604     return sub;
 1605   }
 1606   return nil;
 1607 }
 1608 
 1609 val method_name(val fun)
 1610 {
 1611   val sth_iter = hash_begin(struct_type_hash);
 1612   val sth_cell;
 1613 
 1614   while ((sth_cell = hash_next(sth_iter))) {
 1615     val sym = us_car(sth_cell);
 1616     val stype = us_cdr(sth_cell);
 1617     val sl_iter;
 1618     struct struct_type *st = coerce(struct struct_type *, stype->co.handle);
 1619 
 1620     for (sl_iter = st->slots; sl_iter; sl_iter = cdr(sl_iter)) {
 1621       val slot = car(sl_iter);
 1622       loc ptr = lookup_static_slot(st, slot);
 1623 
 1624       if (!nullocp(ptr) && deref(ptr) == fun) {
 1625         val sstype;
 1626 
 1627         while ((sstype = super(stype)) != nil) {
 1628           struct struct_type *sst = coerce(struct struct_type *,
 1629                                            sstype->co.handle);
 1630           loc sptr = lookup_static_slot(sst, slot);
 1631           if (!nullocp(sptr) && deref(sptr) == fun) {
 1632             stype = sstype;
 1633             sym = sst->name;
 1634             continue;
 1635           }
 1636 
 1637           break;
 1638         }
 1639 
 1640         return list(meth_s, sym, slot, nao);
 1641       }
 1642     }
 1643 
 1644     if (st->initfun == fun)
 1645       return list(meth_s, sym, init_k, nao);
 1646 
 1647     if (st->postinitfun == fun)
 1648       return list(meth_s, sym, postinit_k, nao);
 1649   }
 1650 
 1651   return nil;
 1652 }
 1653 
 1654 val get_slot_syms(val package, val is_current, val method_only)
 1655 {
 1656   val result_hash = make_hash(nil, nil, nil);
 1657   val sth_iter = hash_begin(struct_type_hash);
 1658   val sth_cell;
 1659 
 1660   while ((sth_cell = hash_next(sth_iter))) {
 1661     val stype = us_cdr(sth_cell);
 1662     val sl_iter;
 1663     struct struct_type *st = coerce(struct struct_type *, stype->co.handle);
 1664 
 1665     for (sl_iter = st->slots; sl_iter; sl_iter = cdr(sl_iter)) {
 1666       val slot = car(sl_iter);
 1667 
 1668       if (gethash(result_hash, slot))
 1669         continue;
 1670 
 1671       if (!is_current && symbol_package(slot) != package)
 1672         continue;
 1673 
 1674       if (!symbol_visible(package, slot))
 1675         continue;
 1676 
 1677       if (method_only) {
 1678         loc ptr = lookup_static_slot(st, slot);
 1679         if (nullocp(ptr))
 1680           continue;
 1681         if (!functionp(deref(ptr)))
 1682           continue;
 1683       }
 1684 
 1685       sethash(result_hash, slot, t);
 1686     }
 1687   }
 1688 
 1689   return result_hash;
 1690 }
 1691 
 1692 val slot_types(val slot)
 1693 {
 1694   return gethash(slot_type_hash, slot);
 1695 }
 1696 
 1697 val static_slot_types(val slot)
 1698 {
 1699   return gethash(static_slot_type_hash, slot);
 1700 }
 1701 
 1702 val slot_type_reg(val slot, val strct)
 1703 {
 1704   val typelist = gethash(slot_type_hash, slot);
 1705 
 1706   if (!memq(strct, typelist)) {
 1707     sethash(slot_type_hash, slot, cons(strct, typelist));
 1708     uw_purge_deferred_warning(cons(slot_s, slot));
 1709   }
 1710 
 1711   return slot;
 1712 }
 1713 
 1714 val static_slot_type_reg(val slot, val strct)
 1715 {
 1716   val typelist = gethash(static_slot_type_hash, slot);
 1717 
 1718   if (!memq(strct, typelist)) {
 1719     sethash(slot_type_hash, slot, cons(strct, typelist));
 1720     uw_purge_deferred_warning(cons(slot_s, slot));
 1721   }
 1722 
 1723   return slot;
 1724 }
 1725 
 1726 static_def(struct cobj_ops struct_type_ops =
 1727            cobj_ops_init(eq, struct_type_print, struct_type_destroy,
 1728                          struct_type_mark, cobj_eq_hash_op));
 1729 
 1730 struct cobj_ops struct_inst_ops =
 1731   cobj_ops_init_ex(struct_inst_equal, struct_inst_print,
 1732                    cobj_destroy_free_op, struct_inst_mark,
 1733                    struct_inst_hash, struct_inst_equalsub);