Define UVECTOR and ATOM

Signed-off-by: Kaz Wesley <keziahw@gmail.com>

diff --git a/src/Makefile.am b/src/Makefile.am
index 2da8bbdeb6608964f1cbd4cb54c6bff79f64d139..922b9b6f3e2e7f4202ca6b358919374a7f0e3b64 100644 (file)
--- a/src/Makefile.am
+++ b/src/Makefile.am
@@ -1,3 +1,3 @@
 bin_PROGRAMS = muddle
-muddle_SOURCES = main.c read.c eval.c print.c alloc.c object.c
+muddle_SOURCES = main.c read.c eval.c print.c alloc.c object.c atom.c
 muddle_CFLAGS = -Wall -Wno-unused-function -Werror=implicit-function-declaration -Werror=incompatible-pointer-types

diff --git a/src/alloc.h b/src/alloc.h
index 2c7e6a041b56dae49d70735184335bc7bce17865..58ee8081e391dde43b3738420666453df668c6b4 100644 (file)
--- a/src/alloc.h
+++ b/src/alloc.h
@@ -34,10 +34,15 @@ object *HEAP_OBJECT (heap_ptr p);
 
 pool_ptr pool_alloc (uint32_t len);
 heap_ptr heap_alloc (uint32_t len);
+inline static heap_ptr
+heap_alloc_uv (uint32_t len)
+{
+  return heap_alloc ((len + 1) >> 1);
+}
 
 // given a headerless array of objects of known size,
 // copy it backwards into newly-allocated pool space
-pool_ptr pool_copy_array_rev (const pool_object *objs, uint32_t len);
-heap_ptr heap_copy_array_rev (const object *objs, uint32_t len);
+pool_ptr pool_copy_array_rev (const pool_object * objs, uint32_t len);
+heap_ptr heap_copy_array_rev (const object * objs, uint32_t len);
 
 #endif // ALLOC_H

diff --git a/src/atom.c b/src/atom.c
new file mode 100644 (file)
index 0000000..38cadc0
--- /dev/null
+++ b/src/atom.c
@@ -0,0 +1,20 @@
+/*
+Copyright (C) 2017-2018 Keziah Wesley
+
+You can redistribute and/or modify this file under the terms of the
+GNU Affero General Public License as published by the Free Software
+Foundation, either version 3 of the License, or (at your option) any
+later version.
+
+This file is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+Affero General Public License for more details.
+
+You should have received a copy of the GNU Affero General Public
+License along with this file. If not, see
+<http://www.gnu.org/licenses/>.
+*/
+
+#include "alloc.h"
+#include "atom.h"

diff --git a/src/atom.h b/src/atom.h
new file mode 100644 (file)
index 0000000..5b71ad3
--- /dev/null
+++ b/src/atom.h
@@ -0,0 +1,34 @@
+/*
+Copyright (C) 2017-2018 Keziah Wesley
+
+You can redistribute and/or modify this file under the terms of the
+GNU Affero General Public License as published by the Free Software
+Foundation, either version 3 of the License, or (at your option) any
+later version.
+
+This file is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+Affero General Public License for more details.
+
+You should have received a copy of the GNU Affero General Public
+License along with this file. If not, see
+<http://www.gnu.org/licenses/>.
+*/
+
+#ifndef ATOM_H
+#define ATOM_H
+
+#include "object.h"
+
+typedef struct
+{
+  evaltype type;               // UNBOUND/LOCI
+  // bindid
+  // value ptr
+  // oblist ptr
+  // type ptr
+  const char pname[];
+} atom_body;
+
+#endif

diff --git a/src/eval.c b/src/eval.c
index e563fdfd3acd91eab0048e537b7d7a1aba039b7f..f322946410a159bb45490395529367dde5520722 100644 (file)
--- a/src/eval.c
+++ b/src/eval.c
@@ -111,25 +111,25 @@ eval_rest ()
   // store result of previous call
   pool_object *prev_res = as_pool (&ret);
   list_object *tail = as_list (&cf->locals[1]);
-  *POOL_OBJECT (tail->head) = (pool_object)
+  *POOL_OBJECT (tail->val.head) = (pool_object)
   {
-  .type = prev_res->type,.rest = tail->head + 1,.val = prev_res->val};
+  .type = prev_res->type,.rest = tail->val.head + 1,.val = prev_res->val};
 
   // advance input and output
   assert (cf->args.len == 1);
   list_object *args = as_list (&cf->args.body[0]);
