; LibS: Small RNRS compatibility library for #F, fixnum/flonum arithmetics
; #F's predefined forms:
;
; begin define define-syntax if lambda quote
; set! syntax-lambda syntax-rules
;------------------------------------------------------------------------------
; basic syntax constructs, extended lambda
(define-syntax syntax-rule
(syntax-rules ()
[(_ pat tmpl) (syntax-rules () [(__ . pat) tmpl])]))
(define-syntax let-syntax
(syntax-rules ()
[(_ ([kw init] ...))
(begin)]
[(_ ([kw init] ...) . body)
((syntax-lambda (kw ...) . body)
init ...)]))
(define-syntax letrec-syntax
(let-syntax ([let-syntax let-syntax] [define-syntax define-syntax])
(syntax-rules ()
[(_ ([kw init] ...) . body)
(let-syntax ()
(define-syntax kw init) ... (let-syntax () . body))])))
(define-syntax lambda
(let-syntax ([old-lambda lambda])
(letrec-syntax
([loop
(syntax-rules ()
[(_ (narg . more) (arg ...) . body)
(loop more (arg ... narg) . body)]
[(_ rarg (arg ...) . body)
(make-improper-lambda ; see definition below
#&(length (arg ...))
(old-lambda (arg ... rarg) (let-syntax () . body)))])])
(syntax-rules ()
[(_ (arg ...) . body)
(old-lambda (arg ...) (let-syntax () . body))]
[(_ args . body)
(loop args () . body)]))))
; definition forms
(define-syntax define
(let-syntax ([old-define define])
(letrec-syntax
([new-define
(syntax-rules ()
[(_ exp) (old-define exp)]
[(_ (var-or-prototype . args) . body)
(new-define var-or-prototype (lambda args . body))]
[(_ . other) (old-define . other)])])
new-define)))
(define-syntax define-inline
(letrec-syntax
([loop
(syntax-rules ()
[(_ id ([v e] ...) () . body)
(begin
(define-syntax id
(syntax-rules ()
[(_ e ...)
((lambda (v ...) . body) e ...)]
[_ #&(string->id #&(string-append "%residual-" #&(id->string id)))]))
(define #&(string->id #&(string-append "%residual-" #&(id->string id)))
(lambda (v ...) . body)))]
[(_ id (b ...) (v . vs) . body)
(loop id (b ... [v e]) vs . body)])])
(syntax-rules ()
[(_ (id v ...) . body)
(loop id () (v ...) . body)]
[(_ #&(id? id) val)
(define-syntax id val)])))
(define-syntax define-integrable
(syntax-rules ()
[(_ (op . ll) . body)
(define-syntax op
(%quote (letrec ([op (lambda ll . body)]) op)))]))
; primitive definition helpers
(define-syntax %prim*/rev
(letrec-syntax
([loop
(syntax-rules ()
[(_ prim () args)
(%prim* prim . args)]
[(_ prim (arg . more) args)
(loop prim more (arg . args))])])
(syntax-rules ()
[(_ prim arg ...)
(loop prim (arg ...) ())])))
; binding forms
(define-syntax let
(syntax-rules ()
[(_ ([var init] ...) . body)
((lambda (var ...) . body) init ...)]
[(_ name ([var init] ...) . body)
((letrec ([name (lambda (var ...) . body)])
name)
init ...)]))
(define-syntax let*
(syntax-rules ()
[(_ () . body) (let () . body)]
[(_ ([var init] . bindings) . body)
(let ([var init]) (let* bindings . body))]))
(define-syntax letrec
(syntax-rules ()
[(_ ([var init] ...) . body)
(let () (define var init) ... (let () . body))]))
(define-syntax letrec*
(syntax-rules ()
[(_ ([var expr] ...) . body)
(let ([var #f] ...)
(set! var expr)
...
(let () . body))]))
(define-syntax rec
(syntax-rules ()
[(_ (name . args) . body)
(letrec ([name (lambda args . body)]) name)]
[(_ name expr)
(letrec ([name expr]) name)]))
(define-syntax letcc
(let-syntax ([old-letcc letcc])
(syntax-rules ()
[(_ var . body)
(old-letcc var (let-syntax () . body))])))
(define-syntax receive
(syntax-rules ()
[(_ formals expr . body)
(call-with-values
(lambda () expr)
(lambda formals . body))]))
; control
(define-syntax when
(syntax-rules ()
[(_ test . body) (if test (let-syntax () . body))]))
(define-syntax unless
(syntax-rules ()
[(_ test . body) (if test (if #f #f) (let-syntax () . body))]))
(define-syntax cond
(syntax-rules (else =>)
[(_) (if #f #f)] ; undefined
[(_ [else . exps]) (let () . exps)]
[(_ [x] . rest) (or x (cond . rest))]
[(_ [x => proc] . rest)
(let ([tmp x]) (cond [tmp (proc tmp)] . rest))]
[(_ [x . exps] . rest)
(if x (let () . exps) (cond . rest))]))
(define-syntax and
(syntax-rules ()
[(_) #t]
[(_ test) (let () test)]
[(_ test . tests) (if test (and . tests) #f)]))
(define-syntax or
(syntax-rules ()
[(_) #f]
[(_ test) (let () test)]
[(_ test . tests) (let ([x test]) (if x x (or . tests)))]))
(define-syntax do
(let-syntax ([do-step (syntax-rules () [(_ x) x] [(_ x y) y])])
(syntax-rules ()
[(_ ([var init step ...] ...)
[test expr ...]
command ...)
(let loop ([var init] ...)
(if test
(begin (if #f #f) expr ...)
(let ()
command ...
(loop (do-step var step ...) ...))))])))
;------------------------------------------------------------------------------
; scheme data types
(%definition "/* basic object representation */")
; immediate objects have 7-bit tag followed by at least 24 bits of data
; subtype bits follow lsb which is 1 in non-pointer objects
(%definition "#define isimm(o, t) (((o) & 0xff) == (((t) << 1) | 1))")
(%localdef "long getimmu(obj o, int t) {
assert(isimm(o, t));
return (long)((o >> 8) & 0xffffff);
}")
(%localdef "long getimms(obj o, int t) {
assert(isimm(o, t));
return (long)((((o >> 8) & 0xffffff) ^ 0x800000) - 0x800000);
}")
(%definition "#ifdef NDEBUG
#define getimmu(o, t) (long)(((o) >> 8) & 0xffffff)
#define getimms(o, t) (long)(((((o) >> 8) & 0xffffff) ^ 0x800000) - 0x800000)
#else
extern long getimmu(obj o, int t);
extern long getimms(obj o, int t);
#endif")
(%definition "#define mkimm(o, t) (obj)((((o) & 0xffffff) << 8) | ((t) << 1) | 1)")
; native blocks are 1-element blocks containing a native
; (non-cx) pointer as 0th element and cxtype ptr in block header
(%localdef "#ifndef NDEBUG
int isnative(obj o, cxtype_t *tp) {
return isobjptr(o) && objptr_from_obj(o)[-1] == (obj)tp;
}
void *getnative(obj o, cxtype_t *tp) {
assert(isnative(o, tp));
return (void*)(*objptr_from_obj(o));
}
#endif")
(%definition "#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")
; tagged blocks are heap blocks with runtime int tag as 0th element
; (disjoint from closures which have a pointer as 0th element)
(%localdef "int istagged(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); }
}")
(%localdef "obj cktagged(obj o, int t) {
assert(istagged(o, t));
return o;
}")
(%localdef "int taggedlen(obj o, int t) {
assert(istagged(o, t));
return hblklen(o) - 1;
}")
(%localdef "obj* taggedref(obj o, int t, int i) {
int len; assert(istagged(o, t));
len = hblklen(o);
assert(i >= 0 && i < len-1);
return &hblkref(o, i+1);
}")
(%definition "extern int istagged(obj o, int t);")
(%definition "#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")
; void
; this is the value to be used where it doesn't really matter what value
; is used. Standard header supports void value, which is some immediate
; which looks funny in the debugger; it might correspond to a useful value,
; but we don't really care.
(define-inline (void) (%prim "void(0)"))
; booleans
; #f is (obj)0, #t is immediate 0 with tag 0 (singular true object)
; this layout is compatible with C conventions (0 = false, 1 = true)
; note that any obj but #f is counted as true in conditionals and that
; bool_from_obj and bool_from_bool are already defined in std prelude
(%definition "/* booleans */")
(%definition "#define TRUE_ITAG 0")
(%definition "typedef int bool_t;")
(%definition "#define is_bool_obj(o) (!((o) & ~(obj)1))")
(%definition "#define is_bool_bool(b) ((void)(b), 1)")
(%definition "#define void_from_bool(b) (void)(b)")
(%definition "#define obj_from_bool(b) ((b) ? mkimm(0, TRUE_ITAG) : 0)")
(define-syntax %const
(let-syntax ([old-%const %const])
(syntax-rules (boolean)
[(_ boolean b) (%prim ("bool(" b ")"))]
[(_ arg ...) (old-%const arg ...)])))
(define-inline (boolean? x)
(%prim "bool(is_bool_$arg)" x))
(define-inline (not x)
(%prim "bool(!bool_from_$arg)" x))
; numerical helpers
(%definition "/* numbers */")
(%definition "#define FIXNUM_BIT 24")
(%definition "#define FIXNUM_MIN -8388608")
(%definition "#define FIXNUM_MAX 8388607")
(%definition "#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 fxidv(x, y) ((x) / (y))
/* truncated division (common/C99) */
#define fxquo(x, y) ((x) / (y))
#define fxrem(x, y) ((x) % (y))
/* floor division */
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 fxdiv(long x, long y) {
long q = x / y, r = x % y; return (r < 0) ? ((y > 0) ? q - 1 : q + 1) : q;
}
static long fxmod(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 fxidv(long x, long y);
extern long fxquo(long x, long y);
extern long fxrem(long x, long y);
extern long fxmlo(long x, long y);
extern long fxdiv(long x, long y);
extern long fxmod(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")
(%localdef "#ifndef NDEBUG
long fxneg(long x) {
assert(x != FIXNUM_MIN);
return -x;
}
long fxabs(long x) {
assert(x != FIXNUM_MIN);
return labs(x);
}
long fxadd(long x, long y) {
long z = x + y;
assert(z >= FIXNUM_MIN && z <= FIXNUM_MAX);
return z;
}
long fxsub(long x, long y) {
long z = x - y;
assert(z >= FIXNUM_MIN && z <= FIXNUM_MAX);
return z;
}
long fxmul(long x, long y) {
double z = (double)x * (double)y;
assert(z >= FIXNUM_MIN && z <= FIXNUM_MAX);
return x * y;
}
/* exact integer division */
long fxidv(long x, long y) {
assert(y);
assert(x != FIXNUM_MIN || y != -1);
assert(x % y == 0);
return x / y;
}
/* truncated division (common/C99) */
long fxquo(long x, long y) {
assert(y); assert(x != FIXNUM_MIN || y != -1);
return x / y;
}
long fxrem(long x, long y) {
assert(y);
return x % y;
}
/* floor division */
long fxmlo(long x, long y) {
long r; assert(y); r = x % y;
return ((r < 0 && y > 0) || (r > 0 && y < 0)) ? r + y : r;
}
/* euclidean division */
long fxdiv(long x, long y) {
long q, r; assert(y); assert(x != FIXNUM_MIN || y != -1);
q = x / y, r = x % y;
return (r < 0) ? ((y > 0) ? q - 1 : q + 1) : q;
}
long fxmod(long x, long y) {
long r; assert(y); r = x % y;
return (r < 0) ? ((y > 0) ? r + y : r - y) : r;
}
long fxgcd(long x, long y) {
long a = labs(x), b = labs(y), c;
while (b) c = a%b, a = b, b = c;
assert(a <= FIXNUM_MAX);
return a;
}
long fxasl(long x, long y) {
assert(y >= 0 && y < FIXNUM_BIT);
return x << y;
}
long fxasr(long x, long y) {
assert(y >= 0 && y < FIXNUM_BIT);
assert(!y || x >= 0); /* >> of negative x is undefined */
return x >> y;
}
long fxflo(double f) {
long l = (long)f; assert((double)l == f);
assert(l >= FIXNUM_MIN && l <= FIXNUM_MAX);
return l;
}
#endif")
(%definition "static int flisint(double f) { return f > -HUGE_VAL && f < HUGE_VAL && f == floor(f); }")
(%definition "extern long fxpow(long x, long y);")
(%localdef "long fxpow(long x, long y) {
assert(y >= 0);
retry: if (y == 0) return 1; if (y == 1) return x;
if (y % 2 == 1) x *= fxpow(x, y-1);
else { x *= x; y /= 2; assert(FIXNUM_MIN <= x && x <= FIXNUM_MAX); goto retry; }
assert(FIXNUM_MIN <= x && x <= FIXNUM_MAX); return x;
}")
(%definition "extern int fxifdv(long x, long y, long *pi, double *pd);")
(%localdef "int fxifdv(long x, long y, long *pi, double *pd) {
assert(y); assert(x != FIXNUM_MIN || y != -1);
if (x % y == 0) { *pi = x / y; return 1; }
else { *pd = (double)x / (double)y; return 0; }
}")
(%definition "extern double flquo(double x, double y);")
(%localdef "double flquo(double x, double y) {
double z; assert(y != 0.0 && flisint(x) && flisint(y));
modf(x / y, &z);
return z;
}")
(%definition "extern double flrem(double x, double y);")
(%localdef "double flrem(double x, double y) {
assert(y != 0.0 && flisint(x) && flisint(y));
return fmod(x, y);
}")
(%definition "extern double flmlo(double x, double y);")
(%localdef "double flmlo(double x, double y) {
assert(y != 0.0 && flisint(x) && flisint(y));
return x - y * floor(x / y);
}")
(%definition "extern double flgcd(double x, double y);")
(%localdef "double flgcd(double x, double y) {
double a = fabs(x), b = fabs(y), c;
assert(flisint(a) && flisint(b));
while (b > 0.0) c = fmod(a, b), a = b, b = c;
return a;
}")
(%definition "extern double flround(double x);")
(%localdef "double flround(double x) {
double f = floor(x), c = ceil(x), d = x-f, u = c-x;
if (d == u) return fmod(f, 2.0) == 0.0 ? f : c;
else return (d < u) ? f : c;
}")
(%definition "extern int strtofxfl(char *s, int radix, long *pl, double *pd);")
(%localdef "int strtofxfl(char *s, int radix, long *pl, double *pd) {
char *e; int conv = 0, eno = errno; long l; double d;
for (; s[0] == '#'; s += 2) {
switch (s[1]) {
case 'b': case 'B': radix = 2; break;
case 'o': case 'O': radix = 8; break;
case 'd': case 'D': radix = 10; break;
case 'x': case 'X': radix = 16; break;
case 'e': case 'E': conv = 'e'; break;
case 'i': case 'I': conv = 'i'; break;
default: return 0;
}
}
if (isspace(*s)) return 0;
for (e = s; *e; ++e) { if (strchr(\".eEiInN\", *e)) break; }
if (!*e || radix != 10) { /* s is not a syntax for an inexact number */
l = (errno = 0, strtol(s, &e, radix));
if (errno || *e || e == s) { if (conv == 'i') goto fl; return (errno = eno, 0); }
if (conv == 'i') return (errno = eno, *pd = (double)l, 'i');
if (FIXNUM_MIN <= l && l <= FIXNUM_MAX) return (errno = eno, *pl = l, 'e');
return (errno = eno, 0); /* can't represent as an exact */
}
fl: if (radix != 10) return (errno = eno, 0);
e = \"\", errno = 0; if (*s != '+' && *s != '-') d = strtod(s, &e);
else if (strcmp(s+1, \"inf.0\") == 0) d = (*s == '-' ? -HUGE_VAL : HUGE_VAL);
else if (strcmp(s+1, \"nan.0\") == 0) d = strtod(\"NAN\", &e); /* since C99 */
else d = strtod(s, &e);
if (errno || *e || e == s) return (errno = eno, 0);
if ((conv == 'e') && ((l=(long)d) < FIXNUM_MIN || l > FIXNUM_MAX || (double)l != d))
return (errno = eno, 0); /* can't be converted to an exact number */
return (errno = eno, (conv == 'e') ? (*pl = fxflo(d), 'e') : (*pd = d, 'i'));
}")
; fixnums
; fixnums are immediate with immediate tag 1
(%definition "/* fixnums */")
(%definition "#define FIXNUM_ITAG 1")
(%definition "typedef long fixnum_t;")
(%definition "#define is_fixnum_obj(o) (isimm(o, FIXNUM_ITAG))")
(%definition "#define is_fixnum_fixnum(i) ((void)(i), 1)")
(%definition "#define is_bool_fixnum(i) ((void)(i), 0)")
(%definition "#define is_fixnum_bool(i) ((void)(i), 0)")
(%definition "#define fixnum_from_obj(o) (getimms(o, FIXNUM_ITAG))")
(%definition "#define fixnum_from_fixnum(i) (i)")
(%definition "#define fixnum_from_flonum(l,x) ((fixnum_t)(x))")
(%definition "#define bool_from_fixnum(i) ((void)(i), 1)")
(%definition "#define void_from_fixnum(i) (void)(i)")
(%definition "#define obj_from_fixnum(i) mkimm((fixnum_t)(i), FIXNUM_ITAG)")
(define-syntax %const
(let-syntax ([old-%const %const])
(letrec-syntax
([bin->oct
(syntax-rules ()
[(_ b sign digs) (bin->oct b sign #&(string->list digs) ())]
[(_ b sign () l) (%const integer b sign #&(list->string l) 8)]
[(_ b sign (#\0) l) (bin->oct b sign () (#\0 . l))]
[(_ b sign (#\1) l) (bin->oct b sign () (#\1 . l))]
[(_ b sign (#\0 #\0) l) (bin->oct b sign () (#\0 . l))]
[(_ b sign (#\0 #\1) l) (bin->oct b sign () (#\1 . l))]
[(_ b sign (#\1 #\0) l) (bin->oct b sign () (#\2 . l))]
[(_ b sign (#\1 #\1) l) (bin->oct b sign () (#\3 . l))]
[(_ b sign (d ... #\0 #\0 #\0) l) (bin->oct b sign (d ...) (#\0 . l))]
[(_ b sign (d ... #\0 #\0 #\1) l) (bin->oct b sign (d ...) (#\1 . l))]
[(_ b sign (d ... #\0 #\1 #\0) l) (bin->oct b sign (d ...) (#\2 . l))]
[(_ b sign (d ... #\0 #\1 #\1) l) (bin->oct b sign (d ...) (#\3 . l))]
[(_ b sign (d ... #\1 #\0 #\0) l) (bin->oct b sign (d ...) (#\4 . l))]
[(_ b sign (d ... #\1 #\0 #\1) l) (bin->oct b sign (d ...) (#\5 . l))]
[(_ b sign (d ... #\1 #\1 #\0) l) (bin->oct b sign (d ...) (#\6 . l))]
[(_ b sign (d ... #\1 #\1 #\1) l) (bin->oct b sign (d ...) (#\7 . l))])])
(syntax-rules (integer exact inexact)
[(_ integer 8 sign digs 2) (bin->oct 8 sign digs)]
[(_ integer 16 sign digs 2) (bin->oct 16 sign digs)]
[(_ integer 24 sign digs 2) (bin->oct 24 sign digs)]
[(_ integer 8 sign digs 8) (%prim ("fixnum(" #&(id->string sign) "0" digs ")"))]
[(_ integer 16 sign digs 8) (%prim ("fixnum(" #&(id->string sign) "0" digs ")"))]
[(_ integer 24 sign digs 8) (%prim ("fixnum(" #&(id->string sign) "0" digs ")"))]
[(_ integer 8 sign digs 10) (%prim ("fixnum(" #&(id->string sign) digs ")"))]
[(_ integer 16 sign digs 10) (%prim ("fixnum(" #&(id->string sign) digs ")"))]
[(_ integer 24 sign digs 10) (%prim ("fixnum(" #&(id->string sign) digs ")"))]
[(_ integer 8 sign digs 16) (%prim ("fixnum(" #&(id->string sign) "0x" digs ")"))]
[(_ integer 16 sign digs 16) (%prim ("fixnum(" #&(id->string sign) "0x" digs ")"))]
[(_ integer 24 sign digs 16) (%prim ("fixnum(" #&(id->string sign) "0x" digs ")"))]
[(_ exact (integer . r)) (%const integer . r)]
[(_ inexact (integer . r)) (exact->inexact (%const integer . r))]
[(_ arg ...) (old-%const arg ...)]))))
(define-inline (fixnum? x)
(%prim "bool(is_fixnum_$arg)" x))
(define-inline (fixnum-width)
(%prim "fixnum(FIXNUM_BIT)"))
(define-inline (least-fixnum)
(%prim "fixnum(FIXNUM_MIN)"))
(define-inline (greatest-fixnum)
(%prim "fixnum(FIXNUM_MAX)"))
(define-syntax fx=?
(syntax-rules ()
[(_ x y) (%prim "bool(fixnum_from_$arg == fixnum_from_$arg)" x y)]
[(_ x y z ...) (let ([t y]) (and (fx=? x t) (fx=? t z ...)))]
[_ %residual-fx=?]))
(define-syntax fx<?
(syntax-rules ()
[(_ x y) (%prim "bool(fixnum_from_$arg < fixnum_from_$arg)" x y)]
[(_ x y z ...) (let ([t y]) (and (fx<? x t) (fx<? t z ...)))]
[_ %residual-fx<?]))
(define-syntax fx>?
(syntax-rules ()
[(_ x y) (%prim "bool(fixnum_from_$arg > fixnum_from_$arg)" x y)]
[(_ x y z ...) (let ([t y]) (and (fx>? x t) (fx>? t z ...)))]
[_ %residual-fx>?]))
(define-syntax fx<=?
(syntax-rules ()
[(_ x y) (%prim "bool(fixnum_from_$arg <= fixnum_from_$arg)" x y)]
[(_ x y z ...) (let ([t y]) (and (fx<=? x t) (fx<=? t z ...)))]
[_ %residual-fx<=?]))
(define-syntax fx>=?
(syntax-rules ()
[(_ x y) (%prim "bool(fixnum_from_$arg >= fixnum_from_$arg)" x y)]
[(_ x y z ...) (let ([t y]) (and (fx>=? x t) (fx>=? t z ...)))]
[_ %residual-fx>=?]))
(define-inline (fxzero? x)
(%prim "bool(fixnum_from_$arg == 0)" x))
(define-inline (fxpositive? x)
(%prim "bool(fixnum_from_$arg > 0)" x))
(define-inline (fxnegative? x)
(%prim "bool(fixnum_from_$arg < 0)" x))
(define-inline (fxodd? x)
(%prim "bool((fixnum_from_$arg & 1) != 0)" x))
(define-inline (fxeven? x)
(%prim "bool((fixnum_from_$arg & 1) == 0)" x))
(define-syntax fxmax
(syntax-rules ()
[(_ x) x]
[(_ x y) (let ([a x] [b y]) (if (fx>? a b) a b))]
[(_ x y z ...) (fxmax (fxmax x y) z ...)]
[_ %residual-fxmax]))
(define-syntax fxmin
(syntax-rules ()
[(_ x) x]
[(_ x y) (let ([a x] [b y]) (if (fx<? a b) a b))]
[(_ x y z ...) (fxmin (fxmin x y) z ...)]
[_ %residual-fxmin]))
(define-syntax fx+
(syntax-rules ()
[(_) (%prim "fixnum(0)")] [(_ x) x]
[(_ x y) (%prim "fixnum(fxadd(fixnum_from_$arg, fixnum_from_$arg))" x y)]
[(_ x y z ...) (fx+ x (fx+ y z ...))]
[_ %residual-fx+]))
(define-syntax fx*
(syntax-rules ()
[(_) (%prim "fixnum(1)")] [(_ x) x]
[(_ x y) (%prim "fixnum(fxmul(fixnum_from_$arg, fixnum_from_$arg))" x y)]
[(_ x y z ...) (fx* x (fx* y z ...))]
[_ %residual-fx*]))
(define-syntax fx-
(syntax-rules ()
[(_ x) (%prim "fixnum(fxneg(fixnum_from_$arg))" x)]
[(_ x y) (%prim "fixnum(fxsub(fixnum_from_$arg, fixnum_from_$arg))" x y)]
[(_ x y z ...) (fx- (fx- x y) z ...)]
[_ %residual-fx-]))
(define-syntax fx/
(syntax-rules ()
[(_ x) (%prim "fixnum(fxidv(1, fixnum_from_$arg))" x)]
[(_ x y) (%prim "fixnum(fxidv(fixnum_from_$arg, fixnum_from_$arg))" x y)]
[(_ x y z ...) (fx/ (fx/ x y) z ...)]
[_ %residual-fx/]))
(define-inline (fxquotient x y)
(%prim "fixnum(fxquo(fixnum_from_$arg, fixnum_from_$arg))" x y))
(define-inline (fxremainder x y)
(%prim "fixnum(fxrem(fixnum_from_$arg, fixnum_from_$arg))" x y))
(define-inline (fxmodulo x y)
(%prim "fixnum(fxmlo(fixnum_from_$arg, fixnum_from_$arg))" x y))
(define-inline (fxdiv x y)
(%prim "fixnum(fxdiv(fixnum_from_$arg, fixnum_from_$arg))" x y))
(define-inline (fxmod x y)
(%prim "fixnum(fxmod(fixnum_from_$arg, fixnum_from_$arg))" x y))
(define-inline (fxabs x)
(%prim "fixnum(fxabs(fixnum_from_$arg))" x))
(define-inline (fxgcd x y)
(%prim "fixnum(fxgcd(fixnum_from_$arg, fixnum_from_$arg))" x y))
(define-inline (fxexpt x y)
(%prim* "fixnum(fxpow(fixnum_from_$arg, fixnum_from_$arg))" x y))
(define-inline (fxnot x)
(%prim "fixnum(~fixnum_from_$arg)" x))
(define-inline (fxand x y)
(%prim "fixnum(fixnum_from_$arg & fixnum_from_$arg)" x y))
(define-inline (fxior x y)
(%prim "fixnum(fixnum_from_$arg | fixnum_from_$arg)" x y))
(define-inline (fxxor x y)
(%prim "fixnum(fixnum_from_$arg ^ fixnum_from_$arg)" x y))
(define-inline (fxarithmetic-shift-left x y)
(%prim "fixnum(fxasl(fixnum_from_$arg, fixnum_from_$arg))" x y))
(define-inline (fxarithmetic-shift-right x y)
(%prim "fixnum(fxasr(fixnum_from_$arg, fixnum_from_$arg))" x y))
; flonums
(%include <math.h>)
(%include <errno.h>)
(%definition "/* flonums */")
(%localdef "static cxtype_t cxt_flonum = { \"flonum\", free };")
(%localdef "cxtype_t *FLONUM_NTAG = &cxt_flonum;")
(%definition "extern cxtype_t *FLONUM_NTAG;")
(%definition "typedef double flonum_t;")
(%definition "#define is_flonum_obj(o) (isnative(o, FLONUM_NTAG))")
(%definition "#define is_flonum_flonum(f) ((void)(f), 1)")
(%definition "#define is_flonum_bool(f) ((void)(f), 0)")
(%definition "#define is_bool_flonum(f) ((void)(f), 0)")
(%definition "#define is_fixnum_flonum(i) ((void)(i), 0)")
(%definition "#define is_flonum_fixnum(i) ((void)(i), 0)")
(%definition "#define flonum_from_obj(o) (*(flonum_t*)getnative(o, FLONUM_NTAG))")
(%definition "#define flonum_from_flonum(l, f) (f)")
(%definition "#define flonum_from_fixnum(x) ((flonum_t)(x))")
(%definition "#define bool_from_flonum(f) ((void)(f), 0)")
(%definition "#define void_from_flonum(l, f) (void)(f)")
(%definition "#define obj_from_flonum(l, f) hpushptr(dupflonum(f), FLONUM_NTAG, l)")
(%definition "extern flonum_t *dupflonum(flonum_t f);")
(%localdef "flonum_t *dupflonum(flonum_t f) {
flonum_t *pf = cxm_cknull(malloc(sizeof(flonum_t)), \"malloc(flonum)\");
*pf = f; return pf;
}")
(define-syntax %const
(let-syntax ([old-%const %const])
(syntax-rules (decimal e exact inexact inf nan)
[(_ decimal e str)
(%prim* ("flonum($live, " str ")"))]
[(_ decimal e ms indigs frdigs es exdigs)
(%prim* ("flonum($live, " #&(id->string ms)
indigs "." frdigs "e" #&(id->string es) exdigs ")"))]
[(_ inexact (decimal . r)) (%const decimal . r)]
[(_ exact (decimal . r)) (inexact->exact (%const decimal . r))]
[(_ inf ms) (%prim* ("flonum($live, " #&(id->string ms) "HUGE_VAL)"))]
[(_ inexact (inf . r)) (%const inf . r)]
[(_ nan ms) (%prim* ("flonum($live, HUGE_VAL-HUGE_VAL)"))]
[(_ inexact (nan . r)) (%const nan . r)]
[(_ arg ...) (old-%const arg ...)])))
(define-inline (flonum? x)
(%prim "bool(is_flonum_$arg)" x))
(define-inline (fixnum->flonum n)
(%prim* "flonum($live, (flonum_t)fixnum_from_$arg)" n))
(define-inline (flonum->fixnum x)
(%prim "fixnum(fxflo(flonum_from_$arg))" x))
(define-inline (real->flonum n)
(if (flonum? n) n (fixnum->flonum n)))
(define-inline (real->fixnum n)
(if (fixnum? n) n (flonum->fixnum n)))
(define-syntax fl=?
(syntax-rules ()
[(_ x y) (%prim "bool(flonum_from_$arg == flonum_from_$arg)" x y)]
[(_ x y z ...) (let ([t y]) (and (fl=? x t) (fl=? t z ...)))]
[_ %residual-fl=?]))
(define-syntax fl<?
(syntax-rules ()
[(_ x y) (%prim "bool(flonum_from_$arg < flonum_from_$arg)" x y)]
[(_ x y z ...) (let ([t y]) (and (fl<? x t) (fl<? t z ...)))]
[_ %residual-fl<?]))
(define-syntax fl>?
(syntax-rules ()
[(_ x y) (%prim "bool(flonum_from_$arg > flonum_from_$arg)" x y)]
[(_ x y z ...) (let ([t y]) (and (fl>? x t) (fl>? t z ...)))]
[_ %residual-fl>?]))
(define-syntax fl<=?
(syntax-rules ()
[(_ x y) (%prim "bool(flonum_from_$arg <= flonum_from_$arg)" x y)]
[(_ x y z ...) (let ([t y]) (and (fl<=? x t) (fl<=? t z ...)))]
[_ %residual-fl<=?]))
(define-syntax fl>=?
(syntax-rules ()
[(_ x y) (%prim "bool(flonum_from_$arg >= flonum_from_$arg)" x y)]
[(_ x y z ...) (let ([t y]) (and (fl>=? x t) (fl>=? t z ...)))]
[_ %residual-fl>=?]))
(define-inline (flinteger? x)
(%prim "bool(flisint(flonum_from_$arg))" x))
(define-inline (flzero? x)
(%prim "bool(flonum_from_$arg == 0.0)" x))
(define-inline (flpositive? x)
(%prim "bool(flonum_from_$arg > 0.0)" x))
(define-inline (flnegative? x)
(%prim "bool(flonum_from_$arg < 0.0)" x))
(define-inline (flodd? x)
(%prim "bool(flisint((flonum_from_$arg + 1.0) / 2.0))" x))
(define-inline (fleven? x)
(%prim "bool(flisint(flonum_from_$arg / 2.0))" x))
(define-syntax flmax
(syntax-rules ()
[(_ x) x]
[(_ x y) (let ([a x] [b y]) (if (fl>? a b) a b))]
[(_ x y z ...) (flmax (flmax x y) z ...)]
[_ %residual-flmax]))
(define-syntax flmin
(syntax-rules ()
[(_ x) x]
[(_ x y) (let ([a x] [b y]) (if (fl<? a b) a b))]
[(_ x y z ...) (flmin (flmin x y) z ...)]
[_ %residual-flmin]))
(define-syntax fl+
(syntax-rules ()
[(_) (%prim* "flonum($live, 0.0)")] [(_ x) x]
[(_ x y) (%prim* "flonum($live, flonum_from_$arg + flonum_from_$arg)" x y)]
[(_ x y z ...) (fl+ x (fl+ y z ...))]
[_ %residual-fl+]))
(define-syntax fl*
(syntax-rules ()
[(_) (%prim* "flonum($live, 1.0)")] [(_ x) x]
[(_ x y) (%prim* "flonum($live, flonum_from_$arg * flonum_from_$arg)" x y)]
[(_ x y z ...) (fl* x (fl* y z ...))]
[_ %residual-fl*]))
(define-syntax fl-
(syntax-rules ()
[(_ x) (%prim* "flonum($live, -flonum_from_$arg)" x)]
[(_ x y) (%prim* "flonum($live, flonum_from_$arg - flonum_from_$arg)" x y)]
[(_ x y z ...) (fl- (fl- x y) z ...)]
[_ %residual-fl-]))
(define-syntax fl/
(syntax-rules ()
[(_ x) (%prim* "flonum($live, 1.0/flonum_from_$arg)" x)]
[(_ x y) (%prim* "flonum($live, flonum_from_$arg / flonum_from_$arg)" x y)]
[(_ x y z ...) (fl/ (fl/ x y) z ...)]
[_ %residual-fl/]))
(define-inline (flquotient x y)
(%prim* "flonum($live, flquo(flonum_from_$arg, flonum_from_$arg))" x y))
(define-inline (flremainder x y)
(%prim* "flonum($live, flrem(flonum_from_$arg, flonum_from_$arg))" x y))
(define-inline (flmodulo x y)
(%prim* "flonum($live, flmlo(flonum_from_$arg, flonum_from_$arg))" x y))
(define-inline (flabs x)
(%prim* "flonum($live, fabs(flonum_from_$arg))" x))
(define-inline (flgcd x y)
(%prim* "flonum($live, flgcd(flonum_from_$arg, flonum_from_$arg))" x y))
(define-inline (flfloor x)
(%prim* "flonum($live, floor(flonum_from_$arg))" x))
(define-inline (flceiling x)
(%prim* "flonum($live, ceil(flonum_from_$arg))" x))
(define-inline (fltruncate x)
(%prim* "{ /* fltruncate */
flonum_t x = flonum_from_$arg;
double i; modf(x, &i);
$return flonum($live, i); }" x))
(define-inline (flround x)
(%prim* "flonum($live, flround(flonum_from_$arg))" x))
(define-inline (flsqrt x)
(%prim* "flonum($live, sqrt(flonum_from_$arg))" x))
(define-inline (flexp x)
(%prim* "flonum($live, exp(flonum_from_$arg))" x))
(define-inline (fllog x)
(%prim* "flonum($live, log(flonum_from_$arg))" x))
(define-inline (fllog10 x)
(%prim* "flonum($live, log10(flonum_from_$arg))" x))
(define-inline (flsin x)
(%prim* "flonum($live, sin(flonum_from_$arg))" x))
(define-inline (flcos x)
(%prim* "flonum($live, cos(flonum_from_$arg))" x))
(define-inline (fltan x)
(%prim* "flonum($live, tan(flonum_from_$arg))" x))
(define-inline (flasin x)
(%prim* "flonum($live, asin(flonum_from_$arg))" x))
(define-inline (flacos x)
(%prim* "flonum($live, acos(flonum_from_$arg))" x))
(define-syntax flatan
(syntax-rules ()
[(_ x) (%prim* "flonum($live, atan(flonum_from_$arg))" x)]
[(_ y x) (%prim* "flonum($live, atan2(flonum_from_$arg, flonum_from_$arg))" y x)]
[_ %residual-flatan]))
(define-inline (flexpt x y)
(%prim* "flonum($live, pow(flonum_from_$arg, flonum_from_$arg))" x y))
(define-inline (fxfl/ x y)
(%prim* "{ /* fxfl/ */
fixnum_t x = fixnum_from_$arg, y = fixnum_from_$arg;
long i; double d;
if (0) $return obj(0); /* to fool sfc unboxer */
else if (fxifdv(x, y, &i, &d)) $return fixnum(i);
else $return flonum($live, d); }" x y))
; generic math (fixnum/flonum)
(define-inline (real? x)
(or (fixnum? x) (flonum? x)))
(define-inline (integer? x)
(or (fixnum? x) (and (flonum? x) (flinteger? x))))
(define-inline rational? integer?)
(define-inline complex? real?)
(define-inline number? real?)
(define-inline exact? fixnum?)
(define-inline inexact? flonum?)
(define-inline (inexact->exact x)
(if (fixnum? x) x (flonum->fixnum x)))
(define-inline (exact->inexact x)
(if (flonum? x) x (fixnum->flonum x)))
(define-syntax real-binop
(syntax-rules ()
[(_ x y fxop flop)
(let ([a x] [b y])
(if (fixnum? a)
(if (fixnum? b)
(fxop a b)
(flop (fixnum->flonum a) b))
(if (fixnum? b)
(flop a (fixnum->flonum b))
(flop a b))))]))
(define-syntax =
(syntax-rules ()
[(_ x y) (real-binop x y fx=? fl=?)]
[(_ x y z ...) (let ([t y]) (and (= x t) (= t z ...)))]
[_ %residual=]))
(define-syntax <
(syntax-rules ()
[(_ x y) (real-binop x y fx<? fl<?)]
[(_ x y z ...) (let ([t y]) (and (< x t) (< t z ...)))]
[_ %residual<]))
(define-syntax >
(syntax-rules ()
[(_ x y) (real-binop x y fx>? fl>?)]
[(_ x y z ...) (let ([t y]) (and (> x t) (> t z ...)))]
[_ %residual>]))
(define-syntax <=
(syntax-rules ()
[(_ x y) (real-binop x y fx<=? fl<=?)]
[(_ x y z ...) (let ([t y]) (and (<= x t) (<= t z ...)))]
[_ %residual<=]))
(define-syntax >=
(syntax-rules ()
[(_ x y) (real-binop x y fx>=? fl>=?)]
[(_ x y z ...) (let ([t y]) (and (>= x t) (>= t z ...)))]
[_ %residual>=]))
(define-inline (zero? x)
(if (fixnum? x) (fxzero? x) (flzero? x)))
(define-inline (positive? x)
(if (fixnum? x) (fxpositive? x) (flpositive? x)))
(define-inline (negative? x)
(if (fixnum? x) (fxnegative? x) (flnegative? x)))
(define-inline (even? x)
(if (fixnum? x) (fxeven? x) (fleven? x)))
(define-inline (odd? x)
(if (fixnum? x) (fxodd? x) (flodd? x)))
(define-syntax max
(syntax-rules ()
[(_ x) x]
[(_ x y)
(let ([a x] [b y])
(if (and (fixnum? a) (fixnum? b)) (if (fx>? a b) a b) (%residual-max/2 a b)))]
[(_ x y z ...) (%residual-max x y z ...)]
[_ %residual-max]))
(define-syntax min
(syntax-rules ()
[(_ x) x]
[(_ x y)
(let ([a x] [b y])
(if (and (fixnum? a) (fixnum? b)) (if (fx<? a b) a b) (%residual-min/2 a b)))]
[(_ x y z ...) (%residual-min x y z ...)]
[_ %residual-min]))
(define-syntax +
(syntax-rules ()
[(_) 0]
[(_ x) x]
[(_ x y) (real-binop x y fx+ fl+)]
[(_ x y z ...) (+ (+ x y) z ...)]
[_ %residual+]))
(define-syntax *
(syntax-rules ()
[(_) 1]
[(_ x) x]
[(_ x y) (real-binop x y fx* fl*)]
[(_ x y z ...) (* (* x y) z ...)]
[_ %residual*]))
(define-syntax -
(syntax-rules ()
[(_ x) (let ([a x]) (if (fixnum? a) (fx- a) (fl- a)))]
[(_ x y) (real-binop x y fx- fl-)]
[(_ x y z ...) (- (- x y) z ...)]
[_ %residual-]))
(define-syntax /
(syntax-rules ()
[(_ x) (let ([a x]) (if (fixnum? a) (fxfl/ 1 a) (fl/ a)))]
[(_ x y) (real-binop x y fxfl/ fl/)]
[(_ x y z ...) (/ (/ x y) z ...)]
[_ %residual/]))
(define-inline (abs x)
(if (fixnum? x) (fxabs x) (flabs x)))
(define-inline (quotient x y)
(real-binop x y fxquotient flquotient))
(define-inline (remainder x y)
(real-binop x y fxremainder flremainder))
(define-inline (modulo x y)
(real-binop x y fxmodulo flmodulo))
(define-syntax gcd
(syntax-rules ()
[(_) 0]
[(_ x) x]
[(_ x y) (real-binop x y fxgcd flgcd)]
[(_ x y z ...) (gcd (gcd x y) z ...)]
[_ %residual-gcd]))
(define (lcm/2 x y)
(let ([g (gcd x y)])
(if (zero? g) g (* (quotient (abs x) g) (abs y)))))
(define-syntax lcm
(syntax-rules ()
[(_) 1]
[(_ x) x]
[(_ x y) (lcm/2 x y)]
[(_ x y z ...) (lcm (lcm/2 x y) z ...)]
[_ %residual-lcm]))
; no div
; no mod
(define-inline (numerator n)
n)
(define-inline (denominator n)
1)
(define-inline (rationalize n d)
n)
(define-inline (floor x)
(if (fixnum? x) x (flfloor x)))
(define-inline (ceiling x)
(if (fixnum? x) x (flceiling x)))
(define-inline (truncate x)
(if (fixnum? x) x (fltruncate x)))
(define-inline (round x)
(if (fixnum? x) x (flround x)))
; need exact version?
(define-inline (sqrt x)
(flsqrt (real->flonum x)))
(define-inline (exp x)
(flexp (real->flonum x)))
(define-inline (log x)
(fllog (real->flonum x)))
(define-inline (sin x)
(flsin (real->flonum x)))
(define-inline (cos x)
(flcos (real->flonum x)))
(define-inline (tan x)
(fltan (real->flonum x)))
(define-inline (asin x)
(flasin (real->flonum x)))
(define-inline (acos x)
(flacos (real->flonum x)))
(define-syntax atan
(syntax-rules ()
[(_ x) (flatan (real->flonum x))]
[(_ y x) (flatan (real->flonum y) (real->flonum x))]
[_ %residual-atan]))
(define-inline (expt x y)
(if (and (fixnum? x) (fixnum? y) (fx>=? y 0))
(fxexpt x y)
(flexpt (real->flonum x) (real->flonum y))))
; characters
(%include <ctype.h>)
; characters are immediate with immediate tag 2
(%definition "/* characters */")
(%definition "#define CHAR_ITAG 2")
(%definition "typedef int char_t;")
(%definition "#define ischar(o) (isimm(o, CHAR_ITAG))")
(%definition "#define is_char_obj(o) (isimm(o, CHAR_ITAG))")
(%definition "#define is_char_char(i) ((void)(i), 1)")
(%definition "#define is_char_bool(i) ((void)(i), 0)")
(%definition "#define is_bool_char(i) ((void)(i), 0)")
(%definition "#define is_char_fixnum(i) ((void)(i), 0)")
(%definition "#define is_fixnum_char(i) ((void)(i), 0)")
(%definition "#define is_char_flonum(i) ((void)(i), 0)")
(%definition "#define is_flonum_char(i) ((void)(i), 0)")
(%definition "#define char_from_obj(o) ((int)getimms(o, CHAR_ITAG))")
(%definition "#define char_from_char(i) (i)")
(%definition "#define bool_from_char(i) ((void)(i), 1)")
(%definition "#define void_from_char(i) (void)(i)")
(%definition "#define obj_from_char(i) mkimm(i, CHAR_ITAG)")
(define-syntax %const
(let-syntax ([old-%const %const])
(syntax-rules (char)
[(_ char 8 c) (%prim ("char(" c ")"))]
[(_ char cs) (%prim ("char('" cs "')"))]
[(_ arg ...) (old-%const arg ...)])))
(define-inline (char? x)
(%prim "bool(is_char_$arg)" x))
(define-inline (char=? x y)
(%prim "bool(char_from_$arg == char_from_$arg)" x y))
(define-inline (char<? x y)
(%prim "bool(char_from_$arg < char_from_$arg)" x y))
(define-inline (char>? x y)
(%prim "bool(char_from_$arg > char_from_$arg)" x y))
(define-inline (char<=? x y)
(%prim "bool(char_from_$arg <= char_from_$arg)" x y))
(define-inline (char>=? x y)
(%prim "bool(char_from_$arg >= char_from_$arg)" x y))
(define-inline (char-ci=? x y)
(%prim "bool(tolower(char_from_$arg) == tolower(char_from_$arg))" x y))
(define-inline (char-ci<? x y)
(%prim "bool(tolower(char_from_$arg) < tolower(char_from_$arg))" x y))
(define-inline (char-ci>? x y)
(%prim "bool(tolower(char_from_$arg) > tolower(char_from_$arg))" x y))
(define-inline (char-ci<=? x y)
(%prim "bool(tolower(char_from_$arg) <= tolower(char_from_$arg))" x y))
(define-inline (char-ci>=? x y)
(%prim "bool(tolower(char_from_$arg) >= tolower(char_from_$arg))" x y))
(define-inline (char-alphabetic? x)
(%prim "bool(isalpha(char_from_$arg))" x))
(define-inline (char-numeric? x)
(%prim "bool(isdigit(char_from_$arg))" x))
(define-inline (char-whitespace? x)
(%prim "bool(isspace(char_from_$arg))" x))
(define-inline (char-upper-case? x)
(%prim "bool(isupper(char_from_$arg))" x))
(define-inline (char-lower-case? x)
(%prim "bool(islower(char_from_$arg))" x))
(define-inline (char->integer x)
(%prim "fixnum((fixnum_t)char_from_$arg)" x))
(define-inline (integer->char x)
(%prim "char((char_t)fixnum_from_$arg)" x))
(define-inline (char-upcase x)
(%prim "char(toupper(char_from_$arg))" x))
(define-inline (char-downcase x)
(%prim "char(tolower(char_from_$arg))" x))
; strings
(%include <string.h>)
(%definition "/* strings */")
(%localdef "static cxtype_t cxt_string = { \"string\", free };")
(%localdef "cxtype_t *STRING_NTAG = &cxt_string;")
(%definition "extern cxtype_t *STRING_NTAG;")
(%definition "#define isstring(o) (isnative(o, STRING_NTAG))")
(%definition "#define stringdata(o) ((int*)getnative(o, STRING_NTAG))")
(%definition "#define sdatachars(d) ((char*)((d)+1))")
(%definition "#define stringlen(o) (*stringdata(o))")
(%definition "#define stringchars(o) ((char*)(stringdata(o)+1))")
(%definition "#define hpushstr(l, s) hpushptr(s, STRING_NTAG, l)")
(%localdef "char* stringref(obj o, int i) {
int *d = stringdata(o);
assert(i >= 0 && i < *d);
return ((char*)(d+1))+i;
}")
(%definition "#ifdef NDEBUG
#define stringref(o, i) (stringchars(o)+(i))
#else
extern char* stringref(obj o, int i);
#endif")
(%definition "extern int *newstring(char *s);")
(%localdef "int *newstring(char *s) {
int l, *d; assert(s); l = (int)strlen(s);
d = cxm_cknull(malloc(sizeof(int)+l+1), \"malloc(string)\");
*d = l; strcpy((char*)(d+1), s); return d;
}")
(%definition "extern int *allocstring(int n, int c);")
(%localdef "int *allocstring(int n, int c) {
int *d; char *s; assert(n+1 > 0);
d = cxm_cknull(malloc(sizeof(int)+n+1), \"malloc(string)\");
*d = n; s = (char*)(d+1); memset(s, c, n); s[n] = 0;
return d;
}")
(%definition "extern int *substring(int *d, int from, int to);")
(%localdef "int *substring(int *d0, int from, int to) {
int n = to-from, *d1; char *s0, *s1; assert(d0);
assert(0 <= from && from <= to && to <= *d0);
d1 = cxm_cknull(malloc(sizeof(int)+n+1), \"malloc(string)\");
*d1 = n; s0 = (char*)(d0+1); s1 = (char*)(d1+1);
memcpy(s1, s0+from, n); s1[n] = 0;
return d1;
}")
(%definition "extern int *stringcat(int *d0, int *d1);")
(%localdef "int *stringcat(int *d0, int *d1) {
int l0 = *d0, l1 = *d1, n = l0+l1; char *s0, *s1, *s;
int *d = cxm_cknull(malloc(sizeof(int)+n+1), \"malloc(string)\");
*d = n; s = (char*)(d+1); s0 = (char*)(d0+1); s1 = (char*)(d1+1);
memcpy(s, s0, l0); memcpy(s+l0, s1, l1); s[n] = 0;
return d;
}")
(%definition "extern int *dupstring(int *d);")
(%localdef "int *dupstring(int *d0) {
int n = *d0, *d1 = cxm_cknull(malloc(sizeof(int)+n+1), \"malloc(string)\");
memcpy(d1, d0, sizeof(int)+n+1);
return d1;
}")
(%definition "extern void stringfill(int *d, int c);")
(%localdef "void stringfill(int *d, int c) {
int l = *d, i; char *s = (char*)(d+1);
for (i = 0; i < l; ++i) s[i] = c;
}")
(%definition "extern int strcmp_ci(char *s1, char*s2);")
(%localdef "int strcmp_ci(char *s1, char *s2) {
int c1, c2, d;
do { c1 = *s1++; c2 = *s2++; d = (unsigned)tolower(c1) - (unsigned)tolower(c2); }
while (!d && c1 && c2);
return d;
}")
(define-syntax %const
(let-syntax ([old-%const %const])
(syntax-rules (string)
[(_ string s)
(%prim* ("obj(hpushstr($live, newstring(\"" s "\")))"))]
[(_ string 8 c ...)
(%prim* ("{ static char s[] = { " (c ", ") ... "0 };\n"
" $return obj(hpushstr($live, newstring(s))); }"))]
[(_ arg ...) (old-%const arg ...)])))
(define-inline (string? x)
(%prim "bool(isstring(obj_from_$arg))" x))
(define-syntax make-string
(syntax-rules ()
[(_ k) (%prim* "obj(hpushstr($live, allocstring(fixnum_from_$arg, '?')))" k)]
[(_ k c) (%prim* "obj(hpushstr($live, allocstring(fixnum_from_$arg, char_from_$arg)))" k c)]
[_ %residual-make-string]))
(define-syntax string
(syntax-rules ()
[(_ c ...)
(%prim* "{ /* string */
obj o = hpushstr($live, allocstring($argc, ' '));
unsigned char *s = (unsigned char *)stringchars(o);
${*s++ = (unsigned char)char_from_$arg;
$}$return obj(o); }" c ...)]
[_ %residual-string]))
(define-inline (string-length s)
(%prim "fixnum(stringlen(obj_from_$arg))" s))
(define-inline (string-ref s k)
(%prim? "char(*(unsigned char*)stringref(obj_from_$arg, fixnum_from_$arg))" s k))
(define-inline (string-set! s k c)
(%prim! "void(*stringref(obj_from_$arg, fixnum_from_$arg) = char_from_$arg)" s k c))
(define-inline (string=? x y)
(%prim? "bool(strcmp(stringchars(obj_from_$arg), stringchars(obj_from_$arg)) == 0)" x y))
(define-inline (string<? x y)
(%prim? "bool(strcmp(stringchars(obj_from_$arg), stringchars(obj_from_$arg)) < 0)" x y))
(define-inline (string>? x y)
(%prim? "bool(strcmp(stringchars(obj_from_$arg), stringchars(obj_from_$arg)) > 0)" x y))
(define-inline (string<=? x y)
(%prim? "bool(strcmp(stringchars(obj_from_$arg), stringchars(obj_from_$arg)) <= 0)" x y))
(define-inline (string>=? x y)
(%prim? "bool(strcmp(stringchars(obj_from_$arg), stringchars(obj_from_$arg)) >= 0)" x y))
(define-inline (string-ci=? x y)
(%prim? "bool(strcmp_ci(stringchars(obj_from_$arg), stringchars(obj_from_$arg)) == 0)" x y))
(define-inline (string-ci<? x y)
(%prim? "bool(strcmp_ci(stringchars(obj_from_$arg), stringchars(obj_from_$arg)) < 0)" x y))
(define-inline (string-ci>? x y)
(%prim? "bool(strcmp_ci(stringchars(obj_from_$arg), stringchars(obj_from_$arg)) > 0)" x y))
(define-inline (string-ci<=? x y)
(%prim? "bool(strcmp_ci(stringchars(obj_from_$arg), stringchars(obj_from_$arg)) <= 0)" x y))
(define-inline (string-ci>=? x y)
(%prim? "bool(strcmp_ci(stringchars(obj_from_$arg), stringchars(obj_from_$arg)) >= 0)" x y))
(define-inline (substring s start end)
(%prim*? "{ /* substring */
int *d = substring(stringdata(obj_from_$arg), fixnum_from_$arg, fixnum_from_$arg);
$return obj(hpushstr($live, d)); }" s start end))
(define-inline (string-append/2 s1 s2)
(%prim*? "{ /* string-append */
int *d = stringcat(stringdata(obj_from_$arg), stringdata(obj_from_$arg));
$return obj(hpushstr($live, d)); }" s1 s2))
(define-syntax string-append
(syntax-rules ()
[(_) ""] [(_ x) x]
[(_ x y) (string-append/2 x y)]
[(_ x y z ...) (string-append/2 x (string-append y z ...))]
[_ %residual-string-append]))
(define-inline (string-copy s)
(%prim*? "{ /* string-copy */
int *d = dupstring(stringdata(obj_from_$arg));
$return obj(hpushstr($live, d)); }" s))
(define-inline (string-fill! s c)
(%prim! "void(stringfill(stringdata(obj_from_$arg), char_from_$arg))" s c))
(define-inline (string-position c s)
(%prim? "{ /* string-position */
char *s = stringchars(obj_from_$arg), *p = strchr(s, char_from_$arg);
if (p) $return fixnum(p-s); else $return bool(0); }" s c))
; vectors
(%definition "/* vectors */")
(%definition "#define VECTOR_BTAG 1")
(%definition "#define isvector(o) istagged(o, VECTOR_BTAG)")
(%definition "#define vectorref(v, i) *taggedref(v, VECTOR_BTAG, i)")
(%definition "#define vectorlen(v) taggedlen(v, VECTOR_BTAG)")
(define-inline (vector? o)
(%prim "bool(isvector(obj_from_$arg))" o))
(define-inline (make-vector n i)
(%prim* "{ /* make-vector */
obj o; int i = 0, c = fixnum_from_$arg;
hreserve(hbsz(c+1), $live); /* $live live regs */
o = obj_from_$arg; /* gc-safe */
while (i++ < c) *--hp = o;
*--hp = obj_from_size(VECTOR_BTAG);
$return obj(hendblk(c+1)); }" n i))
(define-syntax make-vector
(let-syntax ([old-make-vector make-vector])
(syntax-rules ()
[(_ n) (old-make-vector n (void))]
[(_ n i) (old-make-vector n i)]
[_ %residual-make-vector])))
(define-syntax vector
(syntax-rules ()
[(_ i ...)
(%prim*/rev "{ /* vector */
hreserve(hbsz($argc+1), $live); /* $live live regs */
${*--hp = obj_from_$arg;
$}*--hp = obj_from_size(VECTOR_BTAG);
$return obj(hendblk($argc+1)); }" i ...)]
[_ %residual-vector]))
(define-syntax %const
(let-syntax ([old-%const %const])
(syntax-rules (vector)
[(_ vector x ...) (vector x ...)]
[(_ arg ...) (old-%const arg ...)])))
(define-inline (vector-length v)
(%prim "fixnum(vectorlen(obj_from_$arg))" v))
(define-inline (vector-ref v i)
(%prim? "obj(vectorref(obj_from_$arg, fixnum_from_$arg))" v i))
(define-inline (vector-set! v i x)
(%prim! "void(vectorref(obj_from_$arg, fixnum_from_$arg) = obj_from_$arg)" v i x))
(define (vector-fill! v x)
(let ([n (vector-length v)])
(do ([i 0 (fx+ i 1)])
[(fx=? i n)]
(vector-set! v i x))))
; boxes
(%definition "/* boxes */")
(%definition "#define BOX_BTAG 2")
(%definition "#define isbox(o) istagged(o, BOX_BTAG)")
(%definition "#define boxref(o) *taggedref(o, BOX_BTAG, 0)")
(define-inline (box? o)
(%prim "bool(isbox(obj_from_$arg))" o))
(define-inline (box o)
(%prim* "{ /* box */
hreserve(hbsz(2), $live); /* $live live regs */
*--hp = obj_from_$arg;
*--hp = obj_from_size(BOX_BTAG);
$return obj(hendblk(2)); }" o))
(define-syntax %const
(let-syntax ([old-%const %const])
(syntax-rules (box)
[(_ box x) (box x)]
[(_ arg ...) (old-%const arg ...)])))
(define-inline (unbox b)
(%prim? "obj(boxref(obj_from_$arg))" b))
(define-inline (set-box! b o)
(%prim! "void(boxref(obj_from_$arg) = obj_from_$arg)" b o))
; null
; () is immediate 0 with immediate tag 3 (singular null object)
(%definition "/* null */")
(%definition "#define NULL_ITAG 3")
(%definition "#define mknull() mkimm(0, NULL_ITAG)")
(%definition "#define isnull(o) ((o) == mkimm(0, NULL_ITAG))")
(define-syntax %const
(let-syntax ([old-%const %const])
(syntax-rules (null)
[(_ null) (%prim "obj(mknull())")]
[(_ arg ...) (old-%const arg ...)])))
(define-inline (null? x)
(%prim "bool(isnull(obj_from_$arg))" x))
; pairs and lists
(%definition "/* pairs and lists */")
(%definition "#define PAIR_BTAG 3")
(%definition "#define ispair(o) istagged(o, PAIR_BTAG)")
(%definition "#define car(o) *taggedref(o, PAIR_BTAG, 0)")
(%definition "#define cdr(o) *taggedref(o, PAIR_BTAG, 1)")
(define-inline (pair? o)
(%prim "bool(ispair(obj_from_$arg))" o))
(define-inline (atom? o)
(%prim "bool(!ispair(obj_from_$arg))" o))
(%definition "extern int islist(obj l);")
(%localdef "int islist(obj l) {
obj s = l;
for (;;) {
if (isnull(l)) return 1;
else if (!ispair(l)) return 0;
else if ((l = cdr(l)) == s) return 0;
else if (isnull(l)) return 1;
else if (!ispair(l)) return 0;
else if ((l = cdr(l)) == s) return 0;
else s = cdr(s);
}
}")
(define-inline (list? o)
(%prim? "bool(islist(obj_from_$arg))" o))
(define-inline (cons a d)
(%prim* "{ /* cons */
hreserve(hbsz(3), $live); /* $live live regs */
*--hp = obj_from_$arg;
*--hp = obj_from_$arg;
*--hp = obj_from_size(PAIR_BTAG);
$return obj(hendblk(3)); }" d a))
(define-syntax %const
(let-syntax ([old-%const %const])
(syntax-rules (pair list)
[(_ pair x y) (cons x y)]
[(_ list x ...) (list x ...)]
[(_ arg ...) (old-%const arg ...)])))
(define-inline (car p)
(%prim? "obj(car(obj_from_$arg))" p))
(define-inline (set-car! p a)
(%prim! "void(car(obj_from_$arg) = obj_from_$arg)" p a))
(define-inline (cdr p)
(%prim? "obj(cdr(obj_from_$arg))" p))
(define-inline (set-cdr! p d)
(%prim! "void(cdr(obj_from_$arg) = obj_from_$arg)" p d))
(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) (c?r a a x))
(define-inline (cadr x) (c?r a d x))
(define-inline (cdar x) (c?r d a x))
(define-inline (cddr x) (c?r d d x))
(define-inline (caaar x) (c?r a a a x))
(define-inline (caadr x) (c?r a a d x))
(define-inline (cadar x) (c?r a d a x))
(define-inline (caddr x) (c?r a d d x))
(define-inline (cdaar x) (c?r d a a x))
(define-inline (cdadr x) (c?r d a d x))
(define-inline (cddar x) (c?r d d a x))
(define-inline (cdddr x) (c?r d d d x))
(define-inline (caaaar x) (c?r a a a a x))
(define-inline (caaadr x) (c?r a a a d x))
(define-inline (caadar x) (c?r a a d a x))
(define-inline (caaddr x) (c?r a a d d x))
(define-inline (cadaar x) (c?r a d a a x))
(define-inline (cadadr x) (c?r a d a d x))
(define-inline (caddar x) (c?r a d d a x))
(define-inline (cadddr x) (c?r a d d d x))
(define-inline (cdaaar x) (c?r d a a a x))
(define-inline (cdaadr x) (c?r d a a d x))
(define-inline (cdadar x) (c?r d a d a x))
(define-inline (cdaddr x) (c?r d a d d x))
(define-inline (cddaar x) (c?r d d a a x))
(define-inline (cddadr x) (c?r d d a d x))
(define-inline (cdddar x) (c?r d d d a x))
(define-inline (cddddr x) (c?r d d d d x))
(define-syntax list
(syntax-rules ()
[(_) '()]
[(_ x . more) (cons x (list . more))]
[_ %residual-list]))
(define-syntax cons*
(syntax-rules ()
[(_ i ... j)
(%prim*/rev "{ /* cons* */
obj p;
hreserve(hbsz(3)*$argc, $live); /* $live live regs */
p = obj_from_$arg; /* gc-safe */
${*--hp = p; *--hp = obj_from_$arg;
*--hp = obj_from_size(PAIR_BTAG); p = hendblk(3);
$}$return obj(p); }" i ... j)]
[_ %residual-cons*]))
(define-syntax list* cons*)
(define-inline (length l)
(%prim? "{ /* length */
int n; obj l = obj_from_$arg;
for (n = 0; l != mknull(); ++n, l = cdr(l)) ;
$return fixnum(n); }" l))
(define-inline (reverse l)
(%prim*? "{ /* reverse */
obj l, o = mknull(); int c = fixnum_from_$arg;
hreserve(hbsz(3)*c, $live); /* $live live regs */
l = obj_from_$arg; /* gc-safe */
for (; l != mknull(); l = cdr(l)) { *--hp = o; *--hp = car(l);
*--hp = obj_from_size(PAIR_BTAG); o = hendblk(3); }
$return obj(o); }" (length l) l))
(define-inline (reverse! l)
(%prim?! "{ /* reverse! */
obj t, v = mknull(), l = obj_from_$arg;
while (l != mknull()) t = cdr(l), cdr(l) = v, v = l, l = t;
$return obj(v); }" l))
(define-inline (append/2 l o)
(%prim*? "{ /* append */
obj t, l, o, *p, *d; int c = fixnum_from_$arg;
hreserve(hbsz(3)*c, $live); /* $live live regs */
l = obj_from_$arg; t = obj_from_$arg; /* gc-safe */
o = t; p = &o;
for (; l != mknull(); l = cdr(l)) {
*--hp = t; d = hp; *--hp = car(l);
*--hp = obj_from_size(PAIR_BTAG);
*p = hendblk(3); p = d; }
$return obj(o); }" (length l) l o))
(define-syntax append
(syntax-rules ()
[(_) '()] [(_ x) x]
[(_ x y) (append/2 x y)]
[(_ x y z ...) (append/2 x (append y z ...))]
[_ %residual-append]))
(define-inline (list-copy l)
(append/2 l '()))
(define-inline (list-ref l n)
(%prim? "{ /* list-ref */
obj l = obj_from_$arg; int c = fixnum_from_$arg;
while (c-- > 0) l = cdr(l);
$return obj(car(l)); }" l n))
(define-inline (list-tail l n)
(%prim? "{ /* list-tail */
obj l = obj_from_$arg; int c = fixnum_from_$arg;
while (c-- > 0) l = cdr(l);
$return obj(l); }" l n))
(define-inline (last-pair l)
(%prim? "{ /* last-pair */
obj l = obj_from_$arg, p;
for (p = cdr(l); ispair(p); p = cdr(p)) l = p;
$return obj(l); }" l))
(define-syntax map
(syntax-rules ()
[(_ fun lst)
(let ([f fun])
(let loop ([l lst])
(if (null? l) '() (cons (f (car l)) (loop (cdr l))))))]
[(_ fun lst . l*) (%residual-map fun lst . l*)]
[_ %residual-map]))
(define-syntax for-each
(syntax-rules ()
[(_ fun lst)
(let ([f fun])
(let loop ([l lst])
(if (null? l) (void) (begin (f (car l)) (loop (cdr l))))))]
[(_ fun lst . l*) (%residual-for-each fun lst . l*)]
[_ %residual-for-each]))
; symbols
; symbols are immediate with immediate tag 4
(%definition "/* symbols */")
(%definition "#define SYMBOL_ITAG 4")
(%definition "#define issymbol(o) (isimm(o, SYMBOL_ITAG))")
(%definition "#define mksymbol(i) mkimm(i, SYMBOL_ITAG)")
(%definition "#define getsymbol(o) getimmu(o, SYMBOL_ITAG)")
(%localdef "static struct { char **a; char ***v; size_t sz; size_t u; size_t maxu; } symt;")
(%localdef "static unsigned long hashs(char *s) {
unsigned long i = 0, l = (unsigned long)strlen(s), h = l;
while (i < l) h = (h << 4) ^ (h >> 28) ^ s[i++];
return h ^ (h >> 10) ^ (h >> 20);
}")
(%definition "extern char *symbolname(int sym);")
(%localdef "char *symbolname(int sym) {
assert(sym >= 0); assert(sym < (int)symt.u);
return symt.a[sym];
}")
(%definition "extern int internsym(char *name);")
(%localdef "int internsym(char *name) {
size_t i, j; /* based on a code (C) 1998, 1999 by James Clark. */
if (symt.sz == 0) { /* init */
symt.a = cxm_cknull(calloc(64, sizeof(char*)), \"symtab[0]\");
symt.v = cxm_cknull(calloc(64, sizeof(char**)), \"symtab[1]\");
symt.sz = 64, symt.maxu = 64 / 2;
i = hashs(name) & (symt.sz-1);
} else {
unsigned long h = hashs(name);
for (i = h & (symt.sz-1); symt.v[i]; i = (i-1) & (symt.sz-1))
if (strcmp(name, *symt.v[i]) == 0) return (int)(symt.v[i] - symt.a);
if (symt.u == symt.maxu) { /* rehash */
size_t nsz = symt.sz * 2;
char **na = cxm_cknull(calloc(nsz, sizeof(char*)), \"symtab[2]\");
char ***nv = cxm_cknull(calloc(nsz, sizeof(char**)), \"symtab[3]\");
for (i = 0; i < symt.sz; i++)
if (symt.v[i]) {
for (j = hashs(*symt.v[i]) & (nsz-1); nv[j]; j = (j-1) & (nsz-1)) ;
nv[j] = symt.v[i] - symt.a + na;
}
free(symt.v); symt.v = nv; symt.sz = nsz; symt.maxu = nsz / 2;
memcpy(na, symt.a, symt.u * sizeof(char*)); free(symt.a); symt.a = na;
for (i = h & (symt.sz-1); symt.v[i]; i = (i-1) & (symt.sz-1)) ;
}
}
*(symt.v[i] = symt.a + symt.u) =
strcpy(cxm_cknull(malloc(strlen(name)+1), \"symtab[4]\"), name);
return (int)((symt.u)++);
}")
(define-syntax %const
(let-syntax ([old-%const %const])
(syntax-rules (symbol)
; wrap code in #() to force constant lifting
[(_ symbol s)
(%prim #("obj(mksymbol(internsym(\"" s "\")))"))]
[(_ symbol 8 c ...)
(%prim #("{ static obj o = 0; static char s[] = { " (c ", ") ... "0 };\n"
" $return obj(o ? o : (o = mksymbol(internsym(s)))); }"))]
[(_ arg ...) (old-%const arg ...)])))
(define-inline (symbol? x)
(%prim "bool(issymbol(obj_from_$arg))" x))
(define-inline (symbol=? x y)
(%prim "bool(getsymbol(obj_from_$arg) == getsymbol(obj_from_$arg))" x y))
; conversions
(define-inline (symbol->string s)
(%prim* "obj(hpushstr($live, newstring(symbolname(getsymbol(obj_from_$arg)))))" s))
(define-inline (string->symbol s)
(%prim? "obj(mksymbol(internsym(stringchars(obj_from_$arg))))" s))
(define (fixnum->string n r)
(%prim* "{ /* fixnum->string */
char buf[35], *s = buf + sizeof(buf) - 1;
int neg = 0;
long num = fixnum_from_$arg;
long radix = fixnum_from_$arg;
if (num < 0) { neg = 1; num = -num; }
*s = 0;
do { int d = num % radix; *--s = d < 10 ? d + '0' : d - 10 + 'a'; }
while (num /= radix);
if (neg) *--s = '-';
$return obj(hpushstr($live, newstring(s))); }" n r))
(define (flonum->string x)
(%prim* "{ /* flonum->string */
char buf[30], *s; sprintf(buf, \"%.15g\", flonum_from_$arg);
for (s = buf; *s != 0; s++) if (strchr(\".eEaAfF\", *s)) break;
if (*s == 'a' || *s == 'A') strcpy(buf, \"+nan.0\");
else if (*s == 'f' || *s == 'F') strcpy(buf, buf[0] == '-' ? \"-inf.0\" : \"+inf.0\");
else if (*s == 'E') *s = 'e'; /* otherwise add .0 */
else if (*s == 0) { *s++ = '.'; *s++ = '0'; *s = 0; }
$return obj(hpushstr($live, newstring(buf))); }" x))
(define-syntax number->string
(syntax-rules ()
[(_ n r) (fixnum->string n r)]
[(_ n) (if (fixnum? n) (fixnum->string n 10) (flonum->string n))]
[_ %residual-number->string]))
(define (string->fixnum s r)
(%prim? "{ /* string->fixnum */
char *e, *s = stringchars(obj_from_$arg);
int radix = fixnum_from_$arg; long l;
if (s[0] == '#' && (s[1] == 'b' || s[1] == 'B')) s += 2, radix = 2;
else if (s[0] == '#' && (s[1] == 'o' || s[1] == 'O')) s += 2, radix = 8;
else if (s[0] == '#' && (s[1] == 'd' || s[1] == 'D')) s += 2, radix = 10;
else if (s[0] == '#' && (s[1] == 'x' || s[1] == 'X')) s += 2, radix = 16;
l = (errno = 0, strtol(s, &e, radix));
if (errno || l < FIXNUM_MIN || l > FIXNUM_MAX || e == s || *e) $return bool(0);
else $return fixnum(l); }" s r))
(define (string->flonum s)
(%prim*? "{ /* string->flonum */
char *e = \"\", *s = stringchars(obj_from_$arg); double d; errno = 0;
if (*s != '+' && *s != '-') d = strtod(s, &e);
else if (strcmp(s+1, \"inf.0\") == 0) d = (*s == '-' ? -HUGE_VAL : HUGE_VAL);
else if (strcmp(s+1, \"nan.0\") == 0) d = strtod(\"NAN\", &e); /* since C99 */
else d = strtod(s, &e);
if (errno || e == s || *e) $return bool(0);
else $return flonum($live, d); }" s))
(define-inline (string->fixnum-or-flonum s r)
(%prim*? "{ /* string->fixnum-or-flonum */
char *s = stringchars(obj_from_$arg);
int radix = fixnum_from_$arg; long l; double d;
if (0) $return obj(0); /* to fool sfc unboxer */
switch (strtofxfl(s, radix, &l, &d)) {
case 'e': $return fixnum(l); break;
case 'i': $return flonum($live, d); break;
default : $return bool(0); break;
} }" s r))
(define-syntax string->number
(syntax-rules ()
[(_ s r) (string->fixnum-or-flonum s r)]
[(_ s) (string->fixnum-or-flonum s 10)]
[_ %residual-string->number]))
(define-inline (vector->list v)
(%prim*? "{ /* vector->list */
obj v, l = mknull(); int c = fixnum_from_$arg;
hreserve(hbsz(3)*c, $live); /* $live live regs */
v = obj_from_$arg; /* gc-safe */
while (c-- > 0) { *--hp = l; *--hp = hblkref(v, 1+c);
*--hp = obj_from_size(PAIR_BTAG); l = hendblk(3); }
$return obj(l); }" (vector-length v) v))
(define-inline (list->vector l)
(%prim*? "{ /* list->vector */
obj l; int i, c = fixnum_from_$arg;
hreserve(hbsz(c+1), $live); /* $live live regs */
l = obj_from_$arg; /* gc-safe */
for (i = 0; i < c; ++i, l = cdr(l)) hp[i-c] = car(l);
hp -= c; *--hp = obj_from_size(VECTOR_BTAG);
$return obj(hendblk(c+1)); }" (length l) l))
(define-inline (list->string l)
(%prim*? "{ /* list->string */
int i, c = fixnum_from_$arg;
obj o = hpushstr($live, allocstring(c, ' ')); /* $live live regs */
obj l = obj_from_$arg; /* gc-safe */
unsigned char *s = (unsigned char *)stringchars(o);
for (i = 0; i < c; ++i, l = cdr(l)) s[i] = (unsigned char)char_from_obj(car(l));
$return obj(o); }" (length l) l))
(define-inline (string->list s)
(%prim*? "{ /* string->list */
int c = fixnum_from_$arg;
unsigned char *s; obj l = mknull();
hreserve(hbsz(3)*c, $live); /* $live live regs */
s = (unsigned char *)stringchars(obj_from_$arg); /* gc-safe */
while (c-- > 0) { *--hp = l; *--hp = obj_from_char(s[c]);
*--hp = obj_from_size(PAIR_BTAG); l = hendblk(3); }
$return obj(l); }" (string-length s) s))
; control
; closure procedures are heap blocks of length >= 1 which
; have a pointer to the static code entry as 0th element;
; sfc allocates env-less global procedures in static memory,
; so procedure? answers #t to any nonzero out-of-heap pointer
(%localdef "int isprocedure(obj o) {
if (!o) return 0;
else if (isaptr(o) && !isobjptr(o)) return 1;
else if (!isobjptr(o)) return 0;
else { obj h = objptr_from_obj(o)[-1];
return notaptr(h) && size_from_obj(h) >= 1
&& isaptr(hblkref(o, 0)); }
}")
(%localdef "int procedurelen(obj o) {
assert(isprocedure(o));
return isobjptr(o) ? hblklen(o) : 1;
}")
(%localdef "obj* procedureref(obj o, int i) {
int len; assert(isprocedure(o));
len = isobjptr(o) ? hblklen(o) : 1;
assert(i >= 0 && i < len);
return &hblkref(o, i);
}")
(%definition "/* procedures */")
(%definition "extern int isprocedure(obj o);")
(%definition "extern int procedurelen(obj o);")
(%definition "extern obj* procedureref(obj o, int i);")
(define-inline (procedure? o)
(%prim "bool(isprocedure(obj_from_$arg))" o))
; apply, dotted lambda list, argc dispatch, case-lambda
(%definition "/* apply and dotted lambda list */")
(%definition "extern obj appcases[];")
(%localdef "/* apply/dotted lambda adapter entry points */")
(%localdef "static obj apphost(obj);")
(%localdef "obj appcases[5] = { (obj)apphost, (obj)apphost, (obj)apphost, (obj)apphost , (obj)apphost };")
(%localdef "/* apphost procedure */
#define APPLY_MAX_REGS 1024 /* limit on rc for apply & friends */
static obj apphost(obj pc)
{
register obj *r = cxg_regs;
register obj *hp = cxg_hp;
register int rc = cxg_rc;
jump:
switch (objptr_from_obj(pc)-appcases) {
case 0: /* apply */
/* clo k f arg... arglist */
assert(rc >= 4);
{ int i; obj l;
rreserve(APPLY_MAX_REGS);
l = r[--rc];
r[0] = r[2];
/* k in r[1] */
for (i = 3; i < rc; ++i) r[i-1] = r[i];
for (--rc; l != mknull(); l = cdr(l)) r[rc++] = car(l);
/* f k arg... arg... */
assert(rc <= APPLY_MAX_REGS);
pc = objptr_from_obj(r[0])[0];
goto jump; }
case 1: /* dotted lambda adapter */
/* clo k arg... */
{ obj* p = objptr_from_obj(r[0]);
int n = fixnum_from_obj(p[1]) + 2;
r[0] = p[2]; /* f */
/* k in r[1] */
assert(rc >= n);
rreserve(n+1);
if (rc == n) r[rc++] = mknull();
else { /* collect rest list */
obj l = mknull();
hreserve(hbsz(3)*(rc-n), rc);
while (rc > n) { *--hp = l; *--hp = r[--rc];
*--hp = obj_from_size(PAIR_BTAG); l = hendblk(3); }
r[rc++] = l; }
/* f k arg... arglist */
pc = objptr_from_obj(r[0])[0];
goto jump; }
case 2: /* void continuation adapter */
/* cclo ek arg ... */
assert(rc >= 2);
{ obj* p = objptr_from_obj(r[0]);
r[0] = p[1]; /* cont */
pc = objptr_from_obj(r[0])[0];
/* ek in r[1] */
rreserve(3);
r[2] = obj_from_void(0);
rc = 3;
goto jump; }
case 3: /* argc dispatcher */
/* clo k arg... */
{ obj* p = objptr_from_obj(r[0]);
obj pv = p[1]; int vl = vectorlen(pv); assert(vl > 0);
if (rc-2 < vl-1) r[0] = vectorref(pv, rc-2); /* matching slot */
else r[0] = vectorref(pv, vl-1); /* catch-all slot */
pc = objptr_from_obj(r[0])[0];
goto jump; }
case 4: /* case lambda dispatcher */
/* clo k arg... */
{ obj* p = objptr_from_obj(r[0]); int bl = hblklen(p), i;
for (i = 1; i < bl; i += 3) {
int min = fixnum_from_obj(hblkref(p, i)), max = fixnum_from_obj(hblkref(p, i+1));
if (min <= rc-2 && rc-2 <= max) { r[0] = hblkref(p, i+2); break; }
} assert(i < bl); /* at least one of the cases should match! */
pc = objptr_from_obj(r[0])[0];
goto jump; }
default: /* inter-host call */
cxg_hp = hp;
cxm_rgc(r, 1);
cxg_rc = rc;
return pc;
}
}")
(define apply
(%prim "{ /* define apply */
static obj c[] = { obj_from_objptr(appcases+0) };
$return objptr(c); }"))
(define-inline (make-improper-lambda n lam)
(%prim* "{ /* make-improper-lambda */
hreserve(hbsz(3), $live); /* $live live regs */
*--hp = obj_from_$arg;
*--hp = obj_from_$arg;
*--hp = obj_from_objptr(appcases+1);
$return obj(hendblk(3)); }" lam n))
(define-inline (make-void-continuation k)
(%prim* "{ /* make-void-continuation */
hreserve(hbsz(2), $live); /* $live live regs */
*--hp = obj_from_$arg;
*--hp = obj_from_objptr(appcases+2);
$return obj(hendblk(2)); }" k))
(define-inline (make-argc-dispatch-lambda pv)
(%prim* "{ /* make-argc-dispatch-lambda */
hreserve(hbsz(2), $live); /* $live live regs */
*--hp = obj_from_$arg;
*--hp = obj_from_objptr(appcases+3);
$return obj(hendblk(2)); }" pv))
(define-syntax argc-dispatch-lambda
(syntax-rules ()
[(_ x ...) (make-argc-dispatch-lambda (vector x ...))]))
(define-inline (argc-dispatch-lambda? x)
(%prim "{ /* argc-dispatch-lambda? */
obj x = obj_from_$arg;
$return bool(isprocedure(x) && *procedureref(x, 0) == obj_from_objptr(appcases+3)); }" x))
(define-syntax make-case-lambda
(syntax-rules ()
[(_ x ...) ; order is: min1 max1 lambda1 min2 max2 lambda2 ...
(%prim*/rev "{ /* make-case-lambda */
hreserve(hbsz($argc+1), $live); /* $live live regs */
${*--hp = obj_from_$arg;
$}*--hp = obj_from_objptr(appcases+4);
$return obj(hendblk($argc+1)); }" x ...)]
[_ %residual-make-case-lambda]))
(define-syntax case-lambda
(letrec-syntax
([min-accepted
(syntax-rules ()
[(_ () N) N] [(_ (a . d) N) (min-accepted d #&(+ 1 N))] [(_ ra N) N])]
[max-accepted
(syntax-rules ()
[(_ () N) N] [(_ (a . d) N) (max-accepted d #&(+ 1 N))] [(_ ra N) (%prim "fixnum(FIXNUM_MAX)")])]
[unroll-cases
(syntax-rules ()
[(_ () c ...)
(make-case-lambda c ... 0 (%prim "fixnum(FIXNUM_MAX)") %fail-lambda)]
[(_ ([formals . body] . more) c ...)
(unroll-cases more c ...
(min-accepted formals 0) (max-accepted formals 0) (lambda formals . body))])])
(syntax-rules ()
[(_ [formals . body] ...)
(unroll-cases ([formals . body] ...))])))
; delay & force
(define make-promise
(lambda (proc)
((lambda (result-ready? result)
(lambda ()
(if result-ready?
result
((lambda (x)
(if result-ready?
result
(begin
(set! result-ready? #t)
(set! result x)
result)))
(proc)))))
#f
#f)))
(define-inline force
(lambda (promise)
(promise)))
(define-syntax delay
(syntax-rules ()
[(delay exp)
(make-promise (lambda () exp))]))
; eof
; eof is immediate -1 with immediate tag 127 (compatible with C EOF)
(%definition "/* eof */")
(%definition "#define EOF_ITAG 127")
(%definition "#define mkeof() mkimm(-1, EOF_ITAG)")
(%definition "#define iseof(o) ((o) == mkimm(-1, EOF_ITAG))")
(define-syntax %const
(let-syntax ([old-%const %const])
(syntax-rules (eof)
[(_ eof) (%prim "obj(mkeof())")]
[(_ arg ...) (old-%const arg ...)])))
(define-inline (eof-object)
(%prim "obj(mkeof())"))
(define-inline (eof-object? x)
(%prim "bool(iseof(obj_from_$arg))" x))
; i/o ports
(define-inline (open-file* fn mode) ;=> #f (i.e. NULL) or foreign ptr
(%prim*?! "obj((obj)fopen(stringchars(obj_from_$arg), stringchars(obj_from_$arg)))" fn mode))
; generic input ports
(%definition "/* input ports */")
(%definition "typedef struct { /* extends cxtype_t */
const char *tname;
void (*free)(void*);
int (*close)(void*);
int (*getch)(void*);
int (*ungetch)(int, void*);
} cxtype_iport_t;")
(%definition "extern cxtype_t *IPORT_FILE_NTAG;")
(%definition "extern cxtype_t *IPORT_STRING_NTAG;")
(%definition "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_FILE_NTAG || pt == IPORT_STRING_NTAG) return (cxtype_iport_t*)pt;
else return NULL; }")
(%definition "#define isiport(o) (iportvt(o) != NULL)")
(%definition "#define iportdata(o) ((void*)(*objptr_from_obj(o)))")
(define-inline (close-input-port p)
(%prim?! "{ /* close-input-port */
obj o = obj_from_$arg; cxtype_iport_t *vt = iportvt(o); assert(vt);
$return void(vt->close(iportdata(o))); }" p))
; file input ports
(%localdef "static void ffree(void *vp) {
/* FILE *fp = vp; assert(fp); cannot fclose(fp) here because of FILE reuse! */ }")
(%localdef "static cxtype_iport_t cxt_iport_file = {
\"file-input-port\", ffree, (int (*)(void*))fclose,
(int (*)(void*))(fgetc), (int (*)(int, void*))(ungetc) };")
(%localdef "cxtype_t *IPORT_FILE_NTAG = (cxtype_t *)&cxt_iport_file;")
(%definition "#define mkiport_file(l, fp) hpushptr(fp, IPORT_FILE_NTAG, l)")
(define-inline (input-port? x)
(%prim "bool(isiport(obj_from_$arg))" x))
(define *current-input-port* (%prim* "obj(mkiport_file($live, stdin))"))
(define-inline (current-input-port) *current-input-port*)
(define-inline (open-input-file fn)
(let ([file* (open-file* fn "r")])
(if file* (%prim*?! "obj(mkiport_file($live, (void*)(obj_from_$arg)))" file*)
(error 'open-input-file "cannot open file" fn))))
(define-inline (call-with-input-file fn proc) ; proc must return 1 value!
(let* ([p (open-input-file fn)] [v (proc p)])
(close-input-port p)
v))
(define (with-input-from-file fn thunk)
(let ([p0 *current-input-port*] [p1 (open-input-file fn)])
(set! *current-input-port* p1)
(let ([v (thunk)]) ; thunk must return 1 value!
(close-input-port p1)
(set! *current-input-port* p0)
v)))
; string input ports
(%definition "/* string input ports */")
(%definition "typedef struct { char *p; void *base; } sifile_t;")
(%localdef "sifile_t *sialloc(char *p, void *base) {
sifile_t *fp = cxm_cknull(malloc(sizeof(sifile_t)), \"malloc(sifile)\");
fp->p = p; fp->base = base; return fp; }")
(%definition "extern sifile_t *sialloc(char *p, void *base);")
(%localdef "static void sifree(sifile_t *fp) {
assert(fp); if (fp->base) free(fp->base); free(fp); }")
(%localdef "static int siclose(sifile_t *fp) {
assert(fp); if (fp->base) free(fp->base); fp->base = NULL; fp->p = \"\"; return 0; }")
(%localdef "static int sigetch(sifile_t *fp) {
int c; assert(fp && fp->p); if (!(c = *(fp->p))) return EOF; ++(fp->p); return c; }")
(%localdef "static int siungetch(int c, sifile_t *fp) {
assert(fp && fp->p); --(fp->p); assert(c == *(fp->p)); return c; }")
(%localdef "static cxtype_iport_t cxt_iport_string = {
\"string-input-port\", (void (*)(void*))sifree, (int (*)(void*))siclose,
(int (*)(void*))sigetch, (int (*)(int, void*))siungetch };")
(%localdef "cxtype_t *IPORT_STRING_NTAG = (cxtype_t *)&cxt_iport_string;")
(%definition "#define mkiport_string(l, fp) hpushptr(fp, IPORT_STRING_NTAG, l)")
(define-inline (open-input-string s)
(%prim*? "{ /* open-input-string */
int *d = dupstring(stringdata(obj_from_$arg));
$return obj(mkiport_string($live, sialloc(sdatachars(d), d))); }" s))
; file output ports
(%definition "/* output ports */")
(%localdef "static void opclose(void *vp) {
/* FILE *fp = vp; assert(fp);
* cannot fclose(fp) here because of FILE reuse! */
}")
(%localdef "static cxtype_t cxt_oport = { \"oport\", opclose };")
(%localdef "cxtype_t *OPORT_NTAG = &cxt_oport;")
(%definition "extern cxtype_t *OPORT_NTAG;")
(%definition "#define isoport(o) (isnative(o, OPORT_NTAG))")
(%definition "#define oportdata(o) ((FILE*)getnative(o, OPORT_NTAG))")
(%definition "#define mkoport(l, fp) hpushptr(fp, OPORT_NTAG, l)")
(define-inline (output-port? x)
(%prim "bool(isoport(obj_from_$arg))" x))
(define *current-output-port* (%prim* "obj(mkoport($live, stdout))"))
(define-inline (current-output-port) *current-output-port*)
(define *current-error-port* (%prim* "obj(mkoport($live, stderr))"))
(define-inline (current-error-port) *current-error-port*)
(define-inline (open-output-file fn)
(let ([file* (open-file* fn "w")])
(if file* (%prim*?! "obj(mkoport($live, (void*)(obj_from_$arg)))" file*)
(error 'open-output-file "cannot open file" fn))))
(define-inline (flush-output-port p)
(%prim?! "void(fflush(oportdata(obj_from_$arg)))" p))
(define-inline (close-output-port p)
(%prim?! "void(fclose(oportdata(obj_from_$arg)))" p))
(define-inline (call-with-output-file fn proc) ; proc must return 1 value!
(let* ([p (open-output-file fn)] [v (proc p)])
(close-output-port p)
v))
(define (with-output-to-file fn thunk)
(let ([p0 *current-output-port*] [p1 (open-output-file fn)])
(set! *current-output-port* p1)
(let ([v (thunk)]) ; thunk must return 1 value!
(close-output-port p1)
(set! *current-output-port* p0)
v)))
; simple i/o
(define-syntax read-char
(syntax-rules ()
[(_) (read-char (current-input-port))]
[(_ p) (%prim?! ("{ obj o = obj_from_$arg; cxtype_iport_t *vt = iportvt(o);\n"
" int c; assert(vt); c = vt->getch(iportdata(o));\n"
" $return obj(c == EOF ? mkeof() : obj_from_char(c)); }") p)]
[_ %residual-read-char]))
(define-syntax peek-char
(syntax-rules ()
[(_) (peek-char (current-input-port))]
[(_ p) (%prim? ("{ obj o = obj_from_$arg; cxtype_iport_t *vt = iportvt(o);\n"
" int c; void *p; assert(vt); p = iportdata(o); c = vt->getch(p); if (c != EOF) vt->ungetch(c, p);\n"
" $return obj(c == EOF ? mkeof() : obj_from_char(c)); }") p)]
[_ %residual-peek-char]))
(define-syntax char-ready?
(syntax-rules ()
[(_) (char-ready? (current-input-port))]
[(_ p) #t] ; no better solution for FILE/STRING ports
[_ %residual-char-ready?]))
(define-syntax write-char
(syntax-rules ()
[(_ c) (write-char c (current-output-port))]
[(_ c p) (%prim! "void(fputc(char_from_$arg, oportdata(obj_from_$arg)))" c p)]
[_ %residual-write-char]))
(define-syntax write-string
(syntax-rules ()
[(_ s) (write-string s (current-output-port))]
[(_ s p) (%prim?! "void(fputs(stringchars(obj_from_$arg), oportdata(obj_from_$arg)))" s p)]
[_ %residual-write-string]))
(define-syntax newline
(syntax-rules ()
[(_) (newline (current-output-port))]
[(_ p) (%prim! "void(fputc('\\n', oportdata(obj_from_$arg)))" p)]
[_ %residual-newline]))
(define-syntax display-fixnum
(syntax-rules ()
[(_ n) (display-fixnum n (current-output-port))]
[(_ n p) (%prim! "void(fprintf(oportdata(obj_from_$arg), \"%ld\", fixnum_from_$arg))" p n)]
[_ %residual-display-fixnum]))
(define-syntax display-flonum
(syntax-rules ()
[(_ x) (display-flonum x (current-output-port))]
[(_ x p) (%prim?! "{ /* display-flonum */
char buf[30], *s; sprintf(buf, \"%.15g\", flonum_from_$arg);
for (s = buf; *s != 0; s++) if (strchr(\".eEaAfF\", *s)) break;
if (*s == 'a' || *s == 'A') strcpy(buf, \"+nan.0\");
else if (*s == 'f' || *s == 'F') strcpy(buf, buf[0] == '-' ? \"-inf.0\" : \"+inf.0\");
else if (*s == 'E') *s = 'e'; /* otherwise add .0 */
else if (*s == 0) { *s++ = '.'; *s++ = '0'; *s = 0; }
$return void(fputs(buf, oportdata(obj_from_$arg))); }" x p)]
[_ %residual-display-flonum]))
(define-syntax display-procedure
(syntax-rules ()
[(_ n) (display-procedure n (current-output-port))]
[(_ n p) (%prim! "void(fprintf(oportdata(obj_from_$arg), \"#<procedure @%p>\", objptr_from_obj(obj_from_$arg)))" p n)]
[_ %residual-display-procedure]))
(define-syntax display-input-port
(syntax-rules ()
[(_ n) (display-input-port n (current-output-port))]
[(_ n p) (%prim! "void(fprintf(oportdata(obj_from_$arg), \"#<%s>\", ((cxtype_iport_t*)cxm_cknull(iportvt(obj_from_$arg), \"iportvt\"))->tname))" p n)]
[_ %residual-display-input-port]))
(define-syntax display-output-port
(syntax-rules ()
[(_ n) (display-input-port n (current-output-port))]
[(_ n p) (write-string "#<oport>" p)]
[_ %residual-display-output-port]))
; equivalence and case
(%definition "extern int iseqv(obj x, obj y);")
(%localdef "int iseqv(obj x, obj y) {
obj h; if (x == y) return 1;
if (!x || !y || notaptr(x) || notaptr(y) || notobjptr(x) || notobjptr(y)) return 0;
if ((h = objptr_from_obj(x)[-1]) != objptr_from_obj(y)[-1]) return 0;
if (h == (obj)FLONUM_NTAG) return *(flonum_t*)objptr_from_obj(x)[0] == *(flonum_t*)objptr_from_obj(y)[0];
return 0;
}")
(%definition "extern obj ismemv(obj x, obj l);")
(%localdef "obj ismemv(obj x, obj l) {
if (!x || notaptr(x) || notobjptr(x)) {
for (; l != mknull(); l = cdr(l))
{ if (car(l) == x) return l; }
} else if (is_flonum_obj(x)) {
flonum_t fx = flonum_from_obj(x);
for (; l != mknull(); l = cdr(l))
{ obj y = car(l); if (is_flonum_obj(y) && fx == flonum_from_obj(y)) return l; }
} else { /* for others, memv == memq */
for (; l != mknull(); l = cdr(l))
{ if (car(l) == x) return l; }
} return 0;
}")
(%definition "extern obj isassv(obj x, obj l);")
(%localdef "obj isassv(obj x, obj l) {
if (!x || notaptr(x) || notobjptr(x)) {
for (; l != mknull(); l = cdr(l))
{ obj p = car(l); if (car(p) == x) return p; }
} else if (is_flonum_obj(x)) {
flonum_t fx = flonum_from_obj(x);
for (; l != mknull(); l = cdr(l))
{ obj p = car(l), y = car(p); if (is_flonum_obj(y) && fx == flonum_from_obj(y)) return p; }
} else { /* for others, assv == assq */
for (; l != mknull(); l = cdr(l))
{ obj p = car(l); if (car(p) == x) return p; }
} return 0;
}")
(%definition "extern int isequal(obj x, obj y);")
(%localdef "int isequal(obj x, obj y) {
obj h; int i, n; loop: if (x == y) return 1;
if (!x || !y || notaptr(x) || notaptr(y) || notobjptr(x) || notobjptr(y)) return 0;
if ((h = objptr_from_obj(x)[-1]) != objptr_from_obj(y)[-1]) return 0;
if (h == (obj)FLONUM_NTAG) return flonum_from_obj(x) == flonum_from_obj(y);
if (h == (obj)STRING_NTAG) return strcmp(stringchars(x), stringchars(y)) == 0;
if (isaptr(h) || !(n = size_from_obj(h)) || hblkref(x, 0) != hblkref(y, 0)) return 0;
for (i = 1; i < n-1; ++i) if (!isequal(hblkref(x, i), hblkref(y, i))) return 0;
if (i == n-1) { x = hblkref(x, i); y = hblkref(y, i); goto loop; } else return 1;
}")
(%definition "extern obj ismember(obj x, obj l);")
(%localdef "obj ismember(obj x, obj l) {
if (!x || notaptr(x) || notobjptr(x)) {
for (; l != mknull(); l = cdr(l))
{ if (car(l) == x) return l; }
} else if (is_flonum_obj(x)) {
flonum_t fx = flonum_from_obj(x);
for (; l != mknull(); l = cdr(l))
{ obj y = car(l); if (is_flonum_obj(y) && fx == flonum_from_obj(y)) return l; }
} else if (isstring(x)) {
char *xs = stringchars(x);
for (; l != mknull(); l = cdr(l))
{ obj y = car(l); if (isstring(y) && 0 == strcmp(xs, stringchars(y))) return l; }
} else {
for (; l != mknull(); l = cdr(l))
{ if (isequal(car(l), x)) return l; }
} return 0;
}")
(%definition "extern obj isassoc(obj x, obj l);")
(%localdef "obj isassoc(obj x, obj l) {
if (!x || notaptr(x) || notobjptr(x)) {
for (; l != mknull(); l = cdr(l))
{ obj p = car(l); if (car(p) == x) return p; }
} else if (is_flonum_obj(x)) {
flonum_t fx = flonum_from_obj(x);
for (; l != mknull(); l = cdr(l))
{ obj p = car(l), y = car(p); if (is_flonum_obj(y) && fx == flonum_from_obj(y)) return p; }
} else if (isstring(x)) {
char *xs = stringchars(x);
for (; l != mknull(); l = cdr(l))
{ obj p = car(l), y = car(p); if (isstring(y) && 0 == strcmp(xs, stringchars(y))) return p; }
} else {
for (; l != mknull(); l = cdr(l))
{ obj p = car(l); if (isequal(car(p), x)) return p; }
} return 0;
}")
(define-inline (eq? x y)
(%prim "bool(obj_from_$arg == obj_from_$arg)" x y))
(define-inline (eqv? x y)
(or (eq? x y) ; covers fx=?
(and (flonum? x) (flonum? y) (fl=? x y))))
(define-inline (equal? x y)
(%prim? "bool(isequal(obj_from_$arg, obj_from_$arg))" x y))
(define-syntax case
(letrec-syntax
([compare
(syntax-rules ()
[(_ key ()) #f]
[(_ key (#&(id? datum) . data))
(if (eq? key 'datum) #t (compare key data))]
[(_ key (datum . data))
(if (eqv? key 'datum) #t (compare key data))])]
[case
(syntax-rules (else =>)
[(case key) (if #f #f)]
[(case key (else => resproc))
(resproc key)]
[(case key (else result1 . results))
(begin result1 . results)]
[(case key ((datum ...) => resproc) . clauses)
(if (compare key (datum ...))
(resproc key)
(case key . clauses))]
[(case key ((datum ...) result1 . results) . clauses)
(if (compare key (datum ...))
(begin result1 . results)
(case key . clauses))])])
(syntax-rules ()
[(_ expr clause1 clause ...)
(let ([key expr]) (case key clause1 clause ...))])))
; equivalence-based member, assoc
(define-inline (memq x l)
(%prim? "{ /* memq */
obj x = obj_from_$arg, l = obj_from_$arg;
for (; l != mknull(); l = cdr(l)) if (car(l) == x) break;
$return obj(l == mknull() ? obj_from_bool(0) : l); }" x l))
(define-inline (memv x l)
(%prim? "obj(ismemv(obj_from_$arg, obj_from_$arg))" x l))
(define-inline (member x l)
(%prim? "obj(ismember(obj_from_$arg, obj_from_$arg))" x l))
(define-inline (assq x l)
(%prim? "{ /* assq */
obj x = obj_from_$arg, l = obj_from_$arg, p = mknull();
for (; l != mknull(); l = cdr(l)) { p = car(l); if (car(p) == x) break; }
$return obj(l == mknull() ? obj_from_bool(0) : p); }" x l))
(define-inline (assv x l)
(%prim? "obj(isassv(obj_from_$arg, obj_from_$arg))" x l))
(define-inline (assoc x l)
(%prim? "obj(isassoc(obj_from_$arg, obj_from_$arg))" x l))
; quasiquote
#read `<datum> as (quasiquote <datum>)
#read ,<datum> as (unquote <datum>)
#read ,@<datum> as (unquote-splicing <datum>)
(define-syntax quasiquote ; from eiod
(syntax-rules (unquote unquote-splicing quasiquote)
[(_ (unquote x)) x]
[(_ ((unquote-splicing x))) x] ;esl: allow `(,@improper-list)
[(_ ((unquote-splicing x) . y)) (append x (quasiquote y))]
[(_ (quasiquote x) . d) (cons 'quasiquote (quasiquote (x) d))]
[(_ (unquote x) d) (cons 'unquote (quasiquote (x) . d))]
[(_ (unquote-splicing x) d) (cons 'unquote-splicing (quasiquote (x) . d))]
[(_ (x . y) . d) (cons (quasiquote x . d) (quasiquote y . d))]
[(_ #(x ...) . d) (list->vector (quasiquote (x ...) . d))]
[(_ x . d) 'x]))
; S-expression writer
(define write-datum
(let ()
(define (sub-write-pair x d? p)
(write-char #\( p)
(let loop ([x x])
(sub-write (car x) d? p)
(cond
[(pair? (cdr x)) (write-char #\space p) (loop (cdr x))]
[(null? (cdr x))]
[else (write-string " . " p) (sub-write (cdr x) d? p)]))
(write-char #\) p))
(define (sub-write-char x p)
(cond
[(char=? x #\alarm) (write-string "#\\alarm" p)]
[(char=? x #\backspace) (write-string "#\\backspace" p)]
[(char=? x #\tab) (write-string "#\\tab" p)]
[(char=? x #\newline) (write-string "#\\newline" p)]
[(char=? x #\vtab) (write-string "#\\vtab" p)]
[(char=? x #\page) (write-string "#\\page" p)]
[(char=? x #\page) (write-string "#\\page" p)]
[(char=? x #\return) (write-string "#\\return" p)]
[(char=? x #\space) (write-string "#\\space" p)]
[else (write-string "#\\" p) (write-char x p)]))
(define (sub-write-string x p)
(write-char #\" p)
(let ([n (string-length x)])
(do ([i 0 (+ i 1)]) [(= i n)]
(let ([c (string-ref x i)])
(if (or (char=? c #\") (char=? c #\\))
(write-char #\\ p))
(write-char c p))))
(write-char #\" p))
(define (sub-write-vector x d? p)
(write-string "#(" p)
(let ([size (vector-length x)])
(if (not (= size 0))
(let ([last (- size 1)])
(let loop ([i 0])
(sub-write (vector-ref x i) d? p)
(if (not (= i last))
(begin (write-char #\space p) (loop (+ i 1))))))))
(write-char #\) p))
(define (sub-write-box x d? p)
(write-string "#&" p)
(sub-write (unbox x) d? p))
(define (sub-write x d? p)
(cond
[(eof-object? x) (write-string "#<eof>" p)]
[(input-port? x) (display-input-port x p)]
[(output-port? x) (display-output-port x p)]
[(symbol? x) (write-string (symbol->string x) p)]
[(pair? x) (sub-write-pair x d? p)]
[(fixnum? x) (display-fixnum x p)]
[(flonum? x) (display-flonum x p)]
[(null? x) (write-string "()" p)]
[(boolean? x) (write-string (if x "#t" "#f") p)]
[(char? x) (if d? (write-char x p) (sub-write-char x p))]
[(string? x) (if d? (write-string x p) (sub-write-string x p))]
[(vector? x) (sub-write-vector x d? p)]
[(box? x) (sub-write-box x d? p)]
[(procedure? x) (display-procedure x p)]
[else (write-string "#<unknown>" p)]))
(lambda (x d? p) ; body of write-datum
(sub-write x d? p))))
(define-inline (put-datum p d)
(write-datum d #f p))
(define-syntax write
(syntax-rules ()
[(_ d) (write-datum d #f (current-output-port))]
[(_ d p) (write-datum d #f p)]
[_ %residual-write]))
(define-syntax display
(syntax-rules ()
[(_ d) (write-datum d #t (current-output-port))]
[(_ d p) (write-datum d #t p)]
[_ %residual-display]))
; simple errors
(define (print-error-message prefix args ep)
(define (pr-where args ep)
(when (pair? args)
(cond [(not (car args))
(write-string ": " ep)
(pr-msg (cdr args) ep)]
[(symbol? (car args))
(write-string " in " ep) (write (car args) ep) (write-string ": " ep)
(pr-msg (cdr args) ep)]
[else
(write-string ": " ep)
(pr-msg args ep)])))
(define (pr-msg args ep)
(when (pair? args)
(cond [(string? (car args))
(display (car args) ep)
(pr-rest (cdr args) ep)]
[else (pr-rest args ep)])))
(define (pr-rest args ep)
(when (pair? args)
(write-char #\space ep) (write (car args) ep)
(pr-rest (cdr args) ep)))
(cond [(or (string? prefix) (symbol? prefix))
(write-string prefix ep)]
[else (write-string "Error" ep)])
(pr-where args ep)
(newline ep))
(define (error . args)
(let ([ep (current-error-port)])
(newline ep)
(print-error-message "Error" args ep)
(reset)))
(define (assertion-violation . args)
(let ([ep (current-error-port)])
(newline ep)
(print-error-message "Assertion violation" args ep)
(%prim! "{ assert(0); exit(1); $return void(0); }")))
; S-expression reader
(define read-datum
(let* ([reader-token-marker (list 'reader-token)]
[close-paren (cons reader-token-marker "right parenthesis")]
[close-bracket (cons reader-token-marker "right bracket")]
[dot (cons reader-token-marker "\" . \"")])
(define-syntax r-error
(syntax-rules () [(_ p r a ...) (error 'read r a ...)]))
(define (reader-token? form)
(and (pair? form) (eq? (car form) reader-token-marker)))
(define (char-symbolic? c)
(string-position c
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!$%&*/:<=>?^_~0123456789+-.@"))
(define (char-hex-digit? c)
(let ([scalar-value (char->integer c)])
(or (and (>= scalar-value 48) (<= scalar-value 57))
(and (>= scalar-value 65) (<= scalar-value 70))
(and (>= scalar-value 97) (<= scalar-value 102)))))
(define (char-delimiter? c)
(or (char-whitespace? c)
(char=? c #\)) (char=? c #\()
(char=? c #\]) (char=? c #\[)
(char=? c #\") (char=? c #\;)))
(define (sub-read-carefully p)
(let ([form (sub-read p)])
(cond [(eof-object? form)
(r-error p "unexpected end of file")]
[(reader-token? form)
(r-error p "unexpected token:" (cdr form))]
[else form])))
(define (sub-read p)
(let ([c (read-char p)])
(cond [(eof-object? c) c]
[(char-whitespace? c) (sub-read p)]
[(char=? c #\() (sub-read-list c p close-paren #t)]
[(char=? c #\)) close-paren]
[(char=? c #\[) (sub-read-list c p close-bracket #t)]
[(char=? c #\]) close-bracket]
[(char=? c #\') (list 'quote (sub-read-carefully p))]
[(char=? c #\`) (list 'quasiquote (sub-read-carefully p))]
[(char-symbolic? c) (sub-read-number-or-symbol c p)]
[(char=? c #\;)
(let loop ([c (read-char p)])
(or (eof-object? c) (char=? c #\newline)
(loop (read-char p))))
(sub-read p)]
[(char=? c #\,)
(let ([next (peek-char p)])
(cond [(eof-object? next)
(r-error p "end of file after ,")]
[(char=? next #\@)
(read-char p)
(list 'unquote-splicing (sub-read-carefully p))]
[else (list 'unquote (sub-read-carefully p))]))]
[(char=? c #\")
(let loop ([l '()])
(let ([c (read-char p)])
(cond [(eof-object? c)
(r-error p "end of file within a string")]
[(char=? c #\\)
(loop (cons (sub-read-string-char-escape p) l))]
[(char=? c #\") (list->string (reverse! l))]
[else (loop (cons c l))])))]
[(char=? c #\#)
(let ([c (peek-char p)])
(cond [(eof-object? c) (r-error p "end of file after #")]
[(char-ci=? c #\t) (read-char p) #t]
[(char-ci=? c #\f) (read-char p) #f]
[(or (char-ci=? c #\b) (char-ci=? c #\o)
(char-ci=? c #\d) (char-ci=? c #\x)
(char-ci=? c #\i) (char-ci=? c #\e))
(sub-read-number-or-symbol #\# p)]
[(char=? c #\&)
(read-char p)
(box (sub-read-carefully p))]
[(char=? c #\;)
(read-char p)
(sub-read-carefully p)
(sub-read p)]
[(char=? c #\|)
(read-char p)
(let recur () ;starts right after opening #|
(let ([next (read-char p)])
(cond
[(eof-object? next)
(r-error p "end of file in #| comment")]
[(char=? next #\|)
(let ([next (peek-char p)])
(cond
[(eof-object? next)
(r-error p "end of file in #| comment")]
[(char=? next #\#) (read-char p)]
[else (recur)]))]
[(char=? next #\#)
(let ([next (peek-char p)])
(cond
[(eof-object? next)
(r-error p "end of file in #| comment")]
[(char=? next #\|) (read-char p) (recur) (recur)]
[else (recur)]))]
[else (recur)])))
(sub-read p)]
[(char=? c #\() ;)
(read-char p)
(list->vector (sub-read-list c p close-paren #f))]
[(char=? c #\\)
(read-char p)
(let ([c (peek-char p)])
(cond
[(eof-object? c)
(r-error p "end of file after #\\")]
[(char=? #\x c)
(read-char p)
(if (char-delimiter? (peek-char p))
c
(sub-read-x-char-escape p #f))]
[(char-alphabetic? c)
(let ([name (sub-read-carefully p)])
(if (= (string-length (symbol->string name)) 1)
c
(case name
[(space) #\space]
[(alarm) #\alarm]
[(backspace) #\backspace]
[(tab) #\tab]
[(newline linefeed) #\newline]
[(vtab) #\vtab]
[(page) #\page]
[(return) #\return]
[else (r-error p "unknown #\\ name" name)])))]
[else (read-char p) c]))]
[else (r-error p "unknown # syntax" c)]))]
[else (r-error p "illegal character read" c)])))
(define (sub-read-list c p close-token dot?)
(let ([form (sub-read p)])
(if (eq? form dot)
(r-error p "missing car -- ( immediately followed by .") ;)
(let recur ([form form])
(cond [(eof-object? form)
(r-error p "eof inside list -- unbalanced parentheses")]
[(eq? form close-token) '()]
[(eq? form dot)
(if dot?
(let* ([last-form (sub-read-carefully p)]
[another-form (sub-read p)])
(if (eq? another-form close-token)
last-form
(r-error p "randomness after form after dot" another-form)))
(r-error p "dot in #(...)"))]
[(reader-token? form)
(r-error p "error inside list --" (cdr form))]
[else (cons form (recur (sub-read p)))])))))
(define (sub-read-string-char-escape p)
(let ([c (read-char p)])
(if (eof-object? c)
(r-error p "end of file within a string"))
(cond [(or (char=? c #\\) (char=? c #\")) c]
[(char=? c #\a) #\alarm]
[(char=? c #\b) #\backspace]
[(char=? c #\t) #\tab]
[(char=? c #\n) #\newline]
[(char=? c #\v) #\vtab]
[(char=? c #\f) #\page]
[(char=? c #\r) #\return]
[(char=? c #\x) (sub-read-x-char-escape p #t)]
[else (r-error p "invalid char escape in string" c)])))
(define (sub-read-x-char-escape p in-string?)
(define (rev-digits->char l)
(if (null? l)
(r-error p "\\x escape sequence is too short")
(integer->char (string->fixnum (list->string (reverse! l)) 16))))
(let loop ([c (peek-char p)] [l '()] [cc 0])
(cond [(eof-object? c)
(if in-string?
(r-error p "end of file within a string")
(rev-digits->char l))]
[(and in-string? (char=? c #\;))
(read-char p)
(rev-digits->char l)]
[(and (not in-string?) (char-delimiter? c))
(rev-digits->char l)]
[(not (char-hex-digit? c))
(r-error p "unexpected char in \\x escape sequence" c)]
[(> cc 2)
(r-error p "\\x escape sequence is too long")]
[else
(read-char p)
(loop (peek-char p) (cons c l) (+ cc 1))])))
(define (sub-read-number-or-symbol c p)
(let loop ([c (peek-char p)] [l (list c)] [hash? (char=? c #\#)])
(cond [(or (eof-object? c) (char-delimiter? c))
(let* ([l (reverse! l)] [c (car l)] [s (list->string l)])
(if (or hash? (char-numeric? c)
(char=? c #\+) (char=? c #\-) (char=? c #\.))
(cond [(string=? s ".") dot]
[(or (string=? s "+") (string=? s "-") (string=? s "..."))
(string->symbol s)]
[(and (not hash?)
(>= (string-length s) 2)
(char=? (string-ref s 0) #\-)
(char=? (string-ref s 1) #\>))
(string->symbol s)]
[(string->number s)]
[else (r-error p "unsupported number syntax (implementation restriction)" s)])
(string->symbol s)))]
[(char=? c #\#)
(read-char p)
(loop (peek-char p) (cons c l) #t)]
[(char-symbolic? c)
(read-char p)
(loop (peek-char p) (cons c l) hash?)]
[else (r-error p "unexpected number/symbol char" c)])))
(lambda (p) ; body of read-datum
(let ([form (sub-read p)])
(if (not (reader-token? form))
form
(r-error p "unexpected token:" (cdr form)))))))
(define-inline (get-datum p)
(read-datum p))
(define-syntax read
(syntax-rules ()
[(_) (read-datum (current-input-port))]
[(_ p) (read-datum p)]
[_ %residual-read]))
; file system
(define-inline (file-exists? fn) ; fixme?
(%prim?! "{ /* file-exists? */
FILE *f = fopen(stringchars(obj_from_$arg), \"r\");
if (f != NULL) fclose(f);
$return bool(f != NULL); }" fn))
(define-inline (delete-file fn)
(%prim?! "{ /* delete-file */
int res = remove(stringchars(obj_from_$arg));
$return bool(res == 0); }" fn))
(define-inline (rename-file fnold fnnew)
(%prim?! "{ /* rename-file */
int res = rename(stringchars(obj_from_$arg), stringchars(obj_from_$arg));
$return bool(res == 0); }" fnold fnnew))
; multiple values & continuations
(define-inline (call-with-values producer consumer)
(letcc k
(withcc
(lambda results
(withcc k (apply consumer results)))
(producer))))
(define *current-dynamic-state* (list #f))
(define (call-with-current-continuation proc)
(let ([here *current-dynamic-state*])
(letcc cont
(proc
(lambda results
(dynamic-state-reroot! here)
(apply cont results))))))
(define-syntax call/cc call-with-current-continuation)
(define-syntax throw
(syntax-rules ()
[(_ k expr ...)
(withcc (%prim "ktrap()") (k expr ...))]))
(define-syntax values
(syntax-rules ()
[(_ expr ...)
(call/cc (lambda (k) (throw k expr ...)))]
[_ %residual-values]))
(define (dynamic-wind before during after)
(let ([here *current-dynamic-state*])
(dynamic-state-reroot! (cons (cons before after) here))
(call-with-values during
(lambda results
(dynamic-state-reroot! here)
(apply values results)))))
(define (dynamic-state-reroot! there)
(if (not (eq? *current-dynamic-state* there))
(begin (dynamic-state-reroot! (cdr there))
(let ([before (caar there)] [after (cdar there)])
(set-car! *current-dynamic-state* (cons after before))
(set-cdr! *current-dynamic-state* there)
(set-car! there #f)
(set-cdr! there '())
(set! *current-dynamic-state* there)
(before)))))
; time
(%include <time.h>)
(define-inline (current-jiffy)
(%prim*! "flonum($live, clock())"))
(define-inline (jiffies-per-second)
(%prim* "flonum($live, CLOCKS_PER_SEC)"))
; miscellaneous / system
(define-syntax exit
(syntax-rules ()
[(_) (exit 0)]
[(_ n) (%prim! "void(exit(fixnum_from_$arg))" n)]
[_ %residual-exit]))
(define-inline (abort) (%prim! "void(exit(1))"))
(define (reset) (%prim! "void(exit(1))"))
(define (set-reset-handler! fn) (set! reset fn))
(define-inline (argv-ref argv i)
(%prim* "{ /* argv-ref */
int i = fixnum_from_$arg;
char *s = ((char **)(obj_from_$arg))[i];
if (s) $return obj(hpushstr($live, newstring(s)));
else $return bool(0); }" i argv))
(define (command-line)
(let loop ([r '()] [i (%prim "fixnum(0)")])
(let ([arg (argv-ref (%prim "obj(cxg_argv)") i)])
(if arg
(loop (cons arg r) (fx+ i (%prim "fixnum(1)")))
(reverse! r)))))
(define-inline (get-environment-variable s)
(%prim*? "{ /* get-environment-variable */
char *v = getenv(stringchars(obj_from_$arg));
if (v) $return obj(hpushstr($live, newstring(v)));
else $return bool(0); }" s))
(define-inline (system cmd)
(%prim?! "{ /* system */
int res = system(stringchars(obj_from_$arg));
$return fixnum(res); }" cmd))
;------------------------------------------------------------------------------
; stubs
(define-inline (make-rectangular r i)
(if (= i 0) r (error 'make-rectangular "nonzero imag part not supported" i)))
(define-inline (make-polar m a)
(cond [(= a 0) m]
[(= a 3.141592653589793238462643) (- m)]
[else (error 'make-polar "angle not supported" a)]))
(define-inline (real-part x) x)
(define-inline (imag-part x) 0)
(define-inline (magnitude x) (abs x))
(define-inline (angle x) (if (negative? x) 3.141592653589793238462643 0))
; residual versions of inline procedures
(define (%residual-values . l)
(call/cc (lambda (k) (throw apply k l))))
(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-fx=? (cmp-reducer fx=?))
(define %residual-fx<? (cmp-reducer fx<?))
(define %residual-fx>? (cmp-reducer fx>?))
(define %residual-fx<=? (cmp-reducer fx<=?))
(define %residual-fx>=? (cmp-reducer fx>=?))
(define %residual-fl=? (cmp-reducer fl=?))
(define %residual-fl<? (cmp-reducer fl<?))
(define %residual-fl>? (cmp-reducer fl>?))
(define %residual-fl<=? (cmp-reducer fl<=?))
(define %residual-fl>=? (cmp-reducer fl>=?))
(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-fxmax (minmax-reducer fxmax))
(define %residual-fxmin (minmax-reducer fxmin))
(define %residual-flmax (minmax-reducer flmax))
(define %residual-flmin (minmax-reducer flmin))
(define (%residual-max/2 a b)
(if (fixnum? a)
(if (fixnum? b)
(if (fx>? a b) a b)
(let ([a (fixnum->flonum a)]) (if (fl>? a b) a b)))
(if (fixnum? b)
(let ([b (fixnum->flonum b)]) (if (fl>? a b) a b))
(if (fl>? a b) a b))))
(define %residual-max (minmax-reducer %residual-max/2))
(define (%residual-min/2 a b)
(if (fixnum? a)
(if (fixnum? b)
(if (fx<? a b) a b)
(let ([a (fixnum->flonum a)]) (if (fl<? a b) a b)))
(if (fixnum? b)
(let ([b (fixnum->flonum b)]) (if (fl<? a b) a b))
(if (fl<? a b) a b))))
(define %residual-min (minmax-reducer %residual-min/2))
(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-fx+ (addmul-reducer fx+ 0))
(define %residual-fx* (addmul-reducer fx* 1))
(define %residual-fl+ (addmul-reducer fl+ 0.0))
(define %residual-fl* (addmul-reducer fl* 1.0))
(define %residual+ (addmul-reducer + 0))
(define %residual* (addmul-reducer * 1))
(define %residual-gcd (addmul-reducer gcd 0))
(define %residual-lcm (addmul-reducer lcm 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-fx- (subdiv-reducer fx-))
(define %residual-fx/ (subdiv-reducer fx/))
(define %residual-fl- (subdiv-reducer fl-))
(define %residual-fl/ (subdiv-reducer fl/))
(define %residual- (subdiv-reducer -))
(define %residual/ (subdiv-reducer /))
(define-syntax nullary-unary-adaptor
(syntax-rules ()
[(_ f)
(lambda args
(if (null? args) (f) (f (car args))))]))
(define-syntax unary-binary-adaptor
(syntax-rules ()
[(_ f)
(lambda (x . args)
(if (null? args) (f x) (f x (car args))))]))
(define %residual-flatan (unary-binary-adaptor flatan))
(define %residual-atan (unary-binary-adaptor atan))
(define (%residual-map f l . l*)
(if (null? l*)
(map f l)
(let loop ([l* (cons l l*)] [r '()])
(if (null? (car l*))
(reverse! r)
(loop (map cdr l*) (cons (apply f (map car l*)) r))))))
(define (%residual-for-each p l . l*)
(if (null? l*)
(for-each p l)
(let loop ([l* (cons l l*)])
(if (pair? (car l*))
(begin (apply p (map car l*)) (loop (map cdr l*)))))))
(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-make-string (unary-binary-adaptor make-string))
(define (%residual-string . l)
(list->string l))
(define %residual-string-append (append-reducer string-append ""))
(define %residual-make-vector (unary-binary-adaptor make-vector))
(define (%residual-vector . l)
(list->vector l))
(define (%residual-list . l) l)
(define (%residual-cons* x . l)
(let loop ([x x] [l l])
(if (null? l) x (cons x (loop (car l) (cdr l))))))
(define %residual-append (append-reducer append '()))
(define %residual-number->string (unary-binary-adaptor number->string))
(define %residual-string->number (unary-binary-adaptor string->number))
(define (%fail-lambda . args)
(error 'case-lambda "unexpected number of arguments" args))
(define (%residual-make-case-lambda . l)
(%prim* "{ /* %residual-make-case-lambda */
obj l; int i, c = fixnum_from_$arg;
hreserve(hbsz(c+1), $live); /* $live live regs */
l = obj_from_$arg; /* gc-safe */
for (i = 0; i < c; ++i, l = cdr(l)) hp[i-c] = car(l);
hp -= c; *--hp = obj_from_objptr(appcases+4);
$return obj(hendblk(c+1)); }" (length l) l))
(define %residual-read-char (nullary-unary-adaptor read-char))
(define %residual-peek-char (nullary-unary-adaptor peek-char))
(define %residual-char-ready? (nullary-unary-adaptor char-ready?))
(define %residual-display-fixnum (unary-binary-adaptor display-fixnum))
(define %residual-display-flonum (unary-binary-adaptor display-flonum))
(define %residual-display-procedure (unary-binary-adaptor display-procedure))
(define %residual-display-input-port (unary-binary-adaptor display-input-port))
(define %residual-display-output-port (unary-binary-adaptor display-output-port))
(define %residual-write-char (unary-binary-adaptor write-char))
(define %residual-write-string (unary-binary-adaptor write-string))
(define %residual-newline (nullary-unary-adaptor newline))
(define %residual-write (unary-binary-adaptor write))
(define %residual-display (unary-binary-adaptor display))
(define %residual-read (nullary-unary-adaptor read))
(define %residual-exit (nullary-unary-adaptor exit))