Introducing lazy structs.

* share/txr/stdlib/struct.tl (lnew): New macro.

* struct.c (struct_type): Turn id into a bitfield one bit
smaller than cnum. New Boolean bitfield lazy.
(struct_init): Register make-lazy-struct intrinsic.
(make_struct): Initialize lazy bitfield to zero.
(lazy_struct_init, check_init_lazy_struct): New static
functions.
(make_lazy_struct): New function.
(copy_struct, clear_struct, replace_struct, reset_struct,
lookup_slot, struct_inst_equal, struct_inst_hash):
Call check_init_lazy_struct on all structures involved.
(lookup_slot): Call check_init_lazy_struct.
(struct_inst_mark): If the struct is lazy, it has one
instance slot which must be marked, holding the argfun
function passed into make_lazy_struct.

* struct.h (make_lazy_struct): Declared.

* txr.1: Documented lnew and make-lazy-struct.

4 files changed, 182 insertions, 3 deletions

diff --git a/share/txr/stdlib/struct.tl b/share/txr/stdlib/struct.tl
index 5cbf3c83..8eb4d35c 100644
--- a/share/txr/stdlib/struct.tl
+++ b/share/txr/stdlib/struct.tl
@@ -188,6 +188,18 @@
       ((atom . args) ^(make-struct ',atom (list ,*qpairs) ,*args))
       (atom ^(make-struct ',atom (list ,*qpairs))))))
 
+(defmacro lnew (spec . pairs)
+  (if (oddp (length pairs))
+    (throwf 'eval-error "~s: slot initform arguments must occur pairwise"
+            'lnew))
+  (let ((qpairs (mappend (aret ^(',@1 ,@2)) (tuples 2 pairs))))
+    (tree-case spec
+      ((atom . args) ^(make-lazy-struct ',atom
+                                        (lambda ()
+                                          (cons (list ,*qpairs)
+                                                (list ,*args)))))
+      (atom ^(make-lazy-struct ',atom (lambda () (list (list ,*qpairs))))))))
+
 (defmacro meth (obj slot)
   ^(method ,obj ',slot))
 
diff --git a/struct.c b/struct.c
index acd28f68..d4521314 100644
--- a/struct.c
+++ b/struct.c
@@ -67,7 +67,8 @@ struct struct_type {
 
 struct struct_inst {
   val type;
-  cnum id;
+  cnum id : sizeof (cnum) * CHAR_BIT - 1 ;
+  unsigned lazy : 1;
   val slot[1];
 };
 
@@ -110,6 +111,8 @@ void struct_init(void)
   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("make-lazy-struct"), user_package),
+          func_n2(make_lazy_struct));
   reg_fun(intern(lit("copy-struct"), user_package), func_n1(copy_struct));
   reg_fun(intern(lit("replace-struct"), user_package), func_n2(replace_struct));
   reg_fun(intern(lit("clear-struct"), user_package), func_n2o(clear_struct, 1));
@@ -366,7 +369,7 @@ val make_struct(val type, val plist, struct args *args)
     si->slot[sl] = nil;
   si->type = nil;
   si->id = st->id;
-
+  si->lazy = 0;
 
   sinst = cobj(coerce(mem_t *, si), st->name, &struct_inst_ops);
 
@@ -398,6 +401,75 @@ val make_struct(val type, val plist, struct args *args)
   return sinst;
 }
 
+static void lazy_struct_init(val sinst, struct struct_inst *si)
+{
+  val self = lit("make-lazy-struct");
+  struct struct_type *st = coerce(struct struct_type *, si->type->co.handle);
+  volatile val inited = nil;
+  val cell = funcall(si->slot[0]);
+  cons_bind (plist, args, cell);
+
+  si->lazy = 0;
+  si->slot[0] = nil;
+
+  if (args && !st->boactor) {
+    uw_throwf(error_s,
+              lit("~a: args present, but ~s has no boa constructor"),
+              self, type, nao);
+  }
+
+  uw_simple_catch_begin;
+
+  call_initfun_chain(st, sinst);
+
+  for (; plist; plist = cddr(plist))
+    slotset(sinst, car(plist), cadr(plist));
+
+  if (args) {
+    args_decl_list(argv, ARGS_MIN, cons(sinst, args));
+    generic_funcall(st->boactor, argv);
+  }
+
+  inited = t;
+
+  uw_unwind {
+    if (!inited)
+      gc_call_finalizers(sinst);
+  }
+
+  uw_catch_end;
+}
+
+INLINE void check_init_lazy_struct(val sinst, struct struct_inst *si)
+{
+  if (si->lazy)
+    lazy_struct_init(sinst, si);
+}
+
+val make_lazy_struct(val type, val argfun)
+{
+  val self = lit("make-lazy-struct");
+  struct struct_type *st = stype_handle(&type, self);
+  cnum nslots = st->nslots, sl;
+  cnum nalloc = nslots ? nslots : 1;
+  size_t size = offsetof(struct struct_inst, slot) + sizeof (val) * nalloc;
+  struct struct_inst *si = coerce(struct struct_inst *, chk_malloc(size));
+  val sinst;
+
+  for (sl = 0; sl < nslots; sl++)
+    si->slot[sl] = nil;
+  si->type = nil;
+  si->id = st->id;
+  si->lazy = 1;
+
+  sinst = cobj(coerce(mem_t *, si), st->name, &struct_inst_ops);
+
+  si->type = type;
+  si->slot[0] = argfun;
+
+  return sinst;
+}
+
 static struct struct_inst *struct_handle(val obj, val ctx)
 {
   if (cobjp(obj) && obj->co.ops == &struct_inst_ops)
@@ -415,6 +487,7 @@ val copy_struct(val strct)
   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));
+  check_init_lazy_struct(strct, si);
   memcpy(si_copy, si, size);
   copy = cobj(coerce(mem_t *, si_copy), st->name, &struct_inst_ops);
   gc_hint(strct);
@@ -429,6 +502,8 @@ val clear_struct(val strct, val value)
   val clear_val = default_bool_arg(value);
   cnum i;
 
+  check_init_lazy_struct(strct, si);
+
   for (i = 0; i < st->nslots; i++)
     si->slot[i] = clear_val;
 
@@ -444,6 +519,10 @@ val replace_struct(val target, val source)
   cnum nslots = sst->nslots;
   size_t size = offsetof(struct struct_inst, slot) + sizeof (val) * nslots;
   struct struct_inst *ssi_copy = coerce(struct struct_inst *, chk_malloc(size));
+
+  check_init_lazy_struct(source, ssi);
+  check_init_lazy_struct(target, tsi);
+
   memcpy(ssi_copy, ssi, size);
   free(tsi);
   target->co.handle = coerce(mem_t *, ssi_copy);
@@ -458,6 +537,8 @@ val reset_struct(val strct)
   struct struct_type *st = coerce(struct struct_type *, si->type->co.handle);
   cnum i;
 
+  check_init_lazy_struct(strct, si);
+
   for (i = 0; i < st->nslots; i++)
     si->slot[i] = nil;
 
@@ -517,6 +598,8 @@ static loc lookup_slot(val inst, struct struct_inst *si, val sym)
   slot_cache_t slot_cache = sym->s.slot_cache;
   cnum id = si->id;
 
+  check_init_lazy_struct(inst, si);
+
   if (slot_cache != 0) {
     slot_cache_set_t *set = &slot_cache[id % SLOT_CACHE_SIZE];
     cnum slot = cache_set_lookup(*set, id);
@@ -874,6 +957,9 @@ static void struct_inst_mark(val obj)
   struct struct_type *st = coerce(struct struct_type *, si->type->co.handle);
   cnum sl, nslots = st->nslots;
 
+  if (si->lazy)
+    nslots = 1;
+
   for (sl = 0; sl < nslots; sl++)
     gc_mark(si->slot[sl]);
   gc_mark(si->type);
@@ -889,6 +975,9 @@ static val struct_inst_equal(val left, val right)
   if (rs->type != ls->type)
     return nil;
 
+  check_init_lazy_struct(left, ls);
+  check_init_lazy_struct(right, rs);
+
   for (sl = 0; sl < nslots; sl++)
     if (!equal(ls->slot[sl], rs->slot[sl]))
       return nil;
@@ -904,6 +993,8 @@ static cnum struct_inst_hash(val obj)
   struct struct_type *st = coerce(struct struct_type *, si->type->co.handle);
   cnum nslots = st->nslots, sl, out = c_num(hash_equal(si->type));
 
+  check_init_lazy_struct(obj, si);
+
   for (sl = 0; sl < nslots; sl++) {
     val hash = hash_equal(si->slot[sl]);
     out += c_num(hash);
diff --git a/struct.h b/struct.h
index d5545bf4..3d5b1942 100644
--- a/struct.h
+++ b/struct.h
@@ -31,6 +31,7 @@ val make_struct_type(val name, val super,
 val struct_type_p(val obj);
 val super(val type);
 val make_struct(val type, val plist, struct args *);
+val make_lazy_struct(val type, val argfun);
 val copy_struct(val strct);
 val clear_struct(val strct, val value);
 val replace_struct(val target, val source);
diff --git a/txr.1 b/txr.1
index 4aba9eb3..d6b128ef 100644
--- a/txr.1
+++ b/txr.1
@@ -18599,9 +18599,10 @@ are applied to the structure as if it were a function, the
 method is invoked with those arguments, with the object itself inserted
 into the leftmost argument position.
 
-.coNP Macro @ new
+.coNP Macros @ new and @ lnew
 .synb
 .mets (new >> { name | >> ( name << arg *)} >> { slot << init-form }*)
+.mets (lnew >> { name | >> ( name << arg *)} >> { slot << init-form }*)
 .syne
 .desc
 The
@@ -18646,6 +18647,32 @@ If any of the initializations abandon the evaluation of
 by a non-local exit such as an exception throw, the object's
 finalizers, if any, are invoked.
 
+The macro
+.code lnew
+differs from new in that it specifies the construction of a
+lazy struct, as if by the
+.code make-lazy-struct
+function.
+When
+.code lnew
+is used to construct an instance, a lazy struct is returned
+immediately, without evaluating any of the the
+.meta arg
+and
+.meta init-form
+expressions.
+The expressions are evaluated when any of the object's
+instance slots is accessed for the first time. At that time,
+these expressions are evaluated (in the same order as under
+.codn new )
+and initialization proceeds in the same way.
+
+If any of the initializations abandon the delayed initializations steps
+arranged by
+.code lnew
+by a non-local exit such as an exception throw, the object's
+finalizers, if any, are invoked.
+
 .coNP Macro @ qref
 .synb
 .mets (qref < object-form
@@ -19123,6 +19150,54 @@ If any of the initializations abandon the evaluation of
 by a non-local exit such as an exception throw, the object's
 finalizers, if any, are invoked.
 
+.coNP Function @ make-lazy-struct
+.synb
+.mets (make-lazy-struct < type << argfun )
+.syne
+.desc
+The
+.code make-lazy-struct
+function returns a new object which is an instance of the
+structure type
+.metn type .
+
+The
+.meta type
+argument must either be a
+.code struct-type
+object, or else a symbol which is the name of a structure.
+
+The
+.meta argfun
+argument should be a function which can be called with no parameters
+and returns a cons cell. More requirements are specified below.
+
+The object returned by
+.code make-lazy-struct
+is a lazily-initialized struct instance, or
+.IR "lazy struct" .
+
+A lazy struct remains uninitialized until just before the first access
+to any of its instance slots. Just before an instance slot is
+accessed, initialization
+takes place as follows. The
+.meta argfun
+function is invoked with no arguments. Its return value must be a cons
+cell. The
+.code car
+of the cons cell is taken to be a property list, as defined by the
+.code prop
+function.  The
+.code cdr
+field is taken to be a list of arguments. These values are treated
+as if they were, respectively, the
+.meta slot-init-plist
+and the boa constructor arguments given in a
+.code make-struct
+invocation. Initialization of the structure proceeds as described
+in the description of
+.codn make-struct .
+
 .coNP Function @ copy-struct
 .synb
 .mets (copy-struct << struct-obj )