-  assert (args->head);
-  args->head = POOL_OBJECT (args->head)->rest;
-  if (!args->head)
+  assert (args->val.head);
+  args->val.head = POOL_OBJECT (args->val.head)->rest;
+  if (!args->val.head)
     {
-      POOL_OBJECT (tail->head)->rest = 0;
+      POOL_OBJECT (tail->val.head)->rest = 0;
       RETURN (cf->locals[0]);
     }
-  tail->head++;
+  tail->val.head++;
 
   // eval next element
   END_LOCALS ();
-  CALL_THEN (eval, new_tuple ((object *) POOL_OBJECT (args->head), 1),
+  CALL_THEN (eval, new_tuple ((object *) POOL_OBJECT (args->val.head), 1),
             eval_rest);
 }
 
@@ -145,7 +145,7 @@ eval ()
     case EVALTYPE_LIST:
       // Handle `head` now; then iterate on `.rest`.
 
-      if (!cf->args.body[0].list.head)
+      if (!cf->args.body[0].list.val.head)
        RETURN (cf->args.body[0]);
       // locals: { list_object list, list_object tail }
       cst += 2;
@@ -157,11 +157,11 @@ eval ()
       END_LOCALS ();
       CALL_THEN (eval,
                 new_tuple ((object *)
-                           POOL_OBJECT (cf->args.body[0].list.head), 1),
+                           POOL_OBJECT (cf->args.body[0].list.val.head), 1),
                 eval_rest);
     case EVALTYPE_FORM:
       // `<>` is a special case.
