From d84362c0ab3da94d8ffe2870303667fd9173f427 Mon Sep 17 00:00:00 2001 From: ESL Date: Mon, 22 Jul 2024 01:56:03 -0400 Subject: [PATCH] n.h n.c s.c t.c fully generated from precursors --- n.c | 47 + pre/k-service.sf | 5313 ---------------------------------------------- pre/n-service.sf | 5050 ------------------------------------------- pre/n.sf | 49 + s.c | 45 +- t.c | 2 +- 6 files changed, 98 insertions(+), 10408 deletions(-) delete mode 100644 pre/k-service.sf delete mode 100644 pre/n-service.sf diff --git a/n.c b/n.c index 674cbe9..3b044fc 100644 --- a/n.c +++ b/n.c @@ -997,3 +997,50 @@ void oportputshared(obj x, obj p, int disp) { stabfree(e.pst); } +/* system-dependent extensions */ + +#include "s.h" + + +extern int is_tty_port(obj o) +{ + FILE *fp = NULL; + if ((cxtype_t*)iportvt(o) == IPORT_FILE_NTAG) fp = (FILE*)iportdata(o); + else if ((cxtype_t*)oportvt(o) == OPORT_FILE_NTAG) fp = (FILE*)oportdata(o); + if (!fp) return 0; + return isatty(fileno(fp)); +} + +#ifdef WIN32 +int dirsep = '\\'; +#else +int dirsep = '/'; +#endif + +extern char *argv_ref(int idx) +{ + char **pv = cxg_argv; + /* be careful with indexing! */ + if (idx < 0) return NULL; + while (idx-- > 0) if (*pv++ == NULL) return NULL; + return *pv; +} + +#if defined(WIN32) +#define cxg_envv _environ +#elif defined(__linux) || defined(__APPLE__) +#define cxg_envv environ +#else /* add more systems? */ +char **cxg_envv = { NULL }; +#endif + +extern char *envv_ref(int idx) +{ + char **pv = cxg_envv; + /* be careful with indexing! */ + if (idx < 0) return NULL; + while (idx-- > 0) if (*pv++ == NULL) return NULL; + return *pv; +} + + diff --git a/pre/k-service.sf b/pre/k-service.sf deleted file mode 100644 index 6bd3f84..0000000 --- a/pre/k-service.sf +++ /dev/null @@ -1,5313 +0,0 @@ -;------------------------------------------------------------------------------ -; -; Non-C extracts from Large RNRS compatibility library for #F, fixnum/flonums -; -; #F's predefined forms: -; -; begin define define-syntax if lambda quote -; set! syntax-lambda syntax-rules -; -;------------------------------------------------------------------------------ - -(load "n.sf") - -; 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 - -; 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 - -(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 - -(define-inline (void) (%prim "void(0)")) -(define-inline (void? x) (%prim "bool(obj_from_$arg == obj_from_void(0))" x)) - - -; unit - -; this is the value to be used when zero results are returned to a context -; where one result is expected; it is analogous to a 0-element tuple - - -; fixnums - -(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-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 (fxstring 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-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 (flfixnum 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 - (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 (fxflonum 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 - -(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-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 - -(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-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=? 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 - -(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=? i end)] (vector-set! vec i x))) - - -; bytevectors - -#read #u8 as (%const bytevector ) - -(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 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 - -(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 - -(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) (if (fixnum? n) (fixnum->string n r) (flonum->string n))] - [(_ 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 (fxvector 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=? 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= 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 - -(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 - -(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)) - - -; shebangs - -; i/o ports - -; internal helper for 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)) - -; input ports - -(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 - -(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 - -(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 - -(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 - -(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 - -(define-inline (output-port? x) - (%prim "bool(isoport(obj_from_$arg))" x)) - -; closed output ports - -(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 - -(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 - -(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 - -(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)) - -; 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, \"#\", 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 - -(define-inline (circular? x) - (%prim "bool(iscircular(obj_from_$arg))" x)) - - -; equivalence and case - -(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 ` as (quasiquote ) -#read , as (unquote ) -#read ,@ as (unquote-splicing ) - -(define-syntax quasiquote ; from eiod - (syntax-rules (unquote unquote-splicing quasiquote) - [(_ (unquote x)) x] - [(_ ((unquote-splicing x))) x] ;esl: allow `(,@improper-list) - [(_ ((unquote-splicing x) . y)) (append x (quasiquote y))] - [(_ (quasiquote x) . d) (cons 'quasiquote (quasiquote (x) d))] - [(_ (unquote x) d) (cons 'unquote (quasiquote (x) . d))] - [(_ (unquote-splicing x) d) (cons 'unquote-splicing (quasiquote (x) . d))] - [(_ (x . y) . d) (cons (quasiquote x . d) (quasiquote y . d))] - [(_ #(x ...) . d) (list->vector (quasiquote (x ...) . d))] - [(_ x . d) 'x])) - - -; S-expression writer - -(define-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?^_~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 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 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 - -(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-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 (fxflonum a)]) (if (flflonum b)]) (if (fl=? 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-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-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)) - - - -;--------------------------------------------------------------------------------------------- -; -; Stack-Based Model compiler/vm, derived from -; -; Three Implementation Models for Scheme -; TR87-0ll -; 1987 -; R. Kent Dybvig -; -; https://www.cs.unc.edu/techreports/87-011.pdf -; -; -;--------------------------------------------------------------------------------------------- - - -;--------------------------------------------------------------------------------------------- -; Utils -;--------------------------------------------------------------------------------------------- - -(define set-member? - (lambda (x s) - (cond - [(null? s) #f] - [(eq? x (car s)) #t] - [else (set-member? x (cdr s))]))) - -(define set-cons - (lambda (x s) - (if (set-member? x s) - s - (cons x s)))) - -(define set-union - (lambda (s1 s2) - (if (null? s1) - s2 - (set-union (cdr s1) (set-cons (car s1) s2))))) - -(define set-minus - (lambda (s1 s2) - (if (null? s1) - '() - (if (set-member? (car s1) s2) - (set-minus (cdr s1) s2) - (cons (car s1) (set-minus (cdr s1) s2)))))) - -(define set-intersect - (lambda (s1 s2) - (if (null? s1) - '() - (if (set-member? (car s1) s2) - (cons (car s1) (set-intersect (cdr s1) s2)) - (set-intersect (cdr s1) s2))))) - -(define-syntax record-case - (syntax-rules (else) - [(record-case (pa . ir) clause ...) - (let ([id (pa . ir)]) - (record-case id clause ...))] - [(record-case id) - 'record-case-miss] - [(record-case id [else exp ...]) - (begin exp ...)] - [(record-case id [(key ...) ids exp ...] clause ...) - (if (memq (car id) '(key ...)) - (apply (lambda ids exp ...) (cdr id)) - (record-case id clause ...))] - [(record-case id [key ids exp ...] clause ...) - (if (eq? (car id) 'key) - (apply (lambda ids exp ...) (cdr id)) - (record-case id clause ...))])) - -(define syntax-match? - (lambda (pat exp) - (or (eq? pat '*) - (equal? exp pat) - (and (pair? pat) - (cond - [(and (eq? (car pat) '$) - (pair? (cdr pat)) - (null? (cddr pat))) - (eq? exp (cadr pat))] - [(and (pair? (cdr pat)) - (eq? (cadr pat) '...) - (null? (cddr pat))) - (let ([pat (car pat)]) - (define (f lst) - (or (null? lst) - (and (pair? lst) - (syntax-match? pat (car lst)) - (f (cdr lst))))) - (f exp))] - [else - (and (pair? exp) - (syntax-match? (car pat) (car exp)) - (syntax-match? (cdr pat) (cdr exp)))]))))) - -; unique symbol generator (poor man's version) -(define gensym - (let ([gsc 0]) - (lambda args ; (), (symbol), or (#f) for gsc reset - (set! gsc (fx+ gsc 1)) - (if (null? args) - (string->symbol - (string-append "#" (fixnum->string gsc 10))) - (if (symbol? (car args)) - (string->symbol - (string-append (symbol->string (car args)) - (string-append "#" (fixnum->string gsc 10)))) - (set! gsc 0)))))) - -(define posq - (lambda (x l) - (let loop ([l l] [n 0]) - (cond [(null? l) #f] - [(eq? x (car l)) n] - [else (loop (cdr l) (fx+ n 1))])))) - -(define list-diff - (lambda (l t) - (if (or (null? l) (eq? l t)) - '() - (cons (car l) (list-diff (cdr l) t))))) - -(define (pair* x . more) - (let loop ([x x] [rest more]) - (if (null? rest) x - (cons x (loop (car rest) (cdr rest)))))) - -(define (andmap p l) - (if (pair? l) (and (p (car l)) (andmap p (cdr l))) #t)) - -(define (list1? x) (and (pair? x) (null? (cdr x)))) -(define (list1+? x) (and (pair? x) (list? (cdr x)))) -(define (list2? x) (and (pair? x) (list1? (cdr x)))) -(define (list2+? x) (and (pair? x) (list1+? (cdr x)))) - -(define integrable? - (%prim "{ /* define integrable? */ - static obj c[] = { obj_from_objptr(vmcases+8) }; - $return objptr(c); }")) - -(define lookup-integrable - (%prim "{ /* define lookup-integrable */ - static obj c[] = { obj_from_objptr(vmcases+9) }; - $return objptr(c); }")) - -(define integrable-type - (%prim "{ /* define integrable-type */ - static obj c[] = { obj_from_objptr(vmcases+10) }; - $return objptr(c); }")) - -(define integrable-global - (%prim "{ /* define integrable-global */ - static obj c[] = { obj_from_objptr(vmcases+11) }; - $return objptr(c); }")) - -(define integrable-code - (%prim "{ /* define integrable-code */ - static obj c[] = { obj_from_objptr(vmcases+12) }; - $return objptr(c); }")) - - -;--------------------------------------------------------------------------------------------- -; Syntax of the Scheme Core language -;--------------------------------------------------------------------------------------------- - -; -> (quote ) -; -> (ref ) -; -> (set! ) -; -> (set& ) -; -> (lambda ) where -> ( ...) | ( ... . ) | -; -> (lambda* ( ) ...) where -> ( ) -; -> (syntax-lambda ( ...) ) -; -> (letcc ) -; -> (withcc ) -; -> (begin ...) -; -> (if ) -; -> (call ...) -; -> (integrable ...) where is an index in the integrables table - -; NB: (begin) is legit, returns unspecified value -; on top level, these two extra core forms are legal: - -; -> (define ) -; -> (define-syntax ) - -(define idslist? - (lambda (x) - (cond [(null? x) #t] - [(pair? x) (and (id? (car x)) (idslist? (cdr x)))] - [else (id? x)]))) - -(define normalize-arity - (lambda (arity) - (if (and (list2? arity) (fixnum? (car arity)) (boolean? (cadr arity))) - arity - (let loop ([cnt 0] [l arity]) - (cond [(pair? l) (loop (fx+ 1 cnt) (cdr l))] - [(null? l) (list cnt #f)] - [else (list cnt #t)]))))) - -; convention for 'flattened' is to put rest arg if any at the front -(define flatten-idslist - (lambda (ilist) - (if (list? ilist) ilist - (let loop ([l ilist] [r '()]) - (cond [(pair? l) (loop (cdr l) (cons (car l) r))] - [else (if (null? l) (reverse! r) (cons l (reverse! r)))]))))) - -(define idslist-req-count - (lambda (ilist) - (if (pair? ilist) - (fx+ 1 (idslist-req-count (cdr ilist))) - 0))) - -;--------------------------------------------------------------------------------------------- -; Macro transformer (from Scheme to Scheme Core) derived from Al Petrofsky's EIOD 1.17 -;--------------------------------------------------------------------------------------------- - -; An environment is a procedure that accepts any identifier and returns a denotation. -; The denotation of an identifier is its macro location, which is a cell storing the -; identifier's current syntactic value. Location's value can be changed later. - -; Special forms are either a symbol naming a builtin, or a transformer procedure -; that takes two arguments: a macro use and the environment of the macro use. - -; -> | -; -> -; -> #& -; -> | -; -> | -; -> syntax-quote | quote | set! | set& | if | lambda | lambda* | -; letcc | withcc | body | begin | define | define-syntax | -; syntax-lambda | syntax-rules | syntax-length | syntax-error -; -> - -(define-inline (val-core? val) (pair? val)) - -(define-inline (make-location v) (box v)) -(define-inline (location-val l) (unbox l)) -(define-inline (location-set-val! l v) (set-box! l v)) - -(define (location-special? l) (not (pair? (unbox l)))) -(define (new-id sym den) (define p (cons sym den)) (lambda () p)) -(define (old-sym id) (car (id))) -(define (old-den id) (cdr (id))) -(define (id? x) (or (symbol? x) (procedure? x))) -(define (id->sym id) (if (symbol? id) id (old-sym id))) - -(define (extend-xenv env id bnd) (lambda (i) (if (eq? id i) bnd (env i)))) - -(define (add-location key val env) ; adds as-is - (extend-xenv env key (make-location val))) - -(define (add-var var val env) ; adds renamed var as - (extend-xenv env var (make-location (list 'ref val)))) - -(define (xform-sexp->datum sexp) - (let conv ([sexp sexp]) - (cond [(id? sexp) (id->sym sexp)] - [(pair? sexp) (cons (conv (car sexp)) (conv (cdr sexp)))] - [(vector? sexp) (list->vector (map conv (vector->list sexp)))] - [else sexp]))) - -(define (x-error msg . args) - (error* (string-append "transformer: " msg) args)) - -; xform receives Scheme s-expressions and returns either Core Scheme -; (always a pair) or special-form, which is either a builtin (a symbol) or -; a transformer (a procedure). Appos? flag is true when the context can -; allow xform to return a transformer; otherwise, only is accepted. - -(define (xform appos? sexp env) - (cond [(id? sexp) - (let ([hval (xform-ref sexp env)]) - (cond [appos? hval] - [(integrable? hval) ; integrable id-syntax - (list 'ref (integrable-global hval))] - [(procedure? hval) ; id-syntax - (xform appos? (hval sexp env) env)] - [(not (pair? hval)) ; special used out of context - (x-error "improper use of syntax form" hval)] - [else hval]))] ; core - [(not (pair? sexp)) - (xform-quote (list sexp) env)] - [else - (let* ([head (car sexp)] [tail (cdr sexp)] [hval (xform #t head env)]) - (case hval - [(syntax-quote) (car tail)] ; internal use only - [(quote) (xform-quote tail env)] - [(set!) (xform-set! tail env)] - [(set&) (xform-set& tail env)] - [(if) (xform-if tail env)] - [(lambda) (xform-lambda tail env)] - [(lambda*) (xform-lambda* tail env)] - [(letcc) (xform-letcc tail env)] - [(withcc) (xform-withcc tail env)] - [(body) (xform-body tail env)] - [(begin) (xform-begin tail env)] - [(define) (xform-define tail env)] - [(define-syntax) (xform-define-syntax tail env)] - [(syntax-lambda) (xform-syntax-lambda tail env)] - [(syntax-rules) (xform-syntax-rules tail env)] - [(syntax-length) (xform-syntax-length tail env)] - [(syntax-error) (xform-syntax-error tail env)] - [else (if (integrable? hval) - (xform-integrable hval tail env) - (if (procedure? hval) - (xform appos? (hval sexp env) env) - (xform-call hval tail env)))]))])) - -(define (xform-ref id env) - (let ([den (env id)]) - (cond [(eq? (location-val den) '...) (x-error "improper use of ...")] - [else (location-val den)]))) - -(define (xform-quote tail env) - (if (list1? tail) - (list 'quote (xform-sexp->datum (car tail))) - (x-error "improper quote form" (cons 'quote tail)))) - -(define (xform-set! tail env) - (if (and (list2? tail) (id? (car tail))) - (let ([den (env (car tail))] [xexp (xform #f (cadr tail) env)]) - (cond [(location-special? den) (location-set-val! den xexp) '(begin)] - [else (let ([val (location-val den)]) - (if (eq? (car val) 'ref) - (list 'set! (cadr val) xexp) - (x-error "set! to non-identifier form")))])) - (x-error "improper set! form" (cons 'set! tail)))) - -(define (xform-set& tail env) - (if (list1? tail) - (let ([den (env (car tail))]) - (cond [(location-special? den) (x-error "set& of a non-variable")] - [else (let ([val (location-val den)]) - (if (eq? (car val) 'ref) - (list 'set& (cadr val)) - (x-error "set& of a non-variable")))])) - (x-error "improper set& form" (cons 'set& tail)))) - -(define (xform-if tail env) - (if (list? tail) - (let ([xexps (map (lambda (sexp) (xform #f sexp env)) tail)]) - (case (length xexps) - [(2) (cons 'if (append xexps '((begin))))] - [(3) (cons 'if xexps)] - [else (x-error "malformed if form" (cons 'if tail))])) - (x-error "improper if form" (cons 'if tail)))) - -(define (xform-call xexp tail env) - (if (list? tail) - (let ([xexps (map (lambda (sexp) (xform #f sexp env)) tail)]) - (if (and (null? xexps) (eq? (car xexp) 'lambda) (null? (cadr xexp))) - (caddr xexp) ; ((let () x)) => x - (pair* 'call xexp xexps))) - (x-error "improper application" (cons xexp tail)))) - -(define (integrable-argc-match? igt n) - (case igt - [(#\0) (= n 0)] [(#\1) (= n 1)] [(#\2) (= n 2)] [(#\3) (= n 3)] - [(#\p) (>= n 0)] [(#\m) (>= n 1)] [(#\c) (>= n 2)] [(#\x) (>= n 1)] - [(#\u) (<= 0 n 1)] [(#\b) (<= 1 n 2)] [(#\t) (<= 2 n 3)] - [(#\#) (>= n 0)] [(#\@) #f] - [else #f])) - -(define (xform-integrable ig tail env) - (if (integrable-argc-match? (integrable-type ig) (length tail)) - (cons 'integrable (cons ig (map (lambda (sexp) (xform #f sexp env)) tail))) - (xform-call (list 'ref (integrable-global ig)) tail env))) - -(define (xform-lambda tail env) - (if (and (list1+? tail) (idslist? (car tail))) - (let loop ([vars (car tail)] [ienv env] [ipars '()]) - (cond [(pair? vars) - (let* ([var (car vars)] [nvar (gensym (id->sym var))]) - (loop (cdr vars) (add-var var nvar ienv) (cons nvar ipars)))] - [(null? vars) - (list 'lambda (reverse ipars) (xform-body (cdr tail) ienv))] - [else ; improper - (let* ([var vars] [nvar (gensym (id->sym var))] - [ienv (add-var var nvar ienv)]) - (list 'lambda (append (reverse ipars) nvar) - (xform-body (cdr tail) ienv)))])) - (x-error "improper lambda body" (cons 'lambda tail)))) - -(define (xform-lambda* tail env) - (if (list? tail) - (cons 'lambda* - (map (lambda (aexp) - (if (and (list2? aexp) - (or (and (list2? (car aexp)) - (fixnum? (caar aexp)) - (boolean? (cadar aexp))) - (idslist? (car aexp)))) - (list (normalize-arity (car aexp)) - (xform #f (cadr aexp) env)) - (x-error "improper lambda* clause" aexp))) - tail)) - (x-error "improper lambda* form" (cons 'lambda* tail)))) - -(define (xform-letcc tail env) - (if (and (list2+? tail) (id? (car tail))) - (let* ([var (car tail)] [nvar (gensym (id->sym var))]) - (list 'letcc nvar - (xform-body (cdr tail) (add-var var nvar env)))) - (x-error "improper letcc form" (cons 'letcc tail)))) - -(define (xform-withcc tail env) - (if (list2+? tail) - (list 'withcc (xform #f (car tail) env) - (xform-body (cdr tail) env)) - (x-error "improper withcc form" (cons 'withcc tail)))) - -(define (xform-body tail env) - (cond - [(null? tail) - (list 'begin)] - [(list1? tail) ; can't have defines there - (xform #f (car tail) env)] - [(not (list? tail)) - (x-error "improper body form" (cons 'body tail))] - [else - (let loop ([env env] [ids '()] [inits '()] [nids '()] [body tail]) - (if (and (pair? body) (pair? (car body))) - (let ([first (car body)] [rest (cdr body)]) - (let* ([head (car first)] [tail (cdr first)] [hval (xform #t head env)]) - (case hval - [(begin) ; internal - (if (list? tail) - (loop env ids inits nids (append tail rest)) - (x-error "improper begin form" first))] - [(define) ; internal - (cond [(and (list2? tail) (null? (car tail))) ; idless - (let ([init (cadr tail)]) - (loop env (cons #f ids) (cons init inits) (cons #f nids) rest))] - [(and (list2? tail) (id? (car tail))) - (let* ([id (car tail)] [init (cadr tail)] - [nid (gensym (id->sym id))] [env (add-var id nid env)]) - (loop env (cons id ids) (cons init inits) (cons nid nids) rest))] - [(and (list2+? tail) (pair? (car tail)) (id? (caar tail)) (idslist? (cdar tail))) - (let* ([id (caar tail)] [lambda-id (new-id 'lambda (make-location 'lambda))] - [init (cons lambda-id (cons (cdar tail) (cdr tail)))] - [nid (gensym (id->sym id))] [env (add-var id nid env)]) - (loop env (cons id ids) (cons init inits) (cons nid nids) rest))] - [else (x-error "improper define form" first)])] - [(define-syntax) ; internal - (if (and (list2? tail) (id? (car tail))) - (let* ([id (car tail)] [init (cadr tail)] - [env (add-location id '(undefined) env)]) - (loop env (cons id ids) (cons init inits) (cons #t nids) rest)) - (x-error "improper define-syntax form" first))] - [else - (if (procedure? hval) - (loop env ids inits nids (cons (hval first env) rest)) - (xform-labels (reverse ids) (reverse inits) (reverse nids) body env))]))) - (xform-labels (reverse ids) (reverse inits) (reverse nids) body env)))])) - -(define (xform-labels ids inits nids body env) - (let loop ([ids ids] [inits inits] [nids nids] [sets '()] [lids '()]) - (cond [(null? ids) - (let* ([xexps (append (reverse sets) (map (lambda (x) (xform #f x env)) body))] - [xexp (if (list1? xexps) (car xexps) (cons 'begin xexps))]) - (if (null? lids) xexp - (pair* 'call (list 'lambda (reverse lids) xexp) - (map (lambda (lid) '(begin)) lids))))] - [(not (car ids)) ; idless define - (loop (cdr ids) (cdr inits) (cdr nids) - (cons (xform #f (car inits) env) sets) lids)] - [(symbol? (car nids)) ; define - (loop (cdr ids) (cdr inits) (cdr nids) - (cons (xform-set! (list (car ids) (car inits)) env) sets) - (cons (car nids) lids))] - [else ; define-syntax - (location-set-val! (env (car ids)) (xform #t (car inits) env)) - (loop (cdr ids) (cdr inits) (cdr nids) sets lids)]))) - -(define (xform-begin tail env) ; top-level - (if (list? tail) - (let ([xexps (map (lambda (sexp) (xform #f sexp env)) tail)]) - (if (and (pair? xexps) (null? (cdr xexps))) - (car xexps) ; (begin x) => x - (cons 'begin xexps))) - (x-error "improper begin form" (cons 'begin! tail)))) - -(define (xform-define tail env) ; top-level - (cond [(and (list2? tail) (null? (car tail))) ; idless - (xform #f (cadr tail) env)] - [(and (list2? tail) (id? (car tail))) - (list 'define (id->sym (car tail)) - (xform #f (cadr tail) env))] - [(and (list2+? tail) (pair? (car tail)) (id? (caar tail)) (idslist? (cdar tail))) - (list 'define (id->sym (caar tail)) - (xform-lambda (cons (cdar tail) (cdr tail)) env))] - [else - (x-error "improper define form" (cons 'define tail))])) - -(define (xform-define-syntax tail env) ; top-level - (if (and (list2? tail) (id? (car tail))) - (list 'define-syntax (id->sym (car tail)) (xform #t (cadr tail) env)) - (x-error "improper define-syntax form" (cons 'define-syntax tail)))) - -(define (xform-syntax-lambda tail env) - (if (and (list2+? tail) (andmap id? (car tail))) - (let ([vars (car tail)] [macenv env] [forms (cdr tail)]) - ; return a transformer that wraps xformed body in (syntax ...) - (lambda (use useenv) - (if (and (list1+? use) (fx=? (length vars) (length (cdr use)))) - (let loop ([vars vars] [exps (cdr use)] [env macenv]) - (if (null? vars) - (list 'syntax-quote (xform-body forms env)) - (loop (cdr vars) (cdr exps) - (add-location (car vars) - (xform #t (car exps) useenv) env)))) - (x-error "invalif syntax-lambda application" use)))) - (x-error "improper syntax-lambda body" (cons 'syntax-lambda tail)))) - -(define (xform-syntax-rules tail env) - (cond [(and (list2+? tail) (id? (car tail)) (andmap id? (cadr tail))) - (syntax-rules* env (car tail) (cadr tail) (cddr tail))] - [(and (list1+? tail) (andmap id? (car tail))) - (syntax-rules* env #f (car tail) (cdr tail))] - [else - (x-error "improper syntax-rules form" (cons 'syntax-rules tail))])) - -(define (xform-syntax-length tail env) - (if (and (list1? tail) (list? (car tail))) - (list 'quote (length (car tail))) - (x-error "improper syntax-length form" (cons 'syntax-length tail)))) - -(define (xform-syntax-error tail env) - (let ([args (map xform-sexp->datum tail)]) - (if (and (list1+? args) (string? (car args))) - (apply x-error args) - (x-error "improper syntax-error form" (cons 'syntax-error tail))))) - -(define *transformers* - (list - (cons 'syntax-quote 'syntax-quote) - (cons 'quote 'quote) - (cons 'set! 'set!) - (cons 'set& 'set&) - (cons 'if 'if) - (cons 'lambda 'lambda) - (cons 'lambda* 'lambda*) - (cons 'letcc 'letcc) - (cons 'withcc 'withcc) - (cons 'body 'body) - (cons 'begin 'begin) - (cons 'define 'define) - (cons 'define-syntax 'define-syntax) - (cons 'syntax-lambda 'syntax-lambda) - (cons 'syntax-rules 'syntax-rules) - (cons 'syntax-length 'syntax-length) - (cons 'syntax-error 'syntax-error) - (cons 'define-library 'define-library) - (cons 'program 'program) - (cons 'import 'import) - (cons 'export 'export) - (cons '... '...) - (cons '_ '_))) - -(define *top-transformer-env* #f) - -(define (top-transformer-env id) - (unless *top-transformer-env* - (set! *top-transformer-env* - (map (lambda (bnd) - (let ([v (cdr bnd)]) - (when (and (pair? v) (eq? (car v) 'syntax-rules)) - (set! v - (if (id? (cadr v)) - (syntax-rules* top-transformer-env (cadr v) (caddr v) (cdddr v)) - (syntax-rules* top-transformer-env #f (cadr v) (cddr v))))) - (cons (car bnd) (make-location v)))) - *transformers*))) - (if (procedure? id) - (old-den id) ; nonsymbolic ids can't be globally bound - (cond [(assq id *top-transformer-env*) - => cdr] - [else - (let ([loc (make-location (or (lookup-integrable id) (list 'ref id)))]) - (set! *top-transformer-env* (cons (cons id loc) *top-transformer-env*)) - loc)]))) - - -(define (install-transformer! s t) - (location-set-val! (top-transformer-env s) t)) - -(define (transform appos? sexp . optenv) - ; (gensym #f) ; reset gs counter to make results reproducible - (xform appos? sexp (if (null? optenv) top-transformer-env (car optenv)))) - - -; make transformer procedure from the rules - -(define (syntax-rules* mac-env ellipsis pat-literals rules) - - (define (pat-literal? id) (memq id pat-literals)) - (define (not-pat-literal? id) (not (pat-literal? id))) - (define (ellipsis-pair? x) - (and (pair? x) (ellipsis? (car x)))) - (define (ellipsis-denotation? den) - (eq? (location-val den) '...)) ; fixme: need eq? with correct #&... - (define (ellipsis? x) - (if ellipsis - (eq? x ellipsis) - (and (id? x) (ellipsis-denotation? (mac-env x))))) - - ; List-ids returns a list of the non-ellipsis ids in a - ; pattern or template for which (pred? id) is true. If - ; include-scalars is false, we only include ids that are - ; within the scope of at least one ellipsis. - (define (list-ids x include-scalars pred?) - (let collect ([x x] [inc include-scalars] [l '()]) - (cond [(id? x) (if (and inc (pred? x)) (cons x l) l)] - [(vector? x) (collect (vector->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]))) - - ; Returns #f or an alist mapping each pattern var to a part of - ; the input. Ellipsis vars are mapped to lists of parts (or - ; lists of lists ...). - (define (match-pattern pat use use-env) - (call-with-current-continuation - (lambda (return) - (define (fail) (return #f)) - (let match ([pat pat] [sexp use] [bindings '()]) - (define (continue-if condition) - (if condition bindings (fail))) - (cond - [(id? pat) - (if (pat-literal? pat) - (continue-if (and (id? sexp) (eq? (use-env sexp) (mac-env pat)))) - (cons (cons pat sexp) bindings))] - [(vector? pat) - (or (vector? sexp) (fail)) - (match (vector->list pat) (vector->list sexp) bindings)] - [(not (pair? pat)) - (continue-if (equal? pat sexp))] - [(ellipsis-pair? (cdr pat)) - (let* ([tail-len (length (cddr pat))] - [sexp-len (if (list? sexp) (length sexp) (fail))] - [seq-len (fx- sexp-len tail-len)] - [sexp-tail (begin (if (negative? seq-len) (fail)) (list-tail sexp seq-len))] - [seq (reverse (list-tail (reverse sexp) tail-len))] - [vars (list-ids (car pat) #t not-pat-literal?)]) - (define (match1 sexp) - (map cdr (match (car pat) sexp '()))) - (append - (apply map (cons list (cons vars (map match1 seq)))) - (match (cddr pat) sexp-tail bindings)))] - [(pair? sexp) - (match (car pat) (car sexp) - (match (cdr pat) (cdr sexp) bindings))] - [else (fail)]))))) - - (define (expand-template pat tmpl top-bindings) - ; New-literals is an alist mapping each literal id in the - ; template to a fresh id for inserting into the output. It - ; might have duplicate entries mapping an id to two different - ; fresh ids, but that's okay because when we go to retrieve a - ; fresh id, assq will always retrieve the first one. - (define new-literals - (map (lambda (id) (cons id (new-id (id->sym id) (mac-env id)))) - (list-ids tmpl #t - (lambda (id) (not (assq id top-bindings)))))) - - (define ellipsis-vars - (list-ids pat #f not-pat-literal?)) - - (define (list-ellipsis-vars subtmpl) - (list-ids subtmpl #t - (lambda (id) (memq id ellipsis-vars)))) - - (let expand ([tmpl tmpl] [bindings top-bindings]) - (let expand-part ([tmpl tmpl]) - (cond - [(id? tmpl) - (cdr (or (assq tmpl bindings) - (assq tmpl top-bindings) - (assq tmpl new-literals)))] - [(vector? tmpl) - (list->vector (expand-part (vector->list tmpl)))] - [(and (pair? tmpl) (ellipsis-pair? (cdr tmpl))) - (let ([vars-to-iterate (list-ellipsis-vars (car tmpl))]) - (define (lookup var) - (cdr (assq var bindings))) - (define (expand-using-vals . vals) - (expand (car tmpl) - (map cons vars-to-iterate vals))) - (if (null? vars-to-iterate) - ; ellipsis following non-repeatable part is an error, but we don't care - (cons (expand-part (car tmpl)) (expand-part (cddr tmpl))) ; repeat once - ; correct use of ellipsis - (let ([val-lists (map lookup vars-to-iterate)]) - (append - (apply map (cons expand-using-vals val-lists)) - (expand-part (cddr tmpl))))))] - [(pair? tmpl) - (cons (expand-part (car tmpl)) (expand-part (cdr tmpl)))] - [else tmpl])))) - - (lambda (use use-env) - (let loop ([rules rules]) - (if (null? rules) (x-error "invalid syntax" use)) - (let* ([rule (car rules)] [pat (car rule)] [tmpl (cadr rule)]) - (cond [(match-pattern pat use use-env) => - (lambda (bindings) (expand-template pat tmpl bindings))] - [else (loop (cdr rules))]))))) - - -;--------------------------------------------------------------------------------------------- -; Runtime globals -;--------------------------------------------------------------------------------------------- - -(%localdef "#include \"i.h\"") - -(define *globals* (make-vector 991 '())) ; nice prime number - -(define *dynamic-state* (list #f)) ; for dynamic-wind - -(define *current-input* #f) -(define *current-output* #f) -(define *current-error* #f) - - -;--------------------------------------------------------------------------------------------- -; String representation of S-expressions and code arguments -;--------------------------------------------------------------------------------------------- - -(define (c-error msg . args) - (error* (string-append "compiler: " msg) args)) - -(define (write-serialized-char x port) - (cond [(or (char=? x #\%) (char=? x #\") (char=? x #\\) (char? x #\~)) - (write-char #\% port) - (let ([s (fixnum->string (char->integer x) 16)]) - (if (fx=? (string-length s) 1) (write-char #\0 port)) - (write-string s port))] - [else (write-char x port)])) - -(define (write-serialized-byte x port) - (let ([s (fixnum->string x 16)]) - (if (fx=? (string-length s) 1) (write-char #\0 port)) - (write-string s port))) - -(define (write-serialized-size n port) - (write-string (fixnum->string n 10) port) - (write-char #\: port)) - -(define (write-serialized-element x port) - (write-serialized-sexp x port) - (write-char #\; port)) - -(define (write-serialized-sexp x port) - (cond [(eq? x #f) - (write-char #\f port)] - [(eq? x #t) - (write-char #\t port)] - [(eq? x '()) - (write-char #\n port)] - [(char? x) - (write-char #\c port) - (write-serialized-char x port)] - [(number? x) - (write-char (if (exact? x) #\i #\j) port) - (write-string (number->string x 10) port)] - [(list? x) - (write-char #\l port) - (write-serialized-size (length x) port) - (do ([x x (cdr x)]) [(null? x)] - (write-serialized-element (car x) port))] - [(pair? x) - (write-char #\p port) - (write-serialized-element (car x) port) - (write-serialized-element (cdr x) port)] - [(vector? x) - (write-char #\v port) - (write-serialized-size (vector-length x) port) - (do ([i 0 (fx+ i 1)]) [(fx=? i (vector-length x))] - (write-serialized-element (vector-ref x i) port))] - [(string? x) - (write-char #\s port) - (write-serialized-size (string-length x) port) - (do ([i 0 (fx+ i 1)]) [(fx=? i (string-length x))] - (write-serialized-char (string-ref x i) port))] - [(bytevector? x) - (write-char #\b port) - (write-serialized-size (bytevector-length x) port) - (do ([i 0 (fx+ i 1)]) [(fx=? i (bytevector-length x))] - (write-serialized-byte (bytevector-u8-ref x i) port))] - [(symbol? x) - (write-char #\y port) - (let ([x (symbol->string x)]) - (write-serialized-size (string-length x) port) - (do ([i 0 (fx+ i 1)]) [(fx=? i (string-length x))] - (write-serialized-char (string-ref x i) port)))] - [(box? x) - (write-char #\z port) - (write-serialized-element (unbox x) port)] - [else (c-error "cannot encode literal" x)])) - -(define (write-serialized-arg arg port) - (if (and (number? arg) (exact? arg) (fx<=? 0 arg) (fx<=? arg 9)) - (write-char (string-ref "0123456789" arg) port) - (begin (write-char #\( port) - (write-serialized-sexp arg port) - (write-char #\) port)))) - - -;--------------------------------------------------------------------------------------------- -; Compiler producing serialized code -;--------------------------------------------------------------------------------------------- - -(define find-free* - (lambda (x* b) - (if (null? x*) - '() - (set-union - (find-free (car x*) b) - (find-free* (cdr x*) b))))) - -(define find-free - (lambda (x b) - (record-case x - [quote (obj) - '()] - [ref (id) - (if (set-member? id b) '() (list id))] - [set! (id exp) - (set-union - (if (set-member? id b) '() (list id)) - (find-free exp b))] - [set& (id) - (if (set-member? id b) '() (list id))] - [lambda (idsi exp) - (find-free exp (set-union (flatten-idslist idsi) b))] - [lambda* clauses - (find-free* (map cadr clauses) b)] - [letcc (kid exp) - (find-free exp (set-union (list kid) b))] - [withcc (kexp exp) - (set-union (find-free kexp b) (find-free exp b))] - [if (test then else) - (set-union - (find-free test b) - (set-union (find-free then b) (find-free else b)))] - [begin exps - (find-free* exps b)] - [integrable (ig . args) - (find-free* args b)] - [call (exp . args) - (set-union (find-free exp b) (find-free* args b))] - [define tail - (c-error "misplaced define form" x)]))) - -(define find-sets* - (lambda (x* v) - (if (null? x*) - '() - (set-union - (find-sets (car x*) v) - (find-sets* (cdr x*) v))))) - -(define find-sets - (lambda (x v) - (record-case x - [quote (obj) - '()] - [ref (id) - '()] - [set! (id x) - (set-union - (if (set-member? id v) (list id) '()) - (find-sets x v))] - [set& (id) - (if (set-member? id v) (list id) '())] - [lambda (idsi exp) - (find-sets exp (set-minus v (flatten-idslist idsi)))] - [lambda* clauses - (find-sets* (map cadr clauses) v)] - [letcc (kid exp) - (find-sets exp (set-minus v (list kid)))] - [withcc (kexp exp) - (set-union (find-sets kexp v) (find-sets exp v))] - [begin exps - (find-sets* exps v)] - [if (test then else) - (set-union - (find-sets test v) - (set-union (find-sets then v) (find-sets else v)))] - [integrable (ig . args) - (find-sets* args v)] - [call (exp . args) - (set-union (find-sets exp v) (find-sets* args v))] - [define tail - (c-error "misplaced define form" x)]))) - -(define codegen - ; x: Scheme Core expression to compile - ; l: local var list (with #f placeholders for nonvar slots) - ; f: free var list - ; s: set! var set - ; g: global var set - ; k: #f: x goes to ac, N: x is to be returned after (sdrop n) - ; port: output code goes here - (lambda (x l f s g k port) - (record-case x - [quote (obj) - (case obj - [(#t) (write-char #\t port)] - [(#f) (write-char #\f port)] - [(()) (write-char #\n port)] - [else (write-char #\' port) (write-serialized-arg obj port)]) - (when k (write-char #\] port) (write-serialized-arg k port))] - [ref (id) - (cond [(posq id l) => ; local - (lambda (n) - (write-char #\. port) - (write-serialized-arg n port) - (if (set-member? id s) (write-char #\^ port)))] - [(posq id f) => ; free - (lambda (n) - (write-char #\: port) - (write-serialized-arg n port) - (if (set-member? id s) (write-char #\^ port)))] - [else ; global - (write-char #\@ port) - (write-serialized-arg id port)]) - (when k (write-char #\] port) (write-serialized-arg k port))] - [set! (id x) - (codegen x l f s g #f port) - (cond [(posq id l) => ; local - (lambda (n) - (write-char #\. port) (write-char #\! port) - (write-serialized-arg n port))] - [(posq id f) => ; free - (lambda (n) - (write-char #\: port) (write-char #\! port) - (write-serialized-arg n port))] - [else ; global - (write-char #\@ port) (write-char #\! port) - (write-serialized-arg id port)]) - (when k (write-char #\] port) (write-serialized-arg k port))] - [set& (id) - (cond [(posq id l) => ; local - (lambda (n) - (write-char #\. port) - (write-serialized-arg n port))] - [(posq id f) => ; free - (lambda (n) - (write-char #\: port) - (write-serialized-arg n port))] - [else ; global - (write-char #\` port) - (write-serialized-arg id port)]) - (when k (write-char #\] port) (write-serialized-arg k port))] - [begin exps - (let loop ([xl exps]) - (when (pair? xl) - (let ([k (if (pair? (cdr xl)) #f k)]) - (codegen (car xl) l f s g k port) - (loop (cdr xl))))) - (when (and k (null? exps)) (write-char #\] port) (write-serialized-arg k port))] - [if (test then else) - (codegen test l f s g #f port) - (write-char #\? port) - (write-char #\{ port) - (codegen then l f s g k port) - (write-char #\} port) - (cond [k ; tail call: 'then' arm exits, so br around is not needed - (codegen else l f s g k port)] - [(equal? else '(begin)) ; non-tail with void 'else' arm - ] ; no code needed -- ac retains #f from failed test - [else ; non-tail with 'else' expression; needs br - (write-char #\{ port) - (codegen else l f s g k port) - (write-char #\} port)])] - [lambda (idsi exp) - (let* ([ids (flatten-idslist idsi)] - [free (set-minus (find-free exp ids) g)] - [sets (find-sets exp ids)]) - (do ([free (reverse free) (cdr free)] [l l (cons #f l)]) [(null? free)] - ; note: called with empty set! var list - ; to make sure no dereferences are generated - (codegen (list 'ref (car free)) l f '() g #f port) - (write-char #\, port)) - (write-char #\& port) - (write-serialized-arg (length free) port) - (write-char #\{ port) - (cond [(list? idsi) - (write-char #\% port) - (write-serialized-arg (length idsi) port)] - [else - (write-char #\% port) (write-char #\! port) - (write-serialized-arg (idslist-req-count idsi) port)]) - (do ([ids ids (cdr ids)] [n 0 (fx+ n 1)]) [(null? ids)] - (when (set-member? (car ids) sets) - (write-char #\# port) - (write-serialized-arg n port))) - (codegen exp ids free - (set-union sets (set-intersect s free)) - g (length ids) port) - (write-char #\} port)) - (when k (write-char #\] port) (write-serialized-arg k port))] - [lambda* clauses - (do ([clauses (reverse clauses) (cdr clauses)] [l l (cons #f l)]) - [(null? clauses)] - (codegen (cadr (car clauses)) l f s g #f port) - (write-char #\% port) (write-char #\x port) - (write-char #\, port)) - (write-char #\& port) - (write-serialized-arg (length clauses) port) - (write-char #\{ port) - (do ([clauses clauses (cdr clauses)] [i 0 (fx+ i 1)]) - [(null? clauses)] - (let* ([arity (caar clauses)] [cnt (car arity)] [rest? (cadr arity)]) - (write-char #\| port) - (if rest? (write-char #\! port)) - (write-serialized-arg cnt port) - (write-serialized-arg i port))) - (write-char #\% port) (write-char #\% port) - (write-char #\} port) - (when k (write-char #\] port) (write-serialized-arg k port))] - [letcc (kid exp) - (let* ([ids (list kid)] [sets (find-sets exp ids)] - [news (set-union (set-minus s ids) sets)]) - (cond [k ; tail position with k locals on stack to be disposed of - (write-char #\k port) (write-serialized-arg k port) - (write-char #\, port) - (when (set-member? kid sets) - (write-char #\# port) (write-char #\0 port)) - ; stack map here: kid on top - (codegen exp (cons kid l) f news g (fx+ k 1) port)] - [else ; non-tail position - (write-char #\$ port) (write-char #\{ port) - (write-char #\k port) (write-char #\0 port) - (write-char #\, port) - (when (set-member? kid sets) - (write-char #\# port) (write-char #\0 port)) - ; stack map here: kid on top, two-slot frame under it - (codegen exp (cons kid (cons #f (cons #f l))) f news g #f port) - (write-char #\_ port) (write-serialized-arg 3 port) - (write-char #\} port)]))] - [withcc (kexp exp) - (cond [(memq (car exp) '(quote ref lambda)) ; exp is a constant, return it - (codegen exp l f s g #f port) - (write-char #\, port) ; stack map after: k on top - (codegen kexp (cons #f l) f s g #f port) - (write-char #\w port) (write-char #\! port)] - [else ; exp is not a constant, thunk it and call it from k - (codegen (list 'lambda '() exp) l f s g #f port) - (write-char #\, port) ; stack map after: k on top - (codegen kexp (cons #f l) f s g #f port) - (write-char #\w port)])] - [integrable (ig . args) - (let ([igty (integrable-type ig)] [igc0 (integrable-code ig 0)]) - (case igty - [(#\0 #\1 #\2 #\3) ; 1st arg in a, others on stack - (do ([args (reverse args) (cdr args)] [l l (cons #f l)]) - [(null? args)] - (codegen (car args) l f s g #f port) - (unless (null? (cdr args)) (write-char #\, port))) - (write-string igc0 port)] - [(#\p) ; (length args) >= 0 - (if (null? args) - (let ([igc1 (integrable-code ig 1)]) - (write-string igc1 port)) - (let ([opc (fx- (length args) 1)]) - (do ([args (reverse args) (cdr args)] [l l (cons #f l)]) - [(null? args)] - (codegen (car args) l f s g #f port) - (unless (null? (cdr args)) (write-char #\, port))) - (do ([i 0 (fx+ i 1)]) [(fx>=? i opc)] - (write-string igc0 port))))] - [(#\m) ; (length args) >= 1 - (if (null? (cdr args)) - (let ([igc1 (integrable-code ig 1)]) - (codegen (car args) l f s g #f port) - (write-string igc1 port)) - (let ([opc (fx- (length args) 1)]) - (do ([args (reverse args) (cdr args)] [l l (cons #f l)]) - [(null? args)] - (codegen (car args) l f s g #f port) - (unless (null? (cdr args)) (write-char #\, port))) - (do ([i 0 (fx+ i 1)]) [(fx>=? i opc)] - (write-string igc0 port))))] - [(#\c) ; (length args) >= 2 - (let ([opc (fx- (length args) 1)] [args (reverse args)]) - (codegen (car args) l f s g #f port) - (write-char #\, port) - (do ([args (cdr args) (cdr args)] [l (cons #f l) (cons #f (cons #f l))]) - [(null? args)] - (codegen (car args) l f s g #f port) - (unless (null? (cdr args)) (write-char #\, port) (write-char #\, port))) - (do ([i 0 (fx+ i 1)]) [(fx>=? i opc)] - (unless (fxzero? i) (write-char #\; port)) - (write-string igc0 port)))] - [(#\x) ; (length args) >= 1 - (let ([opc (fx- (length args) 1)]) - (do ([args (reverse args) (cdr args)] [l l (cons #f l)]) - [(null? args)] - (codegen (car args) l f s g #f port) - (unless (null? (cdr args)) (write-char #\, port))) - (do ([i 0 (fx+ i 1)]) [(fx>=? i opc)] - (write-string igc0 port)))] - [(#\u) ; 0 <= (length args) <= 1 - (if (null? args) - (write-string (integrable-code ig 1) port) - (codegen (car args) l f s g #f port)) - (write-string igc0 port)] - [(#\b) ; 1 <= (length args) <= 2 - (if (null? (cdr args)) - (write-string (integrable-code ig 1) port) - (codegen (cadr args) l f s g #f port)) - (write-char #\, port) - (codegen (car args) (cons #f l) f s g #f port) - (write-string igc0 port)] - [(#\t) ; 2 <= (length args) <= 3 - (if (null? (cddr args)) - (write-string (integrable-code ig 1) port) - (codegen (caddr args) l f s g #f port)) - (write-char #\, port) - (codegen (cadr args) (cons #f l) f s g #f port) - (write-char #\, port) - (codegen (car args) (cons #f (cons #f l)) f s g #f port) - (write-string igc0 port)] - [(#\#) ; (length args) >= 0 - (do ([args (reverse args) (cdr args)] [l l (cons #f l)]) - [(null? args)] - (codegen (car args) l f s g #f port) - (write-char #\, port)) - (write-string igc0 port) - (write-serialized-arg (length args) port)] - [else (c-error "unsupported integrable type" igty)])) - (when k (write-char #\] port) (write-serialized-arg k port))] - [call (exp . args) - (cond [(and (eq? (car exp) 'lambda) (list? (cadr exp)) - (fx=? (length args) (length (cadr exp)))) - ; let-like call; compile as special lambda + call combo - (do ([args (reverse args) (cdr args)] [l l (cons #f l)]) - [(null? args)] - (codegen (car args) l f s g #f port) - (write-char #\, port)) - (let* ([ids (cadr exp)] [exp (caddr exp)] - [sets (find-sets exp ids)] - [news (set-union (set-minus s ids) sets)] - [newl (append ids l)]) ; with real names - (do ([ids ids (cdr ids)] [n 0 (fx+ n 1)]) [(null? ids)] - (when (set-member? (car ids) sets) - (write-char #\# port) - (write-serialized-arg n port))) - (if k - (codegen exp newl f news g (fx+ k (length args)) port) - (begin - (codegen exp newl f news g #f port) - (write-char #\_ port) - (write-serialized-arg (length args) port))))] - [k ; tail call with k elements under arguments - (do ([args (reverse args) (cdr args)] [l l (cons #f l)]) - [(null? args) (codegen exp l f s g #f port)] - (codegen (car args) l f s g #f port) - (write-char #\, port)) - (write-char #\[ port) - (write-serialized-arg k port) - (write-serialized-arg (length args) port)] - [else ; non-tail call; 'save' puts 2 extra elements on the stack! - (write-char #\$ port) (write-char #\{ port) - (do ([args (reverse args) (cdr args)] [l (cons #f (cons #f l)) (cons #f l)]) - [(null? args) (codegen exp l f s g #f port)] - (codegen (car args) l f s g #f port) - (write-char #\, port)) - (write-char #\[ port) - (write-serialized-arg 0 port) - (write-serialized-arg (length args) port) - (write-char #\} port)])] - [define tail - (c-error "misplaced define form" x)]))) - -(define (compile-to-string x) - (let ([p (open-output-string)]) - (codegen x '() '() '() (find-free x '()) #f p) - (get-output-string p))) - - -;--------------------------------------------------------------------------------------------- -; Code deserializer and Evaluator (use built-ins) -;--------------------------------------------------------------------------------------------- - -(define execute-thunk-closure - (%prim "{ /* define execute-thunk-closure */ - static obj c[] = { obj_from_objptr(vmcases+0) }; - $return objptr(c); }")) - -(define make-closure - (%prim "{ /* define make-closure */ - static obj c[] = { obj_from_objptr(vmcases+1) }; - $return objptr(c); }")) - -(define execute - (lambda (code) - (execute-thunk-closure (make-closure code)))) - -(define decode-sexp - (%prim "{ /* define decode-sexp */ - static obj c[] = { obj_from_objptr(vmcases+2) }; - $return objptr(c); }")) - -(define decode - (%prim "{ /* define decode */ - static obj c[] = { obj_from_objptr(vmcases+3) }; - $return objptr(c); }")) - -(define (evaluate x) - (execute (decode (compile-to-string (transform #f x))))) - - -;--------------------------------------------------------------------------------------------- -; File processor (Scheme => Serialized code) -;--------------------------------------------------------------------------------------------- - -(define *hide-refs* '()) - -(define (display-code cstr oport) - (let loop ([i 0] [l (string-length cstr)]) - (let ([r (fx- l i)]) - (cond [(<= r 70) - (display " \"" oport) - (display (substring cstr i l)) - (display "\"," oport)] - [else - (display " \"" oport) - (display (substring cstr i (fx+ i 70))) - (display "\"\n" oport) - (loop (fx+ i 70) l)])))) - - -(define (process-syntax id xval oport) - (newline oport) - (display " \"S\", \"" oport) (display id oport) (display "\",\n" oport) - (let ([p (open-output-string)]) (write-serialized-sexp xval p) - (display-code (get-output-string p) oport) (newline oport))) - -(define (process-alias id oldid oport) - (newline oport) - (display " \"A\", \"" oport) (display id oport) (display "\"," oport) - (display " \"" oport) (display oldid oport) (display "\",\n" oport)) - -(define (process-command xval oport) - (define cstr (compile-to-string xval)) - (newline oport) - (display " \"C\", 0,\n" oport) - (display-code cstr oport) (newline oport)) - -(define (process-define id xlam oport) - (define cstr (compile-to-string xlam)) - (let ([len (string-length cstr)]) - (cond [(and (eq? (car xlam) 'lambda) - (> len 4) - (char=? (string-ref cstr 0) #\&) - (char=? (string-ref cstr 1) #\0) - (char=? (string-ref cstr 2) #\{) - (char=? (string-ref cstr (fx- len 1)) #\})) - (newline oport) - (display " \"P\", \"" oport) (display id oport) (display "\",\n" oport) - (display-code (substring cstr 3 (fx- len 1)) oport) (newline oport)] - [else (process-command (list 'set! id xlam) oport)]))) - -(define (scan-top-form x) - (cond - [(and (list2? x) (eq? (car x) 'load) (string? (cadr x))) - (let ([iport (open-input-file (cadr x))]) - (let loop ([x (read iport)]) - (unless (eof-object? x) - (scan-top-form x) - (loop (read iport)))) - (close-input-port iport))] - [(pair? x) - (let ([hval (transform #t (car x))]) - (cond - [(eq? hval 'begin) - (for-each scan-top-form (cdr x))] - [(eq? hval 'define-syntax) - (let ([xval (transform #t (caddr x))]) - (install-transformer! (cadr x) xval))] - [(procedure? hval) - (scan-top-form (hval x top-transformer-env))]))])) - -(define (process-top-form x oport) - (cond - [(and (list2? x) (eq? (car x) 'load) (string? (cadr x))) - (let ([iport (open-input-file (cadr x))]) - (let loop ([x (read iport)]) - (unless (eof-object? x) - (scan-top-form x) - (loop (read iport)))) - (close-input-port iport))] - [(pair? x) - (let ([hval (transform #t (car x))]) - (cond - [(eq? hval 'begin) - (let loop ([x* (cdr x)]) - (when (pair? x*) - (process-top-form (car x*) oport) - (loop (cdr x*))))] - [(eq? hval 'define-syntax) - (let ([xval (transform #t (caddr x))]) - (install-transformer! (cadr x) xval) - (unless (memq (cadr x) *hide-refs*) - (if (symbol? (caddr x)) - (process-alias (cadr x) (caddr x) oport) - (process-syntax (cadr x) (caddr x) oport))))] - [(eq? hval 'define) - (let* ([dval (transform #f x)] [xval (caddr dval)]) - (process-define (cadr dval) xval oport))] - [(procedure? hval) - (process-top-form (hval x top-transformer-env) oport)] - [else - (process-command (transform #f x) oport)]))] - [else - (process-command (transform #f x) oport)])) - -(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-strip-extension filename) - (let ([l (reverse (string->list filename))]) - (let ([r (memv #\. l)]) - (if r (list->string (reverse (cdr r))) filename)))) - -(define (module-name filename) - (path-strip-extension (path-strip-directory filename))) - -(define (process-file fname) - (define iport (open-input-file fname)) - (define oport (current-output-port)) - (define mname (module-name fname)) - (display "/* " oport) (display mname oport) - (display ".c -- generated via skint -c " oport) - (display (path-strip-directory fname) oport) - (display " */" oport) (newline oport) (newline oport) - (display "char *" oport) (display mname oport) - (display "_code[] = {" oport) (newline oport) - (let loop ([x (read iport)]) - (unless (eof-object? x) - (process-top-form x oport) - (loop (read iport)))) - (display "\n 0, 0, 0\n};\n" oport) - (close-input-port iport)) - - -;--------------------------------------------------------------------------------------------- -; Initial environment -;--------------------------------------------------------------------------------------------- - -; adapter code for continuation closures produced by letcc -(define continuation-adapter-code #f) ; inited via (decode "k!...") in i.c - -; adapter closure for values/call-with-values pair -(define callmv-adapter-closure (make-closure (decode "K5"))) - -(define install-global-lambdas - (%prim "{ /* define install-global-lambdas */ - static obj c[] = { obj_from_objptr(vmcases+6) }; - $return objptr(c); }")) - -(install-global-lambdas) - -(define initialize-modules - (%prim "{ /* define initialize-modules */ - static obj c[] = { obj_from_objptr(vmcases+7) }; - $return objptr(c); }")) - -(initialize-modules) - - -;--------------------------------------------------------------------------------------------- -; Tests -;--------------------------------------------------------------------------------------------- - -(define test1 - '(let () - (define (sort-list obj pred) - (define (loop l) - (if (and (pair? l) (pair? (cdr l))) (split l '() '()) l)) - (define (split l one two) - (if (pair? l) - (split (cdr l) two (cons (car l) one)) - (merge (loop one) (loop two)))) - (define (merge one two) - (cond - [(null? one) two] - [(pred (car two) (car one)) - (cons (car two) (merge (cdr two) one))] - [else (cons (car one) (merge (cdr one) two))])) - (loop obj)) - (sort-list - '("one" "two" "three" "four" "five" "six" - "seven" "eight" "nine" "ten" "eleven" "twelve") - string -; ("eight" "eleven" "five" "four" "nine" "one" "seven" "six" "ten" "three" "twelve" "two") -; -; (evaluate test2) => -; 70 -; -; (evaluate test3) => -; 92 -; -; (evaluate test4) => -; 3628800 -; -; (evaluate test5) => -; (3628800 3628800 3628800 3628800) -; - - -;--------------------------------------------------------------------------------------------- -; REPL -;--------------------------------------------------------------------------------------------- - -(define *verbose* #f) - -(define *reset* #f) - -(define-inline (tty-port? o) - (%prim? "{ /* tty-port? */ - extern int is_tty_port(obj o); - int x = is_tty_port(obj_from_$arg); - $return bool(x); }" o)) - -(define (error* msg args) - (if (procedure? *reset*) - (let ([p (current-error-port)]) - (display msg p) (newline p) - (for-each (lambda (arg) (write arg p) (newline p)) args) - (*reset* #f)) - (apply error (cons msg args)))) - -(define (run-tests) - (define start (current-jiffy)) - (display "Running tests ...") (newline) - (write (evaluate test1)) (newline) - (write (evaluate test2)) (newline) - (write (evaluate test3)) (newline) - (write (evaluate test4)) (newline) - (write (evaluate test5)) (newline) - (display "Elapsed time: ") (write (* 1000 (/ (- (current-jiffy) start) (jiffies-per-second)))) - (display " ms.") (newline)) - -(define (repl-eval x) - (letcc catch - (set! *reset* catch) - (let ([xexp (transform #f x)]) - (when *verbose* (display "TRANSFORM =>") (newline) (write xexp) (newline)) - (unless (pair? xexp) (x-error "unexpected transformed output" xexp)) - (if (eq? (car xexp) 'define) (set-car! xexp 'set!)) - (when *verbose* (display "COMPILE-TO-STRING =>") (newline)) - (let ([cstr (compile-to-string xexp)] [start #f]) - (when *verbose* - (display cstr) (newline) - (display "DECODE+EXECUTE =>") (newline) - (set! start (current-jiffy))) - (let* ([thunk (decode cstr)] [res (execute thunk)]) - (unless (eq? res (void)) (write res) (newline))) - (when *verbose* - (display "Elapsed time: ") (write (* 1000 (/ (- (current-jiffy) start) (jiffies-per-second)))) - (display " ms.") (newline)))))) - -(define (repl-eval-top-form x) - (cond - [(and (list2? x) (eq? (car x) 'load) (string? (cadr x))) - (let ([iport (open-input-file (cadr x))]) - (repl-from-port iport) - (close-input-port iport))] - [(pair? x) - (let ([hval (transform #t (car x))]) - (cond - [(eq? hval 'begin) - (let loop ([x* (cdr x)]) - (when (pair? x*) - (repl-eval-top-form (car x*)) - (loop (cdr x*))))] - [(eq? hval 'define-syntax) - (let ([xval (transform #t (caddr x))]) - (install-transformer! (cadr x) xval))] - [(procedure? hval) - (repl-eval-top-form (hval x top-transformer-env))] - [else - (repl-eval x)]))] - [else - (repl-eval x)])) - -(define (repl-read iport) - (when (eq? iport (current-input-port)) - (display "\nservice> ") (flush-output-port)) - (read iport)) - -(define (repl-from-port iport) - (let loop ([x (repl-read iport)]) - (unless (eof-object? x) - (repl-eval-top-form x) - (loop (repl-read iport))))) - -(define (repl-file fname) - (define iport (open-input-file fname)) - (repl-from-port iport) - (close-input-port iport)) - -(define (benchmark-file fname) - (define iport (open-input-file fname)) - (unless (syntax-match? '(load "libl.sf") (read iport)) - (error "unexpected benchmark file format" fname)) - (repl-from-port iport) - (repl-eval-top-form '(main #f)) - (close-input-port iport)) - -(define (service-repl) - (repl-from-port (current-input-port))) - -(define (tcode-repl) - (execute (decode "${@(y4:repl)[00}"))) - -(define (debug-repl) - (define outer-k #f) - (define (loop) - (display "\ndebug> ") (flush-output-port) - (let ([cmd (read)]) - (if (eof-object? cmd) - #f ; quit scheme with code 0 - (case cmd - [(?) - (display " -Type r to get back to repl - a to abort scheme - s to run service repl -") (loop)] - [(r) (or (eq? (tcode-repl) #t) (loop))] - [(a) (%prim! "void(exit(1))")] - [(s) (service-repl) (loop)] - [else (display "Invalid command. Type ? for options, r to return to REPL.\n") (loop)])))) - (when (tty-port? (current-input-port)) - (call/cc - (lambda (k) - (set! outer-k k) - (loop))))) - -(define (main argv) - (let ([args (cdr (command-line))]) - (cond - [(syntax-match? '("-c" *) args) - (process-file (cadr args))] - [(syntax-match? '("-b" *) args) - (benchmark-file (cadr args))] - [(syntax-match? '("-t") args) - (run-tests)] - [(syntax-match? '("-i") args) - (service-repl)] - [else ; run tcode repl automatically - (or (eq? (tcode-repl) #t) (debug-repl))]))) - diff --git a/pre/n-service.sf b/pre/n-service.sf deleted file mode 100644 index 6882f41..0000000 --- a/pre/n-service.sf +++ /dev/null @@ -1,5050 +0,0 @@ - -; LibN: Large RNRS compatibility library for #F, fixnum/flonum arithmetics - -; #F's predefined forms: -; -; begin define define-syntax if lambda quote -; set! syntax-lambda syntax-rules - - -;------------------------------------------------------------------------------ - -; basic syntax constructs, extended lambda - -(define-syntax syntax-rule - (syntax-rules () - [(_ pat tmpl) (syntax-rules () [(__ . pat) tmpl])])) - -(define-syntax let-syntax - (syntax-rules () - [(_ ([kw init] ...)) - (begin)] - [(_ ([kw init] ...) . body) - ((syntax-lambda (kw ...) . body) - init ...)])) - -(define-syntax letrec-syntax - (let-syntax ([let-syntax let-syntax] [define-syntax define-syntax]) - (syntax-rules () - [(_ ([kw init] ...) . body) - (let-syntax () - (define-syntax kw init) ... (let-syntax () . body))]))) - -(define-syntax lambda - (let-syntax ([old-lambda lambda]) - (letrec-syntax - ([loop - (syntax-rules () - [(_ (narg . more) (arg ...) . body) - (loop more (arg ... narg) . body)] - [(_ rarg (arg ...) . body) - (make-improper-lambda ; see definition below - #&(length (arg ...)) - (old-lambda (arg ... rarg) (let-syntax () . body)))])]) - (syntax-rules () - [(_ (arg ...) . body) - (old-lambda (arg ...) (let-syntax () . body))] - [(_ args . body) - (loop args () . body)])))) - - -; definition forms - -(define-syntax define - (let-syntax ([old-define define]) - (letrec-syntax - ([new-define - (syntax-rules () - [(_ exp) (old-define exp)] - [(_ (var-or-prototype . args) . body) - (new-define var-or-prototype (lambda args . body))] - [(_ . other) (old-define . other)])]) - new-define))) - -(define-syntax define-inline - (letrec-syntax - ([loop - (syntax-rules () - [(_ id ([v e] ...) () . body) - (begin - (define-syntax id - (syntax-rules () - [(_ e ...) - ((lambda (v ...) . body) e ...)] - [_ #&(string->id #&(string-append "%residual-" #&(id->string id)))])) - (define #&(string->id #&(string-append "%residual-" #&(id->string id))) - (lambda (v ...) . body)))] - [(_ id (b ...) (v . vs) . body) - (loop id (b ... [v e]) vs . body)])]) - (syntax-rules () - [(_ (id v ...) . body) - (loop id () (v ...) . body)] - [(_ #&(id? id) val) - (define-syntax id val)]))) - -(define-syntax define-integrable - (syntax-rules () - [(_ (op . ll) . body) - (define-syntax op - (%quote (letrec ([op (lambda ll . body)]) op)))])) - - -; primitive definition helpers - -(define-syntax %prim*/rev - (letrec-syntax - ([loop - (syntax-rules () - [(_ prim () args) - (%prim* prim . args)] - [(_ prim (arg . more) args) - (loop prim more (arg . args))])]) - (syntax-rules () - [(_ prim arg ...) - (loop prim (arg ...) ())]))) - - -; binding forms - -(define-syntax let - (syntax-rules () - [(_ ([var init] ...) . body) - ((lambda (var ...) . body) init ...)] - [(_ name ([var init] ...) . body) - ((letrec ([name (lambda (var ...) . body)]) - name) - init ...)])) - -(define-syntax let* - (syntax-rules () - [(_ () . body) (let () . body)] - [(_ ([var init] . bindings) . body) - (let ([var init]) (let* bindings . body))])) - -(define-syntax letrec - (syntax-rules () - [(_ ([var init] ...) . body) - (let () (define var init) ... (let () . body))])) - -(define-syntax letrec* - (syntax-rules () - [(_ ([var expr] ...) . body) - (let ([var #f] ...) - (set! var expr) - ... - (let () . body))])) - -(define-syntax rec - (syntax-rules () - [(_ (name . args) . body) - (letrec ([name (lambda args . body)]) name)] - [(_ name expr) - (letrec ([name expr]) name)])) - -(define-syntax letcc - (let-syntax ([old-letcc letcc]) - (syntax-rules () - [(_ var . body) - (old-letcc var (let-syntax () . body))]))) - -(define-syntax receive - (syntax-rules () - [(_ formals expr . body) - (call-with-values - (lambda () expr) - (lambda formals . body))])) - -(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 "#ifdef NAN_BOXING") - -(%definition "#define isim0(o) (((o) & 0xffff000000000003ULL) == 3)") -(%definition "#define isimm(o, t) (((o) & 0xffff0000000000ffULL) == (((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)(((((uint32_t)o >> 2) & 0x3fffffff) ^ 0x20000000) - 0x20000000); -} -long getimmu(obj o, int t) { - assert(isimm((o), t)); - return (long)(((uint32_t)o >> 8) & 0xffffff); -} -#endif") -(%definition "#define mkim0(v) ((obj)((((v) & 0x000000003fffffffULL) << 2) | 3))") -(%definition "#define mkimm(v, t) ((obj)((((v) & 0x0000000000ffffffULL) << 8) | ((t) << 2) | 1))") - -(%definition "#else") - -(%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)") -(%definition "#define FLONUMS_BOXED") - -(%definition "#endif") - - -; 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)")) -(define-inline (void? x) (%prim "bool(obj_from_$arg == obj_from_void(0))" x)) - - -; unit - -; this is the value to be used when zero results are returned to a context -; where one result is expected; it is analogous to a 0-element tuple - -(%definition "/* unit */") -(%definition "#define obj_from_unit() (obj_from_size(0x6DF6F577))") - - -; 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 fxdiv(x, y) ((x) / (y)) -/* truncated division (common/C99) */ -#define fxquo(x, y) ((x) / (y)) -#define fxrem(x, y) ((x) % (y)) -/* floor division */ -static long fxmqu(long x, long y) { - long q = x / y; return ((x < 0 && y > 0) || (x > 0 && y < 0)) ? q - 1 : q; -} -static long fxmlo(long x, long y) { - long r = x % y; return ((r < 0 && y > 0) || (r > 0 && y < 0)) ? r + y : r; -} -/* euclidean division */ -static long fxeuq(long x, long y) { - long q = x / y, r = x % y; return (r < 0) ? ((y > 0) ? q - 1 : q + 1) : q; -} -static long fxeur(long x, long y) { - long r = x % y; return (r < 0) ? ((y > 0) ? r + y : r - y) : r; -} -static long fxgcd(long x, long y) { - long a = labs(x), b = labs(y), c; while (b) c = a%b, a = b, b = c; - return a; -} -#define fxasl(x, y) ((x) << (y)) -#define fxasr(x, y) ((x) >> (y)) -#define fxflo(f) ((long)(f)) -#else -extern long fxneg(long x); -extern long fxabs(long x); -extern long fxadd(long x, long y); -extern long fxsub(long x, long y); -extern long fxmul(long x, long y); -extern long fxdiv(long x, long y); -extern long fxquo(long x, long y); -extern long fxrem(long x, long y); -extern long fxmqu(long x, long y); -extern long fxmlo(long x, long y); -extern long fxeuq(long x, long y); -extern long fxeur(long x, long y); -extern long fxgcd(long x, long y); -extern long fxasl(long x, long y); -extern long fxasr(long x, long y); -extern long fxflo(double f); -#endif") - -(%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 fxdiv(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 fxeuq(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 fxeur(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-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) -(%include ) - -(%definition "/* flonums */") -(%definition "#ifndef FLONUMS_BOXED") -(%definition "typedef double flonum_t;") -(%definition "#define is_flonum_obj(o) (((o) & 0xffff000000000000ULL) != 0ULL)") -(%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_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 "union iod { cxoint_t i; double d; };") -(%definition "static double flonum_from_obj(obj o) { - union iod u; - assert(is_flonum_obj(o)); - u.i = ~o; - return u.d; -}") -(%definition "static obj obj_from_flonum(int rc, double d) { - union iod u; - u.d = d; - assert(is_flonum_obj(~u.i)); - return ~u.i; -}") -(%definition "#else /* FLONUMS_BOXED */") -(%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; -}") -(%definition "#endif") - -(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-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 (flfixnum 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 - (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 (fxflonum 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 ) - -; 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-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 ) - -(%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-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=? 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=? 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 as (%const bytevector ) - -(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 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) (if (fixnum? n) (fixnum->string n r) (flonum->string n))] - [(_ 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 (fxvector 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=? 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= 1 which -; have a pointer to the static code entry as 0th element; -; sfc allocates env-less global procedures in static memory, -; so procedure? answers #t to any nonzero out-of-heap pointer - -(%localdef "int isprocedure(obj o) { - if (!o) return 0; - else if (isaptr(o) && !isobjptr(o)) return 1; - else if (!isobjptr(o)) return 0; - else { obj h = objptr_from_obj(o)[-1]; - return notaptr(h) && size_from_obj(h) >= 1 - && isaptr(hblkref(o, 0)); } -}") - -(%localdef "int procedurelen(obj o) { - assert(isprocedure(o)); - return isobjptr(o) ? hblklen(o) : 1; -}") - -(%localdef "obj* procedureref(obj o, int i) { - int len; assert(isprocedure(o)); - len = isobjptr(o) ? hblklen(o) : 1; - assert(i >= 0 && i < len); - return &hblkref(o, i); -}") - -(%definition "/* procedures */") -(%definition "extern int isprocedure(obj o);") -(%definition "extern int procedurelen(obj o);") -(%definition "extern obj* procedureref(obj o, int i);") - -(define-inline (procedure? o) - (%prim "bool(isprocedure(obj_from_$arg))" o)) - - -; apply, dotted lambda list, argc dispatch, case-lambda - -(%definition "/* apply and dotted lambda list */") -(%definition "extern obj appcases[];") -(%localdef "/* apply/dotted lambda adapter entry points */") -(%localdef "static obj apphost(obj);") -(%localdef "obj appcases[5] = { (obj)apphost, (obj)apphost, (obj)apphost, (obj)apphost , (obj)apphost };") -(%localdef "/* apphost procedure */ -#define APPLY_MAX_REGS 1024 /* limit on rc for apply & friends */ -static obj apphost(obj pc) -{ - register obj *r = cxg_regs; - register obj *hp = cxg_hp; - register int rc = cxg_rc; -jump: - switch (objptr_from_obj(pc)-appcases) { - -case 0: /* apply */ - /* clo k f arg... arglist */ - assert(rc >= 4); - { int i; obj l; - rreserve(APPLY_MAX_REGS); - l = r[--rc]; - r[0] = r[2]; - /* k in r[1] */ - for (i = 3; i < rc; ++i) r[i-1] = r[i]; - for (--rc; l != mknull(); l = cdr(l)) r[rc++] = car(l); - /* f k arg... arg... */ - assert(rc <= APPLY_MAX_REGS); - pc = objptr_from_obj(r[0])[0]; - goto jump; } - -case 1: /* dotted lambda adapter */ - /* clo k arg... */ - { obj* p = objptr_from_obj(r[0]); - int n = fixnum_from_obj(p[1]) + 2; - r[0] = p[2]; /* f */ - /* k in r[1] */ - assert(rc >= n); - rreserve(n+1); - if (rc == n) r[rc++] = mknull(); - else { /* collect rest list */ - obj l = mknull(); - hreserve(hbsz(3)*(rc-n), rc); - while (rc > n) { *--hp = l; *--hp = r[--rc]; - *--hp = obj_from_size(PAIR_BTAG); l = hendblk(3); } - r[rc++] = l; } - /* f k arg... arglist */ - pc = objptr_from_obj(r[0])[0]; - goto jump; } - -case 2: /* void continuation adapter */ - /* cclo ek arg ... */ - assert(rc >= 2); - { obj* p = objptr_from_obj(r[0]); - r[0] = p[1]; /* cont */ - pc = objptr_from_obj(r[0])[0]; - /* ek in r[1] */ - rreserve(3); - r[2] = obj_from_void(0); - rc = 3; - goto jump; } - -case 3: /* argc dispatcher */ - /* clo k arg... */ - { obj* p = objptr_from_obj(r[0]); - obj pv = p[1]; int vl = vectorlen(pv); assert(vl > 0); - if (rc-2 < vl-1) r[0] = vectorref(pv, rc-2); /* matching slot */ - else r[0] = vectorref(pv, vl-1); /* catch-all slot */ - pc = objptr_from_obj(r[0])[0]; - goto jump; } - -case 4: /* case lambda dispatcher */ - /* clo k arg... */ - { obj* p = objptr_from_obj(r[0]); int bl = hblklen(p), i; - for (i = 1; i < bl; i += 3) { - int min = fixnum_from_obj(hblkref(p, i)), max = fixnum_from_obj(hblkref(p, i+1)); - if (min <= rc-2 && rc-2 <= max) { r[0] = hblkref(p, i+2); break; } - } assert(i < bl); /* at least one of the cases should match! */ - pc = objptr_from_obj(r[0])[0]; - goto jump; } - -default: /* inter-host call */ - cxg_hp = hp; - cxm_rgc(r, 1); - cxg_rc = rc; - return pc; - } -}") - -(define apply - (%prim "{ /* define apply */ - static obj c[] = { obj_from_objptr(appcases+0) }; - $return objptr(c); }")) - -(define-inline (make-improper-lambda n lam) - (%prim* "{ /* make-improper-lambda */ - hreserve(hbsz(3), $live); /* $live live regs */ - *--hp = obj_from_$arg; - *--hp = obj_from_$arg; - *--hp = obj_from_objptr(appcases+1); - $return obj(hendblk(3)); }" lam n)) - -(define-inline (make-void-continuation k) - (%prim* "{ /* make-void-continuation */ - hreserve(hbsz(2), $live); /* $live live regs */ - *--hp = obj_from_$arg; - *--hp = obj_from_objptr(appcases+2); - $return obj(hendblk(2)); }" k)) - -(define-inline (make-argc-dispatch-lambda pv) - (%prim* "{ /* make-argc-dispatch-lambda */ - hreserve(hbsz(2), $live); /* $live live regs */ - *--hp = obj_from_$arg; - *--hp = obj_from_objptr(appcases+3); - $return obj(hendblk(2)); }" pv)) - -(define-syntax argc-dispatch-lambda - (syntax-rules () - [(_ x ...) (make-argc-dispatch-lambda (vector x ...))])) - -(define-inline (argc-dispatch-lambda? x) - (%prim "{ /* argc-dispatch-lambda? */ - obj x = obj_from_$arg; - $return bool(isprocedure(x) && *procedureref(x, 0) == obj_from_objptr(appcases+3)); }" x)) - -(define-syntax make-case-lambda - (syntax-rules () - [(_ x ...) ; order is: min1 max1 lambda1 min2 max2 lambda2 ... - (%prim*/rev "{ /* make-case-lambda */ - hreserve(hbsz($argc+1), $live); /* $live live regs */ - ${*--hp = obj_from_$arg; - $}*--hp = obj_from_objptr(appcases+4); - $return obj(hendblk($argc+1)); }" x ...)] - [_ %residual-make-case-lambda])) - -(define-syntax case-lambda - (letrec-syntax - ([min-accepted - (syntax-rules () - [(_ () N) N] [(_ (a . d) N) (min-accepted d #&(+ 1 N))] [(_ ra N) N])] - [max-accepted - (syntax-rules () - [(_ () N) N] [(_ (a . d) N) (max-accepted d #&(+ 1 N))] [(_ ra N) (%prim "fixnum(FIXNUM_MAX)")])] - [unroll-cases - (syntax-rules () - [(_ () c ...) - (make-case-lambda c ... 0 (%prim "fixnum(FIXNUM_MAX)") %fail-lambda)] - [(_ ([formals . body] . more) c ...) - (unroll-cases more c ... - (min-accepted formals 0) (max-accepted formals 0) (lambda formals . body))])]) - (syntax-rules () - [(_ [formals . body] ...) - (unroll-cases ([formals . body] ...))]))) - - -; 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)) - - -; shebangs - -; shebangs are symbol-like immediates with immediate tag 8 - -(%definition "/* shebangs (#! directives or script start lines) */") -(%definition "#define SHEBANG_ITAG 8") -(%definition "#define isshebang(o) (isimm(o, SHEBANG_ITAG))") -(%definition "#define mkshebang(i) mkimm(i, SHEBANG_ITAG)") -(%definition "#define getshebang(o) getimmu(o, SHEBANG_ITAG)") - - -; 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; -}") -(%definition "extern void freecb(cbuf_t* pcb);") -(%localdef "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; -}") -(%definition "extern int cbputc(int c, cbuf_t* pcb);") -(%localdef "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; }") -(%definition "extern size_t cblen(cbuf_t* pcb);") -(%localdef "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, \"#\", 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 if (circ && isaptr(objptr_from_obj(o)[0])) return 0; /* opaque */ - 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+(size_t)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 = (size_t)(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 = (size_t)(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; -#ifdef FLONUMS_BOXED - if (h == (obj)FLONUM_NTAG) return flonum_from_obj(x) == flonum_from_obj(y); -#endif - 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; -#ifdef FLONUMS_BOXED - if (h == (obj)FLONUM_NTAG) return flonum_from_obj(x) == flonum_from_obj(y) ? fuel-1 : -1; -#endif - 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; -#ifdef FLONUMS_BOXED - if (h == (obj)FLONUM_NTAG) return *(flonum_t*)objptr_from_obj(x)[0] == *(flonum_t*)objptr_from_obj(y)[0]; -#endif - 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 ` as (quasiquote ) -#read , as (unquote ) -#read ,@ as (unquote-splicing ) - -(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(\"#\", e); - } else if (isvoid(o)) { - wrs(\"#\", e); - } else if (isshebang(o)) { - char *s = symbolname(getshebang(o)); - wrs(\"#', e); - } else if (o == obj_from_unit()) { - wrs(\"#\", 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 (istagged(o, 0)) { - int i, n = taggedlen(o, 0); - wrs(\"#', e); - } else if (isprocedure(o)) { - char buf[60]; - if (isobjptr(hblkref(o, 0))) sprintf(buf, \"#\", objptr_from_obj(o)); - else sprintf(buf, \"#\", objptr_from_obj(o)); - wrs(buf, e); - } else if (isrecord(o)) { - int i, n = recordlen(o); - wrs(\"#', e); - } else { - wrs(\"#\", 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?^_~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 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 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 ) - -(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-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 (fxflonum a)]) (if (flflonum b)]) (if (fl=? 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-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-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)) diff --git a/pre/n.sf b/pre/n.sf index 3d7522b..6dbaa7a 100644 --- a/pre/n.sf +++ b/pre/n.sf @@ -1521,3 +1521,52 @@ void oportputshared(obj x, obj p, int disp) { ; time (%include ) + + +; system-dependent extensions + +(%localdef "/* system-dependent extensions */") +(%localdef "#include \"s.h\"") + +(%localdef " +extern int is_tty_port(obj o) +{ + FILE *fp = NULL; + if ((cxtype_t*)iportvt(o) == IPORT_FILE_NTAG) fp = (FILE*)iportdata(o); + else if ((cxtype_t*)oportvt(o) == OPORT_FILE_NTAG) fp = (FILE*)oportdata(o); + if (!fp) return 0; + return isatty(fileno(fp)); +} + +#ifdef WIN32 +int dirsep = '\\\\'; +#else +int dirsep = '/'; +#endif + +extern char *argv_ref(int idx) +{ + char **pv = cxg_argv; + /* be careful with indexing! */ + if (idx < 0) return NULL; + while (idx-- > 0) if (*pv++ == NULL) return NULL; + return *pv; +} + +#if defined(WIN32) +#define cxg_envv _environ +#elif defined(__linux) || defined(__APPLE__) +#define cxg_envv environ +#else /* add more systems? */ +char **cxg_envv = { NULL }; +#endif + +extern char *envv_ref(int idx) +{ + char **pv = cxg_envv; + /* be careful with indexing! */ + if (idx < 0) return NULL; + while (idx-- > 0) if (*pv++ == NULL) return NULL; + return *pv; +} +") diff --git a/s.c b/s.c index 4f6642d..87c3e48 100644 --- a/s.c +++ b/s.c @@ -1,47 +1,4 @@ -/* s.c -- generated via skint -c s.scm */ -#include "s.h" -#include "n.h" - -extern int is_tty_port(obj o) -{ - FILE *fp = NULL; - if ((cxtype_t*)iportvt(o) == IPORT_FILE_NTAG) fp = (FILE*)iportdata(o); - else if ((cxtype_t*)oportvt(o) == OPORT_FILE_NTAG) fp = (FILE*)oportdata(o); - if (!fp) return 0; - return isatty(fileno(fp)); -} - -#ifdef WIN32 -int dirsep = '\\'; -#else -int dirsep = '/'; -#endif - -extern char *argv_ref(int idx) -{ - char **pv = cxg_argv; - /* be careful with indexing! */ - if (idx < 0) return NULL; - while (idx-- > 0) if (*pv++ == NULL) return NULL; - return *pv; -} - -#if defined(WIN32) -#define cxg_envv _environ -#elif defined(__linux) || defined(__APPLE__) -#define cxg_envv environ -#else /* add more systems? */ -char **cxg_envv = { NULL }; -#endif - -extern char *envv_ref(int idx) -{ - char **pv = cxg_envv; - /* be careful with indexing! */ - if (idx < 0) return NULL; - while (idx-- > 0) if (*pv++ == NULL) return NULL; - return *pv; -} +/* s.c -- generated via skint scm2c.ssc s.scm */ char *s_code[] = { diff --git a/t.c b/t.c index c6f1303..3680a19 100644 --- a/t.c +++ b/t.c @@ -1,4 +1,4 @@ -/* t.c -- generated via skint -c t.scm */ +/* t.c -- generated via skint scm2c.ssc t.scm */ char *t_code[] = {