summaryrefslogtreecommitdiff
path: root/pez.c
diff options
context:
space:
mode:
Diffstat (limited to 'pez.c')
-rw-r--r--pez.c3524
1 files changed, 3524 insertions, 0 deletions
diff --git a/pez.c b/pez.c
new file mode 100644
index 0000000..92e52b0
--- /dev/null
+++ b/pez.c
@@ -0,0 +1,3524 @@
+#include "pez.h"
+
+#include <assert.h>
+#include <errno.h>
+#include <limits.h>
+#include <stdarg.h>
+#include <stdbool.h>
+#include <stddef.h>
+#include <stdint.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
+#ifdef __GNUC__
+#define FORCEINLINE __attribute__((always_inline))
+#define NODISCARD __attribute__((nodiscard))
+#else
+#define FORCEINLINE
+#define NODISCARD
+#endif
+
+/*********/
+/* Types */
+/*********/
+
+typedef unsigned uint;
+typedef int32_t fixnum;
+
+typedef struct Val {
+ uint64_t r;
+} Val;
+
+#define vec_of(T) struct { \
+ T *at; \
+ uint len, cap; \
+}
+
+typedef struct Obj Obj;
+struct Obj {
+ Obj *prev, *next;
+ short t;
+};
+
+typedef struct Str {
+ Obj o;
+ uint n;
+ char dat[];
+} Str;
+
+typedef struct Tuple {
+ Obj o;
+ uint len;
+ Val dat[];
+} Tuple;
+
+typedef struct Array {
+ Obj o;
+ vec_of(Val);
+} Array;
+
+struct KV { Val k, v; };
+
+typedef struct Record {
+ Obj o;
+ uint count, N;
+ struct KV dat[];
+} Record;
+
+typedef struct Fn {
+ Obj o;
+ const char *file;
+ const uint8_t *code;
+ const Val *con;
+ int linebegin;
+ uint ncode, ncon;
+ short nvars, nparams;
+ bool variadic : 1;
+ bool named : 1;
+ char name[];
+} Fn;
+
+typedef struct Local Local;
+
+enum { NAMEMAX = 80 };
+
+typedef struct Comp {
+ PezContext *cx;
+ int (*readcb)(void *);
+ void *readud;
+ uint line, col;
+ int peekchr;
+ bool have_peekchr;
+ char stash_ident[NAMEMAX];
+ Local *stash_local;
+ char stash_binopk;
+ char stash_binopchr;
+ int stash_binopop;
+
+ Fn *fn;
+ vec_of(uint8_t) code;
+ vec_of(Val) con;
+
+ Val k; /* for constant folding */
+ bool has_k;
+
+ int lastop, lastop2; /* last and 2nd-to-last opcode idxs */
+
+ bool lvalue : 1,
+ lvalue_const : 1;
+ const char *lvalue_name;
+
+ vec_of(char) spool; // for var names
+ vec_of(Val) kpool; // for consts
+ struct fenv {
+ struct fenv *prev;
+ vec_of(Local) locals; // also params
+ uint16_t scope;
+ uint16_t nvars; // num of locals in scope not counting konsts
+ } fenv;
+} Comp;
+
+struct Local {
+ uint16_t scope;
+ uint16_t sref; // name
+ uint16_t kref; // when has_k
+ uint16_t index : 10;
+ uint16_t isparam : 1,
+ has_k : 1,
+ mutable : 1;
+};
+
+static struct Str strpool_deleted;
+typedef struct StrPool {
+ uint count, deleted, N;
+ struct Str **dat;
+} StrPool;
+
+typedef struct Globals {
+ uint count, N;
+ struct KV *dat;
+} Globals;
+
+enum dbgopts {
+ DBGbytecode = 1,
+};
+
+struct PezContext {
+ PezAllocFn *alloc;
+ void *ud;
+ int dbg;
+ PezError err;
+ char errstr[140];
+ Val *stack, *stktop, *stkend;
+ Obj *heap, tmpheap;
+ StrPool strpool;
+ Globals globals;
+};
+
+/******************/
+/* Value innards */
+/******************/
+
+enum {
+ TAGObj = 0, // xx00
+ TAGNum = 1, // 0001
+ TAGBool = 5, // 0101
+ TAGSStr = 9, // 1001 (length is in high nybble)
+ TAGCFn = 2, // xx10 (fn pointer is left shifted by 2)
+ TAGDeleted = 15, // 1111 // for KV
+};
+
+#define VOID ((Val){0})
+#define _EMPTY ((Val){TAGEmpty})
+#define _DELETED ((Val){TAGDeleted})
+#define isvoid(v) ((v).r == 0)
+#define _isdeleted(v) (((v).r & 0xFF) == TAGDeleted)
+#define isobj(v) (!isvoid(v) && ((v).r & 3) == TAGObj)
+#define isnum(v) (((v).r & 0xFF) == TAGNum)
+#define isbool(v) (((v).r & 0xFF) == TAGBool)
+#define issstr(v) (((v).r & 0x0F) == TAGSStr)
+#define sstr_len(v) (((v).r & 0xFF) >> 4)
+#define iscfn(v) (((v).r & 3) == TAGCFn)
+#define unbox_num(v) ((fixnum)((v).r >> 32))
+#define unbox_obj(v) ((Obj *)(intptr_t)(v).r)
+#define unbox_bool(v) ((bool)((v).r >> 32))
+#define unbox_cfn(v) ((PezCFn *)((intptr_t)(v).r >> 2))
+#define objtag(v) (unbox_obj(v)->t)
+#define isobj_of(v, tag) (isobj(v) && objtag(v) == (tag))
+#define box_obj(x) ((Val){(intptr_t)(x)})
+#define box_num(x) ((Val){(uint64_t)(x) << 32 | TAGNum})
+#define box_bool(x) ((Val){((uint64_t)(bool)(x) << 32) | TAGBool})
+#define box_cfn(x) ((Val){(uint64_t)(intptr_t)(x) << 2 | TAGCFn})
+#define truthy(x) (!isvoid(x) && ((x).r == TAGBool ? unbox_bool(x) : 1))
+
+static Val length_sstr;
+
+static const char *
+typestr(Val v)
+{
+ if (isvoid(v))
+ return "void";
+ if (isobj(v)) {
+ switch (objtag(v)) {
+ case PEZ_TString: return "string";
+ case PEZ_TTuple: return "tuple";
+ case PEZ_TRecord: return "record";
+ case PEZ_TArray: return "array";
+ case PEZ_TFn: return "function";
+ }
+ }
+ if (isnum(v))
+ return "number";
+ if (isbool(v))
+ return "bool";
+ if (issstr(v))
+ return "string";
+ if (iscfn(v))
+ return "function";
+ return NULL;
+}
+
+static int
+unbox_sstr(Val v, char buf[8])
+{
+ int n = sstr_len(v);
+ assert(issstr(v));
+ assert(n >= 0 && n < 8);
+ buf[n] = 0;
+ for (int i = 0; i < n; ++i) {
+ uint8_t c = (v.r >> (56 - (i * 8))) & 0xFF;
+ buf[i] = c;
+ }
+ return n;
+}
+
+/***********/
+/* Utility */
+/***********/
+
+#define MAX(a, b) ((a) > (b) ? (a) : (b))
+#define TRY(x) do { if (!(x)) return 0; } while (0)
+#define ETRY(x) do { if (!(x)) goto Err; } while (0)
+
+static void *
+cxalloc(PezContext *cx, size_t sz)
+{
+ return cx->alloc(cx->ud, NULL, 0, sz);
+}
+
+static void
+cxfree(PezContext *cx, void *p, size_t sz)
+{
+ cx->alloc(cx->ud, p, sz, 0);
+}
+
+#define delvec(cx, v) \
+ ((v)->at ? cxfree(cx, (v)->at, (v)->cap * sizeof *(v)->at) : (void)0, \
+ memset((v), 0, sizeof *(v)))
+
+#define vecempty(v) ((v)->len == 0)
+
+#define vecpush(cx, v, src, n) \
+ _vecpush(cx, (void **)&(v)->at, sizeof *(v)->at, \
+ &(v)->len, &(v)->cap, (src), (n))
+
+#define veclast(v) (&(v)->at[(v)->len - 1])
+#define vecpop(cx, v) \
+ _vecpop(cx,(void **)&(v)->at, sizeof *(v)->at, &(v)->len, &(v)->cap)
+
+static bool
+_vecpush(PezContext *cx, void **at, size_t sz,
+ uint *len, uint *cap, const void *src, size_t n)
+{
+ if (*len + n >= *cap) {
+ uint newcap = (*len + n) * 2;
+ uint8_t *new;
+ newcap = newcap < 4 ? 4 : newcap;
+ new = cx->alloc(cx->ud, *at, *cap * sz, newcap * sz);
+ if (!new) {
+ if (*at) {
+ cxfree(cx, *at, *cap * sz);
+ }
+ *at = NULL;
+ *len = *cap = 0;
+ return 0;
+ }
+ *at = new;
+ *cap = newcap;
+ }
+ memcpy((char *)*at + *len * sz, src, n * sz);
+ *len += n;
+ return 1;
+}
+
+/*
+static void
+_vecpop(PezContext *cx, void **at, size_t sz,
+ uint *len, uint *cap)
+{
+ uint newcap;
+ assert(*len > 0);
+ --*len;
+ if (*len < *cap / 4) {
+ uint newcap = *cap / 2;
+ uint8_t *new;
+ new = cx->alloc(cx->ud, *at, *cap * sz, newcap * sz);
+ if (new) {
+ *at = new;
+ *cap = newcap;
+ }
+ }
+}
+*/
+
+static Obj *
+newobj(PezContext *cx, int type, size_t sz)
+{
+ Obj *o = cxalloc(cx, sz);
+ assert(sz >= sizeof *o);
+ if (!o) {
+ return NULL;
+ }
+ memset(o, 0, sz);
+ o->next = cx->heap;
+ if (cx->heap) {
+ cx->heap->prev = o;
+ }
+ cx->heap = o;
+ o->t = type;
+ return o;
+}
+
+static void delfn(PezContext *, Fn *);
+static void delarray(PezContext *, Array *);
+static void
+freeobj(PezContext *cx, Obj *o)
+{
+ switch (o->t) {
+ case PEZ_TFn:
+ delfn(cx, (Fn *)o);
+ break;
+ case PEZ_TArray:
+ delarray(cx, (Array *)o);
+ break;
+ }
+ cxfree(cx, o, sizeof *o);
+}
+
+static inline bool FORCEINLINE
+push(PezContext *cx, Val v)
+{
+ if (cx->stktop == cx->stkend) {
+ cx->err = PEZ_EStack;
+ return 0;
+ }
+ *cx->stktop++ = v;
+ return 1;
+}
+
+static inline Val FORCEINLINE
+pop(PezContext *cx)
+{
+ assert(cx->stktop > cx->stack);
+ return *--cx->stktop;
+}
+
+static inline Val * FORCEINLINE
+peek(PezContext *cx)
+{
+ assert(cx->stktop > cx->stack);
+ return &cx->stktop[-1];
+}
+
+#define FNV1A_INI 0x811c9dc5u
+static inline
+uint32_t fnv1a(uint32_t h, const void *src, size_t n)
+{
+ for (const uint8_t *d = src; n--; ++d) {
+ h ^= *d;
+ h *= 0x01000193;
+ }
+ return h;
+}
+
+static inline uint64_t
+splittable64(uint64_t x)
+{
+ x ^= x >> 30;
+ x *= 0xbf58476d1ce4e5b9U;
+ x ^= x >> 27;
+ x *= 0x94d049bb133111ebU;
+ x ^= x >> 31;
+ return x;
+}
+
+/***********/
+/* Objects */
+/***********/
+
+static Fn *
+newfn(PezContext *cx, const char *file, const char *name, int line)
+{
+ Fn *fn = (Fn *)newobj(cx, PEZ_TFn, sizeof *fn + (name ? strlen(name) + 1 : 0));
+ if (fn) {
+ Obj hdr = fn->o;
+ memset(fn, 0, sizeof *fn);
+ fn->o = hdr;
+ fn->file = file;
+ fn->linebegin = line;
+ if (name) {
+ fn->named = 1;
+ strcpy(fn->name, name);
+ }
+ }
+ return fn;
+}
+
+static void
+delfn(PezContext *cx, Fn *fn)
+{
+ cxfree(cx, (void *)fn->code, fn->ncode);
+ cxfree(cx, (void *)fn->con, fn->ncon * sizeof(Val));
+}
+
+static Val *
+globals_lookup(PezContext *cx, Val key, bool put)
+{
+ uint32_t h, idx;
+ Globals *pool = &cx->globals;
+
+ if (!pool->dat) {
+ pool->dat = cxalloc(cx, sizeof(struct KV) * (pool->N = 8));
+ if (!pool->dat) {
+ return NULL;
+ }
+ memset(pool->dat, 0, sizeof(struct KV) * pool->N);
+ }
+
+ if (put && pool->count == pool->N / 2) {
+ //resize
+ struct KV *new = cxalloc(cx, sizeof(struct KV) * (pool->N *= 2));
+ if (!new) {
+ return NULL;
+ }
+ memset(new, 0, sizeof(struct KV) * pool->N);
+ for (int i = 0; i < pool->N / 2; ++i) {
+ struct KV kv = pool->dat[i];
+ if (isvoid(kv.k)) {
+ continue;
+ }
+ h = splittable64(kv.k.r);
+ for (idx = h & (pool->N - 1);; idx = (idx + 1) & (pool->N - 1)) {
+ if (isvoid(new[idx].k)) {
+ new[idx] = kv;
+ break;
+ }
+ }
+ }
+ cxfree(cx, pool->dat, sizeof(struct KV) * (pool->N / 2));
+ pool->dat = new;
+ }
+
+ h = splittable64(key.r);
+ for (idx = h & (pool->N - 1);; idx = (idx + 1) & (pool->N - 1)) {
+ struct KV *kv = &pool->dat[idx];
+ if (kv->k.r == key.r) {
+ return &kv->v;
+ } else if (isvoid(kv->k)) {
+ if (put) {
+ kv->k = key;
+ ++pool->count;
+ return &kv->v;
+ }
+ return NULL;
+ }
+ }
+}
+
+static Val *
+getglobal(PezContext *cx, Val key)
+{
+ return globals_lookup(cx, key, 0);
+}
+
+static bool
+putglobal(PezContext *cx, Val key, Val val)
+{
+ Val *dst = globals_lookup(cx, key, 1);
+ if (!dst) {
+ return 0;
+ }
+ *dst = val;
+ return 1;
+}
+
+static Str **
+strpool_lookup(PezContext *cx, const char *str, int len)
+{
+ StrPool *pool = &cx->strpool;
+ uint32_t h, idx;
+
+ if (!pool->dat) {
+ pool->dat = cxalloc(cx, sizeof(Str *) * (pool->N = 8));
+ if (!pool->dat) {
+ return NULL;
+ }
+ memset(pool->dat, 0, sizeof(Str *) * pool->N);
+ }
+ if (pool->count + pool->deleted == pool->N / 2) {
+ // resize
+ Str **new = cxalloc(cx, sizeof(Str *) * (pool->N *= 2));
+ if (!new) {
+ return NULL;
+ }
+ memset(new, 0, sizeof(Str *) * pool->N);
+ for (int i = 0; i < pool->N / 2; ++i) {
+ Str *s0 = pool->dat[i];
+ if (!s0 || s0 == &strpool_deleted) {
+ continue;
+ }
+ h = fnv1a(FNV1A_INI, s0->dat, s0->n);
+ for (idx = h & (pool->N - 1);; idx = (idx + 1) & (pool->N - 1)) {
+ if (!new[idx]) {
+ new[idx] = s0;
+ break;
+ }
+ }
+ }
+ cxfree(cx, pool->dat, sizeof(Str *) * (pool->N / 2));
+ pool->dat = new;
+ pool->deleted = 0;
+ }
+ h = fnv1a(FNV1A_INI, str, len);
+ for (idx = h & (pool->N - 1);; idx = (idx + 1) & (pool->N - 1)) {
+ Str *s = pool->dat[idx];
+ if (!s || (s != &strpool_deleted && s->n == len && !memcmp(s->dat, str, len))) {
+ return &pool->dat[idx];
+ }
+ }
+}
+
+static bool
+box_str(PezContext *cx, Val *pv, const char *s, int len)
+{
+ Str **slot;
+ if (len < 8) {
+ uint64_t r = TAGSStr + (len << 4);
+ for (int i = 0; i < len; ++i) {
+ r |= (uint64_t)(uint8_t)s[i] << (56 - (i * 8));
+ }
+ pv->r = r;
+ return 1;
+ }
+ TRY(slot = strpool_lookup(cx, s, len));
+ if (!*slot) {
+ Str *o = (Str *)newobj(cx, PEZ_TString, sizeof(Str) + len + 1);
+ if (!o) {
+ return 0;
+ }
+ o->n = len;
+ memcpy(o->dat, s, len + 1);
+ *slot = o;
+ ++cx->strpool.count;
+ }
+ *pv = box_obj(*slot);
+ return 1;
+}
+
+static Array *
+newarr(PezContext *cx, uint cap)
+{
+ Array *arr = (Array *)newobj(cx, PEZ_TArray, sizeof *arr);
+ if (!arr) {
+ return NULL;
+ }
+ arr->len = 0;
+ arr->cap = cap;
+ arr->at = NULL;
+ if (cap) {
+ arr->at = cxalloc(cx, cap * sizeof(Val));
+ }
+ return arr;
+}
+
+static void
+delarray(PezContext *cx, Array *arr)
+{
+ delvec(cx, arr);
+}
+
+static bool
+arrpushn(PezContext *cx, Array *arr, Val *src, uint n)
+{
+ return n == 0 ? 1 : vecpush(cx, arr, src, n);
+}
+
+/********************/
+/* Fixed point math */
+/********************/
+
+#define FX(n) ((fixnum)(n * 4096))
+
+static inline fixnum
+ftofix(double f)
+{
+ return FX(f);
+}
+
+static inline double
+fixtof(fixnum f)
+{
+ return f / 4096.0;
+}
+
+static inline int32_t
+fixtoint(fixnum f)
+{
+ return f >> 12;
+}
+
+static inline fixnum
+inttofix(int32_t n)
+{
+ return (uint32_t)n << 12;
+}
+
+static inline fixnum
+fixtrunc(fixnum f)
+{
+ return f & ~(uint32_t)0xFFF;
+}
+
+/******/
+/* VM */
+/******/
+
+#define OPCODES(_) \
+ /* name,stack effect */ \
+ _(nop, 0) \
+ /* stack manip */ \
+ _(pop, -1) \
+ _(dup, 1) \
+ _(dupn, 000) \
+ _(dupbck, 1) \
+ /* constants */ \
+ _(void, 1) \
+ _(zero, 1) \
+ _(one, 1) \
+ _(byte, 1) \
+ _(short, 1) \
+ _(number, 1) \
+ _(true, 1) \
+ _(false, 1) \
+ _(sstr0, 1) \
+ _(sstr1, 1) \
+ _(sstr2, 1) \
+ _(sstr3, 1) \
+ _(sstr4, 1) \
+ _(sstr5, 1) \
+ _(sstr6, 1) \
+ _(sstr7, 1) \
+ _(string, 1) \
+ _(lambda, 1) \
+ /* unary ops */ \
+ _(neg, 0) \
+ _(not, 0) \
+ /* binary ops */ \
+ _(add, -1) \
+ _(sub, -1) \
+ _(mul, -1) \
+ _(div, -1) \
+ _(mod, -1) \
+ _(band, -1) \
+ _(bior, -1) \
+ _(bxor, -1) \
+ _(shl, -1) \
+ _(shra, -1) \
+ _(shrl, -1) \
+ _(eq, -1) \
+ _(ne, -1) \
+ _(lt, -1) \
+ _(le, -1) \
+ _(gt, -1) \
+ _(ge, -1) \
+ /* ops with immediates */ \
+ _(iadd, 0) \
+ _(imul, 0) \
+ _(idiv, 0) \
+ _(imod, 0) \
+ _(iband, 0) \
+ _(ibior, 0) \
+ _(ibxor, 0) \
+ _(ishl, 0) \
+ _(ishra, 0) \
+ _(ishrl, 0) \
+ _(ieq, 0) \
+ _(ine, 0) \
+ _(ilt, 0) \
+ _(ile, 0) \
+ _(igt, 0) \
+ _(ige, 0) \
+ /* variables */ \
+ _(arg, 1) \
+ _(setarg, 0) \
+ _(local, 1) \
+ _(setloc,-1) \
+ _(global, 0) \
+ _(setglo,-2) \
+ _(putglo,-2) \
+ /* applications */ \
+ _(apply, 000) \
+ _(setapp, 000) \
+ _(length, 0) \
+ /* constructors */ \
+ _(newarr, 000) \
+ _(arradd, 000) \
+ /* control flow */ \
+ _(ret, 0) \
+ _(b, 0) \
+ _(bt, -1) \
+ _(bf, -1) \
+
+enum op {
+#define X(o,_) O##o,
+ OPCODES(X)
+#undef X
+ OPCODE_COUNT,
+};
+
+static const char *opnames[] = {
+#define X(o,_) #o,
+ OPCODES(X)
+#undef X
+};
+
+static const int8_t opeffects[] = {
+#define X(_,effect) effect,
+ OPCODES(X)
+#undef X
+};
+
+static void
+vrunerr(PezContext *cx, void *fn_, int ip, const char *fmt, va_list ap)
+{
+ char buf[80] = {0};
+ cx->err = PEZ_ERuntime;
+ vsnprintf(buf, sizeof buf, fmt, ap);
+ if (ip >= 0) {
+ // from bytecode execution
+ Fn *fn = fn_;
+ assert(fn);
+ snprintf(cx->errstr, sizeof cx->errstr, "%s:%s:%d: %s",
+ fn->file ? fn->file : "?", fn->named ? fn->name : "?",
+ fn->linebegin,
+ buf);
+ } else {
+ // from C code
+ char *fn = fn_;
+ snprintf(cx->errstr, sizeof cx->errstr, "[C]:%s: %s",
+ fn ? fn : "?", buf);
+ }
+ cx->errstr[sizeof cx->errstr - 1] = 0;
+}
+
+static void
+runerr(PezContext *cx, Fn *fn, int ip, const char *fmt, ...)
+{
+ va_list ap;
+ va_start(ap, fmt);
+ vrunerr(cx, fn, ip, fmt, ap);
+ va_end(ap);
+}
+
+static void
+inspectstr(const char *s, size_t len)
+{
+ fputc('"', stderr);
+ for (size_t i = 0; i < len; ++i) {
+ unsigned char c = s[i];
+ extern int isprint(int);
+ switch (c) {
+ case '\n': fprintf(stderr, "\\n"); break;
+ case '\t': fprintf(stderr, "\\t"); break;
+ case '\\': fprintf(stderr, "\\\\"); break;
+ case '\"': fprintf(stderr, "\\\""); break;
+ default: if (isprint(c)) {
+ fputc(c, stderr);
+ } else {
+ fprintf(stderr, "\\x%.2X", c);
+ }
+ }
+ }
+ fputc('"', stderr);
+}
+
+static void
+inspectfn(Fn *fn)
+{
+ int n;
+ for (int i = 0; i < fn->ncon; ++i) {
+ Val k = fn->con[i];
+ if (isobj_of(k, PEZ_TFn)) {
+ inspectfn((Fn *)unbox_obj(k));
+ }
+ }
+ n = fprintf(stderr, "fn %s [%d%s]:\n", fn->name,
+ fn->nparams, fn->variadic ? ",*" : "");
+ for (uint ip = 0; ip < fn->ncode;) {
+ uint8_t o = fn->code[ip++];
+ const uint8_t *argp = &fn->code[ip];
+ int16_t i16;
+ uint dst;
+ fixnum num;
+ Val v;
+ Fn *ofn;
+
+ fprintf(stderr, "%.4X:\t%s \t", ip-1, opnames[o]);
+ switch (o) {
+ case Odupn:
+ ++ip;
+ fprintf(stderr, "%d", 1 + *argp);
+ break;
+ case Obyte: case Oiadd: case Oimul: case Oidiv:
+ case Oimod: case Oiband: case Oibior: case Oibxor:
+ case Oishl: case Oishrl: case Oishra: case Oilt:
+ case Oile: case Oigt: case Oige: case Oeq: case One:
+ ++ip;
+ fprintf(stderr, "%d", (int8_t)*argp);
+ break;
+ case Oshort:
+ memcpy(&i16, argp, 2);
+ ip += 2;
+ fprintf(stderr, "%d", i16);
+ break;
+ case Onumber:
+ memcpy(&num, argp, 4);
+ ip += 4;
+ fprintf(stderr, "%f", fixtof(num));
+ break;
+ case Olocal: case Osetloc: case Oarg: case Osetarg:
+ ++ip;
+ fprintf(stderr, "#%d", *argp);
+ break;
+ case Ostring:
+ ++ip;
+ assert(*argp < fn->ncon);
+ v = fn->con[*argp];
+ assert(isobj_of(v, PEZ_TString));
+ inspectstr(((Str *)unbox_obj(v))->dat, ((Str *)unbox_obj(v))->n);
+ break;
+ case Olambda:
+ ++ip;
+ assert(*argp < fn->ncon);
+ v = fn->con[*argp];
+ assert(isobj_of(v, PEZ_TFn));
+ ofn = (Fn *)unbox_obj(v);
+ if (ofn->named) {
+ fprintf(stderr, "<fn'%s %p>", ofn->name, ofn);
+ } else {
+ fprintf(stderr, "<fn %p>", ofn);
+ }
+ break;
+ case Oapply: case Osetapp: case Onewarr: case Oarradd:
+ ++ip;
+ fprintf(stderr, "%d", *argp);
+ break;
+ case Ob: case Obt: case Obf:
+ memcpy(&i16, argp, 2);
+ ip += 2;
+ dst = ip + i16;
+ assert(dst < fn->ncode);
+ fprintf(stderr, "%.4X", dst);
+ break;
+ }
+ if (o >= Osstr0 && o <= Osstr7) {
+ int n = o - Osstr0;
+ char buf[8] = {0};
+ memcpy(buf, argp, n);
+ inspectstr(buf, n);
+ ip += n;
+ }
+ fprintf(stderr, "\n");
+ }
+ while (n-->1) fputc('-', stderr);
+ fprintf(stderr, "\n");
+}
+
+#define UDO_Oadd(a,b) ( box_num((uint32_t)unbox_num(a) + unbox_num(b)) )
+#define UDO_Osub(a,b) ( box_num((uint32_t)unbox_num(a) - unbox_num(b)) )
+#define UDO_Omul(a,b) ( box_num(pez_fixmul(unbox_num(a), unbox_num(b))) )
+#define UDO_Odiv(a,b) ( box_num(pez_fixdiv(unbox_num(a), unbox_num(b))) )
+#define UDO_Omod(a,b) ( box_num(pez_fixmod(unbox_num(a), unbox_num(b))) )
+#define UDO_Oband(a,b) ( box_num(unbox_num(a) & unbox_num(b)) )
+#define UDO_Obior(a,b) ( box_num(unbox_num(a) | unbox_num(b)) )
+#define UDO_Obxor(a,b) ( box_num(unbox_num(a) ^ unbox_num(b)) )
+#define UDO_Oshl(a,b) ( box_num((uint32_t)unbox_num(a) << (unbox_num(b) >> 12 & 0x1F)) )
+#define UDO_Oshra(a,b) ( box_num(unbox_num(a) >> (unbox_num(b) >> 12 & 0x1F)) )
+#define UDO_Oshrl(a,b) ( box_num((uint32_t)unbox_num(a) >> (unbox_num(b) >> 12 & 0x1F)) )
+#define UDO_Oeq(a,b) ( box_bool((a).r == (b).r) )
+#define UDO_One(a,b) ( box_bool((a).r != (b).r) )
+#define UDO_Olt(a,b) ( box_bool(unbox_num(a) < unbox_num(b)) )
+#define UDO_Ole(a,b) ( box_bool(unbox_num(a) <= unbox_num(b)) )
+#define UDO_Ogt(a,b) ( box_bool(unbox_num(a) > unbox_num(b)) )
+#define UDO_Oge(a,b) ( box_bool(unbox_num(a) >= unbox_num(b)) )
+
+static Val
+uncheckedop(int op, Val a, Val b)
+{
+ switch (op) {
+ case Oadd: return UDO_Oadd(a,b);
+ case Osub: return UDO_Osub(a,b);
+ case Omul: return UDO_Omul(a,b);
+ case Odiv: return UDO_Odiv(a,b);
+ case Omod: return UDO_Omod(a,b);
+ case Oband: return UDO_Oband(a,b);
+ case Obior: return UDO_Obior(a,b);
+ case Obxor: return UDO_Obxor(a,b);
+ case Oshl: return UDO_Oshl(a,b);
+ case Oshra: return UDO_Oshra(a,b);
+ case Oshrl: return UDO_Oshrl(a,b);
+ case Oeq: return UDO_Oeq(a,b);
+ case One: return UDO_One(a,b);
+ case Olt: return UDO_Olt(a,b);
+ case Ole: return UDO_Ole(a,b);
+ case Ogt: return UDO_Ogt(a,b);
+ case Oge: return UDO_Oge(a,b);
+ }
+ assert(0 && "bad op");
+}
+
+static bool exefn(PezContext *cx, Fn *fn, uint nargs);
+
+static inline bool
+checkindex(PezContext *cx, int *idx, Fn *srcfn, int srcpc, const char *what, int len, Val arg)
+{
+ fixnum num;
+ if (!isnum(arg)) {
+ runerr(cx, srcfn, srcpc, "attempt to index %s with %s value",
+ what, typestr(arg));
+ return 0;
+ }
+ num = unbox_num(arg);
+ if (fixtrunc(num) != num) {
+ runerr(cx, srcfn, srcpc, "non-integer %s index", what);
+ return 0;
+ }
+ *idx = fixtoint(num);
+ *idx = *idx < 0 ? len + *idx : *idx;
+ if (*idx >= len) {
+ runerr(cx, srcfn, srcpc, "%s index out of range", what);
+ return 0;
+ }
+ return 1;
+}
+
+static inline bool
+apply(PezContext *cx, Val *ret, void *srcfn, int srcpc, Val recv, uint n)
+{
+ int idx;
+ Val *args = cx->stktop - n, arg;
+ if (isobj_of(recv, PEZ_TFn)) {
+ Fn *f = (Fn *)unbox_obj(recv);
+ if (f->variadic ? n < f->nparams : n != f->nparams) {
+ runerr(cx, srcfn, srcpc, "function takes %d arg(s), %d %s given",
+ f->nparams, n, n == 1 ? "was" : "were");
+ return 0;
+ }
+ TRY(exefn(cx, f, n));
+ *ret = pop(cx);
+ } else if (iscfn(recv)) {
+ Val *stktop = cx->stktop;
+ PezCFn *f = unbox_cfn(recv);
+ assert(f);
+ TRY(f(cx, n));
+ assert(cx->stktop > cx->stack);
+ *ret = *peek(cx);
+ cx->stktop = stktop;
+ } else if (isobj_of(recv, PEZ_TArray)) {
+ Array *arr = (Array *)unbox_obj(recv);
+ if (n != 1) {
+ runerr(cx, srcfn, srcpc, "array indexing takes one argument (got %d)", n);
+ return 0;
+ }
+ arg = args[0];
+ if (arg.r == length_sstr.r) {
+ *ret = box_num(inttofix(arr->len));
+ return 1;
+ }
+ TRY(checkindex(cx, &idx, srcfn, srcpc, "array", arr->len, arg));
+ *ret = arr->at[idx];
+ } else if (issstr(recv) || isobj_of(recv, PEZ_TString)) {
+ char buf[8];
+ const char *str;
+ int len;
+ if (issstr(recv)) {
+ len = unbox_sstr(recv, buf);
+ str = buf;
+ } else {
+ len = ((Str *)unbox_obj(recv))->n;
+ str = ((Str *)unbox_obj(recv))->dat;
+ }
+ if (n != 1) {
+ runerr(cx, srcfn, srcpc, "string indexing takes one argument (got %d)", n);
+ return 0;
+ }
+ arg = args[0];
+ if (arg.r == length_sstr.r) {
+ *ret = box_num(inttofix(len));
+ return 1;
+ }
+ TRY(checkindex(cx, &idx, srcfn, srcpc, "string", len, arg));
+ *ret = (Val){(uint64_t)str[idx] << 56 | TAGSStr | 1 << 4};
+ } else {
+ runerr(cx, srcfn, srcpc, "%s value is not applicable", typestr(recv));
+ return 0;
+ }
+ return 1;
+}
+
+static inline bool
+setapply(PezContext *cx, Val *ret, void *srcfn, int srcpc, Val recv, uint n, Val rval)
+{
+ int idx;
+ Val *args = cx->stktop - n, arg;
+ if (isobj_of(recv, PEZ_TFn) || iscfn(recv)) {
+ runerr(cx, srcfn, srcpc, "procedure has no setter");
+ return 0;
+ } else if (isobj_of(recv, PEZ_TArray)) {
+ Array *arr = (Array *)unbox_obj(recv);
+ if (n != 1) {
+ runerr(cx, srcfn, srcpc, "array indexing takes one argument");
+ return 0;
+ }
+ arg = args[0];
+ if (arg.r == length_sstr.r) {
+ runerr(cx, srcfn, srcpc, "cannot mutate array length");
+ return 0;
+ }
+ TRY(checkindex(cx, &idx, srcfn, srcpc, "array", arr->len, arg));
+ *ret = arr->at[idx] = rval;
+ } else if (issstr(recv) || isobj_of(recv, PEZ_TString)) {
+ runerr(cx, srcfn, srcpc, "cannot mutate string");
+ return 0;
+ } else {
+ runerr(cx, srcfn, srcpc, "%s value is not applicable", typestr(recv));
+ return 0;
+ }
+ return 1;
+}
+
+static bool
+exefn(PezContext *cx, Fn *fn, uint nargs)
+{
+ const uint8_t *code = fn->code;
+ Val *args = cx->stktop - nargs,
+ *locals = cx->stktop;
+ uint ip = 0;
+ for (int i = 0; i < fn->nvars; ++i) {
+ TRY(push(cx, VOID));
+ }
+#ifdef __GNUC__
+// use computed goto
+#define X(o,_) &&DoO##o,
+ static const void *jumptable[] = { OPCODES(X) &&Bad };
+#undef X
+#define VMBEGIN {
+#define VMEND }
+#define CASE(o) goto *jumptable[code[ip++]]; Do##o:
+#define BADOP goto *jumptable[code[ip++]]; Bad:
+#else
+#define VMBEGIN Next: switch (code[ip++]) {
+#define VMEND } goto Next;
+#define CASE(o) break; case o:
+#define BADOP break; default:
+#endif
+
+ VMBEGIN
+ CASE(Onop) {}
+ CASE(Oret) {
+ Val ret = pop(cx);
+ cx->stktop -= fn->nvars;
+ assert(cx->stktop >= cx->stack);
+ push(cx, ret);
+ return 1;
+ }
+ CASE(Opop) {
+ pop(cx);
+ }
+ CASE(Odup) {
+ TRY(push(cx, *peek(cx)));
+ }
+ CASE(Odupn) {
+ int n = code[ip++] + 1;
+ Val *it = cx->stktop - n;
+ assert(cx->stktop > cx->stack + n);
+ for (int i = 0; i < n; ++i ) {
+ TRY(push(cx, it[i]));
+ }
+ }
+ CASE(Odupbck) {
+ Val v;
+ assert(cx->stktop > cx->stack + 1);
+ v = *peek(cx);
+ TRY(push(cx, VOID));
+ cx->stktop[-1] = cx->stktop[-2];
+ cx->stktop[-2] = cx->stktop[-3];
+ cx->stktop[-3] = v;
+ }
+ CASE(Ovoid) {
+ TRY(push(cx, VOID));
+ }
+ CASE(Ozero) {
+ TRY(push(cx, box_num(FX(0))));
+ }
+ CASE(Oone) {
+ TRY(push(cx, box_num(FX(1))));
+ }
+ CASE(Obyte) {
+ TRY(push(cx, box_num(inttofix((int8_t)code[ip++]))));
+ }
+ CASE(Oshort) {
+ int16_t i16;
+ memcpy(&i16, &code[ip], 2), ip += 2;
+ TRY(push(cx, box_num(inttofix(i16))));
+ }
+ CASE(Onumber) {
+ fixnum num;
+ memcpy(&num, &code[ip], 4), ip += 4;
+ TRY(push(cx, box_num(num)));
+ }
+ CASE(Ofalse) {
+ TRY(push(cx, box_bool(0)));
+ }
+ CASE(Otrue) {
+ TRY(push(cx, box_bool(1)));
+ }
+ #define SSTR(n) \
+ CASE(Osstr##n) { \
+ char buf[8]; \
+ Val v; \
+ bool ok; \
+ memcpy(buf, code + ip, n); \
+ ip += n; \
+ ok = box_str(cx, &v, buf, n); \
+ assert(ok); \
+ TRY(push(cx, v)); \
+ }
+ SSTR(0) SSTR(1) SSTR(2) SSTR(3)
+ SSTR(4) SSTR(5) SSTR(6) SSTR(7)
+ #undef SSTR
+ CASE(Ostring) {
+ uint8_t idx = code[ip++];
+ Val v;
+ assert(idx < fn->ncon);
+ v = fn->con[idx];
+ assert(isobj_of(v, PEZ_TString));
+ TRY(push(cx, v));
+ }
+ CASE(Olambda) {
+ uint8_t idx = code[ip++];
+ Val v;
+ assert(idx < fn->ncon);
+ v = fn->con[idx];
+ assert(isobj_of(v, PEZ_TFn));
+ TRY(push(cx, v));
+ }
+ CASE(Onot) {
+ Val *p = peek(cx);
+ *p = box_bool(!truthy(*p));
+ }
+ CASE(Oneg) {
+ Val *p = peek(cx);
+ if (!isnum(*p)) {
+ runerr(cx, fn, ip, "attempt to negate %s value", typestr(*p));
+ return 0;
+ }
+ *p = box_num(-(uint32_t)unbox_num(*p));
+ }
+ #define ARITH(o, oname) \
+ CASE(O##o) { \
+ Val b = pop(cx), a = pop(cx); \
+ if (!isnum(a) || !isnum(b)) { \
+ runerr(cx, fn, ip, "cannot %s %s and %s values", \
+ oname, typestr(a), typestr(b)); \
+ return 0; \
+ } \
+ push(cx, UDO_O##o(a, b)); \
+ }
+ ARITH(add, "add")
+ ARITH(sub, "subtract")
+ ARITH(mul, "multiply")
+ ARITH(div, "divide")
+ ARITH(mod, "divide")
+ ARITH(band, "perform bitwise-and on")
+ ARITH(bior, "perform bitwise-or on")
+ ARITH(bxor, "perform bitwise-xor on")
+ ARITH(shl, "bitshift")
+ ARITH(shra, "bitshift")
+ ARITH(shrl, "bitshift")
+ ARITH(lt, "compare")
+ ARITH(le, "compare")
+ ARITH(gt, "compare")
+ ARITH(ge, "compare")
+ #undef ARITH
+ #define IARITH(o, oname, expr) \
+ CASE(O##i##o) { \
+ Val *p = peek(cx), a = *p; \
+ int32_t iimm =(int8_t)code[ip++]; \
+ fixnum nimm = (uint32_t)iimm << 12; (void)nimm; \
+ fixnum x = unbox_num(a); \
+ if (!isnum(a)) { \
+ runerr(cx, fn, ip, "cannot %s %s and number values", \
+ oname, typestr(a)); \
+ return 0; \
+ } \
+ *p = expr; \
+ }
+ IARITH(add, "add", box_num((uint32_t)x + nimm))
+ IARITH(mul, "multiply", box_num((uint32_t)x * iimm))
+ IARITH(div, "divide", box_num(/*iimm!=0*/ x / iimm))
+ IARITH(mod, "divide", box_num(/*nimm!=0*/ nimm < 0 ? -x % -nimm : x % nimm))
+ IARITH(band, "perform bitwise-and on", box_num(x & nimm))
+ IARITH(bior, "perform bitwise-or on", box_num(x | nimm))
+ IARITH(bxor, "perform bitwise-xor on", box_num(x ^ nimm))
+ IARITH(shl, "bitshift", box_num((uint32_t)x << (iimm & 0x1F)))
+ IARITH(shra, "bitshift", box_num( x >> (iimm & 0x1F)))
+ IARITH(shrl, "bitshift", box_num((uint32_t)x >> (iimm & 0x1F)))
+ IARITH(lt, "compare", box_bool(x < nimm))
+ IARITH(le, "compare", box_bool(x <= nimm))
+ IARITH(gt, "compare", box_bool(x > nimm))
+ IARITH(ge, "compare", box_bool(x >= nimm))
+ #undef IARITH
+ CASE(Oeq) {
+ Val a = pop(cx), b = pop(cx);
+ push(cx, box_bool(a.r == b.r));
+ }
+ CASE(One) {
+ Val a = pop(cx), b = pop(cx);
+ push(cx, box_bool(a.r != b.r));
+ }
+ CASE(Oieq) {
+ *peek(cx) = box_bool(peek(cx)->r == box_num((int8_t)code[ip++] << 12).r);
+ }
+ CASE(Oine) {
+ *peek(cx) = box_bool(peek(cx)->r != box_num((int8_t)code[ip++] << 12).r);
+ }
+ CASE(Oarg) {
+ uint8_t idx = code[ip++];
+ TRY(push(cx, args[idx]));
+ }
+ CASE(Osetarg) {
+ uint8_t idx = code[ip++];
+ args[idx] = *--cx->stktop;
+ }
+ CASE(Olocal) {
+ uint8_t idx = code[ip++];
+ TRY(push(cx, locals[idx]));
+ }
+ CASE(Osetloc) {
+ uint8_t idx = code[ip++];
+ locals[idx] = pop(cx);
+ }
+ CASE(Oglobal) {
+ Val k = pop(cx), *v;
+ if ((v = getglobal(cx, k))) {
+ push(cx, *v);
+ } else {
+ char buf[8];
+ const char *name;
+ if (issstr(k)) {
+ unbox_sstr(k, buf);
+ name = buf;
+ } else if (isobj_of(k, PEZ_TString)) {
+ Str *s = (Str *)unbox_obj(k);
+ name = s->dat;
+ } else { assert(0); }
+ runerr(cx, fn, ip, "no such global \"%s\"", name);
+ return 0;
+ }
+ }
+ CASE(Osetglo) {
+ Val k, v, *g;
+ v = pop(cx);
+ k = pop(cx);
+ if ((g = getglobal(cx, k))) {
+ *g = v;
+ } else {
+ char buf[8];
+ const char *name;
+ if (issstr(k)) {
+ unbox_sstr(k, buf);
+ name = buf;
+ } else if (isobj_of(k, PEZ_TString)) {
+ Str *s = (Str *)unbox_obj(k);
+ name = s->dat;
+ } else { assert(0); }
+ runerr(cx, fn, ip, "no such global \"%s\"", name);
+ return 0;
+ }
+ }
+ CASE(Oputglo) {
+ Val k, v;
+ v = pop(cx);
+ k = pop(cx);
+ TRY(putglobal(cx, k, v));
+ }
+ CASE(Oapply) {
+ uint8_t n = code[ip++];
+ Val lhs, ret;
+ assert(cx->stktop - n - 1 >= cx->stack);
+ lhs = cx->stktop[-n - 1];
+ memmove(cx->stktop - n - 1, cx->stktop - n, n * sizeof(Val));
+ --cx->stktop;
+ if (isobj_of(lhs, PEZ_TFn)) {
+ Fn *f = (Fn *)unbox_obj(lhs);
+ if (f->variadic ? n < f->nparams : n != f->nparams) {
+ runerr(cx, fn, ip, "function takes %d arg(s), %d %s given",
+ f->nparams, n, n == 1 ? "was" : "were");
+ return 0;
+ }
+ TRY(exefn(cx, f, n));
+ ret = pop(cx);
+ cx->stktop -= n-1;
+ *peek(cx) = ret;
+ } else {
+ TRY(apply(cx, &ret, fn, ip, lhs, n));
+ cx->stktop -= n-1;
+ *peek(cx) = ret;
+ }
+ }
+ CASE(Osetapp) {
+ uint8_t n = code[ip++];
+ Val rval = pop(cx),
+ a = cx->stktop[-1 - n],
+ ret;
+ TRY(setapply(cx, &ret, fn, ip, a, n, rval));
+ cx->stktop -= n;
+ cx->stktop[-1] = ret;
+ }
+ CASE(Olength) {
+ Val a = *peek(cx);
+ if (isobj_of(a, PEZ_TArray)) {
+ *peek(cx) = box_num(inttofix(((Array *)unbox_obj(a))->len));
+ } else {
+ Val arg, ret;
+ bool ok = box_str(cx, &arg, "length", 6);
+ assert(ok);
+ TRY(push(cx, arg));
+ TRY(apply(cx, &ret, fn, ip, a, 1));
+ --cx->stktop;
+ *peek(cx) = ret;
+ }
+ }
+ CASE(Onewarr) {
+ uint8_t n = code[ip++];
+ Array *arr = newarr(cx, n);
+ TRY(arr != NULL);
+ TRY(arrpushn(cx, arr, cx->stktop - n, n));
+ cx->stktop -= n;
+ TRY(push(cx, box_obj(arr)));
+ }
+ CASE(Oarradd) {
+ uint8_t n = code[ip++];
+ Val r = cx->stktop[-n - 1];
+ Array *arr = (Array *)unbox_obj(r);
+ assert(isobj(r) && arr->o.t == PEZ_TArray);
+ TRY(arrpushn(cx, arr, cx->stktop - n, n));
+ cx->stktop -= n;
+ }
+ CASE(Ob) {
+ int16_t off;
+ uint dst;
+ memcpy(&off, &code[ip], 2), ip += 2;
+ dst = ip + off;
+ assert(dst < fn->ncode);
+ ip = dst;
+ }
+ CASE(Obt) {
+ int16_t off;
+ uint dst;
+ Val v = pop(cx);
+ memcpy(&off, &code[ip], 2), ip += 2;
+ dst = ip + off;
+ assert(dst < fn->ncode);
+ if (truthy(v)) {
+ ip = dst;
+ }
+ }
+ CASE(Obf) {
+ int16_t off;
+ uint dst;
+ Val v = pop(cx);
+ memcpy(&off, &code[ip], 2), ip += 2;
+ dst = ip + off;
+ assert(dst < fn->ncode);
+ if (!truthy(v)) {
+ ip = dst;
+ }
+ }
+ BADOP {
+ runerr(cx, fn, ip, "bad opcode %#x", code[ip-1]);
+ return 0;
+ }
+ VMEND
+#undef BADOP
+#undef CASE
+#undef VMEND
+#undef VMBEGIN
+}
+
+/******************/
+/* Core functions */
+/******************/
+
+struct vals { vec_of(Val); };
+static bool
+xprint1(PezContext *cx, struct vals *seen,
+ bool (*cb)(PezContext *, void *, const char *, uint), void *u, Val v)
+{
+ for (int i = 0; i < seen->len; ++i) {
+ if (seen->at[i].r == v.r) {
+ char buf[20];
+ int n = sprintf(buf, "#%d", i);
+ return cb(cx, u, buf, n);
+ }
+ }
+ if (isvoid(v)) {
+ cb(cx, u, "()", 2);
+ } else if (isbool(v)) {
+ cb(cx, u, unbox_bool(v) ? "#t" : "#f", 2);
+ } else if (isnum(v)) {
+ fixnum num = unbox_num(v);
+ double d = fixtof(num);
+ char buf[NAMEMAX];
+ int n = sprintf(buf, num == fixtrunc(num) ? "%g" : "%f", d);
+ TRY(cb(cx, u, buf, n));
+ } else if (issstr(v) || isobj_of(v, PEZ_TString)) {
+ char buf[8];
+ const char *str;
+ int len;
+ bool ok = 1;
+ if (issstr(v)) {
+ len = unbox_sstr(v, buf);
+ str = buf;
+ } else {
+ len = ((Str *)unbox_obj(v))->n;
+ str = ((Str *)unbox_obj(v))->dat;
+ }
+ ok &= cb(cx, u, "\"", 1);
+ for (int i = 0; i < len; ++i) {
+ extern int isprint(int);
+ if (str[i] == '\\') {
+ ok &= cb(cx, u, "\\\\", 2);
+ } else if (str[i] == '\n') {
+ ok &= cb(cx, u, "\\n", 2);
+ } else if (str[i] == '\t') {
+ ok &= cb(cx, u, "\\t", 2);
+ } else if (str[i] == '"') {
+ ok &= cb(cx, u, "\\\"", 2);
+ } else if (isprint(str[i])) {
+ ok &= cb(cx, u, &str[i], 1);
+ } else {
+ char tmp[5];
+ sprintf(tmp, "\\x%.2X", (unsigned char)str[i]);
+ ok &= cb(cx, u, tmp, 4);
+ }
+ }
+ ok &= cb(cx, u, "\"", 1);
+ TRY(ok);
+ } else if (iscfn(v) || isobj_of(v, PEZ_TFn)) {
+ const char *name =
+ isobj_of(v, PEZ_TFn) && ((Fn *)unbox_obj(v))->named ? ((Fn *)unbox_obj(v))->name : NULL;
+ if (name) {
+ TRY(cb(cx, u, "#<function ", 11));
+ TRY(cb(cx, u, name, strlen(name)));
+ TRY(cb(cx, u, ">", 1));
+ } else {
+ TRY(cb(cx, u, "#<function>", 11));
+ }
+ } else if (isobj_of(v, PEZ_TArray)) {
+ Array *arr = (Array *)unbox_obj(v);
+ bool ok = 1;
+ TRY(vecpush(cx, seen, &v, 1));
+ ok &= cb(cx, u, "#[", 2);
+ for (int i = 0; i < arr->len; ++i) {
+ ok &= xprint1(cx, seen, cb, u, arr->at[i]);
+ if (i != arr->len - 1) {
+ ok &= cb(cx, u, ", ", 2);
+ }
+ }
+ ok &= cb(cx, u, "]", 1);
+ TRY(ok);
+ } else {
+ TRY(cb(cx, u, "#<?\?\?>", 6));
+ }
+ return 1;
+}
+
+static bool
+f_xprintf1(PezContext *cx, const char *fn,
+ bool (*cb)(PezContext *, void *, const char *, uint), void *u, int argc)
+{
+ int args = pez_top(cx) - argc, arg = 1;
+ char sbuf[8];
+ const char *fmt;
+ int fmtlen;
+ bool ok = 1;
+ if (argc < 1) {
+ pez_error(cx, fn, "missing format string");
+ return 0;
+ }
+ if (!pez_isstring(cx, args + 0)) {
+ pez_error(cx, fn, "expected format string (got %s)", pez_typename(cx, args + 0));
+ return 0;
+ }
+ fmtlen = pez_length(cx, args + 0);
+ fmt = pez_getstring(cx, sbuf, args + 0);
+ for (int i = 0; i < fmtlen; ++i) {
+ char c = fmt[i];
+ if (c == '%' && i < fmtlen - 1) {
+ if ((c = fmt[++i]) != '%') {
+ Val v;
+ char sbuf[8];
+ const char *str;
+ int len;
+ struct vals seen = {0};
+ if (arg == argc) {
+ pez_error(cx, fn, "not enough arguments for format string");
+ return 0;
+ }
+ v = cx->stack[args + arg];
+ switch (c) {
+ case 'a':
+ ok &= xprint1(cx, &seen, cb, u, v);
+ delvec(cx, &seen);
+ break;
+ case 's':
+ if (!pez_isstring(cx, args + arg)) {
+ pez_error(cx, fn, "%%s format specifier expects a string (got %s)",
+ pez_typename(cx, args + arg));
+ return 0;
+ }
+ len = pez_length(cx, args + arg);
+ str = pez_getstring(cx, sbuf, args + arg);
+ ok &= cb(cx, u, str, len);
+ break;
+ default:
+ pez_error(cx, fn, "bad format specifier '%%%c'", c);
+ return 0;
+ }
+ ++arg;
+ continue;
+ }
+ }
+ ok &= cb(cx, u, &c, 1);
+ }
+ TRY(ok);
+ TRY(pez_pushvoid(cx));
+ return 1;
+}
+
+static bool
+printtofile(PezContext *cx, void *fp, const char *d, uint n)
+{
+ fwrite(d, 1, n, fp);
+ return 1;
+}
+
+static bool
+f_printf(PezContext *cx, int argc)
+{
+ return f_xprintf1(cx, "printf", printtofile, stdout, argc);
+}
+
+static bool
+printtostr(PezContext *cx, void *V, const char *d, uint n)
+{
+ vec_of(char) *v = V;
+ return vecpush(cx, v, d, n);
+}
+
+static bool
+f_sprintf(PezContext *cx, int argc)
+{
+ vec_of(char) s = {0};
+ ETRY(f_xprintf1(cx, "sprintf", printtostr, &s, argc));
+ ETRY(pez_pushstring(cx, s.at, s.len));
+ delvec(cx, &s);
+ return 1;
+Err:
+ delvec(cx, &s);
+ return 0;
+}
+
+static const struct coredef { const char *n; PezCFn *f; } core[] = {
+ { "printf", f_printf },
+ { "sprintf", f_sprintf }
+};
+
+static bool
+initcore(PezContext *cx)
+{
+ for (int i = 0; i < sizeof core / sizeof *core; ++i) {
+ const struct coredef *def = &core[i];
+ Val s, f;
+ TRY(box_str(cx, &s, def->n, strlen(def->n)));
+ f = box_cfn(def->f);
+ TRY(putglobal(cx, s, f));
+ }
+ return 1;
+}
+
+/*******************/
+/* Parser/compiler */
+/*******************/
+
+static void
+initcomp(Comp *cm, PezContext *cx, Fn *fn, int (*cb)(void *), void *ud)
+{
+ memset(cm, 0, sizeof *cm);
+ cm->cx = cx;
+ cm->readcb = cb;
+ cm->readud = ud;
+ cm->line = 1;
+ cm->col = 0;
+ cm->lastop = cm->lastop2 = -1;
+ cm->fn = fn;
+}
+
+static void
+delfenv(PezContext *cx, struct fenv *fenv)
+{
+ delvec(cx, &fenv->locals);
+}
+
+static void
+deinitcomp(Comp *cm)
+{
+ delfenv(cm->cx, &cm->fenv);
+ delvec(cm->cx, &cm->spool);
+ delvec(cm->cx, &cm->kpool);
+}
+
+static void
+fincompfn(Comp *cm)
+{
+ Fn *f = cm->fn;
+ const uint8_t *code = cm->cx->alloc(cm->cx->ud, cm->code.at, cm->code.cap, cm->code.len);
+ const Val *con = cm->cx->alloc(cm->cx->ud, cm->con.at,
+ cm->con.cap * sizeof(Val), cm->con.len * sizeof(Val));
+ assert(code != NULL && (cm->con.len == 0 || con != NULL) && "can't shrink?");
+ f->code = code;
+ f->ncode = cm->code.len;
+ f->con = con;
+ f->ncon = cm->con.len;
+}
+
+static void
+comperr(Comp *cm, int ch, const char *fmt, ...)
+{
+ va_list ap;
+ char buf[80] = {0};
+ char buf2[10];
+ cm->cx->err = PEZ_ESyntax;
+ va_start(ap, fmt);
+ vsnprintf(buf, sizeof buf, fmt, ap);
+ va_end(ap);
+ sprintf(buf2, "'%c'", ch);
+ snprintf(cm->cx->errstr, sizeof cm->cx->errstr,
+ "%s:%d:%d: %s (near %s)", cm->fn->file,
+ cm->line, cm->col, buf, ch == EOF ? "<EOF>" : buf2);
+ cm->cx->errstr[sizeof cm->cx->errstr - 1] = 0;
+}
+
+static bool
+compbytes(Comp *cm, void *d, size_t n)
+{
+ return vecpush(cm->cx, &cm->code, d, n);
+}
+
+static bool
+compbyte(Comp *cm, uint8_t x)
+{
+ return compbytes(cm, &x, 1);
+}
+
+static bool compop(Comp *cm, enum op x);
+static int peekchr(Comp *cm);
+
+static bool
+compconst(Comp *cm, Val v)
+{
+ int t;
+ if (isvoid(v)) {
+ TRY(compop(cm, Ovoid));
+ return 1;
+ }
+ if (isnum(v)) {
+ fixnum num = unbox_num(v);
+ if (num == 0) {
+ TRY(compop(cm, Ozero));
+ } else if (num == FX(1)) {
+ TRY(compop(cm, Oone));
+ } else if (num == fixtrunc(num) && num >= FX(-128) && num < FX(127)) {
+ int8_t n = fixtoint(num);
+ TRY(compop(cm, Obyte));
+ TRY(compop(cm, n));
+ } else if (num == fixtrunc(num) && num >= FX(-32768) && num < FX(32768)) {
+ int16_t n = fixtoint(num);
+ TRY(compop(cm, Oshort));
+ TRY(compbytes(cm, &n, 2));
+ } else {
+ TRY(compop(cm, Onumber));
+ TRY(compbytes(cm, &num, 4));
+ }
+ return 1;
+ }
+ if (isbool(v)) {
+ TRY(compop(cm, unbox_bool(v) ? Otrue : Ofalse));
+ return 1;
+ }
+ if (issstr(v)) {
+ char s[8];
+ int n = unbox_sstr(v, s);
+ assert(n >= 0 && n < 8);
+ TRY(compop(cm, Osstr0 + n));
+ TRY(compbytes(cm, s, n));
+ return 1;
+ }
+ if (isobj(v) && ((t = objtag(v)) == PEZ_TString || t == PEZ_TFn)) {
+ uint8_t idx = cm->con.len;
+ for (int i = 0; i < cm->con.len; ++i) {
+ if (cm->con.at[i].r == v.r) {
+ idx = i;
+ goto K;
+ }
+ }
+ if (cm->con.len == UINT8_MAX) {
+ comperr(cm, peekchr(cm), "too many consts");
+ return 0;
+ }
+ K:
+ vecpush(cm->cx, &cm->con, &v, 1);
+ TRY(compop(cm, t == PEZ_TString ? Ostring : Olambda));
+ TRY(compbyte(cm, idx));
+ return 1;
+ }
+ assert(0 && "const?");
+ return 0;
+}
+
+static bool
+compop(Comp *cm, enum op x)
+{
+ if (cm->has_k) {
+ cm->has_k = 0;
+ TRY(compconst(cm, cm->k));
+ }
+ cm->lastop2 = cm->lastop;
+ cm->lastop = cm->code.len;
+ return compbyte(cm, x);
+}
+
+/* must be called after emitting any branches to avoid
+ * confusing discard() peephole optimizer */
+static void
+resetlastops(Comp *cm)
+{
+ cm->lastop = cm->lastop2 = -1;
+}
+
+static bool
+addparam(Comp *cm, const char *name)
+{
+ struct fenv *fenv = &cm->fenv;
+ Local l = { .sref = cm->spool.len,
+ .scope = fenv->scope,
+ .isparam = 1,
+ .mutable = 1 };
+ assert(l.scope == 0);
+ assert(l.sref == cm->spool.len);
+ TRY(vecpush(cm->cx, &cm->spool, name, strlen(name) + 1));
+ l.index = cm->fn->nparams++;
+ TRY(vecpush(cm->cx, &fenv->locals, &l, 1));
+ return 1;
+}
+
+static void
+beginscope(Comp *cm)
+{
+ ++cm->fenv.scope;
+}
+
+static Local *
+addlocal(Comp *cm, uint *idx, const char *name, bool mutable, bool has_k, Val k)
+{
+ struct fenv *fenv = &cm->fenv;
+ Local l = { .sref = cm->spool.len,
+ .scope = fenv->scope,
+ .kref = cm->kpool.len,
+ .has_k = has_k,
+ .mutable = mutable, };
+ assert(l.scope > 0);
+ assert(l.sref == cm->spool.len);
+ assert(l.kref == cm->kpool.len);
+ TRY(vecpush(cm->cx, &cm->spool, name, strlen(name) + 1));
+ if (mutable) {
+ assert(!has_k);
+ }
+ if (!has_k) {
+ // this renders into a stack slot
+ *idx = l.index = fenv->nvars++;
+ cm->fn->nvars = MAX(cm->fn->nvars, fenv->nvars);
+ } else {
+ // to propagate constant folding through const locals
+ TRY(vecpush(cm->cx, &cm->kpool, &k, 1));
+ }
+ TRY(vecpush(cm->cx, &fenv->locals, &l, 1));
+ return veclast(&fenv->locals);
+}
+
+static Local *
+findlocal(Comp *cm, const char *name)
+{
+ for (int i = cm->fenv.locals.len - 1; i >= 0; --i) {
+ Local *l = &cm->fenv.locals.at[i];
+ if (!strcmp(&cm->spool.at[l->sref], name)) {
+ return l;
+ }
+ }
+ return NULL;
+}
+
+static bool
+endscope(Comp *cm)
+{
+ while (!vecempty(&cm->fenv.locals)) {
+ Local *l = veclast(&cm->fenv.locals);
+ if (l->scope < cm->fenv.scope) {
+ break;
+ } else {
+ if (!l->has_k) {
+ --cm->fenv.nvars;
+ }
+ --cm->fenv.locals.len;
+ }
+ }
+ --cm->fenv.scope;
+ return 1;
+}
+
+static int
+nextchr(Comp *cm)
+{
+ int c;
+ if (cm->have_peekchr) {
+ cm->have_peekchr = 0;
+ return cm->peekchr;
+ }
+ c = cm->readcb(cm->readud);
+ if (c == '\n') {
+ ++cm->line;
+ cm->col = 0;
+ } else {
+ ++cm->col;
+ }
+ return c;
+}
+
+static int
+peekchr(Comp *cm)
+{
+ if (cm->have_peekchr) {
+ return cm->peekchr;
+ }
+ cm->peekchr = nextchr(cm);
+ cm->have_peekchr = 1;
+ return cm->peekchr;
+}
+
+static bool
+aisspace(int c)
+{
+ switch (c)
+ case ' ': case '\t': case '\n':
+ case '\r': case '\v': case '\f':
+ return 1;
+ return 0;
+}
+
+static inline void
+eatspaces(Comp *cm)
+{
+ for (;; nextchr(cm)) {
+ int c = peekchr(cm);
+ if (c == ';') { // ; comment
+ for (; (c = peekchr(cm)) != '\n' && c != EOF; nextchr(cm)) ;
+ continue;
+ }
+ if (!aisspace(peekchr(cm))) {
+ break;
+ }
+ }
+}
+
+static bool
+matchchr(Comp *cm, int chr)
+{
+ if (peekchr(cm) == chr) {
+ nextchr(cm);
+ return 1;
+ }
+ return 0;
+}
+
+static bool
+matchspchr(Comp *cm, int chr)
+{
+ eatspaces(cm);
+ return matchchr(cm, chr);
+}
+
+static bool
+expectchr(Comp *cm, int chr)
+{
+ if (!matchchr(cm, chr)) {
+ comperr(cm, peekchr(cm), "expected '%c'", chr);
+ return 0;
+ }
+ return 1;
+}
+
+static bool
+expectspchr(Comp *cm, int chr)
+{
+ eatspaces(cm);
+ return expectchr(cm, chr);
+}
+
+static bool
+aisdigit(int c)
+{
+ return c >= '0' && c <= '9';
+}
+
+static bool
+aisalpha(int c)
+{
+ return (c >= 'a' && c <= 'z')
+ || (c >= 'A' && c <= 'Z');
+}
+
+static bool
+aissep(int c)
+{
+ if (aisspace(c))
+ return 1;
+ switch (c)
+ case '(': case ')': case '[': case ']':
+ case '{': case '}': case '.': case ',':
+ case ';': case '?': case '+': case '-':
+ case '*': case '/': case '&': case '|':
+ case '^': case '~': case '=': case '\'':
+ case '"': case '<': case '>': case ':':
+ case '@': case '%': case '\\': case '`':
+ case EOF:
+ return 1;
+ return 0;
+}
+
+/* Used by 'string-constants */
+static bool
+aissep2(int c)
+{
+ if (aisspace(c))
+ return 1;
+ switch (c)
+ case '(': case ')': case '[': case ']':
+ case '{': case '}': case ',': case ';':
+ case '\'': case '"': case EOF:
+ return 1;
+ return 0;
+}
+
+static bool
+readident(Comp *cm, char *dst, size_t size)
+{
+ size_t i = 0;
+ while (!aissep(peekchr(cm))) {
+ if (i == size - 2) {
+ comperr(cm, peekchr(cm), "identifier too long");
+ return 0;
+ }
+ dst[i++] = nextchr(cm);
+ }
+ dst[i] = 0;
+ return 1;
+}
+
+static bool block(Comp *cm, int endchr);
+static bool expr(Comp *cm);
+
+static bool
+lambda(Comp *cm, const char *name)
+{
+ Fn *fn = newfn(cm->cx, cm->fn->file, name, cm->line);
+ Fn *prevfn = cm->fn;
+ vec_of(uint8_t) prevcode;
+ vec_of(Val) prevcon;
+ struct fenv prevfenv = cm->fenv;;
+ struct fenv fenv = { .prev = &prevfenv };
+ bool ret = 1;
+
+ memcpy(&prevcode, &cm->code, sizeof prevcode);
+ memset(&cm->code, 0, sizeof cm->code);
+ memcpy(&prevcon, &cm->con, sizeof prevcon);
+ memset(&cm->con, 0, sizeof cm->con);
+ cm->fn = fn;
+ cm->fenv = fenv;
+
+ if (matchspchr(cm, '[')) {
+ while (!matchspchr(cm, ']')) {
+ char name[NAMEMAX];
+ int c;
+ eatspaces(cm);
+ if ((c = peekchr(cm)) != '_' && !aisalpha(c)) {
+ comperr(cm, c, "expected identifier");
+ return 0;
+ }
+ ETRY(readident(cm, name, sizeof name));
+
+ ETRY(addparam(cm, name));
+
+ if (!matchspchr(cm, ',')) {
+ ETRY(expectspchr(cm, ']'));
+ break;
+ }
+ }
+ }
+
+ ETRY(block(cm, '}'));
+ ETRY(compop(cm, Oret));
+ fincompfn(cm);
+
+Cleanup:
+ cm->fn = prevfn;
+ memcpy(&cm->code, &prevcode, sizeof prevcode);
+ memcpy(&cm->con, &prevcon, sizeof prevcon);
+ delfenv(cm->cx, &cm->fenv);
+ cm->fenv = prevfenv;
+ return ret && compconst(cm, box_obj(fn));
+
+Err:
+ ret = 1;
+ goto Cleanup;
+}
+
+static bool
+flushconst(Comp *cm)
+{
+ if (cm->has_k) {
+ cm->has_k = 0;
+ return compconst(cm, cm->k);
+ }
+ return 1;
+}
+
+static bool
+primaryexpr(Comp *cm)
+{
+ char buf[NAMEMAX];
+ Local *local;
+ int c;
+
+ if (*cm->stash_ident) {
+ strcpy(buf, cm->stash_ident);
+ *cm->stash_ident = 0;
+ goto Ident;
+ }
+ if (cm->stash_local) {
+ local = cm->stash_local;
+ cm->stash_local = NULL;
+ goto Local;
+ }
+ eatspaces(cm);
+ c = nextchr(cm);
+ cm->lvalue = 0;
+ if (aisdigit(c)) { // number
+ int i = 0;
+ double dbl;
+ fixnum num;
+ char *eptr;
+ goto begin;
+ do {
+ c = nextchr(cm);
+ begin:
+ if (i == sizeof buf - 1) {
+ comperr(cm, c, "number literal too long");
+ return 0;
+ }
+ buf[i++] = c;
+ } while ((c = peekchr(cm)) == '.' || !aissep(c));
+ buf[i++] = 0;
+ dbl = strtod(buf, &eptr);
+ if (eptr != buf + i - 1) {
+ comperr(cm, c, "bad number literal '%s'", buf);
+ return 0;
+ }
+ if (dbl > 0x80000) {
+ comperr(cm, c, "number literal overflow '%s'", buf);
+ return 0;
+ }
+ num = ftofix(dbl);
+ cm->has_k = 1;
+ cm->k = box_num(num);
+ return 1;
+ }
+ if (c == '_' || aisalpha(c)) {
+ // identifier
+ *buf = c;
+ TRY(readident(cm, buf + 1, sizeof buf - 1));
+ Ident:
+ local = findlocal(cm, buf);
+ if (local) {
+ Local:
+ if (local->isparam) {
+ assert(local->index < 256);
+ TRY(compop(cm, Oarg) && compbyte(cm, local->index));
+ } else if (local->has_k) {
+ cm->has_k = 1;
+ cm->k = cm->kpool.at[local->kref];
+ } else {
+ assert(local->index < 256);
+ TRY(compop(cm, Olocal) && compbyte(cm, local->index));
+ }
+ cm->lvalue = 1;
+ cm->lvalue_const = !local->mutable;
+ cm->lvalue_name = &cm->spool.at[local->sref];
+ } else {
+ Val nam;
+ TRY(box_str(cm->cx, &nam, buf, strlen(buf)));
+ TRY(compconst(cm, nam));
+ TRY(compop(cm, Oglobal));
+ cm->lvalue = 1;
+ cm->lvalue_const = 0;
+ cm->lvalue_name = NULL;
+ }
+ return 1;
+ }
+ if (c == '\'') {
+ // enum-like string
+ int i = 0;
+ while (!aissep2((c = peekchr(cm)))) {
+ assert(i < sizeof buf - 2);
+ buf[i++] = c;
+ nextchr(cm);
+ }
+ switch (c) {
+ case EOF: case '(': case ')': case ',': case '[': case ']': case '{': case '}':
+ break;
+ default:
+ if (!aisspace(c)) {
+ goto BadE;
+ }
+ }
+ if (i == 0) {
+ BadE:
+ comperr(cm, c, "expected enum-like string constant");
+ return 0;
+ }
+ buf[i] = 0;
+ TRY(box_str(cm->cx, &cm->k, buf, i));
+ cm->has_k = 1;
+ return 1;
+ }
+ if (c == '"') {
+ // string
+ int i = 0;
+ while ((c = nextchr(cm)) != '"') {
+ assert(i < sizeof buf - 2);
+ if (c == EOF) {
+ Eof:
+ comperr(cm, c, "unterminated string constant");
+ return 0;
+ }
+ if (c == '\\') {
+ switch ((c = nextchr(cm))) {
+ case 'n': c = '\n'; break;
+ case 't': c = '\t'; break;
+ case '"': c = '"'; break;
+ case '\\': c = '\\'; break;
+ case 'x': case 'X':
+ {
+ const char *b16 = "0123456789abcdef", *p;
+ extern int tolower(int);
+ uint8_t b = 0;
+ for (int i = 0; i < 2; ++i) {
+ b <<= 4;
+ if ((c = nextchr(cm)) == EOF) {
+ goto Eof;
+ }
+ if (!(p = strchr(b16, tolower(c))) || !*p) {
+ goto Bad;
+ }
+ b |= p - b16;
+ }
+ c = b;
+ break;
+ }
+ case EOF: goto Eof;
+ default: Bad: comperr(cm, c, "bad escape sequence"); return 0;
+ }
+ }
+ buf[i++] = c;
+ }
+ buf[i] = 0;
+ TRY(box_str(cm->cx, &cm->k, buf, i));
+ cm->has_k = 1;
+ return 1;
+ }
+ switch (c) {
+ case '(':
+ if (peekchr(cm) == ')') {
+ nextchr(cm);
+ cm->k = VOID;
+ cm->has_k = 1;
+ } else {
+ return block(cm, ')');
+ }
+ return 1;
+
+ case '{':
+ return lambda(cm, NULL);
+
+ case '#':
+ // other literals
+ if (aisalpha((c = peekchr(cm)))) {
+ // #t or #f
+ char buf[10];
+ int i = 0;
+ do {
+ buf[i++] = c;
+ if (i == sizeof buf - 1) {
+ comperr(cm, c, "bad literal '#%.*s'", i, buf);
+ return 0;
+ }
+ c = nextchr(cm);
+ } while (!aissep(peekchr(cm)));
+ buf[i++] = 0;
+
+ if (!strcmp(buf, "t") || !strcmp(buf, "f")) {
+ cm->k = box_bool(*buf == 't');
+ cm->has_k = 1;
+ return 1;
+ }
+
+ comperr(cm, c, "bad literal '#%.*s'", i, buf);
+ return 0;
+ } else if (c == '[') {
+ // array
+ int n = 0;
+ bool big = 0;
+ nextchr(cm);
+ cm->lvalue = 0;
+ while (!matchspchr(cm, ']')) {
+ TRY(expr(cm));
+ TRY(flushconst(cm));
+ if (++n == 255) {
+ TRY(compop(cm, big ? Oarradd : Onewarr));
+ TRY(compbyte(cm, n));
+ big = 1;
+ n = 0;
+ }
+ if (!matchspchr(cm, ',')) {
+ TRY(expectspchr(cm, ']'));
+ break;
+ }
+ }
+ TRY(compop(cm, big ? Oarradd : Onewarr));
+ TRY(compbyte(cm, n));
+ return 1;
+ } else if (c == EOF || aisspace(c)) {
+ comperr(cm, c, "stray '#'");
+ return 0;
+ }
+ comperr(cm, c, "bad literal '#%c'", c);
+ return 0;
+ }
+ comperr(cm, c, "expected expression");
+ return 0;
+}
+
+static bool
+postfixexpr(Comp *cm)
+{
+ TRY(primaryexpr(cm));
+ for (;;) {
+ if (matchspchr(cm, '[')) {
+ int n = 0;
+ TRY(flushconst(cm));
+ cm->lvalue = 0;
+ while (!matchspchr(cm, ']')) {
+ TRY(expr(cm));
+ TRY(flushconst(cm));
+ ++n;
+ if (!matchspchr(cm, ',')) {
+ TRY(expectspchr(cm, ']'));
+ break;
+ }
+ }
+ assert(n < 256);
+ cm->lvalue = 1;
+ cm->lvalue_const = 0;
+ cm->lvalue_name = NULL;
+ TRY(compop(cm, Oapply));
+ TRY(compbyte(cm, n));
+ } else if (matchspchr(cm, '.')) {
+ int c;
+ char name[NAMEMAX];
+ Val s;
+
+ eatspaces(cm);
+ if ((c = peekchr(cm)) != '_' && !aisalpha(c)) {
+ comperr(cm, c, "expected identifier");
+ return 0;
+ }
+ TRY(readident(cm, name, sizeof name));
+ if (!strcmp(name, "length")) {
+ TRY(compop(cm, Olength));
+ } else {
+ TRY(box_str(cm->cx, &s, name, strlen(name)));
+ TRY(compconst(cm, s));
+ TRY(compop(cm, Oapply));
+ TRY(compbyte(cm, 1));
+ }
+ cm->lvalue = 1;
+ cm->lvalue_const = 0;
+ cm->lvalue_name = NULL;
+ } else {
+ break;
+ }
+ }
+ return 1;
+}
+
+static bool
+prefixexpr(Comp *cm)
+{
+ if (*cm->stash_ident || cm->stash_local) {
+ return postfixexpr(cm);
+ } else if (matchspchr(cm, '-')) {
+ TRY(prefixexpr(cm));
+ cm->lvalue = 0;
+ if (cm->has_k && isnum(cm->k)) {
+ cm->k = box_num(-(uint32_t)unbox_num(cm->k));
+ return 1;
+ }
+ return compop(cm, Oneg);
+ } else if (matchspchr(cm, '!')) {
+ TRY(prefixexpr(cm));
+ cm->lvalue = 0;
+ if (cm->has_k) {
+ cm->k = box_bool(!truthy(cm->k));
+ return 1;
+ }
+ return compop(cm, Onot);
+ } else {
+ return postfixexpr(cm);
+ }
+}
+
+/*
+ * kinds:
+ * 0 - not binop
+ * 'A' - arith
+ * 'C' - cmp
+ * 'L' - logic
+ * 'S' - setters
+ */
+enum { Oset = 0x100, Ologand, Ologor }; // pseudo ops
+static int
+getbinop(char *kind, char *chr, Comp *cm)
+{
+ int c;
+ if (cm->stash_binopop) {
+ int op = cm->stash_binopop;
+ *kind = cm->stash_binopk;
+ *chr = cm->stash_binopchr;
+ cm->stash_binopop = 0;
+ return op;
+ }
+ eatspaces(cm);
+ c = peekchr(cm);
+ *chr = 0;
+ switch (c) {
+ case '+':
+ *chr = nextchr(cm);
+ *kind = matchchr(cm, '=') ? 'S' : 'A';
+ return Oadd;
+ case '-':
+ *chr = nextchr(cm);
+ *kind = matchchr(cm, '=') ? 'S' : 'A';
+ return Osub;
+ case '*':
+ *chr = nextchr(cm);
+ *kind = matchchr(cm, '=') ? 'S' : 'A';
+ return Omul;
+ case '/':
+ *chr = nextchr(cm);
+ *kind = matchchr(cm, '=') ? 'S' : 'A';
+ return Odiv;
+ case '%':
+ *chr = nextchr(cm);
+ *kind = matchchr(cm, '=') ? 'S' : 'A';
+ return Omod;
+ case '&':
+ *chr = nextchr(cm);
+ if (matchchr(cm, '&')) {
+ *kind = 'L';
+ return Ologand;
+ }
+ *kind = matchchr(cm, '=') ? 'S' : 'A';
+ return Oband;
+ case '|':
+ *chr = nextchr(cm);
+ if (matchchr(cm, '|')) {
+ *kind = 'L';
+ return Ologor;
+ }
+ *kind = matchchr(cm, '=') ? 'S' : 'A';
+ return Obior;
+ case '^':
+ *chr = nextchr(cm);
+ *kind = matchchr(cm, '=') ? 'S' : 'A';
+ return Obxor;
+ case '<':
+ *chr = nextchr(cm);
+ if (matchchr(cm, '<')) {
+ *kind = matchchr(cm, '=') ? 'S' : 'A';
+ return Oshl;
+ }
+ *kind = 'C';
+ if (matchchr(cm, '=')) {
+ return Ole;
+ }
+ return Olt;
+ case '>':
+ *chr = nextchr(cm);
+ if (matchchr(cm, '>')) {
+ int o = matchchr(cm, '>') ? Oshrl : Oshra;
+ *kind = matchchr(cm, '=') ? 'S' : 'A';
+ return o;
+ }
+ *kind = 'C';
+ if (matchchr(cm, '=')) {
+ return Oge;
+ }
+ return Ogt;
+ case '=':
+ *chr = nextchr(cm);
+ if (matchchr(cm, '=')) {
+ *kind = 'C';
+ return Oeq;
+ }
+ *kind = 'S';
+ return Oset;
+ case '!':
+ *chr = nextchr(cm);
+ if (matchchr(cm, '=')) {
+ *kind = 'C';
+ return One;
+ }
+ *kind = 0;
+ return -1;
+ }
+ *kind = 0;
+ return 0;
+}
+
+static void
+stashbinop(Comp *cm, int op, char kind, char chr)
+{
+ cm->stash_binopop = op;
+ cm->stash_binopk = kind;
+ cm->stash_binopchr = chr;
+}
+
+static inline bool
+isimm(int *imm, Val v)
+{
+ fixnum num = unbox_num(v);
+ *imm = fixtoint(num);
+ return isnum(v) && num == fixtrunc(num) && *imm >= -128 && *imm < 128;
+}
+
+// returns true if op is commutative or can be made to be,
+// (mutates op such that a b lt => b a gt, etc)
+static inline bool
+commutate(enum op *op) {
+ switch (*op) {
+ case Oadd: case Omul: case Oband: case Obior:
+ case Obxor: case Oeq: case One:
+ return 1;
+ case Olt: *op = Ogt; return 1;
+ case Ole: *op = Oge; return 1;
+ case Ogt: *op = Olt; return 1;
+ case Oge: *op = Ole; return 1;
+ default:
+ return 0;
+ }
+}
+
+static bool discard(Comp *cm);
+
+static bool
+binexpr(Comp *cm, char okind, bool (*prev)(Comp *))
+{
+ uint save = cm->code.len, save2, save3;
+ char kind, chr;
+ enum op op, op2;
+ TRY(prev(cm));
+ op = getbinop(&kind, &chr, cm), op2 = op;
+ if (kind != okind) {
+ stashbinop(cm, op, kind, chr);
+ return 1;
+ }
+
+ do {
+ Val lk = cm->k;
+ bool has_lk = cm->has_k;
+ int imm;
+ enum op opx = op, iop = 0;
+
+ TRY(flushconst(cm));
+ save2 = cm->code.len;
+ TRY(prev(cm));
+ save3 = cm->code.len;
+ cm->lvalue = 0;
+ if (has_lk && cm->has_k) { // lhs and rhs constant?
+ // only fold when types check
+ if (op == Oeq || op == One || (isnum(lk) && isnum(cm->k))) {
+ // constant fold: undo previous exprs and binop and save constant result
+ cm->code.len = save;
+ cm->has_k = 1;
+ cm->k = uncheckedop(op, lk, cm->k);
+ continue;
+ }
+ } else if (has_lk && isimm(&imm, lk) && commutate(&opx)) {
+ // when lhs is a constant and the operation can be
+ // commutative try use immediate op
+
+ // eliminate code generated for lhs
+ for (int i = 0; i < save3 - save2; ++i) {
+ memmove(cm->code.at + save + i, cm->code.at + save2 + i, save2 - save);
+ }
+ cm->code.len -= (save2 - save);
+
+ cm->has_k = 1;
+ cm->k = lk;
+ goto TryImm;
+ } else if (cm->has_k && isimm(&imm, cm->k)) {
+ // try immediate variants of ops
+ TryImm:
+ if (opx == Osub) {
+ // X - k turns into X + -k, but if k == -128 we cannot encode 128
+ if (imm == -128) {
+ goto Bail;
+ }
+ imm = -imm;
+ goto Oadd;
+ } else if (opx == Odiv && imm == 0) {
+ // the idiv fastpath assumes dividend is nonzero
+ goto Bail;
+ } else if (opx == Omod && imm == 0) {
+ // the imod fastpath assumes dividend is nonzero
+ // always x % 0 = 0
+ cm->has_k = 0;
+ TRY(discard(cm) && compop(cm, Ozero));
+ continue;
+ } else if (opx == Omul) {
+ // try turn mul by powers of 2 into shifts
+ for (int exp = 0; exp < 8; ++exp) {
+ if (imm == 1 << exp) {
+ iop = Oishl;
+ imm = exp;
+ goto CompIop;
+ }
+ }
+ }
+ switch (opx) {
+ Oadd: case Oadd: iop = Oiadd; break;
+ case Omul: iop = Oimul; break;
+ case Odiv: iop = Oidiv; break;
+ case Omod: iop = Oimod; break;
+ case Oband: iop = Oiband; break;
+ case Obior: iop = Oibior; break;
+ case Obxor: iop = Oibxor; break;
+ case Oshl: iop = Oishl; break;
+ case Oshra: iop = Oishra; break;
+ case Oshrl: iop = Oishrl; break;
+ case Olt: iop = Oilt; break;
+ case Ole: iop = Oile; break;
+ case Ogt: iop = Oigt; break;
+ case Oge: iop = Oige; break;
+ case Oeq: iop = Oieq; break;
+ case One: iop = Oine; break;
+ default: break;
+ }
+ CompIop:
+ assert(iop);
+ cm->has_k = 0;
+ TRY(compop(cm, iop) && compbyte(cm, (int8_t)imm));
+ continue;
+ }
+ Bail:
+ TRY(compop(cm, opx));
+ } while (okind != 'C' && (op2 = getbinop(&kind, &chr, cm)) == op);
+ if (op2 != op && kind != 0) {
+ stashbinop(cm, op2, kind, chr);
+ }
+
+ return 1;
+}
+
+static bool
+arithexpr(Comp *cm)
+{
+ return binexpr(cm, 'A', prefixexpr);
+}
+
+static bool
+cmpexpr(Comp *cm)
+{
+ return binexpr(cm, 'C', arithexpr);
+}
+
+static bool
+logicexpr(Comp *cm)
+{
+ uint *ip = &cm->code.len, save;
+ char kind, chr;
+ int op, op2;
+ TRY(cmpexpr(cm));
+ op = getbinop(&kind, &chr, cm), op2 = op;
+ if (kind != 'L') {
+ stashbinop(cm, op, kind, chr);
+ return 1;
+ }
+
+ do {
+ int br_arg, br_jumpfrom, diff;
+ int16_t off;
+
+ if (cm->has_k) {
+ if (op == Ologand ? truthy(cm->k) : !truthy(cm->k)) {
+ // discard lhs
+ cm->has_k = 0;
+ TRY(cmpexpr(cm));
+ } else {
+ // discard rhs
+ Val k = cm->k;
+ save = *ip;
+ TRY(cmpexpr(cm));
+ *ip = save;
+ cm->has_k = 1;
+ cm->k = k;
+ }
+ continue;
+ }
+
+ TRY(compop(cm, Odup));
+ TRY(compop(cm, op == Ologand ? Obf : Obt));
+ br_arg = *ip;
+ TRY(compbytes(cm, "X", 2));
+ br_jumpfrom = *ip;
+
+ TRY(compop(cm, Opop));
+ TRY(cmpexpr(cm));
+ TRY(flushconst(cm));
+
+ off = diff = *ip - br_jumpfrom;
+ assert(off == diff);
+ memcpy(cm->code.at + br_arg, &off, 2);
+
+ resetlastops(cm);
+ } while ((op2 = getbinop(&kind, &chr, cm)) == op);
+ if (op2 != op && kind != 0) {
+ stashbinop(cm, op2, kind, chr);
+ }
+ return 1;
+}
+
+static bool
+condexpr(Comp *cm)
+{
+ TRY(logicexpr(cm));
+ if (matchspchr(cm, '?')) {
+ uint *ip = &cm->code.len, save;
+ if (cm->has_k && truthy(cm->k)) {
+ bool has_k;
+ Val k;
+ TRY(condexpr(cm));
+ has_k = cm->has_k;
+ k = cm->k;
+ cm->has_k = 0;
+ TRY(expectspchr(cm, ':'));
+
+ save = *ip;
+ TRY(condexpr(cm));
+ *ip = save;
+ cm->has_k = has_k;
+ cm->k = k;
+ } else if (cm->has_k && !truthy(cm->k)) {
+ save = *ip;
+ TRY(condexpr(cm));
+ *ip = save;
+ cm->has_k = 0;
+ TRY(expectspchr(cm, ':'));
+ TRY(condexpr(cm));
+ } else {
+ int bf_arg, bf_jumpfrom, b_arg, b_jumpfrom, diff;
+ int16_t off;
+
+ /* <cond>
+ * bf F
+ * <true>
+ * b OK
+ * F: <false>
+ * OK: ...
+ */
+
+ TRY(compop(cm, Obf));
+ bf_arg = *ip;
+ TRY(compbytes(cm, "X", 2));
+ bf_jumpfrom = *ip;
+
+ TRY(condexpr(cm) && flushconst(cm));
+
+ TRY(compop(cm, Ob));
+ b_arg = *ip;
+ TRY(compbytes(cm, "X", 2));
+ b_jumpfrom = *ip;
+
+ TRY(expectspchr(cm, ':'));
+
+ off = diff = *ip - bf_jumpfrom;
+ assert(off == diff);
+ memcpy(&cm->code.at[bf_arg], &off, 2);
+
+ TRY(condexpr(cm) && flushconst(cm));
+
+ off = diff = *ip - b_jumpfrom;
+ assert(off == diff);
+ memcpy(&cm->code.at[b_arg], &off, 2);
+
+ resetlastops(cm);
+ }
+ cm->lvalue = 0;
+ }
+ return 1;
+}
+
+static bool
+setexpr(Comp *cm)
+{
+ char kind, chr;
+ int binop;
+ TRY(condexpr(cm));
+ if ((binop = getbinop(&kind, &chr, cm)) && kind == 'S') {
+ int idx = -1, argc = -1, opcode;
+ vec_of(uint8_t) *code = (void *)&cm->code.at;
+ if (!cm->lvalue) {
+ comperr(cm, chr, "not an lvalue");
+ return 0;
+ }
+ if (cm->lvalue_const) {
+ assert(cm->lvalue_name);
+ comperr(cm, chr, "local '%s' is not mutable", cm->lvalue_name);
+ return 0;
+ }
+
+ /*
+ * with Oset,
+ * ...
+ * local #x
+ * is turned into
+ * ...
+ * <condexpr>
+ * (dup)
+ * setloc #x
+ *
+ * with compound operators, such as Oadd,
+ * ...
+ * local #x
+ * is turned into
+ * ...
+ * local #x
+ * <condexpr>
+ * add
+ * (dup)
+ * setloc #x
+ * and so on
+ */
+
+ assert(cm->lastop >= 0 && cm->lastop < code->len);
+ switch ((opcode = code->at[cm->lastop])) {
+ case Olocal: case Oarg:
+ idx = code->at[cm->lastop + 1];
+ if (binop == Oset) {
+ code->len -= 2;
+ }
+ break;
+ case Oglobal:
+ --code->len;
+ if (binop != Oset) {
+ TRY(compop(cm, Odup));
+ TRY(compop(cm, Oglobal));
+ }
+ break;
+ case Oapply:
+ argc = code->at[cm->lastop + 1];
+ code->len -= 2;
+ Oapply:
+ if (binop != Oset) {
+ TRY(compop(cm, Odupn));
+ TRY(compbyte(cm, argc));
+ TRY(compop(cm, Oapply));
+ TRY(compbyte(cm, argc));
+ }
+ break;
+ case Olength:
+ --code->len;
+ TRY(compconst(cm, length_sstr));
+ argc = 1;
+ opcode = Oapply;
+ goto Oapply;
+ default:
+ assert(0 && "bad lvalue?");
+ }
+
+ TRY(condexpr(cm));
+
+ if (binop != Oset) {
+ TRY(compop(cm, binop));
+ }
+
+ if (opcode == Oglobal) {
+ TRY(compop(cm, Odupbck));
+ } else if (opcode != Oapply) {
+ TRY(compop(cm, Odup));
+ }
+
+ switch (opcode) {
+ case Olocal: case Oarg:
+ TRY(compop(cm, opcode == Olocal ? Osetloc : Osetarg));
+ TRY(compbyte(cm, idx));
+ break;
+ case Oglobal:
+ TRY(compop(cm, Osetglo));
+ break;
+ case Oapply:
+ TRY(compop(cm, Osetapp));
+ TRY(compbyte(cm, argc));
+ break;
+ }
+ } else if (binop) {
+ stashbinop(cm, binop, kind, chr);
+ }
+ return 1;
+}
+
+static bool
+expr(Comp *cm)
+{
+ cm->lvalue = 0;
+ TRY(setexpr(cm));
+ if (cm->stash_binopop) {
+ comperr(cm, cm->stash_binopchr, "unexpected operator");
+ return 0;
+ }
+ return 1;
+}
+
+static bool stmt(Comp *cm);
+
+static bool
+discard(Comp *cm)
+{
+ /*
+ * Optimization to remove sequences like { void; pop }
+ * and turn things like { dup; setloc #n; pop } into { setloc #n }
+ */
+ uint8_t *code = cm->code.at;
+ if (cm->lastop != -1 && cm->code.at[cm->lastop] == Ovoid) {
+ --cm->code.len;
+ resetlastops(cm);
+ return 1;
+ } else if (cm->lastop != -1 && cm->lastop2 != -1
+ && (code[cm->lastop2] == Odup || code[cm->lastop2] == Odupbck))
+ {
+ switch (code[cm->lastop]) {
+ case Osetloc: case Osetarg:
+ memmove(code + cm->lastop2, code + cm->lastop, 2);
+ --cm->code.len;
+ resetlastops(cm);
+ return 1;
+ case Osetglo: case Oputglo:
+ memmove(code + cm->lastop2, code + cm->lastop, 1);
+ --cm->code.len;
+ resetlastops(cm);
+ return 1;
+ }
+ }
+ return compop(cm, Opop);
+}
+
+// @local declarations
+static bool
+decl(Comp *cm, Local **pl, bool nofold)
+{
+ int c;
+ char name[NAMEMAX];
+ bool mutable;
+ uint idx = -1u;
+ Local *l;
+
+ eatspaces(cm);
+ if ((c = peekchr(cm)) != '_' && !aisalpha(c)) {
+ comperr(cm, c, "expected identifier");
+ return 0;
+ }
+ TRY(readident(cm, name, sizeof name));
+ eatspaces(cm);
+ switch ((c = nextchr(cm))) {
+ case ':': // constant
+ mutable = 0;
+ break;
+ case '=': // variable
+ mutable = 1;
+ break;
+ default:
+ comperr(cm, c, "expected ':' or '='");
+ return 0;
+ }
+
+ if (matchspchr(cm, '{')) {
+ // named fn, possibly recursive
+ TRY(l = addlocal(cm, &idx, name, mutable, cm->has_k && !mutable, cm->k));
+ TRY(lambda(cm, name));
+ } else {
+ TRY(expr(cm)); // initializer
+ if (cm->has_k && nofold) {
+ TRY(flushconst(cm));
+ }
+ TRY(l = addlocal(cm, &idx, name, mutable, cm->has_k && !mutable, cm->k));
+ }
+ if (pl) {
+ *pl = l;
+ }
+ if (!cm->has_k || mutable) {
+ if (idx > 255) {
+ comperr(cm, c, "too many locals");
+ return 0;
+ }
+ TRY(compop(cm, Odup));
+ TRY(compop(cm, Osetloc) && compbyte(cm, idx));
+ }
+ return 1;
+}
+
+static bool
+forstmt(Comp *cm)
+{
+ int b_jumpto, bf_jumpfrom, bf_arg, diff;
+ uint *ip = &cm->code.len;
+ int16_t off;
+
+ TRY(expectspchr(cm, '['));
+ if (!matchchr(cm, '@')) {
+ // FOR [cond] body
+ /*
+ * L0: <cond>
+ * bf L1
+ * <body>
+ * b L0
+ * L1: ...
+ */
+ b_jumpto = *ip;
+ TRY(expr(cm));
+
+ TRY(expectspchr(cm, ']'));
+
+ TRY(compop(cm, Obf));
+ bf_arg = *ip;
+ TRY(compbytes(cm, "X", 2));
+ bf_jumpfrom = *ip;
+
+ TRY(stmt(cm) && discard(cm));
+
+ TRY(compop(cm, Ob));
+ off = diff = b_jumpto - (*ip + 2);
+ assert(off == diff);
+ TRY(compbytes(cm, &off, 2));
+
+ off = diff = *ip - bf_jumpfrom;
+ assert(off == diff);
+ memcpy(cm->code.at + bf_arg, &off, 2);
+ } else {
+ // FOR [@x: ini][cond][cont] body
+ /*
+ * <ini>
+ * setloc #x
+ * L0: <cond>
+ * bf L1
+ * <body>
+ * <cont>
+ * setloc #x
+ * b L0
+ * L1: ...
+ *
+ * we copy the generated <cont> code to a temp buffer
+ * to move it to be after <body>
+ */
+ Local *local;
+ uint8_t tmp[256];
+ int ilocal, cont, ncont;
+
+ // ini
+ beginscope(cm);
+ TRY(decl(cm, &local, /* nofold */ 1) && discard(cm));
+ assert(local);
+ ilocal = local - cm->fenv.locals.at;
+ TRY(expectspchr(cm, ']'));
+
+ // cond
+ TRY(expectspchr(cm, '['));
+ b_jumpto = *ip;
+ if (matchspchr(cm, ']')) {
+ comperr(cm, ']', "expected operator");
+ return 0;
+ }
+ cm->stash_local = &cm->fenv.locals.at[ilocal];
+ TRY(expr(cm));
+ TRY(expectspchr(cm, ']'));
+ TRY(compop(cm, Obf));
+ bf_arg = *ip;
+ TRY(compbytes(cm, "X", 2));
+ bf_jumpfrom = *ip;
+
+ // cont
+ TRY(expectspchr(cm, '['));
+ cont = *ip;
+ if (matchspchr(cm, ']')) {
+ comperr(cm, ']', "expected operator");
+ return 0;
+ }
+ cm->stash_local = &cm->fenv.locals.at[ilocal];
+ TRY(expr(cm));
+ TRY(expectspchr(cm, ']'));
+ assert(!cm->has_k);
+ ncont = *ip - cont;
+ assert(ncont > 0 && "?");
+ assert(ncont < 256 && "cont too big");
+ memcpy(tmp, cm->code.at + cont, ncont);
+ *ip -= ncont;
+ resetlastops(cm);
+
+ // body
+ TRY(stmt(cm) && discard(cm));
+
+ // cont (2)
+ TRY(vecpush(cm->cx, &cm->code, tmp, ncont));
+ resetlastops(cm);
+ local = &cm->fenv.locals.at[ilocal];
+ TRY(compop(cm, local->isparam ? Osetarg : Osetloc));
+ assert(local->index < 256);
+ TRY(compbyte(cm, local->index));
+
+ TRY(compop(cm, Ob));
+ off = diff = b_jumpto - (*ip + 2);
+ assert(off == diff);
+ TRY(compbytes(cm, &off, 2));
+
+ off = diff = *ip - bf_jumpfrom;
+ assert(off == diff);
+ memcpy(cm->code.at + bf_arg, &off, 2);
+
+ endscope(cm);
+ }
+
+ resetlastops(cm);
+ return compop(cm, Ovoid);
+}
+static bool
+stmt(Comp *cm)
+{
+ int c;
+ if (matchspchr(cm, '@')) { // local declaration
+ TRY(decl(cm, NULL, /* nofold */ 0));
+ } else if (matchspchr(cm, '~')) { // global define
+ char name[NAMEMAX];
+ Val key;
+
+ eatspaces(cm);
+ if ((c = peekchr(cm)) != '_' && !aisalpha(c)) {
+ comperr(cm, c, "expected identifier");
+ return 0;
+ }
+ TRY(readident(cm, name, sizeof name));
+ TRY(expectspchr(cm, '='));
+ TRY(box_str(cm->cx, &key, name, strlen(name)));
+ TRY(compconst(cm, key));
+ TRY(expr(cm)); // initializer
+ TRY(compop(cm, Odupbck));
+ TRY(compop(cm, Oputglo));
+ } else if ((c = peekchr(cm)) == 'F' || c == 'R' || c == 'B') {
+ char buf[NAMEMAX];
+ TRY(readident(cm, buf, sizeof buf));
+ if (!strcmp(buf, "FOR")) {
+ return forstmt(cm);
+ } else {
+ strcpy(cm->stash_ident, buf);
+ return expr(cm);
+ }
+ } else {
+ return expr(cm);
+ }
+ return 1;
+}
+
+static bool
+block(Comp *cm, int endchr)
+{
+ bool first = 1, eof = 0;
+ beginscope(cm);
+ eatspaces(cm);
+ while (peekchr(cm) != endchr && !(eof = peekchr(cm) == EOF)) {
+ if (!first) {
+ if (cm->has_k) {
+ // just don't emit anything in this case
+ cm->has_k = 0;
+ } else {
+ // discard previous statement value
+ TRY(discard(cm));
+ }
+ }
+ first = 0;
+ TRY(stmt(cm));
+ cm->lvalue = 0;
+ eatspaces(cm);
+ }
+ if (first) {
+ TRY(compop(cm, Ovoid));
+ }
+ if (eof) {
+ comperr(cm, EOF, "unexpected end of input");
+ return 0;
+ }
+ nextchr(cm);
+ endscope(cm);
+ return 1;
+}
+
+/**************/
+/* Public API */
+/**************/
+
+bool
+pez_eval_cb(PezContext *cx, const char *fname, int (*cb)(void *), void *ud)
+{
+ Val *stktop = cx->stktop;
+ Fn *fn = newfn(cx, fname, "<eval>", /* line */ 1);
+ Comp cm;
+ if (!fn) {
+ return 0;
+ }
+ initcomp(&cm, cx, fn, cb, ud);
+
+ ETRY(block(&cm, EOF));
+ ETRY(compop(&cm, Oret));
+ fincompfn(&cm);
+
+ if (cx->dbg & DBGbytecode) {
+ inspectfn(fn);
+ }
+ ETRY(exefn(cx, fn, 0));
+
+ deinitcomp(&cm);
+ return 1;
+
+Err:
+ cx->stktop = stktop;
+ deinitcomp(&cm);
+ delfenv(cx, &cm.fenv);
+ return 0;
+}
+
+static int
+str_read_cb(void *ud)
+{
+ char **s = ud;
+ char c = **s;
+ if (c == 0) {
+ return EOF;
+ }
+ ++*s;
+ return c;
+}
+
+bool
+pez_eval_str(PezContext *cx, const char *fname, const char *str)
+{
+ assert(str);
+ return pez_eval_cb(cx, fname, str_read_cb, &str);
+}
+
+bool pez_eval_file(PezContext *cx, const char *fname, FILE *fp)
+{
+ assert(fp);
+ return pez_eval_cb(cx, fname, (int(*)(void *))fgetc, fp);
+}
+
+static void *
+mallocator(void *_ud, void *ptr, size_t _oldsize, size_t newsize)
+{
+ if (ptr && newsize == 0) {
+ free(ptr);
+ } else if (ptr && newsize > 0) {
+ return realloc(ptr, newsize);
+ } else if (!ptr && newsize > 0) {
+ return malloc(newsize);
+ }
+ return NULL;
+}
+
+#define STACK_SIZE 4096
+
+PezContext *
+pez_new(PezAllocFn *alloc, void *userdata)
+{
+ PezContext *cx;
+
+ alloc = alloc ? alloc : mallocator;
+ cx = alloc(userdata, NULL, 0, sizeof *cx);
+ if (!cx) goto Err;
+ memset(cx, 0, sizeof *cx);
+ cx->alloc = alloc;
+ cx->ud = userdata;
+ cx->stack = cxalloc(cx, STACK_SIZE * sizeof(Val));
+ if (!cx->stack) goto Err;
+ cx->stktop = cx->stack;
+ cx->stkend = cx->stack + STACK_SIZE;
+ if (!box_str(cx, &length_sstr, "length", 6)) assert(0);
+ if (!initcore(cx)) goto Err;
+
+ return cx;
+
+Err:
+ if (cx && cx->stack) {
+ cxfree(cx, cx->stack, sizeof(Val) * STACK_SIZE);
+ }
+ if (cx) {
+ cxfree(cx, cx, sizeof *cx);
+ }
+ return NULL;
+}
+
+void
+pez_del(PezContext *cx)
+{
+ assert(cx);
+ for (Obj *o = cx->heap, *next; o; o = next) {
+ next = o->next;
+ freeobj(cx, o);
+ }
+ cxfree(cx, cx->stack, STACK_SIZE * sizeof(Val));
+ if (cx->strpool.dat) {
+ cxfree(cx, cx->strpool.dat, cx->strpool.N * sizeof(Str *));
+ }
+ if (cx->globals.dat) {
+ cxfree(cx, cx->globals.dat, cx->globals.N * sizeof(struct KV));
+ }
+ cxfree(cx, cx, sizeof *cx);
+}
+
+void
+pez_debug(PezContext *cx, const char *opts)
+{
+ if (!opts) {
+ cx->dbg = 0;
+ return;
+ }
+ if (strchr(opts, 'b')) cx->dbg |= DBGbytecode;
+}
+
+int
+pez_geterrno(PezContext *cx)
+{
+ return cx->err;
+}
+
+const char *
+pez_geterr(PezContext *cx)
+{
+ switch (cx->err) {
+ case PEZ_EStack: return "stack over/under flow";
+ case PEZ_ENoMem: return "out of memory";
+ case PEZ_ESyntax: return cx->errstr;
+ case PEZ_ERuntime: return cx->errstr;
+ }
+ return NULL;
+}
+
+int
+pez_top(PezContext *cx)
+{
+ assert(cx);
+ return cx->stktop - cx->stack;
+}
+
+void
+pez_pop(PezContext *cx)
+{
+ pop(cx);
+}
+
+static inline Val *
+iget(PezContext *cx, int idx)
+{
+ if (idx < 0) {
+ idx += pez_top(cx);
+ }
+ assert(idx >= 0 && idx < pez_top(cx));
+ return &cx->stack[idx];
+}
+
+bool
+pez_push(PezContext *cx, int idx)
+{
+ Val v = *iget(cx, idx);
+ return push(cx, v);
+}
+
+bool
+pez_pushvoid(PezContext *cx)
+{
+ return push(cx, VOID);
+}
+
+bool
+pez_pushnumber(PezContext *cx, PezNumber n)
+{
+ return push(cx, box_num(n));
+}
+
+bool
+pez_pushint(PezContext *cx, int idx)
+{
+ return push(cx, box_num(inttofix(idx)));
+}
+
+bool
+pez_pushstring(PezContext *cx, const char *str, int len)
+{
+ Val s;
+ TRY(box_str(cx, &s, str, len == -1 ? strlen(str) : len));
+ return push(cx, s);
+}
+
+bool
+pez_pushglobal(PezContext *cx, const char *name)
+{
+ Val k, *g;
+ TRY(box_str(cx, &k, name, strlen(name)));
+ TRY(g = getglobal(cx, k));
+ return push(cx, *g);
+}
+
+bool
+pez_isvoid(PezContext *cx, int idx)
+{
+ return isvoid(*iget(cx, idx));
+}
+
+bool
+pez_isnumber(PezContext *cx, int idx)
+{
+ return isnum(*iget(cx, idx));
+}
+
+bool
+pez_isbool(PezContext *cx, int idx)
+{
+ return isbool(*iget(cx, idx));
+}
+
+static bool
+isobj_of1(PezContext *cx, int idx, int type)
+{
+ Val v = *iget(cx, idx);
+ return isobj_of(v, type);
+}
+
+bool
+pez_isstring(PezContext *cx, int idx)
+{
+ return isobj_of1(cx, idx, PEZ_TString) || issstr(*iget(cx, idx));
+}
+
+bool
+pez_isfunction(PezContext *cx, int idx)
+{
+ return isobj_of1(cx, idx, PEZ_TFn) || iscfn(*iget(cx, idx));
+}
+
+bool
+pez_isarray(PezContext *cx, int idx)
+{
+ return isobj_of1(cx, idx, PEZ_TArray);
+}
+
+const char *
+pez_typename(PezContext *cx, int idx)
+{
+ return typestr(*iget(cx, idx));
+}
+
+bool
+pez_getnumber(PezContext *cx, PezNumber *out, int idx)
+{
+ Val v = *iget(cx, idx);
+ *out = unbox_num(v);
+ return isnum(v);
+}
+bool
+pez_getbool(PezContext *cx, bool *out, int idx)
+{
+ Val v = *iget(cx, idx);
+ *out = unbox_bool(v);
+ return isbool(v);
+}
+
+const char *
+pez_getstring(PezContext *cx, char buf[8], int idx)
+{
+ Val v = *iget(cx, idx);
+ if (issstr(v)) {
+ unbox_sstr(v, buf);
+ return buf;
+ }
+ if (isobj_of(v, PEZ_TString)) {
+ Str *s = (Str *)unbox_obj(v);
+ return s->dat;
+ }
+ return NULL;
+}
+
+const char *
+pez_fnname(PezContext *cx, int idx)
+{
+ Val v = *iget(cx, idx);
+ if (isobj_of(v, PEZ_TFn)) {
+ Fn *fn = ((Fn *)unbox_obj(v));
+ if (fn->named) {
+ return fn->name;
+ }
+ }
+ return NULL;
+}
+
+int
+pez_length(PezContext *cx, int idx)
+{
+ Val v = *iget(cx, idx);
+ if (isobj_of(v, PEZ_TArray)) {
+ return ((Array *)unbox_obj(v))->len;
+ }
+ if (issstr(v)) {
+ return sstr_len(v);
+ }
+ if (isobj_of(v, PEZ_TString)) {
+ return ((Str *)unbox_obj(v))->n;
+ }
+ return -1;
+}
+
+void
+pez_error(PezContext *cx, const char *fn, const char *fmt, ...)
+{
+ va_list ap;
+ va_start(ap, fmt);
+ vrunerr(cx, (void *)fn, -1, fmt, ap);
+ va_end(ap);
+}
+
+bool
+pez_apply(PezContext *cx, int argc)
+{
+ Val a = *iget(cx, -argc - 1), ret;
+ assert(pez_top(cx) >= argc + 1);
+ TRY(apply(cx, &ret, NULL, -1, a, argc));
+ cx->stktop -= argc + 1;
+ return push(cx, ret);
+}
+
+bool
+pez_setapply(PezContext *cx, int argc)
+{
+ Val a = *iget(cx, -argc - 2),
+ rval = pop(cx),
+ ret;
+ assert(pez_top(cx) >= argc + 2);
+ TRY(setapply(cx, &ret, NULL, -1, a, argc, rval));
+ cx->stktop -= argc + 1;
+ return push(cx, ret);
+}
+
+bool
+pez_iget(PezContext *cx, int idx, int arg)
+{
+ TRY(pez_push(cx, idx));
+ TRY(pez_pushint(cx, arg));
+ return pez_apply(cx, 1);
+}
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-01 18:34:19 +0000