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
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
--- /dev/null
+/*
+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"
--- /dev/null
+/*
+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
// 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);
}
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;
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]);
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);
// 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);
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)
{
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
enum
{
+ EVALTYPE_LOSE = TYPEPRIM_LOSE,
+
EVALTYPE_FIX32 = TYPEPRIM_FIX32,
EVALTYPE_FIX64 = TYPEPRIM_FIX64,
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,
};
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)
// 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
/// 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;
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;
fix64_object fix64;
list_object list;
vector_object vector;
+ uvector_object uvector;
+ atom_object atom;
tuple_object tuple;
};
{
return (fix32_object)
{
- .type = EVALTYPE_FIX32,.rest = 0,.val = n};
+ .type = EVALTYPE_FIX32,.rest = 0,.val = (fix32_val)
+ {
+ .n = n}
+ };
}
static inline fix64_object
{
return (fix64_object)
{
- .type = EVALTYPE_FIX64,.rest = 0,.val = n};
+ .type = EVALTYPE_FIX64,.rest = 0,.val = (fix64_val)
+ {
+ .n = n}
+ };
}
static inline list_object
{
return (list_object)
{
- .type = EVALTYPE_LIST,.rest = 0,.head = head,};
+ .type = EVALTYPE_LIST,.rest = 0,.val = (list_val)
+ {
+ .head = head}
+ ,};
}
static inline vector_object
{
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
{
return (tuple_object)
{
- .type = EVALTYPE_TUPLE,.len = length,.body = body,};
+ .type = EVALTYPE_TUPLE,.len = length,.body = body};
}
static inline subr_object
{
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}
+ };
}
/**
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)
{
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]);
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);
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 ("(");
*/
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.
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
}
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])
}
*--(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;
}
// 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 ']':
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;
}
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");
projects / muddle-interpreter.git / commitdiff