mirror of
https://github.com/false-schemers/skint.git
synced 2024-12-25 21:58:54 +01:00
new integrable model, part 1
This commit is contained in:
dermagen
parent
98217de003
commit
cbb8eed040
3 changed files with 185 additions and 17 deletions
3
.gitignore
vendored
3
.gitignore
vendored
|
|
@ -50,3 +50,6 @@ modules.order
|
|||
Module.symvers
|
||||
Mkfile.old
|
||||
dkms.conf
|
||||
|
||||
save/
|
||||
.vs/
|
||||
|
|
|
|||
194
i.c
194
i.c
|
|
@ -13,6 +13,11 @@ extern obj cx_callmv_2Dadapter_2Dclosure;
|
|||
|
||||
/* forwards */
|
||||
static struct intgtab_entry *intgtab_find_encoding(int sym, int arity);
|
||||
static struct intgtab_entry *lookup_integrable(int sym);
|
||||
static int isintegrable(obj x);
|
||||
static int integrable_type(struct intgtab_entry *pi);
|
||||
static const char *integrable_global(struct intgtab_entry *pi);
|
||||
static const char *integrable_code(struct intgtab_entry *pi, int n);
|
||||
static void wrs_integrable(int argc, struct intgtab_entry *pe, obj port);
|
||||
static obj *rds_intgtab(obj *r, obj *sp, obj *hp);
|
||||
static obj *rds_stox(obj *r, obj *sp, obj *hp);
|
||||
|
|
@ -181,9 +186,11 @@ typedef obj* regcall (*ins_t)(IPARAMS);
|
|||
#endif
|
||||
|
||||
static obj vmhost(obj);
|
||||
obj vmcases[8] = {
|
||||
obj vmcases[13] = {
|
||||
(obj)vmhost, (obj)vmhost, (obj)vmhost, (obj)vmhost,
|
||||
(obj)vmhost, (obj)vmhost, (obj)vmhost, (obj)vmhost
|
||||
(obj)vmhost, (obj)vmhost, (obj)vmhost, (obj)vmhost,
|
||||
(obj)vmhost, (obj)vmhost, (obj)vmhost, (obj)vmhost,
|
||||
(obj)vmhost
|
||||
};
|
||||
/* vmhost procedure */
|
||||
static obj vmhost(obj pc)
|
||||
|
|
@ -311,6 +318,64 @@ jump:
|
|||
pc = objptr_from_obj(r[0])[0];
|
||||
rc = 3;
|
||||
goto jump; }
|
||||
|
||||
case 8: /* integrable? */
|
||||
/* r[0] = clo, r[1] = k, r[2] = obj */
|
||||
{ assert(rc == 3);
|
||||
r[2] = obj_from_bool(isintegrable(r[2]));
|
||||
r[0] = r[1]; r[1] = obj_from_ktrap();
|
||||
pc = objptr_from_obj(r[0])[0];
|
||||
rc = 3;
|
||||
goto jump; }
|
||||
|
||||
case 9: /* lookup-integrable */
|
||||
/* r[0] = clo, r[1] = k, r[2] = id */
|
||||
{ assert(rc == 3);
|
||||
if (issymbol(r[2])) {
|
||||
int sym = getsymbol(r[2]);
|
||||
struct intgtab_entry *pe = lookup_integrable(sym);
|
||||
r[2] = pe ? (obj)pe : obj_from_bool(0);
|
||||
} else r[2] = obj_from_bool(0);
|
||||
r[0] = r[1]; r[1] = obj_from_ktrap();
|
||||
pc = objptr_from_obj(r[0])[0];
|
||||
rc = 3;
|
||||
goto jump; }
|
||||
|
||||
case 10: /* integrable-type */
|
||||
/* r[0] = clo, r[1] = k, r[2] = ig */
|
||||
{ assert(rc == 3);
|
||||
if (isintegrable(r[2])) {
|
||||
int it = integrable_type((struct intgtab_entry *)(r[2]));
|
||||
r[2] = it ? obj_from_char(it) : obj_from_bool(0);
|
||||
} else r[2] = obj_from_bool(0);
|
||||
r[0] = r[1]; r[1] = obj_from_ktrap();
|
||||
pc = objptr_from_obj(r[0])[0];
|
||||
rc = 3;
|
||||
goto jump; }
|
||||
|
||||
case 11: /* integrable-global */
|
||||
/* r[0] = clo, r[1] = k, r[2] = ig */
|
||||
{ assert(rc == 3);
|
||||
if (isintegrable(r[2])) {
|
||||
const char *igs = integrable_global((struct intgtab_entry *)(r[2]));
|
||||
r[2] = igs ? mksymbol(internsym((char*)igs)) : obj_from_bool(0);
|
||||
} else r[2] = obj_from_bool(0);
|
||||
r[0] = r[1]; r[1] = obj_from_ktrap();
|
||||
pc = objptr_from_obj(r[0])[0];
|
||||
rc = 3;
|
||||
goto jump; }
|
||||
|
||||
case 12: /* integrable-code */
|
||||
/* r[0] = clo, r[1] = k, r[2] = ig, r[3] = i */
|
||||
{ assert(rc == 4);
|
||||
if (isintegrable(r[2]) && is_fixnum_obj(r[3])) {
|
||||
const char *cs = integrable_code((struct intgtab_entry *)(r[2]), fixnum_from_obj(r[3]));
|
||||
r[2] = cs ? hpushstr(3, newstring((char*)cs)) : obj_from_bool(0);
|
||||
} else r[2] = obj_from_bool(0);
|
||||
r[0] = r[1]; r[1] = obj_from_ktrap();
|
||||
pc = objptr_from_obj(r[0])[0];
|
||||
rc = 3;
|
||||
goto jump; }
|
||||
|
||||
default: /* inter-host call */
|
||||
cxg_hp = hp;
|
||||
|
|
@ -369,6 +434,8 @@ define_instrhelper(cxi_failactype) {
|
|||
{ ac = _x; spush((obj)"procedure"); musttail return cxi_failactype(IARGS); } } while (0)
|
||||
#define ckz(x) do { obj _x = (x); if (unlikely(!isbox(_x))) \
|
||||
{ ac = _x; spush((obj)"box, cell, or promise"); musttail return cxi_failactype(IARGS); } } while (0)
|
||||
#define ckg(x) do { obj _x = (x); if (unlikely(!isintegrable(_x))) \
|
||||
{ ac = _x; spush((obj)"integrable entry"); musttail return cxi_failactype(IARGS); } } while (0)
|
||||
|
||||
|
||||
define_instruction(halt) { unwindi(0); }
|
||||
|
|
@ -2401,6 +2468,42 @@ define_instruction(fenc) {
|
|||
gonexti();
|
||||
}
|
||||
|
||||
|
||||
define_instruction(igp) {
|
||||
ac = obj_from_bool(isintegrable(ac));
|
||||
gonexti();
|
||||
}
|
||||
|
||||
define_instruction(iglk) {
|
||||
struct intgtab_entry *pe; cky(ac);
|
||||
pe = lookup_integrable(getsymbol(ac));
|
||||
ac = pe ? (obj)pe : obj_from_bool(0);
|
||||
gonexti();
|
||||
}
|
||||
|
||||
define_instruction(igty) {
|
||||
int it; ckg(ac);
|
||||
it = integrable_type((struct intgtab_entry *)ac);
|
||||
ac = it ? obj_from_char(it) : obj_from_bool(0);
|
||||
gonexti();
|
||||
}
|
||||
|
||||
define_instruction(iggl) {
|
||||
const char *igs; ckg(ac);
|
||||
igs = integrable_global((struct intgtab_entry *)ac);
|
||||
ac = igs ? mksymbol(internsym((char*)igs)) : obj_from_bool(0);
|
||||
gonexti();
|
||||
}
|
||||
|
||||
define_instruction(igco) {
|
||||
int n; const char *cs; ckg(ac); ckk(sref(0));
|
||||
n = fixnum_from_obj(spop());
|
||||
cs = integrable_code((struct intgtab_entry *)ac, n);
|
||||
ac = cs ? hpushstr(sp-r, newstring((char*)cs)) : obj_from_bool(0);
|
||||
gonexti();
|
||||
}
|
||||
|
||||
|
||||
define_instruction(wrsi) {
|
||||
obj c = ac, e = spop(), p = spop(); cki(c);
|
||||
assert(isaptr(e) && notobjptr(e) && isoport(p));
|
||||
|
|
@ -2740,9 +2843,9 @@ define_instruction(pushsub) {
|
|||
#undef VM_GEN_DEFGLOBAL
|
||||
|
||||
/* integrables table */
|
||||
struct intgtab_entry { int sym; char *igname; int arity; char *enc; char *lcode; };
|
||||
#define declare_intgtable_entry(enc, igname, arity, lcode) \
|
||||
{ 0, igname, arity, enc, lcode },
|
||||
struct intgtab_entry { int sym; char *igname; int igtype; char *enc; char *lcode; };
|
||||
#define declare_intgtable_entry(enc, igname, igtype, lcode) \
|
||||
{ 0, igname, igtype, enc, lcode },
|
||||
|
||||
static struct intgtab_entry intgtab[] = {
|
||||
#define VM_GEN_INTGTABLE
|
||||
|
|
@ -2753,12 +2856,15 @@ static struct intgtab_entry intgtab[] = {
|
|||
static int intgtab_sorted = 0;
|
||||
static int intgtab_cmp(const void *p1, const void *p2)
|
||||
{
|
||||
int igtype1, igtype2;
|
||||
struct intgtab_entry *pe1 = (struct intgtab_entry *)p1;
|
||||
struct intgtab_entry *pe2 = (struct intgtab_entry *)p2;
|
||||
if (pe1->sym < pe2->sym) return -1;
|
||||
if (pe1->sym > pe2->sym) return 1;
|
||||
if (pe1->arity < pe2->arity) return -1;
|
||||
if (pe1->arity > pe2->arity) return 1;
|
||||
igtype1 = pe1->igtype; if (igtype1 >= ' ') igtype1 = ' ';
|
||||
igtype2 = pe2->igtype; if (igtype2 >= ' ') igtype2 = ' ';
|
||||
if (igtype1 < igtype2) return -1;
|
||||
if (igtype1 > igtype2) return 1;
|
||||
return 0;
|
||||
}
|
||||
|
||||
|
|
@ -2780,10 +2886,64 @@ static struct intgtab_entry *intgtab_find_encoding(int sym, int arity)
|
|||
struct intgtab_entry e, *pe;
|
||||
int n = sizeof(intgtab)/sizeof(intgtab[0]);
|
||||
if (!intgtab_sorted) sort_intgtab(n);
|
||||
e.sym = sym; e.arity = arity;
|
||||
e.sym = sym; e.igtype = arity;
|
||||
pe = bsearch(&e, &intgtab[0], n, sizeof(intgtab[0]), intgtab_cmp);
|
||||
if (!pe) { e.arity = -1; pe = bsearch(&e, &intgtab[0], n, sizeof(intgtab[0]), intgtab_cmp); }
|
||||
return (pe && pe->enc) ? pe : NULL;
|
||||
if (!pe) { e.igtype = -1; pe = bsearch(&e, &intgtab[0], n, sizeof(intgtab[0]), intgtab_cmp); }
|
||||
return (pe && pe->igtype < ' ' && pe->enc) ? pe : NULL;
|
||||
}
|
||||
|
||||
static int isintegrable(obj x)
|
||||
{
|
||||
int n = sizeof(intgtab)/sizeof(intgtab[0]);
|
||||
struct intgtab_entry *ps = intgtab, *pe = ps + n;
|
||||
return isaptr(x)
|
||||
&& (struct intgtab_entry *)x >= ps
|
||||
&& (struct intgtab_entry *)x < pe
|
||||
&& ((struct intgtab_entry *)x - ps) % sizeof(intgtab[0]) == 0;
|
||||
}
|
||||
|
||||
static struct intgtab_entry *lookup_integrable(int sym)
|
||||
{
|
||||
struct intgtab_entry e, *pe;
|
||||
int n = sizeof(intgtab)/sizeof(intgtab[0]);
|
||||
if (!intgtab_sorted) sort_intgtab(n);
|
||||
e.sym = sym; e.igtype = ' ';
|
||||
pe = bsearch(&e, &intgtab[0], n, sizeof(intgtab[0]), intgtab_cmp);
|
||||
return (pe && pe->igtype >= ' ' && pe->igname && pe->enc) ? pe : NULL;
|
||||
}
|
||||
|
||||
static int integrable_type(struct intgtab_entry *pi)
|
||||
{
|
||||
int it = pi->igtype;
|
||||
return (it >= ' ') ? it : 0;
|
||||
}
|
||||
|
||||
static const char *integrable_global(struct intgtab_entry *pi)
|
||||
{
|
||||
return (pi->igtype >= ' ') ? pi->igname : NULL;
|
||||
}
|
||||
|
||||
static const char *integrable_code(struct intgtab_entry *pi, int n)
|
||||
{
|
||||
static char buf[60]; char *ps, *code = NULL;
|
||||
int it = pi->igtype;
|
||||
if (it >= ' ') {
|
||||
ps = pi->enc;
|
||||
while (ps && n-- > 0) {
|
||||
ps = strchr(ps, '\t');
|
||||
if (ps) ps += 1;
|
||||
}
|
||||
if (ps) {
|
||||
code = ps; ps = strchr(ps, '\t');
|
||||
if (ps) {
|
||||
assert(ps-code < sizeof(buf));
|
||||
strncpy(buf, code, ps-code);
|
||||
buf[ps-code] = 0;
|
||||
code = buf;
|
||||
}
|
||||
}
|
||||
}
|
||||
return code;
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -2802,9 +2962,9 @@ static void wrs_int_arg(int arg, obj port)
|
|||
static void wrs_integrable(int argc, struct intgtab_entry *pe, obj port)
|
||||
{
|
||||
assert(pe); assert(pe->enc);
|
||||
if (pe->arity == -1 && argc > 0) oportputc(',', port);
|
||||
if (pe->igtype == -1 && argc > 0) oportputc(',', port);
|
||||
oportputs(pe->enc, port);
|
||||
if (pe->arity == -1) wrs_int_arg(argc, port);
|
||||
if (pe->igtype == -1) wrs_int_arg(argc, port);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -3298,20 +3458,20 @@ static obj *rds_intgtab(obj *r, obj *sp, obj *hp)
|
|||
struct intgtab_entry *pe = &intgtab[i];
|
||||
if (!pe->igname) continue;
|
||||
lcode = pe->lcode;
|
||||
if (!lcode) switch (pe->arity) {
|
||||
case 0:
|
||||
if (!lcode) switch (pe->igtype) {
|
||||
case 0: case '0':
|
||||
lcode = lbuf; assert(pe->enc);
|
||||
sprintf(lbuf, "%%0%s]0", pe->enc);
|
||||
break;
|
||||
case 1:
|
||||
case 1: case '1':
|
||||
lcode = lbuf; assert(pe->enc);
|
||||
sprintf(lbuf, "%%1_!%s]0", pe->enc); // "%%1.0%s]1"
|
||||
break;
|
||||
case 2:
|
||||
case 2: case '2':
|
||||
lcode = lbuf; assert(pe->enc);
|
||||
sprintf(lbuf, "%%2_!%s]0", pe->enc); // %%2.1,.1%s]2
|
||||
break;
|
||||
case 3:
|
||||
case 3: case '3':
|
||||
lcode = lbuf; assert(pe->enc);
|
||||
sprintf(lbuf, "%%3_!%s]0", pe->enc); // %%3.2,.2,.2%s]3
|
||||
break;
|
||||
|
|
|
|||
5
i.h
5
i.h
|
|
@ -456,10 +456,15 @@ declare_instruction(wrhw, "W7", 0, "%wrhw", 2, INLINED)
|
|||
declare_instruction(wriw, "W8", 0, "%wriw", 2, INLINED)
|
||||
|
||||
/* serialization and deserialization instructions */
|
||||
declare_instruction(igp, "U0", 0, "integrable?", 1, AUTOGL)
|
||||
declare_instruction(fenc, "U1", 0, "find-integrable-encoding", 2, AUTOGL)
|
||||
declare_instruction(wrsi, "U2", 0, "encode-integrable", 3, AUTOGL)
|
||||
declare_instruction(rdsx, "U3", 0, "deserialize-sexp", 1, AUTOGL)
|
||||
declare_instruction(rdsc, "U4", 0, "deserialize-code", 1, AUTOGL)
|
||||
declare_instruction(iglk, "U5", 0, "lookup-integrable", 1, AUTOGL)
|
||||
declare_instruction(igty, "U6", 0, "integrable-type", 1, AUTOGL)
|
||||
declare_instruction(iggl, "U7", 0, "integrable-global", 1, AUTOGL)
|
||||
declare_instruction(igco, "U8", 0, "integrable-code", 2, AUTOGL)
|
||||
|
||||
/* inlined integrables (no custom instructions) */
|
||||
declare_integrable(NULL, "aaa", 0, "%caaar", 1, INLINED)
|
||||
|
|
|
|||
Loading…
Reference in a new issue