mirror of
https://github.com/false-schemers/skint.git
synced 2024-09-28 03:20:44 +02:00
initial commit
This commit is contained in:
ESL
parent
f25fc68ce2
commit
764e925c7a
9 changed files with 49473 additions and 0 deletions
472
i.h
Normal file
472
i.h
Normal file
|
|
@ -0,0 +1,472 @@
|
|||
/* i.h -- instructions */
|
||||
|
||||
#ifndef glue
|
||||
#define glue(a, b) a##b
|
||||
#endif
|
||||
#ifndef AUTOGL
|
||||
#define AUTOGL NULL
|
||||
#endif
|
||||
#ifndef INLINED
|
||||
#define INLINED ""
|
||||
#endif
|
||||
|
||||
#if defined(VM_GEN_DEFGLOBAL)
|
||||
#define declare_instruction(name, enc, etyp, igname, arity, lcode) \
|
||||
declare_instruction_global(name)
|
||||
#define declare_instrshadow(name, enc, etyp, igname, arity, lcode)
|
||||
#define declare_integrable(name, enc, etyp, igname, arity, lcode)
|
||||
#elif defined(VM_GEN_ENCTABLE)
|
||||
#define declare_instruction(name, enc, etyp, igname, arity, lcode) \
|
||||
declare_enctable_entry(name, enc, etyp)
|
||||
#define declare_instrshadow(name, enc, etyp, igname, arity, lcode) \
|
||||
declare_enctable_entry(name, enc, etyp)
|
||||
#define declare_integrable(name, enc, etyp, igname, arity, lcode)
|
||||
#elif defined(VM_GEN_INTGTABLE)
|
||||
#define declare_instruction(name, enc, etyp, igname, arity, lcode) \
|
||||
declare_intgtable_entry(enc, igname, arity, lcode)
|
||||
#define declare_instrshadow(name, enc, etyp, igname, arity, lcode) \
|
||||
declare_intgtable_entry(enc, igname, arity, lcode)
|
||||
#define declare_integrable(name, enc, etyp, igname, arity, lcode) \
|
||||
declare_intgtable_entry(enc, igname, arity, lcode)
|
||||
#else /* regular include */
|
||||
#define declare_instruction(name, enc, etyp, igname, arity, lcode) \
|
||||
extern obj glue(cx_ins_2D, name);
|
||||
#define declare_instrshadow(name, enc, etyp, igname, arity, lcode)
|
||||
#define declare_integrable(name, enc, etyp, igname, arity, lcode)
|
||||
extern obj vmcases[]; /* vm host */
|
||||
#endif
|
||||
|
||||
/* basic vm machinery */
|
||||
declare_instruction(halt, NULL, 0, NULL, 0, NULL)
|
||||
declare_instruction(litf, "f", 0, NULL, 0, NULL)
|
||||
declare_instruction(litt, "t", 0, NULL, 0, NULL)
|
||||
declare_instruction(litn, "n", 0, NULL, 0, NULL)
|
||||
declare_instruction(lit, "'", 1, NULL, 0, NULL)
|
||||
declare_instruction(sref, ".", 1, NULL, 0, NULL)
|
||||
declare_instruction(dref, ":", 1, NULL, 0, NULL)
|
||||
declare_instruction(gref, "@", 'g', NULL, 0, NULL)
|
||||
declare_instruction(indirect, "^", 0, NULL, 0, NULL)
|
||||
declare_instruction(dclose, "&", 'd', NULL, 0, NULL)
|
||||
declare_instruction(sbox, "#", 1, NULL, 0, NULL)
|
||||
declare_instruction(br, NULL, 'b', NULL, 0, NULL)
|
||||
declare_instruction(brnot, "?", 'b', NULL, 0, NULL)
|
||||
declare_instruction(brt, "~?", 'b', NULL, 0, NULL)
|
||||
declare_instruction(sseti, ".!", 1, NULL, 0, NULL)
|
||||
declare_instruction(dseti, ":!", 1, NULL, 0, NULL)
|
||||
declare_instruction(gset, "@!", 'g', NULL, 0, NULL)
|
||||
declare_instruction(conti, "K1", 0, NULL, 0, NULL)
|
||||
declare_instruction(nuate, "K2", 0, NULL, 0, NULL)
|
||||
declare_instruction(appl, "K3", 0, NULL, 0, NULL)
|
||||
declare_instruction(save, "$", 's', NULL, 0, NULL)
|
||||
declare_instruction(push, ",", 0, NULL, 0, NULL)
|
||||
declare_instruction(call, "[0", 1, NULL, 0, NULL)
|
||||
declare_instruction(scall, "[", 2, NULL, 0, NULL)
|
||||
declare_instruction(return, "]0", 0, NULL, 0, NULL)
|
||||
declare_instruction(sreturn, "]", 1, NULL, 0, NULL)
|
||||
declare_instruction(adrop, "_", 1, NULL, 0, NULL)
|
||||
declare_instruction(pop, "_!", 0, NULL, 0, NULL)
|
||||
declare_instruction(atest, "%", 1, NULL, 0, NULL)
|
||||
declare_instruction(shrarg, "%!", 1, NULL, 0, NULL)
|
||||
|
||||
/* popular instruction combos */
|
||||
declare_instruction(shlit, ",'", 1, NULL, 0, NULL)
|
||||
declare_instruction(shi0, ",'0", 0, NULL, 0, NULL)
|
||||
declare_instruction(pushlitf, "f,", 0, NULL, 0, NULL)
|
||||
declare_instruction(pushlitt, "t,", 0, NULL, 0, NULL)
|
||||
declare_instruction(pushlitn, "n,", 0, NULL, 0, NULL)
|
||||
declare_instruction(lit0, "'0", 0, NULL, 0, NULL)
|
||||
declare_instruction(lit1, "'1", 0, NULL, 0, NULL)
|
||||
declare_instruction(lit2, "'2", 0, NULL, 0, NULL)
|
||||
declare_instruction(lit3, "'3", 0, NULL, 0, NULL)
|
||||
declare_instruction(lit4, "'4", 0, NULL, 0, NULL)
|
||||
declare_instruction(lit5, "'5", 0, NULL, 0, NULL)
|
||||
declare_instruction(lit6, "'6", 0, NULL, 0, NULL)
|
||||
declare_instruction(lit7, "'7", 0, NULL, 0, NULL)
|
||||
declare_instruction(lit8, "'8", 0, NULL, 0, NULL)
|
||||
declare_instruction(lit9, "'9", 0, NULL, 0, NULL)
|
||||
declare_instruction(pushlit0, "'0,", 0, NULL, 0, NULL)
|
||||
declare_instruction(pushlit1, "'1,", 0, NULL, 0, NULL)
|
||||
declare_instruction(pushlit2, "'2,", 0, NULL, 0, NULL)
|
||||
declare_instruction(pushlit3, "'3,", 0, NULL, 0, NULL)
|
||||
declare_instruction(pushlit4, "'4,", 0, NULL, 0, NULL)
|
||||
declare_instruction(pushlit5, "'5,", 0, NULL, 0, NULL)
|
||||
declare_instruction(pushlit6, "'6,", 0, NULL, 0, NULL)
|
||||
declare_instruction(pushlit7, "'7,", 0, NULL, 0, NULL)
|
||||
declare_instruction(pushlit8, "'8,", 0, NULL, 0, NULL)
|
||||
declare_instruction(pushlit9, "'9,", 0, NULL, 0, NULL)
|
||||
|
||||
declare_instruction(sref0, ".0", 0, NULL, 0, NULL)
|
||||
declare_instruction(sref1, ".1", 0, NULL, 0, NULL)
|
||||
declare_instruction(sref2, ".2", 0, NULL, 0, NULL)
|
||||
declare_instruction(sref3, ".3", 0, NULL, 0, NULL)
|
||||
declare_instruction(sref4, ".4", 0, NULL, 0, NULL)
|
||||
declare_instruction(sref5, ".5", 0, NULL, 0, NULL)
|
||||
declare_instruction(sref6, ".6", 0, NULL, 0, NULL)
|
||||
declare_instruction(sref7, ".7", 0, NULL, 0, NULL)
|
||||
declare_instruction(sref8, ".8", 0, NULL, 0, NULL)
|
||||
declare_instruction(sref9, ".9", 0, NULL, 0, NULL)
|
||||
declare_instruction(pushsref0, ".0,", 0, NULL, 0, NULL)
|
||||
declare_instruction(pushsref1, ".1,", 0, NULL, 0, NULL)
|
||||
declare_instruction(pushsref2, ".2,", 0, NULL, 0, NULL)
|
||||
declare_instruction(pushsref3, ".3,", 0, NULL, 0, NULL)
|
||||
declare_instruction(pushsref4, ".4,", 0, NULL, 0, NULL)
|
||||
declare_instruction(pushsref5, ".5,", 0, NULL, 0, NULL)
|
||||
declare_instruction(pushsref6, ".6,", 0, NULL, 0, NULL)
|
||||
declare_instruction(pushsref7, ".7,", 0, NULL, 0, NULL)
|
||||
declare_instruction(pushsref8, ".8,", 0, NULL, 0, NULL)
|
||||
declare_instruction(pushsref9, ".9,", 0, NULL, 0, NULL)
|
||||
|
||||
declare_instruction(srefi0, ".0^", 0, NULL, 0, NULL)
|
||||
declare_instruction(srefi1, ".1^", 0, NULL, 0, NULL)
|
||||
declare_instruction(srefi2, ".2^", 0, NULL, 0, NULL)
|
||||
declare_instruction(srefi3, ".3^", 0, NULL, 0, NULL)
|
||||
declare_instruction(srefi4, ".4^", 0, NULL, 0, NULL)
|
||||
declare_instruction(pushsrefi0, ".0^,", 0, NULL, 0, NULL)
|
||||
declare_instruction(pushsrefi1, ".1^,", 0, NULL, 0, NULL)
|
||||
declare_instruction(pushsrefi2, ".2^,", 0, NULL, 0, NULL)
|
||||
declare_instruction(pushsrefi3, ".3^,", 0, NULL, 0, NULL)
|
||||
declare_instruction(pushsrefi4, ".4^,", 0, NULL, 0, NULL)
|
||||
|
||||
declare_instruction(dref0, ":0", 0, NULL, 0, NULL)
|
||||
declare_instruction(dref1, ":1", 0, NULL, 0, NULL)
|
||||
declare_instruction(dref2, ":2", 0, NULL, 0, NULL)
|
||||
declare_instruction(dref3, ":3", 0, NULL, 0, NULL)
|
||||
declare_instruction(dref4, ":4", 0, NULL, 0, NULL)
|
||||
declare_instruction(pushdref0, ":0,", 0, NULL, 0, NULL)
|
||||
declare_instruction(pushdref1, ":1,", 0, NULL, 0, NULL)
|
||||
declare_instruction(pushdref2, ":2,", 0, NULL, 0, NULL)
|
||||
declare_instruction(pushdref3, ":3,", 0, NULL, 0, NULL)
|
||||
declare_instruction(pushdref4, ":4,", 0, NULL, 0, NULL)
|
||||
|
||||
declare_instruction(drefi0, ":0^", 0, NULL, 0, NULL)
|
||||
declare_instruction(drefi1, ":1^", 0, NULL, 0, NULL)
|
||||
declare_instruction(drefi2, ":2^", 0, NULL, 0, NULL)
|
||||
declare_instruction(drefi3, ":3^", 0, NULL, 0, NULL)
|
||||
declare_instruction(drefi4, ":4^", 0, NULL, 0, NULL)
|
||||
declare_instruction(pushdrefi0, ":0^,", 0, NULL, 0, NULL)
|
||||
declare_instruction(pushdrefi1, ":1^,", 0, NULL, 0, NULL)
|
||||
declare_instruction(pushdrefi2, ":2^,", 0, NULL, 0, NULL)
|
||||
declare_instruction(pushdrefi3, ":3^,", 0, NULL, 0, NULL)
|
||||
declare_instruction(pushdrefi4, ":4^,", 0, NULL, 0, NULL)
|
||||
|
||||
declare_instruction(call0, "[00", 0, NULL, 0, NULL)
|
||||
declare_instruction(call1, "[01", 0, NULL, 0, NULL)
|
||||
declare_instruction(call2, "[02", 0, NULL, 0, NULL)
|
||||
declare_instruction(call3, "[03", 0, NULL, 0, NULL)
|
||||
declare_instruction(call4, "[04", 0, NULL, 0, NULL)
|
||||
|
||||
declare_instruction(scall10, "[10", 0, NULL, 0, NULL)
|
||||
declare_instruction(scall11, "[11", 0, NULL, 0, NULL)
|
||||
declare_instruction(scall12, "[12", 0, NULL, 0, NULL)
|
||||
declare_instruction(scall13, "[13", 0, NULL, 0, NULL)
|
||||
declare_instruction(scall14, "[14", 0, NULL, 0, NULL)
|
||||
declare_instruction(scall20, "[20", 0, NULL, 0, NULL)
|
||||
declare_instruction(scall21, "[21", 0, NULL, 0, NULL)
|
||||
declare_instruction(scall22, "[22", 0, NULL, 0, NULL)
|
||||
declare_instruction(scall23, "[23", 0, NULL, 0, NULL)
|
||||
declare_instruction(scall24, "[24", 0, NULL, 0, NULL)
|
||||
declare_instruction(scall30, "[30", 0, NULL, 0, NULL)
|
||||
declare_instruction(scall31, "[31", 0, NULL, 0, NULL)
|
||||
declare_instruction(scall32, "[32", 0, NULL, 0, NULL)
|
||||
declare_instruction(scall33, "[33", 0, NULL, 0, NULL)
|
||||
declare_instruction(scall34, "[34", 0, NULL, 0, NULL)
|
||||
declare_instruction(scall40, "[40", 0, NULL, 0, NULL)
|
||||
declare_instruction(scall41, "[41", 0, NULL, 0, NULL)
|
||||
declare_instruction(scall42, "[42", 0, NULL, 0, NULL)
|
||||
declare_instruction(scall43, "[43", 0, NULL, 0, NULL)
|
||||
declare_instruction(scall44, "[44", 0, NULL, 0, NULL)
|
||||
|
||||
declare_instruction(sreturn1, "]1", 0, NULL, 0, NULL)
|
||||
declare_instruction(sreturn2, "]2", 0, NULL, 0, NULL)
|
||||
declare_instruction(sreturn3, "]3", 0, NULL, 0, NULL)
|
||||
declare_instruction(sreturn4, "]4", 0, NULL, 0, NULL)
|
||||
|
||||
declare_instruction(atest0, "%0", 0, NULL, 0, NULL)
|
||||
declare_instruction(atest1, "%1", 0, NULL, 0, NULL)
|
||||
declare_instruction(atest2, "%2", 0, NULL, 0, NULL)
|
||||
declare_instruction(atest3, "%3", 0, NULL, 0, NULL)
|
||||
declare_instruction(atest4, "%4", 0, NULL, 0, NULL)
|
||||
|
||||
declare_instruction(brnotlt, "<?", 'b', NULL, 0, NULL)
|
||||
declare_instruction(pushsub, "-,", 0, NULL, 0, NULL)
|
||||
|
||||
/* type checks */
|
||||
declare_instruction(ckp, "%p", 0, "%ckp", 1, INLINED)
|
||||
declare_instruction(ckl, "%l", 0, "%ckl", 1, INLINED)
|
||||
declare_instruction(ckv, "%v", 0, "%ckv", 1, INLINED)
|
||||
declare_instruction(ckc, "%c", 0, "%ckc", 1, INLINED)
|
||||
declare_instruction(cks, "%s", 0, "%cks", 1, INLINED)
|
||||
declare_instruction(cki, "%i", 0, "%cki", 1, INLINED)
|
||||
declare_instruction(ckj, "%j", 0, "%ckj", 1, INLINED)
|
||||
declare_instruction(ckn, "%n", 0, "%ckn", 1, INLINED)
|
||||
declare_instruction(ckk, "%k", 0, "%ckk", 1, INLINED)
|
||||
declare_instruction(cky, "%y", 0, "%cky", 1, INLINED)
|
||||
declare_instruction(ckr, "%r", 0, "%ckr", 1, INLINED)
|
||||
declare_instruction(ckw, "%w", 0, "%ckw", 1, INLINED)
|
||||
declare_instruction(ckx, "%x", 0, "%ckx", 1, INLINED)
|
||||
|
||||
/* type checks-adapters */
|
||||
declare_instruction(cknj, "%z", 0, "%cknj", 1, INLINED)
|
||||
|
||||
/* intrinsics (no arg checks), integrables and globals */
|
||||
declare_instruction(isq, "q", 0, "%isq", 2, INLINED)
|
||||
declare_instruction(isv, "v", 0, "%isv", 2, INLINED)
|
||||
declare_instruction(ise, "e", 0, "%ise", 2, INLINED)
|
||||
declare_instruction(car, "a", 0, "%car", 1, INLINED)
|
||||
declare_instruction(setcar, "a!", 0, "%setcar", 2, INLINED)
|
||||
declare_instruction(cdr, "d", 0, "%cdr", 1, INLINED)
|
||||
declare_instruction(setcdr, "d!", 0, "%setcdr", 2, INLINED)
|
||||
declare_instruction(caar, "aa", 0, "%caar", 1, INLINED)
|
||||
declare_instruction(cadr, "da", 0, "%cadr", 1, INLINED)
|
||||
declare_instruction(cdar, "ad", 0, "%cdar", 1, INLINED)
|
||||
declare_instruction(cddr, "dd", 0, "%cddr", 1, INLINED)
|
||||
declare_instruction(nullp, "u", 0, "%nullp", 1, INLINED)
|
||||
declare_instruction(pairp, "p", 0, "%pairp", 1, INLINED)
|
||||
declare_instruction(cons, "c", 0, "%cons", 2, INLINED)
|
||||
declare_instruction(not, "~", 0, "%not", 1, INLINED)
|
||||
declare_instruction(izerop, "I=0", 0, "%izerop", 1, INLINED)
|
||||
declare_instruction(iposp, "I>0", 0, "%iposp", 1, INLINED)
|
||||
declare_instruction(inegp, "I<0", 0, "%inegp", 1, INLINED)
|
||||
declare_instruction(ievnp, "Ie", 0, "%ievnp", 1, INLINED)
|
||||
declare_instruction(ioddp, "Io", 0, "%ioddp", 1, INLINED)
|
||||
declare_instruction(iadd, "I+", 0, "%iadd", 2, INLINED)
|
||||
declare_instruction(isub, "I-", 0, "%isub", 2, INLINED)
|
||||
declare_instruction(imul, "I*", 0, "%imul", 2, INLINED)
|
||||
declare_instruction(idiv, "I/", 0, "%idiv", 2, INLINED)
|
||||
declare_instruction(iquo, "Iq", 0, "%iquo", 2, INLINED)
|
||||
declare_instruction(irem, "Ir", 0, "%irem", 2, INLINED)
|
||||
declare_instruction(ilt, "I<", 0, "%ilt", 2, INLINED)
|
||||
declare_instruction(igt, "I>", 0, "%igt", 2, INLINED)
|
||||
declare_instruction(ile, "I>!", 0, "%ile", 2, INLINED)
|
||||
declare_instruction(ige, "I<!", 0, "%ige", 2, INLINED)
|
||||
declare_instruction(ieq, "I=", 0, "%ieq", 2, INLINED)
|
||||
declare_instruction(ine, "I=!", 0, "%ine", 2, INLINED)
|
||||
declare_instruction(imin, "In", 0, "%imin", 2, INLINED)
|
||||
declare_instruction(imax, "Ix", 0, "%imax", 2, INLINED)
|
||||
declare_instruction(ineg, "I-!", 0, "%ineg", 1, INLINED)
|
||||
declare_instruction(iabs, "Ia", 0, "%iabs", 1, INLINED)
|
||||
declare_instruction(itoj, "Ij", 0, "%itoj", 1, INLINED)
|
||||
declare_instruction(fixp, "I0", 0, "%fixp", 1, INLINED)
|
||||
declare_instruction(imqu, "I3", 0, "%imqu", 2, INLINED)
|
||||
declare_instruction(imlo, "I4", 0, "%imlo", 2, INLINED)
|
||||
declare_instruction(ieuq, "I5", 0, "%ieuq", 2, INLINED)
|
||||
declare_instruction(ieur, "I6", 0, "%ieur", 2, INLINED)
|
||||
declare_instruction(igcd, "I7", 0, "%igcd", 2, INLINED)
|
||||
declare_instruction(ipow, "I8", 0, "%ipow", 2, INLINED)
|
||||
declare_instruction(isqrt, "I9", 0, "%isqrt", 1, INLINED)
|
||||
declare_instruction(inot, "D0", 0, "%inot", 1, INLINED)
|
||||
declare_instruction(iand, "D1", 0, "%iand", 2, INLINED)
|
||||
declare_instruction(iior, "D2", 0, "%iior", 2, INLINED)
|
||||
declare_instruction(ixor, "D3", 0, "%ixor", 2, INLINED)
|
||||
declare_instruction(iasl, "D4", 0, "%iasl", 2, INLINED)
|
||||
declare_instruction(iasr, "D5", 0, "%iasr", 2, INLINED)
|
||||
declare_instruction(jzerop, "J=0", 0, "%jzerop", 1, INLINED)
|
||||
declare_instruction(jposp, "J>0", 0, "%jposp", 1, INLINED)
|
||||
declare_instruction(jnegp, "J<0", 0, "%jnegp", 1, INLINED)
|
||||
declare_instruction(jevnp, "Je", 0, "%jevnp", 1, INLINED)
|
||||
declare_instruction(joddp, "Jo", 0, "%joddp", 1, INLINED)
|
||||
declare_instruction(jintp, "Jw", 0, "%jintp", 1, INLINED)
|
||||
declare_instruction(jnanp, "Ju", 0, "%jnanp", 1, INLINED)
|
||||
declare_instruction(jfinp, "Jf", 0, "%jfinp", 1, INLINED)
|
||||
declare_instruction(jinfp, "Jh", 0, "%jinfp", 1, INLINED)
|
||||
declare_instruction(jadd, "J+", 0, "%jadd", 2, INLINED)
|
||||
declare_instruction(jsub, "J-", 0, "%jsub", 2, INLINED)
|
||||
declare_instruction(jmul, "J*", 0, "%jmul", 2, INLINED)
|
||||
declare_instruction(jdiv, "J/", 0, "%jdiv", 2, INLINED)
|
||||
declare_instruction(jquo, "Jq", 0, "%jquo", 2, INLINED)
|
||||
declare_instruction(jrem, "Jr", 0, "%jrem", 2, INLINED)
|
||||
declare_instruction(jlt, "J<", 0, "%jlt", 2, INLINED)
|
||||
declare_instruction(jgt, "J>", 0, "%jgt", 2, INLINED)
|
||||
declare_instruction(jle, "J>!", 0, "%jle", 2, INLINED)
|
||||
declare_instruction(jge, "J<!", 0, "%jge", 2, INLINED)
|
||||
declare_instruction(jeq, "J=", 0, "%jeq", 2, INLINED)
|
||||
declare_instruction(jne, "J=!", 0, "%jne", 2, INLINED)
|
||||
declare_instruction(jmin, "Jn", 0, "%jmin", 2, INLINED)
|
||||
declare_instruction(jmax, "Jx", 0, "%jmax", 2, INLINED)
|
||||
declare_instruction(jneg, "J-!", 0, "%jneg", 1, INLINED)
|
||||
declare_instruction(jabs, "Ja", 0, "%jabs", 1, INLINED)
|
||||
declare_instruction(jtoi, "Ji", 0, "%jtoi", 1, INLINED)
|
||||
declare_instruction(flop, "J0", 0, "%flop", 1, INLINED)
|
||||
declare_instruction(jmqu, "J3", 0, "%jmqu", 2, INLINED)
|
||||
declare_instruction(jmlo, "J4", 0, "%jmlo", 2, INLINED)
|
||||
declare_instruction(jfloor, "H0", 0, "%jfloor", 1, INLINED)
|
||||
declare_instruction(jceil, "H1", 0, "%jceil", 1, INLINED)
|
||||
declare_instruction(jtrunc, "H2", 0, "%jtrunc", 1, INLINED)
|
||||
declare_instruction(jround, "H3", 0, "%jround", 1, INLINED)
|
||||
declare_instruction(zerop, "=0", 0, "%zerop", 1, INLINED)
|
||||
declare_instruction(posp, ">0", 0, "%posp", 1, INLINED)
|
||||
declare_instruction(negp, "<0", 0, "%negp", 1, INLINED)
|
||||
declare_instruction(add, "+", 0, "%add", 2, INLINED)
|
||||
declare_instruction(sub, "-", 0, "%sub", 2, INLINED)
|
||||
declare_instruction(mul, "*", 0, "%mul", 2, INLINED)
|
||||
declare_instruction(div, "/", 0, "%div", 2, INLINED)
|
||||
declare_instruction(lt, "<", 0, "%lt", 2, INLINED)
|
||||
declare_instruction(gt, ">", 0, "%gt", 2, INLINED)
|
||||
declare_instruction(le, ">!", 0, "%le", 2, INLINED)
|
||||
declare_instruction(ge, "<!", 0, "%ge", 2, INLINED)
|
||||
declare_instruction(eq, "=", 0, "%eq", 2, INLINED)
|
||||
declare_instruction(ne, "=!", 0, "%ne", 2, INLINED)
|
||||
declare_instruction(neg, "-!", 0, "%neg", 1, INLINED)
|
||||
declare_instruction(abs, "G0", 0, "%abs", 1, INLINED)
|
||||
declare_instruction(mqu, "G3", 0, "%mqu", 1, INLINED)
|
||||
declare_instruction(mlo, "G4", 0, "%mlo", 1, INLINED)
|
||||
declare_instruction(quo, "G5", 0, "%quo", 1, INLINED)
|
||||
declare_instruction(rem, "G6", 0, "%rem", 1, INLINED)
|
||||
declare_instruction(nump, "N0", 0, "%nump", 1, INLINED)
|
||||
declare_instruction(intp, "N4", 0, "%intp", 1, INLINED)
|
||||
declare_instruction(nanp, "N5", 0, "%nanp", 1, INLINED)
|
||||
declare_instruction(finp, "N6", 0, "%finp", 1, INLINED)
|
||||
declare_instruction(infp, "N7", 0, "%infp", 1, INLINED)
|
||||
declare_instruction(evnp, "N8", 0, "%evnp", 1, INLINED)
|
||||
declare_instruction(oddp, "N9", 0, "%oddp", 1, INLINED)
|
||||
declare_instruction(ntoi, "M0", 0, "%ntoi", 1, INLINED)
|
||||
declare_instruction(ntoj, "M1", 0, "%ntoj", 1, INLINED)
|
||||
declare_instruction(min, "M2", 0, "%min", 2, INLINED)
|
||||
declare_instruction(max, "M3", 0, "%max", 2, INLINED)
|
||||
declare_instruction(listp, "L0", 0, "%listp", 1, INLINED)
|
||||
declare_instruction(list, "l", 1, "%list", -1, "%!0_!]0") /* "%!0.0]1" */
|
||||
declare_instrshadow(list, "L1", 1, NULL, 0, INLINED)
|
||||
declare_instruction(llen, "g", 0, "%llen", 1, INLINED)
|
||||
declare_instrshadow(llen, "L3", 0, NULL, 0, INLINED)
|
||||
declare_instruction(lget, "L4", 0, "%lget", 2, INLINED)
|
||||
declare_instruction(lput, "L5", 0, "%lput", 3, INLINED)
|
||||
declare_instruction(lcat, "L6", 0, "%lcat", 2, INLINED)
|
||||
declare_instruction(memq, "A0", 0, "%memq", 2, INLINED)
|
||||
declare_instruction(memv, "A1", 0, "%memv", 2, INLINED)
|
||||
declare_instruction(meme, "A2", 0, "%meme", 2, INLINED)
|
||||
declare_instruction(assq, "A3", 0, "%assq", 2, INLINED)
|
||||
declare_instruction(assv, "A4", 0, "%assv", 2, INLINED)
|
||||
declare_instruction(asse, "A5", 0, "%asse", 2, INLINED)
|
||||
declare_instruction(ltail, "A6", 0, "%ltail", 2, INLINED)
|
||||
declare_instruction(lpair, "A7", 0, "%lpair", 1, INLINED)
|
||||
declare_instruction(lrev, "A8", 0, "%lrev", 1, INLINED)
|
||||
declare_instruction(lrevi, "A9", 0, "%lrevi", 1, INLINED)
|
||||
declare_instruction(charp, "C0", 0, "%charp", 1, INLINED)
|
||||
declare_instruction(cwsp, "C1", 0, "%cwsp", 1, INLINED)
|
||||
declare_instruction(clcp, "C2", 0, "%clcp", 1, INLINED)
|
||||
declare_instruction(cucp, "C3", 0, "%cucp", 1, INLINED)
|
||||
declare_instruction(calp, "C4", 0, "%calp", 1, INLINED)
|
||||
declare_instruction(cnup, "C5", 0, "%cnup", 1, INLINED)
|
||||
declare_instruction(cupc, "C6", 0, "%cupc", 1, INLINED)
|
||||
declare_instruction(cdnc, "C7", 0, "%cdnc", 1, INLINED)
|
||||
|
||||
declare_instruction(ceq, "C=", 0, "%ceq", 2, INLINED)
|
||||
declare_instruction(clt, "C<", 0, "%clt", 2, INLINED)
|
||||
declare_instruction(cgt, "C>", 0, "%cgt", 2, INLINED)
|
||||
declare_instruction(cle, "C>!", 0, "%cle", 2, INLINED)
|
||||
declare_instruction(cge, "C<!", 0, "%cge", 2, INLINED)
|
||||
declare_instruction(cieq, "Ci=", 0, "%cieq", 2, INLINED)
|
||||
declare_instruction(cilt, "Ci<", 0, "%cilt", 2, INLINED)
|
||||
declare_instruction(cigt, "Ci>", 0, "%cigt", 2, INLINED)
|
||||
declare_instruction(cile, "Ci>!", 0, "%cile", 2, INLINED)
|
||||
declare_instruction(cige, "Ci<!", 0, "%cige", 2, INLINED)
|
||||
|
||||
declare_instruction(strp, "S0", 0, "%strp", 1, INLINED)
|
||||
declare_instruction(str, "S1", 1, "%str", -1, "%!0.0X3]1")
|
||||
declare_instruction(smk, "S2", 0, "%smk", 2, INLINED)
|
||||
declare_instruction(slen, "S3", 0, "%slen", 1, INLINED)
|
||||
declare_instruction(sget, "S4", 0, "%sget", 2, INLINED)
|
||||
declare_instruction(sput, "S5", 0, "%sput", 3, INLINED)
|
||||
declare_instruction(scat, "S6", 0, "%scat", 2, INLINED)
|
||||
declare_instruction(ssub, "S7", 0, "%ssub", 3, INLINED)
|
||||
|
||||
declare_instruction(seq, "S=", 0, "%seq", 2, INLINED)
|
||||
declare_instruction(slt, "S<", 0, "%slt", 2, INLINED)
|
||||
declare_instruction(sgt, "S>", 0, "%sgt", 2, INLINED)
|
||||
declare_instruction(sle, "S>!", 0, "%sle", 2, INLINED)
|
||||
declare_instruction(sge, "S<!", 0, "%sge", 2, INLINED)
|
||||
declare_instruction(sieq, "Si=", 0, "%sieq", 2, INLINED)
|
||||
declare_instruction(silt, "Si<", 0, "%silt", 2, INLINED)
|
||||
declare_instruction(sigt, "Si>", 0, "%sigt", 2, INLINED)
|
||||
declare_instruction(sile, "Si>!", 0, "%sile", 2, INLINED)
|
||||
declare_instruction(sige, "Si<!", 0, "%sige", 2, INLINED)
|
||||
|
||||
|
||||
declare_instruction(vecp, "V0", 0, "%vecp", 1, INLINED)
|
||||
declare_instruction(vec, "V1", 1, "%vec", -1, "%!0.0X1]1")
|
||||
declare_instruction(vmk, "V2", 0, "%vmk", 2, INLINED)
|
||||
declare_instruction(vlen, "V3", 0, "%vlen", 1, INLINED)
|
||||
declare_instruction(vget, "V4", 0, "%vget", 2, INLINED)
|
||||
declare_instruction(vput, "V5", 0, "%vput", 3, INLINED)
|
||||
declare_instruction(vcat, "V6", 0, "%vcat", 2, INLINED)
|
||||
declare_instruction(vtol, "X0", 0, "%vtol", 1, INLINED)
|
||||
declare_instruction(ltov, "X1", 0, "%ltov", 1, INLINED)
|
||||
declare_instruction(stol, "X2", 0, "%stol", 1, INLINED)
|
||||
declare_instruction(ltos, "X3", 0, "%ltos", 1, INLINED)
|
||||
declare_instruction(ytos, "X4", 0, "%ytos", 1, INLINED)
|
||||
declare_instruction(stoy, "X5", 0, "%stoy", 1, INLINED)
|
||||
declare_instruction(itos, "X6", 0, "%itos", 2, INLINED)
|
||||
declare_instruction(stoi, "X7", 0, "%stoi", 2, INLINED)
|
||||
declare_instruction(ctoi, "X8", 0, "%ctoi", 1, INLINED)
|
||||
declare_instruction(itoc, "X9", 0, "%itoc", 1, INLINED)
|
||||
declare_instruction(jtos, "E6", 0, "%jtos", 1, INLINED)
|
||||
declare_instruction(stoj, "E7", 0, "%stoj", 1, INLINED)
|
||||
declare_instruction(ntos, "E8", 0, "%ntos", 2, INLINED)
|
||||
declare_instruction(ston, "E9", 0, "%ston", 2, INLINED)
|
||||
declare_instruction(ccmp, "O0", 0, "%ccmp", 2, INLINED)
|
||||
declare_instruction(cicmp, "O1", 0, "%cicmp", 2, INLINED)
|
||||
declare_instruction(scmp, "O2", 0, "%scmp", 2, INLINED)
|
||||
declare_instruction(sicmp, "O3", 0, "%sicmp", 2, INLINED)
|
||||
declare_instruction(symp, "Y0", 0, "%symp", 1, INLINED)
|
||||
declare_instruction(boolp, "Y1", 0, "%boolp", 1, INLINED)
|
||||
declare_instruction(eofp, "Y9", 0, "%eofp", 1, INLINED)
|
||||
declare_instruction(funp, "K0", 0, "%funp", 1, INLINED)
|
||||
declare_instruction(ipp, "P00", 0, "%ipp", 1, INLINED)
|
||||
declare_instruction(opp, "P01", 0, "%opp", 1, INLINED)
|
||||
declare_instruction(sip, "P10", 0, "%sip", 0, INLINED)
|
||||
declare_instruction(sop, "P11", 0, "%sop", 0, INLINED)
|
||||
declare_instruction(sep, "P12", 0, "%sep", 0, INLINED)
|
||||
declare_instruction(otip, "P40", 0, "%otip", 1, INLINED)
|
||||
declare_instruction(otop, "P41", 0, "%otop", 1, INLINED)
|
||||
declare_instruction(ois, "P50", 0, "%ois", 1, INLINED)
|
||||
declare_instruction(oos, "P51", 0, "%oos", 0, INLINED)
|
||||
declare_instruction(cip, "P60", 0, "%cip", 1, INLINED)
|
||||
declare_instruction(cop, "P61", 0, "%cop", 1, INLINED)
|
||||
declare_instruction(gos, "P9", 0, "%gos", 1, INLINED)
|
||||
declare_instruction(wrc, "W0", 0, "%wrc", 2, INLINED)
|
||||
declare_instruction(wrs, "W1", 0, "%wrs", 2, INLINED)
|
||||
declare_instruction(wrcd, "W4", 0, "%wrcd", 2, INLINED)
|
||||
declare_instruction(wrcw, "W5", 0, "%wrcw", 2, INLINED)
|
||||
declare_instruction(wrnl, "W6", 0, "%wrnl", 1, INLINED)
|
||||
declare_instruction(wrhw, "W7", 0, "%wrhw", 2, INLINED)
|
||||
declare_instruction(wriw, "W8", 0, "%wriw", 2, INLINED)
|
||||
|
||||
/* serialization and deserialization instructions */
|
||||
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)
|
||||
|
||||
/* inlined integrables (no custom instructions) */
|
||||
declare_integrable(NULL, "aaa", 0, "%caaar", 1, INLINED)
|
||||
declare_integrable(NULL, "daa", 0, "%caadr", 1, INLINED)
|
||||
declare_integrable(NULL, "ada", 0, "%cadar", 1, INLINED)
|
||||
declare_integrable(NULL, "dda", 0, "%caddr", 1, INLINED)
|
||||
declare_integrable(NULL, "aad", 0, "%cdaar", 1, INLINED)
|
||||
declare_integrable(NULL, "dad", 0, "%cdadr", 1, INLINED)
|
||||
declare_integrable(NULL, "add", 0, "%cddar", 1, INLINED)
|
||||
declare_integrable(NULL, "ddd", 0, "%cdddr", 1, INLINED)
|
||||
declare_integrable(NULL, "aaaa", 0, "%caaaar", 1, INLINED)
|
||||
declare_integrable(NULL, "daaa", 0, "%caaadr", 1, INLINED)
|
||||
declare_integrable(NULL, "adaa", 0, "%caadar", 1, INLINED)
|
||||
declare_integrable(NULL, "ddaa", 0, "%caaddr", 1, INLINED)
|
||||
declare_integrable(NULL, "aada", 0, "%cadaar", 1, INLINED)
|
||||
declare_integrable(NULL, "dada", 0, "%cadadr", 1, INLINED)
|
||||
declare_integrable(NULL, "adda", 0, "%caddar", 1, INLINED)
|
||||
declare_integrable(NULL, "ddda", 0, "%cadddr", 1, INLINED)
|
||||
declare_integrable(NULL, "aaad", 0, "%cdaaar", 1, INLINED)
|
||||
declare_integrable(NULL, "daad", 0, "%cdaadr", 1, INLINED)
|
||||
declare_integrable(NULL, "adad", 0, "%cdadar", 1, INLINED)
|
||||
declare_integrable(NULL, "ddad", 0, "%cdaddr", 1, INLINED)
|
||||
declare_integrable(NULL, "aadd", 0, "%cddaar", 1, INLINED)
|
||||
declare_integrable(NULL, "dadd", 0, "%cddadr", 1, INLINED)
|
||||
declare_integrable(NULL, "addd", 0, "%cdddar", 1, INLINED)
|
||||
declare_integrable(NULL, "dddd", 0, "%cddddr", 1, INLINED)
|
||||
|
||||
/* globals */
|
||||
declare_integrable(NULL, NULL, 0, "%ccc", 1, "%1K1,.1[11")
|
||||
declare_integrable(NULL, NULL, 0, "%appl", 2, "%2_!K3")
|
||||
|
||||
#undef declare_instruction
|
||||
#undef declare_instrshadow
|
||||
#undef declare_integrable
|
||||
419
k.h
Normal file
419
k.h
Normal file
|
|
@ -0,0 +1,419 @@
|
|||
/* k.h -- kernel */
|
||||
|
||||
/* standard includes */
|
||||
#include <stdio.h>
|
||||
#include <stddef.h>
|
||||
#include <stdlib.h>
|
||||
#include <assert.h>
|
||||
/* extra includes */
|
||||
#include <math.h>
|
||||
#include <errno.h>
|
||||
#include <ctype.h>
|
||||
#include <string.h>
|
||||
#include <time.h>
|
||||
|
||||
/* standard definitions */
|
||||
typedef ptrdiff_t obj; /* pointers are this size, lower bit zero */
|
||||
typedef ptrdiff_t cxoint_t; /* same thing, used as integer */
|
||||
typedef struct { /* type descriptor */
|
||||
const char *tname; /* name (debug) */
|
||||
void (*free)(void*); /* deallocator */
|
||||
} cxtype_t;
|
||||
|
||||
#define notobjptr(o) (((char*)(o) - (char*)cxg_heap) & cxg_hmask)
|
||||
#define isobjptr(o) (!notobjptr(o))
|
||||
#define notaptr(o) ((o) & 1)
|
||||
#define isaptr(o) (!notaptr(o))
|
||||
|
||||
#define obj_from_obj(o) (o)
|
||||
#define obj_from_objptr(p) ((obj)(p))
|
||||
#define obj_from_size(n) (((cxoint_t)(n) << 1) | 1)
|
||||
|
||||
#define objptr_from_objptr(p) (p)
|
||||
#define objptr_from_obj(o) ((obj*)(o))
|
||||
|
||||
#define size_from_obj(o) ((int)((o) >> 1))
|
||||
|
||||
#define obj_from_case(n) obj_from_objptr(cases+(n))
|
||||
#define case_from_obj(o) (objptr_from_obj(o)-cases)
|
||||
#define obj_from_ktrap() obj_from_size(0x5D56F806)
|
||||
#define obj_from_void(v) ((void)(v), obj_from_size(0x6F56DF77))
|
||||
|
||||
#define bool_from_obj(o) (o)
|
||||
#define bool_from_bool(b) (b)
|
||||
#define bool_from_size(s) (s)
|
||||
|
||||
#define void_from_void(v) (void)(v)
|
||||
#define void_from_obj(o) (void)(o)
|
||||
|
||||
#define rreserve(m) if (r + (m) >= cxg_rend) r = cxm_rgc(r, m)
|
||||
#define hpushptr(p, pt, l) (hreserve(2, l), *--hp = (obj)(p), *--hp = (obj)(pt), (obj)(hp+1))
|
||||
#define hbsz(s) ((s) + 1) /* 1 extra word to store block size */
|
||||
#define hreserve(n, l) ((hp < cxg_heap + (n)) ? hp = cxm_hgc(r, r+(l), hp, n) : hp)
|
||||
#define hendblk(n) (*--hp = obj_from_size(n), (obj)(hp+1))
|
||||
#define hblklen(p) size_from_obj(((obj*)(p))[-1])
|
||||
#define hblkref(p, i) (((obj*)(p))[i])
|
||||
|
||||
typedef obj (*cxhost_t)(obj);
|
||||
typedef struct cxroot_tag {
|
||||
int globc; obj **globv;
|
||||
struct cxroot_tag *next;
|
||||
} cxroot_t;
|
||||
|
||||
extern obj *cxg_heap;
|
||||
extern obj *cxg_hp;
|
||||
extern cxoint_t cxg_hmask;
|
||||
extern cxroot_t *cxg_rootp;
|
||||
extern obj *cxm_rgc(obj *regs, size_t needs);
|
||||
extern obj *cxm_hgc(obj *regs, obj *regp, obj *hp, size_t needs);
|
||||
extern obj *cxg_regs, *cxg_rend;
|
||||
extern void cxm_check(int x, char *msg);
|
||||
extern void *cxm_cknull(void *p, char *msg);
|
||||
extern int cxg_rc;
|
||||
extern char **cxg_argv;
|
||||
|
||||
/* extra definitions */
|
||||
/* basic object representation */
|
||||
#define isimm(o, t) (((o) & 0xf) == (((t) << 1) | 1))
|
||||
#define isimm2(o1, o2, t) (((((o1) & 0xf) << 4) | ((o2) & 0xf)) == (((((t) << 1) | 1) << 4) | (((t) << 1) | 1)))
|
||||
#define getimmu_unchecked(o) (long)(((o) >> 4) & 0xfffffff)
|
||||
#define getimms_unchecked(o) (long)(((((o) >> 4) & 0xfffffff) ^ 0x8000000) - 0x8000000)
|
||||
#ifdef NDEBUG
|
||||
#define getimmu(o, t) getimmu_unchecked(o)
|
||||
#define getimms(o, t) getimms_unchecked(o)
|
||||
#else
|
||||
extern long getimmu(obj o, int t);
|
||||
extern long getimms(obj o, int t);
|
||||
#endif
|
||||
#define mkimm(o, t) (obj)((((o) & 0xfffffff) << 4) | ((t) << 1) | 1)
|
||||
#ifdef NDEBUG
|
||||
static int isnative(obj o, cxtype_t *tp)
|
||||
{ return isobjptr(o) && objptr_from_obj(o)[-1] == (obj)tp; }
|
||||
#define getnative(o, t) ((void*)(*objptr_from_obj(o)))
|
||||
#else
|
||||
extern int isnative(obj o, cxtype_t *tp);
|
||||
extern void *getnative(obj o, cxtype_t *tp);
|
||||
#endif
|
||||
extern int istagged(obj o, int t);
|
||||
static /*inline*/ int istagged_inlined(obj o, int t) {
|
||||
if (!isobjptr(o)) return 0;
|
||||
else { obj h = objptr_from_obj(o)[-1];
|
||||
return notaptr(h) && size_from_obj(h) >= 1
|
||||
&& hblkref(o, 0) == obj_from_size(t); }
|
||||
}
|
||||
#ifdef NDEBUG
|
||||
#define cktagged(o, t) (o)
|
||||
#define taggedlen(o, t) (hblklen(o)-1)
|
||||
#define taggedref(o, t, i) (&hblkref(o, (i)+1))
|
||||
#else
|
||||
extern obj cktagged(obj o, int t);
|
||||
extern int taggedlen(obj o, int t);
|
||||
extern obj* taggedref(obj o, int t, int i);
|
||||
#endif
|
||||
/* booleans */
|
||||
#define TRUE_ITAG 0
|
||||
typedef int bool_t;
|
||||
#define is_bool_obj(o) (!((o) & ~(obj)1))
|
||||
#define is_bool_bool(b) ((void)(b), 1)
|
||||
#define void_from_bool(b) (void)(b)
|
||||
#define obj_from_bool(b) ((b) ? mkimm(0, TRUE_ITAG) : 0)
|
||||
/* numbers */
|
||||
#define FIXNUM_BIT 28
|
||||
#define FIXNUM_MIN -134217728
|
||||
#define FIXNUM_MAX 134217727
|
||||
#ifdef NDEBUG
|
||||
#define fxneg(x) (-(x))
|
||||
#define fxabs(x) (labs(x))
|
||||
#define fxadd(x, y) ((x) + (y))
|
||||
#define fxsub(x, y) ((x) - (y))
|
||||
#define fxmul(x, y) ((x) * (y))
|
||||
/* exact integer division */
|
||||
#define fxdiv(x, y) ((x) / (y))
|
||||
/* truncated division (common/C99) */
|
||||
#define fxquo(x, y) ((x) / (y))
|
||||
#define fxrem(x, y) ((x) % (y))
|
||||
/* floor division */
|
||||
static long fxmqu(long x, long y) {
|
||||
long q = x / y; return ((x < 0 && y > 0) || (x > 0 && y < 0)) ? q - 1 : q;
|
||||
}
|
||||
static long fxmlo(long x, long y) {
|
||||
long r = x % y; return ((r < 0 && y > 0) || (r > 0 && y < 0)) ? r + y : r;
|
||||
}
|
||||
/* euclidean division */
|
||||
static long fxeuq(long x, long y) {
|
||||
long q = x / y, r = x % y; return (r < 0) ? ((y > 0) ? q - 1 : q + 1) : q;
|
||||
}
|
||||
static long fxeur(long x, long y) {
|
||||
long r = x % y; return (r < 0) ? ((y > 0) ? r + y : r - y) : r;
|
||||
}
|
||||
static long fxgcd(long x, long y) {
|
||||
long a = labs(x), b = labs(y), c; while (b) c = a%b, a = b, b = c;
|
||||
return a;
|
||||
}
|
||||
#define fxasl(x, y) ((x) << (y))
|
||||
#define fxasr(x, y) ((x) >> (y))
|
||||
#define fxflo(f) ((long)(f))
|
||||
#else
|
||||
extern long fxneg(long x);
|
||||
extern long fxabs(long x);
|
||||
extern long fxadd(long x, long y);
|
||||
extern long fxsub(long x, long y);
|
||||
extern long fxmul(long x, long y);
|
||||
extern long fxdiv(long x, long y);
|
||||
extern long fxquo(long x, long y);
|
||||
extern long fxrem(long x, long y);
|
||||
extern long fxmqu(long x, long y);
|
||||
extern long fxmlo(long x, long y);
|
||||
extern long fxeuq(long x, long y);
|
||||
extern long fxeur(long x, long y);
|
||||
extern long fxgcd(long x, long y);
|
||||
extern long fxasl(long x, long y);
|
||||
extern long fxasr(long x, long y);
|
||||
extern long fxflo(double f);
|
||||
#endif
|
||||
static int flisint(double f) { return f > -HUGE_VAL && f < HUGE_VAL && f == floor(f); }
|
||||
extern long fxpow(long x, long y);
|
||||
extern long fxsqrt(long x);
|
||||
extern int fxifdv(long x, long y, long *pi, double *pd);
|
||||
extern double flquo(double x, double y);
|
||||
extern double flrem(double x, double y);
|
||||
extern double flmqu(double x, double y);
|
||||
extern double flmlo(double x, double y);
|
||||
extern double flgcd(double x, double y);
|
||||
extern double flround(double x);
|
||||
extern int strtofxfl(char *s, int radix, long *pl, double *pd);
|
||||
/* fixnums */
|
||||
#define FIXNUM_ITAG 1
|
||||
typedef long fixnum_t;
|
||||
#define is_fixnum_obj(o) (isimm(o, FIXNUM_ITAG))
|
||||
#define are_fixnum_objs(o1, o2) (isimm2((o1), (o2), FIXNUM_ITAG))
|
||||
#define get_fixnum_unchecked(o) (getimms_unchecked(o))
|
||||
#define is_fixnum_fixnum(i) ((void)(i), 1)
|
||||
#define is_bool_fixnum(i) ((void)(i), 0)
|
||||
#define is_fixnum_bool(i) ((void)(i), 0)
|
||||
#define fixnum_from_obj(o) (getimms(o, FIXNUM_ITAG))
|
||||
#define fixnum_from_fixnum(i) (i)
|
||||
#define fixnum_from_flonum(l,x) ((fixnum_t)(x))
|
||||
#define bool_from_fixnum(i) ((void)(i), 1)
|
||||
#define void_from_fixnum(i) (void)(i)
|
||||
#define obj_from_fixnum(i) mkimm((fixnum_t)(i), FIXNUM_ITAG)
|
||||
/* flonums */
|
||||
extern cxtype_t *FLONUM_NTAG;
|
||||
typedef double flonum_t;
|
||||
#define is_flonum_obj(o) (isnative(o, FLONUM_NTAG))
|
||||
#define is_flonum_flonum(f) ((void)(f), 1)
|
||||
#define is_flonum_bool(f) ((void)(f), 0)
|
||||
#define is_bool_flonum(f) ((void)(f), 0)
|
||||
#define is_fixnum_flonum(i) ((void)(i), 0)
|
||||
#define is_flonum_fixnum(i) ((void)(i), 0)
|
||||
#define flonum_from_obj(o) (*(flonum_t*)getnative(o, FLONUM_NTAG))
|
||||
#define flonum_from_flonum(l, f) (f)
|
||||
#define flonum_from_fixnum(x) ((flonum_t)(x))
|
||||
#define bool_from_flonum(f) ((void)(f), 0)
|
||||
#define void_from_flonum(l, f) (void)(f)
|
||||
#define obj_from_flonum(l, f) hpushptr(dupflonum(f), FLONUM_NTAG, l)
|
||||
extern flonum_t *dupflonum(flonum_t f);
|
||||
/* characters */
|
||||
#define CHAR_ITAG 2
|
||||
typedef int char_t;
|
||||
#define ischar(o) (isimm(o, CHAR_ITAG))
|
||||
#define is_char_obj(o) (isimm(o, CHAR_ITAG))
|
||||
#define is_char_char(i) ((void)(i), 1)
|
||||
#define is_char_bool(i) ((void)(i), 0)
|
||||
#define is_bool_char(i) ((void)(i), 0)
|
||||
#define is_char_fixnum(i) ((void)(i), 0)
|
||||
#define is_fixnum_char(i) ((void)(i), 0)
|
||||
#define is_char_flonum(i) ((void)(i), 0)
|
||||
#define is_flonum_char(i) ((void)(i), 0)
|
||||
#define char_from_obj(o) ((int)getimms(o, CHAR_ITAG))
|
||||
#define char_from_char(i) (i)
|
||||
#define bool_from_char(i) ((void)(i), 1)
|
||||
#define void_from_char(i) (void)(i)
|
||||
#define obj_from_char(i) mkimm(i, CHAR_ITAG)
|
||||
/* strings */
|
||||
extern cxtype_t *STRING_NTAG;
|
||||
#define isstring(o) (isnative(o, STRING_NTAG))
|
||||
#define stringdata(o) ((int*)getnative(o, STRING_NTAG))
|
||||
#define sdatachars(d) ((char*)((d)+1))
|
||||
#define stringlen(o) (*stringdata(o))
|
||||
#define stringchars(o) ((char*)(stringdata(o)+1))
|
||||
#define hpushstr(l, s) hpushptr(s, STRING_NTAG, l)
|
||||
#ifdef NDEBUG
|
||||
#define stringref(o, i) (stringchars(o)+(i))
|
||||
#else
|
||||
extern char* stringref(obj o, int i);
|
||||
#endif
|
||||
extern int *newstring(char *s);
|
||||
extern int *allocstring(int n, int c);
|
||||
extern int *substring(int *d, int from, int to);
|
||||
extern int *stringcat(int *d0, int *d1);
|
||||
extern int *dupstring(int *d);
|
||||
extern void stringfill(int *d, int c);
|
||||
extern int strcmp_ci(char *s1, char*s2);
|
||||
/* vectors */
|
||||
#define VECTOR_BTAG 1
|
||||
#define isvector(o) istagged(o, VECTOR_BTAG)
|
||||
#define vectorref(v, i) *taggedref(v, VECTOR_BTAG, i)
|
||||
#define vectorlen(v) taggedlen(v, VECTOR_BTAG)
|
||||
/* bytevectors */
|
||||
extern cxtype_t *BYTEVECTOR_NTAG;
|
||||
#define isbytevector(o) (isnative(o, BYTEVECTOR_NTAG))
|
||||
#define bytevectordata(o) ((int*)getnative(o, BYTEVECTOR_NTAG))
|
||||
#define bvdatabytes(d) ((unsigned char*)((d)+1))
|
||||
#define bytevectorlen(o) (*bytevectordata(o))
|
||||
#define bytevectorbytes(o) (bvdatabytes(bytevectordata(o)))
|
||||
#define hpushu8v(l, s) hpushptr(s, BYTEVECTOR_NTAG, l)
|
||||
static int is_byte_obj(obj o) { return (obj_from_fixnum(0) <= o && o <= obj_from_fixnum(255)); }
|
||||
#define byte_from_obj(o) byte_from_fixnum(fixnum_from_obj(o))
|
||||
#ifdef NDEBUG
|
||||
#define byte_from_fixnum(n) ((unsigned char)(n))
|
||||
#else
|
||||
static unsigned char byte_from_fixnum(int n) { assert(0 <= n && n <= 255); return n; }
|
||||
#endif
|
||||
#define byte_from_obj(o) byte_from_fixnum(fixnum_from_obj(o))
|
||||
#ifdef NDEBUG
|
||||
#define bytevectorref(o, i) (bytevectorbytes(o)+(i))
|
||||
#else
|
||||
extern unsigned char* bytevectorref(obj o, int i);
|
||||
#endif
|
||||
extern int *newbytevector(unsigned char *s, int n);
|
||||
extern int *allocbytevector(int n, int c);
|
||||
extern int *dupbytevector(int *d);
|
||||
extern int bytevectoreq(int *d0, int *d1);
|
||||
extern int *subbytevector(int *d, int from, int to);
|
||||
/* boxes */
|
||||
#define BOX_BTAG 2
|
||||
#define isbox(o) istagged(o, BOX_BTAG)
|
||||
#define boxref(o) *taggedref(o, BOX_BTAG, 0)
|
||||
/* null */
|
||||
#define NULL_ITAG 3
|
||||
#define mknull() mkimm(0, NULL_ITAG)
|
||||
#define isnull(o) ((o) == mkimm(0, NULL_ITAG))
|
||||
/* pairs and lists */
|
||||
#define PAIR_BTAG 3
|
||||
#define ispair(o) istagged(o, PAIR_BTAG)
|
||||
#define car(o) *taggedref(o, PAIR_BTAG, 0)
|
||||
#define cdr(o) *taggedref(o, PAIR_BTAG, 1)
|
||||
extern int islist(obj l);
|
||||
/* symbols */
|
||||
#define SYMBOL_ITAG 4
|
||||
#define issymbol(o) (isimm(o, SYMBOL_ITAG))
|
||||
#define mksymbol(i) mkimm(i, SYMBOL_ITAG)
|
||||
#define getsymbol(o) getimmu(o, SYMBOL_ITAG)
|
||||
extern char *symbolname(int sym);
|
||||
extern int internsym(char *name);
|
||||
/* records */
|
||||
#define RECORD_BTAG 4
|
||||
#define isrecord(o) istagged(o, RECORD_BTAG)
|
||||
#define recordrtd(r) *taggedref(r, RECORD_BTAG, 0)
|
||||
#define recordref(r, i) *taggedref(r, RECORD_BTAG, (i)+1)
|
||||
#define recordlen(r) (taggedlen(r, RECORD_BTAG)-1)
|
||||
/* procedures */
|
||||
extern int isprocedure(obj o);
|
||||
extern int procedurelen(obj o);
|
||||
extern obj* procedureref(obj o, int i);
|
||||
/* apply and dotted lambda list */
|
||||
extern obj appcases[];
|
||||
/* eof */
|
||||
#define EOF_ITAG 7
|
||||
#define mkeof() mkimm(-1, EOF_ITAG)
|
||||
#define iseof(o) ((o) == mkimm(-1, EOF_ITAG))
|
||||
/* input ports */
|
||||
typedef struct { /* extends cxtype_t */
|
||||
const char *tname;
|
||||
void (*free)(void*);
|
||||
int (*close)(void*);
|
||||
int (*getch)(void*);
|
||||
int (*ungetch)(int, void*);
|
||||
} cxtype_iport_t;
|
||||
extern cxtype_t *IPORT_CLOSED_NTAG;
|
||||
extern cxtype_t *IPORT_FILE_NTAG;
|
||||
extern cxtype_t *IPORT_STRING_NTAG;
|
||||
extern cxtype_t *IPORT_BYTEVECTOR_NTAG;
|
||||
static cxtype_iport_t *iportvt(obj o) {
|
||||
cxtype_t *pt; if (!isobjptr(o)) return NULL;
|
||||
pt = (cxtype_t*)objptr_from_obj(o)[-1];
|
||||
if (pt != IPORT_CLOSED_NTAG && pt != IPORT_FILE_NTAG &&
|
||||
pt != IPORT_STRING_NTAG && pt != IPORT_BYTEVECTOR_NTAG) return NULL;
|
||||
else return (cxtype_iport_t*)pt; }
|
||||
#define ckiportvt(o) ((cxtype_iport_t*)cxm_cknull(iportvt(o), "iportvt"))
|
||||
#define isiport(o) (iportvt(o) != NULL)
|
||||
#define iportdata(o) ((void*)(*objptr_from_obj(o)))
|
||||
static int iportgetc(obj o) {
|
||||
cxtype_iport_t *vt = iportvt(o); void *pp = iportdata(o);
|
||||
assert(vt); return vt->getch(pp);
|
||||
}
|
||||
static int iportpeekc(obj o) {
|
||||
cxtype_iport_t *vt = iportvt(o); void *pp = iportdata(o); int c;
|
||||
assert(vt); c = vt->getch(pp); if (c != EOF) vt->ungetch(c, pp); return c;
|
||||
}
|
||||
/* closed input ports */
|
||||
#define mkiport_file(l, fp) hpushptr(fp, IPORT_FILE_NTAG, l)
|
||||
/* string input ports */
|
||||
typedef struct { char *p; void *base; } sifile_t;
|
||||
extern sifile_t *sialloc(char *p, void *base);
|
||||
#define mkiport_string(l, fp) hpushptr(fp, IPORT_STRING_NTAG, l)
|
||||
/* bytevector input ports */
|
||||
typedef struct { unsigned char *p, *e; void *base; } bvifile_t;
|
||||
extern bvifile_t *bvialloc(unsigned char *p, unsigned char *e, void *base);
|
||||
#define mkiport_bytevector(l, fp) hpushptr(fp, IPORT_BYTEVECTOR_NTAG, l)
|
||||
/* output ports */
|
||||
typedef struct { /* extends cxtype_t */
|
||||
const char *tname;
|
||||
void (*free)(void*);
|
||||
int (*close)(void*);
|
||||
int (*putch)(int, void*);
|
||||
int (*flush)(void*);
|
||||
} cxtype_oport_t;
|
||||
extern cxtype_t *OPORT_CLOSED_NTAG;
|
||||
extern cxtype_t *OPORT_FILE_NTAG;
|
||||
extern cxtype_t *OPORT_STRING_NTAG;
|
||||
extern cxtype_t *OPORT_BYTEVECTOR_NTAG;
|
||||
static cxtype_oport_t *oportvt(obj o) {
|
||||
cxtype_t *pt; if (!isobjptr(o)) return NULL;
|
||||
pt = (cxtype_t*)objptr_from_obj(o)[-1];
|
||||
if (pt != OPORT_CLOSED_NTAG && pt != OPORT_FILE_NTAG &&
|
||||
pt != OPORT_STRING_NTAG && pt != OPORT_BYTEVECTOR_NTAG) return NULL;
|
||||
else return (cxtype_oport_t*)pt; }
|
||||
#define ckoportvt(o) ((cxtype_oport_t*)cxm_cknull(oportvt(o), "oportvt"))
|
||||
#define isoport(o) (oportvt(o) != NULL)
|
||||
#define oportdata(o) ((void*)(*objptr_from_obj(o)))
|
||||
static void oportputc(int c, obj o) {
|
||||
cxtype_oport_t *vt = oportvt(o); void *pp = oportdata(o);
|
||||
assert(vt); vt->putch(c, pp);
|
||||
}
|
||||
static void oportputs(char *s, obj o) {
|
||||
cxtype_oport_t *vt = oportvt(o); void *pp = oportdata(o);
|
||||
assert(vt); while (*s) vt->putch(*s++, pp);
|
||||
}
|
||||
static void oportwrite(char *s, int n, obj o) {
|
||||
cxtype_oport_t *vt = oportvt(o); void *pp = oportdata(o);
|
||||
assert(vt); while (n-- > 0) vt->putch(*s++, pp);
|
||||
}
|
||||
static void oportflush(obj o) {
|
||||
cxtype_oport_t *vt = oportvt(o); void *pp = oportdata(o);
|
||||
assert(vt); vt->flush(pp);
|
||||
}
|
||||
/* closed output ports */
|
||||
#define mkoport_file(l, fp) hpushptr(fp, OPORT_FILE_NTAG, l)
|
||||
/* string output ports */
|
||||
typedef struct cbuf_tag { char *buf; char *fill; char *end; } cbuf_t;
|
||||
extern cbuf_t* newcb(void);
|
||||
extern void freecb(cbuf_t* pcb);
|
||||
extern int cbputc(int c, cbuf_t* pcb);
|
||||
extern size_t cblen(cbuf_t* pcb);
|
||||
extern char* cbdata(cbuf_t* pcb);
|
||||
#define mkoport_string(l, fp) hpushptr(fp, OPORT_STRING_NTAG, l)
|
||||
/* bytevector output ports */
|
||||
#define mkoport_bytevector(l, fp) hpushptr(fp, OPORT_BYTEVECTOR_NTAG, l)
|
||||
extern int iscircular(obj x);
|
||||
extern int iseqv(obj x, obj y);
|
||||
extern obj ismemv(obj x, obj l);
|
||||
extern obj isassv(obj x, obj l);
|
||||
extern int isequal(obj x, obj y);
|
||||
extern obj ismember(obj x, obj l);
|
||||
extern obj isassoc(obj x, obj l);
|
||||
/* S-expression writers */
|
||||
extern void oportputsimple(obj x, obj p, int disp);
|
||||
extern void oportputcircular(obj x, obj p, int disp);
|
||||
extern void oportputshared(obj x, obj p, int disp);
|
||||
836
src/s.scm
Normal file
836
src/s.scm
Normal file
|
|
@ -0,0 +1,836 @@
|
|||
|
||||
(define-syntax define-inline
|
||||
(syntax-rules ()
|
||||
[(_ (id v ...) rid expr)
|
||||
(begin
|
||||
(define-syntax id
|
||||
(syntax-rules ()
|
||||
[(_ v ...) expr] ; NB: do not use the same var twice!
|
||||
[_ rid]))
|
||||
(define rid (lambda (v ...) expr)))]))
|
||||
|
||||
|
||||
;---------------------------------------------------------------------------------------------
|
||||
; Equivalence predicates
|
||||
;---------------------------------------------------------------------------------------------
|
||||
|
||||
(define-inline (eq? x y) %residual-eq? (%isq x y))
|
||||
|
||||
(define-inline (eqv? x y) %residual-eqv? (%isv x y))
|
||||
|
||||
(define-inline (equal? x y) %residual-equal? (%ise x y))
|
||||
|
||||
|
||||
;---------------------------------------------------------------------------------------------
|
||||
; Exact integer numbers (fixnums)
|
||||
;---------------------------------------------------------------------------------------------
|
||||
|
||||
(define-inline (fixnum? x) %residual-fixnum? (%fixp x))
|
||||
|
||||
(define-inline (fxzero? x) %residual-fxzero? (%izerop (%cki x)))
|
||||
|
||||
(define-inline (fxpositive? x) %residual-fxpositive? (%iposp (%cki x)))
|
||||
|
||||
(define-inline (fxnegative? x) %residual-fxnegative? (%inegp (%cki x)))
|
||||
|
||||
(define-inline (fx+ x y) %residual-fx+ (%iadd (%cki x) (%cki y)))
|
||||
|
||||
(define-inline (fx* x y) %residual-fx* (%imul (%cki x) (%cki y)))
|
||||
|
||||
(define-inline (fx- x y) %residual-fx- (%isub (%cki x) (%cki y)))
|
||||
|
||||
(define-inline (fx/ x y) %residual-fx/ (%idiv (%cki x) (%cki y)))
|
||||
|
||||
(define-inline (fxquotient x y) %residual-fxquotient (%iquo (%cki x) (%cki y)))
|
||||
|
||||
(define-inline (fxremainder x y) %residual-fxremainder (%irem (%cki x) (%cki y)))
|
||||
|
||||
(define-inline (fxmodquo x y) %residual-fxmodquo (%imqu (%cki x) (%cki y)))
|
||||
|
||||
(define-inline (fxmodulo x y) %residual-fxmodulo (%imlo (%cki x) (%cki y)))
|
||||
|
||||
(define-inline (fxeucquo x y) %residual-fxeucquo (%ieuq (%cki x) (%cki y))) ;euclidean-quotient
|
||||
|
||||
(define-inline (fxeucrem x y) %residual-fxeucrem (%ieur (%cki x) (%cki y))) ;euclidean-remainder
|
||||
|
||||
(define-inline (fxneg x) %residual-fxneg (%ineg (%cki x)))
|
||||
|
||||
(define-inline (fxabs x) %residual-fxabs (%iabs (%cki x)))
|
||||
|
||||
(define-inline (fx<? x y) %residual-fx<? (%ilt (%cki x) (%cki y)))
|
||||
|
||||
(define-inline (fx<=? x y) %residual-fx<=? (%ile (%cki x) (%cki y)))
|
||||
|
||||
(define-inline (fx>? x y) %residual-fx>? (%igt (%cki x) (%cki y)))
|
||||
|
||||
(define-inline (fx>=? x y) %residual-fx>=? (%ige (%cki x) (%cki y)))
|
||||
|
||||
(define-inline (fx=? x y) %residual-fx=? (%ieq (%cki x) (%cki y)))
|
||||
|
||||
(define-inline (fxmin x y) %residual-fxmin (%imin (%cki x) (%cki y)))
|
||||
|
||||
(define-inline (fxmax x y) %residual-fxmax (%imax (%cki x) (%cki y)))
|
||||
|
||||
(define-inline (fixnum->flonum x) %residual-fixnum->flonum (%itoj (%cki x)))
|
||||
|
||||
|
||||
;---------------------------------------------------------------------------------------------
|
||||
; Inexact floating-point numbers (flonums)
|
||||
;---------------------------------------------------------------------------------------------
|
||||
|
||||
(define-inline (flonum? x) %residual-flonum? (%flop x))
|
||||
|
||||
(define-inline (flzero? x) %residual-flzero? (%jzerop (%ckj x)))
|
||||
|
||||
(define-inline (flpositive? x) %residual-flpositive? (%jposp (%ckj x)))
|
||||
|
||||
(define-inline (flnegative? x) %residual-flnegative? (%jnegp (%ckj x)))
|
||||
|
||||
(define-inline (flinteger? x) %residual-flinteger? (%jintp (%ckj x)))
|
||||
|
||||
(define-inline (flnan? x) %residual-flnan? (%jnanp (%ckj x)))
|
||||
|
||||
(define-inline (flinfinite? x) %residual-flinfinite? (%jinfp (%ckj x)))
|
||||
|
||||
(define-inline (flfinite? x) %residual-flfinite? (%jfinp (%ckj x)))
|
||||
|
||||
(define-inline (fleven? x) %residual-fleven? (%jevnp (%ckj x)))
|
||||
|
||||
(define-inline (flodd? x) %residual-flodd? (%joddp (%ckj x)))
|
||||
|
||||
(define-inline (fl+ x y) %residual-fl+ (%jadd (%ckj x) (%ckj y)))
|
||||
|
||||
(define-inline (fl- x y) %residual-fl- (%jsub (%ckj x) (%ckj y)))
|
||||
|
||||
(define-inline (fl* x y) %residual-fl* (%jmul (%ckj x) (%ckj y)))
|
||||
|
||||
(define-inline (fl/ x y) %residual-fl/ (%jdiv (%ckj x) (%ckj y)))
|
||||
|
||||
(define-inline (flneg x) %residual-flneg (%jneg (%ckj x)))
|
||||
|
||||
(define-inline (flabs x) %residual-flabs (%jabs (%ckj x)))
|
||||
|
||||
(define-inline (fl<? x y) %residual-fl<? (%jlt (%ckj x) (%ckj y)))
|
||||
|
||||
(define-inline (fl<=? x y) %residual-fl<=? (%jle (%ckj x) (%ckj y)))
|
||||
|
||||
(define-inline (fl>? x y) %residual-fl>? (%jgt (%ckj x) (%ckj y)))
|
||||
|
||||
(define-inline (fl>=? x y) %residual-fl>=? (%jge (%ckj x) (%ckj y)))
|
||||
|
||||
(define-inline (fl=? x y) %residual-fl=? (%jeq (%ckj x) (%ckj y)))
|
||||
|
||||
(define-inline (flmin x y) %residual-flmin (%jmin (%ckj x) (%ckj y)))
|
||||
|
||||
(define-inline (flmax x y) %residual-flmax (%jmax (%ckj x) (%ckj y)))
|
||||
|
||||
(define-inline (flonum->fixnum x) %residual-flonum->fixnum (%jtoi (%ckj x)))
|
||||
|
||||
|
||||
;---------------------------------------------------------------------------------------------
|
||||
; Numbers (fixnums or flonums)
|
||||
;---------------------------------------------------------------------------------------------
|
||||
|
||||
(define-inline (number? x) %residual-number? (%nump x))
|
||||
|
||||
(define-inline (integer? x) %residual-integer? (%intp x))
|
||||
|
||||
(define-syntax complex? number?)
|
||||
|
||||
(define-syntax real? number?)
|
||||
|
||||
(define-syntax rational? integer?)
|
||||
|
||||
(define-syntax exact-integer? fixnum?)
|
||||
|
||||
(define-inline (exact? x) %residual-exact? (%fixp (%ckn x)))
|
||||
|
||||
(define-inline (inexact? x) %residual-inexact? (%flop (%ckn x)))
|
||||
|
||||
(define-inline (finite? x) %residual-finite? (%finp (%ckn x)))
|
||||
|
||||
(define-inline (infinite? x) %residual-infinite? (%infp (%ckn x)))
|
||||
|
||||
(define-inline (nan? x) %residual-nan? (%nanp (%ckn x)))
|
||||
|
||||
(define-inline (zero? x) %residual-zero? (%zerop (%ckn x)))
|
||||
|
||||
(define-inline (positive? x) %residual-positive? (%posp (%ckn x)))
|
||||
|
||||
(define-inline (negative? x) %residual-negative? (%negp (%ckn x)))
|
||||
|
||||
(define-inline (even? x) %residual-even? (%evnp (%ckn x)))
|
||||
|
||||
(define-inline (odd? x) %residual-odd? (%oddp (%ckn x)))
|
||||
|
||||
(define-syntax min
|
||||
(syntax-rules ()
|
||||
[(_ x) x]
|
||||
[(_ x y) (%min (%ckn x) (%ckn y))]
|
||||
[(_ x y z ...) (min (min x y) z ...)]
|
||||
[_ %residual-min]))
|
||||
|
||||
(define-syntax max
|
||||
(syntax-rules ()
|
||||
[(_ x) x]
|
||||
[(_ x y) (%max (%ckn x) (%ckn y))]
|
||||
[(_ x y z ...) (max (max x y) z ...)]
|
||||
[_ %residual-max]))
|
||||
|
||||
(define-syntax +
|
||||
(syntax-rules ()
|
||||
[(_) 0]
|
||||
[(_ x) (%ckn x)]
|
||||
[(_ x y) (%add (%ckn x) (%ckn y))]
|
||||
[(_ x y z ...) (+ (+ x y) z ...)]
|
||||
[_ %residual+]))
|
||||
|
||||
(define-syntax *
|
||||
(syntax-rules ()
|
||||
[(_) 1]
|
||||
[(_ x) (%ckn x)]
|
||||
[(_ x y) (%mul (%ckn x) (%ckn y))]
|
||||
[(_ x y z ...) (* (* x y) z ...)]
|
||||
[_ %residual*]))
|
||||
|
||||
(define-syntax -
|
||||
(syntax-rules ()
|
||||
[(_ x) (%neg (%ckn x))]
|
||||
[(_ x y) (%sub (%ckn x) (%ckn y))]
|
||||
[(_ x y z ...) (- (- x y) z ...)]
|
||||
[_ %residual-]))
|
||||
|
||||
(define-syntax /
|
||||
(syntax-rules ()
|
||||
[(_ x) (%div 1 (%ckn x))]
|
||||
[(_ x y) (%div (%ckn x) (%ckn y))]
|
||||
[(_ x y z ...) (/ (/ x y) z ...)]
|
||||
[_ %residual/]))
|
||||
|
||||
(define-syntax =
|
||||
(syntax-rules ()
|
||||
[(_ x y) (%eq (%ckn x) (%ckn y))]
|
||||
[(_ x y z ...) (let ([t y]) (and (= x t) (= t z ...)))]
|
||||
[_ %residual=]))
|
||||
|
||||
(define-syntax <
|
||||
(syntax-rules ()
|
||||
[(_ x y) (%lt (%ckn x) (%ckn y))]
|
||||
[(_ x y z ...) (let ([t y]) (and (< x t) (< t z ...)))]
|
||||
[_ %residual<]))
|
||||
|
||||
(define-syntax >
|
||||
(syntax-rules ()
|
||||
[(_ x y) (%gt (%ckn x) (%ckn y))]
|
||||
[(_ x y z ...) (let ([t y]) (and (> x t) (> t z ...)))]
|
||||
[_ %residual>]))
|
||||
|
||||
(define-syntax <=
|
||||
(syntax-rules ()
|
||||
[(_ x y) (%le (%ckn x) (%ckn y))]
|
||||
[(_ x y z ...) (let ([t y]) (and (<= x t) (<= t z ...)))]
|
||||
[_ %residual<=]))
|
||||
|
||||
(define-syntax >=
|
||||
(syntax-rules ()
|
||||
[(_ x y) (%ge (%ckn x) (%ckn y))]
|
||||
[(_ x y z ...) (let ([t y]) (and (>= x t) (>= t z ...)))]
|
||||
[_ %residual>=]))
|
||||
|
||||
(define-inline (abs x) %residual-abs (%abs (%ckn x)))
|
||||
|
||||
(define-inline (quotient x y) %residual-quotient (%quo (%ckn x)))
|
||||
(define-inline (remainder x y) %residual-remainder (%rem (%ckn x)))
|
||||
|
||||
(define-syntax truncate-quotient quotient)
|
||||
(define-syntax truncate-remainder remainder)
|
||||
|
||||
(define-inline (modquo x y) %residual-modquo (%mqu (%ckn x)))
|
||||
(define-inline (modulo x y) %residual-modulo (%mlo (%ckn x)))
|
||||
|
||||
(define-syntax floor-quotient modquo)
|
||||
(define-syntax floor-remainder modulo)
|
||||
|
||||
;floor/
|
||||
;truncate/
|
||||
|
||||
|
||||
;---------------------------------------------------------------------------------------------
|
||||
; Booleans
|
||||
;---------------------------------------------------------------------------------------------
|
||||
|
||||
(define-inline (boolean? x) %residual-boolean? (%boolp x))
|
||||
|
||||
(define-inline (not x) %residual-not (%not x))
|
||||
|
||||
|
||||
;---------------------------------------------------------------------------------------------
|
||||
; Characters
|
||||
;---------------------------------------------------------------------------------------------
|
||||
|
||||
(define-inline (char? x) %residual-char? (%charp x))
|
||||
|
||||
(define-inline (char-cmp x y) %residual-char-cmp (%ccmp (%ckc x) (%ckc y)))
|
||||
(define-inline (char=? x y) %residual-char=? (%ceq (%ckc x) (%ckc y)))
|
||||
(define-inline (char<? x y) %residual-char<? (%clt (%ckc x) (%ckc y)))
|
||||
(define-inline (char<=? x y) %residual-char<=? (%cle (%ckc x) (%ckc y)))
|
||||
(define-inline (char>? x y) %residual-char>? (%cgt (%ckc x) (%ckc y)))
|
||||
(define-inline (char>=? x y) %residual-char>=? (%cge (%ckc x) (%ckc y)))
|
||||
|
||||
(define-inline (char-ci-cmp x y) %residual-char-cmp (%cicmp (%ckc x) (%ckc y)))
|
||||
(define-inline (char-ci=? x y) %residual-char-ci=? (%cieq (%ckc x) (%ckc y)))
|
||||
(define-inline (char-ci<? x y) %residual-char-ci<? (%cilt (%ckc x) (%ckc y)))
|
||||
(define-inline (char-ci<=? x y) %residual-char-ci<=? (%cile (%ckc x) (%ckc y)))
|
||||
(define-inline (char-ci>? x y) %residual-char-ci>? (%cigt (%ckc x) (%ckc y)))
|
||||
(define-inline (char-ci>=? x y) %residual-char-ci>=? (%cige (%ckc x) (%ckc y)))
|
||||
|
||||
(define-inline (char-alphabetic? x) %residual-char-alphabetic? (%calp (%ckc x)))
|
||||
(define-inline (char-numeric? x) %residual-char-numeric? (%cnup (%ckc x)))
|
||||
(define-inline (char-whitespace? x) %residual-char-whitespace? (%cwsp (%ckc x)))
|
||||
(define-inline (char-upper-case? x) %residual-char-upper-case? (%cucp (%ckc x)))
|
||||
(define-inline (char-lower-case? x) %residual-char-lower-case? (%clcp (%ckc x)))
|
||||
(define-inline (char-upcase x) %residual-char-upcase (%cupc (%ckc x)))
|
||||
(define-inline (char-downcase x) %residual-char-downcase (%cdnc (%ckc x)))
|
||||
|
||||
(define-inline (char->integer x) %residual-char->integer (%ctoi (%ckc x)))
|
||||
(define-inline (integer->char x) %residual-integer->char (%itoc (%cki x)))
|
||||
|
||||
;char-foldcase
|
||||
;digit-value
|
||||
|
||||
|
||||
;---------------------------------------------------------------------------------------------
|
||||
; Symbols
|
||||
;---------------------------------------------------------------------------------------------
|
||||
|
||||
(define-inline (symbol? x) %residual-symbol? (%symp x))
|
||||
|
||||
(define-inline (symbol->string x) %residual-symbol->string (%ytos (%cky x)))
|
||||
|
||||
(define-inline (string->symbol x) %residual-string->symbol (%stoy (%cks x)))
|
||||
|
||||
|
||||
;---------------------------------------------------------------------------------------------
|
||||
; Null and Pairs
|
||||
;---------------------------------------------------------------------------------------------
|
||||
|
||||
(define-inline (null? x) %residual-null? (%nullp x))
|
||||
|
||||
(define-inline (pair? x) %residual-pair? (%pairp x))
|
||||
|
||||
(define-inline (car x) %residual-car (%car (%ckp x)))
|
||||
|
||||
(define-inline (set-car! x v) %residual-set-car! (%setcar (%ckp x) v))
|
||||
|
||||
(define-inline (cdr x) %residual-cdr (%cdr (%ckp x)))
|
||||
|
||||
(define-inline (set-cdr! x v) %residual-set-cdr! (%setcdr (%ckp x) v))
|
||||
|
||||
(define-syntax c?r
|
||||
(syntax-rules (a d)
|
||||
[(c?r x) x]
|
||||
[(c?r a ? ... x) (car (c?r ? ... x))]
|
||||
[(c?r d ? ... x) (cdr (c?r ? ... x))]))
|
||||
|
||||
(define-inline (caar x) %residual-caar (c?r a a x))
|
||||
(define-inline (cadr x) %residual-cadr (c?r a d x))
|
||||
(define-inline (cdar x) %residual-cdar (c?r d a x))
|
||||
(define-inline (cddr x) %residual-cddr (c?r d d x))
|
||||
(define-inline (caaar x) %residual-caaar (c?r a a a x))
|
||||
(define-inline (caadr x) %residual-caadr (c?r a a d x))
|
||||
(define-inline (cadar x) %residual-cadar (c?r a d a x))
|
||||
(define-inline (caddr x) %residual-caddr (c?r a d d x))
|
||||
(define-inline (cdaar x) %residual-cdaar (c?r d a a x))
|
||||
(define-inline (cdadr x) %residual-cdadr (c?r d a d x))
|
||||
(define-inline (cddar x) %residual-cddar (c?r d d a x))
|
||||
(define-inline (cdddr x) %residual-cdddr (c?r d d d x))
|
||||
(define-inline (caaaar x) %residual-caaaar (c?r a a a a x))
|
||||
(define-inline (caaadr x) %residual-caaadr (c?r a a a d x))
|
||||
(define-inline (caadar x) %residual-caadar (c?r a a d a x))
|
||||
(define-inline (caaddr x) %residual-caaddr (c?r a a d d x))
|
||||
(define-inline (cadaar x) %residual-cadaar (c?r a d a a x))
|
||||
(define-inline (cadadr x) %residual-cadadr (c?r a d a d x))
|
||||
(define-inline (caddar x) %residual-caddar (c?r a d d a x))
|
||||
(define-inline (cadddr x) %residual-cadddr (c?r a d d d x))
|
||||
(define-inline (cdaaar x) %residual-cdaaar (c?r d a a a x))
|
||||
(define-inline (cdaadr x) %residual-cdaadr (c?r d a a d x))
|
||||
(define-inline (cdadar x) %residual-cdadar (c?r d a d a x))
|
||||
(define-inline (cdaddr x) %residual-cdaddr (c?r d a d d x))
|
||||
(define-inline (cddaar x) %residual-cddaar (c?r d d a a x))
|
||||
(define-inline (cddadr x) %residual-cddadr (c?r d d a d x))
|
||||
(define-inline (cdddar x) %residual-cdddar (c?r d d d a x))
|
||||
(define-inline (cddddr x) %residual-cddddr (c?r d d d d x))
|
||||
|
||||
(define-inline (cons x y) %residual-cons (%cons x y))
|
||||
|
||||
|
||||
;---------------------------------------------------------------------------------------------
|
||||
; Lists
|
||||
;---------------------------------------------------------------------------------------------
|
||||
|
||||
(define-inline (list? x) %residual-list? (%listp x))
|
||||
|
||||
(define (%make-list n i)
|
||||
(let loop ([n (%ckk n)] [l '()])
|
||||
(if (%ile n 0) l (loop (%isub n 1) (cons i l)))))
|
||||
|
||||
(define-syntax make-list
|
||||
(syntax-rules ()
|
||||
[(_ n) (%make-list n #f)] ; #f > (void)
|
||||
[(_ n i) (%make-list n i)]
|
||||
[_ %residual-make-list]))
|
||||
|
||||
(define-syntax list
|
||||
(syntax-rules ()
|
||||
[(_) '()]
|
||||
[(_ x) (%cons x '())]
|
||||
[(_ x ...) (%list x ...)]
|
||||
[_ %residual-list]))
|
||||
|
||||
(define-inline (length x) %residual-length (%llen (%ckl x))) ; optimize via combo instruction "%lg"?
|
||||
|
||||
(define-inline (list-ref x i) %residual-list-ref (%lget (%ckl x) (%cki i))) ; check for range, optimize combo?
|
||||
|
||||
(define-inline (list-set! x i v) %residual-list-set! (%lput (%ckl x) (%cki i) v)) ; check for range, optimize combo?
|
||||
|
||||
(define-syntax append
|
||||
(syntax-rules ()
|
||||
[(_) '()] [(_ x) x]
|
||||
[(_ x y) (%lcat (%ckl x) y)]
|
||||
[(_ x y z ...) (%lcat (%ckl x) (append y z ...))]
|
||||
[_ %residual-append]))
|
||||
|
||||
(define-inline (memq v y) %residual-memq (%memq v (%ckl y))) ; optimize combo?
|
||||
|
||||
(define-inline (memv v y) %residual-memv (%memv v (%ckl y))) ; optimize combo?
|
||||
|
||||
(define (%member x l eq)
|
||||
(and (pair? l) (if (eq x (%car l)) l (%member x (%cdr l) eq))))
|
||||
|
||||
(define-syntax member
|
||||
(syntax-rules ()
|
||||
[(_ v y) (%meme v (%ckl y))]
|
||||
[(_ v y eq) (%member v y eq)]
|
||||
[_ %residual-member]))
|
||||
|
||||
(define-inline (assq v y) %residual-assq (%assq v (%ckl y))) ; check for a-list; optimize combo?
|
||||
|
||||
(define-inline (assv v y) %residual-assv (%assv v (%ckl y))) ; check for a-list; optimize combo?
|
||||
|
||||
(define (%assoc v al eq)
|
||||
(and (pair? al) (if (eq v (car (%car al))) (%car al) (%assoc v (%cdr al) eq))))
|
||||
|
||||
(define-syntax assoc
|
||||
(syntax-rules ()
|
||||
[(_ v al) (%asse v (%ckl al))]
|
||||
[(_ v al eq) (%assoc v al eq)]
|
||||
[_ %residual-assoc]))
|
||||
|
||||
(define-inline (list-copy x) %residual-list-copy (%lcat (%ckl x) '()))
|
||||
|
||||
(define-inline (list-tail x i) %residual-list-tail (%ltail (%ckl x) (%cki i))) ; check for range, optimize combo?
|
||||
|
||||
(define-inline (last-pair x) %residual-last-pair (%lpair (%ckp x)))
|
||||
|
||||
(define-inline (reverse x) %residual-reverse (%lrev (%ckl x))) ; optimize combo?
|
||||
|
||||
(define-inline (reverse! x) %residual-reverse! (%lrevi (%ckl x))) ; optimize combo?
|
||||
|
||||
(define-syntax list*
|
||||
(syntax-rules ()
|
||||
[(_ x) x]
|
||||
[(_ x y) (%cons x y)]
|
||||
[(_ x y z ...) (%cons x (list* y z ...))]
|
||||
[_ %residual-list*]))
|
||||
|
||||
(define-syntax cons* list*)
|
||||
|
||||
(define-syntax map
|
||||
(syntax-rules ()
|
||||
[(_ fun lst)
|
||||
(let ([f fun])
|
||||
(let loop ([l lst])
|
||||
(if (pair? l) (cons (f (%car l)) (loop (%cdr l))) '())))]
|
||||
[_ %residual-map]))
|
||||
|
||||
(define-syntax for-each
|
||||
(syntax-rules ()
|
||||
[(_ fun lst)
|
||||
(let ([f fun])
|
||||
(let loop ([l lst])
|
||||
(if (pair? l) (begin (f (%car l)) (loop (%cdr l))))))]
|
||||
[_ %residual-for-each]))
|
||||
|
||||
|
||||
;---------------------------------------------------------------------------------------------
|
||||
; Vectors
|
||||
;---------------------------------------------------------------------------------------------
|
||||
|
||||
(define-inline (vector? x) %residual-vector? (%vecp x))
|
||||
|
||||
(define-syntax vector %vec)
|
||||
|
||||
(define-syntax make-vector
|
||||
(syntax-rules ()
|
||||
[(_ n) (%vmk (%ckk n) #f)]
|
||||
[(_ n v) (%vmk (%ckk n) v)]
|
||||
[_ %residual-make-vector]))
|
||||
|
||||
(define-inline (vector-length x) %residual-vector-length (%vlen (%ckv x))) ; optimize combo?
|
||||
|
||||
(define-inline (vector-ref x i) %residual-vector-ref (%vget (%ckv x) (%cki i))) ; check for range, optimize combo?
|
||||
|
||||
(define-inline (vector-set! x i v) %residual-vector-set! (%vput (%ckv x) (%cki i) v)) ; check for range, optimize combo?
|
||||
|
||||
(define-syntax vector-append
|
||||
(syntax-rules ()
|
||||
[(_) '#()] [(_ x) (%ckv x)]
|
||||
[(_ x y) (%vcat (%ckv x) (%ckv y))]
|
||||
[(_ x y z ...) (vector-append x (vector-append y z ...))]
|
||||
[_ %residual-vector-append]))
|
||||
|
||||
(define-inline (vector->list x) %residual-vector->list (%vtol (%ckv x)))
|
||||
|
||||
(define-inline (list->vector x) %residual-list->vector (%ltov (%ckl x)))
|
||||
|
||||
;vector->list/1/2/3
|
||||
;vector-copy/1/2/3=subvector
|
||||
;vector-copy!/2/3/4/5 (to at from start end)
|
||||
;vector-fill!/2/3/4 (vector val start end)
|
||||
;vector->string/1/2/3
|
||||
;string->vector/1/2/3
|
||||
|
||||
|
||||
;---------------------------------------------------------------------------------------------
|
||||
; Strings
|
||||
;---------------------------------------------------------------------------------------------
|
||||
|
||||
(define-inline (string? x) %residual-string? (%strp x))
|
||||
|
||||
(define-syntax string
|
||||
(syntax-rules ()
|
||||
[(_ c ...) (%str (%ckc c) ...)]
|
||||
[_ %residual-string]))
|
||||
|
||||
(define-syntax make-string
|
||||
(syntax-rules ()
|
||||
[(_ x) (%smk (%ckk x) #\space)]
|
||||
[(_ x y) (%smk (%ckk x) (%ckc y))]
|
||||
[_ %residual-make-string]))
|
||||
|
||||
(define-inline (string-length x) %residual-string-length (%slen (%cks x))) ; optimize combo?
|
||||
|
||||
(define-inline (string-ref x i) %residual-string-ref (%sget (%cks x) (%cki i))) ; check for range, optimize combo?
|
||||
|
||||
(define-inline (string-set! x i v) %residual-string-set! (%sput (%cks x) (%cki i) (%ckc v))) ; check for range, optimize combo?
|
||||
|
||||
(define-syntax string-append
|
||||
(syntax-rules ()
|
||||
[(_) ""] [(_ x) (%cks x)]
|
||||
[(_ x y) (%scat (%cks x) (%cks y))]
|
||||
[(_ x y z ...) (string-append x (string-append y z ...))]
|
||||
[_ %residual-string-append]))
|
||||
|
||||
(define-inline (substring x s e) %residual-substring (%ssub (%cks x) (%cki s) (%cki e))) ; check for range
|
||||
|
||||
(define-inline (string-cmp x y) %residual-string-cmp (%scmp (%cks x) (%cks y)))
|
||||
(define-inline (string=? x y) %residual-string<? (%seq (%cks x) (%cks y)))
|
||||
(define-inline (string<? x y) %residual-string<? (%slt (%cks x) (%cks y)))
|
||||
(define-inline (string<=? x y) %residual-string<=? (%sle (%cks x) (%cks y)))
|
||||
(define-inline (string>? x y) %residual-string>? (%sgt (%cks x) (%cks y)))
|
||||
(define-inline (string>=? x y) %residual-string>=? (%sge (%cks x) (%cks y)))
|
||||
(define-inline (string-ci-cmp x y) %residual-string-cmp (%sicmp (%cks x) (%cks y)))
|
||||
(define-inline (string-ci=? x y) %residual-string<? (%sieq (%cks x) (%cks y)))
|
||||
(define-inline (string-ci<? x y) %residual-string<? (%silt (%cks x) (%cks y)))
|
||||
(define-inline (string-ci<=? x y) %residual-string<=? (%sile (%cks x) (%cks y)))
|
||||
(define-inline (string-ci>? x y) %residual-string>? (%sigt (%cks x) (%cks y)))
|
||||
(define-inline (string-ci>=? x y) %residual-string>=? (%sige (%cks x) (%cks y)))
|
||||
|
||||
(define-inline (string->list x) %residual-string->list (%stol (%cks x)))
|
||||
|
||||
(define-inline (list->string x) %residual-list->string (%ltos (%ckl x))) ; list-of-chars test
|
||||
|
||||
;string-upcase
|
||||
;string-downcase
|
||||
;string-foldcase
|
||||
;string->list/1/2/3
|
||||
;string-copy/1/2/3=substring
|
||||
;string-copy!/2/3/4/5 (to at from start end)
|
||||
;string-fill!/2/3/4 (string v start end)
|
||||
|
||||
|
||||
;---------------------------------------------------------------------------------------------
|
||||
; Conversions
|
||||
;---------------------------------------------------------------------------------------------
|
||||
|
||||
(define-inline (fixnum->string x r) %residual-fixnum->string (%itos (%cki x) (%cki r)))
|
||||
|
||||
(define-inline (string->fixnum x r) %residual-string->fixnum (%stoi (%cks x) (%cki r)))
|
||||
|
||||
(define-inline (flonum->string x) %residual-flonum->string (%jtos (%ckj x)))
|
||||
|
||||
(define-inline (string->flonum x) %residual-string->flonum (%stoj (%cks x)))
|
||||
|
||||
(define-syntax number->string
|
||||
(syntax-rules ()
|
||||
[(_ x r) (%ntos (%cki x) (%cki r))]
|
||||
[(_ x) (%ntos (%cki x) 10)]
|
||||
[_ %residual-number->string]))
|
||||
|
||||
(define-syntax string->number
|
||||
(syntax-rules ()
|
||||
[(_ x r) (%ston (%cks x) (%cki r))]
|
||||
[(_ x) (%ston (%cks x) 10)]
|
||||
[_ %residual-string->number]))
|
||||
|
||||
|
||||
;---------------------------------------------------------------------------------------------
|
||||
; Control features
|
||||
;---------------------------------------------------------------------------------------------
|
||||
|
||||
(define-inline (procedure? x) %residual-procedure? (%funp x))
|
||||
|
||||
(define-syntax apply
|
||||
(syntax-rules ()
|
||||
[(_ p l) (%appl p (%ckl l))] ; -- check for proc?
|
||||
[(_ p a b ... l) (%appl p (list* a b ... l))]
|
||||
[_ %residual-apply]))
|
||||
|
||||
|
||||
(define-syntax call/cc %ccc) ; (%ccc (%ckr1 k)) -- check for 1-arg proc?
|
||||
|
||||
(define-syntax call-with-current-continuation call/cc)
|
||||
|
||||
;map
|
||||
;string-map
|
||||
;vector-map
|
||||
;for-each
|
||||
;string-for-each
|
||||
;vector-for-each
|
||||
;values
|
||||
;call-with-values
|
||||
|
||||
|
||||
;---------------------------------------------------------------------------------------------
|
||||
; I/O Ports
|
||||
;---------------------------------------------------------------------------------------------
|
||||
|
||||
(define-inline (input-port? x) %residual-input-port? (%ipp x))
|
||||
|
||||
(define-inline (output-port? x) %residual-output-port? (%opp x))
|
||||
|
||||
(define-inline (eof-object? x) %residual-eof-object? (%eofp x))
|
||||
|
||||
(define-inline (current-input-port) %residual-current-input-port (%sip))
|
||||
|
||||
(define-inline (current-ouput-port) %residual-current-ouput-port (%sop))
|
||||
|
||||
(define-inline (current-error-port) %residual-current-error-port (%sep))
|
||||
|
||||
(define-inline (open-output-string) %residual-open-output-string (%oos))
|
||||
|
||||
(define-inline (open-input-file x) %residual-open-input-file (%otip (%cks x)))
|
||||
|
||||
(define-inline (open-output-file x) %residual-open-output-file (%otop (%cks x)))
|
||||
|
||||
(define-inline (open-input-string x) %residual-open-input-string (%ois (%cks x)))
|
||||
|
||||
(define-inline (close-input-port x) %residual-close-input-port (%cip (%ckr x)))
|
||||
|
||||
(define-inline (close-output-port x) %residual-close-output-port (%cop (%ckw x)))
|
||||
|
||||
(define-inline (get-output-string x) %residual-get-output-string (%gos (%ckw x)))
|
||||
|
||||
|
||||
;---------------------------------------------------------------------------------------------
|
||||
; Output
|
||||
;---------------------------------------------------------------------------------------------
|
||||
|
||||
(define-inline (write-char x p) %residual-write-char (%wrc (%ckc x) (%ckw p)))
|
||||
|
||||
(define-inline (write-string x p) %residual-write-string (%wrs (%cks x) (%ckw p)))
|
||||
|
||||
(define-inline (display x p) %residual-display (%wrcd x (%ckw p)))
|
||||
|
||||
(define-inline (write x p) %residual-write (%wrcw x (%ckw p)))
|
||||
|
||||
(define-inline (newline p) %residual-newline (%wrnl (%ckw p)))
|
||||
|
||||
(define-inline (write-shared x p) %residual-write-shared (%wrhw x (%ckw p)))
|
||||
|
||||
(define-inline (write-simple x p) %residual-write-simple (%wriw x (%ckw p)))
|
||||
|
||||
|
||||
;---------------------------------------------------------------------------------------------
|
||||
; Residual versions of vararg procedures
|
||||
;---------------------------------------------------------------------------------------------
|
||||
|
||||
(define-syntax nullary-unary-adaptor
|
||||
(syntax-rules ()
|
||||
[(_ f)
|
||||
(lambda args
|
||||
(if (null? args) (f) (f (car args))))]))
|
||||
|
||||
(define-syntax nullary-unary-binary-adaptor
|
||||
(syntax-rules ()
|
||||
[(_ f)
|
||||
(lambda args
|
||||
(if (null? args) (f) (if (null? (cdr args)) (f (car args)) (f (car args) (cadr args)))))]))
|
||||
|
||||
(define-syntax unary-binary-adaptor
|
||||
(syntax-rules ()
|
||||
[(_ f)
|
||||
(lambda (x . args)
|
||||
(if (null? args) (f x) (f x (car args))))]))
|
||||
|
||||
(define-syntax unary-binary-ternary-adaptor
|
||||
(syntax-rules ()
|
||||
[(_ f)
|
||||
(lambda (x . args)
|
||||
(if (null? args) (f x) (if (null? (cdr args)) (f x (car args)) (f x (car args) (cadr args)))))]))
|
||||
|
||||
(define-syntax unary-binary-ternary-quaternary-adaptor
|
||||
(syntax-rules ()
|
||||
[(_ f)
|
||||
(lambda (x . args)
|
||||
(if (null? args) (f x) (if (null? (cdr args)) (f x (car args))
|
||||
(if (null? (cddr args)) (f x (car args) (cadr args)) (f x (car args) (cadr args) (caddr args))))))]))
|
||||
|
||||
(define-syntax binary-ternary-adaptor
|
||||
(syntax-rules ()
|
||||
[(_ f)
|
||||
(lambda (x y . args)
|
||||
(if (null? args) (f x y) (f x y (car args))))]))
|
||||
|
||||
(define-syntax cmp-reducer
|
||||
(syntax-rules ()
|
||||
[(_ f)
|
||||
(lambda args
|
||||
(or (null? args)
|
||||
(let loop ([x (car args)] [args (cdr args)])
|
||||
(or (null? args)
|
||||
(let ([y (car args)])
|
||||
(and (f x y) (loop y (cdr args))))))))]))
|
||||
|
||||
(define (%residual-list . l) l)
|
||||
|
||||
(define %residual-make-list (unary-binary-adaptor make-list))
|
||||
(define %residual-make-vector (unary-binary-adaptor make-vector))
|
||||
(define %residual-make-string (unary-binary-adaptor make-string))
|
||||
|
||||
(define %residual= (cmp-reducer =))
|
||||
(define %residual< (cmp-reducer <))
|
||||
(define %residual> (cmp-reducer >))
|
||||
(define %residual<= (cmp-reducer <=))
|
||||
(define %residual>= (cmp-reducer >=))
|
||||
|
||||
(define-syntax minmax-reducer
|
||||
(syntax-rules ()
|
||||
[(_ f)
|
||||
(lambda (x . args)
|
||||
(let loop ([x x] [args args])
|
||||
(if (null? args)
|
||||
x
|
||||
(loop (f x (car args)) (cdr args)))))]))
|
||||
|
||||
(define %residual-min (minmax-reducer min))
|
||||
(define %residual-max (minmax-reducer max))
|
||||
|
||||
(define-syntax addmul-reducer
|
||||
(syntax-rules ()
|
||||
[(_ f s)
|
||||
(lambda args
|
||||
(if (null? args)
|
||||
s
|
||||
(let loop ([x (car args)] [args (cdr args)])
|
||||
(if (null? args)
|
||||
x
|
||||
(loop (f x (car args)) (cdr args))))))]))
|
||||
|
||||
(define %residual+ (addmul-reducer + 0))
|
||||
(define %residual* (addmul-reducer * 1))
|
||||
|
||||
(define-syntax subdiv-reducer
|
||||
(syntax-rules ()
|
||||
[(_ f)
|
||||
(lambda (x . args)
|
||||
(if (null? args)
|
||||
(f x)
|
||||
(let loop ([x x] [args args])
|
||||
(if (null? args)
|
||||
x
|
||||
(loop (f x (car args)) (cdr args))))))]))
|
||||
|
||||
(define %residual- (subdiv-reducer -))
|
||||
(define %residual/ (subdiv-reducer /))
|
||||
|
||||
(define %residual-member (binary-ternary-adaptor member))
|
||||
(define %residual-assoc (binary-ternary-adaptor assoc))
|
||||
|
||||
(define (%residual-list* x . l)
|
||||
(let loop ([x x] [l l])
|
||||
(if (null? l) x (cons x (loop (car l) (cdr l))))))
|
||||
|
||||
(define (%residual-apply f x . l)
|
||||
(apply f
|
||||
(let loop ([x x] [l l])
|
||||
(if (null? l) x (cons x (loop (car l) (cdr l)))))))
|
||||
|
||||
(define (%residual-map p l . l*)
|
||||
(if (null? l*)
|
||||
(let loop ([l l] [r '()])
|
||||
(if (pair? l) (loop (cdr l) (cons (p (car l)) r)) (reverse! r)))
|
||||
(let loop ([l* (cons l l*)] [r '()])
|
||||
(if (let lp ([l* l*]) (or (null? l*) (and (pair? (car l*)) (lp (cdr l*)))))
|
||||
(loop (map cdr l*) (cons (apply p (map car l*)) r))
|
||||
(reverse! r)))))
|
||||
|
||||
(define (%residual-for-each p l . l*)
|
||||
(if (null? l*)
|
||||
(let loop ([l l]) (if (pair? l) (begin (p (car l)) (loop (cdr l)))))
|
||||
(let loop ([l* (cons l l*)])
|
||||
(if (let lp ([l* l*]) (or (null? l*) (and (pair? (car l*)) (lp (cdr l*)))))
|
||||
(begin (apply p (map car l*)) (loop (map cdr l*)))))))
|
||||
|
||||
(define (string-map p s . s*)
|
||||
(if (null? s*)
|
||||
(let* ([len (string-length s)] [res (make-string len)])
|
||||
(do ([i 0 (fx+ i 1)]) [(fx>=? i len) res]
|
||||
(string-set! res i (p (string-ref s i)))))
|
||||
(list->string (apply map p (map string->list (cons s s*))))))
|
||||
|
||||
(define (vector-map p v . v*)
|
||||
(if (null? v*)
|
||||
(let* ([len (vector-length v)] [res (make-vector len)])
|
||||
(do ([i 0 (fx+ i 1)]) [(fx>=? i len) res]
|
||||
(vector-set! res i (p (vector-ref v i)))))
|
||||
(list->vector (apply map p (map vector->list (cons v v*))))))
|
||||
|
||||
(define (string-for-each p s . s*)
|
||||
(if (null? s*)
|
||||
(let ([len (string-length s)])
|
||||
(do ([i 0 (fx+ i 1)]) [(fx>=? i len)] (p (string-ref s i))))
|
||||
(apply for-each p (map string->list (cons s s*)))))
|
||||
|
||||
(define (vector-for-each p v . v*)
|
||||
(if (null? v*)
|
||||
(let ([len (vector-length v)])
|
||||
(do ([i 0 (fx+ i 1)]) [(fx>=? i len)] (p (vector-ref v i))))
|
||||
(apply for-each p (map vector->list (cons v v*)))))
|
||||
|
||||
(define-syntax append-reducer
|
||||
(syntax-rules ()
|
||||
[(_ f s)
|
||||
(lambda args
|
||||
(let loop ([args args])
|
||||
(cond [(null? args) s]
|
||||
[(null? (cdr args)) (car args)]
|
||||
[else (f (car args) (loop (cdr args)))])))]))
|
||||
|
||||
(define %residual-append (append-reducer append '()))
|
||||
(define %residual-string-append (append-reducer string-append ""))
|
||||
(define %residual-vector-append (append-reducer vector-append '#()))
|
||||
|
||||
(define %residual-number->string (unary-binary-adaptor number->string))
|
||||
(define %residual-string->number (unary-binary-adaptor string->number))
|
||||
|
||||
Loading…
Reference in a new issue