Miroirs/skint
1
0
Fork 0
mirror of https://github.com/false-schemers/skint.git synced 2024-12-26 21:58:51 +01:00
Code Issues Projects Releases Packages Wiki Activity Actions

define-record-type, records added

Browse source
This commit is contained in:
ESL 2023-03-28 18:14:45 -04:00
parent d08bddc4c9
commit 149827f452
8 changed files with 3127 additions and 2625 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

182
i.c
View file

@ -180,7 +180,7 @@ static void _sck(obj *s) {
#define is_char(o) is_char_obj(o) #define is_char(o) is_char_obj(o)
#define get_char(o) char_from_obj(o) #define get_char(o) char_from_obj(o)
#define void_obj() obj_from_void(0) #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 null_obj() mknull()
#define is_null(o) isnull(o) #define is_null(o) isnull(o)
#define eof_obj() mkeof() #define eof_obj() mkeof()
@ -204,10 +204,16 @@ static void _sck(obj *s) {
#define is_circular(o) iscircular(o) #define is_circular(o) iscircular(o)
#define is_noncircular(o) (!iscircular(o)) #define is_noncircular(o) (!iscircular(o))
#define is_vector(o) isvector(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 string_obj(s) hp_pushptr((s), STRING_NTAG)
#define is_string(o) isstring(o) #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 bytevector_obj(s) hp_pushptr((s), BYTEVECTOR_NTAG)
#define is_bytevector(o) isbytevector(o) #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 iport_file_obj(fp) hp_pushptr((fp), IPORT_FILE_NTAG)
#define oport_file_obj(fp) hp_pushptr((fp), OPORT_FILE_NTAG) #define oport_file_obj(fp) hp_pushptr((fp), OPORT_FILE_NTAG)
#define iport_string_obj(fp) hp_pushptr((fp), IPORT_STRING_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_iport(o) isiport(o)
#define is_oport(o) isoport(o) #define is_oport(o) isoport(o)
#define is_box(o) isbox(o) #define is_box(o) isbox(o)
#define box_ref(o) boxref(o)
#define is_proc(o) isvmclo(o) #define is_proc(o) isvmclo(o)
#define is_tuple(o) (isrecord(o) && recordrtd(o) == 0) #define is_tuple(o) (isrecord(o) && recordrtd(o) == 0)
#define is_record(o) (isrecord(o) && recordrtd(o) != 0) #define is_record(o) (isrecord(o) && recordrtd(o) != 0)
#define record_rtd(o) recordrtd(o) #define record_rtd(o) recordrtd(o)
#define record_len(o) recordlen(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: */ /* cxi instructions protocol; retval is new hp: */
@ -561,12 +568,12 @@ define_instruction(gref) {
} }
define_instruction(iref) { define_instruction(iref) {
ac = boxref(ac); ac = box_ref(ac);
gonexti(); gonexti();
} }
define_instruction(iset) { define_instruction(iset) {
boxref(ac) = spop(); box_ref(ac) = spop();
gonexti(); gonexti();
} }
@ -618,13 +625,13 @@ define_instruction(andbo) {
define_instruction(sseti) { define_instruction(sseti) {
int i = get_fixnum(*ip++); int i = get_fixnum(*ip++);
boxref(sref(i)) = ac; box_ref(sref(i)) = ac;
gonexti(); gonexti();
} }
define_instruction(dseti) { define_instruction(dseti) {
int i = get_fixnum(*ip++); int i = get_fixnum(*ip++);
boxref(dref(i)) = ac; box_ref(dref(i)) = ac;
gonexti(); gonexti();
} }
@ -791,7 +798,7 @@ define_instruction(rck) {
define_instruction(save) { define_instruction(save) {
int dx = get_fixnum(*ip++); int dx = get_fixnum(*ip++);
spush(rd); spush(rd);
spush(fixnum_obj(ip + dx - &vectorref(vmcloref(rd, 0), 0))); spush(fixnum_obj(ip + dx - &vector_ref(vmcloref(rd, 0), 0)));
gonexti(); gonexti();
} }
@ -950,8 +957,17 @@ define_instruction(ise) {
gonexti(); gonexti();
} }
define_instruction(unbox) { ckz(ac); ac = boxref(ac); gonexti(); } define_instruction(unbox) {
define_instruction(setbox) { ckz(ac); boxref(ac) = spop(); gonexti(); } ckz(ac);
ac = box_ref(ac);
gonexti();
}
define_instruction(setbox) {
ckz(ac);
box_ref(ac) = spop();
gonexti();
}
define_instruction(box) { define_instruction(box) {
hp_reserve(boxbsz()); hp_reserve(boxbsz());
@ -1151,7 +1167,7 @@ define_instruction(smk) {
define_instruction(slen) { define_instruction(slen) {
cks(ac); cks(ac);
ac = fixnum_obj(stringlen(ac)); ac = fixnum_obj(string_len(ac));
gonexti(); gonexti();
} }
@ -1159,8 +1175,8 @@ define_instruction(sget) {
obj x = spop(); int i; obj x = spop(); int i;
cks(ac); ckk(x); cks(ac); ckk(x);
i = get_fixnum(x); i = get_fixnum(x);
if (i >= stringlen(ac)) failtype(x, "valid string index"); if (i >= string_len(ac)) failtype(x, "valid string index");
ac = char_obj(*stringref(ac, i)); ac = char_obj(string_ref(ac, i));
gonexti(); gonexti();
} }
@ -1168,8 +1184,8 @@ define_instruction(sput) {
obj x = spop(), y = spop(); int i; obj x = spop(), y = spop(); int i;
cks(ac); ckk(x); ckc(y); cks(ac); ckk(x); ckc(y);
i = get_fixnum(x); i = get_fixnum(x);
if (i >= stringlen(ac)) failtype(x, "valid string index"); if (i >= string_len(ac)) failtype(x, "valid string index");
*stringref(ac, i) = get_char(y); string_ref(ac, i) = get_char(y);
gonexti(); gonexti();
} }
@ -1186,7 +1202,7 @@ define_instruction(ssub) {
cks(ac); ckk(x); ckk(y); cks(ac); ckk(x); ckk(y);
is = get_fixnum(x), ie = get_fixnum(y); is = get_fixnum(x), ie = get_fixnum(y);
if (is > ie) failtype(x, "valid start string index"); 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); d = substring(stringdata(ac), is, ie);
ac = string_obj(d); ac = string_obj(d);
gonexti(); gonexti();
@ -1251,7 +1267,7 @@ define_instruction(bmk) {
define_instruction(blen) { define_instruction(blen) {
ckb(ac); ckb(ac);
ac = fixnum_obj(bytevectorlen(ac)); ac = fixnum_obj(bytevector_len(ac));
gonexti(); gonexti();
} }
@ -1259,8 +1275,8 @@ define_instruction(bget) {
obj x = spop(); int i; obj x = spop(); int i;
ckb(ac); ckk(x); ckb(ac); ckk(x);
i = get_fixnum(x); i = get_fixnum(x);
if (i >= bytevectorlen(ac)) failtype(x, "valid bytevector index"); if (i >= bytevector_len(ac)) failtype(x, "valid bytevector index");
ac = fixnum_obj(*bytevectorref(ac, i)); ac = fixnum_obj(bytevector_ref(ac, i));
gonexti(); gonexti();
} }
@ -1268,8 +1284,8 @@ define_instruction(bput) {
obj x = spop(), y = spop(); int i; obj x = spop(), y = spop(); int i;
ckb(ac); ckk(x); ck8(y); ckb(ac); ckk(x); ck8(y);
i = get_fixnum(x); i = get_fixnum(x);
if (i >= bytevectorlen(ac)) failtype(x, "valid bytevector index"); if (i >= bytevector_len(ac)) failtype(x, "valid bytevector index");
*bytevectorref(ac, i) = byte_from_obj(y); bytevector_ref(ac, i) = byte_from_obj(y);
gonexti(); gonexti();
} }
@ -1278,7 +1294,7 @@ define_instruction(bsub) {
ckb(ac); ckk(x); ckk(y); ckb(ac); ckk(x); ckk(y);
is = get_fixnum(x), ie = get_fixnum(y); is = get_fixnum(x), ie = get_fixnum(y);
if (is > ie) failtype(x, "valid start bytevector index"); 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); d = subbytevector(bytevectordata(ac), is, ie);
ac = bytevector_obj(d); ac = bytevector_obj(d);
gonexti(); gonexti();
@ -1290,8 +1306,54 @@ define_instruction(beq) {
gonexti(); gonexti();
} }
define_instruction(recp) { 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(); gonexti();
} }
@ -1322,7 +1384,7 @@ define_instruction(vmk) {
define_instruction(vlen) { define_instruction(vlen) {
ckv(ac); ckv(ac);
ac = fixnum_obj(vectorlen(ac)); ac = fixnum_obj(vector_len(ac));
gonexti(); gonexti();
} }
@ -1330,8 +1392,8 @@ define_instruction(vget) {
obj x = spop(); int i; obj x = spop(); int i;
ckv(ac); ckk(x); ckv(ac); ckk(x);
i = get_fixnum(x); i = get_fixnum(x);
if (i >= vectorlen(ac)) failtype(x, "valid vector index"); if (i >= vector_len(ac)) failtype(x, "valid vector index");
ac = vectorref(ac, i); ac = vector_ref(ac, i);
gonexti(); gonexti();
} }
@ -1339,19 +1401,19 @@ define_instruction(vput) {
obj x = spop(), y = spop(); int i; obj x = spop(), y = spop(); int i;
ckv(ac); ckk(x); ckv(ac); ckk(x);
i = get_fixnum(x); i = get_fixnum(x);
if (i >= vectorlen(ac)) failtype(x, "valid vector index"); if (i >= vector_len(ac)) failtype(x, "valid vector index");
vectorref(ac, i) = y; vector_ref(ac, i) = y;
gonexti(); gonexti();
} }
define_instruction(vcat) { define_instruction(vcat) {
obj x = ac, y = sref(0); int n1, n2, n; obj x = ac, y = sref(0); int n1, n2, n;
ckv(x); ckv(y); 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)); hp_reserve(vecbsz(n));
/* NB: vectorref fails to return pointer to empty vector's start */ /* NB: vector_ref fails to return pointer to empty vector's start */
hp -= n2; if (n2) memcpy(hp, &vectorref(y, 0), n2*sizeof(obj)); hp -= n2; if (n2) memcpy(hp, &vector_ref(y, 0), n2*sizeof(obj));
hp -= n1; if (n1) memcpy(hp, &vectorref(x, 0), n1*sizeof(obj)); hp -= n1; if (n1) memcpy(hp, &vector_ref(x, 0), n1*sizeof(obj));
ac = hend_vec(n); ac = hend_vec(n);
sdrop(1); sdrop(1);
gonexti(); gonexti();
@ -1359,10 +1421,10 @@ define_instruction(vcat) {
define_instruction(vtol) { define_instruction(vtol) {
obj l = null_obj(); int n; obj l = null_obj(); int n;
ckv(ac); n = vectorlen(ac); ckv(ac); n = vector_len(ac);
hp_reserve(pairbsz()*n); hp_reserve(pairbsz()*n);
while (n > 0) { while (n > 0) {
*--hp = l; *--hp = vectorref(ac, n-1); *--hp = l; *--hp = vector_ref(ac, n-1);
l = hend_pair(); l = hend_pair();
--n; --n;
} }
@ -1394,10 +1456,10 @@ define_instruction(ltob) {
define_instruction(stol) { define_instruction(stol) {
obj l = null_obj(); int n; obj l = null_obj(); int n;
cks(ac); n = stringlen(ac); cks(ac); n = string_len(ac);
hp_reserve(pairbsz()*n); hp_reserve(pairbsz()*n);
while (n > 0) { 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(); l = hend_pair();
--n; --n;
} }
@ -2874,6 +2936,16 @@ define_instruction(funp) {
gonexti(); gonexti();
} }
define_instruction(voidp) {
ac = bool_obj(is_void(ac));
gonexti();
}
define_instruction(void) {
ac = void_obj();
gonexti();
}
define_instruction(ipp) { define_instruction(ipp) {
ac = bool_obj(is_iport(ac)); ac = bool_obj(is_iport(ac));
gonexti(); 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(pushsref8) { ac = sref(8); spush(ac); gonexti(); }
define_instruction(pushsref9) { ac = sref(9); spush(ac); gonexti(); } define_instruction(pushsref9) { ac = sref(9); spush(ac); gonexti(); }
define_instruction(srefi0) { ac = boxref(sref(0)); gonexti(); } define_instruction(srefi0) { ac = box_ref(sref(0)); gonexti(); }
define_instruction(srefi1) { ac = boxref(sref(1)); gonexti(); } define_instruction(srefi1) { ac = box_ref(sref(1)); gonexti(); }
define_instruction(srefi2) { ac = boxref(sref(2)); gonexti(); } define_instruction(srefi2) { ac = box_ref(sref(2)); gonexti(); }
define_instruction(srefi3) { ac = boxref(sref(3)); gonexti(); } define_instruction(srefi3) { ac = box_ref(sref(3)); gonexti(); }
define_instruction(srefi4) { ac = boxref(sref(4)); gonexti(); } define_instruction(srefi4) { ac = box_ref(sref(4)); gonexti(); }
define_instruction(pushsrefi0) { ac = boxref(sref(0)); spush(ac); gonexti(); } define_instruction(pushsrefi0) { ac = box_ref(sref(0)); spush(ac); gonexti(); }
define_instruction(pushsrefi1) { ac = boxref(sref(1)); spush(ac); gonexti(); } define_instruction(pushsrefi1) { ac = box_ref(sref(1)); spush(ac); gonexti(); }
define_instruction(pushsrefi2) { ac = boxref(sref(2)); spush(ac); gonexti(); } define_instruction(pushsrefi2) { ac = box_ref(sref(2)); spush(ac); gonexti(); }
define_instruction(pushsrefi3) { ac = boxref(sref(3)); spush(ac); gonexti(); } define_instruction(pushsrefi3) { ac = box_ref(sref(3)); spush(ac); gonexti(); }
define_instruction(pushsrefi4) { ac = boxref(sref(4)); spush(ac); gonexti(); } define_instruction(pushsrefi4) { ac = box_ref(sref(4)); spush(ac); gonexti(); }
define_instruction(dref0) { ac = dref(0); gonexti(); } define_instruction(dref0) { ac = dref(0); gonexti(); }
define_instruction(dref1) { ac = dref(1); 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(pushdref3) { ac = dref(3); spush(ac); gonexti(); }
define_instruction(pushdref4) { ac = dref(4); spush(ac); gonexti(); } define_instruction(pushdref4) { ac = dref(4); spush(ac); gonexti(); }
define_instruction(drefi0) { ac = boxref(dref(0)); gonexti(); } define_instruction(drefi0) { ac = box_ref(dref(0)); gonexti(); }
define_instruction(drefi1) { ac = boxref(dref(1)); gonexti(); } define_instruction(drefi1) { ac = box_ref(dref(1)); gonexti(); }
define_instruction(drefi2) { ac = boxref(dref(2)); gonexti(); } define_instruction(drefi2) { ac = box_ref(dref(2)); gonexti(); }
define_instruction(drefi3) { ac = boxref(dref(3)); gonexti(); } define_instruction(drefi3) { ac = box_ref(dref(3)); gonexti(); }
define_instruction(drefi4) { ac = boxref(dref(4)); gonexti(); } define_instruction(drefi4) { ac = box_ref(dref(4)); gonexti(); }
define_instruction(pushdrefi0) { ac = boxref(dref(0)); spush(ac); gonexti(); } define_instruction(pushdrefi0) { ac = box_ref(dref(0)); spush(ac); gonexti(); }
define_instruction(pushdrefi1) { ac = boxref(dref(1)); spush(ac); gonexti(); } define_instruction(pushdrefi1) { ac = box_ref(dref(1)); spush(ac); gonexti(); }
define_instruction(pushdrefi2) { ac = boxref(dref(2)); spush(ac); gonexti(); } define_instruction(pushdrefi2) { ac = box_ref(dref(2)); spush(ac); gonexti(); }
define_instruction(pushdrefi3) { ac = boxref(dref(3)); spush(ac); gonexti(); } define_instruction(pushdrefi3) { ac = box_ref(dref(3)); spush(ac); gonexti(); }
define_instruction(pushdrefi4) { ac = boxref(dref(4)); spush(ac); gonexti(); } define_instruction(pushdrefi4) { ac = box_ref(dref(4)); spush(ac); gonexti(); }
define_instruction(call0) { define_instruction(call0) {
ckx(ac); rd = ac; rx = fixnum_obj(0); ac = fixnum_obj(0); ckx(ac); rd = ac; rx = fixnum_obj(0); ac = fixnum_obj(0);

8
i.h
View file

@ -438,6 +438,12 @@ declare_instruction(bget, "B4", 0, "bytevector-u8-ref",
declare_instruction(bput, "B5", 0, "bytevector-u8-set!", '3', AUTOGL) declare_instruction(bput, "B5", 0, "bytevector-u8-set!", '3', AUTOGL)
declare_instruction(bsub, "B7", 0, "subbytevector", '3', AUTOGL) declare_instruction(bsub, "B7", 0, "subbytevector", '3', AUTOGL)
declare_instruction(beq, "B=", 0, "bytevector=?", 'c', 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(vtol, "X0", 0, "%vector->list1", '1', AUTOGL)
declare_instruction(ltov, "X1", 0, "list->vector", '1', AUTOGL) declare_instruction(ltov, "X1", 0, "list->vector", '1', AUTOGL)
declare_instruction(stol, "X2", 0, "%string->list1", '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(symp, "Y0", 0, "symbol?", '1', AUTOGL)
declare_instruction(boolp, "Y1", 0, "boolean?", '1', AUTOGL) declare_instruction(boolp, "Y1", 0, "boolean?", '1', AUTOGL)
declare_instruction(boxp, "Y2", 0, "box?", '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(funp, "K0", 0, "procedure?", '1', AUTOGL)
declare_instruction(ipp, "P00", 0, "input-port?", '1', AUTOGL) declare_instruction(ipp, "P00", 0, "input-port?", '1', AUTOGL)
declare_instruction(opp, "P01", 0, "output-port?", '1', AUTOGL) declare_instruction(opp, "P01", 0, "output-port?", '1', AUTOGL)

5216
k.c
View file

File diff suppressed because it is too large Load diff

50
s.c
View file

@ -171,6 +171,56 @@ char *s_code[] = {
"l3:y12:syntax-rules;n;l2:l2:y1:_;y1:x;;l2:y11:delay-force;l2:y12:make-" "l3:y12:syntax-rules;n;l2:l2:y1:_;y1:x;;l2:y11:delay-force;l2:y12:make-"
"promise;y1:x;;;;", "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/", "P", "floor/",
"%2.1,.1Nm,.2,.2Nl,@(y6:values)[22", "%2.1,.1Nm,.2,.2Nl,@(y6:values)[22",

29
src/k.sf
View file

@ -299,12 +299,21 @@
[(body) (xform-body tail env)] [(body) (xform-body tail env)]
[(define) (xform-define tail env)] [(define) (xform-define tail env)]
[(define-syntax) (xform-define-syntax 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) [else (if (integrable? hval)
(xform-integrable hval tail env) (xform-integrable hval tail env)
(if (procedure? hval) (if (procedure? hval)
(xform appos? (hval sexp env) env) (xform appos? (hval sexp env) env)
(xform-call hval tail 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) (define (xform-ref id env)
(let ([den (env id)]) (let ([den (env id)])
(cond [(symbol? den) (list 'ref den)] (cond [(symbol? den) (list 'ref den)]
@ -312,14 +321,20 @@
(define (xform-quote tail env) (define (xform-quote tail env)
(if (list1? tail) (if (list1? tail)
(list 'quote (list 'quote (xform-sexp->datum (car tail)))
(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])))
(x-error "improper quote form" (cons 'quote 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) (define (xform-set! tail env)
(if (and (list2? tail) (id? (car tail))) (if (and (list2? tail) (id? (car tail)))
(let ([den (env (car tail))] [xexp (xform #f (cadr tail) env)]) (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 'lambda* 'lambda*) (make-binding 'lambda* 'lambda*)
(make-binding 'syntax-lambda 'syntax-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 'letcc 'letcc)
(make-binding 'withcc 'withcc) (make-binding 'withcc 'withcc)
(make-binding 'begin 'begin) (make-binding 'begin 'begin)

73
src/s.scm
View file

@ -222,6 +222,79 @@
(syntax-rules () [(_ x) (delay-force (make-promise x))])) (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 ; Equivalence predicates
;--------------------------------------------------------------------------------------------- ;---------------------------------------------------------------------------------------------

109
src/t.scm
View file

@ -263,12 +263,21 @@
[(body) (xform-body tail env)] [(body) (xform-body tail env)]
[(define) (xform-define tail env)] [(define) (xform-define tail env)]
[(define-syntax) (xform-define-syntax 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) [else (if (integrable? hval)
(xform-integrable hval tail env) (xform-integrable hval tail env)
(if (procedure? hval) (if (procedure? hval)
(xform appos? (hval sexp env) env) (xform appos? (hval sexp env) env)
(xform-call hval tail 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) (define (xform-ref id env)
(let ([den (env id)]) (let ([den (env id)])
(cond [(symbol? den) (list 'ref den)] (cond [(symbol? den) (list 'ref den)]
@ -276,14 +285,20 @@
(define (xform-quote tail env) (define (xform-quote tail env)
(if (list1? tail) (if (list1? tail)
(list 'quote (list 'quote (xform-sexp->datum (car tail)))
(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])))
(x-error "improper quote form" (cons 'quote 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) (define (xform-set! tail env)
(if (and (list2? tail) (id? (car tail))) (if (and (list2? tail) (id? (car tail)))
(let ([den (env (car tail))] [xexp (xform #f (cadr tail) env)]) (let ([den (env (car tail))] [xexp (xform #f (cadr tail) env)])
@ -335,7 +350,7 @@
(case igt (case igt
[(#\0) (= n 0)] [(#\1) (= n 1)] [(#\2) (= n 2)] [(#\3) (= n 3)] [(#\0) (= n 0)] [(#\1) (= n 1)] [(#\2) (= n 2)] [(#\3) (= n 3)]
[(#\p) (>= n 0)] [(#\m) (>= n 1)] [(#\c) (>= n 2)] [(#\x) (>= n 1)] [(#\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] [(#\#) (>= n 0)] [(#\@) #f]
[else #f])) [else #f]))
@ -403,41 +418,53 @@
(x-error "improper withcc form" (cons 'withcc tail)))) (x-error "improper withcc form" (cons 'withcc tail))))
(define (xform-body tail env) (define (xform-body tail env)
(if (null? tail) (cond
(list 'begin) [(null? tail)
(let loop ([env env] [ids '()] [inits '()] [nids '()] [body tail]) (list 'begin)]
(if (and (pair? body) (pair? (car body))) [(not (list? tail))
(let ([first (car body)] [rest (cdr body)]) (x-error "improper body form" (cons 'body tail))]
(let* ([head (car first)] [hval (xform #t head env)]) [else
(case hval (let loop ([env env] [ids '()] [inits '()] [nids '()] [body tail])
[(begin) (if (and (pair? body) (pair? (car body)))
(loop env ids inits nids (append (cdr first) rest))] (let ([first (car body)] [rest (cdr body)])
[(define) (let* ([head (car first)] [tail (cdr first)] [hval (xform #t head env)])
(let* ([id (cadr first)] [init (caddr first)] (case hval
[nid (gensym (id->sym id))] [env (add-var id nid env)]) [(begin)
(loop env (cons id ids) (cons init inits) (cons nid nids) rest))] (if (list? tail)
[(define-syntax) (loop env ids inits nids (append tail rest))
(let* ([id (cadr first)] [init (caddr first)] (x-error "improper begin form" first))]
[env (add-binding id '(undefined) env)]) [(define)
(loop env (cons id ids) (cons init inits) (cons #t nids) rest))] (if (and (list2? tail) (null? (car tail)))
[else (let ([init (cadr tail)]) ; idless
(if (procedure? hval) (loop env (cons #f ids) (cons init inits) (cons #f nids) rest))
(loop env ids inits nids (cons (hval first env) rest)) (if (and (list2? tail) (id? (car tail)))
(xform-labels (reverse ids) (reverse inits) (reverse nids) body env))]))) (let* ([id (car tail)] [init (cadr tail)]
(xform-labels (reverse ids) (reverse inits) (reverse nids) body env))))) [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) (define (xform-labels ids inits nids body env)
(let loop ([ids ids] [inits inits] [nids nids] [sets '()] [lids '()]) (let loop ([ids ids] [inits inits] [nids nids] [sets '()] [lids '()])
(cond [(null? ids) (cond [(null? ids)
(let* ([xexps (append (reverse sets) (let* ([xexps (append (reverse sets) (map (lambda (x) (xform #f x env)) body))]
(map (lambda (sexp) (xform #f sexp env)) body))] [xexp (if (list1? xexps) (car xexps) (cons 'begin xexps))])
[xexp (if (and (pair? xexps) (null? (cdr xexps))) (if (null? lids) xexp
(car xexps)
(cons 'begin xexps))])
(if (null? lids)
xexp
(pair* 'call (list 'lambda (reverse lids) xexp) (pair* 'call (list 'lambda (reverse lids) xexp)
(map (lambda (lid) '(begin)) lids))))] (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 [(symbol? (car nids)) ; define
(loop (cdr ids) (cdr inits) (cdr nids) (loop (cdr ids) (cdr inits) (cdr nids)
(cons (xform-set! (list (car ids) (car inits)) env) sets) (cons (xform-set! (list (car ids) (car inits)) env) sets)
@ -447,9 +474,11 @@
(loop (cdr ids) (cdr inits) (cdr nids) sets lids)]))) (loop (cdr ids) (cdr inits) (cdr nids) sets lids)])))
(define (xform-define tail env) ; top-level only (define (xform-define tail env) ; top-level only
(if (and (list2? tail) (id? (car tail))) (if (and (list2? tail) (null? (car tail))) ; idless
(list 'define (id->sym (car tail)) (xform #f (cadr tail) env)) (xform #f (cadr tail) env)
(x-error "improper define form" (cons 'define tail)))) (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 (define (xform-define-syntax tail env) ; top-level only
(if (and (list2? tail) (id? (car tail))) (if (and (list2? tail) (id? (car tail)))
@ -473,6 +502,8 @@
(make-binding 'lambda 'lambda) (make-binding 'lambda 'lambda)
(make-binding 'lambda* 'lambda*) (make-binding 'lambda* 'lambda*)
(make-binding 'syntax-lambda 'syntax-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 'letcc 'letcc)
(make-binding 'withcc 'withcc) (make-binding 'withcc 'withcc)
(make-binding 'begin 'begin) (make-binding 'begin 'begin)

85
t.c
View file

@ -144,18 +144,32 @@ char *t_code[] = {
".3,@(y19:xform-syntax-lambda)[72}'(y5:letcc),.1v?{.6,.3,@(y11:xform-le" ".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?" "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" "{.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" ")[72}'(y13:define-syntax),.1v?{.6,.3,@(y19:xform-define-syntax)[72}'(y"
"0?{.6,.3,.3,@(y16:xform-integrable)[73}.1K0?{.6,${.9,.9,.6[02},.6,@(y5" "13:syntax-length),.1v?{.6,.3,@(y19:xform-syntax-length)[72}'(y12:synta"
":xform)[73}.6,.3,.3,@(y10:xform-call)[73", "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", "P", "xform-ref",
"%2${.2,.4[01},.0Y0?{.0,'(y3:ref),l2]3}.0d]3", "%2${.2,.4[01},.0Y0?{.0,'(y3:ref),l2]3}.0d]3",
"P", "xform-quote", "P", "xform-quote",
"%2${.2,@(y6:list1?)[01}?{${.2a,,#0.0,&1{%1${.2,@(y3:id?)[01}?{.0,@(y7:" "%2${.2,@(y6:list1?)[01}?{${.2a,@(y17:xform-sexp->datum)[01},'(y5:quote"
"id->sym)[11}.0p?{${.2d,:0^[01},${.3a,:0^[01}c]1}.0V0?{${.2X0,:0^,@(y5:" "),l2]2}.0,'(y5:quote)c,'(s19:improper quote form),@(y7:x-error)[22",
"%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", "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!", "P", "xform-set!",
"%2${.2,@(y6:list2?)[01}?{${.2a,@(y3:id?)[01}}{f}?{${.3,.3da,f,@(y5:xfo" "%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)" "%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" ",.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<!]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", "P", "xform-integrable",
"%3${.3g,.3U6,@(y22:integrable-argc-match?)[02}?{${.3,.5,&1{%1:0,.1,f,@" "%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", " form),@(y7:x-error)[22",
"P", "xform-body", "P", "xform-body",
"%2.0u?{'(y5:begin),l1]2}.0,n,n,n,.5,,#0.0,&1{%5.4p?{.4ap}{f}?{.4d,.5a," "%2.0u?{'(y5:begin),l1]2}.0L0~?{.0,'(y4:body)c,'(s18:improper body form"
".0a,${.5,.3,t,@(y5:xform)[03},.0,'(y5:begin),.1v?{.4,.4dL6,.9,.9,.9,.9" "),@(y7:x-error)[22}.0,n,n,n,.5,,#0.0,&1{%5.4p?{.4ap}{f}?{.4d,.5a,.0a,."
",:0^[(i10)5}'(y6:define),.1v?{.3da,.4dda,${${.5,@(y7:id->sym)[01},@(y6" "1d,${.6,.4,t,@(y5:xform)[03},.0,'(y5:begin),.1v?{.2L0?{.5,.3L6,.(i10),"
":gensym)[01},${.(i10),.3,.6,@(y7:add-var)[03},.8,.(i13),.3c,.(i13),.5c" ".(i10),.(i10),.(i10),:0^[(i11)5}.4,'(s19:improper begin form),@(y7:x-e"
",.(i13),.7c,.4,:0^[(i14)5}'(y13:define-syntax),.1v?{.3da,.4dda,${.9,'(" "rror)[(i11)2}'(y6:define),.1v?{${.4,@(y6:list2?)[01}?{.2au}{f}?{.2da,."
"l1:y9:undefined;),.5,@(y11:add-binding)[03},.7,.(i12),tc,.(i12),.4c,.(" "6,.(i11),fc,.(i11),.3c,.(i11),fc,.(i11),:0^[(i12)5}${.4,@(y6:list2?)[0"
"i12),.6c,.4,:0^[(i13)5}.1K0?{.4,${.8,.7,.6[02}c,.9,.9,.9,.9,:0^[(i10)5" "1}?{${.4a,@(y3:id?)[01}}{f}?{.2a,.3da,${${.5,@(y7:id->sym)[01},@(y6:ge"
"}.5,.(i10),.(i10)A8,.(i10)A8,.(i10)A8,@(y12:xform-labels)[(i10)5}.0,.5" "nsym)[01},${.(i11),.3,.6,@(y7:add-var)[03},.9,.(i14),.3c,.(i14),.5c,.("
",.5A8,.5A8,.5A8,@(y12:xform-labels)[55}.!0.0^_1[25", "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", "P", "xform-labels",
"%5n,n,.4,.4,.4,,#0.0,.(i11),.(i11),&3{%5.0u?{${:0,:1,&1{%1:0,.1,f,@(y5" "%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" ":xform)[13},@(y5:%25map1)[02},.4A8L6,${.2,@(y6:list1?)[01}?{.0a}{.0,'("
")c},.6u?{.0]7}${.8,&0{%1'(l1:y5:begin;)]1},@(y5:%25map1)[02},.1,.8A8,'" "y5:begin)c},.6u?{.0]7}${.8,&0{%1'(l1:y5:begin;)]1},@(y5:%25map1)[02},."
"(y6:lambda),l3,'(y4:call),@(y5:pair*)[73}.2aY0?{.4,.3ac,.4,${:1,.6a,.6" "1,.8A8,'(y6:lambda),l3,'(y4:call),@(y5:pair*)[73}.0a~?{.4,.4,${:1,.6a,"
"a,l2,@(y10:xform-set!)[02}c,.4d,.4d,.4d,:2^[55}${:1,.4a,t,@(y5:xform)[" "f,@(y5:xform)[03}c,.4d,.4d,.4d,:2^[55}.2aY0?{.4,.3ac,.4,${:1,.6a,.6a,l"
"03},${.3a,:1[01}sd.4,.4,.4d,.4d,.4d,:2^[55}.!0.0^_1[55", "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", "P", "xform-define",
"%2${.2,@(y6:list2?)[01}?{${.2a,@(y3:id?)[01}}{f}?{${.3,.3da,f,@(y5:xfo" "%2${.2,@(y6:list2?)[01}?{.0au}{f}?{.1,.1da,f,@(y5:xform)[23}${.2,@(y6:"
"rm)[03},${.3a,@(y7:id->sym)[01},'(y6:define),l3]2}.0,'(y6:define)c,'(s" "list2?)[01}?{${.2a,@(y3:id?)[01}}{f}?{${.3,.3da,f,@(y5:xform)[03},${.3"
"20:improper define form),@(y7:x-error)[22", "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", "P", "xform-define-syntax",
"%2${.2,@(y6:list2?)[01}?{${.2a,@(y3:id?)[01}}{f}?{${.3,.3da,t,@(y5:xfo" "%2${.2,@(y6:list2?)[01}?{${.2a,@(y3:id?)[01}}{f}?{${.3,.3da,t,@(y5:xfo"
@ -270,11 +294,12 @@ char *t_code[] = {
"C", 0, "C", 0,
"@(y30:denotation-of-default-ellipsis),'(y4:body),'(y4:body)c,'(y2:if)," "@(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" "'(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" "cc),'(y5:letcc)c,'(y12:syntax-error),'(y12:syntax-error)c,'(y13:syntax"
"a*),'(y7:lambda*)c,'(y6:lambda),'(y6:lambda)c,'(y4:set&),'(y4:set&)c,'" "-length),'(y13:syntax-length)c,'(y13:syntax-lambda),'(y13:syntax-lambd"
"(y4:set!),'(y4:set!)c,'(y5:quote),'(y5:quote)c,'(y13:define-syntax),'(" "a)c,'(y7:lambda*),'(y7:lambda*)c,'(y6:lambda),'(y6:lambda)c,'(y4:set&)"
"y13:define-syntax)c,'(y6:define),'(y6:define)c,'(y6:syntax),'(y6:synta" ",'(y4:set&)c,'(y4:set!),'(y4:set!)c,'(y5:quote),'(y5:quote)c,'(y13:def"
"x)c,l(i15)@!(y14:*transformers*)", "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", "P", "top-transformer-env",
"%1@(y14:*transformers*),.1A3,.0p?{.0d,.0p?{'(y12:syntax-rules),.1aq}{f" "%1@(y14:*transformers*),.1A3,.0p?{.0d,.0p?{'(y12:syntax-rules),.1aq}{f"