-      if (!cf->args.body[0].list.head)
+      if (!cf->args.body[0].list.val.head)
        {
          cf->args.body[0].type = EVALTYPE_FALSE;
          RETURN (cf->args.body[0]);
@@ -170,7 +170,7 @@ eval ()
       END_LOCALS ();
       CALL_THEN (eval,
                 new_tuple ((object *)
-                           POOL_OBJECT (cf->args.body[0].list.head), 1),
+                           POOL_OBJECT (cf->args.body[0].list.val.head), 1),
                 call);
       /*
          case EVALTYPE_VECTOR: TAILCALL(eval_vector);

diff --git a/src/main.c b/src/main.c
index 0819cc9abd0cea517935ad69c786fc8779a9a747..6645f6e4564f72f72f67d1bea7949761452be844 100644 (file)
--- a/src/main.c
+++ b/src/main.c
@@ -105,9 +105,9 @@ main ()
       // Eval the thing
       cf->prevcst = cst;
       push_frame (eval, new_tuple (st.pos, 1), 0);
-      while (cf->cont.fn)
+      while (cf->cont.val.fn)
        {
-         cf->cont.fn ();
+         cf->cont.val.fn ();
        }
       // Print the thing
       print_object (&ret);

diff --git a/src/object.c b/src/object.c
index a2a81a62e478134ddd188ec4188c0fbe9a2c869d..ff65f41651060c96e103a875cc06d96c1d6f53e3 100644 (file)
--- a/src/object.c
+++ b/src/object.c
@@ -21,7 +21,7 @@ License along with this file. If not, see
 uint32_t
 list_length (const list_object * o)
 {
-  const pool_object *p = POOL_OBJECT (o->head);
+  const pool_object *p = POOL_OBJECT (o->val.head);
   uint32_t n = 0;
   while (p)
     {

diff --git a/src/object.h b/src/object.h
index 1d9918e20a415404bfe1e0f5005643452bae256b..ec322b5d219547c405b6632735a3a0130fce5663 100644 (file)
--- a/src/object.h
+++ b/src/object.h
@@ -31,14 +31,18 @@ typedef uint32_t evaltype;
 enum
 {
 // pool OK
+  TYPEPRIM_LOSE = 0x00000000,
   TYPEPRIM_FIX32 = 0x00010000,
   TYPEPRIM_FIX64 = 0x00020000,
   TYPEPRIM_LIST = 0x00030000,
   TYPEPRIM_VECTOR = 0x00040000,
-  TYPEPRIM_SUBR = 0x00050000,
+  TYPEPRIM_UVECTOR = 0x00050000,
+  TYPEPRIM_SUBR = 0x00060000,
+  TYPEPRIM_ATOM = 0x00070000,
 
 // can't be in pool
   TYPEPRIM_NOPOOL_MASK = 0x70000000,
+  TYPEPRIM_VECTOR_BODY = 0x70000000,
   TYPEPRIM_TUPLE = 0x70010000,
 
 // TYPEPRIM is half of EVALTYPE
@@ -47,6 +51,8 @@ enum
 
 enum
 {
+  EVALTYPE_LOSE = TYPEPRIM_LOSE,
+
   EVALTYPE_FIX32 = TYPEPRIM_FIX32,
 
   EVALTYPE_FIX64 = TYPEPRIM_FIX64,
@@ -57,8 +63,16 @@ enum
 
   EVALTYPE_VECTOR = TYPEPRIM_VECTOR,
 
+  EVALTYPE_UVECTOR = TYPEPRIM_UVECTOR,
+  EVALTYPE_OBLIST,
+
   EVALTYPE_SUBR = TYPEPRIM_SUBR,
 
+  EVALTYPE_ATOM = TYPEPRIM_ATOM,
+
+  EVALTYPE_VECTOR_BODY = TYPEPRIM_VECTOR_BODY,
+  EVALTYPE_ATOM_BODY,
+
   EVALTYPE_TUPLE = TYPEPRIM_TUPLE,
 };
 
@@ -106,44 +120,88 @@ about types.
 
 typedef union object object;
 
+typedef struct
+{
+  alignas (8) uint32_t _pad;
+  int32_t n;
+} fix32_val;
 typedef struct
 {
   alignas (16) evaltype type;
   pool_ptr rest;
-  uint32_t _pad;
-  int32_t val;
+  fix32_val val;
 } fix32_object;
 
+typedef struct
+{
+  alignas (8) int64_t n;
+} fix64_val;
 typedef struct
 {
   alignas (16) evaltype type;
   pool_ptr rest;
-  int64_t val;
+  fix64_val val;
 } fix64_object;
 
+typedef struct
+{
+  alignas (8) uint32_t _pad;
+  pool_ptr head;
+} list_val;
 typedef struct
 {
   alignas (16) evaltype type;
   pool_ptr rest;
-  uint32_t _pad;
-  pool_ptr head;
+  list_val val;
 } list_object;
 
+typedef struct
+{
+  alignas (8) uint32_t len;
+  heap_ptr body;
+} vector_val;
 typedef struct
 {
   alignas (16) evaltype type;
   pool_ptr rest;
-  uint32_t len;
-  heap_ptr body;
+  vector_val val;
 } vector_object;
 
+typedef struct
+{
+  alignas (8) uint32_t len;
+  heap_ptr body;
+} uvector_val;
+typedef struct
+{
+  alignas (16) evaltype type;
+  pool_ptr rest;
+  uvector_val val;
+} uvector_object;
+
+typedef struct
+{
+  alignas (8) void (*fn) ();
+} subr_val;
 typedef struct
 {
   alignas (16) evaltype type;
   pool_ptr rest;
-  void (*fn) ();
+  subr_val val;
 } subr_object;
 
+typedef struct
+{
+  alignas (8) uint32_t _pad;
+  heap_ptr body;
+} atom_val;
+typedef struct
+{
+  alignas (16) evaltype type;
+  pool_ptr rest;
+  atom_val val;
+} atom_object;
+
 typedef struct
 {
   alignas (16)
@@ -155,6 +213,14 @@ typedef struct
   // uniq_id uid ??
 } tuple_object;
 
+typedef struct
+{
+  alignas (16) evaltype type;
+  uint32_t grow;
+  uint32_t len;
+  uint32_t gc;
+} dope_object;
+
 /// Object of a type that can be stored in the pool.
 /// NB. a pool_object* can point outside the pool; contrast with pool_ptr.
 typedef union pool_object
@@ -162,6 +228,7 @@ typedef union pool_object
   /// any pool object has a type and a rest
   struct
   {
+    // NB. never take the address of these type-punned fields!
     alignas (16) evaltype type;
     pool_ptr rest;
     opaque64 val;
@@ -171,13 +238,28 @@ typedef union pool_object
   fix64_object fix64;
   list_object list;
   vector_object vector;
+  uvector_object uvector;
+  atom_object atom;
 } pool_object;
 
+/// Value half of a poolable object, for storage in a uvector.
+typedef union
+{
+  fix32_val fix32;
+  fix64_val fix64;
+  list_val list;
+  vector_val vector;
+  uvector_val uvector;
+  subr_val subr;
+  atom_val atom;
+} uv_val;
+
 union object
 {
   /// any object has a type
   struct
   {
+    // NB. never take the address of these type-punned fields!
     alignas (16) evaltype type;
     opaque32 _unknown0;
     opaque64 _unknown1;
@@ -189,6 +271,8 @@ union object
   fix64_object fix64;
   list_object list;
   vector_object vector;
+  uvector_object uvector;
+  atom_object atom;
   tuple_object tuple;
 };
 
@@ -201,7 +285,10 @@ new_fix32 (int32_t n)
 {
   return (fix32_object)
   {
-  .type = EVALTYPE_FIX32,.rest = 0,.val = n};
+    .type = EVALTYPE_FIX32,.rest = 0,.val = (fix32_val)
+    {
+    .n = n}
+  };
 }
 
 static inline fix64_object
@@ -209,7 +296,10 @@ new_fix64 (int64_t n)
 {
   return (fix64_object)
   {
-  .type = EVALTYPE_FIX64,.rest = 0,.val = n};
+    .type = EVALTYPE_FIX64,.rest = 0,.val = (fix64_val)
+    {
+    .n = n}
+  };
 }
 
 static inline list_object
@@ -217,7 +307,10 @@ new_list (pool_ptr head)
 {
   return (list_object)
   {
-  .type = EVALTYPE_LIST,.rest = 0,.head = head,};
+    .type = EVALTYPE_LIST,.rest = 0,.val = (list_val)
+    {
+    .head = head}
+  ,};
 }
 
 static inline vector_object
@@ -225,7 +318,21 @@ new_vector (heap_ptr body, uint32_t length)
 {
   return (vector_object)
   {
-  .type = EVALTYPE_VECTOR,.rest = 0,.len = length,.body = body,};
+    .type = EVALTYPE_VECTOR,.rest = 0,.val = (vector_val)
+    {
+    .len = length,.body = body}
+  ,};
+}
+
+static inline uvector_object
+new_uvector (heap_ptr body, uint32_t length)
+{
+  return (uvector_object)
+  {
+    .type = EVALTYPE_VECTOR,.rest = 0,.val = (uvector_val)
+    {
+    .len = length,.body = body}
+  };
 }
 
 static inline tuple_object
@@ -233,7 +340,7 @@ new_tuple (object * body, uint32_t length)
 {
   return (tuple_object)
   {
-  .type = EVALTYPE_TUPLE,.len = length,.body = body,};
+  .type = EVALTYPE_TUPLE,.len = length,.body = body};
 }
 
 static inline subr_object
@@ -241,7 +348,21 @@ new_subr (void (*fn) ())
 {
   return (subr_object)
   {
-  .type = EVALTYPE_SUBR,.rest = 0,.fn = fn,};
+    .type = EVALTYPE_SUBR,.rest = 0,.val = (subr_val)
+    {
+    .fn = fn}
+  };
+}
+
+static inline atom_object
+new_atom (pool_ptr body)
+{
+  return (atom_object)
+  {
+    .type = EVALTYPE_ATOM,.rest = 0,.val = (atom_val)
+    {
+    .body = body}
+  };
 }
 
 /**
@@ -268,6 +389,13 @@ as_vector (object * o)
   return &o->vector;
 }
 
+static inline uvector_object *
+as_uvector (object * o)
+{
+  assert (TYPEPRIM_EQ (o->type, EVALTYPE_UVECTOR));
+  return &o->uvector;
+}
+
 static inline pool_object *
 as_pool (object * p)
 {

diff --git a/src/print.c b/src/print.c
index 8f089a3fbd3126615addcf43d9249b5a4065293d..3a5866ad0f29234031a7b28aec51d60434578582 100644 (file)
--- a/src/print.c
+++ b/src/print.c
@@ -27,12 +27,12 @@ License along with this file. If not, see
 static void
 print_vector_body (const vector_object * o)
 {
-  const object *p = HEAP_OBJECT (o->body);
+  const object *p = HEAP_OBJECT (o->val.body);
   if (!p)
     return;
-  if (o->len)
+  if (o->val.len)
     print_object (&p[0]);
-  for (uint32_t i = 1; i < o->len; i++)
+  for (uint32_t i = 1; i < o->val.len; i++)
     {
       printf (" ");
       print_object (&p[i]);
@@ -42,7 +42,7 @@ print_vector_body (const vector_object * o)
 static void
 print_list_body (const list_object * o)
 {
-  const pool_object *p = POOL_OBJECT (o->head);
+  const pool_object *p = POOL_OBJECT (o->val.head);
   if (!p)
     return;
   print_object ((const object *) p);
@@ -59,10 +59,10 @@ print_object (const object * o)
   switch (o->type)
     {
     case EVALTYPE_FIX32:
-      printf ("%d", o->fix32.val);
+      printf ("%d", o->fix32.val.n);
       break;
     case EVALTYPE_FIX64:
-      printf ("%ld", o->fix64.val);
+      printf ("%ld", o->fix64.val.n);
       break;
     case EVALTYPE_LIST:
       printf ("(");

diff --git a/src/read.c b/src/read.c
index dd12916ebb33a601af75008d8d11e804007ac175..b8570f3778f09fa13f134a1a2af088d00e1cce9e 100644 (file)
--- a/src/read.c
+++ b/src/read.c
@@ -114,7 +114,7 @@ static uint32_t obj_get_fix32(const object *o) {
 */
 
 static int
