prototype polymorphic typechecking dispatch
luser- -droog
Goswell's interpreter.
This technique lets the body of the operator function
to be damned small!
Is it silly to malloc an array of enums? Perhaps they
should be bytes; to be more concrete.
It feels a little weird checking the stack top-down
rather than left-right. I may change that.
#include <stdarg.h>
#include "core.h"
enum typepat { TYPES(AS_TYPE) numbertype, floattype, anytype };
typedef struct signat {
int n;
enum typepat *t /*[n]*/;
void (*fp) ( /* arg0, ... , argN */ );
} signat;
typedef struct oper {
int n;
integer name;
signat *sig /*[n]*/;
} oper;
oper optab[200];
size noop = 0; /* no. of ops! */
/* patterns match from top of stack, downward */
object consoper (char *name, void (*fp)(), int n, ... /* enum typepat
pat0, ... , patN */) {
object nm;
int opcode;
int i;
nm = consname(name);
for (opcode=0; opcode < noop && optab[opcode].name != nm.u; opcode+
+) /*find op*/;
if (opcode == noop) {
/* initialize */
optab[opcode] = (oper) { .n = 0, .name = nm.u, .sig = NULL };
++noop;
}
optab[opcode].sig = realloc(optab[opcode].sig, ++optab[opcode].n *
sizeof(enum typepat));
{
va_list args;
va_start(args,n);
for (i = 0; i < n; i++) {
optab[opcode].sig[ optab[opcode].n-1 ] = va_arg(args, enum
typepat);
}
va_end(args);
}
}
void IIadd(object x, object y) { push(consint(x.u.i + y.u.i)); }
void IRadd(object i, object r) { push(consreal(r.u.r + i.u.i)); }
void RIadd(object r, object i) { push(consreal(r.u.r + i.u.i)); }
void RRadd(object x, object y) { push(consreal(x.u.r + y.u.r)); }
bool initops (void) {
object op = consoper("add", IIadd, 2, integertype, integertype);
object op = consoper("add", IRadd, 2, realtype, integertype);
object op = consoper("add", RIadd, 2, integertype, realtype);
object op = consoper("add", RRadd, 2, realtype, realtype);
}
void opexec (oper op) {
int i, j;
bool pass;
for (i=0; i<op.n; i++) { /* each signature */
pass = true;
for (j=0; j<op.sig[i].n; j++) { /* check types */
/* check stack element against type pattern */
if (op.sig[i].t[j] == anytype)
continue;
if (tos[-1-j].tag == op.sig[i].t[j])
continue;
if ( op.sig[i].t[j] == numbertype
&& ( tos[-1-j].tag == integertype || tos[1-j].tag ==
realtype) )
continue;
/* the floattype pattern causes automatic coercion
of integers to reals */
if ( op.sig[i].t[j] == floattype ) {
if (tos[-1-j].tag == integertype) promote(tos[-1-j]);
if (tos[-1-j].tag == realtype) continue;
}
/* all these checks failed */
pass = false;
}
if (pass) goto call;
}
error(typecheck);
call:
/* pass args bottom-up */
switch (op.sig[i].n) {
case 0: op.sig[i].fp(); break;
case 1: op.sig[i].fp(tos[-1]); break;
case 2: op.sig[i].fp(tos[-2], tos[-1]); break;
default: error(limitcheck);
}
}
/* core.h */
#define VERBOSE 1
#define _BSD_SOURCE
#define _GNU_SOURCE
#include <assert.h>
#include <stdbool.h>
#include <stdio.h>
//#include <stdint.h>
#include <stdlib.h>
#include <string.h>
#include <sys/mman.h>
#define MAXSAVE 15
#define BLOCKSIZE 1000
typedef unsigned long address;
//typedef uint32_t address;
typedef unsigned short size;
//typedef uint16_t size;
typedef unsigned char byte;
typedef bool boolean;
typedef long integer;
//typedef int32_t integer;
typedef double real;
#define AS_BARE(a) a ,
#define AS_STR(a) #a ,
/* puts(errorname[(enum err)limitcheck]); */
#define ERRORS(_) \
_(noerror) \
_(dictfull) _(dictstackoverflow) _(dictstackunderflow) \
_(execstackoverflow) _(execstackunderflow) \
_(handleerror) \
_(interrupt) \
_(invalidaccess) _(invalidexit) _(invalidfileaccess) \
_(invalidfont) _(invalidrestore) \
_(ioerror) \
_(limitcheck) \
_(nocurrentpoint) \
_(rangecheck) \
_(stackoverflow) _(stackunderflow) \
_(syntaxerror) \
_(timeout) \
_(typecheck) \
_(undefined) _(undefinedfilename) _(undefinedresult) \
_(unmatchedmark) \
_(unregistered) \
_(VMerror) \
/* puts(typename[(enum type)marktype]); */
#define AS_TYPE(a) a ## type ,
#define TYPES(_) \
_(boolean) _(integer) _(mark) _(name) _(null) _(operator) _(real)
_(save) \
_(array) _(dict) _(file) _(gstate) _(packedarray) _(string)
typedef struct flags {
union {
struct {
unsigned char lit : 1;
unsigned char read : 1;
unsigned char write : 1;
unsigned char exec : 1;
};
unsigned char allflags;
};
} flags;
typedef struct header {
flags flags;
address new, old;
} header;
typedef struct trailer {
address magic;
address head;
size sz;
} trailer;
typedef struct composite {
address a;
size off;
size n;
} composite;
typedef struct object {
byte tag;
flags flags;
union {
boolean b;
integer i;
unsigned u;
real r;
composite c;
} u;
} object;
/* ternary search tree */
typedef struct tst {
byte val;
struct tst *lo, *eq, *hi;
} tst;
/* the global interpreter state */
typedef struct state {
unsigned char *vm; /* pointer to "virtual memory" */
address vmsz; /* max memory in use */
address save[MAXSAVE];
size level;
size_t vmmax; /* max memory allocated */
tst *namet; /* search tree */
unsigned namen; /* number */
char **names; /* strings */
size_t namemax; /* size of allocated string vector */
} state;
luser- -droog
#include "core.h"
extern object os[], *tos;
void push(object o);
enum typepat { numbertype = stringtype + 1, floattype, anytype };
typedef struct signat {
void (*fp) ( /* arg0, ... , argN */ );
int n;
byte *t /*enum type&typepat t[n]*/;
} signat;
typedef struct oper {
unsigned name;
int n;
signat *sig /*[n]*/;
} oper;
extern oper optab[];
extern size noop; /* no. of ops! */
bool initops (state *st);
object consoper (state *st, char *name,
void (*fp)(), int n, ... /* enum typepat pat0, ... , patN-1
*/);
void ops_dump (state *st);
void opexec (size opcode);
object os[50], *tos = os;
void push(object o) { *tos++ = o; }
oper optab[200];
size noop = 0; /* no. of ops! */
/* patterns match from top_of_stack - n, upward */
object consoper (state *st, char *name,
void (*fp)(), int n, ... /* enum typepat pat0, ... , patN-1
*/) {
object nm;
size opcode;
int i;
unsigned sp; /* signature pointer */
nm = consname(st, name);
for (opcode=0; opcode < noop && optab[opcode].name != nm.u.u;
opcode++) /*find op*/;
if (opcode == noop) {
/* initialize */
optab[opcode] = (oper) { .n = 0, .name = nm.u.u, .sig =
NULL };
/* optab[opcode].n = 0; optab[opcode].name = nm.u; */
++noop;
}
optab[opcode].sig = realloc(optab[opcode].sig, ++optab[opcode].n *
sizeof(signat));
sp = optab[opcode].n - 1;
optab[opcode].sig[ sp ].t = malloc(n);
{
va_list args;
va_start(args,n);
for (i = 0; i < n; i++) {
optab[opcode].sig[ sp ].t[i] = va_arg(args, int);
}
va_end(args);
optab[opcode].sig[ sp ].n = n;
optab[opcode].sig[ sp ].fp = fp;
}
return (object) { .tag = operatortype, .u.u = opcode };
}
void ops_dump (state *st) {
int i,j,k;
printf("installed operator signatures:\n");
for (i=0; i<noop; i++) {
for (j=0; j<optab[i].n; j++) {
for (k=0; k<optab[i].sig[j].n; k++) {
printf("%s ", typename[optab[i].sig[j].t[k]]);
}
printf("--%s--\n", st->names[ optab[i].name ]);
}
}
}
#define promote(o) ((o).tag = realtype, (o).u.r = (o).u.i)
void opexec (size opcode) {
oper op = optab[opcode];
int i, j;
bool pass;
object *siq; /* stack-segment in question */
for (i=0; i<op.n; i++) { /* each signature */
pass = true;
siq = tos-op.sig[i].n;
for (j=0; j<op.sig[i].n; j++) { /* check types */
/* anytype matches anything */
if (op.sig[i].t[j] == anytype)
continue;
/* exact match */
if (siq[j].tag == op.sig[i].t[j])
continue;
/* the numbertype pattern matches integers or reals */
if ( op.sig[i].t[j] == numbertype
&& ( siq[j].tag == integertype
|| siq[j].tag == realtype) )
continue;
/* the floattype pattern causes automatic coercion
of integers to reals */
if ( op.sig[i].t[j] == floattype ) {
if (siq[j].tag == integertype) promote(siq[j]);
if (siq[j].tag == realtype) continue;
}
/* all these possibilities failed */
pass = false;
break;
}
if (pass) goto call;
}
error(typecheck);
call:
/* pass args bottom-up */
tos = siq;
switch (op.sig[i].n) {
case 0: op.sig[i].fp(); break;
case 1: op.sig[i].fp(siq[0]); break;
case 2: op.sig[i].fp(siq[0], siq[1]); break;
case 3: op.sig[i].fp(siq[0], siq[1], siq[2]); break;
case 4: op.sig[i].fp(siq[0], siq[1], siq[2], siq[3]); break;
case 5: op.sig[i].fp(siq[0], siq[1], siq[2], siq[3], siq[4]);
break;
case 6: op.sig[i].fp(siq[0], siq[1], siq[2], siq[3], siq[4],
siq[5]); break;
default: error(limitcheck);
}
}
void IIadd(object x, object y) { push(consint(x.u.i + y.u.i)); }
void IRadd(object x, object y) { push(consreal((real)x.u.i +
y.u.r)); }
void RIadd(object x, object y) { push(consreal(x.u.r + y.u.i)); }
void RRadd(object x, object y) { push(consreal(x.u.r + y.u.r)); }
void IIsub(object x, object y) { push(consint(x.u.i - y.u.i)); }
void IRsub(object x, object y) { push(consreal((real)x.u.i -
y.u.r)); }
void RIsub(object x, object y) { push(consreal(x.u.r - y.u.i)); }
void RRsub(object x, object y) { push(consreal(x.u.r - y.u.r)); }
bool initops (state *st) {
object op;
op = consoper(st, "add", IIadd, 2, (int)integertype,
(int)integertype);
op = consoper(st, "add", IRadd, 2, (int)integertype,
(int)realtype);
op = consoper(st, "add", RIadd, 2, (int)realtype,
(int)integertype);
op = consoper(st, "add", RRadd, 2, (int)realtype, (int)realtype);
op = consoper(st, "sub", IIsub, 2, (int)integertype,
(int)integertype);
op = consoper(st, "sub", IRsub, 2, (int)integertype,
(int)realtype);
op = consoper(st, "sub", RIsub, 2, (int)realtype,
(int)integertype);
op = consoper(st, "sub", RRsub, 2, (int)realtype, (int)realtype);
return true;
}
testing section from main:
if (1) { /* test operators */
ops_dump(st);
push(consint(20));
push(consreal(100));
opexec(0); /* add */
o_dump(st, tos[-1]);
}
output produced:
installing new name add as 1
resizing name table
installing new name sub as 2
installed operator signatures:
integer integer --add--
integer real --add--
real integer --add--
real real --add--
integer integer --sub--
integer real --sub--
real integer --sub--
real real --sub--
<real 0:X--- 120.000000>
the integer 20 plus the floating-point number 100
does indeed equal 120. yay!