summaryrefslogtreecommitdiff
path: root/pez.c
diff options
context:
space:
mode:
Diffstat (limited to 'pez.c')
-rw-r--r--pez.c158
1 files changed, 132 insertions, 26 deletions
diff --git a/pez.c b/pez.c
index 34a0e76..84d24c9 100644
--- a/pez.c
+++ b/pez.c
@@ -98,6 +98,11 @@ typedef struct Fn {
Upval *upval[];
} Fn;
+typedef struct Dilambda {
+ OBJHEADER;
+ Fn *getf, *setf;
+} Dilambda;
+
typedef struct Local Local;
enum { NAMEMAX = 80 };
@@ -233,12 +238,13 @@ typestr(Val 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";
- case PEZ_TFnProto: return "(function prototype)";
+ 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";
+ case PEZ_TFnProto: return "(function prototype)";
+ case PEZ_TDilambda: return "dilambda";
}
}
if (isnum(v))
@@ -728,6 +734,18 @@ delstring(PezContext *cx, Str *str)
--cx->strpool.count;
}
+static Dilambda *
+newdilambda(PezContext *cx, Fn *getf, Fn *setf)
+{
+ Dilambda *dl = newobj(cx, PEZ_TDilambda, sizeof *dl);
+ assert(setf->proto->nparams >= 1);
+ if (dl) {
+ dl->getf = getf;
+ dl->setf = setf;
+ }
+ return dl;
+}
+
/******/
/* GC */
/******/
@@ -756,6 +774,9 @@ delobj(PezContext *cx, Obj *o)
case PEZ_TUpval:
sz = sizeof(Upval);
break;
+ case PEZ_TDilambda:
+ sz = sizeof(Dilambda);
+ break;
}
assert(sz);
cxfree(cx, o, sz);
@@ -795,6 +816,13 @@ markarray(PezContext *cx, Array *arr)
}
static void
+markdilambda(PezContext *cx, Dilambda *dl)
+{
+ gcmark(cx, (Obj *)dl->getf);
+ gcmark(cx, (Obj *)dl->setf);
+}
+
+static void
gcmark(PezContext *cx, Obj *o)
{
assert(cx->gccanrun);
@@ -815,6 +843,9 @@ gcmark(PezContext *cx, Obj *o)
case PEZ_TArray:
markarray(cx, (Array *)o);
break;
+ case PEZ_TDilambda:
+ markdilambda(cx, (Dilambda *)o);
+ break;
}
}
@@ -826,6 +857,8 @@ gc(PezContext *cx)
fprintf(stderr, "--- GC running with %d bytes allocated\n",
nalloc);
}
+
+ /* mark roots */
for (Val *stk = cx->stack; stk != cx->stktop; ++stk) {
if (isobj(*stk)) {
gcmark(cx, unbox_obj(*stk));
@@ -844,6 +877,8 @@ gc(PezContext *cx)
}
}
}
+
+ /* sweep */
for (Obj *o = cx->heap, *next, *prev = NULL; o; o = next) {
next = o->next;
if (o->gc) {
@@ -1255,6 +1290,15 @@ apply(PezContext *cx, Val *ret, void *srcfn, int srcpc, Val recv, uint n)
assert(cx->stktop > cx->stack);
*ret = *peek(cx);
cx->stktop = stktop;
+ } else if (isobj_of(recv, PEZ_TDilambda)) {
+ Fn *getf = ((Dilambda *)unbox_obj(recv))->getf;
+ if (getf->proto->variadic ? n < getf->proto->nparams : n != getf->proto->nparams) {
+ runerr(cx, srcfn, srcpc, "dilambda getter takes %d arg(s), %d %s given",
+ getf->proto->nparams, n, n == 1 ? "was" : "were");
+ return 0;
+ }
+ TRY(exefn(cx, getf, n));
+ *ret = pop(cx);
} else if (isobj_of(recv, PEZ_TArray)) {
Array *arr = unbox_obj(recv);
if (n != 1) {
@@ -1305,6 +1349,19 @@ setapply(PezContext *cx, Val *ret, void *srcfn, int srcpc, Val recv, uint n, Val
if (isobj_of(recv, PEZ_TFn) || iscfn(recv)) {
runerr(cx, srcfn, srcpc, "procedure has no setter");
return 0;
+ } else if (isobj_of(recv, PEZ_TDilambda)) {
+ Fn *setf = ((Dilambda *)unbox_obj(recv))->setf;
+ int nparams = setf->proto->nparams - 1;
+ assert(setf->proto->nparams >= 0);
+ if (setf->proto->variadic ? n < nparams : n != nparams) {
+ runerr(cx, srcfn, srcpc, "dilambda setter takes %d arg(s), %d %s given",
+ nparams, n, n == 1 ? "was" : "were");
+ return 0;
+ }
+ TRY(push(cx, rval));
+ TRY(exefn(cx, setf, n + 1));
+ *ret = pop(cx);
+ pop(cx);
} else if (isobj_of(recv, PEZ_TArray)) {
Array *arr = unbox_obj(recv);
if (n != 1) {
@@ -1322,7 +1379,7 @@ setapply(PezContext *cx, Val *ret, void *srcfn, int srcpc, Val recv, uint n, Val
runerr(cx, srcfn, srcpc, "cannot mutate string");
return 0;
} else {
- runerr(cx, srcfn, srcpc, "%s value is not applicable", typestr(recv));
+ runerr(cx, srcfn, srcpc, "%s value is not settable", typestr(recv));
return 0;
}
return 1;
@@ -1780,6 +1837,8 @@ xprint1(PezContext *cx, struct vals *seen,
} else {
TRY(cb(cx, u, "#<function>", 11));
}
+ } else if (isobj_of(v, PEZ_TDilambda)) {
+ TRY(cb(cx, u, "#<dilambda>", 12));
} else if (isobj_of(v, PEZ_TArray)) {
Array *arr = unbox_obj(v);
bool ok = 1;
@@ -1895,9 +1954,54 @@ Err:
return 0;
}
+static bool
+f_dilambda(PezContext *cx, int argc)
+{
+ Dilambda *dl;
+ if (argc != 2) {
+ pez_error(cx, "dilambda", "expected two arguments");
+ return 0;
+ }
+ if (!isobj_of(cx->stktop[-2], PEZ_TFn) || !isobj_of(cx->stktop[-1], PEZ_TFn)) {
+ pez_error(cx, "dilambda", "expected two function arguments");
+ return 0;
+ }
+ if (((Fn *)unbox_obj(cx->stktop[-1]))->proto->nparams < 1) {
+ pez_error(cx, "dilambda", "setter should take at least one argument");
+ return 0;
+ }
+ TRY(dl = newdilambda(cx, unbox_obj(cx->stktop[-2]), unbox_obj(cx->stktop[-1])));
+ TRY(push(cx, box_obj(dl)));
+ return 1;
+}
+
+static bool
+f_arrayfill(PezContext *cx, int argc)
+{
+ fixnum n;
+ Array *arr;
+ if (argc != 2) {
+ pez_error(cx, "array#fill", "expected two arguments");
+ return 0;
+ }
+ n = unbox_num(cx->stktop[-2]);
+ if (!isnum(cx->stktop[-2]) || n < 0 || fixtrunc(n) != n) {
+ pez_error(cx, "array#fill", "argument #1 should be positive integer");
+ return 0;
+ }
+ TRY(arr = newarr(cx, fixtoint(n)));
+ arr->len = fixtoint(n);
+ for (int i = 0; i < fixtoint(n); ++i) {
+ arr->at[i] = cx->stktop[-1];
+ }
+ return push(cx, box_obj(arr));
+}
+
static const struct coredef { const char *n; PezCFn *f; } core[] = {
{ "printf", f_printf },
- { "sprintf", f_sprintf }
+ { "sprintf", f_sprintf },
+ { "dilambda", f_dilambda },
+ { "array#fill", f_arrayfill },
};
static bool
@@ -2160,7 +2264,7 @@ addupval(Comp *cm, struct fenv *fenv, uint8_t idx, bool arg, bool local)
struct cmupval up = { idx, arg, local };
for (int i = 0; i < fenv->nupval; ++i) {
struct cmupval *up = &fenv->upvals[i];
- if (up->idx == idx && up->local == local) {
+ if (up->idx == idx && up->local == local && up->arg == arg) {
return up->idx;
}
}
@@ -2204,7 +2308,7 @@ endscope(Comp *cm)
} else {
if (!l->has_k) {
--cm->fenv.nvars;
- if (l->mutable && l->scope > 0 && l->captured) {
+ if (l->scope > 0 && l->captured) {
TRY(compop(cm, Oclose) && compbyte(cm, l->index));
}
}
@@ -2974,7 +3078,7 @@ Bail:
static bool
binexpr(Comp *cm, char okind, bool (*prev)(Comp *))
{
- uint save = cm->code.len, save2, save3;
+ uint save = cm->code.len;
char kind, chr;
enum op op, op2;
TRY(prev(cm));
@@ -2990,10 +3094,25 @@ binexpr(Comp *cm, char okind, bool (*prev)(Comp *))
int imm;
enum op opx = op;
+ if (has_lk && isimm(&imm, lk) && commutate(&opx)) {
+ // when lhs is a constant and the operation can be
+ // commutative try use immediate op
+ cm->has_k = 0;
+ TRY(prev(cm));
+ if (cm->has_k && (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 {
+ goto TryImm;
+ }
+ }
+
TRY(flushconst(cm));
- save2 = cm->code.len;
+ has_lk = 0;
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
@@ -3004,19 +3123,6 @@ binexpr(Comp *cm, char okind, bool (*prev)(Comp *))
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 (uint 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:
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-01 18:46:38 +0000