-read_num (const char *p, reader_stack *st)
+read_num (const char *p, reader_stack * st)
 {
   int i = 0;
   // Use an unsigned intermediate to simplify overflow checks.
@@ -151,7 +151,7 @@ read_num (const char *p, reader_stack *st)
   if (p[0] != '-')
     {
       if (x <= INT32_MAX)
-       (--(st->pos))->fix32 = new_fix32 ((int32_t)x);
+       (--(st->pos))->fix32 = new_fix32 ((int32_t) x);
       else if (x <= INT64_MAX)
        (--(st->pos))->fix64 = new_fix64 (x);
       else
@@ -159,24 +159,24 @@ read_num (const char *p, reader_stack *st)
     }
   else
     {
-      if (-x >= (uint64_t)INT32_MIN)
-       (--(st->pos))->fix32 = new_fix32 (0 - (int32_t)x);
-      else if (-x >= (uint64_t)INT64_MIN)
-       (--(st->pos))->fix64 = new_fix64 (0 - (int64_t)x);
+      if (-x >= (uint64_t) INT32_MIN)
+       (--(st->pos))->fix32 = new_fix32 (0 - (int32_t) x);
+      else if (-x >= (uint64_t) INT64_MIN)
+       (--(st->pos))->fix64 = new_fix64 (0 - (int64_t) x);
       else
        goto read_float;
     }
   st->framelen++;
   return i;
- read_float:
-  assert(0 && "unimplemented: promote num to float");
+read_float:
+  assert (0 && "unimplemented: promote num to float");
   return i;
 }
 
 // stack[0..len]: objs in current list
 // stack[len]: parent len
 const char *
