; SIOF Scheme Interpreter 1.0.2 -- esl
; parts of the code are derived from the following sources:
; 1) SCHEME -- A Scheme interpreter written by Marc Feeley.
; 2) alexpander.scm v1.65 2007/11/05 02:50:34 (see license below)
; Copyright 2002-2004,2006,2007 Al Petrofsky <alexpander@petrofsky.org>
;
; Redistribution and use in source and binary forms, with or without
; modification, are permitted provided that the following conditions
; are met:
;
; Redistributions of source code must retain the above copyright
; notice, this list of conditions and the following disclaimer.
;
; Redistributions in binary form must reproduce the above copyright
; notice, this list of conditions and the following disclaimer in
; the documentation and/or other materials provided with the
; distribution.
;
; Neither the name of the author nor the names of its contributors
; may be used to endorse or promote products derived from this
; software without specific prior written permission.
;
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
; HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
; BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS
; OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
; AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY
; WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
; POSSIBILITY OF SUCH DAMAGE.
; #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))]))
(define-syntax let*-values
(syntax-rules ()
[(_ () . body) (let () . body)]
[(_ ([(a) x] . b*) . body) (let ([a x]) (let*-values b* . body))]
[(_ ([aa x] . b*) . body) (call-with-values (lambda () x) (lambda aa (let*-values b* . body)))]))
(define-syntax let-values
(letrec-syntax
([loop
(syntax-rules ()
[(_ (new-b ...) new-aa x map-b* () () . body)
(let*-values (new-b ... [new-aa x]) (let map-b* . body))]
[(_ (new-b ...) new-aa old-x map-b* () ([aa x] . b*) . body)
(loop (new-b ... [new-aa old-x]) () x map-b* aa b* . body)]
[(_ new-b* (new-a ...) x (map-b ...) (a . aa) b* . body)
(loop new-b* (new-a ... tmp-a) x (map-b ... [a tmp-a]) aa b* . body)]
[(_ new-b* (new-a ...) x (map-b ...) a b* . body)
(loop new-b* (new-a ... . tmp-a) x (map-b ... [a tmp-a]) () b* . body)])])
(syntax-rules ()
[(_ () . body) (let () . body)]
[(_ ([aa x] . b*) . body)
(loop () () x () aa b* . body)])))
#;(define-syntax set!-values
(letrec-syntax
([loop
(syntax-rules ()
[(_ new-aa ([a tmp-a] ...) () x)
(call-with-values (lambda () x) (lambda new-aa (set! a tmp-a) ...))]
[(_ (new-a ...) (map-a ...) (a . aa) x)
(loop (new-a ... tmp-a) (map-a ... [a tmp-a]) aa x)]
[(_ (new-a ...) (map-a ...) a x)
(loop (new-a ... . tmp-a) (map-a ... [a tmp-a]) () x)])])
(syntax-rules ()
[(_ () x) (define x)]
[(_ aa x) (loop () () aa x)])))
(define-syntax define-values
(letrec-syntax
([loop
(syntax-rules ()
[(_ new-aa ([a tmp-a] ...) () x)
(begin
(define a (void)) ...
(define (call-with-values (lambda () x) (lambda new-aa (set! a tmp-a) ...))))]
[(_ (new-a ...) (map-a ...) (a . aa) x)
(loop (new-a ... tmp-a) (map-a ... [a tmp-a]) aa x)]
[(_ (new-a ...) (map-a ...) a x)
(loop (new-a ... . tmp-a) (map-a ... [a tmp-a]) () x)])])
(syntax-rules ()
[(_ () x) (define x)]
[(_ aa x) (loop () () aa x)])))
; 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 */")
; there are two types of immediate objects: those with 30 bits of payload data
; and no secondary tag (lower two bits are 11), and those with 3-bit tag and 24
; bits of payload data (lower two bits are 01); in both cases lsb is 1
(%definition "#define isim0(o) (((o) & 3) == 3)")
(%definition "#define isimm(o, t) (((o) & 0xff) == (((t) << 2) | 1))")
(%definition "#ifdef NDEBUG
#define getim0s(o) (long)((((o >> 2) & 0x3fffffff) ^ 0x20000000) - 0x20000000)
#define getimmu(o, t) (long)(((o) >> 8) & 0xffffff)
#else
extern long getim0s(obj o);
extern long getimmu(obj o, int t);
#endif")
(%localdef "#ifndef NDEBUG
long getim0s(obj o) {
assert(isim0(o));
return (long)((((o >> 2) & 0x3fffffff) ^ 0x20000000) - 0x20000000);
}
long getimmu(obj o, int t) {
assert(isimm(o, t));
return (long)((o >> 8) & 0xffffff);
}
#endif")
(%definition "#define mkim0(o) (obj)((((o) & 0x3fffffff) << 2) | 3)")
(%definition "#define mkimm(o, t) (obj)((((o) & 0xffffff) << 8) | ((t) << 2) | 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 foreign pointer as 0th element
; and from typed blocks which have scheme heap pointer as 0th element)
(%definition "extern int istagged(obj o, int t);")
(%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); }
}")
(%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")
(%localdef "#ifndef NDEBUG
obj cktagged(obj o, int t) {
assert(istagged(o, t));
return o;
}
int taggedlen(obj o, int t) {
assert(istagged(o, t));
return hblklen(o) - 1;
}
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);
}
#endif")
; typed blocks have non-immediate scheme tag as 0th element
; (disjoint from closures and native/tagged blocks)
(%definition "extern int istyped(obj o);")
(%localdef "int istyped(obj o) {
if (!isobjptr(o)) return 0;
else { obj h = objptr_from_obj(o)[-1];
return notaptr(h) && size_from_obj(h) >= 1
&& isobjptr(hblkref(o, 0)); }
}")
(%definition "#ifdef NDEBUG
#define cktyped(o, t) (o)
#define typedtype(o) (&hblkref(o, 0))
#define typedlen(o) (hblklen(o)-1)
#define typedref(o, i) (&hblkref(o, (i)+1))
#else
extern obj cktyped(obj o);
extern obj* typedtype(obj o);
extern int typedlen(obj o);
extern obj* typedref(obj o, int i);
#endif")
(%localdef "#ifndef NDEBUG
obj cktyped(obj o) {
assert(istyped(o));
return o;
}
obj* typedtype(obj o) {
assert(istyped(o));
return &hblkref(o, 0);
}
int typedlen(obj o) {
assert(istyped(o));
return hblklen(o) - 1;
}
obj* typedref(obj o, int i) {
int len; assert(istyped(o));
len = hblklen(o);
assert(i >= 0 && i < len-1);
return &hblkref(o, i+1);
}
#endif")
; 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))
(define-syntax boolean=?
(syntax-rules ()
[(_ x y) (%prim "bool(bool_from_$arg == bool_from_$arg)" x y)]
[(_ x y z ...) (let ([t y]) (and (boolean=? x t) (boolean=? t z ...)))]
[_ %residual-boolean=?]))
; void
; void object redefined as immediate with payload 0 and immediate tag 1
(%definition "/* void */")
(%definition "#define VOID_ITAG 1")
(%definition "#define mkvoid() mkimm(0, VOID_ITAG)")
(%definition "#define isvoid(o) ((o) == mkimm(0, VOID_ITAG))")
(%definition "#undef obj_from_void")
(%definition "#define obj_from_void(v) ((void)(v), mkimm(0, VOID_ITAG))")
(define-inline (void) (%prim "void(0)"))
; numerical helpers
(%definition "/* numbers */")
(%definition "#define FIXNUM_BIT 30")
(%definition "#define FIXNUM_MIN -536870912")
(%definition "#define FIXNUM_MAX 536870911")
(%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 fxmqu(long x, long y) {
long q = x / y; return ((x < 0 && y > 0) || (x > 0 && y < 0)) ? q - 1 : q;
}
static long fxmlo(long x, long y) {
long r = x % y; return ((r < 0 && y > 0) || (r > 0 && y < 0)) ? r + y : r;
}
/* euclidean division */
static long 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 fxmqu(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 fxmqu(long x, long y) {
long q; assert(y); assert(x != FIXNUM_MIN || y != -1);
q = x / y;
return ((x < 0 && y > 0) || (x > 0 && y < 0)) ? q - 1 : q;
}
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 long fxsqrt(long x);")
(%localdef "long fxsqrt(long x) {
assert(x >= 0); if (x < 2) return x;
else { long s = fxsqrt(x >> 2) << 1, l = s + 1; return l*l > x ? s : l; }
}")
(%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 flmqu(double x, double y);")
(%localdef "double flmqu(double x, double y) {
assert(y != 0.0 && flisint(x) && flisint(y));
return floor(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) {
extern int strcmp_ci(char *s1, char *s2); /* defined below */
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_ci(s+1, \"inf.0\") == 0) d = (*s == '-' ? -HUGE_VAL : HUGE_VAL);
else if (strcmp_ci(s+1, \"nan.0\") == 0) d = HUGE_VAL - HUGE_VAL;
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 tag-less immediates with 30 bits of payload
(%definition "/* fixnums */")
(%definition "typedef long fixnum_t;")
(%definition "#define is_fixnum_obj(o) (isim0(o))")
(%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) (getim0s(o))")
(%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) mkim0((fixnum_t)(i))")
(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 (fxmodquo x y)
(%prim "fixnum(fxmqu(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 (fxsqrt x)
(%prim "fixnum(fxsqrt(fixnum_from_$arg))" x))
(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-inline (flnan? x)
(%prim "{ /* flnan? */
flonum_t f = flonum_from_$arg;
$return bool(f != f); }" x))
(define-inline (flinfinite? x)
(%prim "{ /* flinfinite? */
flonum_t f = flonum_from_$arg;
$return bool(f <= -HUGE_VAL || f >= HUGE_VAL); }" 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 (flmodquo x y)
(%prim* "flonum($live, flmqu(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-syntax exact-integer? fixnum?)
(define-inline rational? integer?)
(define-inline complex? real?)
(define-inline number? real?)
(define-inline exact? fixnum?)
(define-inline inexact? flonum?)
(define-inline (exact x)
(if (fixnum? x) x (flonum->fixnum x)))
(define-inline (inexact x)
(if (flonum? x) x (fixnum->flonum x)))
(define-syntax inexact->exact exact)
(define-syntax exact->inexact inexact)
(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-inline (nan? x)
(and (flonum? x) (flnan? x)))
(define-inline (infinite? x)
(and (flonum? x) (flinfinite? x)))
(define-inline (finite? x)
(or (fixnum? x) (not (flinfinite? 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-syntax truncate-quotient quotient)
(define-syntax truncate-remainder remainder)
(define-inline (modquo x y)
(real-binop x y fxmodquo flmodquo))
(define-inline (modulo x y)
(real-binop x y fxmodulo flmodulo))
(define-syntax floor-quotient modquo)
(define-syntax floor-remainder modulo)
(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-syntax log
(syntax-rules ()
[(_ x) (fllog (real->flonum x))]
[(_ x b) (if (fx=? b 10) (fllog10 (real->flonum x)) (fl/ (log x) (log b)))]
[_ %residual-log]))
(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))))
(define-inline (square x) (* x x))
; characters
(%include <ctype.h>)
; characters are 24-bit immediates 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)getimmu(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-syntax char=?
(syntax-rules ()
[(_ x y) (%prim "bool(char_from_$arg == char_from_$arg)" x y)]
[(_ x y z ...) (let ([t y]) (and (char=? x t) (char=? t z ...)))]
[_ %residual-char=?]))
(define-syntax char>?
(syntax-rules ()
[(_ x y) (%prim "bool(char_from_$arg > char_from_$arg)" x y)]
[(_ x y z ...) (let ([t y]) (and (char>? x t) (char>? t z ...)))]
[_ %residual-char>?]))
(define-syntax char<?
(syntax-rules ()
[(_ x y) (%prim "bool(char_from_$arg < char_from_$arg)" x y)]
[(_ x y z ...) (let ([t y]) (and (char<? x t) (char<? t z ...)))]
[_ %residual-char<?]))
(define-syntax char>=?
(syntax-rules ()
[(_ x y) (%prim "bool(char_from_$arg >= char_from_$arg)" x y)]
[(_ x y z ...) (let ([t y]) (and (char>=? x t) (char>=? t z ...)))]
[_ %residual-char>=?]))
(define-syntax char<=?
(syntax-rules ()
[(_ x y) (%prim "bool(char_from_$arg <= char_from_$arg)" x y)]
[(_ x y z ...) (let ([t y]) (and (char<=? x t) (char<=? t z ...)))]
[_ %residual-char<=?]))
(define-syntax char-ci=?
(syntax-rules ()
[(_ x y) (%prim "bool(tolower(char_from_$arg) == tolower(char_from_$arg))" x y)]
[(_ x y z ...) (let ([t y]) (and (char-ci=? x t) (char-ci=? t z ...)))]
[_ %residual-char-ci=?]))
(define-syntax char-ci>?
(syntax-rules ()
[(_ x y) (%prim "bool(tolower(char_from_$arg) > tolower(char_from_$arg))" x y)]
[(_ x y z ...) (let ([t y]) (and (char-ci>? x t) (char-ci>? t z ...)))]
[_ %residual-char-ci>?]))
(define-syntax char-ci<?
(syntax-rules ()
[(_ x y) (%prim "bool(tolower(char_from_$arg) < tolower(char_from_$arg))" x y)]
[(_ x y z ...) (let ([t y]) (and (char-ci<? x t) (char-ci<? t z ...)))]
[_ %residual-char-ci<?]))
(define-syntax char-ci>=?
(syntax-rules ()
[(_ x y) (%prim "bool(tolower(char_from_$arg) >= tolower(char_from_$arg))" x y)]
[(_ x y z ...) (let ([t y]) (and (char-ci>=? x t) (char-ci>=? t z ...)))]
[_ %residual-char-ci>=?]))
(define-syntax char-ci<=?
(syntax-rules ()
[(_ x y) (%prim "bool(tolower(char_from_$arg) <= tolower(char_from_$arg))" x y)]
[(_ x y z ...) (let ([t y]) (and (char-ci<=? x t) (char-ci<=? t z ...)))]
[_ %residual-char-ci<=?]))
(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))
(define-syntax char-foldcase char-downcase)
(define-inline (digit-value x)
(and (char<=? #\0 x #\9) (fx- (char->integer x) (%prim "fixnum('0')"))))
; 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 sdatachars(d)+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(sdatachars(d), s); return d;
}")
(%definition "extern int *newstringn(char *s, int n);")
(%localdef "int *newstringn(char *s, int n) {
int *d; char *ns; assert(s); assert(n >= 0);
d = cxm_cknull(malloc(sizeof(int)+n+1), \"malloc(stringn)\");
*d = n; memcpy((ns = sdatachars(d)), s, n); ns[n] = 0; 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 = sdatachars(d); 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 = sdatachars(d0); s1 = sdatachars(d1);
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 = sdatachars(d); s0 = sdatachars(d0); s1 = sdatachars(d1);
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 = sdatachars(d);
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-syntax string=?
(syntax-rules ()
[(_ x y) (%prim? "bool(strcmp(stringchars(obj_from_$arg), stringchars(obj_from_$arg)) == 0)" x y)]
[(_ x y z ...) (let ([t y]) (and (string=? x t) (string=? t z ...)))]
[_ %residual-string=?]))
(define-syntax string<?
(syntax-rules ()
[(_ x y) (%prim? "bool(strcmp(stringchars(obj_from_$arg), stringchars(obj_from_$arg)) < 0)" x y)]
[(_ x y z ...) (let ([t y]) (and (string<? x t) (string<? t z ...)))]
[_ %residual-string<?]))
(define-syntax string>?
(syntax-rules ()
[(_ x y) (%prim? "bool(strcmp(stringchars(obj_from_$arg), stringchars(obj_from_$arg)) > 0)" x y)]
[(_ x y z ...) (let ([t y]) (and (string>? x t) (string>? t z ...)))]
[_ %residual-string>?]))
(define-syntax string<=?
(syntax-rules ()
[(_ x y) (%prim? "bool(strcmp(stringchars(obj_from_$arg), stringchars(obj_from_$arg)) <= 0)" x y)]
[(_ x y z ...) (let ([t y]) (and (string<=? x t) (string<=? t z ...)))]
[_ %residual-string<=?]))
(define-syntax string>=?
(syntax-rules ()
[(_ x y) (%prim? "bool(strcmp(stringchars(obj_from_$arg), stringchars(obj_from_$arg)) >= 0)" x y)]
[(_ x y z ...) (let ([t y]) (and (string>=? x t) (string>=? t z ...)))]
[_ %residual-string>=?]))
(define-syntax string-ci=?
(syntax-rules ()
[(_ x y) (%prim? "bool(strcmp_ci(stringchars(obj_from_$arg), stringchars(obj_from_$arg)) == 0)" x y)]
[(_ x y z ...) (let ([t y]) (and (string-ci=? x t) (string-ci=? t z ...)))]
[_ %residual-string-ci=?]))
(define-syntax string-ci<?
(syntax-rules ()
[(_ x y) (%prim? "bool(strcmp_ci(stringchars(obj_from_$arg), stringchars(obj_from_$arg)) < 0)" x y)]
[(_ x y z ...) (let ([t y]) (and (string-ci<? x t) (string-ci<? t z ...)))]
[_ %residual-string-ci<?]))
(define-syntax string-ci>?
(syntax-rules ()
[(_ x y) (%prim? "bool(strcmp_ci(stringchars(obj_from_$arg), stringchars(obj_from_$arg)) > 0)" x y)]
[(_ x y z ...) (let ([t y]) (and (string-ci>? x t) (string-ci>? t z ...)))]
[_ %residual-string-ci>?]))
(define-syntax string-ci<=?
(syntax-rules ()
[(_ x y) (%prim? "bool(strcmp_ci(stringchars(obj_from_$arg), stringchars(obj_from_$arg)) <= 0)" x y)]
[(_ x y z ...) (let ([t y]) (and (string-ci<=? x t) (string-ci<=? t z ...)))]
[_ %residual-string-ci<=?]))
(define-syntax string-ci>=?
(syntax-rules ()
[(_ x y) (%prim? "bool(strcmp_ci(stringchars(obj_from_$arg), stringchars(obj_from_$arg)) >= 0)" x y)]
[(_ x y z ...) (let ([t y]) (and (string-ci>=? x t) (string-ci>=? t z ...)))]
[_ %residual-string-ci>=?]))
(define-inline (string-upcase s)
(%prim*? "{ /* string-upcase */
int *d = dupstring(stringdata(obj_from_$arg)); char *s;
for (s = sdatachars(d); *s; ++s) *s = toupper(*s);
$return obj(hpushstr($live, d)); }" s))
(define-inline (string-downcase s)
(%prim*? "{ /* string-downcase */
int *d = dupstring(stringdata(obj_from_$arg)); char *s;
for (s = sdatachars(d); *s; ++s) *s = tolower(*s);
$return obj(hpushstr($live, d)); }" s))
(define-syntax string-foldcase string-downcase)
(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 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 x y)]
[(_ x y z ...) (%string-append 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 (substring-copy! to at from start end)
(let ([limit (fxmin end (fx+ start (fx- (string-length to) at)))])
(if (fx<=? at start)
(do ([i at (fx+ i 1)] [j start (fx+ j 1)])
[(fx>=? j limit)]
(string-set! to i (string-ref from j)))
(do ([i (fx+ at (fx- end start 1)) (fx- i 1)] [j (fx- limit 1) (fx- j 1)])
[(fx<? j start)]
(string-set! to i (string-ref from j))))))
(define (substring-fill! str c start end)
(do ([i start (fx+ i 1)]) [(fx>=? i end)] (string-set! str i c)))
(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 (%new-vector n)
(%prim* "{ /* new-vector */
int c = fixnum_from_$arg;
hreserve(hbsz(c+1), $live); /* $live live regs */
hp -= c; memset(hp, 0, c * sizeof(obj));
*--hp = obj_from_size(VECTOR_BTAG);
$return obj(hendblk(c+1)); }" n))
(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
(syntax-rules ()
[(_ n) (%new-vector n)]
[(_ n i) (%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 (subvector-copy! to at from start end)
(let ([limit (fxmin end (fx+ start (fx- (vector-length to) at)))])
(if (fx<=? at start)
(do ([i at (fx+ i 1)] [j start (fx+ j 1)])
[(fx>=? j limit)]
(vector-set! to i (vector-ref from j)))
(do ([i (fx+ at (fx- end start 1)) (fx- i 1)] [j (fx- limit 1) (fx- j 1)])
[(fx<? j start)]
(vector-set! to i (vector-ref from j))))))
(define (subvector vec start end)
(let ([v (make-vector (fx- end start))])
(subvector-copy! v 0 vec start end)
v))
(define (subvector-fill! vec x start end)
(do ([i start (fx+ i 1)]) [(fx>=? i end)] (vector-set! vec i x)))
; bytevectors
(%definition "/* bytevectors */")
(%localdef "static cxtype_t cxt_bytevector = { \"bytevector\", free };")
(%localdef "cxtype_t *BYTEVECTOR_NTAG = &cxt_bytevector;")
(%definition "extern cxtype_t *BYTEVECTOR_NTAG;")
(%definition "#define isbytevector(o) (isnative(o, BYTEVECTOR_NTAG))")
(%definition "#define bytevectordata(o) ((int*)getnative(o, BYTEVECTOR_NTAG))")
(%definition "#define bvdatabytes(d) ((unsigned char*)((d)+1))")
(%definition "#define bytevectorlen(o) (*bytevectordata(o))")
(%definition "#define bytevectorbytes(o) (bvdatabytes(bytevectordata(o)))")
(%definition "#define hpushu8v(l, s) hpushptr(s, BYTEVECTOR_NTAG, l)")
(%localdef "#define mallocbvdata(n) cxm_cknull(malloc(sizeof(int)+(n)), \"malloc(bytevector)\")")
(%definition "static int is_byte_obj(obj o) { return (obj_from_fixnum(0) <= o && o <= obj_from_fixnum(255)); } ")
(%definition "#define byte_from_obj(o) byte_from_fixnum(fixnum_from_obj(o))")
(%definition "#ifdef NDEBUG
#define byte_from_fixnum(n) ((unsigned char)(n))
#else
static unsigned char byte_from_fixnum(int n) { assert(0 <= n && n <= 255); return n; }
#endif")
(%definition "#define byte_from_obj(o) byte_from_fixnum(fixnum_from_obj(o))")
(%localdef "unsigned char* bytevectorref(obj o, int i) {
int *d = bytevectordata(o); assert(i >= 0 && i < *d); return (bvdatabytes(d))+i;
}")
(%definition "#ifdef NDEBUG
#define bytevectorref(o, i) (bytevectorbytes(o)+(i))
#else
extern unsigned char* bytevectorref(obj o, int i);
#endif")
(%definition "extern int *newbytevector(unsigned char *s, int n);")
(%localdef "int *newbytevector(unsigned char *s, int n) {
int *d; assert(s); assert(n >= 0);
d = mallocbvdata(n); *d = n; memcpy(bvdatabytes(d), s, n); return d;
}")
(%definition "extern int *makebytevector(int n, int c);")
(%localdef "int *makebytevector(int n, int c) {
int *d; assert(n >= 0);
d = mallocbvdata(n); *d = n; memset(bvdatabytes(d), c, n);
return d;
}")
(%definition "extern int *allocbytevector(int n);")
(%localdef "int *allocbytevector(int n) {
int *d = mallocbvdata(n); *d = n; return d;
}")
(%definition "extern int *dupbytevector(int *d);")
(%localdef "int *dupbytevector(int *d0) {
int *d1 = mallocbvdata(*d0); *d1 = *d0;
memcpy(bvdatabytes(d1), bvdatabytes(d0), *d0);
return d1;
}")
(%definition "extern int bytevectoreq(int *d0, int *d1);")
(%localdef "int bytevectoreq(int *d0, int *d1) {
int l0 = *d0, l1 = *d1;
return (l0 != l1) ? 0 : memcmp(bvdatabytes(d0), bvdatabytes(d1), l0) == 0;
}")
(%definition "extern int *subbytevector(int *d, int from, int to);")
(%localdef "int *subbytevector(int *d0, int from, int to) {
int n = to-from, *d1; unsigned char *s0, *s1; assert(d0);
assert(0 <= from && from <= to && to <= *d0);
d1 = mallocbvdata(n); *d1 = n; s0 = bvdatabytes(d0); s1 = bvdatabytes(d1);
memcpy(s1, s0+from, n); return d1;
}")
#read #u8<list> as (%const bytevector <list>)
(define-syntax %const
(let-syntax ([old-%const %const])
(syntax-rules (bytevector)
[(_ bytevector (x ...)) (bytevector x ...)]
[(_ arg ...) (old-%const arg ...)])))
(define-inline (byte? x)
(%prim "bool(is_byte_obj(obj_from_$arg))" x))
(define-inline (bytevector? x)
(%prim "bool(isbytevector(obj_from_$arg))" x))
(define-syntax make-bytevector
(syntax-rules ()
[(_ k) (%prim* "obj(hpushu8v($live, allocbytevector(fixnum_from_$arg)))" k)]
[(_ k c) (%prim* "obj(hpushu8v($live, makebytevector(fixnum_from_$arg, byte_from_fixnum(fixnum_from_$arg))))" k c)]
[_ %residual-make-bytevector]))
(define-syntax bytevector
(syntax-rules ()
[(_ b ...)
(%prim* "{ /* bytevector */
obj o = hpushu8v($live, allocbytevector($argc));
unsigned char *s = bytevectorbytes(o);
${*s++ = byte_from_fixnum(fixnum_from_$arg);
$}$return obj(o); }" b ...)]
[_ %residual-bytevector]))
(define-inline (bytevector-length bv)
(%prim "fixnum(bytevectorlen(obj_from_$arg))" bv))
(define-inline (bytevector-u8-ref bv k)
(%prim? "fixnum(*bytevectorref(obj_from_$arg, fixnum_from_$arg))" bv k))
(define-inline (bytevector-u8-set! bv k b)
(%prim! "void(*bytevectorref(obj_from_$arg, fixnum_from_$arg) = byte_from_fixnum(fixnum_from_$arg))" bv k b))
(define-inline (bytevector=? x y)
(%prim? "bool(bytevectoreq(bytevectordata(obj_from_$arg), bytevectordata(obj_from_$arg)))" x y))
(define (subbytevector-copy! to at from start end)
(let ([limit (fxmin end (fx+ start (fx- (bytevector-length to) at)))])
(if (fx<=? at start)
(do ([i at (fx+ i 1)] [j start (fx+ j 1)])
[(fx>=? j limit)]
(bytevector-u8-set! to i (bytevector-u8-ref from j)))
(do ([i (fx+ at (fx- end start 1)) (fx- i 1)] [j (fx- limit 1) (fx- j 1)])
[(fx<? j start)]
(bytevector-u8-set! to i (bytevector-u8-ref from j))))))
(define-inline (subbytevector bv start end)
(%prim*? "{ /* subbytevector */
int *d = subbytevector(bytevectordata(obj_from_$arg), fixnum_from_$arg, fixnum_from_$arg);
$return obj(hpushu8v($live, d)); }" bv start end))
; 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 with payload 0 and 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 (%make-list n i)
(let loop ([n n] [l '()])
(if (<= n 0) l (loop (- n 1) (cons i l)))))
(define-syntax make-list
(syntax-rules ()
[(_ n) (%make-list n (void))]
[(_ n i) (%make-list n i)]
[_ %residual-make-list]))
(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 (%append 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 x y)]
[(_ x y z ...) (%append x (append y z ...))]
[_ %residual-append]))
(define (list-copy obj)
(if (pair? obj)
(cons (car obj) (list-copy (cdr obj)))
obj))
(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 (list-set! l n obj)
(set-car! (list-tail list n) obj))
(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 (pair? 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 (pair? l) (begin (f (car l)) (loop (cdr l))))))]
[(_ fun lst . l*) (%residual-for-each fun lst . l*)]
[_ %residual-for-each]))
; symbols
; symbols are 24-bit immediates 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-syntax symbol=?
(syntax-rules ()
[(_ x y) (%prim "bool(getsymbol(obj_from_$arg) == getsymbol(obj_from_$arg))" x y)]
[(_ x y z ...) (let ([t y]) (and (symbol=? x t) (symbol=? t z ...)))]
[_ %residual-symbol=?]))
; records
; records are typed blocks with rtd (non-immediate object) as type
(%definition "/* records */")
(%definition "#define isrecord(o) istyped(o)")
(%definition "#define recordrtd(r) *typedtype(r)")
(%definition "#define recordlen(r) typedlen(r)")
(%definition "#define recordref(r, i) *typedref(r, i)")
(define-syntax record?
(syntax-rules ()
[(_ o) (%prim "bool(isrecord(obj_from_$arg))" o)]
[(_ o t) (%prim "{ /* record? */
obj o = obj_from_$arg, t = obj_from_$arg;
if (!isrecord(o)) $return bool(0);
else $return bool(recordrtd(o) == t); }" o t)]
[_ %residual-record?]))
(define-inline (make-record rtd n)
(%prim* "{ /* make-record */
int c = fixnum_from_$arg;
hreserve(hbsz(c+1), $live); /* $live live regs */
hp -= c; memset(hp, 0, c * sizeof(obj));
*--hp = obj_from_$arg; assert(isobjptr(*hp));
$return obj(hendblk(c+1)); }" n rtd))
(define-inline (record-type-descriptor r)
(%prim "obj(recordrtd(obj_from_$arg))" r))
(define-inline (record-length r)
(%prim "fixnum(recordlen(obj_from_$arg))" r))
(define-inline (record-ref r i)
(%prim? "obj(recordref(obj_from_$arg, fixnum_from_$arg))" r i))
(define-inline (record-set! r i x)
(%prim! "void(recordref(obj_from_$arg, fixnum_from_$arg) = obj_from_$arg)" r i x))
(define-inline (new-record-type name fields) ; stub
(cons name fields))
; works on top and locally, but field names cannot be hygienically generated on top level
(define-syntax define-record-type
(letrec-syntax
([id-eq?? ; see http://okmij.org/ftp/Scheme/macro-symbol-p.txt
(syntax-rules ()
[(_ id b kt kf)
((syntax-lambda (id ok) ((syntax-rules () [(_ b) (id)]) ok))
(syntax-rules () [(_) kf]) (syntax-rules () [(_) kt]))])]
[id-assq??
(syntax-rules ()
[(_ id () kt kf) kf]
[(_ id ([id0 . r0] . idr*) kt kf) (id-eq?? id id0 (kt . r0) (id-assq?? id idr* kt kf))])]
[init
(syntax-rules ()
[(_ r () fi* (x ...)) (begin x ... r)]
[(_ r (id0 . id*) fi* (x ...))
(id-assq?? id0 fi*
(syntax-rules () [(_ i0) (init r id* fi* (x ... (record-set! r i0 id0)))])
(syntax-error "id in define-record-type constructor is not a field:" id0))])]
[unroll
(syntax-rules ()
[(_ rtn (consn id ...) predn () ([f i] ...) ([a ia] ...) ([m im] ...))
(begin
(define rtn (new-record-type 'rtn '(f ...)))
(define consn (lambda (id ...) (let ([r (make-record rtn #&(length (f ...)))]) (init r (id ...) ([f i] ...) ()))))
(define predn (lambda (obj) (record? obj rtn)))
(define a (lambda (obj) (record-ref obj ia))) ...
(define m (lambda (obj val) (record-set! obj im val))) ...)]
[(_ rtn cf* predn ([fn accn] fam ...) (fi ...) (ai ...) (mi ...))
(unroll rtn cf* predn (fam ...)
(fi ... [fn #&(length (fi ...))]) (ai ... [accn #&(length (fi ...))]) (mi ...))]
[(_ rtn cf* predn ([fn accn modn] fam ...) (fi ...) (ai ...) (mi ...))
(unroll rtn cf* predn (fam ...)
(fi ... [fn #&(length (fi ...))]) (ai ... [accn #&(length (fi ...))]) (mi ... [modn #&(length (fi ...))]))])])
(syntax-rules ()
[(_ rtn (consn id ...) predn (fn . am) ...)
(unroll rtn (consn id ...) predn ((fn . am) ...) () () ())])))
; 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; double d = flonum_from_$arg; sprintf(buf, \"%.15g\", d);
for (s = buf; *s != 0; s++) if (strchr(\".eE\", *s)) break;
if (d != d) strcpy(buf, \"+nan.0\"); else if (d <= -HUGE_VAL) strcpy(buf, \"-inf.0\");
else if (d >= HUGE_VAL) strcpy(buf, \"+inf.0\"); else if (*s == 'E') *s = 'e';
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_ci(s+1, \"inf.0\") == 0) d = (*s == '-' ? -HUGE_VAL : HUGE_VAL);
else if (strcmp_ci(s+1, \"nan.0\") == 0) d = HUGE_VAL - HUGE_VAL;
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 (subvector->list vec start end)
(let loop ([i (fx- end 1)] [l '()])
(if (fx<? i start) l (loop (fx- i 1) (cons (vector-ref vec i) l)))))
(define (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 (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 (substring->list str start end)
(let loop ([i (fx- end 1)] [l '()])
(if (fx<? i start) l (loop (fx- i 1) (cons (string-ref str i) l)))))
(define (%subvector-string-copy! to at from start end)
(let ([limit (fxmin end (fx+ start (fx- (string-length to) at)))])
(do ([i at (fx+ i 1)] [j start (fx+ j 1)])
[(fx>=? j limit) to]
(string-set! to i (vector-ref from j)))))
(define (subvector->string vec start end)
(%subvector-string-copy! (make-string (fx- end start)) 0 vec start end))
(define (%substring-vector-copy! to at from start end)
(let ([limit (fxmin end (fx+ start (fx- (vector-length to) at)))])
(do ([i at (fx+ i 1)] [j start (fx+ j 1)])
[(fx>=? j limit) to]
(vector-set! to i (string-ref from j)))))
(define (substring->vector str start end)
(%substring-vector-copy! (make-vector (fx- end start)) 0 str start end))
(define (list->bytevector l)
(%prim*? "{ /* list->bytevector */
int i, c = fixnum_from_$arg;
obj o = hpushu8v($live, allocbytevector(c)); /* $live live regs */
obj l = obj_from_$arg; /* gc-safe */
unsigned char *s = bytevectorbytes(o);
for (i = 0; i < c; ++i, l = cdr(l)) s[i] = byte_from_obj(car(l));
$return obj(o); }" (length l) l))
(define (subbytevector->list vec start end)
(let loop ([i (fx- end 1)] [l '()])
(if (fx<? i start) l (loop (fx- i 1) (cons (bytevector-u8-ref vec i) l)))))
; 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], t;
return notaptr(h) && size_from_obj(h) >= 1
&& isaptr(t = hblkref(o, 0)) && t && notobjptr(t); }
}")
(%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] ...))])))
; parameters, r7rs-style
(define make-parameter
(case-lambda
[(value)
(case-lambda
[() value]
[(x) (set! value x)]
[(x s) (if s (set! value x) x)])]
[(init converter)
(let ([value (converter init)])
(case-lambda
[() value]
[(x) (set! value (converter x))]
[(x s) (if s (set! value x) (converter x))]))]))
(define-syntax parameterize
(letrec-syntax
([loop
(syntax-rules ()
[(_ ([param value p old new] ...) () body)
(let ([p param] ...)
(let ([old (p)] ... [new (p value #f)] ...)
(dynamic-wind
(lambda () (p new #t) ...)
(lambda () . body)
(lambda () (p old #t) ...))))]
[(_ args ([param value] . rest) body)
(loop ([param value p old new] . args) rest body)])])
(syntax-rules ()
[(_ ([param value] ...) . body)
(loop () ([param value] ...) body)])))
; delay & force, r7rs-style
(define promise? box?)
(define (make-promise o) (box (cons #t o)))
(define (make-lazy-promise o) (box (cons #f o)))
(define (force p)
(let ([pc (unbox p)])
(if (car pc)
(cdr pc)
(let* ([newp ((cdr pc))] [pc (unbox p)])
(unless (car pc)
(set-car! pc (car (unbox newp)))
(set-cdr! pc (cdr (unbox newp)))
(set-box! newp pc))
(force p)))))
(define-syntax delay-force
(syntax-rules () [(_ x) (make-lazy-promise (lambda () x))]))
(define-syntax delay
(syntax-rules () [(_ x) (delay-force (make-promise x))]))
; eof
; eof is tagged immediate with payload 0 and immediate tag 7
(%definition "/* eof */")
(%definition "#define EOF_ITAG 7")
(%definition "#define mkeof() mkimm(0, EOF_ITAG)")
(%definition "#define iseof(o) ((o) == mkimm(0, 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
; internal helper fo opening regular files
(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_CLOSED_NTAG;")
(%definition "extern cxtype_t *IPORT_FILE_NTAG;")
(%definition "extern cxtype_t *IPORT_STRING_NTAG;")
(%definition "extern cxtype_t *IPORT_BYTEVECTOR_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_CLOSED_NTAG && pt != IPORT_FILE_NTAG &&
pt != IPORT_STRING_NTAG && pt != IPORT_BYTEVECTOR_NTAG) return NULL;
else return (cxtype_iport_t*)pt; }")
(%definition "#define ckiportvt(o) ((cxtype_iport_t*)cxm_cknull(iportvt(o), \"iportvt\"))")
(%definition "#define isiport(o) (iportvt(o) != NULL)")
(%definition "#define iportdata(o) ((void*)(*objptr_from_obj(o)))")
(%definition "static int iportgetc(obj o) {
cxtype_iport_t *vt = iportvt(o); void *pp = iportdata(o);
assert(vt); return vt->getch(pp);
}")
(%definition "static int iportpeekc(obj o) {
cxtype_iport_t *vt = iportvt(o); void *pp = iportdata(o); int c;
assert(vt); c = vt->getch(pp); if (c != EOF) vt->ungetch(c, pp); return c;
}")
(define-inline (input-port? x)
(%prim "bool(isiport(obj_from_$arg))" x))
(define-inline (port-fold-case? ip) ;stub
(%prim? "bool(((void)ckiportvt(obj_from_$arg), 0))" ip))
(define-inline (set-port-fold-case! ip b) ;stub
(%prim?! "void(ckiportvt(obj_from_$arg))" ip))
; closed input ports
(%definition "/* closed input ports */")
(%localdef "static void cifree(void *p) {}")
(%localdef "static int ciclose(void *p) { return 0; }")
(%localdef "static int cigetch(void *p) { return EOF; }")
(%localdef "static int ciungetch(int c) { return c; }")
(%localdef "static cxtype_iport_t cxt_iport_closed = {
\"closed-input-port\", (void (*)(void*))cifree, (int (*)(void*))ciclose,
(int (*)(void*))cigetch, (int (*)(int, void*))ciungetch };")
(%localdef "cxtype_t *IPORT_CLOSED_NTAG = (cxtype_t *)&cxt_iport_closed;")
(define (close-input-port p)
(%prim?! "{ /* close-input-port */
obj o = obj_from_$arg; cxtype_iport_t *vt = iportvt(o); assert(vt);
vt->close(iportdata(o)); vt->free(iportdata(o));
objptr_from_obj(o)[-1] = (obj)IPORT_CLOSED_NTAG;
$return void(0); }" p))
(define-inline (input-port-open? p)
(%prim? "bool(ckiportvt(obj_from_$arg) != (cxtype_iport_t *)IPORT_CLOSED_NTAG)" 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 *current-input-port* (%prim* "obj(mkiport_file($live, stdin))"))
(define-syntax current-input-port ; parameter
(syntax-rules ()
[(_) *current-input-port*]
[(_ p) (set! *current-input-port* p)]
[(_ p s) (if s (set! *current-input-port* p) p)]
[_ %residual-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*)
(file-error "cannot open input file" fn))))
(define-inline (open-binary-input-file fn)
(let ([file* (open-file* fn "rb")])
(if file* (%prim*?! "obj(mkiport_file($live, (void*)(obj_from_$arg)))" file*)
(file-error "cannot open binary input file" fn))))
; 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))
; bytevector input ports
(%definition "/* bytevector input ports */")
(%definition "typedef struct { unsigned char *p, *e; void *base; } bvifile_t;")
(%localdef "bvifile_t *bvialloc(unsigned char *p, unsigned char *e, void *base) {
bvifile_t *fp = cxm_cknull(malloc(sizeof(bvifile_t)), \"malloc(bvifile)\");
fp->p = p; fp->e = e; fp->base = base; return fp; }")
(%definition "extern bvifile_t *bvialloc(unsigned char *p, unsigned char *e, void *base);")
(%localdef "static void bvifree(bvifile_t *fp) {
assert(fp); if (fp->base) free(fp->base); free(fp); }")
(%localdef "static int bviclose(bvifile_t *fp) {
assert(fp); if (fp->base) free(fp->base); fp->base = NULL;
fp->p = fp->e = (unsigned char *)\"\"; return 0; }")
(%localdef "static int bvigetch(bvifile_t *fp) {
assert(fp && fp->p && fp->e); return (fp->p >= fp->e) ? EOF : (0xff & *(fp->p)++); }")
(%localdef "static int bviungetch(int c, bvifile_t *fp) {
assert(fp && fp->p && fp->e); --(fp->p); assert(c == *(fp->p)); return c; }")
(%localdef "static cxtype_iport_t cxt_iport_bytevector = {
\"bytevector-input-port\", (void (*)(void*))bvifree, (int (*)(void*))bviclose,
(int (*)(void*))bvigetch, (int (*)(int, void*))bviungetch };")
(%localdef "cxtype_t *IPORT_BYTEVECTOR_NTAG = (cxtype_t *)&cxt_iport_bytevector;")
(%definition "#define mkiport_bytevector(l, fp) hpushptr(fp, IPORT_BYTEVECTOR_NTAG, l)")
(define-inline (open-input-bytevector s)
(%prim*? "{ /* open-input-bytevector */
int *d = dupbytevector(bytevectordata(obj_from_$arg));
unsigned char *p = bvdatabytes(d), *e = p + *d;
$return obj(mkiport_bytevector($live, bvialloc(p, e, d))); }" s))
; generic output ports
(%definition "/* output ports */")
(%definition "typedef struct { /* extends cxtype_t */
const char *tname;
void (*free)(void*);
int (*close)(void*);
int (*putch)(int, void*);
int (*flush)(void*);
} cxtype_oport_t;")
(%definition "extern cxtype_t *OPORT_CLOSED_NTAG;")
(%definition "extern cxtype_t *OPORT_FILE_NTAG;")
(%definition "extern cxtype_t *OPORT_STRING_NTAG;")
(%definition "extern cxtype_t *OPORT_BYTEVECTOR_NTAG;")
(%definition "static cxtype_oport_t *oportvt(obj o) {
cxtype_t *pt; if (!isobjptr(o)) return NULL;
pt = (cxtype_t*)objptr_from_obj(o)[-1];
if (pt != OPORT_CLOSED_NTAG && pt != OPORT_FILE_NTAG &&
pt != OPORT_STRING_NTAG && pt != OPORT_BYTEVECTOR_NTAG) return NULL;
else return (cxtype_oport_t*)pt; }")
(%definition "#define ckoportvt(o) ((cxtype_oport_t*)cxm_cknull(oportvt(o), \"oportvt\"))")
(%definition "#define isoport(o) (oportvt(o) != NULL)")
(%definition "#define oportdata(o) ((void*)(*objptr_from_obj(o)))")
(%definition "static void oportputc(int c, obj o) {
cxtype_oport_t *vt = oportvt(o); void *pp = oportdata(o);
assert(vt); vt->putch(c, pp);
}")
(%definition "static void oportputs(char *s, obj o) {
cxtype_oport_t *vt = oportvt(o); void *pp = oportdata(o);
assert(vt); while (*s) vt->putch(*s++, pp);
}")
(%definition "static void oportwrite(char *s, int n, obj o) {
cxtype_oport_t *vt = oportvt(o); void *pp = oportdata(o);
assert(vt); while (n-- > 0) vt->putch(*s++, pp);
}")
(%definition "static void oportflush(obj o) {
cxtype_oport_t *vt = oportvt(o); void *pp = oportdata(o);
assert(vt); vt->flush(pp);
}")
(define-inline (output-port? x)
(%prim "bool(isoport(obj_from_$arg))" x))
; closed output ports
(%definition "/* closed output ports */")
(%localdef "static void cofree(void *p) {}")
(%localdef "static int coclose(void *p) { return 0; }")
(%localdef "static int coputch(int c, void *p) { return EOF; }")
(%localdef "static int coflush(void *p) { return EOF; }")
(%localdef "static cxtype_oport_t cxt_oport_closed = {
\"closed-output-port\", (void (*)(void*))cofree, (int (*)(void*))coclose,
(int (*)(int, void*))coputch, (int (*)(void*))coflush };")
(%localdef "cxtype_t *OPORT_CLOSED_NTAG = (cxtype_t *)&cxt_oport_closed;")
(define (close-output-port p)
(%prim?! "{ /* close-output-port */
obj o = obj_from_$arg; cxtype_oport_t *vt = oportvt(o); assert(vt);
vt->close(oportdata(o)); vt->free(oportdata(o));
objptr_from_obj(o)[-1] = (obj)OPORT_CLOSED_NTAG;
$return void(0); }" p))
(define-inline (output-port-open? p)
(%prim? "bool(ckoportvt(obj_from_$arg) != (cxtype_oport_t *)OPORT_CLOSED_NTAG)" p))
; file output ports
(%localdef "static cxtype_oport_t cxt_oport_file = {
\"file-output-port\", ffree, (int (*)(void*))fclose,
(int (*)(int, void*))(fputc), (int (*)(void*))fflush };")
(%localdef "cxtype_t *OPORT_FILE_NTAG = (cxtype_t *)&cxt_oport_file;")
(%definition "#define mkoport_file(l, fp) hpushptr(fp, OPORT_FILE_NTAG, l)")
(define *current-output-port* (%prim* "obj(mkoport_file($live, stdout))"))
(define-syntax current-output-port ; parameter
(syntax-rules ()
[(_) *current-output-port*]
[(_ p) (set! *current-output-port* p)]
[(_ p s) (if s (set! *current-output-port* p) p)]
[_ %residual-current-output-port]))
(define *current-error-port* (%prim* "obj(mkoport_file($live, stderr))"))
(define-syntax current-error-port ; parameter
(syntax-rules ()
[(_) *current-error-port*]
[(_ p) (set! *current-error-port* p)]
[(_ p s) (if s (set! *current-error-port* p) p)]
[_ %residual-current-error-port]))
(define-inline (open-output-file fn)
(let ([file* (open-file* fn "w")])
(if file* (%prim*?! "obj(mkoport_file($live, (void*)(obj_from_$arg)))" file*)
(file-error "cannot open output file" fn))))
(define-inline (open-binary-output-file fn)
(let ([file* (open-file* fn "wb")])
(if file* (%prim*?! "obj(mkoport_file($live, (void*)(obj_from_$arg)))" file*)
(file-error "cannot open binary output file" fn))))
; string output ports
(%definition "/* string output ports */")
(%definition "typedef struct cbuf_tag { char *buf; char *fill; char *end; } cbuf_t;")
(%definition "extern cbuf_t* newcb(void);")
(%localdef "cbuf_t* newcb(void) {
cbuf_t* pcb = cxm_cknull(malloc(sizeof(cbuf_t)), \"malloc(cbuf)\");
pcb->fill = pcb->buf = cxm_cknull(malloc(64), \"malloc(cbdata)\");
pcb->end = pcb->buf + 64; return pcb;
}")
(%localdef "static void freecb(cbuf_t* pcb) { if (pcb) { free(pcb->buf); free(pcb); } }")
(%localdef "static void cbgrow(cbuf_t* pcb, size_t n) {
size_t oldsz = pcb->end - pcb->buf, newsz = oldsz*2;
size_t cnt = pcb->fill - pcb->buf;
if (oldsz + n > newsz) newsz += n;
pcb->buf = cxm_cknull(realloc(pcb->buf, newsz), \"realloc(cbdata)\");
pcb->fill = pcb->buf + cnt, pcb->end = pcb->buf + newsz;
}")
(%localdef "static int cbputc(int c, cbuf_t* pcb) {
if ((pcb)->fill == (pcb)->end) cbgrow(pcb, 1); *((pcb)->fill)++ = c; return c;
}")
(%localdef "static int cbflush(cbuf_t* pcb) { return 0; }")
(%localdef "static int cbclose(cbuf_t* pcb) { free(pcb->buf); pcb->buf = NULL; return 0; }")
;(%localdef "static size_t cblen(cbuf_t* pcb) { return pcb->fill - pcb->buf; }")
(%definition "extern char* cbdata(cbuf_t* pcb);")
(%localdef "char* cbdata(cbuf_t* pcb) {
if (pcb->fill == pcb->end) cbgrow(pcb, 1); *(pcb->fill) = 0; return pcb->buf;
}")
(%localdef "static cxtype_oport_t cxt_oport_string = {
\"string-output-port\", (void (*)(void*))freecb, (int (*)(void*))cbclose,
(int (*)(int, void*))cbputc, (int (*)(void*))cbflush };")
(%localdef "cxtype_t *OPORT_STRING_NTAG = (cxtype_t *)&cxt_oport_string;")
(%definition "#define mkoport_string(l, fp) hpushptr(fp, OPORT_STRING_NTAG, l)")
(define-inline (open-output-string)
(%prim*? "{ /* open-output-string */
$return obj(mkoport_string($live, newcb())); }"))
(define-inline (get-output-string p) ; works on string and bv ports
(%prim*? "{ /* get-output-string */
obj o = obj_from_$arg; cxtype_oport_t *vt = ckoportvt(o);
if (vt != (cxtype_oport_t *)OPORT_STRING_NTAG &&
vt != (cxtype_oport_t *)OPORT_BYTEVECTOR_NTAG) $return obj(mkeof());
else { cbuf_t *pcb = oportdata(o);
$return obj(hpushstr($live, newstring(cbdata(pcb)))); } }" p))
; bytevector output ports
(%definition "/* bytevector output ports */")
(%localdef "static cxtype_oport_t cxt_oport_bytevector = {
\"bytevector-output-port\", (void (*)(void*))freecb, (int (*)(void*))cbclose,
(int (*)(int, void*))cbputc, (int (*)(void*))cbflush };")
(%localdef "cxtype_t *OPORT_BYTEVECTOR_NTAG = (cxtype_t *)&cxt_oport_bytevector;")
(%definition "#define mkoport_bytevector(l, fp) hpushptr(fp, OPORT_BYTEVECTOR_NTAG, l)")
(define-inline (open-output-bytevector)
(%prim*? "{ /* open-output-bytevector */
$return obj(mkoport_bytevector($live, newcb())); }"))
(define-inline (get-output-bytevector p) ; works on bv and string ports
(%prim*? "{ /* get-output-bytevector */
obj o = obj_from_$arg; cxtype_oport_t *vt = ckoportvt(o);
if (vt != (cxtype_oport_t *)OPORT_BYTEVECTOR_NTAG &&
vt != (cxtype_oport_t *)OPORT_STRING_NTAG) $return obj(mkeof());
else { cbuf_t *pcb = oportdata(o); int len = (int)(pcb->fill - pcb->buf);
$return obj(hpushu8v($live, newbytevector((unsigned char *)pcb->buf, len))); } }" p))
; generic port predicates and standard opening/closing convenience ops
(define-inline (port? x) (or (input-port? x) (output-port? x)))
(define-syntax textual-port? port?) ; all ports are bimodal
(define-syntax binary-port? port?) ; all ports are bimodal
(define (close-port p)
(if (input-port? p) (close-input-port p))
(if (output-port? p) (close-output-port p)))
; NB: call-with-port defined in the last section, after call-with-values
(define (call-with-input-file fname proc)
(call-with-port (open-input-file fname) proc))
(define (call-with-output-file fname proc)
(call-with-port (open-output-file fname) proc))
(define (with-input-from-port port thunk) ; extra
(parameterize ([current-input-port port]) (thunk)))
(define (with-output-to-port port thunk) ; extra
(parameterize ([current-output-port port]) (thunk)))
(define (with-input-from-file fname thunk)
(call-with-input-file fname (lambda (p) (with-input-from-port p thunk))))
(define (with-output-to-file fname thunk)
(call-with-output-file fname (lambda (p) (with-output-to-port p thunk))))
; simple text i/o
(define-syntax read-char
(syntax-rules ()
[(_) (read-char (current-input-port))]
[(_ p) (%prim?! "{ int c = iportgetc(obj_from_$arg); $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?! "{ int c = iportpeekc(obj_from_$arg); $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 (%read-line p)
(let ([op (open-output-string)])
(let loop ([read-nothing? #t])
(let ([c (read-char p)])
(cond [(or (eof-object? c) (char=? c #\newline))
(let ([s (get-output-string op)])
(close-output-port op) ; todo: use get-final-output-string
(if (and (eof-object? c) read-nothing?) c s))]
[(char=? c #\return) (loop #f)]
[else (%prim?! "void(oportputc(char_from_$arg, obj_from_$arg))" c op) (loop #f)])))))
(define-syntax read-line
(syntax-rules ()
[(_) (%read-line (current-input-port))]
[(_ p) (%read-line p)]
[_ %residual-read-line]))
(define (read-substring! str start end p)
(let loop ([i start])
(if (fx>=? i end)
(fx- i start)
(let ([c (read-char p)])
(cond [(eof-object? c) (if (fx=? i start) c (fx- i start))]
[else (string-set! str i c) (loop (fx+ i 1))])))))
(define (read-substring k p)
(let ([str (make-string k)])
(let ([r (read-substring! str 0 k p)])
(if (eof-object? r)
r
(if (fx=? r k) str (substring str 0 r))))))
(define-syntax flush-output-port
(syntax-rules ()
[(_) (flush-output-port (current-output-port))]
[(_ p) (%prim?! "void(oportflush(obj_from_$arg))" p)]
[_ %residual-flush-output-port]))
(define-syntax write-char
(syntax-rules ()
[(_ c) (write-char c (current-output-port))]
[(_ c p) (%prim?! "void(oportputc(char_from_$arg, obj_from_$arg))" c p)]
[_ %residual-write-char]))
(define (write-substring from start end p)
(do ([i start (fx+ i 1)]) [(fx>=? i end)] (write-char (string-ref from i) p)))
(define-syntax write-string
(syntax-rules ()
[(_ s) (write-string s (current-output-port))]
[(_ s p) (%prim?! "void(oportputs(stringchars(obj_from_$arg), obj_from_$arg))" s p)]
[(_ s p start) (let ([str s]) (write-substring str start (string-length str) p))]
[(_ s p start end) (write-substring s start end p)]
[_ %residual-write-string]))
(define-syntax newline
(syntax-rules ()
[(_) (newline (current-output-port))]
[(_ p) (%prim?! "void(oportputc('\\n', obj_from_$arg))" p)]
[_ %residual-newline]))
(define-syntax display-fixnum
(syntax-rules ()
[(_ x) (display-fixnum x (current-output-port))]
[(_ x p) (%prim?! "{ /* display-fixnum */
char buf[30]; sprintf(buf, \"%ld\", fixnum_from_$arg);
$return void(oportputs(buf, obj_from_$arg)); }" x p)]
[_ %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; double d = flonum_from_$arg; sprintf(buf, \"%.15g\", d);
for (s = buf; *s != 0; s++) if (strchr(\".eE\", *s)) break;
if (d != d) strcpy(buf, \"+nan.0\"); else if (d <= -HUGE_VAL) strcpy(buf, \"-inf.0\");
else if (d >= HUGE_VAL) strcpy(buf, \"+inf.0\"); else if (*s == 'E') *s = 'e';
else if (*s == 0) { *s++ = '.'; *s++ = '0'; *s = 0; }
$return void(oportputs(buf, obj_from_$arg)); }" x p)]
[_ %residual-display-flonum]))
(define-syntax display-procedure
(syntax-rules ()
[(_ x) (display-procedure x (current-output-port))]
[(_ x p) (%prim?! "{ /* display-procedure */
char buf[60]; sprintf(buf, \"#<procedure @%p>\", objptr_from_obj(obj_from_$arg));
$return void(oportputs(buf, obj_from_$arg)); }" x p)]
[_ %residual-display-procedure]))
(define-syntax display-input-port
(syntax-rules ()
[(_ x) (display-input-port x (current-output-port))]
[(_ x p) (%prim?! "{ /* display-input-port */
char buf[60]; sprintf(buf, \"#<%s>\", ckiportvt(obj_from_$arg)->tname);
$return void(oportputs(buf, obj_from_$arg)); }" x p)]
[_ %residual-display-input-port]))
(define-syntax display-output-port
(syntax-rules ()
[(_ x) (display-output-port x (current-output-port))]
[(_ x p) (%prim?! "{ /* display-output-port */
char buf[60]; sprintf(buf, \"#<%s>\", ckoportvt(obj_from_$arg)->tname);
$return void(oportputs(buf, obj_from_$arg)); }" x p)]
[_ %residual-display-output-port]))
; simple binary i/o
(define-syntax read-u8
(syntax-rules ()
[(_) (read-u8 (current-input-port))]
[(_ p) (%prim?! "{ int c = iportgetc(obj_from_$arg); $return obj(c == EOF ? mkeof() : obj_from_fixnum(c & 0xff)); }" p)]
[_ %residual-read-u8]))
(define-syntax peek-u8
(syntax-rules ()
[(_) (peek-u8 (current-input-port))]
[(_ p) (%prim?! "{ int c = iportpeekc(obj_from_$arg); $return obj(c == EOF ? mkeof() : obj_from_fixnum(c & 0xff)); }" p)]
[_ %residual-peek-char]))
(define-syntax u8-ready?
(syntax-rules ()
[(_) (u8-ready? (current-input-port))]
[(_ p) #t] ; no better solution for FILE/STRING ports
[_ %residual-u8-ready?]))
(define (read-subbytevector! vec start end p)
(let loop ([i start])
(if (fx>=? i end)
(fx- i start)
(let ([u8 (read-u8 p)])
(cond [(eof-object? u8) (if (fx=? i start) u8 (fx- i start))]
[else (bytevector-u8-set! vec i u8) (loop (fx+ i 1))])))))
(define (read-subbytevector k p)
(let ([vec (make-bytevector k)])
(let ([r (read-subbytevector! vec 0 k p)])
(if (eof-object? r)
r
(if (fx=? r k) vec (subbytevector vec 0 r))))))
(define-syntax write-u8
(syntax-rules ()
[(_ c) (write-u8 c (current-output-port))]
[(_ c p) (%prim?! "void(oportputc(fixnum_from_$arg, obj_from_$arg))" c p)]
[_ %residual-write-u8]))
(define (write-subbytevector from start end p)
(do ([i start (fx+ i 1)]) [(fx>=? i end)] (write-u8 (bytevector-u8-ref from i) p)))
(define-syntax write-bytevector
(syntax-rules ()
[(_ bv) (write-bytevector bv (current-output-port))]
[(_ bv p) (%prim?! "{ /* write-bytevector */
int *d = bytevectordata(obj_from_$arg);
$return void(oportwrite((char *)bvdatabytes(d), *d, obj_from_$arg)); }" bv p)]
[(_ bv p start) (let ([vec bv]) (write-subbytevector vec start (bytevector-length vec) p))]
[(_ bv p start end) (write-subbytevector bv start end p)]
[_ %residual-write-bytevector]))
; circularity and sharing helpers
(%localdef "/* eq hash table for circular/sharing checks and safe equal? */
typedef struct { obj *v; obj *r; size_t sz; size_t u, maxu, c; } stab_t;
static stab_t *staballoc(void) {
stab_t *p = cxm_cknull(calloc(1, sizeof(stab_t)), \"newstab\");
p->v = cxm_cknull(calloc(64, sizeof(obj)), \"newstab[1]\");
p->sz = 64, p->maxu = 64 / 2; return p;
}
static stab_t *stabfree(stab_t *p) {
if (p) { free(p->v); free(p->r); free(p); }
return NULL;
}
static int stabnew(obj o, stab_t *p, int circ) {
if (!o || notaptr(o) || notobjptr(o) || (circ && isaptr(objptr_from_obj(o)[-1]))) return 0;
else { /* v[i] is 0 or heap obj, possibly with lower bit set if it's not new */
unsigned long h = (unsigned long)o; size_t sz = p->sz, i, j;
for (i = h & (sz-1); p->v[i]; i = (i-1) & (sz-1))
if ((p->v[i] & ~1) == o) { p->v[i] |= 1; return 0; }
if (p->u == p->maxu) { /* rehash */
size_t nsz = sz * 2; obj *nv = cxm_cknull(calloc(nsz, sizeof(obj)), \"stabnew\");
for (i = 0; i < sz; ++i) if (p->v[i] & ~1) {
for (j = (unsigned long)(p->v[i] & ~1) & (nsz-1); nv[j]; j = (j-1) & (nsz-1)) ;
nv[j] = p->v[i];
}
free(p->v); p->v = nv; sz = p->sz = nsz; p->maxu = nsz / 2;
for (i = h & (sz-1); p->v[i]; i = (i-1) & (sz-1)) ;
}
p->v[i] = o; p->u += 1; return 1;
}
}
static void stabdelifu(obj o, stab_t *p) {
unsigned long h = (unsigned long)o; size_t sz = p->sz, i;
for (i = h & (sz-1); p->v[i]; i = (i-1) & (sz-1)) if ((p->v[i] & ~1) == o) {
if (p->v[i] & 1) /* keep */; else p->v[i] = 1; /* del */
return;
}
}
static void stabpushp(obj o, stab_t *p) {
obj *r = p->r; if (!r) { p->r = r = cxm_cknull(calloc(sizeof(obj), 12), \"stabpushp\"); r[1] = 10; }
else if (r[0] == r[1]) { p->r = r = cxm_cknull(realloc(r, sizeof(obj)*(2+r[1]*2)), \"stabpushp\"); r[1] *= 2; }
r[2 + r[0]++] = o;
}
static void stabpopp(stab_t *p) {
obj *r = p->r; assert(r && r[0] > 0); r[0] -= 1;
}
static void stabcircular(obj o, stab_t *p) {
tail: if (stabnew(o, p, 1)) {
obj *op = objptr_from_obj(o), fo = op[-1];
if (notaptr(fo)) {
obj *fop = op + size_from_obj(fo);
stabpushp(0, p); while (op+1 < fop) stabcircular(*op++, p); stabpopp(p);
if (op+1 == fop) { stabpushp(o, p); o = *op; goto tail; }
}
} else {
obj *r = p->r; if (r) {
obj *op = r+2, *fop = op+r[0];
while (fop > op && fop[-1] != 0) stabdelifu(*--fop, p);
r[0] = fop - op;
}
}
}
static void stabshared(obj o, stab_t *p) {
tail: if (stabnew(o, p, 0)) {
obj *op = objptr_from_obj(o), fo = op[-1];
if (notaptr(fo)) {
obj *fop = op + size_from_obj(fo);
while (op+1 < fop) stabshared(*op++, p);
if (op+1 == fop) { o = *op; goto tail; }
}
}
}
static stab_t *stabend(stab_t *p) {
size_t nz, i, sz = p->sz;
for (nz = i = 0; i < sz; ++i) if ((p->v[i] & ~1) && (p->v[i] & 1)) ++nz;
if (nz) {
size_t nsz, j; obj *nv; for (nsz = 8; nsz < nz*2; nsz *= 2) ;
nv = cxm_cknull(calloc(nsz, sizeof(obj)), \"stabend\");
for (i = 0; i < sz; ++i) if ((p->v[i] & ~1) && (p->v[i] & 1)) {
for (j = (unsigned long)(p->v[i] & ~1) & (nsz-1); nv[j]; j = (j-1) & (nsz-1)) ;
nv[j] = p->v[i];
}
free(p->v); p->v = nv; sz = p->sz = nsz; p->maxu = nsz / 2;
free(p->r); p->r = NULL;
} else p = stabfree(p);
return p;
}
static long stabri(size_t i, stab_t *p, int upd) {
obj *pri, ri; if (!p->r) p->r = cxm_cknull(calloc(p->sz, sizeof(obj)), \"stabri\");
pri = p->r + i; ri = *pri; if (!ri) *pri = ri = ++(p->c);
if (upd && ri > 0) *pri = -ri; return (long)ri;
}
static long stabref(obj o, stab_t *p, int upd) {
if (!p || !o || notaptr(o) || notobjptr(o)) return 0; else {
unsigned long h = (unsigned long)o; size_t sz = p->sz, i;
for (i = h & (sz-1); p->v[i]; i = (i-1) & (sz-1))
if ((p->v[i] & ~1) == o) return (p->v[i] & 1) ? stabri(i, p, upd) : 0;
return 0;
}
}
static int stabufind(obj x, obj y, stab_t *p) {
size_t sz = p->sz, i, ix=0, iy=0; /* bogus 0 inits to silence gcc */ obj *r = p->r;
for (i = (unsigned long)x & (sz-1); p->v[i]; i = (i-1) & (sz-1)) if ((p->v[i] & ~1) == x) { ix = i; break; }
for (i = ix; r[i] >= 0; ) i = (size_t)r[i]; if (i != ix) ix = r[ix] = i;
for (i = (unsigned long)y & (sz-1); p->v[i]; i = (i-1) & (sz-1)) if ((p->v[i] & ~1) == y) { iy = i; break; }
for (i = iy; r[i] >= 0; ) i = (size_t)r[i]; if (i != iy) iy = r[iy] = i;
if (ix == iy) return 1; /* same class, assumed to be equal */
if (r[ix] < r[iy]) { r[ix] += r[iy]; r[iy] = ix; } else { r[iy] += r[ix]; r[ix] = iy; } return 0;
}
static int stabequal(obj x, obj y, stab_t *p) {
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 (h == (obj)BYTEVECTOR_NTAG) return bytevectoreq(bytevectordata(x), bytevectordata(y));
if (isaptr(h) || !(n = size_from_obj(h)) || hblkref(x, 0) != hblkref(y, 0)) return 0;
if (stabufind(x, y, p)) return 1; /* seen before and decided to be equal */
for (i = 1; i < n-1; ++i) if (!stabequal(hblkref(x, i), hblkref(y, i), p)) return 0;
if (i == n-1) { x = hblkref(x, i); y = hblkref(y, i); goto loop; } else return 1;
}
static int boundequal(obj x, obj y, int fuel) { /* => remaining fuel or <0 on failure */
obj h; int i, n; loop: assert(fuel > 0); if (x == y) return fuel-1;
if (!x || !y || notaptr(x) || notaptr(y) || notobjptr(x) || notobjptr(y)) return -1;
if ((h = objptr_from_obj(x)[-1]) != objptr_from_obj(y)[-1]) return -1;
if (h == (obj)FLONUM_NTAG) return flonum_from_obj(x) == flonum_from_obj(y) ? fuel-1 : -1;
if (h == (obj)STRING_NTAG) return strcmp(stringchars(x), stringchars(y)) == 0 ? fuel-1 : -1;
if (h == (obj)BYTEVECTOR_NTAG) return bytevectoreq(bytevectordata(x), bytevectordata(y)) ? fuel-1 : -1;
if (isaptr(h) || !(n = size_from_obj(h)) || hblkref(x, 0) != hblkref(y, 0)) return -1;
if (--fuel == 0) return 0; /* we must spend fuel while comparing objects themselves */
for (i = 1; i < n-1; ++i) if ((fuel = boundequal(hblkref(x, i), hblkref(y, i), fuel)) <= 0) return fuel;
if (i == n-1) { x = hblkref(x, i); y = hblkref(y, i); goto loop; } else return fuel;
}")
; circularity
(%definition "extern int iscircular(obj x);")
(%localdef "int iscircular(obj x) {
if (!x || notaptr(x) || notobjptr(x)) return 0;
else { stab_t *p = staballoc(); stabcircular(x, p); p = stabend(p); stabfree(p); return p != NULL; }
}")
(define-inline (circular? x)
(%prim "bool(iscircular(obj_from_$arg))" x))
; 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) {
stab_t *p; obj *r; size_t i; int res = boundequal(x, y, 500);
if (res != 0) return res > 0; /* small/non-circular/easy */
p = staballoc(); stabshared(x, p); stabshared(y, p);
r = p->r = cxm_cknull(calloc(p->sz, sizeof(obj)), \"isequal\");
for (i = 0; i < p->sz; ++i) if (p->v[i] & ~1) r[i] = -1;
res = stabequal(x, y, p); stabfree(p); return res;
}")
(%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 (meml x l)
(%prim? "obj(ismember(obj_from_$arg, obj_from_$arg))" x l))
(define (%member x l eq)
(and (pair? l) (if (eq x (car l)) l (%member x (cdr l) eq))))
(define-syntax member
(syntax-rules ()
[(_ x l) (meml x l)]
[(_ x l eq) (%member x l eq)]
[_ %residual-member]))
(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 (assl x l)
(%prim? "obj(isassoc(obj_from_$arg, obj_from_$arg))" x l))
(define (%assoc x al eq)
(and (pair? al) (if (eq x (caar al)) (car al) (%assoc x (cdr al) eq))))
(define-syntax assoc
(syntax-rules ()
[(_ x al) (assl x al)]
[(_ x al eq) (%assoc x al eq)]
[_ %residual-assoc]))
; 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
(%localdef "/* internal recursive write procedure */
typedef struct { stab_t *pst; int disp; cxtype_oport_t *vt; void *pp; } wenv_t;
static void wrc(int c, wenv_t *e) { e->vt->putch(c, e->pp); }
static void wrs(char *s, wenv_t *e) {
cxtype_oport_t *vt = e->vt; void *pp = e->pp;
assert(vt); while (*s) vt->putch(*s++, pp);
}
static int cleansymname(char *s) {
char *inits = \"abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ!$%&*/:<=>?@^_~\";
char *subss = \"abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ!$%&*/:<=>?@^_~0123456789.@+-\";
if (s[0] == 0 || s[strspn(s, subss)] != 0) return 0; else if (strchr(inits, s[0])) return 1;
else if (s[0] == '+' || s[0] == '-') return s[1] == 0 || (s[1] == '.' && s[2] && !isdigit(s[2])) || !isdigit(s[1]);
else return s[0] == '.' && s[1] && !isdigit(s[1]);
}
static void wrdatum(obj o, wenv_t *e) {
long ref;
tail: ref = stabref(o, e->pst, 1); /* update ref after access */
if (ref < 0) { char buf[30]; sprintf(buf, \"#%ld#\", -ref-1); wrs(buf, e); return; }
if (ref > 0) { char buf[30]; sprintf(buf, \"#%ld=\", +ref-1); wrs(buf, e); }
if (is_bool_obj(o)) {
wrs(bool_from_obj(o) ? \"#t\" : \"#f\", e);
} else if (is_fixnum_obj(o)) {
char buf[30]; sprintf(buf, \"%ld\", fixnum_from_obj(o)); wrs(buf, e);
} else if (is_flonum_obj(o)) {
char buf[30], *s; double d = flonum_from_obj(o); sprintf(buf, \"%.15g\", d);
for (s = buf; *s != 0; s++) if (strchr(\".eE\", *s)) break;
if (d != d) strcpy(buf, \"+nan.0\"); else if (d <= -HUGE_VAL) strcpy(buf, \"-inf.0\");
else if (d >= HUGE_VAL) strcpy(buf, \"+inf.0\"); else if (*s == 'E') *s = 'e';
else if (*s == 0) { *s++ = '.'; *s++ = '0'; *s = 0; }
wrs(buf, e);
} else if (iseof(o)) {
wrs(\"#<eof>\", e);
} else if (isiport(o)) {
char buf[60]; sprintf(buf, \"#<%s>\", ckiportvt(o)->tname); wrs(buf, e);
} else if (isoport(o)) {
char buf[60]; sprintf(buf, \"#<%s>\", ckoportvt(o)->tname); wrs(buf, e);
} else if (issymbol(o)) {
char *s = symbolname(getsymbol(o));
if (e->disp || cleansymname(s)) wrs(s, e);
else {
wrc('|', e);
while (*s) {
int c = *s++;
switch(c) {
case '|': wrs(\"\\\\|\", e); break;
case '\\\\': wrs(\"\\\\\\\\\", e); break;
default: wrc(c, e); break;
}
}
wrc('|', e);
}
} else if (isnull(o)) {
wrs(\"()\", e);
} else if (ispair(o)) {
wrc('(', e); wrdatum(car(o), e);
while (ispair(cdr(o)) && !stabref(cdr(o), e->pst, 0)) { wrc(' ', e); o = cdr(o); wrdatum(car(o), e); }
if (!isnull(cdr(o))) { wrs(\" . \", e); wrdatum(cdr(o), e); }
wrc(')', e);
} else if (is_char_obj(o)) {
int c = char_from_obj(o);
if (e->disp) wrc(c, e);
else switch(c) {
case 0x00: wrs(\"#\\\\null\", e); break;
case 0x07: wrs(\"#\\\\alarm\", e); break;
case 0x08: wrs(\"#\\\\backspace\", e); break;
case 0x7f: wrs(\"#\\\\delete\", e); break;
case 0x1b: wrs(\"#\\\\escape\", e); break;
case '\\t': wrs(\"#\\\\tab\", e); break;
case '\\n': wrs(\"#\\\\newline\", e); break;
case '\\r': wrs(\"#\\\\return\", e); break;
case ' ': wrs(\"#\\\\space\", e); break;
default: wrs(\"#\\\\\", e); wrc(c, e); break;
}
} else if (isstring(o)) {
char *s = stringchars(o);
if (e->disp) wrs(s, e);
else {
wrc('\\\"', e);
while (*s) {
int c = *s++;
switch(c) {
case '\\\"': wrs(\"\\\\\\\"\", e); break;
case '\\\\': wrs(\"\\\\\\\\\", e); break;
default: wrc(c, e); break;
}
}
wrc('\\\"', e);
}
} else if (isvector(o)) {
int i, n = vectorlen(o);
wrs(\"#(\", e);
for (i = 0; i < n; ++i) {
if (i) wrc(' ', e); wrdatum(vectorref(o, i), e);
}
wrc(')', e);
} else if (isbytevector(o)) {
int i, n = bytevectorlen(o);
wrs(\"#u8(\", e);
for (i = 0; i < n; ++i) {
char buf[30]; sprintf(buf, \"%d\", *bytevectorref(o, i));
if (i) wrc(' ', e); wrs(buf, e);
}
wrc(')', e);
} else if (isbox(o)) {
wrs(\"#&\", e); o = boxref(o); goto tail;
} else if (isrecord(o)) {
int i, n = recordlen(o);
wrs(\"#<record \", e);
wrdatum(recordrtd(o), e); // TODO: no need to show as shared!
for (i = 0; i < n; ++i) {
wrc(' ', e); wrdatum(recordref(o, i), e);
}
wrc('>', e);
} else if (isprocedure(o)) {
char buf[60]; sprintf(buf, \"#<procedure @%p>\", objptr_from_obj(o)); wrs(buf, e);
} else if (isvoid(o)) {
wrs(\"#<void>\", e);
} else {
wrs(\"#<unknown>\", e);
}
}")
(%definition "/* S-expression writers */
extern void oportputsimple(obj x, obj p, int disp);
extern void oportputcircular(obj x, obj p, int disp);
extern void oportputshared(obj x, obj p, int disp);")
(%localdef "/* S-expression writers */
void oportputsimple(obj x, obj p, int disp) {
wenv_t e; e.pst = NULL; e.disp = disp; e.vt = oportvt(p); e.pp = oportdata(p);
wrdatum(x, &e);
}
void oportputcircular(obj x, obj p, int disp) {
wenv_t e; e.pst = staballoc(); e.disp = disp; e.vt = oportvt(p); e.pp = oportdata(p);
stabcircular(x, e.pst); e.pst = stabend(e.pst);
wrdatum(x, &e);
stabfree(e.pst);
}
void oportputshared(obj x, obj p, int disp) {
wenv_t e; e.pst = staballoc(); e.disp = disp; e.vt = oportvt(p); e.pp = oportdata(p);
stabshared(x, e.pst); e.pst = stabend(e.pst);
wrdatum(x, &e);
stabfree(e.pst);
}")
(define-syntax write-simple
(syntax-rules ()
[(_ x) (%prim?! "void(oportputsimple(obj_from_$arg, obj_from_$arg, 0))" x (current-output-port))]
[(_ x p) (%prim?! "void(oportputsimple(obj_from_$arg, obj_from_$arg, 0))" x p)]
[_ %residual-write-simple]))
(define-syntax write-shared
(syntax-rules ()
[(_ x) (%prim?! "void(oportputshared(obj_from_$arg, obj_from_$arg, 0))" x (current-output-port))]
[(_ x p) (%prim?! "void(oportputshared(obj_from_$arg, obj_from_$arg, 0))" x p)]
[_ %residual-write-shared]))
(define-syntax write
(syntax-rules ()
[(_ x) (%prim?! "void(oportputcircular(obj_from_$arg, obj_from_$arg, 0))" x (current-output-port))]
[(_ x p) (%prim?! "void(oportputcircular(obj_from_$arg, obj_from_$arg, 0))" x p)]
[_ %residual-write]))
(define-syntax display
(syntax-rules ()
[(_ x) (%prim?! "void(oportputcircular(obj_from_$arg, obj_from_$arg, 1))" x (current-output-port))]
[(_ x p) (%prim?! "void(oportputcircular(obj_from_$arg, obj_from_$arg, 1))" x 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 (simple-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 port simple?)
(define-syntax r-error
(syntax-rules () [(_ p msg a ...) (read-error msg a ... 'port: p)])) ; see read-error below
(define shared '())
(define (make-shared-ref loc) (lambda () (unbox loc)))
(define (shared-ref? form) (procedure? form))
(define (patch-ref! form) (if (procedure? form) (patch-ref! (form)) form))
(define (patch-shared! form)
(cond [(pair? form)
(if (procedure? (car form))
(set-car! form (patch-ref! (car form)))
(patch-shared! (car form)))
(if (procedure? (cdr form))
(set-cdr! form (patch-ref! (cdr form)))
(patch-shared! (cdr form)))]
[(vector? form)
(let loop ([i 0])
(when (fx<? i (vector-length form))
(let ([fi (vector-ref form i)])
(if (procedure? fi)
(vector-set! form i (patch-ref! fi))
(patch-shared! fi)))
(loop (fx+ i 1))))]
[(box? form)
(if (procedure? (unbox form))
(set-box! form (patch-shared! (unbox form)))
(patch-shared! (unbox form)))]))
(define (patch-shared form) (patch-shared! form) form)
(define reader-token-marker #f)
(define close-paren #f)
(define close-bracket #f)
(define dot #f)
(define (let ([rtm (list 'reader-token)])
(set! reader-token-marker rtm)
(set! close-paren (cons rtm "right parenthesis"))
(set! close-bracket (cons rtm "right bracket"))
(set! dot (cons rtm "\" . \""))))
(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 #\\)
(let ([e (sub-read-strsym-char-escape p 'string)])
(loop (if e (cons e l) l)))]
[(char=? c #\") (list->string (reverse! l))]
[else (loop (cons c l))])))]
[(char=? c #\|)
(let loop ([l '()])
(let ([c (read-char p)])
(cond [(eof-object? c)
(r-error p "end of file within a |symbol|")]
[(char=? c #\\)
(let ([e (sub-read-strsym-char-escape p 'symbol)])
(loop (if e (cons e l) l)))]
[(char=? c #\|) (string->symbol (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 #")]
[(or (char-ci=? c #\t) (char-ci=? c #\f))
(let ([name (sub-read-carefully p)])
(case name [(t true) #t] [(f false) #f]
[else (r-error p "unexpected name after #" name)]))]
[(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 #\u)
(read-char p)
(if (and (eq? (read-char p) #\8) (eq? (read-char p) #\())
(list->bytevector (sub-read-byte-list p))
(r-error p "invalid bytevector syntax"))]
[(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
[(null) (integer->char #x00)]
[(space) #\space]
[(alarm) #\alarm]
[(backspace) #\backspace]
[(delete) (integer->char #x7F)] ; todo: support by SFC
[(escape) (integer->char #x1B)]
[(tab) #\tab]
[(newline linefeed) #\newline]
[(vtab) #\vtab]
[(page) #\page]
[(return) #\return]
[else (r-error p "unknown #\\ name" name)])))]
[else (read-char p) c]))]
[(char-numeric? c)
(when simple? (r-error p "#N=/#N# notation is not allowed in this mode"))
(let loop ([l '()])
(let ([c (read-char p)])
(cond [(eof-object? c)
(r-error p "end of file within a #N notation")]
[(char-numeric? c)
(loop (cons c l))]
[(char=? c #\#)
(let* ([s (list->string (reverse! l))] [n (string->number s)])
(cond [(and (fixnum? n) (assq n shared)) => cdr]
[else (r-error "unknown #n# reference:" s)]))]
[(char=? c #\=)
(let* ([s (list->string (reverse! l))] [n (string->number s)])
(cond [(not (fixnum? n)) (r-error "invalid #n= reference:" s)]
[(assq n shared) (r-error "duplicate #n= tag:" n)])
(let ([loc (box #f)])
(set! shared (cons (cons n (make-shared-ref loc)) shared))
(let ([form (sub-read-carefully p)])
(cond [(shared-ref? form) (r-error "#n= has another label as target" s)]
[else (set-box! loc form) form]))))]
[else (r-error p "invalid terminator for #N notation")])))]
[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-byte-list p)
(let recur ([form (sub-read p)])
(cond [(eof-object? form)
(r-error p "eof inside bytevector")]
[(eq? form close-paren) '()]
[(reader-token? form)
(r-error p "error inside bytevector --" (cdr form))]
[(or (not (fixnum? form)) (fx<? form 0) (fx>? form 255))
(r-error p "invalid byte inside bytevector --" form)]
[else (cons form (recur (sub-read p)))])))
(define (sub-read-strsym-char-escape p what)
(let ([c (read-char p)])
(if (eof-object? c)
(r-error p "end of file within a" what))
(cond [(or (char=? c #\\) (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)]
[(and (eq? what 'string) (char-whitespace? c))
(let loop ([gotnl (char=? c #\newline)] [nc (peek-char p)])
(cond [(or (eof-object? nc) (not (char-whitespace? nc)))
(if gotnl #f (r-error p "no newline in line ending escape"))]
[(and gotnl (char=? nc #\newline)) #f]
[else (read-char p) (loop (or gotnl (char=? nc #\newline)) (peek-char p))]))]
[else (r-error p "invalid char escape in" what ': 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 (suspect-number-or-symbol-peculiar? hash? c l s)
(cond [(or hash? (char-numeric? c)) #f]
[(or (string-ci=? s "+i") (string-ci=? s "-i")) #f]
[(or (string-ci=? s "+nan.0") (string-ci=? s "-nan.0")) #f]
[(or (string-ci=? s "+inf.0") (string-ci=? s "-inf.0")) #f]
[(or (char=? c #\+) (char=? c #\-))
(cond [(null? (cdr l)) #t]
[(char=? (cadr l) #\.) (and (pair? (cddr l)) (not (char-numeric? (caddr l))))]
[else (not (char-numeric? (cadr l)))])]
[else (and (char=? c #\.) (pair? (cdr l)) (not (char-numeric? (cadr l))))]))
(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]
[(suspect-number-or-symbol-peculiar? hash? c l s) (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)])))
; body of %read
(let ([form (sub-read port)])
(if (not (reader-token? form))
(if (null? shared) form (patch-shared form))
(r-error port "unexpected token:" (cdr form)))))
(define-syntax read
(syntax-rules ()
[(_) (%read (current-input-port) #f)]
[(_ p) (%read p #f)]
[_ %residual-read]))
(define-syntax read-simple
(syntax-rules ()
[(_) (%read (current-input-port) #t)]
[(_ p) (%read p #t)]
[_ %residual-read-simple]))
; file system
(define (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 (delete-file fn)
(unless (%prim?! "{ /* delete-file */
int res = remove(stringchars(obj_from_$arg));
$return bool(res == 0); }" fn)
(file-error "cannot delete file:" fn)))
(define (rename-file fnold fnnew) ; not in r7rs
(unless (%prim?! "{ /* rename-file */
int res = rename(stringchars(obj_from_$arg), stringchars(obj_from_$arg));
$return bool(res == 0); }" fnold fnnew)
(file-error "cannot rename file:" 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)))))
; exceptions and errors
(define-record-type <error-object>
(error-object kind message irritants)
error-object?
(kind error-object-kind)
(message error-object-message)
(irritants error-object-irritants))
(define (error msg . args)
(raise (error-object #f msg args)))
(define current-exception-handler
(make-parameter
(letrec
([default-handler
(case-lambda
[() default-handler] ;this one its own parent
[(obj)
(if (error-object? obj)
(apply simple-error (error-object-kind obj) (error-object-message obj) (error-object-irritants obj))
(simple-error #f "unhandled exception" obj))])])
default-handler)))
(define (with-exception-handler handler thunk)
(let ([eh (current-exception-handler)])
(parameterize ([current-exception-handler (case-lambda [() eh] [(obj) (handler obj)])])
(thunk))))
(define (raise obj)
(let ([eh (current-exception-handler)])
(parameterize ([current-exception-handler (eh)])
(eh obj)
(raise (error-object 'raise "exception handler returned" (list eh obj))))))
(define (raise-continuable obj)
(let ([eh (current-exception-handler)])
(parameterize ([current-exception-handler (eh)])
(eh obj))))
(define-inline (abort) (%prim! "void(exit(1))"))
(define (reset) (%prim! "void(exit(1))"))
(define (set-reset-handler! fn) (set! reset fn))
(define-syntax guard
(letrec-syntax
([guard-aux
(syntax-rules (else =>)
[(guard-aux reraise (else result1 result2 ...))
(begin result1 result2 ...)]
[(guard-aux reraise (test => result))
(let ([temp test]) (if temp (result temp) reraise))]
[(guard-aux reraise (test => result) clause1 clause2 ...)
(let ([temp test])
(if temp
(result temp)
(guard-aux reraise clause1 clause2 ...)))]
[(guard-aux reraise (test)) (or test reraise)]
[(guard-aux reraise (test) clause1 clause2 ...)
(let ([temp test])
(if temp temp (guard-aux reraise clause1 clause2 ...)))]
[(guard-aux reraise (test result1 result2 ...))
(if test (begin result1 result2 ...) reraise)]
[(guard-aux reraise (test result1 result2 ...) clause1 clause2 ...)
(if test
(begin result1 result2 ...)
(guard-aux reraise clause1 clause2 ...))])])
(syntax-rules ()
[(guard (var clause ...) e1 e2 ...)
((call/cc
(lambda (guard-k)
(with-exception-handler
(lambda (condition)
((call/cc
(lambda (handler-k)
(guard-k
(lambda ()
(let ([var condition])
(guard-aux
(handler-k
(lambda ()
(raise-continuable condition)))
clause
...))))))))
(lambda ()
(call-with-values
(lambda () e1 e2 ...)
(lambda args
(guard-k (lambda () (apply values args))))))))))])))
(define (read-error msg . args)
(raise (error-object 'read msg args)))
(define (read-error? obj)
(and (error-object? obj) (eq? (error-object-kind obj) 'read)))
(define (file-error msg . args)
(raise (error-object 'file msg args)))
(define (file-error? obj)
(and (error-object? obj) (eq? (error-object-kind obj) 'file)))
; time
(%include <time.h>)
(define-inline (current-jiffy)
(%prim*! "flonum($live, clock())"))
(define-inline (jiffies-per-second)
(%prim* "flonum($live, CLOCKS_PER_SEC)"))
(define-inline (current-second)
(%prim* "flonum($live, difftime(time(NULL), 0)+37.0)"))
; miscellaneous / system
(define emergency-exit
(case-lambda ; exits no matter what
[() (%prim! "void(exit(0))")]
[(n) (cond [(eq? n #t) (%prim! "void(exit(0))")]
[(fixnum? n) (%prim! "void(exit(fixnum_from_$arg))" n)]
[else (%prim! "void(exit(1))")])]
[args (%prim! "void(exit(1))")]))
(define exit
(let ([exit-ds *current-dynamic-state*])
(lambda args
(dynamic-state-reroot! exit-ds)
(apply emergency-exit args))))
(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))
; procedures requiring call-with-values / values
(define (truncate/ x y)
(values (truncate-quotient x y) (truncate-remainder x y)))
(define (floor/ x y)
(values (floor-quotient x y) (floor-remainder x y)))
(define (exact-integer-sqrt x)
(let ([r (fxsqrt x)])
(values r (- x (* r r)))))
(define (call-with-port port proc)
(call-with-values (lambda () (proc port))
(lambda vals (close-port port) (apply values vals))))
; procedures of variable arity (plain and making use of case-lambda)
(define string->list
(case-lambda
[(str) (substring->list str 0 (string-length str))]
[(str start) (substring->list str start (string-length str))]
[(str start end) (substring->list str start end)]))
(define string-copy
(case-lambda
[(str) (%string-copy str)]
[(str start) (substring str start (string-length str))]
[(str start end) (substring str start end)]))
(define string-copy!
(case-lambda
[(to at from) (substring-copy! to at from 0 (string-length from))]
[(to at from start) (substring-copy! to at from start (string-length from))]
[(to at from start end) (substring-copy! to at from start end)]))
(define string-fill!
(case-lambda
[(str c) (%string-fill! str c)]
[(str c start) (substring-fill! str c start (string-length str))]
[(str c start end) (substring-fill! str c start end)]))
(define vector->list
(case-lambda
[(vec) (subvector->list vec 0 (vector-length vec))]
[(vec start) (subvector->list vec start (vector-length vec))]
[(vec start end) (subvector->list vec start end)]))
(define vector->string
(case-lambda
[(vec) (subvector->string vec 0 (vector-length vec))]
[(vec start) (subvector->string vec start (vector-length vec))]
[(vec start end) (subvector->string vec start end)]))
(define string->vector
(case-lambda
[(str) (substring->vector str 0 (string-length str))]
[(str start) (substring->vector str start (string-length str))]
[(str start end) (substring->vector str start end)]))
(define vector-copy!
(case-lambda
[(to at from) (subvector-copy! to at from 0 (vector-length from))]
[(to at from start) (subvector-copy! to at from start (vector-length from))]
[(to at from start end) (subvector-copy! to at from start end)]))
(define vector-copy
(case-lambda
[(vec) (subvector vec 0 (vector-length vec))]
[(vec start) (subvector vec start (vector-length vec))]
[(vec start end) (subvector vec start end)]))
(define (%vectors-sum-length vecs)
(let loop ([vecs vecs] [l 0])
(if (null? vecs) l (loop (cdr vecs) (fx+ l (vector-length (car vecs)))))))
(define (%vectors-copy-into! to vecs)
(let loop ([vecs vecs] [i 0])
(if (null? vecs)
to
(let ([vec (car vecs)] [vecs (cdr vecs)])
(let ([len (vector-length vec)])
(subvector-copy! to i vec 0 len)
(loop vecs (fx+ i len)))))))
(define (vector-append . vecs)
(%vectors-copy-into! (make-vector (%vectors-sum-length vecs)) vecs))
(define vector-fill!
(case-lambda
[(vec x) (subvector-fill! vec x 0 (vector-length vec))]
[(vec x start) (subvector-fill! vec x start (vector-length vec))]
[(vec x start end) (subvector-fill! vec x start end)]))
(define bytevector->list
(case-lambda
[(vec) (subbytevector->list vec 0 (bytevector-length vec))]
[(vec start) (subbytevector->list vec start (bytevector-length vec))]
[(vec start end) (subbytevector->list vec start end)]))
(define bytevector-copy!
(case-lambda
[(to at from) (subbytevector-copy! to at from 0 (bytevector-length from))]
[(to at from start) (subbytevector-copy! to at from start (bytevector-length from))]
[(to at from start end) (subbytevector-copy! to at from start end)]))
(define bytevector-copy
(case-lambda
[(vec) (subbytevector vec 0 (bytevector-length vec))]
[(vec start) (subbytevector vec start (bytevector-length vec))]
[(vec start end) (subbytevector vec start end)]))
(define (%bytevectors-sum-length vecs)
(let loop ([vecs vecs] [l 0])
(if (null? vecs) l (loop (cdr vecs) (fx+ l (bytevector-length (car vecs)))))))
(define (%bytevectors-copy-into! to vecs)
(let loop ([vecs vecs] [i 0])
(if (null? vecs)
to
(let ([vec (car vecs)] [vecs (cdr vecs)])
(let ([len (bytevector-length vec)])
(subbytevector-copy! to i vec 0 len)
(loop vecs (fx+ i len)))))))
(define (bytevector-append . vecs)
(%bytevectors-copy-into! (make-bytevector (%bytevectors-sum-length vecs)) vecs))
(define (subutf8->string vec start end)
(let ([p (open-output-string)])
(write-subbytevector vec start end p)
; todo: make a single operation: get-final-output-string (can reuse cbuf?)
(let ([s (get-output-string p)]) (close-output-port p) s)))
(define utf8->string
(case-lambda
[(vec) (%prim*? "{ /* bytevector->string */
int *d = bytevectordata(obj_from_$arg);
$return obj(hpushstr($live, newstringn((char *)bvdatabytes(d), *d))); }" vec)]
[(vec start) (subutf8->string vec start (bytevector-length vec))]
[(vec start end) (subutf8->string vec start end)]))
(define (substring->utf8 str start end)
(let ([p (open-output-bytevector)])
(write-substring str start end p)
; todo: make a single operation: get-final-output-bytevector (can reuse cbuf?)
(let ([v (get-output-bytevector p)]) (close-output-port p) v)))
(define string->utf8
(case-lambda
[(str) (%prim*? "{ /* string->bytevector */
int *d = stringdata(obj_from_$arg);
$return obj(hpushu8v($live, newbytevector((unsigned char *)sdatachars(d), *d))); }" str)]
[(str start) (substring->utf8 str start (string-length str))]
[(str start end) (substring->utf8 str start end)]))
(define read-string!
(case-lambda
[(str) (read-substring! str 0 (string-length str) (current-input-port))]
[(str p) (read-substring! str 0 (string-length str) p)]
[(str p start) (read-substring! str start (string-length str) p)]
[(str p start end) (read-substring! str start end p)]))
(define read-string
(case-lambda
[(k) (read-substring k (current-input-port))]
[(k p) (read-substring k p)]))
(define read-bytevector!
(case-lambda
[(vec) (read-subbytevector! vec 0 (bytevector-length vec) (current-input-port))]
[(vec p) (read-subbytevector! vec 0 (bytevector-length vec) p)]
[(vec p start) (read-subbytevector! vec start (bytevector-length vec) p)]
[(vec p start end) (read-subbytevector! vec start end p)]))
(define read-bytevector
(case-lambda
[(k) (read-subbytevector k (current-input-port))]
[(k p) (read-subbytevector k p)]))
; 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-boolean=? (cmp-reducer boolean=?))
(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 nullary-unary-binary-adaptor
(syntax-rules ()
[(_ f)
(lambda args
(if (null? args) (f) (if (null? (cdr args)) (f (car args)) (f (car args) (cadr args)))))]))
(define-syntax unary-binary-adaptor
(syntax-rules ()
[(_ f)
(lambda (x . args)
(if (null? args) (f x) (f x (car args))))]))
(define-syntax unary-binary-ternary-adaptor
(syntax-rules ()
[(_ f)
(lambda (x . args)
(if (null? args) (f x) (if (null? (cdr args)) (f x (car args)) (f x (car args) (cadr args)))))]))
(define-syntax unary-binary-ternary-quaternary-adaptor
(syntax-rules ()
[(_ f)
(lambda (x . args)
(if (null? args) (f x) (if (null? (cdr args)) (f x (car args))
(if (null? (cddr args)) (f x (car args) (cadr args)) (f x (car args) (cadr args) (caddr args))))))]))
(define-syntax binary-ternary-adaptor
(syntax-rules ()
[(_ f)
(lambda (x y . args)
(if (null? args) (f x y) (f x y (car args))))]))
(define-syntax binary-ternary-quaternary-adaptor
(syntax-rules ()
[(_ f)
(lambda (x y . args)
(if (null? args) (f x y)
(if (null? (cdr args)) (f x y (car args)) (f x y (car args) (cadr args)))))]))
(define %residual-log (unary-binary-adaptor log))
(define %residual-flatan (unary-binary-adaptor flatan))
(define %residual-atan (unary-binary-adaptor atan))
(define %residual-member (binary-ternary-adaptor member))
(define %residual-assoc (binary-ternary-adaptor assoc))
(define (%residual-map p l . l*)
(if (null? l*)
(let loop ([l l] [r '()])
(if (pair? l) (loop (cdr l) (cons (p (car l)) r)) (reverse! r)))
(let loop ([l* (cons l l*)] [r '()])
(if (let lp ([l* l*]) (or (null? l*) (and (pair? (car l*)) (lp (cdr l*)))))
(loop (map cdr l*) (cons (apply p (map car l*)) r))
(reverse! r)))))
(define (%residual-for-each p l . l*)
(if (null? l*)
(let loop ([l l]) (if (pair? l) (begin (p (car l)) (loop (cdr l)))))
(let loop ([l* (cons l l*)])
(if (let lp ([l* l*]) (or (null? l*) (and (pair? (car l*)) (lp (cdr l*)))))
(begin (apply p (map car l*)) (loop (map cdr l*)))))))
(define (string-map p s . s*)
(if (null? s*)
(let* ([len (string-length s)] [res (make-string len)])
(do ([i 0 (fx+ i 1)]) [(fx>=? i len) res]
(string-set! res i (p (string-ref s i)))))
(list->string (apply map p (map string->list (cons s s*))))))
(define (vector-map p v . v*)
(if (null? v*)
(let* ([len (vector-length v)] [res (make-vector len)])
(do ([i 0 (fx+ i 1)]) [(fx>=? i len) res]
(vector-set! res i (p (vector-ref v i)))))
(list->vector (apply map p (map vector->list (cons v v*))))))
(define (string-for-each p s . s*)
(if (null? s*)
(let ([len (string-length s)])
(do ([i 0 (fx+ i 1)]) [(fx>=? i len)] (p (string-ref s i))))
(apply for-each p (map string->list (cons s s*)))))
(define (vector-for-each p v . v*)
(if (null? v*)
(let ([len (vector-length v)])
(do ([i 0 (fx+ i 1)]) [(fx>=? i len)] (p (vector-ref v i))))
(apply for-each p (map vector->list (cons v v*)))))
(define-syntax append-reducer
(syntax-rules ()
[(_ f s)
(lambda args
(let loop ([args args])
(cond [(null? args) s]
[(null? (cdr args)) (car args)]
[else (f (car args) (loop (cdr args)))])))]))
(define %residual-char=? (cmp-reducer char=?))
(define %residual-char<? (cmp-reducer char<?))
(define %residual-char>? (cmp-reducer char>?))
(define %residual-char<=? (cmp-reducer char<=?))
(define %residual-char>=? (cmp-reducer char>=?))
(define %residual-char-ci=? (cmp-reducer char-ci=?))
(define %residual-char-ci<? (cmp-reducer char-ci<?))
(define %residual-char-ci>? (cmp-reducer char-ci>?))
(define %residual-char-ci<=? (cmp-reducer char-ci<=?))
(define %residual-char-ci>=? (cmp-reducer char-ci>=?))
(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-string=? (cmp-reducer string=?))
(define %residual-string<? (cmp-reducer string<?))
(define %residual-string>? (cmp-reducer string>?))
(define %residual-string<=? (cmp-reducer string<=?))
(define %residual-string>=? (cmp-reducer string>=?))
(define %residual-string-ci=? (cmp-reducer string-ci=?))
(define %residual-string-ci<? (cmp-reducer string-ci<?))
(define %residual-string-ci>? (cmp-reducer string-ci>?))
(define %residual-string-ci<=? (cmp-reducer string-ci<=?))
(define %residual-string-ci>=? (cmp-reducer string-ci>=?))
(define %residual-make-vector (unary-binary-adaptor make-vector))
(define (%residual-vector . l)
(list->vector l))
(define %residual-make-bytevector (unary-binary-adaptor make-bytevector))
(define (%residual-bytevector . l)
(list->bytevector l))
(define (%residual-list . l) l)
(define %residual-make-list (unary-binary-adaptor make-list))
(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-record? (unary-binary-adaptor record?))
(define %residual-number->string (unary-binary-adaptor number->string))
(define %residual-string->number (unary-binary-adaptor string->number))
(define %residual-symbol=? (cmp-reducer symbol=?))
(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-current-input-port (nullary-unary-binary-adaptor current-input-port))
(define %residual-current-output-port (nullary-unary-binary-adaptor current-output-port))
(define %residual-current-error-port (nullary-unary-binary-adaptor current-error-port))
(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-read-line (nullary-unary-adaptor read-line))
(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-ternary-quaternary-adaptor write-string))
(define %residual-newline (nullary-unary-adaptor newline))
(define %residual-flush-output-port (nullary-unary-adaptor flush-output-port))
(define %residual-read-u8 (nullary-unary-adaptor read-u8))
(define %residual-peek-u8 (nullary-unary-adaptor peek-u8))
(define %residual-u8-ready? (nullary-unary-adaptor u8-ready?))
(define %residual-write-u8 (unary-binary-adaptor write-u8))
(define %residual-write-bytevector (unary-binary-ternary-quaternary-adaptor write-bytevector))
(define %residual-write-simple (unary-binary-adaptor write-simple))
(define %residual-write-shared (unary-binary-adaptor write-shared))
(define %residual-write (unary-binary-adaptor write))
(define %residual-display (unary-binary-adaptor display))
(define %residual-read (nullary-unary-adaptor read))
(define %residual-read-simple (nullary-unary-adaptor read-simple))
(define %residual-exit (nullary-unary-adaptor exit))
;------------------------------------------------------------------------------
; features provided by this interpreter
(define (features) '(r7rs exact-closed siof siof-1.0.2))
;------------------------------------------------------------------------------
; assorted utils
(define-syntax andmap
(letrec-syntax
([and-loop
(syntax-rules ()
[(_ ([l e] ...) f)
(let loop ([l e] ...)
(or (null? l) ...
(and (f (car l) ...)
(loop (cdr l) ...))))]
[(_ (b ...) f l . ls)
(and-loop (b ... [id l]) f . ls)])])
(syntax-rules ()
[(_ f l ...)
(and-loop () f l ...)])))
(define-syntax ormap
(letrec-syntax
([or-loop
(syntax-rules ()
[(_ ([l e] ...) f)
(let loop ([l e] ...)
(and (not (null? l)) ...
(or (f (car l) ...)
(loop (cdr l) ...))))]
[(_ (b ...) f l . ls)
(or-loop (b ... [id l]) f . ls)])])
(syntax-rules ()
[(_ f l ...)
(or-loop () f l ...)])))
(define (append* lst)
(cond [(null? lst) '()]
[(null? (cdr lst)) (car lst)]
[else (append (car lst) (append* (cdr lst)))]))
(define (string-append* l)
(apply string-append l))
(define (apply-map-list lst)
(let loop ([lst lst] [res '()])
(if (ormap null? lst)
(reverse res)
(loop (map cdr lst) (cons (map car lst) res)))))
(define (pairwise-andmap pred? lst)
(or (null? lst)
(let ([x (car lst)] [r (cdr lst)])
(or (null? r)
(and (pred? x (car r))
(pairwise-andmap pred? r))))))
(define (sexp-match? pat x)
(or (eq? pat '*)
(and (eq? pat '<symbol>) (symbol? x))
(and (eq? pat '<string>) (string? x))
(eq? x pat)
(and (pair? pat)
(cond [(and (eq? (car pat) '...)
(pair? (cdr pat))
(null? (cddr pat)))
(eq? x (cadr pat))]
[(and (pair? (cdr pat))
(eq? (cadr pat) '...)
(null? (cddr pat)))
(let ([pat (car pat)])
(if (eq? pat '*)
(list? x)
(let loop ([lst x])
(or (null? lst)
(and (pair? lst)
(sexp-match? pat (car lst))
(loop (cdr lst)))))))]
[else
(and (pair? x)
(sexp-match? (car pat) (car x))
(sexp-match? (cdr pat) (cdr x)))]))))
(define-syntax sexp-case
(syntax-rules (else)
[(_ (key ...) clauses ...)
(let ([atom-key (key ...)])
(sexp-case atom-key clauses ...))]
[(_ key (else result1 result2 ...))
(begin result1 result2 ...)]
[(_ key (pat result1 result2 ...))
(if (sexp-match? 'pat key)
(begin result1 result2 ...))]
[(_ key (pat result1 result2 ...) clause clauses ...)
(if (sexp-match? 'pat key)
(begin result1 result2 ...)
(sexp-case key clause clauses ...))]))
(define (read-code-sexp port)
; for now, we will just use read with no support for circular structures
(read-simple port))
;------------------------------------------------------------------------------
; warnings and errors
; expansion-time
(define-syntax x-error
(syntax-rules () [(_ r a ...)
(simple-error 'macroexpander r (unwrap-vecs a) ...)]))
(define-syntax x-error*
(syntax-rules () [(_ r args)
(apply simple-error 'macroexpander r (map unwrap-vecs args))]))
; compile-time
(define-syntax c-error
(syntax-rules () [(_ r a ...) (simple-error 'compiler r a ...)]))
(define (c-warning . args)
(let ([ep (current-error-port)])
;(newline ep)
(print-error-message "; warning" args ep)))
; run-time
(define (r-error msg . args)
(let loop ([args args] [a* '()])
(cond [(null? args) (apply simple-error #f msg (reverse! a*))]
[(procedure? (car args))
(let ([name (reverse-global-lookup (car args))])
(if name
(loop (cdr args) (cons (list name) (cons (car args) a*)))
(loop (cdr args) (cons (car args) a*))))]
[else (loop (cdr args) (cons (car args) a*))])))
;------------------------------------------------------------------------------
; path and file name resolution
(define (path-strip-directory filename)
(let loop ([l (reverse (string->list filename))] [r '()])
(cond [(null? l) (list->string r)]
[(memv (car l) '(#\\ #\/ #\:)) (list->string r)]
[else (loop (cdr l) (cons (car l) r))])))
(define (path-directory filename)
(let loop ([l (reverse (string->list filename))])
(cond [(null? l) ""]
[(memv (car l) '(#\\ #\/ #\:)) (list->string (reverse l))]
[else (loop (cdr l))])))
(define (path-strip-extension filename) ;; improved
(let loop ([l (reverse (string->list filename))])
(cond [(null? l) filename]
[(eqv? (car l) #\.) (list->string (reverse (cdr l)))]
[(memv (car l) '(#\\ #\/ #\:)) filename]
[else (loop (cdr l))])))
#;(define (path-extension filename)
(let loop ([l (reverse (string->list filename))] [r '()])
(cond [(null? l) ""]
[(memv (car l) '(#\\ #\/ #\:)) ""]
[(eqv? (car l) #\.) (list->string (cons #\. r))]
[else (loop (cdr l) (cons (car l) r))])))
(define (base-path-separator basepath)
(let ([l (reverse (string->list basepath))])
(cond [(null? l) #f]
[(memv (car l) '(#\\ #\/)) (car l)]
[else #f])))
(define (path-relative? filename)
(let ([l (string->list filename)])
(cond [(null? l) #f]
[(memv (car l) '(#\\ #\/)) #f]
[(and (> (length l) 3) (char-alphabetic? (car l)) (eqv? (cadr l) #\:) (eqv? (caddr l) #\\)) #f]
[else #t])))
(define (file-resolve-relative-to-base-path filename basepath)
(if (and (path-relative? filename) (base-path-separator basepath))
(string-append basepath filename) ; leading . and .. to be resolved by OS
filename))
; hacks for relative file name resolution
(define *current-file-stack* '())
(define (current-file) ;=> filename of #f
(and (pair? *current-file-stack*) (car *current-file-stack*)))
(define (with-current-file filename thunk)
(dynamic-wind
(lambda () (set! *current-file-stack* (cons filename *current-file-stack*)))
thunk
(lambda () (set! *current-file-stack* (cdr *current-file-stack*)))))
(define (file-resolve-relative-to-current filename) ; => resolved or original filename
(if (path-relative? filename)
(let ([cf (current-file)])
(if cf (file-resolve-relative-to-base-path filename (path-directory cf)) filename))
filename))
;------------------------------------------------------------------------------
; library names and library file lookup
(define (listname-segment->string s)
(cond [(symbol? s) (symbol->string s)]
[(number? s) (number->string s)]
[(string? s) s]
[else (c-error "invalid symbolic file name element" s)]))
(define modname-separator "_")
(define (listname->modname listname)
(define sep modname-separator)
(let loop ([l listname] [r '()])
(if (pair? l)
(loop (cdr l)
(if (null? r)
(cons (listname-segment->string (car l)) r)
(cons (listname-segment->string (car l)) (cons sep r))))
(string-append* (reverse r)))))
(define (listname->path listname basepath ext)
(define sep
(let ([sc (base-path-separator basepath)])
(if sc (string sc) (c-error "library path does not end in separator" basepath))))
(let loop ([l listname] [r '()])
(if (pair? l)
(loop (cdr l)
(if (null? r)
(cons (listname-segment->string (car l)) r)
(cons (listname-segment->string (car l)) (cons sep r))))
(file-resolve-relative-to-base-path (string-append* (reverse (cons ext r))) basepath))))
; hacks for locating library files
(define *library-path-list* '())
(define (add-library-path! path)
(if (base-path-separator path)
(set! *library-path-list* (append *library-path-list* (list path)))
(c-error "library path should end in directory separator" path)))
(define (find-library-path libname) ;=> name of existing .sld file or #f
(let loop ([l *library-path-list*])
(if (null? l)
#f
(let ([p (listname->path libname (car l) ".sld")])
(if (and p (file-exists? p)) p (loop (cdr l)))))))
(define (resolve-input-file/lib-name name) ;=> path (or error is signalled)
(define filepath
(if (string? name)
(file-resolve-relative-to-current name)
(find-library-path name)))
(if (not filepath)
(if (string? name)
(c-error "cannot resolve file name to a file:" name)
(c-error "cannot resolve library name to a file:" name 'in *library-path-list*)))
(if (not (file-exists? filepath))
(c-error "cannot resolve file or library name to an existing file:" name '=> filepath))
filepath)
(define (call-with-input-file/lib name ci? proc) ;=> (proc filepath port), called while name is current-file
(let ([filepath (resolve-input-file/lib-name name)])
(with-current-file filepath
(lambda ()
(call-with-input-file filepath
(lambda (port)
(when ci? (set-port-fold-case! port #t))
(proc filepath port)))))))
(define (call-with-file/lib-sexps name ci? proc) ;=> (proc sexps), called while name is current-file
(call-with-input-file/lib name ci? ;=>
(lambda (filepath port)
(let loop ([sexps '()])
(let ([s (read-code-sexp port)])
(if (eof-object? s)
(proc (reverse! sexps))
(loop (cons s sexps))))))))
(define (for-each-file/lib-sexp proc name ci?) ; proc called while name is current-file
(call-with-input-file/lib name ci? ;=>
(lambda (filepath port)
(let loop ()
(let ([s (read-code-sexp port)])
(unless (eof-object? s) (proc s) (loop)))))))
(define (file/lib->modname name)
(cond [(and (pair? name) (list? name)) (listname->modname name)]
[(string? name) (path-strip-extension (path-strip-directory name))]
[else (c-error "illegal file or library name:" name)]))
(define (file/lib/stdin->modname name)
(if (and (string? name) (string=? name "-"))
"stdin"
(file/lib->modname name)))
; name manglers
(define (fully-qualified-name modname id)
(string->symbol (string-append modname (string-append "." (symbol->string id)))))
(define (fully-qualified-library-name lib id)
(fully-qualified-name (file/lib->modname lib) id))
;------------------------------------------------------------------------------
; macroexpander
(define (sid? sexp) (or (symbol? sexp) (renamed-sid? sexp)))
(define (renamed-sid? sexp) (and (vector? sexp) (not (= (vector-length sexp) 1)))) ;** (len is always 3)
(define (svector? sexp) (and (vector? sexp) (= 1 (vector-length sexp))))
(define (svector->list sexp) (vector-ref sexp 0))
(define (list->svector l) (vector l))
(define (make-sid name renamed-id location) (vector name renamed-id location)) ;**
(define (sid-name sid) (if (symbol? sid) sid (vector-ref sid 0)))
(define (sid-id sid) (if (symbol? sid) sid (vector-ref sid 1)))
(define (sid-location sid) (if (symbol? sid) sid (vector-ref sid 2))) ;**
(define (list1? x) (and (pair? x) (null? (cdr x))))
(define (list2? x) (and (pair? x) (list1? (cdr x))))
(define (map-vecs f x)
(define (mv2 x)
(if (vector? x)
(f x)
(and (pair? x)
(let ([a (car x)] [b (cdr x)])
(let ([a-mapped (mv2 a)])
(if a-mapped
(cons a-mapped (mv b))
(let ([b-mapped (mv2 b)])
(and b-mapped (cons a b-mapped)))))))))
(define (mv x) (or (mv2 x) x))
(mv x))
(define (wrap-vec v) (list->svector (wrap-vecs (vector->list v))))
(define (wrap-vecs input) (map-vecs wrap-vec input))
(define (unwrap-vec v-sexp)
(if (= 1 (vector-length v-sexp))
(list->vector (unwrap-vecs (svector->list v-sexp)))
(vector-ref v-sexp 0)))
(define (unwrap-vecs sexp) (map-vecs unwrap-vec sexp))
(define (make-code output) (list output))
(define (make-builtin name) (list '(builtin) name))
(define (variable? val) (symbol? val))
(define (expanded-code? val) (list1? val))
(define (code-output code) (car code))
(define (syntax? val) (list2? val))
(define (builtin? syntax) (eq? 'builtin (caar syntax)))
(define (builtin-name builtin) (cadr builtin))
(define (expander? syntax) (not (builtin? syntax)))
(define (make-expander form env) (list form env))
(define (expander-form expd) (car expd))
(define (expander-env expd) (cadr expd))
(define (acons key val alist) (cons (cons key val) alist))
(define (lookup-sid sid env)
(define id (sid-id sid))
(let loop ([env env])
(cond [(null? env) (sid-location sid)]
[(procedure? env) (if (symbol? sid) (env sid) (sid-location sid))] ;++ global mapping support
[(eqv? (caar env) id) (cdar env)]
[else (loop (cdr env))])))
(define (lookup-location location store)
(cond [(assv location store) => cdr]
[(symbol? location) (symloc->var location)]
[else #f]))
(define (lookup2 sid env store)
(or (lookup-location (lookup-sid sid env) store)
(x-error (string-append
"premature use of keyword bound by letrec-syntax"
" (or an internal define-syntax): ")
sid)))
(define (extend-env env id location) (acons id location env))
(define (extend-store store loc val) (acons loc val store))
(define (substitute-in-store store loc val)
(let ([store
(if (assv loc store)
(let loop ([store store])
(let ([p (car store)])
(if (eqv? loc (car p))
(cdr store)
(cons p (loop (cdr store))))))
store)])
(if (and (symbol? loc) (eq? val (symloc->var loc)))
store
(acons loc val store))))
(define (symloc->var sym)
(define str (symbol->string sym))
(define (rename) (string->symbol (string-append "_" str "_")))
(case sym
[(begin define if lambda letrec quote set!) (rename)]
[else (if (and (positive? (string-length str)) (char=? #\_ (string-ref str 0)))
(rename)
sym)]))
(define (intloc->var intloc sid)
(let ([str (symbol->string (sid-name sid))])
(string->symbol
(string-append "_" str "_" (number->string intloc)))))
(define (loc->var loc sid)
(if (symbol? loc) (symloc->var loc) (intloc->var loc sid)))
(define (make-begin outputs)
(if (list1? outputs) (car outputs) (cons 'begin outputs)))
(define (make-letrec bindings expr)
(if (null? bindings) expr (list 'letrec bindings expr)))
(define (expand-lambda formals expr id-n env store loc-n)
(define (flatten-dotted x)
(if (pair? x) (cons (car x) (flatten-dotted (cdr x))) (list x)))
(define (dot-flattened x)
(if (null? (cdr x))
(car x)
(cons (car x) (dot-flattened (cdr x)))))
(let* ([dotted? (not (list? formals))]
[flattened (if dotted? (flatten-dotted formals) formals)])
(define (check x)
(or (sid? x)
(x-error "non-identifier: " x " in lambda formals: " formals))
(if (member x (cdr (member x flattened)))
(x-error "duplicate variable: " x " in lambda formals: " formals)))
(begin
(for-each check flattened)
(let loop ([formals flattened] [rvars '()]
[env env] [store store] [loc-n loc-n])
(if (not (null? formals))
(let* ([var (intloc->var loc-n (car formals))]
[env (extend-env env (sid-id (car formals)) loc-n)]
[store (extend-store store loc-n var)])
(loop (cdr formals) (cons var rvars)
env store (+ 1 loc-n)))
(let* ([vars (reverse rvars)]
[vars (if dotted? (dot-flattened vars) vars)])
(list vars (expand-expr expr id-n env store loc-n))))))))
#;(define (expand-letcc formal expr id-n env store loc-n)
(if (sid? formal)
(let* ([var (intloc->var loc-n formal)]
[env (extend-env env (sid-id formal) loc-n)]
[store (extend-store store loc-n var)]
[loc-n (+ 1 loc-n)]) ;*** fixed in 153s
(list var (expand-expr expr id-n env store loc-n)))
(x-error "non-identifier: " formal " used as letcc formal")))
(define (check-syntax-bindings bindings)
(or (list? bindings)
(x-error "non-list syntax bindings list: " bindings))
(for-each
(lambda (b)
(or (and (list2? b) (sid? (car b)))
(x-error "malformed syntax binding: " b)))
bindings)
(do ([bs bindings (cdr bs)]) [(null? bs)]
(let ([dup (assoc (caar bs) (cdr bs))])
(if dup
(x-error "duplicate bindings for a keyword: " (car bs)
" and: " dup)))))
(define (expand-syntax-bindings bindings id-n syntax-env ienv store loc-n k)
(let loop ([bs bindings] [vals '()] [store store] [loc-n loc-n])
(if (not (null? bs))
(expand-val (cadar bs) id-n syntax-env store loc-n
(lambda (val store loc-n)
(loop (cdr bs) (cons val vals) store loc-n)))
(let loop ([store store] [vals (reverse vals)] [bs bindings])
(if (not (null? vals))
(let* ([loc (lookup-sid (caar bs) ienv)]
[store (extend-store store loc (car vals))])
(loop store (cdr vals) (cdr bs)))
(k store loc-n))))))
;++ support for syntax-lambda
(define (apply-expander syntax sexp id-n env store loc-n lsd? ek sk dk bk)
(case (sid-name (caar syntax))
[(syntax-rules)
(apply-synrules syntax sexp id-n env
(lambda (sexp id-n)
(expand-any sexp id-n env store loc-n lsd? ek sk dk bk)))]
[(syntax-lambda)
(or ek sk lsd? (pair? sexp)
(x-error "syntax lambda applied in bad context: " sexp))
(let ([formals (cadar syntax)] [sexps (cdr sexp)]
[body (cddar syntax)] [denv (cadr syntax)])
(or (= (length formals) (length sexps))
(x-error "incorrect number of arguments to syntax lambda: " sexp))
(let loop ([ids formals] [loc-n loc-n] [ienv denv])
(if (not (null? ids))
(loop (cdr ids) (+ loc-n 1)
(extend-env ienv (sid-id (car ids)) loc-n))
(expand-syntax-bindings
(map list formals sexps)
id-n env ienv store loc-n
(lambda (store loc-n)
(expand-body body
id-n ienv store loc-n lsd? ek sk
(and lsd? dk) (and lsd? bk)))))))]
[else
(x-error "invalid expander: " syntax)]))
(define (expand-any sexp id-n env store loc-n lsd? ek sk dk bk)
(define (get-k k sexp name)
(or k (x-error (string-append name " used in bad context: ") sexp)))
(define (get-ek sexp) (get-k ek sexp "expression"))
(define (get-sk sexp) (get-k sk sexp "syntax"))
(define (get-dk sexp) (get-k dk sexp "definition"))
(define (get-bk sexp) (get-k dk sexp "begin"))
(define (expand-subexpr sexp)
(expand-expr sexp id-n env store loc-n))
(define (expand-subexpr-root sexp) ;++ : expand converted constants in root env
(expand-expr sexp id-n root-environment store loc-n))
(define (handle-syntax-use syntax head store loc-n)
(let* ([tail (cdr sexp)] [sexp (cons head tail)])
(if (expander? syntax)
(apply-expander syntax sexp id-n env store loc-n lsd? ek sk dk bk)
(let ([builtin (builtin-name syntax)] [len (length tail)])
(define (handle-expr-builtin)
(define (expr-assert test)
(or test
(x-error "malformed " builtin " expression: " sexp)))
(case builtin
[(lambda)
(expr-assert (= len 2))
(cons 'lambda
(expand-lambda
(car tail) (cadr tail) id-n env store loc-n))]
[(quote)
(expr-assert (= len 1))
(list 'quote (unwrap-vecs (car tail)))]
[(set!)
(expr-assert (and (= len 2) (sid? (car tail))))
(let ([var (lookup2 (car tail) env store)])
(or (variable? var)
(x-error "attempt to set a keyword: " sexp))
(list 'set! var (expand-subexpr (cadr tail))))]
[(if)
(expr-assert (<= 2 len 3))
(cons 'if (map expand-subexpr tail))]))
(case builtin
[(syntax-rules)
(if (< len 1)
(x-error "empty syntax-rules form: " sexp))
(let ([syn (compile-syntax-rules sexp env)])
((get-sk sexp) syn sexp store loc-n))]
[(syntax-lambda)
(if (< len 2)
(x-error "malformed syntax-lambda form: " sexp))
(let ([syn (compile-syntax-lambda sexp env)])
((get-sk sexp) syn sexp store loc-n))]
[(begin)
(or ek (get-bk sexp)) ;** as in v1.65
(cond [bk (bk sexp id-n env store loc-n)]
[(null? tail) (x-error "empty begin expression: " sexp)]
[else (ek (make-begin (map expand-subexpr tail)))])] ;** as in v1.65
[(define define-syntax)
(or (and (= 2 len) (sid? (car tail)))
(and (= 1 len) (eq? builtin 'define))
(x-error "malformed definition: " sexp))
((get-dk sexp) builtin sexp id-n env store loc-n)]
[else (get-ek sexp) (ek (handle-expr-builtin))]))))) ;** as in v1.65
(define (handle-combination output)
(ek (if (and (pair? output) (eq? 'lambda (car output))
(null? (cadr output)) (null? (cdr sexp)))
(caddr output)
(cons output (map expand-subexpr (cdr sexp))))))
(cond
[(sid? sexp)
(let ([val (lookup2 sexp env store)])
(if (syntax? val)
(if (and (not sk) ek (expander? val))
;++ : support for identifier-syntax
(apply-expander val sexp id-n env store loc-n #f ek #f #f #f)
((get-sk sexp) val sexp store loc-n))
((get-ek sexp)
(if (expanded-code? val) (code-output val) val))))]
[(and (pair? sexp) (list? sexp)) ;** as in v1.65
(expand-any (car sexp) id-n env store loc-n #f
(and ek handle-combination) handle-syntax-use #f #f)]
[(or (number? sexp) (boolean? sexp) (string? sexp) (bytevector? sexp) (char? sexp) ;++ added bytevector
(procedure? sexp)) ; wrapped 'micro-syntax'
((get-ek sexp) sexp)]
[(vector? sexp) ;++ vector now is self-evaluating
((get-ek sexp) (unwrap-vec sexp))]
[else
(x-error (cond [(pair? sexp) "improper list: "]
[(null? sexp) "empty list: "] ;** as in v1.65
;[(vector? sexp) "vector: "] ** self-evaluating
[else "unexpected type of s-expression: "])
sexp " used as an expression, syntax, or definition.")]))
(define (expand-val sexp id-n env store loc-n k)
(expand-any sexp
id-n env store loc-n #f
(lambda (output) (k (make-code output) store loc-n))
(lambda (syn error-sexp store loc-n) (k syn store loc-n))
#f #f))
(define (expand-expr sexp id-n env store loc-n)
(expand-any sexp id-n env store loc-n #f (lambda (x) x) #f #f #f))
(define (expand-body sexps id-n env store loc-n lsd? ek sk dk bk)
(define (expand-def sexp vds sds exprs id-n env store loc-n k dek) ;** ek&dek, as in v1.65
(define (dk builtin sexp id-n env store loc-n)
(or ek (eq? builtin 'define-syntax)
(x-error "non-syntax definition in a syntax body: " sexp))
(if (list2? sexp)
(k vds sds (cons (cadr sexp) exprs) id-n env store loc-n)
(let* ([sid (cadr sexp)]
[id (sid-id sid)]
[env (extend-env env id loc-n)])
(define (check def)
(if (eqv? id (sid-id (cadr def)))
(x-error "duplicate internal definitions: " def
" and: " sexp)))
(begin
(for-each check sds)
(for-each check vds)
(case builtin
[(define-syntax)
(k vds (cons sexp sds) exprs
id-n env store (+ loc-n 1))]
[(define)
(let* ([var (intloc->var loc-n sid)]
[store (extend-store store loc-n var)]
[loc-n (+ loc-n 1)])
(k (cons sexp vds) sds exprs
id-n env store loc-n))])))))
(define (bk sexp id-n env store loc-n)
(let loop ([sexps (cdr sexp)] [vds vds] [sds sds] [exprs exprs]
[id-n id-n] [env env] [store store] [loc-n loc-n] [dek dek])
(if (null? sexps)
(k vds sds exprs id-n env store loc-n)
(expand-def (car sexps) vds sds exprs
id-n env store loc-n
(lambda (vds sds exprs id-n env store loc-n)
(loop (cdr sexps) vds sds exprs
id-n env store loc-n #f))
(and dek
(lambda (out)
(define (expand-one sexp)
(expand-expr sexp id-n env store loc-n))
(let ([rest (map expand-one (cdr sexps))])
(dek (make-begin (cons out rest))))))))))
(expand-any sexp id-n env store loc-n #f dek #f dk bk))
(let loop ([first (car sexps)] [rest (cdr sexps)]
[vds '()] [sds '()] [exprs '()] ;** as in v1.65
[id-n id-n] [env env] [store store] [loc-n loc-n])
(define (finish-body boundary-exp-output)
(expand-syntax-bindings
(map cdr sds) id-n env env store loc-n
(lambda (store loc-n)
(define (iexpand sexp)
(expand-expr sexp id-n env store loc-n))
(define (expand-vd vd)
(list (lookup2 (cadr vd) env store) (iexpand (caddr vd))))
(if (and (null? rest) (null? vds) (null? exprs))
(expand-any first id-n env store loc-n lsd? ek sk dk bk)
(ek (make-letrec
(map expand-vd (reverse vds))
(let ([body-exprs-output
(if (null? rest)
(list (iexpand first))
(cons
boundary-exp-output
(map iexpand rest)))])
(make-begin
(append (map iexpand (reverse exprs))
body-exprs-output)))))))))
(if (null? rest)
(finish-body #f)
(expand-def first vds sds exprs id-n env store loc-n
(lambda (vds sds exprs id-n env store loc-n)
(loop (car rest) (cdr rest) vds sds exprs
id-n env store loc-n))
(and ek finish-body)))))
(define (expand-top-level-forms forms top-env store loc-n k)
(define (finalize store loc-n acc) (k (reverse acc) store loc-n))
(let expand ([sexps (wrap-vecs forms)] [id-n 0] [env top-env]
[store store] [loc-n loc-n] [acc '()] [k finalize])
(if (null? sexps)
(k store loc-n acc)
(let ([rest (cdr sexps)])
(define (ek output)
(expand rest id-n env store loc-n (cons output acc) k))
(define (dk builtin sexp id-n* env* store loc-n)
(if (list2? sexp)
(ek (expand-expr (cadr sexp) id-n* env* store loc-n))
(let* ([tail (cdr sexp)] [sid (car tail)]
[loc (lookup-sid sid env*)] ;** as in v1.65
[init (cadr tail)])
(if (eq? builtin 'define)
(let* ([expr (expand-expr init id-n* env* store loc-n)]
[var (loc->var loc sid)]
[acc (cons (list 'define var expr) acc)]
[store (substitute-in-store store loc var)])
(expand rest id-n env store loc-n acc k))
(expand-val init id-n* env* store loc-n
(lambda (val store loc-n)
(let ([store (substitute-in-store store loc val)])
(expand rest id-n env store loc-n acc k))))))))
(define (bk sexp id-n* env* store loc-n)
(expand (cdr sexp) id-n* env* store loc-n acc
(lambda (store loc-n acc)
(expand rest id-n env store loc-n acc k))))
(expand-any (car sexps) id-n env store loc-n #t ek #f dk bk)))))
(define (compile-syntax-lambda synlambda env)
(let ([formals (cadr synlambda)])
(define (check x)
(or (sid? x)
(x-error "non-identifier: " x
" in syntax-lambda formals: " formals))
(if (member x (cdr (member x formals)))
(x-error "duplicate variable: " x
" in syntax-lambda formals: " formals)))
(for-each check formals)
(make-expander (cons 'syntax-lambda (cdr synlambda)) env))) ;*** fixed in 153s
; ++ : pattern matcher extension
(define (sbox->sexp-list b) (cdr (unbox b)))
(define (pattern-sbox->sexp b) (cadr (unbox b)))
(define (pattern-sbox? b)
(and (box? b) (list2? (unbox b))
(memq (car (unbox b))
'(char? number? string? id? feature? library?))))
(define (pattern-sbox->test b)
(case (car (unbox b))
[(char?)
(lambda (sexp env) (char? sexp))]
[(number?)
(lambda (sexp env) (number? sexp))]
[(string?)
(lambda (sexp env) (string? sexp))]
[(id?)
(lambda (sexp env) (sid? sexp))]
[(feature?)
(lambda (sexp env) (and (sid? sexp) (memq (sid-name sexp) (features))))]
[(library?)
(lambda (sexp env)
(cond [(string? sexp) (library-available? sexp)]
[(and (pair? sexp) (list? sexp) (andmap (lambda (x) (or (sid? x) (number? x))) sexp))
(library-available? (map (lambda (x) (if (sid? x) (sid-name x) x)) sexp))]
[else #f]))]))
(define (template-sbox->sexp b) (cdr (unbox b)))
(define (template-sbox? b)
(and (box? b) (pair? (unbox b))
(let ([l (unbox b)])
(case (car l)
[(error) (and (pair? (cdr l))) (list? (cdr l))]
[(number->string) (list1? (cdr l))]
[(string->number) (list1? (cdr l))]
[(list->string) (list1? (cdr l))]
[(string->list) (list1? (cdr l))]
[(length) (list1? (cdr l))]
[(string-append) (list? (cdr l))]
[(+ *) (list? (cdr l))]
[(id->string) (list1? (cdr l))]
[(string->id) (list1? (cdr l))]
[else #f]))))
(define (template-sbox->conv b)
(case (car (unbox b))
[(error)
(lambda (sexps env)
(if (and (pair? sexps) (string? (car sexps)))
(x-error* (car sexps) (cdr sexps))
(x-error* " " sexps)))]
[(number->string)
(lambda (sexps env)
(let ([sexp (car sexps)])
(if (number? sexp)
(number->string sexp)
(x-error "number->string: not a number: " sexp))))]
[(string->number)
(lambda (sexps env)
(let ([sexp (car sexps)])
(if (string? sexp)
(string->number sexp)
(x-error "string->number: not a string: " sexp))))]
[(list->string)
(lambda (sexps env)
(let ([sexp (car sexps)])
(if (and (list? sexp) (andmap char? sexp))
(list->string sexp)
(x-error "list->string: not a list of chars: " sexp))))]
[(string->list)
(lambda (sexps env)
(let ([sexp (car sexps)])
(if (string? sexp)
(string->list sexp)
(x-error "string->list: not a string: " sexp))))]
[(length)
(lambda (sexps env)
(let ([sexp (car sexps)])
(if (list? sexp)
(length sexp)
(x-error "length: not a list: " sexp))))]
[(string-append)
(lambda (sexps env)
(let loop ([sexps sexps])
(cond [(null? sexps) ""]
[(string? (car sexps))
(string-append (car sexps) (loop (cdr sexps)))]
[else (x-error "string-append: not a string: " (car sexps))])))]
[(+)
(lambda (sexps env)
(let loop ([sexps sexps])
(cond [(null? sexps) 0]
[(number? (car sexps))
(+ (car sexps) (loop (cdr sexps)))]
[else (x-error "+: not a number: " (car sexps))])))]
[(*)
(lambda (sexps env)
(let loop ([sexps sexps])
(cond [(null? sexps) 1]
[(number? (car sexps))
(* (car sexps) (loop (cdr sexps)))]
[else (x-error "*: not a number: " (car sexps))])))]
[(id->string)
(lambda (sexps env)
(let ([sexp (car sexps)])
(if (sid? sexp)
(symbol->string (sid-name sexp))
(x-error "id->string: not an id: " sexp))))]
[(string->id)
(lambda (sexps env)
(let ([sexp (car sexps)])
(if (string? sexp)
(let ([id (string->symbol sexp)])
(let ([location (cond [(assv id env) => cdr] [else id])])
(make-sid id id location)))
(x-error "string->id: not a string: " sexp))))]))
(define (compile-syntax-rules synrules env)
(define ellipsis-id
(and (pair? (cddr synrules))
(sid? (cadr synrules))
(sid-id (cadr synrules))))
(define (ellipsis? x)
(and (sid? x)
(if ellipsis-id
(eqv? ellipsis-id (sid-id x))
(eq? (lookup-sid x env) ellipsis-location)))) ;** was '...
(define (check-lit lit)
(or (sid? lit)
(x-error "non-id: " lit " in literals list of: " synrules))
(if (ellipsis? lit)
(x-error "ellipsis " lit " in literals list of: " synrules)))
(let* ([rest (if ellipsis-id (cddr synrules) (cdr synrules))]
[pat-literal-sids (car rest)]
[rules (cdr rest)]
[pat-literals
(begin (or (list? pat-literal-sids)
(x-error "pattern literals list is not a list: "
pat-literal-sids))
(for-each check-lit pat-literal-sids)
(map sid-id pat-literal-sids))])
(define (ellipsis-pair? x) (and (pair? x) (ellipsis? (car x))))
(define (check-ellipses pat/tmpl in-template?)
(define (bad-ellipsis x reason)
(x-error (string-append reason ": ") x
(if in-template? " in template: " " in pattern: ")
pat/tmpl))
(define (multi-ellipsis-error x)
(bad-ellipsis x "list or vector pattern with multiple ellipses"))
(define (ellipsis/tail-error x)
(bad-ellipsis x "improper list pattern with an ellipsis"))
(define (ellipsis-follows x thing)
(bad-ellipsis x (string-append "ellipsis following " thing)))
(let ([x (if in-template? pat/tmpl (cdr pat/tmpl))])
(if in-template?
(if (ellipsis? x) (ellipsis-follows x "nothing"))
(cond [(ellipsis? x) (ellipsis-follows pat/tmpl "a '.'")]
[(ellipsis-pair? x)
(ellipsis-follows pat/tmpl "the pattern keyword")]))
(let check ([x x])
(cond
[(pair? x)
(if (ellipsis? (car x)) (ellipsis-follows x "a '('"))
(check (car x))
(if (ellipsis? (cdr x)) (ellipsis-follows x "a '.'"))
(if (ellipsis-pair? (cdr x))
(cond
[(ellipsis? (cddr x))
(ellipsis-follows (cdr x) "a '.'")]
[(ellipsis-pair? (cddr x))
(ellipsis-follows (cdr x) "an ellipsis")]
[in-template? (check (cddr x))]
[else
(or (list? x) (ellipsis/tail-error x))
(for-each
(lambda (y)
(if (ellipsis? y) (multi-ellipsis-error x))
(check y))
(cddr x))])
(check (cdr x)))]
[(svector? x)
(let ([elts (svector->list x)])
(if (ellipsis-pair? elts)
(ellipsis-follows x "a '#('")
(check elts)))]
[(if in-template? (template-sbox? x) (pattern-sbox? x))
(let ([elts (sbox->sexp-list x)])
(if (ellipsis-pair? elts)
(ellipsis-follows x "a '#&(op'")
(check elts)))]
[(box? x)
(bad-ellipsis x "malformed box")]))))
(define (make-pat-env pat)
(let collect ([x (cdr pat)] [depth 0] [l '()])
(cond
[(sid? x)
(let ([id (sid-id x)])
(cond
[(memv id pat-literals) l]
[(assv id l)
(x-error "duplicate pattern var: " x " in pattern: " pat)]
[else (acons id depth l)]))]
[(vector? x) (collect (svector->list x) depth l)]
[(box? x) (collect (pattern-sbox->sexp x) depth l)]
[(pair? x)
(if (ellipsis-pair? (cdr x))
(collect (car x) (+ 1 depth) (collect (cddr x) depth l))
(collect (car x) depth (collect (cdr x) depth l)))]
[else l])))
(define (check-var-depths tmpl pat-env)
(define (depth-error x)
(x-error "pattern var used at bad depth: " x
" in template: " tmpl))
(define (close-error x)
(x-error "template ellipsis closes no variables: " x
" in template: " tmpl))
(let collect ([x tmpl] [depth 0])
(cond
[(sid? x)
(let ([p (assv (sid-id x) pat-env)])
(and p
(let*
([pat-depth (cdr p)]
[same-depth? (= depth pat-depth)])
(if (and (positive? pat-depth) (not same-depth?))
(depth-error x))
same-depth?)))]
[(vector? x) (collect (svector->list x) depth)]
[(box? x) (collect (template-sbox->sexp x) depth)]
[(pair? x)
(let* ([ellip? (ellipsis-pair? (cdr x))]
[car-closed?
(collect (car x) (if ellip? (+ 1 depth) depth))]
[cdr-closed? (collect ((if ellip? cddr cdr) x) depth)])
(and ellip? (not car-closed?) (close-error x))
(or car-closed? cdr-closed?))]
[else #f])))
(define (check-rule rule)
(or (list2? rule) (x-error "malformed syntax rule: " rule))
(let ([pat (car rule)] [tmpl (cadr rule)])
(or (and (pair? pat) (sid? (car pat)))
(sid? pat) ;++ : support for identifier-syntax
(x-error "malformed pattern: " pat))
;++ : treat _ pat as (_) for checking purposes
(let ([pat (if (sid? pat) (list pat) pat)])
(check-ellipses pat #f)
(check-ellipses tmpl #t)
(let ([pat-env (make-pat-env pat)])
(check-var-depths tmpl pat-env)
(let collect ([x tmpl] [lits '()])
(cond
[(ellipsis? x) lits]
[(sid? x) (if (assv (sid-id x) pat-env) lits (cons (sid-id x) lits))]
[(vector? x) (collect (svector->list x) lits)]
[(box? x) (collect (template-sbox->sexp x) lits)]
[(pair? x) (collect (car x) (collect (cdr x) lits))]
[else lits]))))))
(or (list? rules) (x-error "malformed syntax rules: " rules))
(for-each check-rule rules) ;** reduction is dropped
(make-expander (cons 'syntax-rules (cdr synrules)) env)))
(define (apply-synrules transformer sexp id-n env k)
(let* ([synrules (expander-form transformer)]
[mac-env (expander-env transformer)]
[ellipsis-id (and (sid? (cadr synrules)) (sid-id (cadr synrules)))]
[rest (if ellipsis-id (cddr synrules) (cdr synrules))]
[pat-literals (map sid-id (car rest))]
[rules (cdr rest)])
(define (pat-literal? id) (memv id pat-literals))
(define (not-pat-literal? id) (not (pat-literal? id)))
(define (ellipsis-pair? x) (and (pair? x) (ellipsis? (car x))))
(define (ellipsis? x)
(and (sid? x)
(if ellipsis-id
(eqv? ellipsis-id (sid-id x))
(eq? (lookup-sid x mac-env) ellipsis-location)))) ;** was '...
(define (list-ids x include-scalars pred?)
(let collect ([x x] [inc include-scalars] [l '()])
(cond [(sid? x)
(let ([id (sid-id x)])
(if (and inc (pred? id)) (cons id l) l))]
[(vector? x) (collect (svector->list x) inc l)]
[(box? x) (collect (sbox->sexp-list x) inc l)]
[(pair? x)
(if (ellipsis-pair? (cdr x))
(collect (car x) #t (collect (cddr x) inc l))
(collect (car x) inc (collect (cdr x) inc l)))]
[else l])))
(define (matches? pat)
(let match ([pat pat] [sexp (cdr sexp)])
(cond [(sid? pat)
(or (not (pat-literal? (sid-id pat)))
(and (sid? sexp)
(eqv?
(lookup-sid pat mac-env)
(lookup-sid sexp env))))]
[(svector? pat)
(and (svector? sexp)
(match (svector->list pat) (svector->list sexp)))]
[(pattern-sbox? pat)
(and ((pattern-sbox->test pat) sexp env)
(match (pattern-sbox->sexp pat) sexp))]
[(not (pair? pat)) (equal? pat sexp)]
[(ellipsis-pair? (cdr pat))
(let skip ([p (cddr pat)] [s sexp])
(if (pair? p)
(and (pair? s) (skip (cdr p) (cdr s)))
(let match-cars ([sexp sexp] [s s])
(if (pair? s)
(and (match (car pat) (car sexp))
(match-cars (cdr sexp) (cdr s)))
(match (cddr pat) sexp)))))]
[else
(and (pair? sexp)
(match (car pat) (car sexp))
(match (cdr pat) (cdr sexp)))])))
(define (make-bindings pat)
(let collect ([pat pat] [sexp (cdr sexp)] [bindings '()])
(cond
[(and (sid? pat) (not (pat-literal? (sid-id pat))))
(acons (sid-id pat) sexp bindings)]
[(svector? pat)
(collect (svector->list pat) (svector->list sexp) bindings)]
[(box? pat)
(collect (pattern-sbox->sexp pat) sexp bindings)]
[(not (pair? pat)) bindings]
[(ellipsis-pair? (cdr pat))
(let* ([tail-len (length (cddr pat))]
[tail (list-tail sexp (- (length sexp) tail-len))]
[matches
(reverse (list-tail (reverse sexp) tail-len))]
[vars (list-ids (car pat) #t not-pat-literal?)])
(define (collect1 match)
(map cdr (collect (car pat) match '())))
(append (apply-map-list (cons vars (map collect1 matches))) ; *
(collect (cddr pat) tail bindings)))]
[else
(collect (car pat) (car sexp)
(collect (cdr pat) (cdr sexp) bindings))])))
(define (remove-dups l)
(let loop ([l l] [result '()])
(if (null? l)
result
(loop (cdr l)
(let ([elt (car l)])
(if (memv elt result) result (cons elt result)))))))
(define (expand-template pat tmpl top-bindings)
(define tmpl-literals
(remove-dups
(list-ids tmpl #t (lambda (id) (not (assv id top-bindings))))))
(define ellipsis-vars (list-ids pat #f not-pat-literal?))
(define (list-ellipsis-vars subtmpl)
(list-ids subtmpl #t (lambda (id) (memv id ellipsis-vars))))
(define (expand tmpl bindings)
(let expand-part ([tmpl tmpl])
(cond
[(sid? tmpl)
(let ([id (sid-id tmpl)])
(cond
[(assv id bindings) => cdr]
[(assv id top-bindings) => cdr]
[else
(let ([index (+ -1 (length (memv id tmpl-literals)))]
[location (lookup-sid tmpl mac-env)])
(make-sid (sid-name tmpl) (+ id-n index) location))]))]
[(vector? tmpl)
(list->svector (expand-part (svector->list tmpl)))]
[(box? tmpl)
((template-sbox->conv tmpl)
(expand-part (template-sbox->sexp tmpl)) env)]
[(pair? tmpl)
(if (ellipsis-pair? (cdr tmpl))
(let ([vars-to-iterate (list-ellipsis-vars (car tmpl))])
(define (lookup var) (cdr (assv var bindings)))
(define (expand-using-vals-list vals) ; used dotted arglist
(expand (car tmpl) (map cons vars-to-iterate vals)))
(let ([val-lists (map lookup vars-to-iterate)])
(if (or (null? (cdr val-lists))
(pairwise-andmap (lambda (x y) (= x y)) ; *
(map length val-lists))) ; was (apply = (map length val-lists))
(append
(map expand-using-vals-list (apply-map-list val-lists))
(expand-part (cddr tmpl)))
(x-error
"unequal sequence lengths for pattern vars: "
vars-to-iterate " in macro call: " sexp))))
(cons (expand-part (car tmpl))
(expand-part (cdr tmpl))))]
[else tmpl])))
(k (expand tmpl top-bindings) (+ id-n (length tmpl-literals))))
(let loop ([rules rules])
(if (null? rules)
(x-error "no matching rule for macro use: " sexp)
(let* ([rule (car rules)] [pat (car rule)] [tmpl (cadr rule)])
(cond
[(and (pair? pat) (pair? sexp) (matches? (cdr pat)))
(expand-template (cdr pat) tmpl (make-bindings (cdr pat)))]
;++ : support for identifier-syntax
[(and (sid? pat) (sid? sexp))
(expand-template '() tmpl '())]
[else
(loop (cdr rules))]))))))
(define root-environment ;++ replaces empty-env
'((syntax-lambda . -10) (syntax-rules . -9)
(set! . -8) (quote . -7) (lambda . -6) (if . -5)
(define-syntax . -4) (define . -3) (begin . -2)
(... . -1))) ; todo: add (_ . -11) -- specially treated by syntax-rules
(define root-macro-store ;++ replaces null-store, null-loc-n
'(((-10 (builtin) syntax-lambda) (-9 (builtin) syntax-rules)
(-8 (builtin) set!) (-7 (builtin) quote) (-6 (builtin) lambda) (-5 (builtin) if)
(-4 (builtin) define-syntax) (-3 (builtin) define) (-2 (builtin) begin)
(-1 (builtin) ...)
) . 0))
(define ellipsis-location -1) ;++ used to be '...
(define *current-environment*
root-environment) ; replaced by derived environments, root-environment itself is not mutated
(define *current-macro-store* ; pair itself is mutated by expand-top-level-forms!
(cons (car root-macro-store) (cdr root-macro-store))) ; root-macro-store is not mutated
(define (expand-top-level-forms! forms environment)
(expand-top-level-forms forms environment (car *current-macro-store*) (cdr *current-macro-store*)
(lambda (outputs store loc-n)
(set-car! *current-macro-store* store) (set-cdr! *current-macro-store* loc-n) outputs)))
;------------------------------------------------------------------------------
; main library processing code
; used by commented-out code in adjoin-env
#;(define (rassq k al)
(and (pair? al)
(let ([a (car al)])
(if (eq? k (cdr a)) a (rassq k (cdr al))))))
(define (make-lib file/lib)
; todo: make an object?
(cond [(string? file/lib) (file-resolve-relative-to-current file/lib)]
[(pair? file/lib) file/lib]
[else (c-error "invalid module:" file/lib)]))
(define lib=? equal?)
(define (lib-public? lib)
; libraries referred to by list names have private internal definitions by default, string ones don't
(string? lib))
; libs is a list of library names (both string-like and list-like)
(define (adjoin-libs libs1 libs2) ;=> libs12, in original order w/o duplicates
(if (null? libs1) libs2
(let ([libs2 (adjoin-libs (cdr libs1) libs2)])
(cond [(member (car libs1) libs2) libs2]
[else (cons (car libs1) libs2)]))))
(define (env-lookup i env full?) ;=> <macro-store-key> or #f
(let loop ([env env])
(cond [(null? env) #f]
[(procedure? env) (and full? (symbol? i) (env i))]
[(eqv? i (caar env)) (cdar env)]
[else (loop (cdr env))])))
; env1 here is a proper alist of bindings ((<id> . <id-or-number>) ...)
; <id-or-number> is either a unique global id or an integer store location used for built-ins;
; both are keys (i.e. symbolic addresses) in current-macro-store.
; env2 is the same, but can also be an improper alist ending in a procedure which
; serves as a default <id> => <macro-store-key> mapper for <id>s not mapped explicitly
(define (adjoin-env env1 env2) ;=> env12
(if (null? env1) env2
(let ([env2 (adjoin-env (cdr env1) env2)])
(cond [(env-lookup (caar env1) env2 #f) =>
(lambda (a) ; a is not auto-mapped even when env2 supports it (i.e. is proc-terminated alist)
(if (eq? (cdar env1) a)
env2 ; repeat of same id with same binding is allowed
(c-error "multiple identifier bindings on import:" (caar env1) (cdar env1) a)))]
; uncommenting the check below won't allow call/cc and call-with-current-continuation to import the same binding
;[(rassq (cdar env1) env2) => (lambda (db) (c-error "multiple identifier imports on import:" (car env1) db))]
[else (cons (car env1) env2)]))))
; this variant is used in repl; it allows shadowing of old bindings with new ones
; todo: remove duplicates e.g. (... (foo . lib1.foo) ... (foo . lib2.foo) ... (foo . lib1.foo) ...) by starting
; with the env1 and appending non-duplicate parts of env2
(define (adjoin-env/shadow env1 env2) ;=> env12
(if (null? env1) env2
(let ([env2 (adjoin-env/shadow (cdr env1) env2)])
(cond [(env-lookup (caar env1) env2 #f) =>
(lambda (a) ; a is not auto-mapped even when env2 supports it (i.e. is proc-terminated alist)
(if (eq? (cdar env1) a)
env2 ; repeat of same id with same binding is allowed
(begin
(c-warning "old identifier binding shadowed on import:" (caar env1) 'was: a 'now: (cdar env1))
(cons (car env1) env2))))]
; uncommenting the check below won't allow call/cc and call-with-current-continuation to import the same binding
;[(rassq (cdar env1) env2) => (lambda (db) (c-error "multiple identifier imports on import:" (car env1) db))]
[else (cons (car env1) env2)]))))
; esps is #f or a list of export specs, each spec is either <id> or (rename <id> <id>)
; #f means all internal definitions are exported as-is; not used for libraries
(define (adjoin-esps esps1 esps2) ;=> esps12
(cond [(not esps1) esps2]
[(not esps2) esps1]
[else (append esps1 esps2)]))
; begs is a list of "begins", i.e. expression blocks, each "beg" is either (<path> . <ci-flag>) or (<path-or-false> <form> ...)
; where <path> is the source path name string, <path-or-false> is either <path> or #f; in the (<path> . <ci-flag>) form,
; forms should be read from the <path>
; NB: pathname is needed in the second form for macroexpander to process relative includes correctly
(define (adjoin-begs begs1 begs2) ;=> beg12
(append begs1 begs2))
(define (preprocess-library lib return) ;=> (return this-and-used-libs export-env)
(get-library-info lib ;=>
(lambda (used-libs import-env export-specs beg-forms)
(return
(adjoin-libs used-libs (list lib)) ; init order: used-libs, then lib
(make-export-env export-specs lib import-env)))))
(define (preprocess-import-set iset return) ;=> (return libs env)
(define (pp s return)
(sexp-case s
[(only * <symbol> ...)
(pp (cadr s) ;=>
(lambda (libs env)
(return libs
(let loop ([env env] [ids (cddr s)])
(cond [(null? env) env]
[(memq (caar env) ids) (cons (car env) (loop (cdr env) ids))]
[else (loop (cdr env) ids)])))))]
[(except * <symbol> ...)
(pp (cadr s) ;=>
(lambda (libs env)
(return libs
(let loop ([env env] [ids (cddr s)])
(cond [(null? env) env]
[(memq (caar env) ids) (loop (cdr env) ids)]
[else (cons (car env) (loop (cdr env) ids))])))))]
[(prefix * <symbol>)
(pp (cadr s) ;=>
(lambda (libs env)
(return libs
(let loop ([env env] [pfx (symbol->string (caddr s))])
(if (null? env)
env
(let ([nn (string->symbol (string-append pfx (symbol->string (caar env))))])
(cons (cons nn (cdar env)) (loop (cdr env) pfx))))))))]
[(rename * [<symbol> <symbol>] ...)
(pp (cadr s) ;=>
(lambda (libs env)
(return libs
(let loop ([env env] [idpairs (cddr s)])
(cond [(null? env) env]
[(assq (caar env) idpairs) =>
(lambda (idpair) (cons (cons (cadr idpair) (cdar env)) (loop (cdr env) idpairs)))]
[else (cons (car env) (loop (cdr env) idpairs))])))))]
[(* * ...)
(preprocess-library (make-lib s) return)]
[<string>
(preprocess-library (make-lib s) return)]
[#f ; #f is a predefined library for sharpf-null environment (compiler/interpreter)
(preprocess-library #f return)]
[else
(c-error "invalid import set in import:" s)]))
(pp iset return))
(define (preprocess-import-sets isets return) ;=> (return requred-libs import-env)
(let loop ([isets isets] [libs '()] [env '()])
(if (null? isets)
(return libs env)
(preprocess-import-set (car isets) ;=>
(lambda (new-libs new-env)
(loop (cdr isets)
(adjoin-libs libs new-libs)
(adjoin-env new-env env)))))))
; local environment is made for expansion of thislib library's body forms
; it is made of import environment followed by a default mapper to lib-specific locations
(define (make-local-env esps thislib import-env) ;=> env (if lib is private, ends with . private-id-gen-proc)
(let loop ([esps esps] [env import-env])
(if (null? esps)
(if (lib-public? thislib)
; all non-exported definitions are public and in global namespace under their own names
env ; null-terminated env -- lookups fall back to identity mapper (id => id)
; otherwise they are in global namespace under mangled names
(append env (lambda (id) (fully-qualified-library-name thislib id))))
(loop (cdr esps)
(sexp-case (car esps)
[<symbol> env]
[(rename <symbol> <symbol>) env]
[else (c-error "invalid export spec in export:" (car esps))])))))
; environment for import from thislib library into outside libs or programs
(define (make-export-env esps thislib import-env) ;=> env
(define (extend-export lid eid env)
(cond [(assq eid env) (c-error "duplicate external id in export:" eid esps)]
[(assq lid import-env) => ; re-exported imported id, keep using imported binding under eid
(lambda (b) (cons (cons eid (cdr b)) env))]
[else (cons (cons eid (fully-qualified-library-name thislib lid)) env)]))
(if (lib-public? thislib)
(if (or esps (pair? import-env))
(c-error "module cannot be imported:" thislib)
'())
(let loop ([esps esps] [env '()])
(if (null? esps)
env
(loop (cdr esps)
(sexp-case (car esps)
[<symbol> (extend-export (car esps) (car esps) env)]
[(rename <symbol> <symbol>) (extend-export (cadr (car esps)) (caddr (car esps)) env)]
[else (c-error "invalid export spec in export:" (car esps))]))))))
; processes special forms (not expressions / definitions) preceding expressions / definitions
; a special case is a standalone (define-library * * ...) form (normally the file is an .sld file)
(define (process-header-forms curlib all-forms return) ;=> (return used-libs import-env export-specs beg-forms)
(let loop ([forms all-forms] [libs '()] [env '()])
(if (null? forms)
(return libs env #f (cons (current-file) forms)) ; #f esps means exports are implicit
(sexp-case (car forms)
#;[(load <string>) ; treated as simplified import form by sfc compiler: comment out for interpreter!
(preprocess-library (make-lib (cadr (car forms))) ;=>
(lambda (new-libs new-env)
(loop (cdr forms)
(adjoin-libs libs new-libs)
(adjoin-env new-env env))))]
[(import * ...)
(preprocess-import-sets (cdr (car forms)) ;=>
(lambda (new-libs new-env)
(loop (cdr forms)
(adjoin-libs libs new-libs)
(adjoin-env new-env env))))]
[(define-library * * ...)
(let ([thislib (make-lib (cadr (car forms)))])
(if (not (list1? all-forms))
(c-error "define-library form not alone in the file:" (car forms)))
(if (and curlib (not (lib=? curlib thislib)))
(c-error "define-library form located in the wrong file:" curlib '<=> thislib))
(process-define-library-decls thislib (cddr (car forms)) ;=>
return))]
[else ; other forms start body consisting of expressions / definitions only
(return libs env #f (cons (current-file) forms))])))) ; #f esps means exports are implicit
; helper for processing include and include-ci forms in process-define-library-decl below
(define (process-includes names ci? return) ;=> (return used-libs import-env export-specs beg-forms)
(let loop ([names names] [begs '()])
(if (null? names)
(return '() '() '() begs)
; since includes can't contain header forms, we can postpone reading them
(let ([path (resolve-input-file/lib-name (car names))])
(loop (cdr names) (adjoin-begs begs (list (cons path ci?))))))))
; processor for define-library header form's single declaration
(define (process-define-library-decl thislib d return) ;=> (return used-libs import-env export-specs beg-forms)
(sexp-case d
[(export * ...)
(return '() '() (cdr d) '())]
[(import * ...)
(preprocess-import-sets (cdr d) ;=>
(lambda (libs env) (return libs env '() '())))]
[(begin * ...)
(return '() '() '() (list (cons (current-file) (cdr d))))]
[(include * * ...)
(process-includes (cdr d) #f return)] ; no default case folding
[(include-ci * * ...)
(process-includes (cdr d) #t return)] ; fold case by default
[(include-library-declarations * ...)
(let loop ([names (cdr d)] [libs '()] [env '()] [esps '()] [begs '()])
(if (null? names)
(return libs env esps begs)
(let ([lesf (call-with-file/lib-sexps (car names) #f ; no case folding
(lambda (sexps) ; called while (car names) is current file
(process-define-library-decls thislib sexps list)))])
(loop (cdr names)
(adjoin-libs libs (car lesf))
(adjoin-env (cadr lesf) env)
(adjoin-esps (caddr lesf) esps)
(adjoin-begs begs (cadddr lesf))))))]
[(cond-expand * ...)
(let loop ([clauses (cdr d)])
(if (null? clauses)
(return '() '() '() '()) ; got nothing to contribute
(sexp-case (car clauses)
[(else * ...)
(if (null? (cdr clauses))
(process-define-library-decls thislib (cdar clauses) return)
(c-error "'else' clause in the middle of cond-expand:" d thislib))]
[(* * ...) ; todo: process OR/AND/NOT tests
(if (memq (caar clauses) (features)) ; (features) returns list of supported features
(process-define-library-decls thislib (cdar clauses) return)
(loop (cdr clauses)))]
[else (c-error "invalid clause in define-library's cond-expand:" (car clauses) thislib)])))]
[else (c-error "unknown declaration in define-library:" d thislib)]))
; processor for define-library header form's declaration list
(define (process-define-library-decls thislib decls return) ;=> (return used-libs import-env export-specs beg-forms)
(let loop ([decls decls] [libs '()] [env '()] [esps '()] [begs '()])
(if (null? decls)
(return libs env esps begs)
(process-define-library-decl thislib (car decls) ;=>
(lambda (new-libs new-env new-esps new-begs)
(loop (cdr decls)
(adjoin-libs libs new-libs)
(adjoin-env new-env env)
(adjoin-esps new-esps esps)
(adjoin-begs begs new-begs)))))))
; r7rs environment constructor
(define environment
(let ([gensym-count 1]) ; gensym unique pseudo-library names for name mangling
(lambda isets
(let ([import-env (load-import-sets scheme-eval isets)]
[ename (string-append "hidden_" (number->string gensym-count))])
; return 'closed' environment with unknown ids mapped to unique private locations
(set! gensym-count (+ gensym-count 1))
(append import-env (lambda (id) (fully-qualified-name ename id)))))))
;------------------------------------------------------------------------------
; library processing state
; we have to cache loaded libraries, so stores are not hit on repeat loads/visits
; of/to the same library
(define *library-info-cache* '())
(define (make-library-info) (make-vector 4 #f)) ;; #(used-libs import-env export-specs beg-forms ...?)
(define *root-library-info* ; used for special library #f
(vector '() root-environment (map car root-environment) '()))
(define *base-library-info* #f) ; used for special library (sharpf base) -- interpreter-only!
(define (base-library-info) ; has to be delayed until initial envs are ready
(unless *base-library-info*
(let ([env (append *initial-macro-environment* *initial-value-environment*)])
(set! *base-library-info* (vector '() env (map car env) '()))))
*base-library-info*)
(define (library-available? lib)
(cond [(eq? lib #f) #t]
[(equal? lib '(sharpf base)) #t]
[(assoc lib *library-info-cache*) #t]
[(string? lib) (file-resolve-relative-to-current lib)]
[(and (pair? lib) (list? lib)) (find-library-path lib)]
[else #f]))
(define (lookup-library-info lib) ;=> li (possibly non-inited)
(cond [(eq? lib #f) *root-library-info*] ; available both to the interpreter and sfc compiler
[(equal? lib '(sharpf base)) (base-library-info)] ; available to the interpreter only
[(assoc lib *library-info-cache*) => cdr]
[else (let ([li (make-library-info)])
(set! *library-info-cache* (cons (cons lib li) *library-info-cache*)) li)]))
; main hub for library info -- called from preprocess-library
(define (get-library-info lib return) ;=> (return used-libs import-env export-specs beg-forms)
(define li (lookup-library-info lib))
(define (update-li! used-libs import-env export-specs beg-forms)
(vector-set! li 0 used-libs)
(vector-set! li 1 import-env)
(vector-set! li 2 export-specs)
(vector-set! li 3 beg-forms))
(unless (vector-ref li 0) ; not inited?
(call-with-file/lib-sexps lib #f
(lambda (all-forms) ; need to split off header forms
(process-header-forms lib all-forms update-li!))))
(return (vector-ref li 0)
(vector-ref li 1)
(vector-ref li 2)
(vector-ref li 3)))
;------------------------------------------------------------------------------
; interpreter-specific import handler
(define *loaded-libraries* '()) ; keep separate from lookup-library-info for quick checks
(define *libraries-being-loaded* '()) ; load-import-sets internal dependency loop check
(define (check-export-specs-after-load lib esps import-env)
(define (undefined lid loc)
(c-warning "exported identifier not defined in" lib ': lid (list loc)))
(define (check lid)
(unless (assq lid import-env)
(let ([loc (fully-qualified-library-name lib lid)])
(cond [(assq loc (car *current-macro-store*))]
[(assq loc *current-value-store*) =>
(lambda (s&v) (when (eq? (car s&v) (cdr s&v)) (undefined lid loc)))]
[else (undefined lid loc)]))))
(unless (lib-public? lib)
(let loop ([esps esps])
(unless (null? esps)
(sexp-case (car esps)
[<symbol> (check (car esps)) (loop (cdr esps))]
[(rename <symbol> <symbol>) (check (cadr (car esps))) (loop (cdr esps))]
[else (c-error "invalid export spec in export:" (car esps))])))))
; load-import-sets in the interpreter should be called with 'eval', sfc should use 'visit' that hits macro store only
(define (load-import-sets eval-like isets) ;=> import-env to merge into the caller's one
(set! *libraries-being-loaded* '()) ; in case we had errors during previous interactive call
(preprocess-import-sets isets ;=>
(lambda (libs-to-load import-env-for-load)
(define (load-lib! lib) ; modifies store, loc-n parts of macro store, value store; may have side effects
(unless (member lib *loaded-libraries*)
(begin (display "; loading library: ") (write lib) (newline)) ; todo: remove this info message later
(if (member lib *libraries-being-loaded*)
(c-error "recursive library dependence involving" lib)
(get-library-info lib ;=>
(lambda (used-libs import-env export-specs beg-forms)
(set! *libraries-being-loaded* (cons lib *libraries-being-loaded*))
(for-each load-lib! used-libs)
(set! *libraries-being-loaded* (cdr *libraries-being-loaded*))
(let ([lib-local-env (make-local-env export-specs lib import-env)])
(define (proc-expr! expr) (eval-like expr lib-local-env))
(let loop ([begs beg-forms])
(unless (null? begs)
(sexp-case (car begs)
[(<string> * ...) ; proper list of forms
(with-current-file (caar begs)
(lambda () (for-each proc-expr! (cdar begs))))]
[(#f * ...) ; proper list of forms, not from a file
(for-each proc-expr! (cdar begs))]
[(<string> . *) ; cdr is ci? flag
(for-each-file/lib-sexp proc-expr! (caar begs) (cdar begs))])
(loop (cdr begs)))))
(check-export-specs-after-load lib export-specs import-env)
(set! *loaded-libraries* (cons lib *loaded-libraries*)))))))
; may modify store, loc-n parts of (current-global-environment), value-store in the interpreter
(for-each load-lib! libs-to-load)
; NB: import-env-for-load is always a proper alist, so it can be prepended to any env
import-env-for-load)))
;------------------------------------------------------------------------------
; procedure hacks and argument checking
(define-inline (%procedure-length p)
(%prim "fixnum(procedurelen(obj_from_$arg))" p))
(define-inline (%procedure-ref p i)
(%prim? "obj(*procedureref(obj_from_$arg, fixnum_from_$arg))" p i))
(define-inline (%procedure-set! p i x)
(%prim! "void(*procedureref(obj_from_$arg, fixnum_from_$arg) = obj_from_$arg)" p i x))
(define-inline (%make-procedure vc code)
(%prim* "{ /* %make-procedure */
int i = 0, c = fixnum_from_$arg; assert(c >= 0);
hreserve(hbsz(c+1), $live); /* $live live regs */
while (i++ < c) *--hp = obj_from_bool(0);
*--hp = obj_from_$arg; /* gc-safe */
$return obj(hendblk(c+1)); }" vc code))
(define (print-procedure x) ;debugging
(write-string "#<procedure ")
(let ([size (%procedure-length x)])
(if (not (= size 0))
(let ([last (- size 1)])
(let loop ([i 0])
(let ([v (%procedure-ref x i)])
(cond [(= i 0) (write-string "#<code>")]
[else (write v)]))
(if (not (= i last))
(begin (write-char #\space) (loop (+ i 1))))))))
(write-char #\>) (newline)
(void))
(define (make-annotated-procedure p ann)
(let* ([l (%procedure-length p)] [vc (fx- l 1)]
[newp (%make-procedure (fx+ vc 1) (%procedure-ref p 0))])
(let loop ([i 0])
(if (fx=? i vc)
(begin (%procedure-set! newp (fx+ i 1) ann) newp)
(begin (%procedure-set! newp (fx+ i 1) (%procedure-ref p (fx+ i 1))) (loop (fx+ i 1)))))))
(define-inline (procedure-annotation ap) ;assumes annotation is there!
(%procedure-ref ap (fx- (%procedure-length ap) 1)))
(define-inline (argc->annotation c) (fx+ (fx* c 1000) c))
(define-inline (range-argc->annotation cmin cmax) (fx+ (fx* cmin 1000) cmax))
(define-inline (rest-argc->annotation c) (fx+ (fx* (fx- c 1) 1000) 999))
(%localdef "enum {
ARGCHECK_BOOLEAN_BOOLEAN_BOOLEAN_ETC = -1000,
ARGCHECK_N_OPT,
ARGCHECK_N,
ARGCHECK_N_N,
ARGCHECK_N_ETC,
ARGCHECK_Q,
ARGCHECK_K,
ARGCHECK_Z,
ARGCHECK_Z_Z,
ARGCHECK_Z_ETC,
ARGCHECK_Z_Z_ETC,
ARGCHECK_Z_Z_Z_ETC,
ARGCHECK_X,
ARGCHECK_X_X,
ARGCHECK_X_ETC,
ARGCHECK_X_X_ETC,
ARGCHECK_X_X_X_ETC,
ARGCHECK_Z_Z_OPT,
ARGCHECK_Z_OR_X_X,
ARGCHECK_Z_RADIX_OPT,
ARGCHECK_K_CHAR_OPT,
ARGCHECK_K_OBJ_OPT,
ARGCHECK_BOX,
ARGCHECK_PAIR,
ARGCHECK_PAIR_OBJ,
ARGCHECK_LIST,
ARGCHECK_LIST_ETC,
ARGCHECK_LIST_ETC_OBJ_OPT,
ARGCHECK_OBJ_LIST,
ARGCHECK_ALIST,
ARGCHECK_OBJ_ALIST,
ARGCHECK_U8LIST,
ARGCHECK_SYMBOL,
ARGCHECK_SYMBOL_SYMBOL_SYMBOL_ETC,
ARGCHECK_CHAR,
ARGCHECK_CHAR_CHAR,
ARGCHECK_CHAR_CHAR_CHAR_ETC,
ARGCHECK_CHAR_ETC,
ARGCHECK_STRING,
ARGCHECK_STRING_STRING,
ARGCHECK_STRING_STRING_STRING_ETC,
ARGCHECK_STRING_CHAR,
ARGCHECK_STRING_ETC,
ARGCHECK_STRING_OBJ_ETC,
ARGCHECK_STRING_RADIX_OPT,
ARGCHECK_STRING_INDEX,
ARGCHECK_STRING_INDEX_CHAR,
ARGCHECK_STRING_START_END,
ARGCHECK_STRING_INDEX_STRING_START_END,
ARGCHECK_STRING_CHAR_START_END,
ARGCHECK_STRING_START_END_IPORT,
ARGCHECK_STRING_START_END_OPORT,
ARGCHECK_VECTOR,
ARGCHECK_VECTOR_ETC,
ARGCHECK_VECTOR_INDEX,
ARGCHECK_VECTOR_INDEX_OBJ,
ARGCHECK_VECTOR_START_END,
ARGCHECK_VECTOR_INDEX_VECTOR_START_END,
ARGCHECK_VECTOR_OBJ_START_END,
ARGCHECK_VECTOR_OBJ,
ARGCHECK_U8_ETC,
ARGCHECK_K_U8_OPT,
ARGCHECK_U8VECTOR,
ARGCHECK_U8VECTOR_U8VECTOR,
ARGCHECK_U8VECTOR_ETC,
ARGCHECK_U8VECTOR_INDEX,
ARGCHECK_U8VECTOR_INDEX_U8,
ARGCHECK_U8VECTOR_START_END,
ARGCHECK_U8VECTOR_INDEX_U8VECTOR_START_END,
ARGCHECK_U8VECTOR_START_END_IPORT,
ARGCHECK_U8VECTOR_START_END_OPORT,
ARGCHECK_OBJ_K,
ARGCHECK_RECORD,
ARGCHECK_RECORD_INDEX,
ARGCHECK_RECORD_INDEX_OBJ,
ARGCHECK_PROC,
ARGCHECK_PROC_OBJ_ETC_LIST,
ARGCHECK_PROC1CC,
ARGCHECK_THUNK_PROC,
ARGCHECK_THUNK_THUNK_THUNK,
ARGCHECK_STRING_THUNK,
ARGCHECK_IPORT_THUNK,
ARGCHECK_OPORT_THUNK,
ARGCHECK_STRING_PROC1IP,
ARGCHECK_STRING_PROC1OP,
ARGCHECK_PORT_PROC1P,
ARGCHECK_OBJ_PROC1_OPT,
ARGCHECK_PROC1_THUNK,
ARGCHECK_ENVIRONMENT,
ARGCHECK_OBJ_ENVIRONMENT_OPT,
ARGCHECK_IPORT,
ARGCHECK_IPORT_OPT,
ARGCHECK_K_IPORT_OPT,
ARGCHECK_OPORT,
ARGCHECK_OPORT_OPT,
ARGCHECK_PORT,
ARGCHECK_OBJ_OPORT_OPT,
ARGCHECK_CHAR_OPORT_OPT,
ARGCHECK_U8_OPORT_OPT,
ARGCHECK_IPORT_OPT_BOOLEAN_OPT,
ARGCHECK_OPORT_OPT_BOOLEAN_OPT,
ABS_X,
TOEXACT_Z,
ADD_Z_ETC,
MUL_Z_ETC,
SUB_Z_Z_ETC,
DIV_Z_Z_ETC,
QUO_N_N,
REM_N_N,
MQU_N_N,
MLO_N_N,
E_Z_Z_Z_ETC,
L_X_X_X_ETC,
G_X_X_X_ETC,
LE_X_X_X_ETC,
GE_X_X_X_ETC,
GCD_N_ETC,
LCM_N_ETC,
EXPT_Z_Z,
CAR_PAIR,
CDR_PAIR,
CAAR_PAIR,
CADR_PAIR,
CDAR_PAIR,
CDDR_PAIR,
NOT_OBJ,
EQ_OBJ_OBJ,
EQV_OBJ_OBJ,
ISNULL_OBJ,
ISPAIR_OBJ,
LENGTH_LIST,
LENGTH_STRING,
REF_STRING_INDEX,
SET_STRING_INDEX_CHAR,
LENGTH_VECTOR,
REF_VECTOR_INDEX,
SET_VECTOR_INDEX_OBJ
};")
; special return values (magical immediates)
(%definition "#define ARCRES_ITAG 6")
(%localdef "#define ACRES_APPLY mkimm(0, ARCRES_ITAG)")
(%localdef "#define ACRES_BADPROC mkimm(1, ARCRES_ITAG)")
(%localdef "#define ACRES_BADARGC mkimm(2, ARCRES_ITAG)")
(%localdef "#define ACRES_BADTYPE mkimm(3, ARCRES_ITAG)")
(%localdef "#define ACRES_BADINDEX mkimm(4, ARCRES_ITAG)")
(%localdef "#define ACRES_BADRANGE mkimm(5, ARCRES_ITAG)")
(%localdef "#define ACRES_ZERODIV mkimm(6, ARCRES_ITAG)")
(%localdef "#define ACRES_FIXOVER mkimm(7, ARCRES_ITAG)")
(define-syntax acres-special?
(syntax-rules () [(_ x) (%prim "bool(isimm(obj_from_$arg, ARCRES_ITAG))" x)]))
(define-syntax enum (syntax-rules () [(_ s) (%prim #&(string-append "fixnum(" #&(id->string s) ")"))]))
(define-syntax argcheck->annotation enum)
(%localdef "static long listlen(obj l) {
obj s = l; long n = 0;
for (;;) {
if (isnull(l)) return n;
else if (!ispair(l)) return -1;
else if (++n, (l = cdr(l)) == s) return -1;
else if (isnull(l)) return n;
else if (!ispair(l)) return -1;
else if (++n, (l = cdr(l)) == s) return -1;
else s = cdr(s);
}
}")
(%localdef "static int isalist(obj l) {
obj s = l;
for (;;) {
if (isnull(l)) return 1;
else if (!ispair(l) || !ispair(car(l))) return 0;
else if ((l = cdr(l)) == s) return 0;
else if (isnull(l)) return 1;
else if (!ispair(l) || !ispair(car(l))) return 0;
else if ((l = cdr(l)) == s) return 0;
else s = cdr(s);
}
}")
(%localdef "static int isu8list(obj l) {
obj s = l;
for (;;) {
if (isnull(l)) return 1;
else if (!ispair(l) || !is_byte_obj(car(l))) return 0;
else if ((l = cdr(l)) == s) return 0;
else if (isnull(l)) return 1;
else if (!ispair(l) || !is_byte_obj(car(l))) return 0;
else if ((l = cdr(l)) == s) return 0;
else s = cdr(s);
}
}")
(%localdef "static int isenvironment(obj l) {
obj s = l;
for (;;) {
if (isnull(l) || isprocedure(l)) return 1;
else if (!ispair(l) || !ispair(car(l))) return 0;
else if ((l = cdr(l)) == s) return 0;
else if (isnull(l) || isprocedure(l)) return 1;
else if (!ispair(l) || !ispair(car(l))) return 0;
else if ((l = cdr(l)) == s) return 0;
else s = cdr(s);
}
}")
(%localdef "static int iexpt(long *px, long y) {
if (y < 0) return 0; /* consistent with the op/fxpow */
retry: if (y == 0) return (*px = 1, 1); if (y == 1) return 1;
if (y % 2 == 1) {
long long zz; long z = *px; if (!iexpt(&z, y-1)) return 0;
zz = *px * (long long)z; if (zz < FIXNUM_MIN || zz > FIXNUM_MAX) return 0;
*px = (long)zz; return 1;
} else {
long long zz = *px; zz *= zz;
if (zz < FIXNUM_MIN || zz > FIXNUM_MAX) return 0;
*px = (long)zz; y /= 2; goto retry;
}
}")
(%localdef "static int peekann(obj p) {
int len, ann; obj h;
if (!p || !isobjptr(p)) return FIXNUM_MIN; /* not a heap object */
h = objptr_from_obj(p)[-1]; if (isaptr(h)) return FIXNUM_MIN; /* native */
if (size_from_obj(h) < 1 || notaptr(hblkref(p, 0))) return FIXNUM_MIN; /* no code */
len = hblklen(p); assert(len >= 2); /* must have code & ann */
ann = fixnum_from_obj(hblkref(p, len-1)); return ann;
}")
(%localdef "static int isthunk(obj p) {
int ann = peekann(p);
if (ann == FIXNUM_MIN) return 0; /* not a proc */
if (ann >= 0) { /* ac check only */
int ac = 0; return (ann / 1000 <= ac && ac <= ann % 1000);
} else switch (ann) {
case ARGCHECK_N_OPT:
case ARGCHECK_N_ETC:
case ARGCHECK_Z_ETC:
case ARGCHECK_X_ETC:
case ARGCHECK_CHAR_ETC:
case ARGCHECK_STRING_ETC:
case ARGCHECK_VECTOR_ETC:
case ARGCHECK_U8VECTOR_ETC:
case ARGCHECK_IPORT_OPT:
case ARGCHECK_OPORT_OPT:
case ARGCHECK_IPORT_OPT_BOOLEAN_OPT:
case ARGCHECK_OPORT_OPT_BOOLEAN_OPT:
case ADD_Z_ETC:
case MUL_Z_ETC:
case GCD_N_ETC:
case LCM_N_ETC:
return 1;
default:
return 0;
}
}")
(%localdef "static int isproc1cc(obj p) {
int ann = peekann(p);
if (ann == FIXNUM_MIN) return 0; /* not a proc */
if (ann >= 0) { /* ac check only */
int ac = 1; return (ann / 1000 <= ac && ac <= ann % 1000);
} else switch (ann) {
case ARGCHECK_OBJ_PROC1_OPT:
case ARGCHECK_PROC:
case ARGCHECK_PROC1CC:
case ARGCHECK_OBJ_ENVIRONMENT_OPT:
case ARGCHECK_OBJ_OPORT_OPT:
case NOT_OBJ:
case ISNULL_OBJ:
case ISPAIR_OBJ:
return 1;
default:
return 0;
}
}")
(%localdef "static int isproc1ip(obj p) {
int ann = peekann(p);
if (ann == FIXNUM_MIN) return 0; /* not a proc */
if (ann >= 0) { /* ac check only */
int ac = 1; return (ann / 1000 <= ac && ac <= ann % 1000);
} else switch (ann) {
case ARGCHECK_OBJ_PROC1_OPT:
case ARGCHECK_IPORT:
case ARGCHECK_IPORT_OPT:
case ARGCHECK_PORT:
case ARGCHECK_OBJ_OPORT_OPT:
case ARGCHECK_IPORT_OPT_BOOLEAN_OPT:
case NOT_OBJ:
case ISNULL_OBJ:
case ISPAIR_OBJ:
return 1;
default:
return 0;
}
}")
(%localdef "static int isproc1op(obj p) {
int ann = peekann(p);
if (ann == FIXNUM_MIN) return 0; /* not a proc */
if (ann >= 0) { /* ac check only */
int ac = 1; return (ann / 1000 <= ac && ac <= ann % 1000);
} else switch (ann) {
case ARGCHECK_OBJ_PROC1_OPT:
case ARGCHECK_OPORT:
case ARGCHECK_OPORT_OPT:
case ARGCHECK_PORT:
case ARGCHECK_OBJ_OPORT_OPT:
case ARGCHECK_OPORT_OPT_BOOLEAN_OPT:
case NOT_OBJ:
case ISNULL_OBJ:
case ISPAIR_OBJ:
return 1;
default:
return 0;
}
}")
(%localdef "static int isproc1(obj p) {
int ann = peekann(p);
if (ann == FIXNUM_MIN) return 0; /* not a proc */
if (ann >= 0) { /* ac check only */
int ac = 1; return (ann / 1000 <= ac && ac <= ann % 1000);
} else switch (ann) {
case ARGCHECK_N_OPT:
case ARGCHECK_N:
case ARGCHECK_N_ETC:
case ARGCHECK_Q:
case ARGCHECK_K:
case ARGCHECK_Z:
case ARGCHECK_Z_ETC:
case ARGCHECK_X:
case ARGCHECK_X_ETC:
case ARGCHECK_X_X_ETC:
case ARGCHECK_Z_Z_OPT:
case ARGCHECK_Z_OR_X_X:
case ARGCHECK_Z_RADIX_OPT:
case ARGCHECK_K_CHAR_OPT:
case ARGCHECK_K_OBJ_OPT:
case ARGCHECK_BOX:
case ARGCHECK_PAIR:
case ARGCHECK_LIST:
case ARGCHECK_LIST_ETC:
case ARGCHECK_LIST_ETC_OBJ_OPT:
case ARGCHECK_ALIST:
case ARGCHECK_U8LIST:
case ARGCHECK_SYMBOL:
case ARGCHECK_CHAR:
case ARGCHECK_CHAR_ETC:
case ARGCHECK_STRING:
case ARGCHECK_STRING_ETC:
case ARGCHECK_STRING_OBJ_ETC:
case ARGCHECK_STRING_RADIX_OPT:
case ARGCHECK_VECTOR:
case ARGCHECK_VECTOR_ETC:
case ARGCHECK_U8_ETC:
case ARGCHECK_K_U8_OPT:
case ARGCHECK_U8VECTOR:
case ARGCHECK_U8VECTOR_ETC:
case ARGCHECK_RECORD:
case ARGCHECK_PROC:
case ARGCHECK_PROC1CC:
case ARGCHECK_OBJ_PROC1_OPT:
case ARGCHECK_ENVIRONMENT:
case ARGCHECK_OBJ_ENVIRONMENT_OPT:
case ARGCHECK_IPORT:
case ARGCHECK_IPORT_OPT:
case ARGCHECK_K_IPORT_OPT:
case ARGCHECK_OPORT:
case ARGCHECK_OPORT_OPT:
case ARGCHECK_PORT:
case ARGCHECK_OBJ_OPORT_OPT:
case ARGCHECK_CHAR_OPORT_OPT:
case ARGCHECK_U8_OPORT_OPT:
case ARGCHECK_IPORT_OPT_BOOLEAN_OPT:
case ARGCHECK_OPORT_OPT_BOOLEAN_OPT:
case ABS_X:
case TOEXACT_Z:
case ADD_Z_ETC:
case MUL_Z_ETC:
case SUB_Z_Z_ETC:
case DIV_Z_Z_ETC:
case GCD_N_ETC:
case LCM_N_ETC:
case CAR_PAIR:
case CDR_PAIR:
case CAAR_PAIR:
case CADR_PAIR:
case CDAR_PAIR:
case CDDR_PAIR:
case NOT_OBJ:
case ISNULL_OBJ:
case ISPAIR_OBJ:
case LENGTH_LIST:
case LENGTH_STRING:
case LENGTH_VECTOR:
return 1;
default:
return 0;
}
}")
(%localdef "static int isradix(obj o) {
if (!is_fixnum_obj(o)) return 0;
else { long i = fixnum_from_obj(o); return (i == 2 || i == 8 || i == 10 || i == 16); }
}")
(%include <stdarg.h>)
(%localdef "obj argcheck(obj p, long ac, obj l, ...) {
int ann; assert(ac >= 0);
ann = peekann(p); if (ann == FIXNUM_MIN) return ACRES_BADPROC; /* not a proc */
if (ann >= 0) { /* ac check only */
if (ann / 1000 <= ac && ac <= ann % 1000) return ACRES_APPLY; /* ac ok */
else return ACRES_BADARGC; /* a closure, but won't accept ac */
} else { /* full argument check */
obj res = ACRES_APPLY; va_list args;
va_start(args, l);
switch (ann) {
/* regular arg checks */
case ARGCHECK_BOOLEAN_BOOLEAN_BOOLEAN_ETC:
if (ac < 2) res = ACRES_BADARGC; else while (ac-- > 0) {
obj o; if (l) { o = car(l); l = cdr(l); } else o = va_arg(args, obj);
if (!is_bool_obj(o)) { res = ACRES_BADTYPE; break; }
} break;
case ARGCHECK_N_OPT: if (ac == 0) break; /* else fall thru */
case ARGCHECK_N: if (ac != 1) { res = ACRES_BADARGC; break; } else goto int_etc;
case ARGCHECK_N_N: if (ac != 2) { res = ACRES_BADARGC; break; } else goto int_etc;
case ARGCHECK_N_ETC: goto int_etc;
case ARGCHECK_Q: if (ac != 1) { res = ACRES_BADARGC; break; } else goto int_etc;
int_etc:
while (ac-- > 0) {
obj o; if (l) { o = car(l); l = cdr(l); } else o = va_arg(args, obj);
if (is_fixnum_obj(o) || (is_flonum_obj(o) && flisint(flonum_from_obj(o)))) continue;
res = ACRES_BADTYPE; break;
} break;
case ARGCHECK_K:
if (ac == 1) {
obj o; if (l) o = car(l); else o = va_arg(args, obj);
if (!is_fixnum_obj(o) || fixnum_from_obj(o) < 0) res = ACRES_BADTYPE;
} else res = ACRES_BADARGC;
break;
case ARGCHECK_Z: if (ac != 1) { res = ACRES_BADARGC; break; } else goto real_etc;
case ARGCHECK_Z_Z: if (ac != 2) { res = ACRES_BADARGC; break; } else goto real_etc;
case ARGCHECK_Z_ETC: goto real_etc;
case ARGCHECK_Z_Z_ETC: if (ac < 1) { res = ACRES_BADARGC; break; } else goto real_etc;
case ARGCHECK_Z_Z_Z_ETC: if (ac < 2) { res = ACRES_BADARGC; break; } else goto real_etc;
case ARGCHECK_X: if (ac != 1) { res = ACRES_BADARGC; break; } else goto real_etc;
case ARGCHECK_X_X: if (ac != 2) { res = ACRES_BADARGC; break; } else goto real_etc;
case ARGCHECK_X_ETC: goto real_etc;
case ARGCHECK_X_X_ETC: if (ac < 1) { res = ACRES_BADARGC; break; } else goto real_etc;
case ARGCHECK_X_X_X_ETC: if (ac < 2) { res = ACRES_BADARGC; break; } else goto real_etc;
case ARGCHECK_Z_Z_OPT: /* same as below */
case ARGCHECK_Z_OR_X_X: if (ac < 1 || ac > 2) { res = ACRES_BADARGC; break; } else goto real_etc;
real_etc:
while (ac-- > 0) {
obj o; if (l) { o = car(l); l = cdr(l); } else o = va_arg(args, obj);
if (!is_fixnum_obj(o) && !is_flonum_obj(o)) { res = ACRES_BADTYPE; break; }
} break;
case ARGCHECK_Z_RADIX_OPT:
if (ac == 1) {
obj o; if (l) o = car(l); else o = va_arg(args, obj);
if (!is_fixnum_obj(o) && !is_flonum_obj(o)) res = ACRES_BADTYPE;
} else if (ac == 2) {
obj o1, o2; if (l) { o1 = car(l); l = cdr(l); o2 = car(l); } else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); }
if (!is_fixnum_obj(o1) && !is_flonum_obj(o1)) res = ACRES_BADTYPE;
else if (!isradix(o2)) res = ACRES_BADTYPE;
} else res = ACRES_BADARGC;
break;
case ARGCHECK_K_CHAR_OPT:
if (ac == 1) {
obj o; if (l) o = car(l); else o = va_arg(args, obj);
if (!is_fixnum_obj(o) || fixnum_from_obj(o) < 0) res = ACRES_BADTYPE;
} else if (ac == 2) {
obj o1, o2; if (l) { o1 = car(l); l = cdr(l); o2 = car(l); } else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); }
if (!is_fixnum_obj(o1) || fixnum_from_obj(o1) < 0) res = ACRES_BADTYPE;
else if (!ischar(o2)) res = ACRES_BADTYPE;
} else res = ACRES_BADARGC;
break;
case ARGCHECK_K_OBJ_OPT:
if (ac == 1 || ac == 2) {
obj o; if (l) o = car(l); else o = va_arg(args, obj);
if (!is_fixnum_obj(o) || fixnum_from_obj(o) < 0) res = ACRES_BADTYPE;
} else res = ACRES_BADARGC;
break;
case ARGCHECK_BOX:
if (ac != 1) res = ACRES_BADARGC; else {
obj o; if (l) o = car(l); else o = va_arg(args, obj);
if (!isbox(o)) res = ACRES_BADTYPE;
} break;
case ARGCHECK_PAIR:
if (ac != 1) res = ACRES_BADARGC; else {
obj o; if (l) o = car(l); else o = va_arg(args, obj);
if (!ispair(o)) res = ACRES_BADTYPE;
} break;
case ARGCHECK_PAIR_OBJ:
if (ac != 2) res = ACRES_BADARGC; else {
obj o; if (l) o = car(l); else o = va_arg(args, obj);
if (!ispair(o)) res = ACRES_BADTYPE;
} break;
case ARGCHECK_LIST:
if (ac != 1) res = ACRES_BADARGC; else {
obj o; if (l) o = car(l); else o = va_arg(args, obj);
if (!islist(o)) res = ACRES_BADTYPE;
} break;
case ARGCHECK_LIST_ETC:
while (ac-- > 0) {
obj o; if (l) { o = car(l); l = cdr(l); } else o = va_arg(args, obj);
if (!islist(o)) { res = ACRES_BADTYPE; break; }
} break;
case ARGCHECK_LIST_ETC_OBJ_OPT:
while (ac-- > 1) {
obj o; if (l) { o = car(l); l = cdr(l); } else o = va_arg(args, obj);
if (!islist(o)) { res = ACRES_BADTYPE; break; }
} break;
case ARGCHECK_OBJ_LIST:
if (ac != 2) res = ACRES_BADARGC; else {
obj o1, o2; if (l) { o1 = car(l); l = cdr(l); o2 = car(l); } else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); }
if (!islist(o2)) res = ACRES_BADTYPE;
} break;
case ARGCHECK_ALIST:
if (ac != 1) res = ACRES_BADARGC; else {
obj o; if (l) o = car(l); else o = va_arg(args, obj);
if (!isalist(o)) res = ACRES_BADTYPE;
} break;
case ARGCHECK_U8LIST:
if (ac != 1) res = ACRES_BADARGC; else {
obj o; if (l) o = car(l); else o = va_arg(args, obj);
if (!isu8list(o)) res = ACRES_BADTYPE;
} break;
case ARGCHECK_OBJ_ALIST:
if (ac != 2) res = ACRES_BADARGC; else {
obj o1, o2; if (l) { o1 = car(l); l = cdr(l); o2 = car(l); } else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); }
if (!isalist(o2)) res = ACRES_BADTYPE;
} break;
case ARGCHECK_SYMBOL:
if (ac != 1) res = ACRES_BADARGC; else {
obj o; if (l) o = car(l); else o = va_arg(args, obj);
if (!issymbol(o)) res = ACRES_BADTYPE;
} break;
case ARGCHECK_SYMBOL_SYMBOL_SYMBOL_ETC:
if (ac < 2) res = ACRES_BADARGC; else while (ac-- > 0) {
obj o; if (l) { o = car(l); l = cdr(l); } else o = va_arg(args, obj);
if (!issymbol(o)) { res = ACRES_BADTYPE; break; }
} break;
case ARGCHECK_CHAR:
if (ac != 1) res = ACRES_BADARGC; else {
obj o; if (l) o = car(l); else o = va_arg(args, obj);
if (!ischar(o)) res = ACRES_BADTYPE;
} break;
case ARGCHECK_CHAR_CHAR:
if (ac != 2) res = ACRES_BADARGC; else {
obj o1, o2; if (l) { o1 = car(l); l = cdr(l); o2 = car(l); } else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); }
if (!ischar(o1) || !ischar(o2)) res = ACRES_BADTYPE;
} break;
case ARGCHECK_CHAR_CHAR_CHAR_ETC:
if (ac < 2) res = ACRES_BADARGC; else while (ac-- > 0) {
obj o; if (l) { o = car(l); l = cdr(l); } else o = va_arg(args, obj);
if (!ischar(o)) { res = ACRES_BADTYPE; break; }
} break;
case ARGCHECK_CHAR_ETC:
while (ac-- > 0) {
obj o; if (l) { o = car(l); l = cdr(l); } else o = va_arg(args, obj);
if (!ischar(o)) { res = ACRES_BADTYPE; break; }
} break;
case ARGCHECK_STRING:
if (ac != 1) res = ACRES_BADARGC; else {
obj o; if (l) o = car(l); else o = va_arg(args, obj);
if (!isstring(o)) res = ACRES_BADTYPE;
} break;
case ARGCHECK_STRING_STRING:
if (ac != 2) res = ACRES_BADARGC; else {
obj o1, o2; if (l) { o1 = car(l); l = cdr(l); o2 = car(l); } else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); }
if (!isstring(o1) || !isstring(o2)) res = ACRES_BADTYPE;
} break;
case ARGCHECK_STRING_STRING_STRING_ETC:
if (ac < 2) res = ACRES_BADARGC; else while (ac-- > 0) {
obj o; if (l) { o = car(l); l = cdr(l); } else o = va_arg(args, obj);
if (!isstring(o)) { res = ACRES_BADTYPE; break; }
} break;
case ARGCHECK_STRING_CHAR:
if (ac != 2) res = ACRES_BADARGC; else {
obj o1, o2; if (l) { o1 = car(l); l = cdr(l); o2 = car(l); } else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); }
if (!isstring(o1) || !ischar(o2)) res = ACRES_BADTYPE;
} break;
case ARGCHECK_STRING_ETC:
while (ac-- > 0) {
obj o; if (l) { o = car(l); l = cdr(l); } else o = va_arg(args, obj);
if (!isstring(o)) { res = ACRES_BADTYPE; break; }
} break;
case ARGCHECK_STRING_OBJ_ETC:
if (ac < 1) res = ACRES_BADARGC; else {
obj o; if (l) o = car(l); else o = va_arg(args, obj);
if (!isstring(o)) res = ACRES_BADTYPE;
} break;
case ARGCHECK_STRING_RADIX_OPT:
if (ac == 1) {
obj o; if (l) o = car(l); else o = va_arg(args, obj);
if (!isstring(o)) res = ACRES_BADTYPE;
} else if (ac == 2) {
obj o1, o2; if (l) { o1 = car(l); l = cdr(l); o2 = car(l); } else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); }
if (!isstring(o1) || !isradix(o2)) res = ACRES_BADTYPE;
} else res = ACRES_BADARGC;
break;
case ARGCHECK_STRING_INDEX:
if (ac != 2) res = ACRES_BADARGC; else {
obj o1, o2; if (l) { o1 = car(l); l = cdr(l); o2 = car(l); } else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); }
if (!isstring(o1) || !is_fixnum_obj(o2)) res = ACRES_BADTYPE;
else { long len = stringlen(o1), n = fixnum_from_obj(o2); if (n < 0 || n >= len) res = ACRES_BADINDEX; }
} break;
case ARGCHECK_STRING_INDEX_CHAR:
if (ac != 3) res = ACRES_BADARGC; else {
obj o1, o2, o3;
if (l) { o1 = car(l); l = cdr(l); o2 = car(l); l = cdr(l); o3 = car(l); }
else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); o3 = va_arg(args, obj); }
if (!isstring(o1) || !is_fixnum_obj(o2) || !ischar(o3)) res = ACRES_BADTYPE;
else { long len = stringlen(o1), n = fixnum_from_obj(o2); if (n < 0 || n >= len) res = ACRES_BADINDEX; }
} break;
case ARGCHECK_STRING_START_END:
if (ac != 3) res = ACRES_BADARGC; else {
obj o1, o2, o3;
if (l) { o1 = car(l); l = cdr(l); o2 = car(l); l = cdr(l); o3 = car(l); }
else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); o3 = va_arg(args, obj); }
if (!isstring(o1) || !is_fixnum_obj(o2) || !is_fixnum_obj(o3)) res = ACRES_BADTYPE;
else { long len = stringlen(o1), s = fixnum_from_obj(o2), e = fixnum_from_obj(o3);
if (s < 0 || s > e || e > len) res = ACRES_BADRANGE; }
} break;
case ARGCHECK_STRING_INDEX_STRING_START_END:
if (ac != 5) res = ACRES_BADARGC; else {
obj o1, o2, o3, o4, o5; long tlen = -1;
if (l) { o1 = car(l); l = cdr(l); o2 = car(l); l = cdr(l); o3 = car(l); l = cdr(l); o4 = car(l); l = cdr(l); o5 = car(l); }
else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); o3 = va_arg(args, obj); o4 = va_arg(args, obj); o5 = va_arg(args, obj); }
if (!isstring(o1) || !is_fixnum_obj(o2)) res = ACRES_BADTYPE;
else { long len = stringlen(o1), n = fixnum_from_obj(o2); if (n < 0 || n >= len) res = ACRES_BADINDEX; else tlen = len-n; }
if (!isstring(o3) || !is_fixnum_obj(o4) || !is_fixnum_obj(o5)) res = ACRES_BADTYPE;
else { long len = stringlen(o3), s = fixnum_from_obj(o4), e = fixnum_from_obj(o5);
if (s < 0 || s > e || e > len || e-s > tlen) res = ACRES_BADRANGE; }
} break;
case ARGCHECK_STRING_CHAR_START_END:
if (ac != 4) res = ACRES_BADARGC; else {
obj o1, o2, o3, o4;
if (l) { o1 = car(l); l = cdr(l); o2 = car(l); l = cdr(l); o3 = car(l); l = cdr(l); o4 = car(l); }
else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); o3 = va_arg(args, obj); o4 = va_arg(args, obj); }
if (!isstring(o1) || !ischar(o2) || !is_fixnum_obj(o3) || !is_fixnum_obj(o3)) res = ACRES_BADTYPE;
else { long len = stringlen(o1), s = fixnum_from_obj(o3), e = fixnum_from_obj(o4);
if (s < 0 || s > e || e > len) res = ACRES_BADRANGE; }
} break;
case ARGCHECK_STRING_START_END_IPORT:
if (ac != 4) res = ACRES_BADARGC; else {
obj o1, o2, o3, o4;
if (l) { o1 = car(l); l = cdr(l); o2 = car(l); l = cdr(l); o3 = car(l); l = cdr(l); o4 = car(l); }
else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); o3 = va_arg(args, obj); o4 = va_arg(args, obj); }
if (!isstring(o1) || !is_fixnum_obj(o2) || !is_fixnum_obj(o3)) res = ACRES_BADTYPE;
else { long len = stringlen(o1), s = fixnum_from_obj(o2), e = fixnum_from_obj(o3);
if (s < 0 || s > e || e > len) res = ACRES_BADRANGE; }
if (!isiport(o4)) res = ACRES_BADTYPE;
} break;
case ARGCHECK_STRING_START_END_OPORT:
if (ac != 4) res = ACRES_BADARGC; else {
obj o1, o2, o3, o4;
if (l) { o1 = car(l); l = cdr(l); o2 = car(l); l = cdr(l); o3 = car(l); l = cdr(l); o4 = car(l); }
else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); o3 = va_arg(args, obj); o4 = va_arg(args, obj); }
if (!isstring(o1) || !is_fixnum_obj(o2) || !is_fixnum_obj(o3)) res = ACRES_BADTYPE;
else { long len = stringlen(o1), s = fixnum_from_obj(o2), e = fixnum_from_obj(o3);
if (s < 0 || s > e || e > len) res = ACRES_BADRANGE; }
if (!isoport(o4)) res = ACRES_BADTYPE;
} break;
case ARGCHECK_VECTOR:
if (ac != 1) res = ACRES_BADARGC; else {
obj o; if (l) o = car(l); else o = va_arg(args, obj);
if (!isvector(o)) res = ACRES_BADTYPE;
} break;
case ARGCHECK_VECTOR_ETC:
while (ac-- > 0) {
obj o; if (l) { o = car(l); l = cdr(l); } else o = va_arg(args, obj);
if (!isvector(o)) { res = ACRES_BADTYPE; break; }
} break;
case ARGCHECK_VECTOR_INDEX:
if (ac != 2) res = ACRES_BADARGC; else {
obj o1, o2; if (l) { o1 = car(l); l = cdr(l); o2 = car(l); } else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); }
if (!isvector(o1) || !is_fixnum_obj(o2)) res = ACRES_BADTYPE;
else { long len = vectorlen(o1), n = fixnum_from_obj(o2); if (n < 0 || n >= len) res = ACRES_BADINDEX; }
} break;
case ARGCHECK_VECTOR_INDEX_OBJ:
if (ac != 3) res = ACRES_BADARGC; else {
obj o1, o2; if (l) { o1 = car(l); l = cdr(l); o2 = car(l); } else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); }
if (!isvector(o1) || !is_fixnum_obj(o2)) res = ACRES_BADTYPE;
else { long len = vectorlen(o1), n = fixnum_from_obj(o2); if (n < 0 || n >= len) res = ACRES_BADINDEX; }
} break;
case ARGCHECK_VECTOR_START_END:
if (ac != 3) res = ACRES_BADARGC; else {
obj o1, o2, o3;
if (l) { o1 = car(l); l = cdr(l); o2 = car(l); l = cdr(l); o3 = car(l); }
else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); o3 = va_arg(args, obj); }
if (!isvector(o1) || !is_fixnum_obj(o2) || !is_fixnum_obj(o3)) res = ACRES_BADTYPE;
else { long len = vectorlen(o1), s = fixnum_from_obj(o2), e = fixnum_from_obj(o3);
if (s < 0 || s > e || e > len) res = ACRES_BADRANGE; }
} break;
case ARGCHECK_VECTOR_INDEX_VECTOR_START_END:
if (ac != 5) res = ACRES_BADARGC; else {
obj o1, o2, o3, o4, o5; long tlen = -1;
if (l) { o1 = car(l); l = cdr(l); o2 = car(l); l = cdr(l); o3 = car(l); l = cdr(l); o4 = car(l); l = cdr(l); o5 = car(l); }
else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); o3 = va_arg(args, obj); o4 = va_arg(args, obj); o5 = va_arg(args, obj); }
if (!isvector(o1) || !is_fixnum_obj(o2)) res = ACRES_BADTYPE;
else { long len = vectorlen(o1), n = fixnum_from_obj(o2); if (n < 0 || n >= len) res = ACRES_BADINDEX; else tlen = len-n; }
if (!isvector(o3) || !is_fixnum_obj(o4) || !is_fixnum_obj(o5)) res = ACRES_BADTYPE;
else { long len = vectorlen(o3), s = fixnum_from_obj(o4), e = fixnum_from_obj(o5);
if (s < 0 || s > e || e > len || e-s > tlen) res = ACRES_BADRANGE; }
} break;
case ARGCHECK_VECTOR_OBJ_START_END:
if (ac != 4) res = ACRES_BADARGC; else {
obj o1, o2, o3, o4;
if (l) { o1 = car(l); l = cdr(l); o2 = car(l); l = cdr(l); o3 = car(l); l = cdr(l); o4 = car(l); }
else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); o3 = va_arg(args, obj); o4 = va_arg(args, obj); }
if (!isvector(o1) || !is_fixnum_obj(o3) || !is_fixnum_obj(o3)) res = ACRES_BADTYPE;
else { long len = vectorlen(o1), s = fixnum_from_obj(o3), e = fixnum_from_obj(o4);
if (s < 0 || s > e || e > len) res = ACRES_BADRANGE; }
} break;
case ARGCHECK_VECTOR_OBJ:
if (ac != 2) res = ACRES_BADARGC; else {
obj o; if (l) o = car(l); else o = va_arg(args, obj);
if (!isvector(o)) res = ACRES_BADTYPE;
} break;
case ARGCHECK_U8_ETC:
while (ac-- > 0) {
obj o; if (l) { o = car(l); l = cdr(l); } else o = va_arg(args, obj);
if (!is_byte_obj(o)) { res = ACRES_BADTYPE; break; }
} break;
case ARGCHECK_K_U8_OPT:
if (ac == 1) {
obj o; if (l) o = car(l); else o = va_arg(args, obj);
if (!is_fixnum_obj(o) || fixnum_from_obj(o) < 0) res = ACRES_BADTYPE;
} else if (ac == 2) {
obj o1, o2; if (l) { o1 = car(l); l = cdr(l); o2 = car(l); } else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); }
if (!is_fixnum_obj(o1) || fixnum_from_obj(o1) < 0) res = ACRES_BADTYPE;
else if (!is_byte_obj(o2)) res = ACRES_BADTYPE;
} else res = ACRES_BADARGC;
break;
case ARGCHECK_U8VECTOR:
if (ac != 1) res = ACRES_BADARGC; else {
obj o; if (l) o = car(l); else o = va_arg(args, obj);
if (!isbytevector(o)) res = ACRES_BADTYPE;
} break;
case ARGCHECK_U8VECTOR_U8VECTOR:
if (ac != 2) res = ACRES_BADARGC; else {
obj o1, o2; if (l) { o1 = car(l); l = cdr(l); o2 = car(l); } else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); }
if (!isbytevector(o1) || !isbytevector(o2)) res = ACRES_BADTYPE;
} break;
case ARGCHECK_U8VECTOR_ETC:
while (ac-- > 0) {
obj o; if (l) { o = car(l); l = cdr(l); } else o = va_arg(args, obj);
if (!isbytevector(o)) { res = ACRES_BADTYPE; break; }
} break;
case ARGCHECK_U8VECTOR_INDEX:
if (ac != 2) res = ACRES_BADARGC; else {
obj o1, o2; if (l) { o1 = car(l); l = cdr(l); o2 = car(l); } else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); }
if (!isbytevector(o1) || !is_fixnum_obj(o2)) res = ACRES_BADTYPE;
else { long len = bytevectorlen(o1), n = fixnum_from_obj(o2); if (n < 0 || n >= len) res = ACRES_BADINDEX; }
} break;
case ARGCHECK_U8VECTOR_INDEX_U8:
if (ac != 3) res = ACRES_BADARGC; else {
obj o1, o2, o3;
if (l) { o1 = car(l); l = cdr(l); o2 = car(l); l = cdr(l); o3 = car(l); }
else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); o3 = va_arg(args, obj); }
if (!isbytevector(o1) || !is_fixnum_obj(o2) || !is_byte_obj(o3)) res = ACRES_BADTYPE;
else { long len = bytevectorlen(o1), n = fixnum_from_obj(o2); if (n < 0 || n >= len) res = ACRES_BADINDEX; }
} break;
case ARGCHECK_U8VECTOR_START_END:
if (ac != 3) res = ACRES_BADARGC; else {
obj o1, o2, o3;
if (l) { o1 = car(l); l = cdr(l); o2 = car(l); l = cdr(l); o3 = car(l); }
else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); o3 = va_arg(args, obj); }
if (!isbytevector(o1) || !is_fixnum_obj(o2) || !is_fixnum_obj(o3)) res = ACRES_BADTYPE;
else { long len = bytevectorlen(o1), s = fixnum_from_obj(o2), e = fixnum_from_obj(o3);
if (s < 0 || s > e || e > len) res = ACRES_BADRANGE; }
} break;
case ARGCHECK_U8VECTOR_INDEX_U8VECTOR_START_END:
if (ac != 5) res = ACRES_BADARGC; else {
obj o1, o2, o3, o4, o5; long tlen = -1;
if (l) { o1 = car(l); l = cdr(l); o2 = car(l); l = cdr(l); o3 = car(l); l = cdr(l); o4 = car(l); l = cdr(l); o5 = car(l); }
else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); o3 = va_arg(args, obj); o4 = va_arg(args, obj); o5 = va_arg(args, obj); }
if (!isbytevector(o1) || !is_fixnum_obj(o2)) res = ACRES_BADTYPE;
else { long len = bytevectorlen(o1), n = fixnum_from_obj(o2); if (n < 0 || n >= len) res = ACRES_BADINDEX; else tlen = len-n; }
if (!isbytevector(o3) || !is_fixnum_obj(o4) || !is_fixnum_obj(o5)) res = ACRES_BADTYPE;
else { long len = bytevectorlen(o3), s = fixnum_from_obj(o4), e = fixnum_from_obj(o5);
if (s < 0 || s > e || e > len || e-s > tlen) res = ACRES_BADRANGE; }
} break;
case ARGCHECK_U8VECTOR_START_END_IPORT:
if (ac != 4) res = ACRES_BADARGC; else {
obj o1, o2, o3, o4;
if (l) { o1 = car(l); l = cdr(l); o2 = car(l); l = cdr(l); o3 = car(l); l = cdr(l); o4 = car(l); }
else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); o3 = va_arg(args, obj); o4 = va_arg(args, obj); }
if (!isbytevector(o1) || !is_fixnum_obj(o2) || !is_fixnum_obj(o3)) res = ACRES_BADTYPE;
else { long len = bytevectorlen(o1), s = fixnum_from_obj(o2), e = fixnum_from_obj(o3);
if (s < 0 || s > e || e > len) res = ACRES_BADRANGE; }
if (!isiport(o4)) res = ACRES_BADTYPE;
} break;
case ARGCHECK_U8VECTOR_START_END_OPORT:
if (ac != 4) res = ACRES_BADARGC; else {
obj o1, o2, o3, o4;
if (l) { o1 = car(l); l = cdr(l); o2 = car(l); l = cdr(l); o3 = car(l); l = cdr(l); o4 = car(l); }
else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); o3 = va_arg(args, obj); o4 = va_arg(args, obj); }
if (!isbytevector(o1) || !is_fixnum_obj(o2) || !is_fixnum_obj(o3)) res = ACRES_BADTYPE;
else { long len = bytevectorlen(o1), s = fixnum_from_obj(o2), e = fixnum_from_obj(o3);
if (s < 0 || s > e || e > len) res = ACRES_BADRANGE; }
if (!isoport(o4)) res = ACRES_BADTYPE;
} break;
case ARGCHECK_OBJ_K:
if (ac != 2) res = ACRES_BADARGC; else {
obj o1, o2; if (l) { o1 = car(l); l = cdr(l); o2 = car(l); } else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); }
if (!is_fixnum_obj(o2) || fixnum_from_obj(o2) < 0) res = ACRES_BADTYPE;
} break;
case ARGCHECK_RECORD:
if (ac != 1) res = ACRES_BADARGC; else {
obj o; if (l) o = car(l); else o = va_arg(args, obj);
if (!isrecord(o)) res = ACRES_BADTYPE;
} break;
case ARGCHECK_RECORD_INDEX:
if (ac != 2) res = ACRES_BADARGC; else {
obj o1, o2; if (l) { o1 = car(l); l = cdr(l); o2 = car(l); } else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); }
if (!isrecord(o1) || !is_fixnum_obj(o2)) res = ACRES_BADTYPE;
else { long len = recordlen(o1), n = fixnum_from_obj(o2); if (n < 0 || n >= len) res = ACRES_BADINDEX; }
} break;
case ARGCHECK_RECORD_INDEX_OBJ:
if (ac != 3) res = ACRES_BADARGC; else {
obj o1, o2; if (l) { o1 = car(l); l = cdr(l); o2 = car(l); } else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); }
if (!isrecord(o1) || !is_fixnum_obj(o2)) res = ACRES_BADTYPE;
else { long len = recordlen(o1), n = fixnum_from_obj(o2); if (n < 0 || n >= len) res = ACRES_BADINDEX; }
} break;
case ARGCHECK_PROC:
if (ac != 1) res = ACRES_BADARGC; else {
obj o; if (l) o = car(l); else o = va_arg(args, obj);
if (!isprocedure(o)) res = ACRES_BADTYPE;
} break;
case ARGCHECK_PROC_OBJ_ETC_LIST:
if (ac < 2) res = ACRES_BADARGC; else {
obj o; if (l) { o = car(l); l = cdr(l); } else o = va_arg(args, obj);
if (!isprocedure(o)) res = ACRES_BADTYPE;
else if (l) { long i = 1; while (++i < ac) l = cdr(l); o = car(l); if (!islist(o)) res = ACRES_BADTYPE; }
else { long i = 1; while (++i < ac) va_arg(args, obj); o = va_arg(args, obj); if (!islist(o)) res = ACRES_BADTYPE; }
} break;
case ARGCHECK_PROC1CC:
if (ac != 1) res = ACRES_BADARGC; else {
obj o; if (l) o = car(l); else o = va_arg(args, obj);
if (!isproc1cc(o)) res = ACRES_BADTYPE;
} break;
case ARGCHECK_THUNK_PROC:
if (ac != 2) res = ACRES_BADARGC; else {
obj o1, o2; if (l) { o1 = car(l); l = cdr(l); o2 = car(l); } else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); }
if (!isthunk(o1) || !isprocedure(o2)) res = ACRES_BADTYPE;
} break;
case ARGCHECK_THUNK_THUNK_THUNK:
if (ac != 3) res = ACRES_BADARGC; else {
obj o1, o2, o3;
if (l) { o1 = car(l); l = cdr(l); o2 = car(l); l = cdr(l); o3 = car(l); }
else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); o3 = va_arg(args, obj); }
if (!isthunk(o1) || !isthunk(o2) || !isthunk(o3)) res = ACRES_BADTYPE;
} break;
case ARGCHECK_STRING_THUNK:
if (ac != 2) res = ACRES_BADARGC; else {
obj o1, o2; if (l) { o1 = car(l); l = cdr(l); o2 = car(l); } else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); }
if (!isstring(o1) || !isthunk(o2)) res = ACRES_BADTYPE;
} break;
case ARGCHECK_IPORT_THUNK:
if (ac != 2) res = ACRES_BADARGC; else {
obj o1, o2; if (l) { o1 = car(l); l = cdr(l); o2 = car(l); } else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); }
if (!isiport(o1) || !isthunk(o2)) res = ACRES_BADTYPE;
} break;
case ARGCHECK_OPORT_THUNK:
if (ac != 2) res = ACRES_BADARGC; else {
obj o1, o2; if (l) { o1 = car(l); l = cdr(l); o2 = car(l); } else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); }
if (!isoport(o1) || !isthunk(o2)) res = ACRES_BADTYPE;
} break;
case ARGCHECK_STRING_PROC1IP:
if (ac != 2) res = ACRES_BADARGC; else {
obj o1, o2; if (l) { o1 = car(l); l = cdr(l); o2 = car(l); } else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); }
if (!isstring(o1) || !isproc1ip(o2)) res = ACRES_BADTYPE;
} break;
case ARGCHECK_STRING_PROC1OP:
if (ac != 2) res = ACRES_BADARGC; else {
obj o1, o2; if (l) { o1 = car(l); l = cdr(l); o2 = car(l); } else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); }
if (!isstring(o1) || !isproc1op(o2)) res = ACRES_BADTYPE;
} break;
case ARGCHECK_PORT_PROC1P:
if (ac != 2) res = ACRES_BADARGC; else {
obj o1, o2; if (l) { o1 = car(l); l = cdr(l); o2 = car(l); } else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); }
if (!((isiport(o1) && isproc1ip(o2)) || (isoport(o1) && isproc1op(o2)))) res = ACRES_BADTYPE;
} break;
case ARGCHECK_OBJ_PROC1_OPT:
if (ac == 1) {
/* ok, obj requires no check */
} else if (ac == 2) {
obj o1, o2; if (l) { o1 = car(l); l = cdr(l); o2 = car(l); } else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); }
if (!isproc1(o2)) res = ACRES_BADTYPE;
} else res = ACRES_BADARGC;
break;
case ARGCHECK_PROC1_THUNK:
if (ac != 2) res = ACRES_BADARGC; else {
obj o1, o2; if (l) { o1 = car(l); l = cdr(l); o2 = car(l); } else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); }
if (!isproc1(o1) || !isthunk(o2)) res = ACRES_BADTYPE;
} break;
case ARGCHECK_ENVIRONMENT:
if (ac != 1) res = ACRES_BADARGC; else {
obj o; if (l) o = car(l); else o = va_arg(args, obj);
if (!isenvironment(o)) res = ACRES_BADTYPE;
} break;
case ARGCHECK_OBJ_ENVIRONMENT_OPT:
if (ac == 1) {
/* ok, obj requires no check */
} else if (ac == 2) {
obj o1, o2; if (l) { o1 = car(l); l = cdr(l); o2 = car(l); } else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); }
if (!isenvironment(o2)) res = ACRES_BADTYPE;
} else res = ACRES_BADARGC;
break;
case ARGCHECK_IPORT_OPT:
if (ac == 0) break; /* else fall thru */
case ARGCHECK_IPORT:
if (ac != 1) res = ACRES_BADARGC; else {
obj o; if (l) o = car(l); else o = va_arg(args, obj);
if (!isiport(o)) res = ACRES_BADTYPE;
} break;
case ARGCHECK_K_IPORT_OPT:
if (ac == 1) {
obj o; if (l) o = car(l); else o = va_arg(args, obj);
if (!is_fixnum_obj(o) || fixnum_from_obj(o) < 0) res = ACRES_BADTYPE;
} else if (ac == 2) {
obj o1, o2; if (l) { o1 = car(l); l = cdr(l); o2 = car(l); } else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); }
if (!is_fixnum_obj(o1) || fixnum_from_obj(o1) < 0) res = ACRES_BADTYPE;
if (!isiport(o2)) res = ACRES_BADTYPE;
} else res = ACRES_BADARGC;
break;
case ARGCHECK_OPORT_OPT:
if (ac == 0) break; /* else fall thru */
case ARGCHECK_OPORT:
if (ac != 1) res = ACRES_BADARGC; else {
obj o; if (l) o = car(l); else o = va_arg(args, obj);
if (!isoport(o)) res = ACRES_BADTYPE;
} break;
case ARGCHECK_PORT:
if (ac != 1) res = ACRES_BADARGC; else {
obj o; if (l) o = car(l); else o = va_arg(args, obj);
if (!isiport(o) && !isoport(o)) res = ACRES_BADTYPE;
} break;
case ARGCHECK_OBJ_OPORT_OPT:
if (ac == 1) {
/* ok, obj requires no check */
} else if (ac == 2) {
obj o1, o2; if (l) { o1 = car(l); l = cdr(l); o2 = car(l); } else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); }
if (!isoport(o2)) res = ACRES_BADTYPE;
} else res = ACRES_BADARGC;
break;
case ARGCHECK_CHAR_OPORT_OPT:
if (ac == 1) {
obj o; if (l) o = car(l); else o = va_arg(args, obj);
if (!ischar(o)) res = ACRES_BADTYPE;
} else if (ac == 2) {
obj o1, o2; if (l) { o1 = car(l); l = cdr(l); o2 = car(l); } else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); }
if (!ischar(o1) || !isoport(o2)) res = ACRES_BADTYPE;
} else res = ACRES_BADARGC;
break;
case ARGCHECK_U8_OPORT_OPT:
if (ac == 1) {
obj o; if (l) o = car(l); else o = va_arg(args, obj);
if (!is_byte_obj(o)) res = ACRES_BADTYPE;
} else if (ac == 2) {
obj o1, o2; if (l) { o1 = car(l); l = cdr(l); o2 = car(l); } else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); }
if (!is_byte_obj(o1) || !isoport(o2)) res = ACRES_BADTYPE;
} else res = ACRES_BADARGC;
break;
case ARGCHECK_IPORT_OPT_BOOLEAN_OPT:
if (ac == 0) {
} else if (ac == 1) {
obj o; if (l) o = car(l); else o = va_arg(args, obj);
if (!isiport(o)) res = ACRES_BADTYPE;
} else if (ac == 2) {
obj o1, o2; if (l) { o1 = car(l); l = cdr(l); o2 = car(l); } else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); }
if (!isiport(o1) || !is_bool_obj(o2)) res = ACRES_BADTYPE;
} else res = ACRES_BADARGC;
break;
case ARGCHECK_OPORT_OPT_BOOLEAN_OPT:
if (ac == 0) {
} else if (ac == 1) {
obj o; if (l) o = car(l); else o = va_arg(args, obj);
if (!isoport(o)) res = ACRES_BADTYPE;
} else if (ac == 2) {
obj o1, o2; if (l) { o1 = car(l); l = cdr(l); o2 = car(l); } else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); }
if (!isoport(o1) || !is_bool_obj(o2)) res = ACRES_BADTYPE;
} else res = ACRES_BADARGC;
break;
/* special checks for popular operations; may return result if no allocation is needed */
case ABS_X:
if (ac != 1) res = ACRES_BADARGC; else {
long z; obj o; if (l) o = car(l); else o = va_arg(args, obj);
if (is_flonum_obj(o)) goto out;
if (!is_fixnum_obj(o)) { res = ACRES_BADTYPE; goto out; }
z = fixnum_from_obj(o); if (z == FIXNUM_MIN) { res = ACRES_FIXOVER; goto out; }
res = obj_from_fixnum(labs(z));
} break;
case TOEXACT_Z:
if (ac != 1) res = ACRES_BADARGC; else {
double f; long z; obj o; if (l) o = car(l); else o = va_arg(args, obj);
if (is_fixnum_obj(o)) { res = o; goto out; }
if (!is_flonum_obj(o)) { res = ACRES_BADTYPE; goto out; }
f = flonum_from_obj(o); z = (long)f;
if ((double)z != f || z < FIXNUM_MIN || z > FIXNUM_MAX) { res = ACRES_FIXOVER; goto out; }
res = obj_from_fixnum(z);
} break;
case ADD_Z_ETC:
if (ac < 2) goto real_etc; else {
long z = 0; while (ac-- > 0) {
obj o; if (l) { o = car(l); l = cdr(l); } else o = va_arg(args, obj);
if (is_flonum_obj(o)) goto real_etc; /* fl/mixed op won't overflow */
if (!is_fixnum_obj(o)) { res = ACRES_BADTYPE; goto out; }
z += fixnum_from_obj(o); if (z < FIXNUM_MIN || z > FIXNUM_MAX) { res = ACRES_FIXOVER; goto out; }
} res = obj_from_fixnum(z);
} break;
case MUL_Z_ETC:
if (ac < 2) goto real_etc; else {
long long z = 1; while (ac-- > 0) {
obj o; if (l) { o = car(l); l = cdr(l); } else o = va_arg(args, obj);
if (is_flonum_obj(o)) goto real_etc; /* fl/mixed op won't overflow */
if (!is_fixnum_obj(o)) { res = ACRES_BADTYPE; goto out; }
z *= fixnum_from_obj(o); if (z < FIXNUM_MIN || z > FIXNUM_MAX) { res = ACRES_FIXOVER; goto out; }
} res = obj_from_fixnum((long)z);
} break;
case SUB_Z_Z_ETC:
if (ac < 1) res = ACRES_BADARGC; else {
long z = 0, i = 0; while (ac-- > 0) {
obj o; if (l) { o = car(l); l = cdr(l); } else o = va_arg(args, obj);
if (is_flonum_obj(o)) goto real_etc; /* fl/mixed op won't overflow */
if (!is_fixnum_obj(o)) { res = ACRES_BADTYPE; goto out; }
if (!i++) { z = fixnum_from_obj(o); if (!ac) z = -z; } else z -= fixnum_from_obj(o);
if (z < FIXNUM_MIN || z > FIXNUM_MAX) { res = ACRES_FIXOVER; goto out; }
} res = obj_from_fixnum(z);
} break;
case DIV_Z_Z_ETC:
if (ac < 1) res = ACRES_BADARGC; else {
long z = 0, i = 0; while (ac-- > 0) {
obj o; if (l) { o = car(l); l = cdr(l); } else o = va_arg(args, obj);
if (is_flonum_obj(o)) goto real_etc; /* our fl/mixed op won't overflow or zerodiv */
if (!is_fixnum_obj(o)) { res = ACRES_BADTYPE; goto out; }
if ((i || !ac) && o == obj_from_fixnum(0)) { res = ACRES_ZERODIV; goto out; }
if (!i++) { z = fixnum_from_obj(o); if (!ac) { if (z != 1 && z != -1) goto out; } }
else { long x = fixnum_from_obj(o); if (z % x == 0) z /= x; else goto out; }
if (z < FIXNUM_MIN || z > FIXNUM_MAX) { res = ACRES_FIXOVER; goto out; }
} res = obj_from_fixnum(z);
} break;
case QUO_N_N:
if (ac != 2) res = ACRES_BADARGC; else {
obj o1, o2; if (l) { o1 = car(l); l = cdr(l); o2 = car(l); } else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); }
if (is_fixnum_obj(o1) && is_fixnum_obj(o2)) { long x = fixnum_from_obj(o1), y = fixnum_from_obj(o2);
res = (!y) ? ACRES_ZERODIV : (x == FIXNUM_MIN && y == -1) ? ACRES_FIXOVER : obj_from_fixnum(x / y);
} else if (!(is_fixnum_obj(o1) || (is_flonum_obj(o1) && flisint(flonum_from_obj(o1)))) ||
!(is_fixnum_obj(o2) || (is_flonum_obj(o2) && flisint(flonum_from_obj(o2))))) res = ACRES_BADTYPE;
} break;
case REM_N_N:
if (ac != 2) res = ACRES_BADARGC; else {
obj o1, o2; if (l) { o1 = car(l); l = cdr(l); o2 = car(l); } else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); }
if (is_fixnum_obj(o1) && is_fixnum_obj(o2)) { long x = fixnum_from_obj(o1), y = fixnum_from_obj(o2);
res = (!y) ? ACRES_ZERODIV : obj_from_fixnum(x % y);
} else if (!(is_fixnum_obj(o1) || (is_flonum_obj(o1) && flisint(flonum_from_obj(o1)))) ||
!(is_fixnum_obj(o2) || (is_flonum_obj(o2) && flisint(flonum_from_obj(o2))))) res = ACRES_BADTYPE;
} break;
case MQU_N_N:
if (ac != 2) res = ACRES_BADARGC; else {
obj o1, o2; if (l) { o1 = car(l); l = cdr(l); o2 = car(l); } else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); }
if (is_fixnum_obj(o1) && is_fixnum_obj(o2)) { long x = fixnum_from_obj(o1), y = fixnum_from_obj(o2);
if (!y) res = ACRES_ZERODIV; else if (x == FIXNUM_MIN && y == -1) res = ACRES_FIXOVER;
else { long q = x / y; res = obj_from_fixnum(((x < 0 && y > 0) || (x > 0 && y < 0)) ? q - 1 : q); }
} else if (!(is_fixnum_obj(o1) || (is_flonum_obj(o1) && flisint(flonum_from_obj(o1)))) ||
!(is_fixnum_obj(o2) || (is_flonum_obj(o2) && flisint(flonum_from_obj(o2))))) res = ACRES_BADTYPE;
} break;
case MLO_N_N:
if (ac != 2) res = ACRES_BADARGC; else {
obj o1, o2; if (l) { o1 = car(l); l = cdr(l); o2 = car(l); } else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); }
if (is_fixnum_obj(o1) && is_fixnum_obj(o2)) { long x = fixnum_from_obj(o1), y = fixnum_from_obj(o2);
if (!y) res = ACRES_ZERODIV; else { long r = x % y; res = obj_from_fixnum(((r < 0 && y > 0) || (r > 0 && y < 0)) ? r + y : r); }
} else if (!(is_fixnum_obj(o1) || (is_flonum_obj(o1) && flisint(flonum_from_obj(o1)))) ||
!(is_fixnum_obj(o2) || (is_flonum_obj(o2) && flisint(flonum_from_obj(o2))))) res = ACRES_BADTYPE;
} break;
case E_Z_Z_Z_ETC:
if (ac < 2) res = ACRES_BADARGC; else if (ac == 2) {
obj o1, o2; if (l) { o1 = car(l); l = cdr(l); o2 = car(l); } else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); }
if (is_fixnum_obj(o1) && is_fixnum_obj(o2)) res = obj_from_bool(o1 == o2);
else if (!(is_fixnum_obj(o1) || is_flonum_obj(o1)) || !(is_fixnum_obj(o2) || is_flonum_obj(o2))) res = ACRES_BADTYPE;
} else goto real_etc;
break;
case L_X_X_X_ETC:
if (ac < 2) res = ACRES_BADARGC; else if (ac == 2) {
obj o1, o2; if (l) { o1 = car(l); l = cdr(l); o2 = car(l); } else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); }
if (is_fixnum_obj(o1) && is_fixnum_obj(o2)) res = obj_from_bool(fixnum_from_obj(o1) < fixnum_from_obj(o2));
else if (!(is_fixnum_obj(o1) || is_flonum_obj(o1)) || !(is_fixnum_obj(o2) || is_flonum_obj(o2))) res = ACRES_BADTYPE;
} else goto real_etc;
break;
case G_X_X_X_ETC:
if (ac < 2) res = ACRES_BADARGC; else if (ac == 2) {
obj o1, o2; if (l) { o1 = car(l); l = cdr(l); o2 = car(l); } else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); }
if (is_fixnum_obj(o1) && is_fixnum_obj(o2)) res = obj_from_bool(fixnum_from_obj(o1) > fixnum_from_obj(o2));
else if (!(is_fixnum_obj(o1) || is_flonum_obj(o1)) || !(is_fixnum_obj(o2) || is_flonum_obj(o2))) res = ACRES_BADTYPE;
} else goto real_etc;
break;
case LE_X_X_X_ETC:
if (ac < 2) res = ACRES_BADARGC; else if (ac == 2) {
obj o1, o2; if (l) { o1 = car(l); l = cdr(l); o2 = car(l); } else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); }
if (is_fixnum_obj(o1) && is_fixnum_obj(o2)) res = obj_from_bool(fixnum_from_obj(o1) <= fixnum_from_obj(o2));
else if (!(is_fixnum_obj(o1) || is_flonum_obj(o1)) || !(is_fixnum_obj(o2) || is_flonum_obj(o2))) res = ACRES_BADTYPE;
} else goto real_etc;
break;
case GE_X_X_X_ETC:
if (ac < 2) res = ACRES_BADARGC; else if (ac == 2) {
obj o1, o2; if (l) { o1 = car(l); l = cdr(l); o2 = car(l); } else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); }
if (is_fixnum_obj(o1) && is_fixnum_obj(o2)) res = obj_from_bool(fixnum_from_obj(o1) >= fixnum_from_obj(o2));
else if (!(is_fixnum_obj(o1) || is_flonum_obj(o1)) || !(is_fixnum_obj(o2) || is_flonum_obj(o2))) res = ACRES_BADTYPE;
} else goto real_etc;
break;
case GCD_N_ETC:
if (ac == 0) res = obj_from_fixnum(0); else {
long a = 0, i = 0; while (ac-- > 0) {
obj o; if (l) { o = car(l); l = cdr(l); } else o = va_arg(args, obj);
if (is_flonum_obj(o) && flisint(flonum_from_obj(o))) goto int_etc; /* our fl/mixed op won't overflow */
if (!is_fixnum_obj(o)) { res = ACRES_BADTYPE; goto out; }
if (!i++) a = labs(fixnum_from_obj(o));
else { long b = labs(fixnum_from_obj(o)), c; while (b) c = a%b, a = b, b = c; }
if (a > FIXNUM_MAX) { res = ACRES_FIXOVER; goto out; }
} res = obj_from_fixnum(a);
} break;
case LCM_N_ETC:
if (ac == 0) res = obj_from_fixnum(1); else {
long long x = 1; long i = 0; while (ac-- > 0) {
obj o; if (l) { o = car(l); l = cdr(l); } else o = va_arg(args, obj);
if (is_flonum_obj(o) && flisint(flonum_from_obj(o))) goto int_etc; /* our fl/mixed op won't overflow */
if (!is_fixnum_obj(o)) { res = ACRES_BADTYPE; goto out; }
if (!i++) x = labs(fixnum_from_obj(o));
else { long y = labs(fixnum_from_obj(o)), a = (long)x, b = y, c; while (b) c = a%b, a = b, b = c;
if (!a) x = a; else x = (x / a) * y; }
if (x > FIXNUM_MAX) { res = ACRES_FIXOVER; goto out; } /* internal overflow, like in real op */
} res = obj_from_fixnum((long)x);
} break;
case EXPT_Z_Z:
if (ac != 2) res = ACRES_BADARGC; else {
obj o1, o2; if (l) { o1 = car(l); l = cdr(l); o2 = car(l); } else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); }
if (is_fixnum_obj(o1) && is_fixnum_obj(o2) && fixnum_from_obj(o2) >= 0) {
long x = fixnum_from_obj(o1), y = fixnum_from_obj(o2);
if (!iexpt(&x, y)) res = ACRES_FIXOVER; else res = obj_from_fixnum(x);
} else if (!(is_fixnum_obj(o1) || is_flonum_obj(o1)) || !(is_fixnum_obj(o2) || is_flonum_obj(o2))) res = ACRES_BADTYPE;
} break;
case CAR_PAIR:
if (ac != 1) res = ACRES_BADARGC; else {
obj o; if (l) o = car(l); else o = va_arg(args, obj); res = ispair(o) ? car(o) : ACRES_BADTYPE;
} break;
case CDR_PAIR:
if (ac != 1) res = ACRES_BADARGC; else {
obj o; if (l) o = car(l); else o = va_arg(args, obj); res = ispair(o) ? cdr(o) : ACRES_BADTYPE;
} break;
case CAAR_PAIR:
if (ac != 1) res = ACRES_BADARGC; else {
obj o; if (l) o = car(l); else o = va_arg(args, obj); res = (ispair(o) && ispair(car(o))) ? car(car(o)) : ACRES_BADTYPE;
} break;
case CDAR_PAIR:
if (ac != 1) res = ACRES_BADARGC; else {
obj o; if (l) o = car(l); else o = va_arg(args, obj); res = (ispair(o) && ispair(car(o))) ? cdr(car(o)) : ACRES_BADTYPE;
} break;
case CADR_PAIR:
if (ac != 1) res = ACRES_BADARGC; else {
obj o; if (l) o = car(l); else o = va_arg(args, obj); res = (ispair(o) && ispair(cdr(o))) ? car(cdr(o)) : ACRES_BADTYPE;
} break;
case CDDR_PAIR:
if (ac != 1) res = ACRES_BADARGC; else {
obj o; if (l) o = car(l); else o = va_arg(args, obj); res = (ispair(o) && ispair(cdr(o))) ? cdr(cdr(o)) : ACRES_BADTYPE;
} break;
case NOT_OBJ:
if (ac != 1) res = ACRES_BADARGC; else {
obj o; if (l) o = car(l); else o = va_arg(args, obj); res = obj_from_bool(!bool_from_obj(o));
} break;
case EQ_OBJ_OBJ:
if (ac != 2) res = ACRES_BADARGC; else {
obj o1, o2; if (l) { o1 = car(l); l = cdr(l); o2 = car(l); } else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); }
res = obj_from_bool(o1 == o2);
} break;
case EQV_OBJ_OBJ:
if (ac != 2) res = ACRES_BADARGC; else {
obj o1, o2; if (l) { o1 = car(l); l = cdr(l); o2 = car(l); } else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); }
if (is_flonum_obj(o1) && is_flonum_obj(o2)) res = obj_from_bool(flonum_from_obj(o1) == flonum_from_obj(o2));
else res = obj_from_bool(o1 == o2);
} break;
case ISNULL_OBJ:
if (ac != 1) res = ACRES_BADARGC; else {
obj o; if (l) o = car(l); else o = va_arg(args, obj); res = obj_from_bool(isnull(o));
} break;
case ISPAIR_OBJ:
if (ac != 1) res = ACRES_BADARGC; else {
obj o; if (l) o = car(l); else o = va_arg(args, obj); res = obj_from_bool(ispair(o));
} break;
case LENGTH_LIST:
if (ac != 1) res = ACRES_BADARGC; else {
long n; obj o; if (l) o = car(l); else o = va_arg(args, obj); res = ((n = listlen(o)) < 0) ? ACRES_BADTYPE : obj_from_fixnum(n);
} break;
case LENGTH_STRING:
if (ac != 1) res = ACRES_BADARGC; else {
obj o; if (l) o = car(l); else o = va_arg(args, obj); res = isstring(o) ? obj_from_fixnum(stringlen(o)) : ACRES_BADTYPE;
} break;
case REF_STRING_INDEX:
if (ac != 2) res = ACRES_BADARGC; else {
obj o1, o2; if (l) { o1 = car(l); l = cdr(l); o2 = car(l); } else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); }
if (!isstring(o1) || !is_fixnum_obj(o2)) res = ACRES_BADTYPE;
else { long len = stringlen(o1), n = fixnum_from_obj(o2); res = (n < 0 || n >= len) ? ACRES_BADINDEX : obj_from_char(*(unsigned char*)stringref(o1, n)); }
} break;
case SET_STRING_INDEX_CHAR:
if (ac != 3) res = ACRES_BADARGC; else {
obj o1, o2, o3;
if (l) { o1 = car(l); l = cdr(l); o2 = car(l); l = cdr(l); o3 = car(l); }
else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); o3 = va_arg(args, obj); }
if (!isstring(o1) || !is_fixnum_obj(o2) || !ischar(o3)) res = ACRES_BADTYPE;
else {
long len = stringlen(o1), n = fixnum_from_obj(o2);
res = (n < 0 || n >= len) ? ACRES_BADINDEX : obj_from_void(*stringref(o1, n) = char_from_obj(o3));
}
} break;
case LENGTH_VECTOR:
if (ac != 1) res = ACRES_BADARGC; else {
obj o; if (l) o = car(l); else o = va_arg(args, obj); res = isvector(o) ? obj_from_fixnum(vectorlen(o)) : ACRES_BADTYPE;
} break;
case REF_VECTOR_INDEX:
if (ac != 2) res = ACRES_BADARGC; else {
obj o1, o2; if (l) { o1 = car(l); l = cdr(l); o2 = car(l); } else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); }
if (!isvector(o1) || !is_fixnum_obj(o2)) res = ACRES_BADTYPE;
else { long len = vectorlen(o1), n = fixnum_from_obj(o2); res = (n < 0 || n >= len) ? ACRES_BADINDEX : vectorref(o1, n); }
} break;
case SET_VECTOR_INDEX_OBJ:
if (ac != 3) res = ACRES_BADARGC; else {
obj o1, o2, o3;
if (l) { o1 = car(l); l = cdr(l); o2 = car(l); l = cdr(l); o3 = car(l); }
else { o1 = va_arg(args, obj); o2 = va_arg(args, obj); o3 = va_arg(args, obj); }
if (!isvector(o1) || !is_fixnum_obj(o2)) res = ACRES_BADTYPE;
else { long len = vectorlen(o1), n = fixnum_from_obj(o2); res = (n < 0 || n >= len) ? ACRES_BADINDEX : (vectorref(o1, n) = o3); }
} break;
default: assert(0);
}
out:
va_end(args);
return res;
}
}")
(define-syntax %procedure-argcheck
(syntax-rules ()
[(_ p 0) (%prim? "obj(argcheck(obj_from_$arg, 0, 0))" p)]
[(_ p 1 x) (%prim? "obj(argcheck(obj_from_$arg, 1, 0, obj_from_$arg))" p x)]
[(_ p 2 x y) (%prim? "obj(argcheck(obj_from_$arg, 2, 0, obj_from_$arg, obj_from_$arg))" p x y)]
[(_ p 3 x y z) (%prim? "obj(argcheck(obj_from_$arg, 3, 0, obj_from_$arg, obj_from_$arg, obj_from_$arg))" p x y z)]
[(_ p 4 x y z t) (%prim? "obj(argcheck(obj_from_$arg, 4, 0, obj_from_$arg, obj_from_$arg, obj_from_$arg, obj_from_$arg))" p x y z t)]))
(define (scheme-call-error n r p l)
(cond [(eq? r (%prim "obj(ACRES_BADPROC)")) (r-error "attempt to call non-procedure" p)]
[(eq? r (%prim "obj(ACRES_BADARGC)")) (r-error "procedure can't be called with argc =" n p ': l)]
[(eq? r (%prim "obj(ACRES_BADTYPE)")) (r-error "invalid arguments to" p ': l)]
[(eq? r (%prim "obj(ACRES_BADINDEX)")) (r-error "index out of range in call to" p ': l)]
[(eq? r (%prim "obj(ACRES_BADRANGE)")) (r-error "bad index range in call to" p ': l)]
[(eq? r (%prim "obj(ACRES_ZERODIV)")) (r-error "division by zero in call to" p ': l)]
[(eq? r (%prim "obj(ACRES_FIXOVER)")) (r-error "exact integer overflow in call to" p ': l)]
[else (%prim! "void(assert(0))")]))
(define-syntax scheme-argcheck-call
(syntax-rules ()
[(_ n p () (a ...))
(let ([r (%procedure-argcheck p n a ...)])
(cond [(not (acres-special? r)) r]
[(eq? r (%prim "obj(ACRES_APPLY)")) (p a ...)]
[else (scheme-call-error n r p (list a ...))]))]
[(_ n p (arg0 . arg*) (a ...))
(let ([a0 arg0]) (scheme-argcheck-call n p arg* (a ... a0)))]
[(_ n proc arg*)
(let ([p proc]) (scheme-argcheck-call n p arg* ()))]))
(define-syntax %procedure-argcheck*
(syntax-rules ()
[(_ p n l)
(%prim? "obj(argcheck(obj_from_$arg, fixnum_from_$arg, obj_from_$arg))" p n l)]))
(define-syntax scheme-argcheck-apply
(syntax-rules ()
[(_ n proc arglist)
(let ([p proc] [l arglist])
(let ([r (%procedure-argcheck* p n l)])
(cond [(not (acres-special? r)) r]
[(eq? r (%prim "obj(ACRES_APPLY)")) (apply p l)]
[else (scheme-call-error n r p l)])))]))
(define-inline (annotated-procedure-argc-ok? ap argc) ;assumes annotation is there!
(let ([ann (%procedure-ref ap (fx- (%procedure-length ap) 1))])
(let ([cmin (fxquotient ann 1000)] [cmax (fxremainder ann 1000)])
(and (fx<=? cmin argc) (fx<=? argc cmax)))))
;------------------------------------------------------------------------------
; wrappers for argc checking
(define-syntax scheme-call
(syntax-rules ()
[(_ n proc arg ...) (scheme-argcheck-call n proc (arg ...))]))
(define-syntax scheme-apply
(syntax-rules ()
[(_ n proc arglist) (scheme-argcheck-apply n proc arglist)]))
(define-syntax scheme-lambda
(syntax-rules ()
[(_ n formals . body)
(make-annotated-procedure (lambda formals . body) (argc->annotation n))]))
(define-syntax scheme-lambda-rest
(syntax-rules ()
[(_ n formals . body)
(make-annotated-procedure (lambda formals . body) (rest-argc->annotation n))]))
;------------------------------------------------------------------------------
; compiler (applied to macroexpander output)
(define (variable x)
(if (not (symbol? x)) (c-error "identifier expected" x)))
(define (mutable-variable x ill)
(cond [(not (symbol? x)) (c-error "identifier expected" x)]
[(memq x ill) (c-warning "modifying imported location" x)]))
(define (shape+ form n) ;form must be proper list of n or more elements
(let loop ([n n] [l form])
(cond [(<= n 0)]
[(pair? l) (loop (- n 1) (cdr l))]
[else (c-error "ill-constructed form" form)])))
(define (shape form n) ;form must be proper list of exactly n elements
(let loop ([n n] [l form])
(cond [(and (= n 0) (null? l))]
[(and (> n 0) (pair? l)) (loop (- n 1) (cdr l))]
[else (c-error "ill-constructed form" form)])))
(define (parms->frame parms)
(cond [(null? parms) '()]
[(pair? parms)
(let ([x (car parms)])
(variable x) (cons x (parms->frame (cdr parms))))]
[else (variable parms) (list parms)]))
(define (bindings->vars bindings)
(if (pair? bindings)
(let ([binding (car bindings)])
(shape binding 2)
(let ([x (car binding)])
(variable x) (cons x (bindings->vars (cdr bindings)))))
'()))
(define (bindings->vals bindings)
(if (pair? bindings)
(let ([binding (car bindings)])
(cons (cadr binding) (bindings->vals (cdr bindings))))
'()))
(define (scheme-compile expr cte ill)
(define (cons-cte frame cte)
(if (null? frame) cte (cons cte frame)))
(define (lookup name)
(let loop1 ([chain cte] [up 0])
(if (null? chain)
name
(let loop2 ([chain chain] [up up] [frame (cdr chain)] [over 1])
(cond [(null? frame) (loop1 (car chain) (fx+ up 1))]
[(eq? (car frame) name) (cons up over)]
[else (loop2 chain up (cdr frame) (fx+ over 1))])))))
(define (comp expr)
(cond [(symbol? expr) (variable expr)
(gen-var-ref (lookup expr))]
[(not (pair? expr))
(gen-cst expr)]
[(eq? (car expr) 'quote) (shape expr 2)
(gen-cst (cadr expr))]
[(eq? (car expr) 'set!) (shape expr 3) (mutable-variable (cadr expr) ill)
(gen-var-set (lookup (cadr expr)) (comp (caddr expr)))]
[(eq? (car expr) 'lambda) (shape expr 3)
(let ([parms (cadr expr)])
(let ([frame (parms->frame parms)])
(let ([nb-vars (length frame)]
[code (scheme-compile (caddr expr) (cons-cte frame cte) ill)])
(if (list? parms)
(gen-lambda nb-vars code)
(gen-lambda-rest nb-vars code)))))]
[(eq? (car expr) 'if) (shape+ expr 3)
(let ([code1 (comp (cadr expr))] [code2 (comp (caddr expr))])
(if (pair? (cdddr expr))
(gen-if code1 code2 (comp (cadddr expr)))
(gen-when code1 code2)))]
[(eq? (car expr) 'letrec) (shape expr 3)
(let ([bindings (cadr expr)])
(let ([new-cte (cons-cte (bindings->vars bindings) cte)])
(let loop ([vals (bindings->vals bindings)] [codes '()])
(if (null? vals)
(gen-letrec (reverse codes) (scheme-compile (caddr expr) new-cte ill))
(loop (cdr vals) (cons (scheme-compile (car vals) new-cte ill) codes))))))]
[(eq? (car expr) 'begin) (shape+ expr 2)
(let loop ([expr0 (cadr expr)] [exprs (cddr expr)])
(let ([code (comp expr0)])
(if (null? exprs)
code
(gen-sequence code (loop (car exprs) (cdr exprs))))))]
[(eq? (car expr) 'define) (shape expr 3) (mutable-variable (cadr expr) ill)
(gen-sequence ; returns symbol to simplify interactive debugging
(gen-var-set (lookup (cadr expr)) (comp (caddr expr)))
(gen-cst (cadr expr)))]
[(symbol? (car expr)) (variable (car expr))
(let ([var (lookup (car expr))])
(if (pair? var) ; local
(gen-combination (comp (car expr)) (map comp (cdr expr)))
(gen-glo-combination var (map comp (cdr expr)))))]
[else (gen-combination (comp (car expr)) (map comp (cdr expr)))]))
(comp expr))
;------------------------------------------------------------------------------
; code generator
; global value store locations are kept in linked alist, value is stored in the cdr
(define-inline (value-store-location-ref i) (cdr i))
(define-inline (value-store-location-set! i val) (set-cdr! i val))
(define (gen-var-ref var)
(if (pair? var)
(gen-rte-ref (car var) (cdr var))
(gen-glo-ref (value-store-lookup var))))
(define (gen-rte-ref up over)
(case up
[(0) (gen-slot-ref-0 over)]
[(1) (gen-slot-ref-1 over)]
[else (gen-slot-ref-up-2 (gen-rte-ref (- up 2) over))]))
(define (gen-slot-ref-0 i)
(case i
[(0) (lambda (rte) (vector-ref rte 0))]
[(1) (lambda (rte) (vector-ref rte 1))]
[(2) (lambda (rte) (vector-ref rte 2))]
[(3) (lambda (rte) (vector-ref rte 3))]
[else (lambda (rte) (vector-ref rte i))]))
(define (gen-slot-ref-1 i)
(case i
[(0) (lambda (rte) (vector-ref (vector-ref rte 0) 0))]
[(1) (lambda (rte) (vector-ref (vector-ref rte 0) 1))]
[(2) (lambda (rte) (vector-ref (vector-ref rte 0) 2))]
[(3) (lambda (rte) (vector-ref (vector-ref rte 0) 3))]
[else (lambda (rte) (vector-ref (vector-ref rte 0) i))]))
(define (gen-slot-ref-up-2 code)
(lambda (rte) (code (vector-ref (vector-ref rte 0) 0))))
(define (gen-glo-ref i)
(lambda (rte) (value-store-location-ref i)))
(define (gen-cst val)
(case val
[(()) (lambda (rte) '())]
[(#f) (lambda (rte) #f)]
[(#t) (lambda (rte) #t)]
[(-2) (lambda (rte) -2)]
[(-1) (lambda (rte) -1)]
[(0) (lambda (rte) 0)]
[(1) (lambda (rte) 1)]
[(2) (lambda (rte) 2)]
[else (lambda (rte) val)]))
(define (gen-var-set var code)
(if (pair? var)
(gen-rte-set (car var) (cdr var) code)
(gen-glo-set (value-store-lookup var) code)))
(define (gen-rte-set up over code)
(case up
[(0) (gen-slot-set-0 over code)]
[(1) (gen-slot-set-1 over code)]
[else (gen-slot-set-n (gen-rte-ref (- up 2) 0) over code)]))
(define (gen-slot-set-0 i code)
(case i
[(0) (lambda (rte) (vector-set! rte 0 (code rte)))]
[(1) (lambda (rte) (vector-set! rte 1 (code rte)))]
[(2) (lambda (rte) (vector-set! rte 2 (code rte)))]
[(3) (lambda (rte) (vector-set! rte 3 (code rte)))]
[else (lambda (rte) (vector-set! rte i (code rte)))]))
(define (gen-slot-set-1 i code)
(case i
[(0) (lambda (rte) (vector-set! (vector-ref rte 0) 0 (code rte)))]
[(1) (lambda (rte) (vector-set! (vector-ref rte 0) 1 (code rte)))]
[(2) (lambda (rte) (vector-set! (vector-ref rte 0) 2 (code rte)))]
[(3) (lambda (rte) (vector-set! (vector-ref rte 0) 3 (code rte)))]
[else (lambda (rte) (vector-set! (vector-ref rte 0) i (code rte)))]))
(define (gen-slot-set-n up i code)
(case i
[(0) (lambda (rte) (vector-set! (up (vector-ref rte 0)) 0 (code rte)))]
[(1) (lambda (rte) (vector-set! (up (vector-ref rte 0)) 1 (code rte)))]
[(2) (lambda (rte) (vector-set! (up (vector-ref rte 0)) 2 (code rte)))]
[(3) (lambda (rte) (vector-set! (up (vector-ref rte 0)) 3 (code rte)))]
[else (lambda (rte) (vector-set! (up (vector-ref rte 0)) i (code rte)))]))
(define (gen-glo-set i code)
(lambda (rte) (value-store-location-set! i (code rte))))
(define (gen-lambda-rest nb-vars body)
(case nb-vars
[(1) (gen-lambda-1-rest body)]
[(2) (gen-lambda-2-rest body)]
[(3) (gen-lambda-3-rest body)]
[else (gen-lambda-n-rest nb-vars body)]))
(define (gen-lambda-1-rest body)
(lambda (rte) (scheme-lambda-rest 1 a (body (vector rte a)))))
(define (gen-lambda-2-rest body)
(lambda (rte) (scheme-lambda-rest 2 (a . b) (body (vector rte a b)))))
(define (gen-lambda-3-rest body)
(lambda (rte) (scheme-lambda-rest 3 (a b . c) (body (vector rte a b c)))))
(define (gen-lambda-n-rest nb-vars body)
(lambda (rte)
(scheme-lambda-rest nb-vars (a b c . d)
(let ([x (make-vector (+ nb-vars 1))])
(vector-set! x 0 rte)
(vector-set! x 1 a)
(vector-set! x 2 b)
(vector-set! x 3 c)
(let loop ([n nb-vars] [x x] [i 4] [l d])
(if (< i n)
(begin
(vector-set! x i (car l))
(loop n x (+ i 1) (cdr l)))
(vector-set! x i l)))
(body x)))))
(define (gen-lambda nb-vars body)
(case nb-vars
[(0) (gen-lambda-0 body)]
[(1) (gen-lambda-1 body)]
[(2) (gen-lambda-2 body)]
[(3) (gen-lambda-3 body)]
[(4) (gen-lambda-4 body)]
[else (gen-lambda-n nb-vars body)]))
(define (gen-lambda-0 body)
(lambda (rte) (scheme-lambda 0 () (body rte))))
(define (gen-lambda-1 body)
(lambda (rte) (scheme-lambda 1 (a) (body (vector rte a)))))
(define (gen-lambda-2 body)
(lambda (rte) (scheme-lambda 2 (a b) (body (vector rte a b)))))
(define (gen-lambda-3 body)
(lambda (rte) (scheme-lambda 3 (a b c) (body (vector rte a b c)))))
(define (gen-lambda-4 body)
(lambda (rte) (scheme-lambda 4 (a b c d) (body (vector rte a b c d)))))
(define (gen-lambda-n nb-vars body)
(lambda (rte)
(scheme-lambda nb-vars (a b c d . e)
(let ([x (make-vector (+ nb-vars 1))])
(vector-set! x 0 rte)
(vector-set! x 1 a)
(vector-set! x 2 b)
(vector-set! x 3 c)
(vector-set! x 4 d)
(let loop ([n nb-vars] [x x] [i 5] [l e])
(if (<= i n)
(begin
(vector-set! x i (car l))
(loop n x (+ i 1) (cdr l)))))
(body x)))))
(define (gen-sequence code1 code2)
(lambda (rte) (code1 rte) (code2 rte)))
(define (gen-when code1 code2)
(lambda (rte) (if (code1 rte) (code2 rte) (void))))
(define (gen-if code1 code2 code3)
(lambda (rte) (if (code1 rte) (code2 rte) (code3 rte))))
(define (gen-letrec vals body)
(let ([nb-vals (length vals)])
(case nb-vals
[(1) (gen-letrec-1 (car vals) body)]
[(2) (gen-letrec-2 (car vals) (cadr vals) body)]
[(3) (gen-letrec-3 (car vals) (cadr vals) (caddr vals) body)]
[else (gen-letrec-n nb-vals vals body)])))
(define (gen-letrec-1 val1 body)
(lambda (rte)
(let ([x (vector rte #f)]) (vector-set! x 1 (val1 x)) (body x))))
(define (gen-letrec-2 val1 val2 body)
(lambda (rte)
(let ([x (vector rte #f #f)])
(vector-set! x 1 (val1 x))
(vector-set! x 2 (val2 x))
(body x))))
(define (gen-letrec-3 val1 val2 val3 body)
(lambda (rte)
(let ([x (vector rte #f #f #f)])
(vector-set! x 1 (val1 x))
(vector-set! x 2 (val2 x))
(vector-set! x 3 (val3 x))
(body x))))
(define (gen-letrec-n nb-vals vals body)
(lambda (rte)
(let ([x (make-vector (+ nb-vals 1))])
(vector-set! x 0 rte)
(let loop ([x x] [i 1] [l vals])
(if (pair? l)
(begin
(vector-set! x i ((car l) x))
(loop x (+ i 1) (cdr l)))))
(body x))))
(define (gen-glo-combination var args)
(let ([i (value-store-lookup var)] [argc (length args)])
(case argc
[(0) (gen-glo-combination-0 i)]
[(1) (gen-glo-combination-1 i (car args))]
[(2) (gen-glo-combination-2 i (car args) (cadr args))]
[(3) (gen-glo-combination-3 i (car args) (cadr args) (caddr args))]
[(4) (gen-glo-combination-4 i (car args) (cadr args) (caddr args) (cadddr args))]
[else (gen-glo-combination-n argc i args)])))
(define (gen-glo-combination-0 i)
(lambda (rte) (scheme-call 0 (value-store-location-ref i))))
(define (gen-glo-combination-1 i arg1)
(lambda (rte) (scheme-call 1 (value-store-location-ref i) (arg1 rte))))
(define (gen-glo-combination-2 i arg1 arg2)
(lambda (rte) (scheme-call 2 (value-store-location-ref i) (arg1 rte) (arg2 rte))))
(define (gen-glo-combination-3 i arg1 arg2 arg3)
(lambda (rte) (scheme-call 3 (value-store-location-ref i) (arg1 rte) (arg2 rte) (arg3 rte))))
(define (gen-glo-combination-4 i arg1 arg2 arg3 arg4)
(lambda (rte) (scheme-call 4 (value-store-location-ref i) (arg1 rte) (arg2 rte) (arg3 rte) (arg4 rte))))
(define (gen-glo-combination-n argc i args)
(lambda (rte)
(define (evaluate l rte)
(if (pair? l)
(cons ((car l) rte) (evaluate (cdr l) rte))
'()))
(scheme-apply argc (value-store-location-ref i) (evaluate args rte))))
(define (gen-combination oper args)
(let ([argc (length args)])
(case argc
[(0) (gen-combination-0 oper)]
[(1) (gen-combination-1 oper (car args))]
[(2) (gen-combination-2 oper (car args) (cadr args))]
[(3) (gen-combination-3 oper (car args) (cadr args) (caddr args))]
[(4) (gen-combination-4 oper (car args) (cadr args) (caddr args) (cadddr args))]
[else (gen-combination-n argc oper args)])))
(define (gen-combination-0 oper)
(lambda (rte) (scheme-call 0 (oper rte))))
(define (gen-combination-1 oper arg1)
(lambda (rte) (scheme-call 1 (oper rte) (arg1 rte))))
(define (gen-combination-2 oper arg1 arg2)
(lambda (rte) (scheme-call 2 (oper rte) (arg1 rte) (arg2 rte))))
(define (gen-combination-3 oper arg1 arg2 arg3)
(lambda (rte) (scheme-call 3 (oper rte) (arg1 rte) (arg2 rte) (arg3 rte))))
(define (gen-combination-4 oper arg1 arg2 arg3 arg4)
(lambda (rte) (scheme-call 4 (oper rte) (arg1 rte) (arg2 rte) (arg3 rte) (arg4 rte))))
(define (gen-combination-n argc oper args)
(lambda (rte)
(define (evaluate l rte)
(if (pair? l)
(cons ((car l) rte) (evaluate (cdr l) rte))
'()))
(scheme-apply argc (oper rte) (evaluate args rte))))
;------------------------------------------------------------------------------
; evaluator
(define (scheme-compile-run expr environment)
; immutable locations -- how to calculate from environment??
; we should make sure that local-env does not contain any explicit
; locations *from the library itself*, then pick cdrs of explicit env pairs!
; for this, we should modify make-local-env to this effect
(define immlocs (let loop ([e environment] [ill '()]) (if (pair? e) (loop (cdr e) (cons (cdar e) ill)) ill)))
(let ([code (scheme-compile expr '() immlocs)]) ;no locals on top level
(code #f))) ;no local frames at run time
(define (scheme-expand-compile-run form environment)
(let loop ([outs (expand-top-level-forms! (list form) environment)])
(cond [(null? outs) (void)]
[(null? (cdr outs)) (scheme-compile-run (car outs) environment)] ; tail call
[else (scheme-compile-run (car outs) environment) (loop (cdr outs))])))
(define (scheme-expand-to-list expr . ?environment)
(when (circular? expr) (c-error "circular input form:" expr))
(expand-top-level-forms! (list expr) (if (null? ?environment) *current-environment* (car ?environment))))
(define (scheme-eval expr . ?environment)
(when (circular? expr) (c-error "circular input form:" expr))
(scheme-expand-compile-run expr (if (null? ?environment) *current-environment* (car ?environment))))
;------------------------------------------------------------------------------
; interpreter global value store and initialization
(define *current-value-store* '())
(define (value-store-lookup name) ;=> store location
(let ([x (assq name *current-value-store*)])
(if x
x
; default value of a global var is its own symbol (simplifies bug reporting)
(let ([y (cons name name)])
(set! *current-value-store* (cons y *current-value-store*))
y))))
(define (reverse-global-lookup val)
(let loop ([al *current-value-store*])
(cond [(null? al) #f]
[(eq? (cdar al) val) (caar al)]
[else (loop (cdr al))])))
(define (get-global name)
(value-store-location-ref (value-store-lookup name)))
(define (set-global! name value)
(value-store-location-set! (value-store-lookup name) value))
(define-syntax def-global
(syntax-rules ()
[(_ (name . args))
(def-global (name . args) name)]
[(_ (name arg ...) val)
(set-global! 'name (#&(string->id #&(string-append "wrapper-for" #&(string-append "-" #&(id->string arg)) ...)) val))]
[(_ name val) (set-global! 'name val)]))
(define-syntax def-arg-checker
(syntax-rules ()
; this produces more compact executable, but primitives are slower because residual versions are called always
#;[(_ (id arg ...) checker)
(define #&(string->id #&(string-append "wrapper-for" #&(string-append "-" #&(id->string arg)) ...))
(lambda (id) checker))]
; this variant produces more code, but actual operation may get inlined
[(_ (id arg ...) checker)
(define-syntax #&(string->id #&(string-append "wrapper-for" #&(string-append "-" #&(id->string arg)) ...))
(syntax-lambda (id) checker))]))
(define-syntax mark-argc (syntax-rules () [(_ n p) (make-annotated-procedure p (argc->annotation n))]))
(define-syntax mark-rest-argc (syntax-rules () [(_ n p) (make-annotated-procedure p (rest-argc->annotation n))]))
(define-syntax mark-range-argc (syntax-rules () [(_ n k p) (make-annotated-procedure p (range-argc->annotation n k))]))
(define-syntax mark-argcheck (syntax-rules () [(_ s p) (make-annotated-procedure p (argcheck->annotation s))]))
(define (splice-last-list l) ; for flattening of pre-checked apply's arglist
(let loop ([l l])
(cond [(list1? l) (car l)]
[(pair? l) (cons (car l) (loop (cdr l)))])))
(def-arg-checker (*) (mark-argc 0 *))
(def-arg-checker (* obj) (mark-argc 1 *))
(def-arg-checker (* obj ?) (mark-range-argc 0 1 *))
(def-arg-checker (* obj obj) (mark-argc 2 *))
(def-arg-checker (* obj obj ?) (mark-range-argc 1 2 *))
(def-arg-checker (* obj obj obj) (mark-argc 3 *))
(def-arg-checker (* obj ...) (mark-rest-argc 1 *))
(def-arg-checker (* boolean boolean boolean ...) (mark-argcheck ARGCHECK_BOOLEAN_BOOLEAN_BOOLEAN_ETC (argc-dispatch-lambda #f #f (lambda (x y) (* x y)) *)))
(def-arg-checker (* n) (mark-argcheck ARGCHECK_N *))
(def-arg-checker (* n n) (mark-argcheck ARGCHECK_N_N *))
(def-arg-checker (* n ?) (mark-argcheck ARGCHECK_N_OPT (argc-dispatch-lambda (lambda () (*)) (lambda (x) (* x)) #f)))
(def-arg-checker (* n ...) (mark-argcheck ARGCHECK_N_ETC
(argc-dispatch-lambda
(lambda () (*)) (lambda (x) (* x)) (lambda (x y) (* x y)) (lambda (x y z) (* x y z)) (lambda (x y z t) (* x y z t)) *)))
(def-arg-checker (* q) (mark-argcheck ARGCHECK_Q *))
(def-arg-checker (* k) (mark-argcheck ARGCHECK_K *))
(def-arg-checker (* x) (mark-argcheck ARGCHECK_X *))
(def-arg-checker (* x x) (mark-argcheck ARGCHECK_X_X *))
(def-arg-checker (* x x ...) (mark-argcheck ARGCHECK_X_X_ETC
(argc-dispatch-lambda
#f (lambda (x) (* x)) (lambda (x y) (* x y)) (lambda (x y z) (* x y z)) (lambda (x y z t) (* x y z t)) *)))
(def-arg-checker (* x x x ...) (mark-argcheck ARGCHECK_X_X_X_ETC
(argc-dispatch-lambda
#f #f (lambda (x y) (* x y)) (lambda (x y z) (* x y z)) (lambda (x y z t) (* x y z t)) *)))
(def-arg-checker (* z) (mark-argcheck ARGCHECK_Z *))
(def-arg-checker (* z z) (mark-argcheck ARGCHECK_Z_Z *))
(def-arg-checker (* z z ?) (mark-argcheck ARGCHECK_Z_Z_OPT (argc-dispatch-lambda #f (lambda (x) (* x)) (lambda (x y) (* x y)) #f)))
(def-arg-checker (* z ...) (mark-argcheck ARGCHECK_Z_ETC
(argc-dispatch-lambda
(lambda () (*)) (lambda (x) (* x)) (lambda (x y) (* x y)) (lambda (x y z) (* x y z)) (lambda (x y z t) (* x y z t)) *)))
(def-arg-checker (* z z ...) (mark-argcheck ARGCHECK_Z_Z_ETC
(argc-dispatch-lambda
#f (lambda (x) (* x)) (lambda (x y) (* x y)) (lambda (x y z) (* x y z)) (lambda (x y z t) (* x y z t)) *)))
(def-arg-checker (* z z z ...) (mark-argcheck ARGCHECK_Z_Z_Z_ETC
(argc-dispatch-lambda
#f #f (lambda (x y) (* x y)) (lambda (x y z) (* x y z)) (lambda (x y z t) (* x y z t)) *)))
(def-arg-checker (* z radix ?) (mark-argcheck ARGCHECK_Z_RADIX_OPT (argc-dispatch-lambda #f (lambda (x) (* x)) (lambda (x y) (* x y)) #f)))
(def-arg-checker (* string radix ?) (mark-argcheck ARGCHECK_STRING_RADIX_OPT (argc-dispatch-lambda #f (lambda (x) (* x)) (lambda (x y) (* x y)) #f)))
(def-arg-checker (* box) (mark-argcheck ARGCHECK_BOX *))
(def-arg-checker (* pair) (mark-argcheck ARGCHECK_PAIR *))
(def-arg-checker (* pair obj) (mark-argcheck ARGCHECK_PAIR_OBJ *))
(def-arg-checker (* list) (mark-argcheck ARGCHECK_LIST *))
(def-arg-checker (* list ...) (mark-argcheck ARGCHECK_LIST_ETC *))
(def-arg-checker (* alist) (mark-argcheck ARGCHECK_ALIST *))
(def-arg-checker (* u8list) (mark-argcheck ARGCHECK_U8LIST *))
(def-arg-checker (* obj list) (mark-argcheck ARGCHECK_OBJ_LIST *))
(def-arg-checker (* obj alist) (mark-argcheck ARGCHECK_OBJ_ALIST *))
(def-arg-checker (* symbol) (mark-argcheck ARGCHECK_SYMBOL *))
(def-arg-checker (* symbol symbol symbol ...) (mark-argcheck ARGCHECK_SYMBOL_SYMBOL_SYMBOL_ETC (argc-dispatch-lambda #f #f (lambda (x y) (* x y)) *)))
(def-arg-checker (* char) (mark-argcheck ARGCHECK_CHAR *))
(def-arg-checker (* char char) (mark-argcheck ARGCHECK_CHAR_CHAR *))
(def-arg-checker (* char char char ...) (mark-argcheck ARGCHECK_CHAR_CHAR_CHAR_ETC (argc-dispatch-lambda #f #f (lambda (x y) (* x y)) *)))
(def-arg-checker (* char ...) (mark-argcheck ARGCHECK_CHAR_ETC *))
(def-arg-checker (* k char ?) (mark-argcheck ARGCHECK_K_CHAR_OPT (argc-dispatch-lambda #f (lambda (x) (* x)) (lambda (x y) (* x y)) #f)))
(def-arg-checker (* string) (mark-argcheck ARGCHECK_STRING *))
(def-arg-checker (* string string) (mark-argcheck ARGCHECK_STRING_STRING *))
(def-arg-checker (* string string string ...) (mark-argcheck ARGCHECK_STRING_STRING_STRING_ETC (argc-dispatch-lambda #f #f (lambda (x y) (* x y)) *)))
(def-arg-checker (* string ...) (mark-argcheck ARGCHECK_STRING_ETC
(argc-dispatch-lambda (lambda () (*)) (lambda (x) (* x)) (lambda (x y) (* x y)) *)))
(def-arg-checker (* string obj ...) (mark-argcheck ARGCHECK_STRING_OBJ_ETC *))
(def-arg-checker (* string index) (mark-argcheck ARGCHECK_STRING_INDEX *))
(def-arg-checker (* string index char) (mark-argcheck ARGCHECK_STRING_INDEX_CHAR *))
(def-arg-checker (* string start end) (mark-argcheck ARGCHECK_STRING_START_END *))
(def-arg-checker (* string index string start end) (mark-argcheck ARGCHECK_STRING_INDEX_STRING_START_END *))
(def-arg-checker (* string char start end) (mark-argcheck ARGCHECK_STRING_CHAR_START_END *))
(def-arg-checker (* string char) (mark-argcheck ARGCHECK_STRING_CHAR *))
(def-arg-checker (* vector) (mark-argcheck ARGCHECK_VECTOR *))
(def-arg-checker (* vector ...) (mark-argcheck ARGCHECK_VECTOR_ETC
(argc-dispatch-lambda (lambda () (*)) (lambda (x) (* x)) (lambda (x y) (* x y)) *)))
(def-arg-checker (* k obj ?) (mark-argcheck ARGCHECK_K_OBJ_OPT (argc-dispatch-lambda #f (lambda (x) (* x)) (lambda (x y) (* x y)) #f)))
(def-arg-checker (* vector index) (mark-argcheck ARGCHECK_VECTOR_INDEX *))
(def-arg-checker (* vector index obj) (mark-argcheck ARGCHECK_VECTOR_INDEX_OBJ *))
(def-arg-checker (* vector start end) (mark-argcheck ARGCHECK_VECTOR_START_END *))
(def-arg-checker (* vector index vector start end) (mark-argcheck ARGCHECK_VECTOR_INDEX_VECTOR_START_END *))
(def-arg-checker (* vector obj start end) (mark-argcheck ARGCHECK_VECTOR_OBJ_START_END *))
(def-arg-checker (* vector obj) (mark-argcheck ARGCHECK_VECTOR_OBJ *))
(def-arg-checker (* u8 ...) (mark-argcheck ARGCHECK_U8_ETC *))
(def-arg-checker (* k u8 ?) (mark-argcheck ARGCHECK_K_U8_OPT (argc-dispatch-lambda #f (lambda (x) (* x)) (lambda (x y) (* x y)) #f)))
(def-arg-checker (* u8vector) (mark-argcheck ARGCHECK_U8VECTOR *))
(def-arg-checker (* u8vector u8vector) (mark-argcheck ARGCHECK_U8VECTOR_U8VECTOR *))
(def-arg-checker (* u8vector ...) (mark-argcheck ARGCHECK_U8VECTOR_ETC
(argc-dispatch-lambda (lambda () (*)) (lambda (x) (* x)) (lambda (x y) (* x y)) *)))
(def-arg-checker (* u8vector index) (mark-argcheck ARGCHECK_U8VECTOR_INDEX *))
(def-arg-checker (* u8vector index u8) (mark-argcheck ARGCHECK_U8VECTOR_INDEX_U8 *))
(def-arg-checker (* u8vector start end) (mark-argcheck ARGCHECK_U8VECTOR_START_END *))
(def-arg-checker (* u8vector index u8vector start end) (mark-argcheck ARGCHECK_U8VECTOR_INDEX_U8VECTOR_START_END *))
(def-arg-checker (* obj k) (mark-argcheck ARGCHECK_OBJ_K *))
(def-arg-checker (* record) (mark-argcheck ARGCHECK_RECORD *))
(def-arg-checker (* record index) (mark-argcheck ARGCHECK_RECORD_INDEX *))
(def-arg-checker (* record index obj) (mark-argcheck ARGCHECK_RECORD_INDEX_OBJ *))
(def-arg-checker (* proc) (mark-argcheck ARGCHECK_PROC *))
(def-arg-checker (* proc1cc) (mark-argcheck ARGCHECK_PROC1CC *))
(def-arg-checker (* string proc1ip) (mark-argcheck ARGCHECK_STRING_PROC1IP *))
(def-arg-checker (* string proc1op) (mark-argcheck ARGCHECK_STRING_PROC1OP *))
(def-arg-checker (* port proc1p) (mark-argcheck ARGCHECK_PORT_PROC1P *))
(def-arg-checker (* string thunk) (mark-argcheck ARGCHECK_STRING_THUNK *))
(def-arg-checker (* iport thunk) (mark-argcheck ARGCHECK_IPORT_THUNK *))
(def-arg-checker (* oport thunk) (mark-argcheck ARGCHECK_OPORT_THUNK *))
(def-arg-checker (* thunk proc) (mark-argcheck ARGCHECK_THUNK_PROC *))
(def-arg-checker (* thunk thunk thunk) (mark-argcheck ARGCHECK_THUNK_THUNK_THUNK *))
(def-arg-checker (* obj proc1 ?) (mark-argcheck ARGCHECK_OBJ_PROC1_OPT *))
(def-arg-checker (* proc1 thunk) (mark-argcheck ARGCHECK_PROC1_THUNK *))
(def-arg-checker (* environment) (mark-argcheck ARGCHECK_ENVIRONMENT *))
(def-arg-checker (* obj environment ?) (mark-argcheck ARGCHECK_OBJ_ENVIRONMENT_OPT *))
(def-arg-checker (* iport) (mark-argcheck ARGCHECK_IPORT *))
(def-arg-checker (* oport) (mark-argcheck ARGCHECK_OPORT *))
(def-arg-checker (* port) (mark-argcheck ARGCHECK_PORT *))
(def-arg-checker (* iport ?) (mark-argcheck ARGCHECK_IPORT_OPT (argc-dispatch-lambda (lambda () (*)) (lambda (x) (* x)) #f)))
(def-arg-checker (* k iport ?) (mark-argcheck ARGCHECK_K_IPORT_OPT (argc-dispatch-lambda #f (lambda (x) (* x)) (lambda (x y) (* x y)) #f)))
(def-arg-checker (* string start end iport) (mark-argcheck ARGCHECK_STRING_START_END_IPORT *))
(def-arg-checker (* string start end oport) (mark-argcheck ARGCHECK_STRING_START_END_OPORT *))
(def-arg-checker (* u8vector start end iport) (mark-argcheck ARGCHECK_U8VECTOR_START_END_IPORT *))
(def-arg-checker (* u8vector start end oport) (mark-argcheck ARGCHECK_U8VECTOR_START_END_OPORT *))
(def-arg-checker (* oport ?) (mark-argcheck ARGCHECK_OPORT_OPT (argc-dispatch-lambda (lambda () (*)) (lambda (x) (* x)) #f)))
(def-arg-checker (* obj oport ?) (mark-argcheck ARGCHECK_OBJ_OPORT_OPT (argc-dispatch-lambda #f (lambda (x) (* x)) (lambda (x y) (* x y)) #f)))
(def-arg-checker (* char oport ?) (mark-argcheck ARGCHECK_CHAR_OPORT_OPT (argc-dispatch-lambda #f (lambda (x) (* x)) (lambda (x y) (* x y)) #f)))
(def-arg-checker (* u8 oport ?) (mark-argcheck ARGCHECK_U8_OPORT_OPT (argc-dispatch-lambda #f (lambda (x) (* x)) (lambda (x y) (* x y)) #f)))
(def-arg-checker (* iport ? boolean ?) (mark-argcheck ARGCHECK_IPORT_OPT_BOOLEAN_OPT (argc-dispatch-lambda (lambda () (*)) (lambda (x) (* x)) (lambda (x y) (* x y)) #f)))
(def-arg-checker (* oport ? boolean ?) (mark-argcheck ARGCHECK_OPORT_OPT_BOOLEAN_OPT (argc-dispatch-lambda (lambda () (*)) (lambda (x) (* x)) (lambda (x y) (* x y)) #f)))
;------------------------------------------------------------------------------
; R5RS
; 6.1 Equivalence predicates
(def-global eqv? (mark-argcheck EQV_OBJ_OBJ eqv?))
(def-global eq? (mark-argcheck EQ_OBJ_OBJ eq?))
(def-global (equal? obj obj))
; 6.2.5 Numerical operations
(def-global (number? obj))
(def-global (complex? obj))
(def-global (real? obj))
(def-global (rational? obj))
(def-global (integer? obj))
(def-global (exact? obj))
(def-global (inexact? obj))
(def-global = (mark-argcheck E_Z_Z_Z_ETC =))
(def-global < (mark-argcheck L_X_X_X_ETC <))
(def-global > (mark-argcheck G_X_X_X_ETC >))
(def-global <= (mark-argcheck LE_X_X_X_ETC <=))
(def-global >= (mark-argcheck GE_X_X_X_ETC >=))
(def-global (zero? z))
(def-global (positive? x))
(def-global (negative? x))
(def-global (odd? n))
(def-global (even? n))
(def-global (max x x ...))
(def-global (min x x ...))
(def-global + (mark-argcheck ADD_Z_ETC +))
(def-global * (mark-argcheck MUL_Z_ETC *))
(def-global - (mark-argcheck SUB_Z_Z_ETC -))
(def-global / (mark-argcheck DIV_Z_Z_ETC /))
(def-global abs (mark-argcheck ABS_X abs))
(def-global quotient (mark-argcheck QUO_N_N quotient))
(def-global remainder (mark-argcheck REM_N_N remainder))
(def-global modulo (mark-argcheck MLO_N_N modulo))
(def-global gcd (mark-argcheck GCD_N_ETC gcd))
(def-global lcm (mark-argcheck LCM_N_ETC lcm))
(def-global (numerator q))
(def-global (denominator q))
(def-global (floor x))
(def-global (ceiling x))
(def-global (truncate x))
(def-global (round x))
(def-global (rationalize x x))
(def-global (exp z))
;(def-global (log z)) ; extended in r7rs: has (log z z) variant where second arg is base (defaults to e)
(def-global (sin z))
(def-global (cos z))
(def-global (tan z))
(def-global (asin z))
(def-global (acos z))
(def-global atan (mark-argcheck ARGCHECK_Z_OR_X_X atan)) ;(atan z) (atan x x)
(def-global (sqrt z))
(def-global expt (mark-argcheck EXPT_Z_Z expt))
(def-global (make-rectangular x x))
(def-global (make-polar x x))
(def-global (real-part z))
(def-global (imag-part z))
(def-global (magnitude z))
(def-global (angle z))
(def-global (exact->inexact z)) ; r7rs name: inexact
(def-global inexact->exact (mark-argcheck TOEXACT_Z inexact->exact)) ; r7rs name: exact
; 6.2.6 Numerical input and output
(def-global (number->string z radix ?))
(def-global (string->number string radix ?))
; 6.3.1 Booleans
(def-global not (mark-argcheck NOT_OBJ not))
(def-global (boolean? obj))
; 6.3.2 Pairs and lists
(def-global pair? (mark-argcheck ISPAIR_OBJ pair?))
(def-global (cons obj obj))
(def-global car (mark-argcheck CAR_PAIR car))
(def-global cdr (mark-argcheck CDR_PAIR cdr))
(def-global (set-car! pair obj))
(def-global (set-cdr! pair obj))
(def-global caar (mark-argcheck CAAR_PAIR caar))
(def-global cadr (mark-argcheck CADR_PAIR cadr))
(def-global cdar (mark-argcheck CDAR_PAIR cdar))
(def-global cddr (mark-argcheck CDDR_PAIR cddr))
;(def-global (caaar pair)) ; caaar & friends are implemented in init
;(def-global (caadr pair))
;(def-global (cadar pair))
;(def-global (caddr pair))
;(def-global (cdaar pair))
;(def-global (cdadr pair))
;(def-global (cddar pair))
;(def-global (cdddr pair))
;(def-global (caaaar pair))
;(def-global (caaadr pair))
;(def-global (caadar pair))
;(def-global (caaddr pair))
;(def-global (cadaar pair))
;(def-global (cadadr pair))
;(def-global (caddar pair))
;(def-global (cadddr pair))
;(def-global (cdaaar pair))
;(def-global (cdaadr pair))
;(def-global (cdadar pair))
;(def-global (cdaddr pair))
;(def-global (cddaar pair))
;(def-global (cddadr pair))
;(def-global (cdddar pair))
;(def-global (cddddr pair))
(def-global null? (mark-argcheck ISNULL_OBJ null?))
(def-global (list? obj))
(def-global (list obj ...))
(def-global length (mark-argcheck LENGTH_LIST length))
(def-global append (mark-argcheck ARGCHECK_LIST_ETC_OBJ_OPT
(argc-dispatch-lambda
(lambda () '()) (lambda (x) x) (lambda (x y) (append x y))
(lambda (x y z) (append x y z)) (lambda (x y z t) (append x y z t)) append)))
(def-global (reverse list))
;(def-global (list-tail list index)) ;implemented in init
;(def-global (list-ref list index)) ;implemented in init
(def-global (memq obj list))
(def-global (memv obj list))
;(def-global (member obj list)) ; extended in r7rs
(def-global (assq obj alist))
(def-global (assv obj alist))
;(def-global (assoc obj alist)) ; extended in r7rs
; 6.3.3 Symbols
(def-global (symbol? obj))
(def-global (symbol->string symbol))
(def-global (string->symbol string))
; 6.3.4 Characters
(def-global (char? obj))
;(def-global (char=? char char)) ; see extended versions in r7rs
;(def-global (char<? char char))
;(def-global (char>? char char))
;(def-global (char<=? char char))
;(def-global (char>=? char char))
;(def-global (char-ci=? char char))
;(def-global (char-ci<? char char))
;(def-global (char-ci>? char char))
;(def-global (char-ci<=? char char))
;(def-global (char-ci>=? char char))
(def-global (char-alphabetic? char))
(def-global (char-numeric? char))
(def-global (char-whitespace? char))
(def-global (char-upper-case? char))
(def-global (char-lower-case? char))
(def-global (char->integer char))
(def-global (integer->char n))
(def-global (char-upcase char))
(def-global (char-downcase char))
; 6.3.5 Strings
(def-global (string? obj))
(def-global (make-string k char ?))
(def-global (string char ...))
(def-global string-length (mark-argcheck LENGTH_STRING string-length))
(def-global string-ref (mark-argcheck REF_STRING_INDEX string-ref))
(def-global string-set! (mark-argcheck SET_STRING_INDEX_CHAR string-set!))
;(def-global (string=? string string)) ; see extended versions in r7rs
;(def-global (string<? string string))
;(def-global (string>? string string))
;(def-global (string<=? string string))
;(def-global (string>=? string string))
;(def-global (string-ci=? string string))
;(def-global (string-ci<? string string))
;(def-global (string-ci>? string string))
;(def-global (string-ci<=? string string))
;(def-global (string-ci>=? string string))
(def-global (substring string start end))
(def-global (string-append string ...))
;(def-global (string->list string)) ; extended version is in init
(def-global (list->string list))
;(def-global (string-copy string)) ; extended version is in init
;(def-global (string-fill! string char)) ; extended version is in init
; 6.3.6 Vectors
(def-global (vector? obj))
(def-global (make-vector k obj ?))
(def-global (vector obj ...))
(def-global vector-length (mark-argcheck LENGTH_VECTOR vector-length))
(def-global vector-ref (mark-argcheck REF_VECTOR_INDEX vector-ref))
(def-global vector-set! (mark-argcheck SET_VECTOR_INDEX_OBJ vector-set!))
;(def-global (vector->list vector)) ; extended version is in init
(def-global (list->vector list))
(def-global (vector-fill! vector obj))
; 6.4 Control features
(define *values-tag* (list 'values))
;(def-global *values-tag* *values-tag*)
(def-global (procedure? obj))
(def-global apply (mark-argcheck ARGCHECK_PROC_OBJ_ETC_LIST
(argc-dispatch-lambda
#f #f (lambda (x l) (scheme-apply (length l) x l))
(lambda (x . a*l) (let ([l (splice-last-list a*l)]) (scheme-apply (length l) x l))))))
;(def-global (map procn list list ...)) ; implemented in init
;(def-global (for-each procn list list ...)) ; implemented in init
(def-global (call/cc proc1cc)
(lambda (p) ;p is annotated, pre-checked as proc1cc
(call/cc (lambda (k) ;k is not annotated, so should be called directly (with 1 arg)
(p (scheme-lambda-rest 1 args (k (if (list1? args) (car args) (cons *values-tag* args)))))))))
(def-global call-with-current-continuation (get-global 'call/cc))
(def-global (values obj ...)
(lambda args (if (list1? args) (car args) (cons *values-tag* args))))
(def-global (call-with-values thunk proc)
(lambda (producer consumer)
(let ([v (producer)]) ;pre-checked as thunk
(if (and (pair? v) (eq? (car v) *values-tag*))
(scheme-apply (length (cdr v)) consumer (cdr v))
(scheme-call 1 consumer v)))))
(def-global (dynamic-wind thunk thunk thunk))
; 6.5 Eval
;(eval expression environment-specifier)
(def-global (eval obj environment ?)
(argc-dispatch-lambda #f
(lambda (x) (scheme-eval x))
(lambda (x environment) (scheme-eval x environment))))
; R5RS environment procedures are defined below in R7RS section
; 6.6 Input and output
; 6.6.1 Ports
(def-global (call-with-input-file string proc1ip))
(def-global (call-with-output-file string proc1op))
(def-global (input-port? obj))
(def-global (output-port? obj))
(def-global (current-input-port iport ? boolean ?)) ; parameter, as in r7rs
(def-global (current-output-port oport ? boolean ?)) ; parameter, as in r7rs
(def-global (with-input-from-file string thunk))
(def-global (with-output-to-file string thunk))
(def-global (open-input-file string))
(def-global (open-output-file string))
(def-global (close-input-port iport))
(def-global (close-output-port oport))
; 6.6.2 Input
(def-global (read iport ?))
(def-global (read-char iport ?))
(def-global (peek-char iport ?))
(def-global (eof-object? obj))
(def-global (char-ready? iport ?))
; 6.6.3 Output
(def-global (write obj oport ?))
(def-global (display obj oport ?))
(def-global (write-char char oport ?))
(def-global (newline oport ?))
; 6.6.4 System interface
; R5RS load is defined below in R7RS section
;(transcript-on filename)
;(transcript-off)
;------------------------------------------------------------------------------
; R7RS extras
; 4.2.5. Delayed evaluation
(def-global (promise? obj))
(def-global (make-promise obj))
(def-global (make-lazy-promise obj))
(def-global (force box))
; 4.2.6. Dynamic bindings
(def-global (make-parameter obj proc1 ?) ; macro is in init
(lambda args (make-annotated-procedure (apply make-parameter args) (range-argc->annotation 0 2))))
; 4.2.9. Case-lambda
(def-global (make-case-lambda obj ...) ; macro is in init
(lambda args (make-annotated-procedure (apply make-case-lambda args) (rest-argc->annotation 1))))
; 6.2.6. Numerical operations
(def-global exact (mark-argcheck TOEXACT_Z exact)) ; r5rs name: inexact->exact
(def-global (inexact z)) ; r5rs name: exact->inexact
(def-global (exact-integer? z))
(def-global (nan? z))
(def-global (finite? z))
(def-global (infinite? z))
(def-global floor-quotient (mark-argcheck MQU_N_N floor-quotient))
(def-global floor-remainder (mark-argcheck MLO_N_N floor-remainder))
;(floor/ n n) is in the init code
(def-global truncate-quotient (mark-argcheck QUO_N_N truncate-quotient))
(def-global truncate-remainder (mark-argcheck REM_N_N truncate-remainder))
;(truncate/ n n) is in the init code
(def-global (log z z ?))
;(square z) is in the init code
(def-global (exact-integer-sqrt k)
(lambda (x) (let ([r (fxsqrt x)]) (list *values-tag* r (- x (* r r))))))
; 6.3. Booleans
(def-global (boolean=? boolean boolean boolean ...))
; 6.4. Pairs and lists
(def-global (make-list k obj ?))
(def-global (list-copy obj))
;(def-global (list-set! list index obj)) ; implemented in init
;(def-global (member obj list proc2 ?)) ; implemented in init
;(def-global (assoc obj alist proc2 ?)) ; implemented in init
; 6.5. Symbols
(def-global (symbol=? symbol symbol symbol ...))
; 6.6. Characters
(def-global (char=? char char char ...))
(def-global (char<? char char char ...))
(def-global (char>? char char char ...))
(def-global (char<=? char char char ...))
(def-global (char>=? char char char ...))
(def-global (char-ci=? char char char ...))
(def-global (char-ci<? char char char ...))
(def-global (char-ci>? char char char ...))
(def-global (char-ci<=? char char char ...))
(def-global (char-ci>=? char char char ...))
(def-global (char-foldcase char))
(def-global (digit-value char))
; 6.7. Strings
(def-global (string=? string string string ...))
(def-global (string<? string string string ...))
(def-global (string>? string string string ...))
(def-global (string<=? string string string ...))
(def-global (string>=? string string string ...))
(def-global (string-ci=? string string string ...))
(def-global (string-ci<? string string string ...))
(def-global (string-ci>? string string string ...))
(def-global (string-ci<=? string string string ...))
(def-global (string-ci>=? string string string ...))
(def-global (string-upcase string))
(def-global (string-downcase string))
(def-global (string-foldcase string))
; 6.8. Vectors
;(vector->string vector start ? end ?) ; implemented in init
;(string->vector string start ? end ?) ; implemented in init
;(vector-copy vector start ? end ?) ; implemented in init
;(vector-copy! vector index vector start ? end ?) ; implemented in init
(def-global (vector-append vector ...))
; 6.9. Bytevectors
(def-global (bytevector? obj))
(def-global (make-bytevector k u8 ?))
(def-global (bytevector u8 ...))
(def-global (bytevector-length u8vector))
(def-global (bytevector=? u8vector u8vector))
(def-global (bytevector-u8-ref u8vector index))
(def-global (bytevector-u8-set! u8vector index u8))
;(def-global (bytevector->list u8vector start? end?)) ; not in r7rs, implemented in init
(def-global (list->bytevector u8list)) ; not in r7rs
;(bytevector-copy u8vector start ? end ?) ; implemented in init
;(bytevector-copy! u8vector index u8vector start ? end ?) ; implemented in init
(def-global (bytevector-append u8vector ...))
; 6.10. Control features
;(def-global (string-map proc string string ...)) ; implemented in init
;(def-global (vector-map proc vector vector ...)) ; implemented in init
;(def-global (string-for-each proc string string ...)) ; implemented in init
;(def-global (vector-for-each proc vector vector ...)) ; implemented in init
; 6.11. Exceptions
(def-global (with-exception-handler proc1 thunk))
(def-global (raise obj))
(def-global (raise-continuable obj))
(def-global (error string obj ...))
(def-global (error-object? obj))
(def-global (error-object-message record)) ;fixme: error-object
(def-global (error-object-irritants record)) ;fixme: error-object
(def-global (read-error? obj))
(def-global (file-error? obj))
; 6.12. Environments and evaluation
; r7rs 'environment' procedure
; NB: r7rs requires the result to be immutable in all respects, but we don't care: making them
; immutable would require (selectively) copying the stores and flagging them, which is a drag
(def-global (environment list ...))
; r5rs/r7rs (scheme-report-environment n)
; note that the returned environment allows set! to imported locations like car
; (which are re-exported from sharpf base); such set! s will change the definition of 'car' everywhere
; because stores are not copied. Also, evaluating '(define foo ..) and other definitions like it will
; keep the corresponding values in gensym-ed locations unique to this call to scheme-report-environment;
; if another call to scheme-report-environment is made, it will produce a separate environment which
; does not share store locations of newly defined variables/syntax with the first one. Which is OK
; wrt standards because most of these details are either undefined or explicitly allowed in repl
(def-global (scheme-report-environment n)
(lambda (n)
(case n
[(5) (environment '(scheme r5rs))]
[else (error "scheme-report-environment version not supported" n)])))
; r5rs/r7rs (null-environment n)
; todo: either filter out value bindings from (scheme-report-environment n)
; or have separate (scheme r5rs-null) library for simplicity
(def-global (null-environment n)
(lambda (n)
(case n
[(5) (environment '(scheme r5rs-null))]
[else (error "null-environment version not supported" n)])))
; r5rs/r7rs (interaction-environment)
; NB: (current-environment) would return a snapshot of the current env at the moment of the call;
; if current env is extended later (via import), the snapshot won't reflect it
(def-global (interaction-environment)
(lambda ()
; improper alist with nothin but a redirector of lookups to the actual current env
(lambda (id) (env-lookup id *current-environment* #t))))
; 6.13.1. Ports
(def-global (port? obj))
(def-global (textual-port? port))
(def-global (binary-port? port))
(def-global (close-port port))
(def-global (call-with-port port proc1p))
(def-global (current-error-port oport ? boolean ?)) ; parameter
(def-global (open-binary-input-file string))
(def-global (open-input-string string))
(def-global (open-input-bytevector u8vector))
(def-global (open-binary-output-file string))
(def-global (input-port-open? iport))
(def-global (output-port-open? oport))
(def-global (open-output-string))
(def-global (get-output-string oport))
(def-global (open-output-bytevector))
(def-global (get-output-bytevector oport))
; 6.13.2. Input
(def-global (eof-object))
(def-global (read-u8 iport ?))
(def-global (peek-u8 iport ?))
(def-global (u8-ready? iport ?))
(def-global (read-line iport ?))
(def-global (read-string k iport ?))
(def-global (read-bytevector k iport ?))
;(def-global (read-string! string port ? start ? end ?)) ; not in r7rs, implemented in init
;(def-global (read-bytevector! bytevector port ? start ? end ?)) ; implemented in init
; 6.13.3. Output
(def-global (write-shared obj oport ?))
(def-global (write-simple obj oport ?))
(def-global (flush-output-port oport ?))
;(def-global (write-string string oport ? start ? end ?)) ; implemented in init
(def-global (write-u8 u8 oport ?))
;(def-global (write-bytevector u8vector oport ? start ? end ?)) ; implemented in init
; 6.14. System interface
; r7rs load with optional environment
; resolves relative file names, barfs on header forms
(def-global (load obj environment ?)
(lambda (name . ?environment)
(define ci? #f) ; case-sensitive by default
(let ([env (if (pair? environment) (car ?environment) *current-environment*)])
(for-each-file/lib-sexp
(lambda (sexp)
(sexp-case sexp
[(import . *) (error "unexpected form encountered by load in" name sexp)] ; r7rs does not allow it
[(define-library . *) (error "unexpected form encountered by load in" name sexp)] ; r7rs does not allow it
[else (scheme-eval sexp env)]))
name ci?))))
(def-global (exit obj ?))
(def-global (emergency-exit obj ?))
(def-global (file-exists? string))
(def-global (delete-file string))
(def-global (command-line))
(def-global (get-environment-variable string))
(def-global (current-second))
(def-global (current-jiffy))
(def-global (jiffies-per-second))
(def-global (features))
;------------------------------------------------------------------------------
; #F extras
(def-global (circular? obj))
(def-global (byte? obj))
(def-global (last-pair pair))
(def-global (meml obj list))
(def-global (assl obj alist))
; sub{string,vector,bytevector,utf8} operations
(def-global (substring->list string start end))
(def-global (substring-copy! string index string start end))
(def-global (substring-fill! string char start end))
(def-global (substring->vector string start end))
(def-global (subvector->list vector start end))
(def-global (subvector->string vector start end))
(def-global (subvector-copy! vector index vector start end))
(def-global (subvector vector start end))
(def-global (subvector-fill! vector obj start end))
(def-global (subbytevector->list u8vector start end))
(def-global (subbytevector-copy! u8vector index u8vector start end))
(def-global (subbytevector u8vector start end))
(def-global (subutf8->string u8vector start end))
(def-global (substring->utf8 string start end))
; record internals
(def-global (record? obj obj ?))
(def-global (make-record obj k))
(def-global (record-type-descriptor record))
(def-global (record-length record))
(def-global (record-ref record index))
(def-global (record-set! record index obj))
(def-global (new-record-type obj list))
; i/o
(def-global (with-input-from-port iport thunk))
(def-global (with-output-to-port oport thunk))
(def-global (read-substring! string start end iport))
(def-global (read-subbytevector! u8vector start end iport))
(def-global (write-substring string start end oport))
(def-global (write-subbytevector u8vector start end oport))
; misc
(def-global (void))
(def-global (reverse! list)) ; used in init code
(def-global (system string))
(def-global (print-procedure proc))
(def-global (current-environment) (lambda () *current-environment*))
(def-global (set-current-environment! environment) (lambda (e) (set! *current-environment* e)))
(def-global (current-macro-store) (lambda () *current-macro-store*))
(def-global (current-value-store) (lambda () *current-value-store*))
(def-global (root-environment) (lambda () root-environment))
(def-global (initial-value-environment) (lambda () *initial-value-environment*))
(def-global (initial-macro-environment) (lambda () *initial-macro-environment*))
(def-global (library-info-cache) (lambda () *library-info-cache*))
(def-global (expand obj environment ?)
(argc-dispatch-lambda #f
(lambda (x) (cons *values-tag* (scheme-expand-to-list x)))
(lambda (x environment) (cons *values-tag* (scheme-expand-to-list x environment)))))
; experiments
(%definition "extern obj *cxa_lis3(obj *r, int l, obj *hp, obj ax, obj ay, obj az);")
(%localdef "obj *cxa_lis3(obj *r, int l, obj *hp, obj ax, obj ay, obj az) {
obj d = mknull();
hreserve(hbsz(3)*3+1, l); /* l live regs */
*--hp = d;
*--hp = az;
*--hp = obj_from_size(PAIR_BTAG);
d = (hendblk(3));
*--hp = d;
*--hp = ay;
*--hp = obj_from_size(PAIR_BTAG);
d = (hendblk(3));
*--hp = d;
*--hp = ax;
*--hp = obj_from_size(PAIR_BTAG);
d = hendblk(3);
*--hp = d;
return hp;
}")
(def-global (lis3 obj obj obj)
(lambda (x y z)
(%prim "obj((hp = cxa_lis3(r, $live, hp, obj_from_$arg, obj_from_$arg, obj_from_$arg), *hp++))" x y z)))
;------------------------------------------------------------------------------
; Code to feed the interpreter at initialization time
(%localdef #<<EOS
/* initialization code */
static char *ints_init_code =
"(define-syntax syntax-error"
" (syntax-rules ()"
" [(_ #&(string? msg) arg ...) #&(error msg arg ...)]))"
""
"(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])"
" (syntax-rules ()"
" [(_ args . body)"
" (old-lambda args (let-syntax () . body))])))"
""
"(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 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 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 ...) ...))))])))"
""
"(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 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 ...))])))"
""
"(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 cond-expand"
" (letrec-syntax"
" ([if-expand"
" (syntax-rules (and or not library)"
" [(_ (and) con alt) con]"
" [(_ (and r) con alt) (if-expand r con alt)]"
" [(_ (and r . r*) con alt) (if-expand r (if-expand (and . r*) con alt) alt)]"
" [(_ (or) con alt) alt]"
" [(_ (or r) con alt) (if-expand r con alt)]"
" [(_ (or r . r*) con alt) (if-expand r con (if-expand (or . r*) con alt))]"
" [(_ (not r) con alt) (if-expand r alt con)]"
" [(_ (library #&(library? x)) con alt) con]"
" [(_ (library x) con alt) alt]"
" [(_ #&(feature? x) con alt) con]"
" [(_ #&(id? x) con alt) alt]"
" [(_ x con alt) (syntax-error \"unrecognized cond-expand feature requirement:\" x)])])"
" (syntax-rules (else)"
" [(_) (void)]"
" [(_ [else . exps])"
" (begin . exps)]"
" [(_ [x] . rest)"
" (if-expand x (void) (cond-expand . rest))]"
" [(_ [x . exps] . rest)"
" (if-expand x (begin . exps) (cond-expand . rest))])))"
""
"(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]))"
""
"(define (fail-lambda . args) "
" (error 'case-lambda \"unexpected number of arguments\" args))"
""
"(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) 999])]"
" [unroll-cases"
" (syntax-rules ()"
" [(_ () c ...) "
" (make-case-lambda c ... 0 999 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] ...))])))"
""
"(define-syntax delay-force"
" (syntax-rules () [(_ x) (make-lazy-promise (lambda () x))]))"
""
"(define-syntax delay"
" (syntax-rules () [(_ x) (delay-force (make-promise x))]))"
""
"(set! call-with-current-continuation call/cc)"
""
"(define (list-tail ls k)"
" (if (= k 0) ls (list-tail (cdr ls) (- k 1))))"
""
"(define (list-ref ls k) "
" (car (list-tail ls k)))"
""
"(define (list-set! ls k x)"
" (set-car! (list-tail ls k) x)) "
""
"(define (caaar x) (car (car (car x))))"
"(define (caadr x) (car (car (cdr x))))"
"(define (cadar x) (car (cdr (car x))))"
"(define (caddr x) (car (cdr (cdr x))))"
"(define (cdaar x) (cdr (car (car x))))"
"(define (cdadr x) (cdr (car (cdr x))))"
"(define (cddar x) (cdr (cdr (car x))))"
"(define (cdddr x) (cdr (cdr (cdr x))))"
"(define (caaaar x) (car (car (car (car x)))))"
"(define (caaadr x) (car (car (car (cdr x)))))"
"(define (caadar x) (car (car (cdr (car x)))))"
"(define (caaddr x) (car (car (cdr (cdr x)))))"
"(define (cadaar x) (car (cdr (car (car x)))))"
"(define (cadadr x) (car (cdr (car (cdr x)))))"
"(define (caddar x) (car (cdr (cdr (car x)))))"
"(define (cadddr x) (car (cdr (cdr (cdr x)))))"
"(define (cdaaar x) (cdr (car (car (car x)))))"
"(define (cdaadr x) (cdr (car (car (cdr x)))))"
"(define (cdadar x) (cdr (car (cdr (car x)))))"
"(define (cdaddr x) (cdr (car (cdr (cdr x)))))"
"(define (cddaar x) (cdr (cdr (car (car x)))))"
"(define (cddadr x) (cdr (cdr (car (cdr x)))))"
"(define (cdddar x) (cdr (cdr (cdr (car x)))))"
"(define (cddddr x) (cdr (cdr (cdr (cdr x)))))"
""
"(define (%member obj l eq) "
" (and (pair? l) (if (eq obj (car l)) l (%member obj (cdr l) eq))))"
""
"(define member"
" (case-lambda"
" [(obj l) (meml obj l)]"
" [(obj l eq) (%member obj l eq)]))"
""
"(define (%assoc obj al eq) "
" (and (pair? al) (if (eq obj (caar al)) (car al) (%assoc obj (cdr al) eq))))"
""
"(define assoc"
" (case-lambda"
" [(obj al) (assl obj al)]"
" [(obj al eq) (%assoc obj al eq)]))"
""
"(define (map p l . l*)"
" (if (null? l*)"
" (let loop ([l l] [r '()])"
" (if (pair? l) (loop (cdr l) (cons (p (car l)) r)) (reverse! r)))"
" (let loop ([l* (cons l l*)] [r '()])"
" (if (let lp ([l* l*]) (or (null? l*) (and (pair? (car l*)) (lp (cdr l*)))))"
" (loop (map cdr l*) (cons (apply p (map car l*)) r))"
" (reverse! r)))))"
""
"(define (for-each p l . l*)"
" (if (null? l*)"
" (let loop ([l l]) (if (pair? l) (begin (p (car l)) (loop (cdr l)))))"
" (let loop ([l* (cons l l*)])"
" (if (let lp ([l* l*]) (or (null? l*) (and (pair? (car l*)) (lp (cdr l*)))))"
" (begin (apply p (map car l*)) (loop (map cdr l*)))))))"
""
"(define (string-map p s . s*)"
" (if (null? s*)"
" (let* ([len (string-length s)] [res (make-string len)])"
" (do ([i 0 (+ i 1)]) [(>= i len) res]"
" (string-set! res i (p (string-ref s i)))))"
" (list->string (apply map p (map string->list (cons s s*))))))"
""
"(define (vector-map p v . v*)"
" (if (null? v*)"
" (let* ([len (vector-length v)] [res (make-vector len)])"
" (do ([i 0 (+ i 1)]) [(>= i len) res]"
" (vector-set! res i (p (vector-ref v i)))))"
" (list->vector (apply map p (map vector->list (cons v v*))))))"
""
"(define (string-for-each p s . s*)"
" (if (null? s*)"
" (let ([len (string-length s)])"
" (do ([i 0 (+ i 1)]) [(>= i len)] (p (string-ref s i))))"
" (apply for-each p (map string->list (cons s s*)))))"
""
"(define (vector-for-each p v . v*)"
" (if (null? v*)"
" (let ([len (vector-length v)])"
" (do ([i 0 (+ i 1)]) [(>= i len)] (p (vector-ref v i))))"
" (apply for-each p (map vector->list (cons v v*)))))"
""
"(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 define-record-type"
" (letrec-syntax"
" ([id-eq??"
" (syntax-rules ()"
" [(_ id b kt kf)"
" ((syntax-lambda (id ok) ((syntax-rules () [(_ b) (id)]) ok))"
" (syntax-rules () [(_) kf]) (syntax-rules () [(_) kt]))])]"
" [id-assq??"
" (syntax-rules ()"
" [(_ id () kt kf) kf]"
" [(_ id ([id0 . r0] . idr*) kt kf) (id-eq?? id id0 (kt . r0) (id-assq?? id idr* kt kf))])]"
" [init"
" (syntax-rules ()"
" [(_ r () fi* (x ...)) (begin x ... r)]"
" [(_ r (id0 . id*) fi* (x ...))"
" (id-assq?? id0 fi* "
" (syntax-rules () [(_ i0) (init r id* fi* (x ... (record-set! r i0 id0)))]) "
" (syntax-error \"id in define-record-type constructor is not a field:\" id0))])]"
" [unroll"
" (syntax-rules ()"
" [(_ rtn (consn id ...) predn () ([f i] ...) ([a ia] ...) ([m im] ...))"
" (begin"
" (define rtn (new-record-type 'rtn '(f ...)))"
" (define consn (lambda (id ...) (let ([r (make-record rtn #&(length (f ...)))]) (init r (id ...) ([f i] ...) ()))))"
" (define predn (lambda (obj) (record? obj rtn)))"
" (define a (lambda (obj) (record-ref obj ia))) ..."
" (define m (lambda (obj val) (record-set! obj im val))) ..."
" (define 'rtn))]"
" [(_ rtn cf* predn ([fn accn] fam ...) (fi ...) (ai ...) (mi ...))"
" (unroll rtn cf* predn (fam ...) "
" (fi ... [fn #&(length (fi ...))]) (ai ... [accn #&(length (fi ...))]) (mi ...))]"
" [(_ rtn cf* predn ([fn accn modn] fam ...) (fi ...) (ai ...) (mi ...))"
" (unroll rtn cf* predn (fam ...) "
" (fi ... [fn #&(length (fi ...))]) (ai ... [accn #&(length (fi ...))]) (mi ... [modn #&(length (fi ...))]))])])"
" (syntax-rules ()"
" [(_ rtn (consn id ...) predn (fn . am) ...)"
" (unroll rtn (consn id ...) predn ((fn . am) ...) () () ())])))"
""
"(define-syntax let*-values"
" (syntax-rules ()"
" [(_ () . body) (let () . body)]"
" [(_ ([(a) x] . b*) . body) (let ([a x]) (let*-values b* . body))]"
" [(_ ([aa x] . b*) . body) (call-with-values (lambda () x) (lambda aa (let*-values b* . body)))]))"
""
"(define-syntax let-values"
" (letrec-syntax"
" ([loop "
" (syntax-rules ()"
" [(_ (new-b ...) new-aa x map-b* () () . body)"
" (let*-values (new-b ... [new-aa x]) (let map-b* . body))]"
" [(_ (new-b ...) new-aa old-x map-b* () ([aa x] . b*) . body)"
" (loop (new-b ... [new-aa old-x]) () x map-b* aa b* . body)]"
" [(_ new-b* (new-a ...) x (map-b ...) (a . aa) b* . body)"
" (loop new-b* (new-a ... tmp-a) x (map-b ... [a tmp-a]) aa b* . body)]"
" [(_ new-b* (new-a ...) x (map-b ...) a b* . body) "
" (loop new-b* (new-a ... . tmp-a) x (map-b ... [a tmp-a]) () b* . body)])])"
" (syntax-rules ()"
" [(_ () . body) (let () . body)]"
" [(_ ([aa x] . b*) . body)"
" (loop () () x () aa b* . body)])))"
""
"(define-syntax define-values"
" (letrec-syntax"
" ([loop "
" (syntax-rules ()"
" [(_ new-aa ([a tmp-a] ...) () x)"
" (begin"
" (define a (void)) ..."
" (define (call-with-values (lambda () x) (lambda new-aa (set! a tmp-a) ...))))]"
" [(_ (new-a ...) (map-a ...) (a . aa) x) "
" (loop (new-a ... tmp-a) (map-a ... [a tmp-a]) aa x)]"
" [(_ (new-a ...) (map-a ...) a x) "
" (loop (new-a ... . tmp-a) (map-a ... [a tmp-a]) () x)])])"
" (syntax-rules ()"
" [(_ () x) (define x)]"
" [(_ aa x) (loop () () aa x)])))"
""
"(define-syntax parameterize"
" (letrec-syntax"
" ([loop "
" (syntax-rules ()"
" [(_ ([param value p old new] ...) () body)"
" (let ([p param] ...)"
" (let ([old (p)] ... [new (p value #f)] ...)"
" (dynamic-wind"
" (lambda () (p new #t) ...)"
" (lambda () . body)"
" (lambda () (p old #t) ...))))]"
" [(_ args ([param value] . rest) body)"
" (loop ([param value p old new] . args) rest body)])])"
" (syntax-rules ()"
" [(_ ([param value] ...) . body)"
" (loop () ([param value] ...) body)])))"
""
"(define-syntax guard"
" (letrec-syntax"
" ([guard-aux"
" (syntax-rules (else =>)"
" [(guard-aux reraise (else result1 result2 ...))"
" (begin result1 result2 ...)]"
" [(guard-aux reraise (test => result))"
" (let ([temp test]) (if temp (result temp) reraise))]"
" [(guard-aux reraise (test => result) clause1 clause2 ...)"
" (let ([temp test])"
" (if temp"
" (result temp)"
" (guard-aux reraise clause1 clause2 ...)))]"
" [(guard-aux reraise (test)) (or test reraise)]"
" [(guard-aux reraise (test) clause1 clause2 ...)"
" (let ([temp test])"
" (if temp temp (guard-aux reraise clause1 clause2 ...)))]"
" [(guard-aux reraise (test result1 result2 ...))"
" (if test (begin result1 result2 ...) reraise)]"
" [(guard-aux reraise (test result1 result2 ...) clause1 clause2 ...)"
" (if test"
" (begin result1 result2 ...)"
" (guard-aux reraise clause1 clause2 ...))])])"
" (syntax-rules ()"
" [(guard (var clause ...) e1 e2 ...)"
" ((call/cc"
" (lambda (guard-k)"
" (with-exception-handler"
" (lambda (condition)"
" ((call/cc"
" (lambda (handler-k)"
" (guard-k"
" (lambda ()"
" (let ([var condition])"
" (guard-aux"
" (handler-k"
" (lambda ()"
" (raise-continuable condition)))"
" clause"
" ...))))))))"
" (lambda ()"
" (call-with-values"
" (lambda () e1 e2 ...)"
" (lambda args"
" (guard-k (lambda () (apply values args))))))))))])))"
""
"(define (floor/ x y) (values (floor-quotient x y) (floor-remainder x y)))"
"(define (truncate/ x y) (values (truncate-quotient x y) (truncate-remainder x y)))"
"(define (square x) (* x x))"
""
"(define string->list"
" (case-lambda"
" [(str) (substring->list str 0 (string-length str))]"
" [(str start) (substring->list str start (string-length str))]"
" [(str start end) (substring->list str start end)]))"
""
"(define string-copy"
" (case-lambda"
" [(str) (substring str 0 (string-length str))]"
" [(str start) (substring str start (string-length str))]"
" [(str start end) (substring str start end)]))"
""
"(define string-copy!"
" (case-lambda"
" [(to at from) (substring-copy! to at from 0 (string-length from))]"
" [(to at from start) (substring-copy! to at from start (string-length from))]"
" [(to at from start end) (substring-copy! to at from start end)]))"
""
"(define string-fill!"
" (case-lambda"
" [(str c) (substring-fill! str c 0 (string-length str))]"
" [(str c start) (substring-fill! str c start (string-length str))]"
" [(str c start end) (substring-fill! str c start end)]))"
""
"(define vector->list"
" (case-lambda"
" [(vec) (subvector->list vec 0 (vector-length vec))]"
" [(vec start) (subvector->list vec start (vector-length vec))]"
" [(vec start end) (subvector->list vec start end)]))"
""
"(define vector->string"
" (case-lambda"
" [(vec) (subvector->string vec 0 (vector-length vec))]"
" [(vec start) (subvector->string vec start (vector-length vec))]"
" [(vec start end) (subvector->string vec start end)]))"
""
"(define string->vector"
" (case-lambda"
" [(str) (substring->vector str 0 (string-length str))]"
" [(str start) (substring->vector str start (string-length str))]"
" [(str start end) (substring->vector str start end)]))"
""
"(define vector-copy!"
" (case-lambda"
" [(to at from) (subvector-copy! to at from 0 (vector-length from))]"
" [(to at from start) (subvector-copy! to at from start (vector-length from))]"
" [(to at from start end) (subvector-copy! to at from start end)]))"
""
"(define vector-copy"
" (case-lambda"
" [(vec) (subvector vec 0 (vector-length vec))]"
" [(vec start) (subvector vec start (vector-length vec))]"
" [(vec start end) (subvector vec start end)]))"
""
"(define vector-fill!"
" (case-lambda"
" [(vec x) (subvector-fill! vec x 0 (vector-length vec))]"
" [(vec x start) (subvector-fill! vec x start (vector-length vec))]"
" [(vec x start end) (subvector-fill! vec x start end)]))"
""
"(define bytevector->list"
" (case-lambda"
" [(vec) (subbytevector->list vec 0 (bytevector-length vec))]"
" [(vec start) (subbytevector->list vec start (bytevector-length vec))]"
" [(vec start end) (subbytevector->list vec start end)]))"
""
"(define bytevector-copy!"
" (case-lambda"
" [(to at from) (subbytevector-copy! to at from 0 (bytevector-length from))]"
" [(to at from start) (subbytevector-copy! to at from start (bytevector-length from))]"
" [(to at from start end) (subbytevector-copy! to at from start end)]))"
""
"(define bytevector-copy"
" (case-lambda"
" [(vec) (subbytevector vec 0 (bytevector-length vec))]"
" [(vec start) (subbytevector vec start (bytevector-length vec))]"
" [(vec start end) (subbytevector vec start end)]))"
""
"(define utf8->string"
" (case-lambda"
" [(vec) (subutf8->string vec 0 (bytevector-length vec))]"
" [(vec start) (subutf8->string vec start (bytevector-length vec))]"
" [(vec start end) (subutf8->string vec start end)]))"
""
"(define string->utf8"
" (case-lambda"
" [(str) (substring->utf8 str 0 (string-length str))]"
" [(str start) (substring->utf8 str start (string-length str))]"
" [(str start end) (substring->utf8 str start end)]))"
""
"(define read-string!"
" (case-lambda"
" [(str) (read-substring! str 0 (string-length str) (current-input-port))]"
" [(str p) (read-substring! str 0 (string-length str) p)]"
" [(str p start) (read-substring! str start (string-length str) p)]"
" [(str p start end) (read-substring! str start end p)]))"
""
"(define read-bytevector!"
" (case-lambda"
" [(vec) (read-subbytevector! vec 0 (bytevector-length vec) (current-input-port))]"
" [(vec p) (read-subbytevector! vec 0 (bytevector-length vec) p)]"
" [(vec p start) (read-subbytevector! vec start (bytevector-length vec) p)]"
" [(vec p start end) (read-subbytevector! vec start end p)]))"
""
"(define write-string"
" (case-lambda"
" [(str) (write-substring str 0 (string-length str) (current-output-port))]"
" [(str p) (write-substring str 0 (string-length str) p)]"
" [(str p start) (write-substring str start (string-length str) p)]"
" [(str p start end) (write-substring str start end p)]))"
""
"(define write-bytevector"
" (case-lambda"
" [(vec) (write-subbytevector vec 0 (bytevector-length vec) (current-output-port))]"
" [(vec p) (write-subbytevector vec 0 (bytevector-length vec) p)]"
" [(vec p start) (write-subbytevector vec start (bytevector-length vec) p)]"
" [(vec p start end) (write-subbytevector vec start end p)]))"
;
EOS
)
(let ([p (%prim*?! "obj(mkiport_string($live, sialloc(ints_init_code, NULL)))")])
(let loop ([x (read p)])
(unless (eof-object? x)
;(display x)(newline)
(scheme-eval x) (loop (read p)))))
;------------------------------------------------------------------------------
; post-initialization environments
(define *initial-value-environment*
(let loop ([l *current-value-store*] [e '()])
(cond [(null? l) e]
[(symbol? (caar l)) (loop (cdr l) (cons (cons (caar l) (caar l)) e))]
[else (loop (cdr l) e)])))
(define *initial-macro-environment*
(let loop ([l (car *current-macro-store*)]
[e (append '((unquote . unquote) (unquote-splicing . unquote-splicing) (=> . =>) (else . else)) root-environment)])
(cond [(null? l) e]
[(symbol? (caar l)) (loop (cdr l) (cons (cons (caar l) (caar l)) e))]
[else (loop (cdr l) e)])))
; actual repl cannot spoil global environment, so we have to make a special one that keeps its defines separate
(define *repl-base-environment* ; contains interpreter's complete set of built-in bindings and syntax
(append *initial-macro-environment* ; all built-in syntax identifiers, including ... => else
*initial-value-environment* ; all built-in value identifiers, including additional procedures
(lambda (id) (fully-qualified-name ".repl" id)))) ; map other names to private ones in 'repl' namespace
;------------------------------------------------------------------------------
; REPL and main
(define (fprintf* port fstr olst)
(let loop ([flst (string->list fstr)] [olst olst])
(cond [(null? flst) #t]
[(char=? (car flst) #\~)
(and (pair? (cdr flst))
(let ([c (cadr flst)])
(cond
[(char=? c #\a)
(unless (null? olst)
(display (car olst) port)
(loop (cddr flst) (cdr olst)))]
[(char=? c #\s)
(unless (null? olst)
(write (car olst) port)
(loop (cddr flst) (cdr olst)))]
[(char=? c #\%)
(newline port)
(loop (cddr flst) olst)]
[(char=? c #\~)
(write-char #\~ port)
(loop (cddr flst) olst)]
[else #f])))] ; (error 'format "Unrecognized escape sequence")
[else
(write-char (car flst) port)
(loop (cdr flst) olst)])))
(define-syntax fprintf
(syntax-rules ()
[(_ p f o ...) (fprintf* p f (list o ...))]))
(define-syntax printf
(syntax-rules ()
[(_ f o ...) (fprintf* (current-output-port) f (list o ...))]))
; handle multiple values; todo: handle (void)
(define (scheme-eval->list x)
(let ([v (scheme-eval x)])
(if (and (pair? v) (eq? (car v) *values-tag*))
(cdr v)
(list v))))
; in the future, this one will pretty-print
(define (int-pp x)
(write x)
(newline))
(define (int-rep port)
(let ([sexp (read port)])
(if (eof-object? sexp)
#f
(sexp-case sexp
[(import . *) ; yes, we can process it interactively!
(if (sexp-match? '((* ...) ...) (cdr sexp))
(let ([import-env (load-import-sets scheme-eval (cdr sexp))] [oce *current-environment*])
; now we have to use import-env to make some storage locations
; selectibly visible under imported names in the current environment
(set! *current-environment* (adjoin-env/shadow import-env *current-environment*))
;(int-pp (mem-diff *current-environment* oce)) ; tmp hack for for debugging purposes
#t)
(c-error "invalid import form in repl" sexp))]
[(define-library . *) ; yes, we can process it interactively!
(if (and (sexp-match? '(* * ...) (cdr sexp))
(or (string? (cadr sexp)) (sexp-match? '(<symbol> <symbol> ...) (cadr sexp))))
(let ([lib (make-lib (cadr sexp))])
(let ([li (lookup-library-info lib)])
(if (not (vector-ref li 0)) ; not inited?
(process-define-library-decls lib (cddr sexp) ;=>
(lambda (used-libs import-env export-specs beg-forms)
(vector-set! li 0 used-libs)
(vector-set! li 1 import-env)
(vector-set! li 2 export-specs)
(vector-set! li 3 beg-forms)
;(int-pp (map car *library-info-cache*)) ; tmp hack for for debugging purposes
#t))
(c-error "library cannot be redefined in repl" lib))))
(c-error "invalid define-library form in repl" sexp))]
[else
(let loop ([results (scheme-eval->list sexp)])
(if (null? results)
#t
(let ([result (car results)])
(if (not (eq? result (void))) (int-pp result))
(loop (cdr results)))))]))))
(define *quiet* #f)
(define *exit* #f)
(define *greeting* #t)
(define (greet-once)
(when *greeting*
(printf "SIOF Scheme Interpreter 1.0.2~%")
(set! *greeting* #f)))
(define (int-repl port)
(unless *quiet* (greet-once) (printf "~%"))
(let loop ()
(display "> ")
(flush-output-port)
(if (call/cc
(lambda (return)
(set-reset-handler!
(lambda ()
(printf "; returning to top level~%")
(return #t)))
(int-rep port)))
(loop))))
(define (main argv)
(define (about)
(printf "siof 1.0.2~%")
(printf "Usage: siof [-qx] file ...~%")
(printf "-q suppress greeting~%")
(printf "-x exit after loading files on the command line~%")
(printf "-L path add path to library search path list~%"))
; first, set up for loads and interaction
(set! *current-environment* *repl-base-environment*)
(add-library-path! "./") ; default lib search path
; process command line, maybe end in REPL
(let loop ([args (cdr (command-line))])
(cond ; #f result means OK, return status 0, #t is status 1
[(null? args) (if *exit* #f (int-repl (current-input-port)))]
[(string=? (car args) "-q") (set! *quiet* #t) (loop (cdr args))]
[(string=? (car args) "-x") (set! *exit* #t) (loop (cdr args))]
[(and (string=? (car args) "-L") (pair? (cdr args))) (add-library-path! (cadr args)) (loop (cddr args))]
[(or (string=? (car args) "-h") (string=? (car args) "--help")) (about) #f]
[(not (file-exists? (car args))) (printf "cannot open input file ~a~%" (car args)) #t]
[else (unless *quiet* (greet-once) (printf "~%"))
(unless *quiet* (printf "; loading ~a...~%" (car args)))
((get-global 'load) (car args))
(loop (cdr args))])))