mirror of
https://github.com/false-schemers/skint.git
synced 2024-12-25 21:58:54 +01:00
define-record-type, records added
This commit is contained in:
ESL
parent
d08bddc4c9
commit
149827f452
8 changed files with 3127 additions and 2625 deletions
182
i.c
182
i.c
|
|
@ -180,7 +180,7 @@ static void _sck(obj *s) {
|
|||
#define is_char(o) is_char_obj(o)
|
||||
#define get_char(o) char_from_obj(o)
|
||||
#define void_obj() obj_from_void(0)
|
||||
#define is_void(o) is_void_obj(o)
|
||||
#define is_void(o) (o == obj_from_void(0))
|
||||
#define null_obj() mknull()
|
||||
#define is_null(o) isnull(o)
|
||||
#define eof_obj() mkeof()
|
||||
|
|
@ -204,10 +204,16 @@ static void _sck(obj *s) {
|
|||
#define is_circular(o) iscircular(o)
|
||||
#define is_noncircular(o) (!iscircular(o))
|
||||
#define is_vector(o) isvector(o)
|
||||
#define vector_len(o) vectorlen(o)
|
||||
#define vector_ref(o, i) vectorref(o, i)
|
||||
#define string_obj(s) hp_pushptr((s), STRING_NTAG)
|
||||
#define is_string(o) isstring(o)
|
||||
#define string_len(o) stringlen(o)
|
||||
#define string_ref(o, i) (*stringref(o, i))
|
||||
#define bytevector_obj(s) hp_pushptr((s), BYTEVECTOR_NTAG)
|
||||
#define is_bytevector(o) isbytevector(o)
|
||||
#define bytevector_len(o) bytevectorlen(o)
|
||||
#define bytevector_ref(o, i) (*bytevectorref(o, i))
|
||||
#define iport_file_obj(fp) hp_pushptr((fp), IPORT_FILE_NTAG)
|
||||
#define oport_file_obj(fp) hp_pushptr((fp), OPORT_FILE_NTAG)
|
||||
#define iport_string_obj(fp) hp_pushptr((fp), IPORT_STRING_NTAG)
|
||||
|
|
@ -217,12 +223,13 @@ static void _sck(obj *s) {
|
|||
#define is_iport(o) isiport(o)
|
||||
#define is_oport(o) isoport(o)
|
||||
#define is_box(o) isbox(o)
|
||||
#define box_ref(o) boxref(o)
|
||||
#define is_proc(o) isvmclo(o)
|
||||
#define is_tuple(o) (isrecord(o) && recordrtd(o) == 0)
|
||||
#define is_record(o) (isrecord(o) && recordrtd(o) != 0)
|
||||
#define record_rtd(o) recordrtd(o)
|
||||
#define record_len(o) recordlen(o)
|
||||
#define record_ref(o) recordref(o)
|
||||
#define record_ref(o, i) recordref(o, i)
|
||||
|
||||
|
||||
/* cxi instructions protocol; retval is new hp: */
|
||||
|
|
@ -561,12 +568,12 @@ define_instruction(gref) {
|
|||
}
|
||||
|
||||
define_instruction(iref) {
|
||||
ac = boxref(ac);
|
||||
ac = box_ref(ac);
|
||||
gonexti();
|
||||
}
|
||||
|
||||
define_instruction(iset) {
|
||||
boxref(ac) = spop();
|
||||
box_ref(ac) = spop();
|
||||
gonexti();
|
||||
}
|
||||
|
||||
|
|
@ -618,13 +625,13 @@ define_instruction(andbo) {
|
|||
|
||||
define_instruction(sseti) {
|
||||
int i = get_fixnum(*ip++);
|
||||
boxref(sref(i)) = ac;
|
||||
box_ref(sref(i)) = ac;
|
||||
gonexti();
|
||||
}
|
||||
|
||||
define_instruction(dseti) {
|
||||
int i = get_fixnum(*ip++);
|
||||
boxref(dref(i)) = ac;
|
||||
box_ref(dref(i)) = ac;
|
||||
gonexti();
|
||||
}
|
||||
|
||||
|
|
@ -791,7 +798,7 @@ define_instruction(rck) {
|
|||
define_instruction(save) {
|
||||
int dx = get_fixnum(*ip++);
|
||||
spush(rd);
|
||||
spush(fixnum_obj(ip + dx - &vectorref(vmcloref(rd, 0), 0)));
|
||||
spush(fixnum_obj(ip + dx - &vector_ref(vmcloref(rd, 0), 0)));
|
||||
gonexti();
|
||||
}
|
||||
|
||||
|
|
@ -950,8 +957,17 @@ define_instruction(ise) {
|
|||
gonexti();
|
||||
}
|
||||
|
||||
define_instruction(unbox) { ckz(ac); ac = boxref(ac); gonexti(); }
|
||||
define_instruction(setbox) { ckz(ac); boxref(ac) = spop(); gonexti(); }
|
||||
define_instruction(unbox) {
|
||||
ckz(ac);
|
||||
ac = box_ref(ac);
|
||||
gonexti();
|
||||
}
|
||||
|
||||
define_instruction(setbox) {
|
||||
ckz(ac);
|
||||
box_ref(ac) = spop();
|
||||
gonexti();
|
||||
}
|
||||
|
||||
define_instruction(box) {
|
||||
hp_reserve(boxbsz());
|
||||
|
|
@ -1151,7 +1167,7 @@ define_instruction(smk) {
|
|||
|
||||
define_instruction(slen) {
|
||||
cks(ac);
|
||||
ac = fixnum_obj(stringlen(ac));
|
||||
ac = fixnum_obj(string_len(ac));
|
||||
gonexti();
|
||||
}
|
||||
|
||||
|
|
@ -1159,8 +1175,8 @@ define_instruction(sget) {
|
|||
obj x = spop(); int i;
|
||||
cks(ac); ckk(x);
|
||||
i = get_fixnum(x);
|
||||
if (i >= stringlen(ac)) failtype(x, "valid string index");
|
||||
ac = char_obj(*stringref(ac, i));
|
||||
if (i >= string_len(ac)) failtype(x, "valid string index");
|
||||
ac = char_obj(string_ref(ac, i));
|
||||
gonexti();
|
||||
}
|
||||
|
||||
|
|
@ -1168,8 +1184,8 @@ define_instruction(sput) {
|
|||
obj x = spop(), y = spop(); int i;
|
||||
cks(ac); ckk(x); ckc(y);
|
||||
i = get_fixnum(x);
|
||||
if (i >= stringlen(ac)) failtype(x, "valid string index");
|
||||
*stringref(ac, i) = get_char(y);
|
||||
if (i >= string_len(ac)) failtype(x, "valid string index");
|
||||
string_ref(ac, i) = get_char(y);
|
||||
gonexti();
|
||||
}
|
||||
|
||||
|
|
@ -1186,7 +1202,7 @@ define_instruction(ssub) {
|
|||
cks(ac); ckk(x); ckk(y);
|
||||
is = get_fixnum(x), ie = get_fixnum(y);
|
||||
if (is > ie) failtype(x, "valid start string index");
|
||||
if (ie > stringlen(ac)) failtype(y, "valid end string index");
|
||||
if (ie > string_len(ac)) failtype(y, "valid end string index");
|
||||
d = substring(stringdata(ac), is, ie);
|
||||
ac = string_obj(d);
|
||||
gonexti();
|
||||
|
|
@ -1251,7 +1267,7 @@ define_instruction(bmk) {
|
|||
|
||||
define_instruction(blen) {
|
||||
ckb(ac);
|
||||
ac = fixnum_obj(bytevectorlen(ac));
|
||||
ac = fixnum_obj(bytevector_len(ac));
|
||||
gonexti();
|
||||
}
|
||||
|
||||
|
|
@ -1259,8 +1275,8 @@ define_instruction(bget) {
|
|||
obj x = spop(); int i;
|
||||
ckb(ac); ckk(x);
|
||||
i = get_fixnum(x);
|
||||
if (i >= bytevectorlen(ac)) failtype(x, "valid bytevector index");
|
||||
ac = fixnum_obj(*bytevectorref(ac, i));
|
||||
if (i >= bytevector_len(ac)) failtype(x, "valid bytevector index");
|
||||
ac = fixnum_obj(bytevector_ref(ac, i));
|
||||
gonexti();
|
||||
}
|
||||
|
||||
|
|
@ -1268,8 +1284,8 @@ define_instruction(bput) {
|
|||
obj x = spop(), y = spop(); int i;
|
||||
ckb(ac); ckk(x); ck8(y);
|
||||
i = get_fixnum(x);
|
||||
if (i >= bytevectorlen(ac)) failtype(x, "valid bytevector index");
|
||||
*bytevectorref(ac, i) = byte_from_obj(y);
|
||||
if (i >= bytevector_len(ac)) failtype(x, "valid bytevector index");
|
||||
bytevector_ref(ac, i) = byte_from_obj(y);
|
||||
gonexti();
|
||||
}
|
||||
|
||||
|
|
@ -1278,7 +1294,7 @@ define_instruction(bsub) {
|
|||
ckb(ac); ckk(x); ckk(y);
|
||||
is = get_fixnum(x), ie = get_fixnum(y);
|
||||
if (is > ie) failtype(x, "valid start bytevector index");
|
||||
if (ie > bytevectorlen(ac)) failtype(y, "valid end bytevector index");
|
||||
if (ie > bytevector_len(ac)) failtype(y, "valid end bytevector index");
|
||||
d = subbytevector(bytevectordata(ac), is, ie);
|
||||
ac = bytevector_obj(d);
|
||||
gonexti();
|
||||
|
|
@ -1290,8 +1306,54 @@ define_instruction(beq) {
|
|||
gonexti();
|
||||
}
|
||||
|
||||
|
||||
define_instruction(recp) {
|
||||
ac = bool_obj(is_record(ac));
|
||||
obj x = ac, y = spop();
|
||||
if (is_void(y)) {
|
||||
ac = bool_obj(is_record(ac));
|
||||
} else {
|
||||
ac = bool_obj(is_record(ac) && record_rtd(ac) == y);
|
||||
}
|
||||
gonexti();
|
||||
}
|
||||
|
||||
define_instruction(rmk) {
|
||||
int i, n; obj v; ckk(sref(0));
|
||||
n = get_fixnum(sref(0));
|
||||
hp_reserve(recbsz(n)); v = sref(1);
|
||||
for (i = 0; i < n; ++i) *--hp = v;
|
||||
ac = hend_rec(ac, n);
|
||||
sdrop(2);
|
||||
gonexti();
|
||||
}
|
||||
|
||||
define_instruction(rlen) {
|
||||
cko(ac);
|
||||
ac = fixnum_obj(record_len(ac));
|
||||
gonexti();
|
||||
}
|
||||
|
||||
define_instruction(rget) {
|
||||
obj x = spop(); int i;
|
||||
cko(ac); ckk(x);
|
||||
i = get_fixnum(x);
|
||||
if (i >= record_len(ac)) failtype(x, "valid record index");
|
||||
ac = record_ref(ac, i);
|
||||
gonexti();
|
||||
}
|
||||
|
||||
define_instruction(rput) {
|
||||
obj x = spop(), y = spop(); int i;
|
||||
cko(ac); ckk(x);
|
||||
i = get_fixnum(x);
|
||||
if (i >= record_len(ac)) failtype(x, "valid record index");
|
||||
record_ref(ac, i) = y;
|
||||
gonexti();
|
||||
}
|
||||
|
||||
define_instruction(rrtd) {
|
||||
cko(ac);
|
||||
ac = record_rtd(ac);
|
||||
gonexti();
|
||||
}
|
||||
|
||||
|
|
@ -1322,7 +1384,7 @@ define_instruction(vmk) {
|
|||
|
||||
define_instruction(vlen) {
|
||||
ckv(ac);
|
||||
ac = fixnum_obj(vectorlen(ac));
|
||||
ac = fixnum_obj(vector_len(ac));
|
||||
gonexti();
|
||||
}
|
||||
|
||||
|
|
@ -1330,8 +1392,8 @@ define_instruction(vget) {
|
|||
obj x = spop(); int i;
|
||||
ckv(ac); ckk(x);
|
||||
i = get_fixnum(x);
|
||||
if (i >= vectorlen(ac)) failtype(x, "valid vector index");
|
||||
ac = vectorref(ac, i);
|
||||
if (i >= vector_len(ac)) failtype(x, "valid vector index");
|
||||
ac = vector_ref(ac, i);
|
||||
gonexti();
|
||||
}
|
||||
|
||||
|
|
@ -1339,19 +1401,19 @@ define_instruction(vput) {
|
|||
obj x = spop(), y = spop(); int i;
|
||||
ckv(ac); ckk(x);
|
||||
i = get_fixnum(x);
|
||||
if (i >= vectorlen(ac)) failtype(x, "valid vector index");
|
||||
vectorref(ac, i) = y;
|
||||
if (i >= vector_len(ac)) failtype(x, "valid vector index");
|
||||
vector_ref(ac, i) = y;
|
||||
gonexti();
|
||||
}
|
||||
|
||||
define_instruction(vcat) {
|
||||
obj x = ac, y = sref(0); int n1, n2, n;
|
||||
ckv(x); ckv(y);
|
||||
n1 = vectorlen(x), n2 = vectorlen(y), n = n1 + n2;
|
||||
n1 = vector_len(x), n2 = vector_len(y), n = n1 + n2;
|
||||
hp_reserve(vecbsz(n));
|
||||
/* NB: vectorref fails to return pointer to empty vector's start */
|
||||
hp -= n2; if (n2) memcpy(hp, &vectorref(y, 0), n2*sizeof(obj));
|
||||
hp -= n1; if (n1) memcpy(hp, &vectorref(x, 0), n1*sizeof(obj));
|
||||
/* NB: vector_ref fails to return pointer to empty vector's start */
|
||||
hp -= n2; if (n2) memcpy(hp, &vector_ref(y, 0), n2*sizeof(obj));
|
||||
hp -= n1; if (n1) memcpy(hp, &vector_ref(x, 0), n1*sizeof(obj));
|
||||
ac = hend_vec(n);
|
||||
sdrop(1);
|
||||
gonexti();
|
||||
|
|
@ -1359,10 +1421,10 @@ define_instruction(vcat) {
|
|||
|
||||
define_instruction(vtol) {
|
||||
obj l = null_obj(); int n;
|
||||
ckv(ac); n = vectorlen(ac);
|
||||
ckv(ac); n = vector_len(ac);
|
||||
hp_reserve(pairbsz()*n);
|
||||
while (n > 0) {
|
||||
*--hp = l; *--hp = vectorref(ac, n-1);
|
||||
*--hp = l; *--hp = vector_ref(ac, n-1);
|
||||
l = hend_pair();
|
||||
--n;
|
||||
}
|
||||
|
|
@ -1394,10 +1456,10 @@ define_instruction(ltob) {
|
|||
|
||||
define_instruction(stol) {
|
||||
obj l = null_obj(); int n;
|
||||
cks(ac); n = stringlen(ac);
|
||||
cks(ac); n = string_len(ac);
|
||||
hp_reserve(pairbsz()*n);
|
||||
while (n > 0) {
|
||||
*--hp = l; *--hp = char_obj(*stringref(ac, n-1));
|
||||
*--hp = l; *--hp = char_obj(string_ref(ac, n-1));
|
||||
l = hend_pair();
|
||||
--n;
|
||||
}
|
||||
|
|
@ -2874,6 +2936,16 @@ define_instruction(funp) {
|
|||
gonexti();
|
||||
}
|
||||
|
||||
define_instruction(voidp) {
|
||||
ac = bool_obj(is_void(ac));
|
||||
gonexti();
|
||||
}
|
||||
|
||||
define_instruction(void) {
|
||||
ac = void_obj();
|
||||
gonexti();
|
||||
}
|
||||
|
||||
define_instruction(ipp) {
|
||||
ac = bool_obj(is_iport(ac));
|
||||
gonexti();
|
||||
|
|
@ -3240,16 +3312,16 @@ define_instruction(pushsref7) { ac = sref(7); spush(ac); gonexti(); }
|
|||
define_instruction(pushsref8) { ac = sref(8); spush(ac); gonexti(); }
|
||||
define_instruction(pushsref9) { ac = sref(9); spush(ac); gonexti(); }
|
||||
|
||||
define_instruction(srefi0) { ac = boxref(sref(0)); gonexti(); }
|
||||
define_instruction(srefi1) { ac = boxref(sref(1)); gonexti(); }
|
||||
define_instruction(srefi2) { ac = boxref(sref(2)); gonexti(); }
|
||||
define_instruction(srefi3) { ac = boxref(sref(3)); gonexti(); }
|
||||
define_instruction(srefi4) { ac = boxref(sref(4)); gonexti(); }
|
||||
define_instruction(pushsrefi0) { ac = boxref(sref(0)); spush(ac); gonexti(); }
|
||||
define_instruction(pushsrefi1) { ac = boxref(sref(1)); spush(ac); gonexti(); }
|
||||
define_instruction(pushsrefi2) { ac = boxref(sref(2)); spush(ac); gonexti(); }
|
||||
define_instruction(pushsrefi3) { ac = boxref(sref(3)); spush(ac); gonexti(); }
|
||||
define_instruction(pushsrefi4) { ac = boxref(sref(4)); spush(ac); gonexti(); }
|
||||
define_instruction(srefi0) { ac = box_ref(sref(0)); gonexti(); }
|
||||
define_instruction(srefi1) { ac = box_ref(sref(1)); gonexti(); }
|
||||
define_instruction(srefi2) { ac = box_ref(sref(2)); gonexti(); }
|
||||
define_instruction(srefi3) { ac = box_ref(sref(3)); gonexti(); }
|
||||
define_instruction(srefi4) { ac = box_ref(sref(4)); gonexti(); }
|
||||
define_instruction(pushsrefi0) { ac = box_ref(sref(0)); spush(ac); gonexti(); }
|
||||
define_instruction(pushsrefi1) { ac = box_ref(sref(1)); spush(ac); gonexti(); }
|
||||
define_instruction(pushsrefi2) { ac = box_ref(sref(2)); spush(ac); gonexti(); }
|
||||
define_instruction(pushsrefi3) { ac = box_ref(sref(3)); spush(ac); gonexti(); }
|
||||
define_instruction(pushsrefi4) { ac = box_ref(sref(4)); spush(ac); gonexti(); }
|
||||
|
||||
define_instruction(dref0) { ac = dref(0); gonexti(); }
|
||||
define_instruction(dref1) { ac = dref(1); gonexti(); }
|
||||
|
|
@ -3262,16 +3334,16 @@ define_instruction(pushdref2) { ac = dref(2); spush(ac); gonexti(); }
|
|||
define_instruction(pushdref3) { ac = dref(3); spush(ac); gonexti(); }
|
||||
define_instruction(pushdref4) { ac = dref(4); spush(ac); gonexti(); }
|
||||
|
||||
define_instruction(drefi0) { ac = boxref(dref(0)); gonexti(); }
|
||||
define_instruction(drefi1) { ac = boxref(dref(1)); gonexti(); }
|
||||
define_instruction(drefi2) { ac = boxref(dref(2)); gonexti(); }
|
||||
define_instruction(drefi3) { ac = boxref(dref(3)); gonexti(); }
|
||||
define_instruction(drefi4) { ac = boxref(dref(4)); gonexti(); }
|
||||
define_instruction(pushdrefi0) { ac = boxref(dref(0)); spush(ac); gonexti(); }
|
||||
define_instruction(pushdrefi1) { ac = boxref(dref(1)); spush(ac); gonexti(); }
|
||||
define_instruction(pushdrefi2) { ac = boxref(dref(2)); spush(ac); gonexti(); }
|
||||
define_instruction(pushdrefi3) { ac = boxref(dref(3)); spush(ac); gonexti(); }
|
||||
define_instruction(pushdrefi4) { ac = boxref(dref(4)); spush(ac); gonexti(); }
|
||||
define_instruction(drefi0) { ac = box_ref(dref(0)); gonexti(); }
|
||||
define_instruction(drefi1) { ac = box_ref(dref(1)); gonexti(); }
|
||||
define_instruction(drefi2) { ac = box_ref(dref(2)); gonexti(); }
|
||||
define_instruction(drefi3) { ac = box_ref(dref(3)); gonexti(); }
|
||||
define_instruction(drefi4) { ac = box_ref(dref(4)); gonexti(); }
|
||||
define_instruction(pushdrefi0) { ac = box_ref(dref(0)); spush(ac); gonexti(); }
|
||||
define_instruction(pushdrefi1) { ac = box_ref(dref(1)); spush(ac); gonexti(); }
|
||||
define_instruction(pushdrefi2) { ac = box_ref(dref(2)); spush(ac); gonexti(); }
|
||||
define_instruction(pushdrefi3) { ac = box_ref(dref(3)); spush(ac); gonexti(); }
|
||||
define_instruction(pushdrefi4) { ac = box_ref(dref(4)); spush(ac); gonexti(); }
|
||||
|
||||
define_instruction(call0) {
|
||||
ckx(ac); rd = ac; rx = fixnum_obj(0); ac = fixnum_obj(0);
|
||||
|
|
|
|||
8
i.h
8
i.h
|
|
@ -438,6 +438,12 @@ declare_instruction(bget, "B4", 0, "bytevector-u8-ref",
|
|||
declare_instruction(bput, "B5", 0, "bytevector-u8-set!", '3', AUTOGL)
|
||||
declare_instruction(bsub, "B7", 0, "subbytevector", '3', AUTOGL)
|
||||
declare_instruction(beq, "B=", 0, "bytevector=?", 'c', AUTOGL)
|
||||
declare_instruction(recp, "O0\0Y9", 0, "record?", 'b', AUTOGL)
|
||||
declare_instruction(rmk, "O2\0f", 0, "make-record", 't', AUTOGL)
|
||||
declare_instruction(rlen, "O3", 0, "record-length", '1', AUTOGL)
|
||||
declare_instruction(rget, "O4", 0, "record-ref", '2', AUTOGL)
|
||||
declare_instruction(rput, "O5", 0, "record-set!", '3', AUTOGL)
|
||||
declare_instruction(rrtd, "O6", 0, "record-type-descriptor", '1', AUTOGL)
|
||||
declare_instruction(vtol, "X0", 0, "%vector->list1", '1', AUTOGL)
|
||||
declare_instruction(ltov, "X1", 0, "list->vector", '1', AUTOGL)
|
||||
declare_instruction(stol, "X2", 0, "%string->list1", '1', AUTOGL)
|
||||
|
|
@ -456,6 +462,8 @@ declare_instruction(ston, "E9\0'(i10)", 0, "string->number",
|
|||
declare_instruction(symp, "Y0", 0, "symbol?", '1', AUTOGL)
|
||||
declare_instruction(boolp, "Y1", 0, "boolean?", '1', AUTOGL)
|
||||
declare_instruction(boxp, "Y2", 0, "box?", '1', AUTOGL)
|
||||
declare_instruction(voidp, "Y8", 0, "void?", '1', AUTOGL)
|
||||
declare_instruction(void, "Y9", 0, "void", '0', AUTOGL)
|
||||
declare_instruction(funp, "K0", 0, "procedure?", '1', AUTOGL)
|
||||
declare_instruction(ipp, "P00", 0, "input-port?", '1', AUTOGL)
|
||||
declare_instruction(opp, "P01", 0, "output-port?", '1', AUTOGL)
|
||||
|
|
|
|||
50
s.c
50
s.c
|
|
@ -171,6 +171,56 @@ char *s_code[] = {
|
|||
"l3:y12:syntax-rules;n;l2:l2:y1:_;y1:x;;l2:y11:delay-force;l2:y12:make-"
|
||||
"promise;y1:x;;;;",
|
||||
|
||||
"P", "new-record-type",
|
||||
"%2.1,.1c]2",
|
||||
|
||||
"S", "%id-eq??",
|
||||
"l3:y12:syntax-rules;n;l2:l5:y1:_;y2:id;y1:b;y2:kt;y2:kf;;l3:l3:y13:syn"
|
||||
"tax-lambda;l2:y2:id;y2:ok;;l2:l3:y12:syntax-rules;n;l2:l2:y1:_;y1:b;;l"
|
||||
"1:y2:id;;;;y2:ok;;;l3:y12:syntax-rules;n;l2:l1:y1:_;;y2:kf;;;l3:y12:sy"
|
||||
"ntax-rules;n;l2:l1:y1:_;;y2:kt;;;;;",
|
||||
|
||||
"S", "%id-assq??",
|
||||
"l4:y12:syntax-rules;n;l2:l5:y1:_;y2:id;n;y2:kt;y2:kf;;y2:kf;;l2:l5:y1:"
|
||||
"_;y2:id;ppy3:id0;y2:r0;;y4:idr*;;y2:kt;y2:kf;;l5:y8:%25id-eq??;y2:id;y"
|
||||
"3:id0;py2:kt;y2:r0;;l5:y10:%25id-assq??;y2:id;y4:idr*;y2:kt;y2:kf;;;;",
|
||||
|
||||
"S", "%drt-init",
|
||||
"l4:y12:syntax-rules;n;l2:l5:y1:_;y1:r;n;y3:fi*;l2:y1:x;y3:...;;;l4:y5:"
|
||||
"begin;y1:x;y3:...;y1:r;;;l2:l5:y1:_;y1:r;py3:id0;y3:id*;;y3:fi*;l2:y1:"
|
||||
"x;y3:...;;;l5:y10:%25id-assq??;y3:id0;y3:fi*;l3:y12:syntax-rules;n;l2:"
|
||||
"l2:y1:_;y2:i0;;l5:y9:%25drt-init;y1:r;y3:id*;y3:fi*;l3:y1:x;y3:...;l4:"
|
||||
"y11:record-set!;y1:r;y2:i0;y3:id0;;;;;;l3:y12:syntax-error;s52:id in d"
|
||||
"efine-record-type constructor is not a field:;y3:id0;;;;",
|
||||
|
||||
"S", "%drt-unroll",
|
||||
"l5:y12:syntax-rules;n;l2:l8:y1:_;y3:rtn;l3:y5:consn;y2:id;y3:...;;y5:p"
|
||||
"redn;n;l2:l2:y1:f;y1:i;;y3:...;;l2:l2:y1:a;y2:ia;;y3:...;;l2:l2:y1:m;y"
|
||||
"2:im;;y3:...;;;l8:y5:begin;l3:y6:define;y3:rtn;l3:y15:new-record-type;"
|
||||
"l2:y5:quote;y3:rtn;;l2:y5:quote;l2:y1:f;y3:...;;;;;l3:y6:define;y5:con"
|
||||
"sn;l3:y6:lambda;l2:y2:id;y3:...;;l3:y3:let;l1:l2:y1:r;l3:y11:make-reco"
|
||||
"rd;y3:rtn;l2:y13:syntax-length;l2:y1:f;y3:...;;;;;;l5:y9:%25drt-init;y"
|
||||
"1:r;l2:y2:id;y3:...;;l2:l2:y1:f;y1:i;;y3:...;;n;;;;;l3:y6:define;y5:pr"
|
||||
"edn;l3:y6:lambda;l1:y3:obj;;l3:y7:record?;y3:obj;y3:rtn;;;;l3:y6:defin"
|
||||
"e;y1:a;l3:y6:lambda;l1:y3:obj;;l3:y10:record-ref;y3:obj;y2:ia;;;;y3:.."
|
||||
".;l3:y6:define;y1:m;l3:y6:lambda;l2:y3:obj;y3:val;;l4:y11:record-set!;"
|
||||
"y3:obj;y2:im;y3:val;;;;y3:...;;;l2:l8:y1:_;y3:rtn;y3:cf*;y5:predn;l3:l"
|
||||
"2:y2:fn;y4:accn;;y3:fam;y3:...;;l2:y2:fi;y3:...;;l2:y2:ai;y3:...;;l2:y"
|
||||
"2:mi;y3:...;;;l8:y11:%25drt-unroll;y3:rtn;y3:cf*;y5:predn;l2:y3:fam;y3"
|
||||
":...;;l3:y2:fi;y3:...;l2:y2:fn;l2:y13:syntax-length;l2:y2:fi;y3:...;;;"
|
||||
";;l3:y2:ai;y3:...;l2:y4:accn;l2:y13:syntax-length;l2:y2:fi;y3:...;;;;;"
|
||||
"l2:y2:mi;y3:...;;;;l2:l8:y1:_;y3:rtn;y3:cf*;y5:predn;l3:l3:y2:fn;y4:ac"
|
||||
"cn;y4:modn;;y3:fam;y3:...;;l2:y2:fi;y3:...;;l2:y2:ai;y3:...;;l2:y2:mi;"
|
||||
"y3:...;;;l8:y11:%25drt-unroll;y3:rtn;y3:cf*;y5:predn;l2:y3:fam;y3:...;"
|
||||
";l3:y2:fi;y3:...;l2:y2:fn;l2:y13:syntax-length;l2:y2:fi;y3:...;;;;;l3:"
|
||||
"y2:ai;y3:...;l2:y4:accn;l2:y13:syntax-length;l2:y2:fi;y3:...;;;;;l3:y2"
|
||||
":mi;y3:...;l2:y4:modn;l2:y13:syntax-length;l2:y2:fi;y3:...;;;;;;;",
|
||||
|
||||
"S", "define-record-type",
|
||||
"l3:y12:syntax-rules;n;l2:l6:y1:_;y3:rtn;l3:y5:consn;y2:id;y3:...;;y5:p"
|
||||
"redn;py2:fn;y2:am;;y3:...;;l8:y11:%25drt-unroll;y3:rtn;l3:y5:consn;y2:"
|
||||
"id;y3:...;;y5:predn;l2:py2:fn;y2:am;;y3:...;;n;n;n;;;",
|
||||
|
||||
"P", "floor/",
|
||||
"%2.1,.1Nm,.2,.2Nl,@(y6:values)[22",
|
||||
|
||||
|
|
|
|||
29
src/k.sf
29
src/k.sf
|
|
@ -299,12 +299,21 @@
|
|||
[(body) (xform-body tail env)]
|
||||
[(define) (xform-define tail env)]
|
||||
[(define-syntax) (xform-define-syntax tail env)]
|
||||
[(syntax-length) (xform-syntax-length tail env)]
|
||||
[(syntax-error) (xform-syntax-error tail env)]
|
||||
[else (if (integrable? hval)
|
||||
(xform-integrable hval tail env)
|
||||
(if (procedure? hval)
|
||||
(xform appos? (hval sexp env) env)
|
||||
(xform-call hval tail env)))]))]))
|
||||
|
||||
(define (xform-sexp->datum sexp)
|
||||
(let conv ([sexp sexp])
|
||||
(cond [(id? sexp) (id->sym sexp)]
|
||||
[(pair? sexp) (cons (conv (car sexp)) (conv (cdr sexp)))]
|
||||
[(vector? sexp) (list->vector (map conv (vector->list sexp)))]
|
||||
[else sexp])))
|
||||
|
||||
(define (xform-ref id env)
|
||||
(let ([den (env id)])
|
||||
(cond [(symbol? den) (list 'ref den)]
|
||||
|
|
@ -312,14 +321,20 @@
|
|||
|
||||
(define (xform-quote tail env)
|
||||
(if (list1? tail)
|
||||
(list 'quote
|
||||
(let conv ([sexp (car tail)])
|
||||
(cond [(id? sexp) (id->sym sexp)]
|
||||
[(pair? sexp) (cons (conv (car sexp)) (conv (cdr sexp)))]
|
||||
[(vector? sexp) (list->vector (map conv (vector->list sexp)))]
|
||||
[else sexp])))
|
||||
(list 'quote (xform-sexp->datum (car tail)))
|
||||
(x-error "improper quote form" (cons 'quote tail))))
|
||||
|
||||
(define (xform-syntax-length tail env)
|
||||
(if (and (list1? tail) (list? (car tail)))
|
||||
(list 'quote (length (car tail)))
|
||||
(x-error "improper syntax-length form" (cons 'syntax-length tail))))
|
||||
|
||||
(define (xform-syntax-error tail env)
|
||||
(let ([args (map xform-sexp->datum tail)])
|
||||
(if (and (list1+? args) (string? (car args)))
|
||||
(apply x-error args)
|
||||
(x-error "improper syntax-error form" (cons 'syntax-error tail)))))
|
||||
|
||||
(define (xform-set! tail env)
|
||||
(if (and (list2? tail) (id? (car tail)))
|
||||
(let ([den (env (car tail))] [xexp (xform #f (cadr tail) env)])
|
||||
|
|
@ -523,6 +538,8 @@
|
|||
(make-binding 'lambda 'lambda)
|
||||
(make-binding 'lambda* 'lambda*)
|
||||
(make-binding 'syntax-lambda 'syntax-lambda)
|
||||
(make-binding 'syntax-length 'syntax-length)
|
||||
(make-binding 'syntax-error 'syntax-error)
|
||||
(make-binding 'letcc 'letcc)
|
||||
(make-binding 'withcc 'withcc)
|
||||
(make-binding 'begin 'begin)
|
||||
|
|
|
|||
73
src/s.scm
73
src/s.scm
|
|
@ -222,6 +222,79 @@
|
|||
(syntax-rules () [(_ x) (delay-force (make-promise x))]))
|
||||
|
||||
|
||||
;---------------------------------------------------------------------------------------------
|
||||
; Record type definitions
|
||||
;---------------------------------------------------------------------------------------------
|
||||
|
||||
; integrables:
|
||||
;
|
||||
; (record? x (rtd))
|
||||
; (make-record rtd n (fill #f))
|
||||
; (record-length r)
|
||||
; (record-ref r i)
|
||||
; (record-set! r i v)
|
||||
|
||||
(define (new-record-type name fields) ; stub
|
||||
(cons name fields))
|
||||
|
||||
; see http://okmij.org/ftp/Scheme/macro-symbol-p.txt
|
||||
(define-syntax %id-eq??
|
||||
(syntax-rules ()
|
||||
[(_ id b kt kf)
|
||||
((syntax-lambda (id ok) ((syntax-rules () [(_ b) (id)]) ok))
|
||||
(syntax-rules () [(_) kf]) (syntax-rules () [(_) kt]))]))
|
||||
|
||||
(define-syntax %id-assq??
|
||||
(syntax-rules ()
|
||||
[(_ id () kt kf)
|
||||
kf]
|
||||
[(_ id ([id0 . r0] . idr*) kt kf)
|
||||
(%id-eq?? id id0 (kt . r0) (%id-assq?? id idr* kt kf))]))
|
||||
|
||||
(define-syntax %drt-init
|
||||
(syntax-rules ()
|
||||
[(_ r () fi* (x ...))
|
||||
(begin x ... r)]
|
||||
[(_ r (id0 . id*) fi* (x ...))
|
||||
(%id-assq?? id0 fi*
|
||||
(syntax-rules () [(_ i0) (%drt-init r id* fi* (x ... (record-set! r i0 id0)))])
|
||||
(syntax-error "id in define-record-type constructor is not a field:" id0))]))
|
||||
|
||||
(define-syntax %drt-unroll
|
||||
(syntax-rules ()
|
||||
[(_ rtn (consn id ...) predn () ([f i] ...) ([a ia] ...) ([m im] ...))
|
||||
(begin
|
||||
(define rtn
|
||||
(new-record-type 'rtn '(f ...)))
|
||||
(define consn
|
||||
(lambda (id ...)
|
||||
(let ([r (make-record rtn (syntax-length (f ...)))])
|
||||
(%drt-init r (id ...) ([f i] ...) ()))))
|
||||
(define predn
|
||||
(lambda (obj) (record? obj rtn)))
|
||||
(define a
|
||||
(lambda (obj) (record-ref obj ia)))
|
||||
...
|
||||
(define m
|
||||
(lambda (obj val) (record-set! obj im val)))
|
||||
...)]
|
||||
[(_ rtn cf* predn ([fn accn] fam ...) (fi ...) (ai ...) (mi ...))
|
||||
(%drt-unroll rtn cf* predn (fam ...)
|
||||
(fi ... [fn (syntax-length (fi ...))])
|
||||
(ai ... [accn (syntax-length (fi ...))])
|
||||
(mi ...))]
|
||||
[(_ rtn cf* predn ([fn accn modn] fam ...) (fi ...) (ai ...) (mi ...))
|
||||
(%drt-unroll rtn cf* predn (fam ...)
|
||||
(fi ... [fn (syntax-length (fi ...))])
|
||||
(ai ... [accn (syntax-length (fi ...))])
|
||||
(mi ... [modn (syntax-length (fi ...))]))]))
|
||||
|
||||
(define-syntax define-record-type
|
||||
(syntax-rules ()
|
||||
[(_ rtn (consn id ...) predn (fn . am) ...)
|
||||
(%drt-unroll rtn (consn id ...) predn ((fn . am) ...) () () ())]))
|
||||
|
||||
|
||||
;---------------------------------------------------------------------------------------------
|
||||
; Equivalence predicates
|
||||
;---------------------------------------------------------------------------------------------
|
||||
|
|
|
|||
109
src/t.scm
109
src/t.scm
|
|
@ -263,12 +263,21 @@
|
|||
[(body) (xform-body tail env)]
|
||||
[(define) (xform-define tail env)]
|
||||
[(define-syntax) (xform-define-syntax tail env)]
|
||||
[(syntax-length) (xform-syntax-length tail env)]
|
||||
[(syntax-error) (xform-syntax-error tail env)]
|
||||
[else (if (integrable? hval)
|
||||
(xform-integrable hval tail env)
|
||||
(if (procedure? hval)
|
||||
(xform appos? (hval sexp env) env)
|
||||
(xform-call hval tail env)))]))]))
|
||||
|
||||
(define (xform-sexp->datum sexp)
|
||||
(let conv ([sexp sexp])
|
||||
(cond [(id? sexp) (id->sym sexp)]
|
||||
[(pair? sexp) (cons (conv (car sexp)) (conv (cdr sexp)))]
|
||||
[(vector? sexp) (list->vector (map conv (vector->list sexp)))]
|
||||
[else sexp])))
|
||||
|
||||
(define (xform-ref id env)
|
||||
(let ([den (env id)])
|
||||
(cond [(symbol? den) (list 'ref den)]
|
||||
|
|
@ -276,14 +285,20 @@
|
|||
|
||||
(define (xform-quote tail env)
|
||||
(if (list1? tail)
|
||||
(list 'quote
|
||||
(let conv ([sexp (car tail)])
|
||||
(cond [(id? sexp) (id->sym sexp)]
|
||||
[(pair? sexp) (cons (conv (car sexp)) (conv (cdr sexp)))]
|
||||
[(vector? sexp) (list->vector (map conv (vector->list sexp)))]
|
||||
[else sexp])))
|
||||
(list 'quote (xform-sexp->datum (car tail)))
|
||||
(x-error "improper quote form" (cons 'quote tail))))
|
||||
|
||||
(define (xform-syntax-length tail env)
|
||||
(if (and (list1? tail) (list? (car tail)))
|
||||
(list 'quote (length (car tail)))
|
||||
(x-error "improper syntax-length form" (cons 'syntax-length tail))))
|
||||
|
||||
(define (xform-syntax-error tail env)
|
||||
(let ([args (map xform-sexp->datum tail)])
|
||||
(if (and (list1+? args) (string? (car args)))
|
||||
(apply x-error args)
|
||||
(x-error "improper syntax-error form" (cons 'syntax-error tail)))))
|
||||
|
||||
(define (xform-set! tail env)
|
||||
(if (and (list2? tail) (id? (car tail)))
|
||||
(let ([den (env (car tail))] [xexp (xform #f (cadr tail) env)])
|
||||
|
|
@ -335,7 +350,7 @@
|
|||
(case igt
|
||||
[(#\0) (= n 0)] [(#\1) (= n 1)] [(#\2) (= n 2)] [(#\3) (= n 3)]
|
||||
[(#\p) (>= n 0)] [(#\m) (>= n 1)] [(#\c) (>= n 2)] [(#\x) (>= n 1)]
|
||||
[(#\u) (<= 0 n 1)] [(#\b) (<= 1 n 2)]
|
||||
[(#\u) (<= 0 n 1)] [(#\b) (<= 1 n 2)] [(#\t) (<= 2 n 3)]
|
||||
[(#\#) (>= n 0)] [(#\@) #f]
|
||||
[else #f]))
|
||||
|
||||
|
|
@ -403,41 +418,53 @@
|
|||
(x-error "improper withcc form" (cons 'withcc tail))))
|
||||
|
||||
(define (xform-body tail env)
|
||||
(if (null? tail)
|
||||
(list 'begin)
|
||||
(let loop ([env env] [ids '()] [inits '()] [nids '()] [body tail])
|
||||
(if (and (pair? body) (pair? (car body)))
|
||||
(let ([first (car body)] [rest (cdr body)])
|
||||
(let* ([head (car first)] [hval (xform #t head env)])
|
||||
(case hval
|
||||
[(begin)
|
||||
(loop env ids inits nids (append (cdr first) rest))]
|
||||
[(define)
|
||||
(let* ([id (cadr first)] [init (caddr first)]
|
||||
[nid (gensym (id->sym id))] [env (add-var id nid env)])
|
||||
(loop env (cons id ids) (cons init inits) (cons nid nids) rest))]
|
||||
[(define-syntax)
|
||||
(let* ([id (cadr first)] [init (caddr first)]
|
||||
[env (add-binding id '(undefined) env)])
|
||||
(loop env (cons id ids) (cons init inits) (cons #t nids) rest))]
|
||||
[else
|
||||
(if (procedure? hval)
|
||||
(loop env ids inits nids (cons (hval first env) rest))
|
||||
(xform-labels (reverse ids) (reverse inits) (reverse nids) body env))])))
|
||||
(xform-labels (reverse ids) (reverse inits) (reverse nids) body env)))))
|
||||
(cond
|
||||
[(null? tail)
|
||||
(list 'begin)]
|
||||
[(not (list? tail))
|
||||
(x-error "improper body form" (cons 'body tail))]
|
||||
[else
|
||||
(let loop ([env env] [ids '()] [inits '()] [nids '()] [body tail])
|
||||
(if (and (pair? body) (pair? (car body)))
|
||||
(let ([first (car body)] [rest (cdr body)])
|
||||
(let* ([head (car first)] [tail (cdr first)] [hval (xform #t head env)])
|
||||
(case hval
|
||||
[(begin)
|
||||
(if (list? tail)
|
||||
(loop env ids inits nids (append tail rest))
|
||||
(x-error "improper begin form" first))]
|
||||
[(define)
|
||||
(if (and (list2? tail) (null? (car tail)))
|
||||
(let ([init (cadr tail)]) ; idless
|
||||
(loop env (cons #f ids) (cons init inits) (cons #f nids) rest))
|
||||
(if (and (list2? tail) (id? (car tail)))
|
||||
(let* ([id (car tail)] [init (cadr tail)]
|
||||
[nid (gensym (id->sym id))] [env (add-var id nid env)])
|
||||
(loop env (cons id ids) (cons init inits) (cons nid nids) rest))
|
||||
(x-error "improper define form" first)))]
|
||||
[(define-syntax)
|
||||
(if (and (list2? tail) (id? (car tail)))
|
||||
(let* ([id (car tail)] [init (cadr tail)]
|
||||
[env (add-binding id '(undefined) env)])
|
||||
(loop env (cons id ids) (cons init inits) (cons #t nids) rest))
|
||||
(x-error "improper define-syntax form" first))]
|
||||
[else
|
||||
(if (procedure? hval)
|
||||
(loop env ids inits nids (cons (hval first env) rest))
|
||||
(xform-labels (reverse ids) (reverse inits) (reverse nids) body env))])))
|
||||
(xform-labels (reverse ids) (reverse inits) (reverse nids) body env)))]))
|
||||
|
||||
(define (xform-labels ids inits nids body env)
|
||||
(let loop ([ids ids] [inits inits] [nids nids] [sets '()] [lids '()])
|
||||
(cond [(null? ids)
|
||||
(let* ([xexps (append (reverse sets)
|
||||
(map (lambda (sexp) (xform #f sexp env)) body))]
|
||||
[xexp (if (and (pair? xexps) (null? (cdr xexps)))
|
||||
(car xexps)
|
||||
(cons 'begin xexps))])
|
||||
(if (null? lids)
|
||||
xexp
|
||||
(let* ([xexps (append (reverse sets) (map (lambda (x) (xform #f x env)) body))]
|
||||
[xexp (if (list1? xexps) (car xexps) (cons 'begin xexps))])
|
||||
(if (null? lids) xexp
|
||||
(pair* 'call (list 'lambda (reverse lids) xexp)
|
||||
(map (lambda (lid) '(begin)) lids))))]
|
||||
[(not (car ids)) ; idless define
|
||||
(loop (cdr ids) (cdr inits) (cdr nids)
|
||||
(cons (xform #f (car inits) env) sets) lids)]
|
||||
[(symbol? (car nids)) ; define
|
||||
(loop (cdr ids) (cdr inits) (cdr nids)
|
||||
(cons (xform-set! (list (car ids) (car inits)) env) sets)
|
||||
|
|
@ -447,9 +474,11 @@
|
|||
(loop (cdr ids) (cdr inits) (cdr nids) sets lids)])))
|
||||
|
||||
(define (xform-define tail env) ; top-level only
|
||||
(if (and (list2? tail) (id? (car tail)))
|
||||
(list 'define (id->sym (car tail)) (xform #f (cadr tail) env))
|
||||
(x-error "improper define form" (cons 'define tail))))
|
||||
(if (and (list2? tail) (null? (car tail))) ; idless
|
||||
(xform #f (cadr tail) env)
|
||||
(if (and (list2? tail) (id? (car tail)))
|
||||
(list 'define (id->sym (car tail)) (xform #f (cadr tail) env))
|
||||
(x-error "improper define form" (cons 'define tail)))))
|
||||
|
||||
(define (xform-define-syntax tail env) ; top-level only
|
||||
(if (and (list2? tail) (id? (car tail)))
|
||||
|
|
@ -473,6 +502,8 @@
|
|||
(make-binding 'lambda 'lambda)
|
||||
(make-binding 'lambda* 'lambda*)
|
||||
(make-binding 'syntax-lambda 'syntax-lambda)
|
||||
(make-binding 'syntax-length 'syntax-length)
|
||||
(make-binding 'syntax-error 'syntax-error)
|
||||
(make-binding 'letcc 'letcc)
|
||||
(make-binding 'withcc 'withcc)
|
||||
(make-binding 'begin 'begin)
|
||||
|
|
|
|||
85
t.c
85
t.c
|
|
@ -144,18 +144,32 @@ char *t_code[] = {
|
|||
".3,@(y19:xform-syntax-lambda)[72}'(y5:letcc),.1v?{.6,.3,@(y11:xform-le"
|
||||
"tcc)[72}'(y6:withcc),.1v?{.6,.3,@(y12:xform-withcc)[72}'(y4:body),.1v?"
|
||||
"{.6,.3,@(y10:xform-body)[72}'(y6:define),.1v?{.6,.3,@(y12:xform-define"
|
||||
")[72}'(y13:define-syntax),.1v?{.6,.3,@(y19:xform-define-syntax)[72}.1U"
|
||||
"0?{.6,.3,.3,@(y16:xform-integrable)[73}.1K0?{.6,${.9,.9,.6[02},.6,@(y5"
|
||||
":xform)[73}.6,.3,.3,@(y10:xform-call)[73",
|
||||
")[72}'(y13:define-syntax),.1v?{.6,.3,@(y19:xform-define-syntax)[72}'(y"
|
||||
"13:syntax-length),.1v?{.6,.3,@(y19:xform-syntax-length)[72}'(y12:synta"
|
||||
"x-error),.1v?{.6,.3,@(y18:xform-syntax-error)[72}.1U0?{.6,.3,.3,@(y16:"
|
||||
"xform-integrable)[73}.1K0?{.6,${.9,.9,.6[02},.6,@(y5:xform)[73}.6,.3,."
|
||||
"3,@(y10:xform-call)[73",
|
||||
|
||||
"P", "xform-sexp->datum",
|
||||
"%1.0,,#0.0,&1{%1${.2,@(y3:id?)[01}?{.0,@(y7:id->sym)[11}.0p?{${.2d,:0^"
|
||||
"[01},${.3a,:0^[01}c]1}.0V0?{${.2X0,:0^,@(y5:%25map1)[02}X1]1}.0]1}.!0."
|
||||
"0^_1[11",
|
||||
|
||||
"P", "xform-ref",
|
||||
"%2${.2,.4[01},.0Y0?{.0,'(y3:ref),l2]3}.0d]3",
|
||||
|
||||
"P", "xform-quote",
|
||||
"%2${.2,@(y6:list1?)[01}?{${.2a,,#0.0,&1{%1${.2,@(y3:id?)[01}?{.0,@(y7:"
|
||||
"id->sym)[11}.0p?{${.2d,:0^[01},${.3a,:0^[01}c]1}.0V0?{${.2X0,:0^,@(y5:"
|
||||
"%25map1)[02}X1]1}.0]1}.!0.0^_1[01},'(y5:quote),l2]2}.0,'(y5:quote)c,'("
|
||||
"s19:improper quote form),@(y7:x-error)[22",
|
||||
"%2${.2,@(y6:list1?)[01}?{${.2a,@(y17:xform-sexp->datum)[01},'(y5:quote"
|
||||
"),l2]2}.0,'(y5:quote)c,'(s19:improper quote form),@(y7:x-error)[22",
|
||||
|
||||
"P", "xform-syntax-length",
|
||||
"%2${.2,@(y6:list1?)[01}?{.0aL0}{f}?{.0ag,'(y5:quote),l2]2}.0,'(y13:syn"
|
||||
"tax-length)c,'(s27:improper syntax-length form),@(y7:x-error)[22",
|
||||
|
||||
"P", "xform-syntax-error",
|
||||
"%2${.2,@(y17:xform-sexp->datum),@(y5:%25map1)[02},${.2,@(y7:list1+?)[0"
|
||||
"1}?{.0aS0}{f}?{.0,@(y7:x-error),@(y13:apply-to-list)[32}.1,'(y12:synta"
|
||||
"x-error)c,'(s26:improper syntax-error form),@(y7:x-error)[32",
|
||||
|
||||
"P", "xform-set!",
|
||||
"%2${.2,@(y6:list2?)[01}?{${.2a,@(y3:id?)[01}}{f}?{${.3,.3da,f,@(y5:xfo"
|
||||
|
|
@ -191,7 +205,8 @@ char *t_code[] = {
|
|||
"%2.0,'(c0),.1v?{'0,.3=]3}'(c1),.1v?{'1,.3=]3}'(c2),.1v?{'2,.3=]3}'(c3)"
|
||||
",.1v?{'3,.3=]3}'(cp),.1v?{'0,.3<!]3}'(cm),.1v?{'1,.3<!]3}'(cc),.1v?{'2"
|
||||
",.3<!]3}'(cx),.1v?{'1,.3<!]3}'(cu),.1v?{'1,.3,,'0>!;>!]3}'(cb),.1v?{'2"
|
||||
",.3,,'1>!;>!]3}'(c#),.1v?{'0,.3<!]3}'(c@),.1v?{f]3}f]3",
|
||||
",.3,,'1>!;>!]3}'(ct),.1v?{'3,.3,,'2>!;>!]3}'(c#),.1v?{'0,.3<!]3}'(c@),"
|
||||
".1v?{f]3}f]3",
|
||||
|
||||
"P", "xform-integrable",
|
||||
"%3${.3g,.3U6,@(y22:integrable-argc-match?)[02}?{${.3,.5,&1{%1:0,.1,f,@"
|
||||
|
|
@ -235,28 +250,37 @@ char *t_code[] = {
|
|||
" form),@(y7:x-error)[22",
|
||||
|
||||
"P", "xform-body",
|
||||
"%2.0u?{'(y5:begin),l1]2}.0,n,n,n,.5,,#0.0,&1{%5.4p?{.4ap}{f}?{.4d,.5a,"
|
||||
".0a,${.5,.3,t,@(y5:xform)[03},.0,'(y5:begin),.1v?{.4,.4dL6,.9,.9,.9,.9"
|
||||
",:0^[(i10)5}'(y6:define),.1v?{.3da,.4dda,${${.5,@(y7:id->sym)[01},@(y6"
|
||||
":gensym)[01},${.(i10),.3,.6,@(y7:add-var)[03},.8,.(i13),.3c,.(i13),.5c"
|
||||
",.(i13),.7c,.4,:0^[(i14)5}'(y13:define-syntax),.1v?{.3da,.4dda,${.9,'("
|
||||
"l1:y9:undefined;),.5,@(y11:add-binding)[03},.7,.(i12),tc,.(i12),.4c,.("
|
||||
"i12),.6c,.4,:0^[(i13)5}.1K0?{.4,${.8,.7,.6[02}c,.9,.9,.9,.9,:0^[(i10)5"
|
||||
"}.5,.(i10),.(i10)A8,.(i10)A8,.(i10)A8,@(y12:xform-labels)[(i10)5}.0,.5"
|
||||
",.5A8,.5A8,.5A8,@(y12:xform-labels)[55}.!0.0^_1[25",
|
||||
"%2.0u?{'(y5:begin),l1]2}.0L0~?{.0,'(y4:body)c,'(s18:improper body form"
|
||||
"),@(y7:x-error)[22}.0,n,n,n,.5,,#0.0,&1{%5.4p?{.4ap}{f}?{.4d,.5a,.0a,."
|
||||
"1d,${.6,.4,t,@(y5:xform)[03},.0,'(y5:begin),.1v?{.2L0?{.5,.3L6,.(i10),"
|
||||
".(i10),.(i10),.(i10),:0^[(i11)5}.4,'(s19:improper begin form),@(y7:x-e"
|
||||
"rror)[(i11)2}'(y6:define),.1v?{${.4,@(y6:list2?)[01}?{.2au}{f}?{.2da,."
|
||||
"6,.(i11),fc,.(i11),.3c,.(i11),fc,.(i11),:0^[(i12)5}${.4,@(y6:list2?)[0"
|
||||
"1}?{${.4a,@(y3:id?)[01}}{f}?{.2a,.3da,${${.5,@(y7:id->sym)[01},@(y6:ge"
|
||||
"nsym)[01},${.(i11),.3,.6,@(y7:add-var)[03},.9,.(i14),.3c,.(i14),.5c,.("
|
||||
"i14),.7c,.4,:0^[(i15)5}.4,'(s20:improper define form),@(y7:x-error)[(i"
|
||||
"11)2}'(y13:define-syntax),.1v?{${.4,@(y6:list2?)[01}?{${.4a,@(y3:id?)["
|
||||
"01}}{f}?{.2a,.3da,${.(i10),'(l1:y9:undefined;),.5,@(y11:add-binding)[0"
|
||||
"3},.8,.(i13),tc,.(i13),.4c,.(i13),.6c,.4,:0^[(i14)5}.4,'(s27:improper "
|
||||
"define-syntax form),@(y7:x-error)[(i11)2}.1K0?{.5,${.9,.8,.6[02}c,.(i1"
|
||||
"0),.(i10),.(i10),.(i10),:0^[(i11)5}.6,.(i11),.(i11)A8,.(i11)A8,.(i11)A"
|
||||
"8,@(y12:xform-labels)[(i11)5}.0,.5,.5A8,.5A8,.5A8,@(y12:xform-labels)["
|
||||
"55}.!0.0^_1[25",
|
||||
|
||||
"P", "xform-labels",
|
||||
"%5n,n,.4,.4,.4,,#0.0,.(i11),.(i11),&3{%5.0u?{${:0,:1,&1{%1:0,.1,f,@(y5"
|
||||
":xform)[13},@(y5:%25map1)[02},.4A8L6,.0p?{.0du}{f}?{.0a}{.0,'(y5:begin"
|
||||
")c},.6u?{.0]7}${.8,&0{%1'(l1:y5:begin;)]1},@(y5:%25map1)[02},.1,.8A8,'"
|
||||
"(y6:lambda),l3,'(y4:call),@(y5:pair*)[73}.2aY0?{.4,.3ac,.4,${:1,.6a,.6"
|
||||
"a,l2,@(y10:xform-set!)[02}c,.4d,.4d,.4d,:2^[55}${:1,.4a,t,@(y5:xform)["
|
||||
"03},${.3a,:1[01}sd.4,.4,.4d,.4d,.4d,:2^[55}.!0.0^_1[55",
|
||||
":xform)[13},@(y5:%25map1)[02},.4A8L6,${.2,@(y6:list1?)[01}?{.0a}{.0,'("
|
||||
"y5:begin)c},.6u?{.0]7}${.8,&0{%1'(l1:y5:begin;)]1},@(y5:%25map1)[02},."
|
||||
"1,.8A8,'(y6:lambda),l3,'(y4:call),@(y5:pair*)[73}.0a~?{.4,.4,${:1,.6a,"
|
||||
"f,@(y5:xform)[03}c,.4d,.4d,.4d,:2^[55}.2aY0?{.4,.3ac,.4,${:1,.6a,.6a,l"
|
||||
"2,@(y10:xform-set!)[02}c,.4d,.4d,.4d,:2^[55}${:1,.4a,t,@(y5:xform)[03}"
|
||||
",${.3a,:1[01}sd.4,.4,.4d,.4d,.4d,:2^[55}.!0.0^_1[55",
|
||||
|
||||
"P", "xform-define",
|
||||
"%2${.2,@(y6:list2?)[01}?{${.2a,@(y3:id?)[01}}{f}?{${.3,.3da,f,@(y5:xfo"
|
||||
"rm)[03},${.3a,@(y7:id->sym)[01},'(y6:define),l3]2}.0,'(y6:define)c,'(s"
|
||||
"20:improper define form),@(y7:x-error)[22",
|
||||
"%2${.2,@(y6:list2?)[01}?{.0au}{f}?{.1,.1da,f,@(y5:xform)[23}${.2,@(y6:"
|
||||
"list2?)[01}?{${.2a,@(y3:id?)[01}}{f}?{${.3,.3da,f,@(y5:xform)[03},${.3"
|
||||
"a,@(y7:id->sym)[01},'(y6:define),l3]2}.0,'(y6:define)c,'(s20:improper "
|
||||
"define form),@(y7:x-error)[22",
|
||||
|
||||
"P", "xform-define-syntax",
|
||||
"%2${.2,@(y6:list2?)[01}?{${.2a,@(y3:id?)[01}}{f}?{${.3,.3da,t,@(y5:xfo"
|
||||
|
|
@ -270,11 +294,12 @@ char *t_code[] = {
|
|||
"C", 0,
|
||||
"@(y30:denotation-of-default-ellipsis),'(y4:body),'(y4:body)c,'(y2:if),"
|
||||
"'(y2:if)c,'(y5:begin),'(y5:begin)c,'(y6:withcc),'(y6:withcc)c,'(y5:let"
|
||||
"cc),'(y5:letcc)c,'(y13:syntax-lambda),'(y13:syntax-lambda)c,'(y7:lambd"
|
||||
"a*),'(y7:lambda*)c,'(y6:lambda),'(y6:lambda)c,'(y4:set&),'(y4:set&)c,'"
|
||||
"(y4:set!),'(y4:set!)c,'(y5:quote),'(y5:quote)c,'(y13:define-syntax),'("
|
||||
"y13:define-syntax)c,'(y6:define),'(y6:define)c,'(y6:syntax),'(y6:synta"
|
||||
"x)c,l(i15)@!(y14:*transformers*)",
|
||||
"cc),'(y5:letcc)c,'(y12:syntax-error),'(y12:syntax-error)c,'(y13:syntax"
|
||||
"-length),'(y13:syntax-length)c,'(y13:syntax-lambda),'(y13:syntax-lambd"
|
||||
"a)c,'(y7:lambda*),'(y7:lambda*)c,'(y6:lambda),'(y6:lambda)c,'(y4:set&)"
|
||||
",'(y4:set&)c,'(y4:set!),'(y4:set!)c,'(y5:quote),'(y5:quote)c,'(y13:def"
|
||||
"ine-syntax),'(y13:define-syntax)c,'(y6:define),'(y6:define)c,'(y6:synt"
|
||||
"ax),'(y6:syntax)c,l(i17)@!(y14:*transformers*)",
|
||||
|
||||
"P", "top-transformer-env",
|
||||
"%1@(y14:*transformers*),.1A3,.0p?{.0d,.0p?{'(y12:syntax-rules),.1aq}{f"
|
||||
|
|
|
|||
Loading…
Reference in a new issue