-read_token (const char *p, reader_stack *st)
+read_token (const char *p, reader_stack * st)
 {
   p += count_whitespace (p);
   switch (p[0])
@@ -206,7 +206,10 @@ read_token (const char *p, reader_stack *st)
          }
        *--(st->pos) = (object)
        {
-       .fix32.type = type,.fix32.rest = 0,.fix32.val = st->framelen,};
+         .fix32.type = type,.fix32.rest = 0,.fix32.val = (fix32_val)
+         {
+         .n = st->framelen}
+       ,};
        st->framelen = 0;
        break;
       }
@@ -231,11 +234,10 @@ read_token (const char *p, reader_stack *st)
        // pop frame, push new LIST
        st->pos += st->framelen;
        assert (st->pos->type == type);
-       st->framelen = st->pos->fix32.val + 1;
+       st->framelen = st->pos->fix32.val.n + 1;
        // overwrite the frame marker with the collection it became
-       st->pos->list = (list_object)
-       {
-       .type = type,.rest = 0,.head = o};
+       st->pos->list = new_list (o);
+       st->pos->list.type = type;
        break;
       }
     case ']':
@@ -247,7 +249,7 @@ read_token (const char *p, reader_stack *st)
        uint32_t len = st->framelen;
        st->pos += st->framelen;
        assert (st->pos->type == EVALTYPE_VECTOR);
-       st->framelen = st->pos->fix32.val + 1;
+       st->framelen = st->pos->fix32.val.n + 1;
        st->pos->vector = new_vector (h, len);
        break;
       }
@@ -257,7 +259,13 @@ read_token (const char *p, reader_stack *st)
        if (n)
          return p + n;
 
-       // TODO: try read pname
+       n = count_pname (p);
+       if (n > 0)
+         {
+           (--(st->pos))->atom = new_atom (0);
+           st->framelen++;
+           return p + n;
+         }
 
        fprintf (stderr, "read unimplemented for char: '%c'\n", *p);
        assert (0 && "read unimplemented for char");