skint/src/k.sf

;------------------------------------------------------------------------------
;
;  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-syntax fx>=?
  (syntax-rules ()
    [(_ x y) (%prim "bool(fixnum_from_$arg >= fixnum_from_$arg)" x y)]
    [(_ x y z ...) (let ([t y]) (and (fx>=? x t) (fx>=? t z ...)))]
    [_ %residual-fx>=?]))

(define-inline (fxzero? x)
  (%prim "bool(fixnum_from_$arg == 0)" x))

(define-inline (fxpositive? x)
  (%prim "bool(fixnum_from_$arg > 0)" x))

(define-inline (fxnegative? x)
  (%prim "bool(fixnum_from_$arg < 0)" x))

(define-inline (fxodd? x)
  (%prim "bool((fixnum_from_$arg & 1) != 0)" x))

(define-inline (fxeven? x)
  (%prim "bool((fixnum_from_$arg & 1) == 0)" x))

(define-syntax fxmax
  (syntax-rules ()
    [(_ x) x]
    [(_ x y) (let ([a x] [b y]) (if (fx>? a b) a b))]
    [(_ x y z ...) (fxmax (fxmax x y) z ...)]
    [_ %residual-fxmax]))

(define-syntax fxmin
  (syntax-rules ()
    [(_ x) x]
    [(_ x y) (let ([a x] [b y]) (if (fx<? a b) a b))]
    [(_ x y z ...) (fxmin (fxmin x y) z ...)]
    [_ %residual-fxmin]))

(define-syntax fx+
  (syntax-rules ()
    [(_) (%prim "fixnum(0)")] [(_ x) x]
    [(_ x y) (%prim "fixnum(fxadd(fixnum_from_$arg, fixnum_from_$arg))" x y)]
    [(_ x y z ...) (fx+ x (fx+ y z ...))]
    [_ %residual-fx+]))

(define-syntax fx*
  (syntax-rules ()
    [(_) (%prim "fixnum(1)")] [(_ x) x]
    [(_ x y) (%prim "fixnum(fxmul(fixnum_from_$arg, fixnum_from_$arg))" x y)]
    [(_ x y z ...) (fx* x (fx* y z ...))]
    [_ %residual-fx*]))

(define-syntax fx-
  (syntax-rules ()
    [(_ x) (%prim "fixnum(fxneg(fixnum_from_$arg))" x)]
    [(_ x y) (%prim "fixnum(fxsub(fixnum_from_$arg, fixnum_from_$arg))" x y)]
    [(_ x y z ...) (fx- (fx- x y) z ...)]
    [_ %residual-fx-]))

(define-syntax fx/
  (syntax-rules ()
    [(_ x) (%prim "fixnum(fxdiv(1, fixnum_from_$arg))" x)]
    [(_ x y) (%prim "fixnum(fxdiv(fixnum_from_$arg, fixnum_from_$arg))" x y)]
    [(_ x y z ...) (fx/ (fx/ x y) z ...)]
    [_ %residual-fx/]))

(define-inline (fxquotient x y)
  (%prim "fixnum(fxquo(fixnum_from_$arg, fixnum_from_$arg))" x y))

(define-inline (fxremainder x y)
  (%prim "fixnum(fxrem(fixnum_from_$arg, fixnum_from_$arg))" x y))

(define-inline (fxmodquo x y)
  (%prim "fixnum(fxmqu(fixnum_from_$arg, fixnum_from_$arg))" x y))

(define-inline (fxmodulo x y)
  (%prim "fixnum(fxmlo(fixnum_from_$arg, fixnum_from_$arg))" x y))

(define-inline (fxeuq x y)
  (%prim "fixnum(fxeuq(fixnum_from_$arg, fixnum_from_$arg))" x y))

(define-inline (fxeur x y)
  (%prim "fixnum(fxeur(fixnum_from_$arg, fixnum_from_$arg))" x y))

(define-inline (fxabs x)
  (%prim "fixnum(fxabs(fixnum_from_$arg))" x))

(define-inline (fxgcd x y)
  (%prim "fixnum(fxgcd(fixnum_from_$arg, fixnum_from_$arg))" x y))

(define-inline (fxexpt x y)
  (%prim* "fixnum(fxpow(fixnum_from_$arg, fixnum_from_$arg))" x y))

(define-inline (fxsqrt x)
  (%prim "fixnum(fxsqrt(fixnum_from_$arg))" x))
  
(define-inline (fxnot x)
  (%prim "fixnum(~fixnum_from_$arg)" x))
  
(define-inline (fxand x y)
  (%prim "fixnum(fixnum_from_$arg & fixnum_from_$arg)" x y))
  
(define-inline (fxior x y)
  (%prim "fixnum(fixnum_from_$arg | fixnum_from_$arg)" x y))

(define-inline (fxxor x y)
  (%prim "fixnum(fixnum_from_$arg ^ fixnum_from_$arg)" x y))

(define-inline (fxarithmetic-shift-left x y)
  (%prim "fixnum(fxasl(fixnum_from_$arg, fixnum_from_$arg))" x y))

(define-inline (fxarithmetic-shift-right x y)
  (%prim "fixnum(fxasr(fixnum_from_$arg, fixnum_from_$arg))" x y))


; flonums

(define-syntax %const
  (let-syntax ([old-%const %const])
    (syntax-rules (decimal e exact inexact inf nan)
      [(_ decimal e str) 
       (%prim* ("flonum($live, " str ")"))]
      [(_ decimal e ms indigs frdigs es exdigs) 
       (%prim* ("flonum($live, " #&(id->string ms) 
         indigs "." frdigs "e" #&(id->string es) exdigs ")"))]
      [(_ inexact (decimal . r)) (%const decimal . r)]
      [(_ exact (decimal . r)) (inexact->exact (%const decimal . r))] 
      [(_ inf ms) (%prim* ("flonum($live, " #&(id->string ms) "HUGE_VAL)"))]
      [(_ inexact (inf . r)) (%const inf . r)] 
      [(_ nan ms) (%prim* ("flonum($live, HUGE_VAL-HUGE_VAL)"))]
      [(_ inexact (nan . r)) (%const nan . r)] 
      [(_ arg ...) (old-%const arg ...)]))) 

(define-inline (flonum? x)
  (%prim "bool(is_flonum_$arg)" x))

(define-inline (fixnum->flonum n) 
  (%prim* "flonum($live, (flonum_t)fixnum_from_$arg)" n))

(define-inline (flonum->fixnum x) 
  (%prim "fixnum(fxflo(flonum_from_$arg))" x))

(define-inline (real->flonum n)
  (if (flonum? n) n (fixnum->flonum n))) 

(define-inline (real->fixnum n)
  (if (fixnum? n) n (flonum->fixnum n))) 

(define-syntax fl=?
  (syntax-rules ()
    [(_ x y) (%prim "bool(flonum_from_$arg == flonum_from_$arg)" x y)]
    [(_ x y z ...) (let ([t y]) (and (fl=? x t) (fl=? t z ...)))]
    [_ %residual-fl=?]))

(define-syntax fl<?
  (syntax-rules ()
    [(_ x y) (%prim "bool(flonum_from_$arg < flonum_from_$arg)" x y)]
    [(_ x y z ...) (let ([t y]) (and (fl<? x t) (fl<? t z ...)))]
    [_ %residual-fl<?]))

(define-syntax fl>?
  (syntax-rules ()
    [(_ x y) (%prim "bool(flonum_from_$arg > flonum_from_$arg)" x y)]
    [(_ x y z ...) (let ([t y]) (and (fl>? x t) (fl>? t z ...)))]
    [_ %residual-fl>?]))

(define-syntax fl<=?
  (syntax-rules ()
    [(_ x y) (%prim "bool(flonum_from_$arg <= flonum_from_$arg)" x y)]
    [(_ x y z ...) (let ([t y]) (and (fl<=? x t) (fl<=? t z ...)))]
    [_ %residual-fl<=?]))

(define-syntax fl>=?
  (syntax-rules ()
    [(_ x y) (%prim "bool(flonum_from_$arg >= flonum_from_$arg)" x y)]
    [(_ x y z ...) (let ([t y]) (and (fl>=? x t) (fl>=? t z ...)))]
    [_ %residual-fl>=?]))

(define-inline (flinteger? x)
  (%prim "bool(flisint(flonum_from_$arg))" x))

(define-inline (flzero? x)
  (%prim "bool(flonum_from_$arg == 0.0)" x))

(define-inline (flpositive? x)
  (%prim "bool(flonum_from_$arg > 0.0)" x))

(define-inline (flnegative? x)
  (%prim "bool(flonum_from_$arg < 0.0)" x))

(define-inline (flodd? x)
  (%prim "bool(flisint((flonum_from_$arg + 1.0) / 2.0))" x))
 
(define-inline (fleven? x)
  (%prim "bool(flisint(flonum_from_$arg / 2.0))" x))

(define-inline (flnan? x)
  (%prim "{ /* flnan? */ 
    flonum_t f = flonum_from_$arg;
    $return bool(f != f); }" x))

(define-inline (flinfinite? x)
  (%prim "{ /* flinfinite? */ 
    flonum_t f = flonum_from_$arg;
    $return bool(f <= -HUGE_VAL || f >= HUGE_VAL); }" x))

(define-syntax flmax
  (syntax-rules ()
    [(_ x) x]
    [(_ x y) (let ([a x] [b y]) (if (fl>? a b) a b))]
    [(_ x y z ...) (flmax (flmax x y) z ...)]
    [_ %residual-flmax]))

(define-syntax flmin
  (syntax-rules ()
    [(_ x) x]
    [(_ x y) (let ([a x] [b y]) (if (fl<? a b) a b))]
    [(_ x y z ...) (flmin (flmin x y) z ...)]
    [_ %residual-flmin]))

(define-syntax fl+
  (syntax-rules ()
    [(_) (%prim* "flonum($live, 0.0)")] [(_ x) x]
    [(_ x y) (%prim* "flonum($live, flonum_from_$arg + flonum_from_$arg)" x y)]
    [(_ x y z ...) (fl+ x (fl+ y z ...))]
    [_ %residual-fl+]))

(define-syntax fl*
  (syntax-rules ()
    [(_) (%prim* "flonum($live, 1.0)")] [(_ x) x]
    [(_ x y) (%prim* "flonum($live, flonum_from_$arg * flonum_from_$arg)" x y)]
    [(_ x y z ...) (fl* x (fl* y z ...))]
    [_ %residual-fl*]))

(define-syntax fl-
  (syntax-rules ()
    [(_ x) (%prim* "flonum($live, -flonum_from_$arg)" x)]
    [(_ x y) (%prim* "flonum($live, flonum_from_$arg - flonum_from_$arg)" x y)]
    [(_ x y z ...) (fl- (fl- x y) z ...)]
    [_ %residual-fl-]))

(define-syntax fl/
  (syntax-rules ()
    [(_ x) (%prim* "flonum($live, 1.0/flonum_from_$arg)" x)]
    [(_ x y) (%prim* "flonum($live, flonum_from_$arg / flonum_from_$arg)" x y)]
    [(_ x y z ...) (fl/ (fl/ x y) z ...)]
    [_ %residual-fl/]))

(define-inline (flquotient x y)
  (%prim* "flonum($live, flquo(flonum_from_$arg, flonum_from_$arg))" x y))

(define-inline (flremainder x y)
  (%prim* "flonum($live, flrem(flonum_from_$arg, flonum_from_$arg))" x y))

(define-inline (flmodquo x y)
  (%prim* "flonum($live, flmqu(flonum_from_$arg, flonum_from_$arg))" x y))

(define-inline (flmodulo x y)
  (%prim* "flonum($live, flmlo(flonum_from_$arg, flonum_from_$arg))" x y))

(define-inline (flabs x)
  (%prim* "flonum($live, fabs(flonum_from_$arg))" x))

(define-inline (flgcd x y)
  (%prim* "flonum($live, flgcd(flonum_from_$arg, flonum_from_$arg))" x y))

(define-inline (flfloor x)
  (%prim* "flonum($live, floor(flonum_from_$arg))" x))

(define-inline (flceiling x)
  (%prim* "flonum($live, ceil(flonum_from_$arg))" x))

(define-inline (fltruncate x)
  (%prim* "{ /* fltruncate */ 
    flonum_t x = flonum_from_$arg;
    double i; modf(x,  &i);
    $return flonum($live, i); }" x))
    
(define-inline (flround x)
  (%prim* "flonum($live, flround(flonum_from_$arg))" x))

(define-inline (flsqrt x)
  (%prim* "flonum($live, sqrt(flonum_from_$arg))" x))

(define-inline (flexp x)
  (%prim* "flonum($live, exp(flonum_from_$arg))" x))

(define-inline (fllog x)
  (%prim* "flonum($live, log(flonum_from_$arg))" x))

(define-inline (fllog10 x)
  (%prim* "flonum($live, log10(flonum_from_$arg))" x))

(define-inline (flsin x)
  (%prim* "flonum($live, sin(flonum_from_$arg))" x))

(define-inline (flcos x)
  (%prim* "flonum($live, cos(flonum_from_$arg))" x))

(define-inline (fltan x)
  (%prim* "flonum($live, tan(flonum_from_$arg))" x))

(define-inline (flasin x)
  (%prim* "flonum($live, asin(flonum_from_$arg))" x))

(define-inline (flacos x)
  (%prim* "flonum($live, acos(flonum_from_$arg))" x))

(define-syntax flatan
  (syntax-rules ()
    [(_ x) (%prim* "flonum($live, atan(flonum_from_$arg))" x)]
    [(_ y x) (%prim* "flonum($live, atan2(flonum_from_$arg, flonum_from_$arg))" y x)]
    [_ %residual-flatan]))

(define-inline (flexpt x y)
  (%prim* "flonum($live, pow(flonum_from_$arg, flonum_from_$arg))" x y))

(define-inline (fxfl/ x y)
  (%prim* "{ /* fxfl/ */ 
    fixnum_t x = fixnum_from_$arg, y = fixnum_from_$arg;
    long i; double d;
    if (0) $return obj(0); /* to fool sfc unboxer */
    else if (fxifdv(x, y, &i, &d)) $return fixnum(i);
    else $return flonum($live, d); }" x y))


; generic math (fixnum/flonum)

(define-inline (real? x)
  (or (fixnum? x) (flonum? x))) 

(define-inline (integer? x)
  (or (fixnum? x) (and (flonum? x) (flinteger? x)))) 

(define-syntax exact-integer? fixnum?)

(define-inline rational? integer?)
(define-inline complex? real?)
(define-inline number? real?)

(define-inline exact? fixnum?)
(define-inline inexact? flonum?)
(define-inline (exact x)
  (if (fixnum? x) x (flonum->fixnum x)))
(define-inline (inexact x)
  (if (flonum? x) x (fixnum->flonum x)))
(define-syntax inexact->exact exact)
(define-syntax exact->inexact inexact)

(define-syntax real-binop
  (syntax-rules ()
    [(_ x y fxop flop) 
     (let ([a x] [b y])
       (if (fixnum? a)
           (if (fixnum? b)
               (fxop a b)
               (flop (fixnum->flonum a) b))
           (if (fixnum? b)
               (flop a (fixnum->flonum b))
               (flop a b))))]))

(define-syntax =
  (syntax-rules ()
    [(_ x y) (real-binop x y fx=? fl=?)] 
    [(_ x y z ...) (let ([t y]) (and (= x t) (= t z ...)))]
    [_ %residual=]))

(define-syntax <
  (syntax-rules ()
    [(_ x y) (real-binop x y fx<? fl<?)]
    [(_ x y z ...) (let ([t y]) (and (< x t) (< t z ...)))]
    [_ %residual<]))

(define-syntax >
  (syntax-rules ()
    [(_ x y) (real-binop x y fx>? fl>?)]
    [(_ x y z ...) (let ([t y]) (and (> x t) (> t z ...)))]
    [_ %residual>]))

(define-syntax <=
  (syntax-rules ()
    [(_ x y) (real-binop x y fx<=? fl<=?)]
    [(_ x y z ...) (let ([t y]) (and (<= x t) (<= t z ...)))]
    [_ %residual<=]))

(define-syntax >=
  (syntax-rules ()
    [(_ x y) (real-binop x y fx>=? fl>=?)]
    [(_ x y z ...) (let ([t y]) (and (>= x t) (>= t z ...)))]
    [_ %residual>=]))

(define-inline (zero? x)
  (if (fixnum? x) (fxzero? x) (flzero? x))) 

(define-inline (positive? x)
  (if (fixnum? x) (fxpositive? x) (flpositive? x))) 

(define-inline (negative? x)
  (if (fixnum? x) (fxnegative? x) (flnegative? x))) 

(define-inline (even? x)
  (if (fixnum? x) (fxeven? x) (fleven? x))) 

(define-inline (odd? x)
  (if (fixnum? x) (fxodd? x) (flodd? x)))

(define-inline (nan? x)
  (and (flonum? x) (flnan? x))) 

(define-inline (infinite? x)
  (and (flonum? x) (flinfinite? x))) 

(define-inline (finite? x)
  (or (fixnum? x) (not (flinfinite? x)))) 

(define-syntax max
  (syntax-rules ()
    [(_ x) x]
    [(_ x y) 
     (let ([a x] [b y]) 
       (if (and (fixnum? a) (fixnum? b)) (if (fx>? a b) a b) (%residual-max/2 a b)))]
    [(_ x y z ...) (%residual-max x y z ...)]
    [_ %residual-max]))

(define-syntax min
  (syntax-rules ()
    [(_ x) x]
    [(_ x y)
     (let ([a x] [b y]) 
       (if (and (fixnum? a) (fixnum? b)) (if (fx<? a b) a b) (%residual-min/2 a b)))]
    [(_ x y z ...) (%residual-min x y z ...)]
    [_ %residual-min]))

(define-syntax +
  (syntax-rules ()
    [(_) 0] 
    [(_ x) x]
    [(_ x y) (real-binop x y fx+ fl+)]
    [(_ x y z ...) (+ (+ x y) z ...)]
    [_ %residual+]))

(define-syntax *
  (syntax-rules ()
    [(_) 1]
    [(_ x) x]
    [(_ x y) (real-binop x y fx* fl*)]
    [(_ x y z ...) (* (* x y) z ...)]
    [_ %residual*]))

(define-syntax -
  (syntax-rules ()
    [(_ x) (let ([a x]) (if (fixnum? a) (fx- a) (fl- a)))]
    [(_ x y) (real-binop x y fx- fl-)]
    [(_ x y z ...) (- (- x y) z ...)]
    [_ %residual-]))

(define-syntax /
  (syntax-rules ()
    [(_ x) (let ([a x]) (if (fixnum? a) (fxfl/ 1 a) (fl/ a)))]
    [(_ x y) (real-binop x y fxfl/ fl/)]
    [(_ x y z ...) (/ (/ x y) z ...)]
    [_ %residual/]))
   
(define-inline (abs x)
  (if (fixnum? x) (fxabs x) (flabs x)))

(define-inline (quotient x y)
  (real-binop x y fxquotient flquotient))

(define-inline (remainder x y)
  (real-binop x y fxremainder flremainder))

(define-syntax truncate-quotient quotient)
(define-syntax truncate-remainder remainder)

(define-inline (modquo x y)
  (real-binop x y fxmodquo flmodquo))

(define-inline (modulo x y)
  (real-binop x y fxmodulo flmodulo))

(define-syntax floor-quotient modquo)
(define-syntax floor-remainder modulo)

(define-syntax gcd
  (syntax-rules ()
    [(_) 0] 
    [(_ x) x]
    [(_ x y) (real-binop x y fxgcd flgcd)]
    [(_ x y z ...) (gcd (gcd x y) z ...)]
    [_ %residual-gcd]))

(define (lcm/2 x y)
  (let ([g (gcd x y)])
    (if (zero? g) g (* (quotient (abs x) g) (abs y)))))

(define-syntax lcm
  (syntax-rules ()
    [(_) 1] 
    [(_ x) x]
    [(_ x y) (lcm/2 x y)]
    [(_ x y z ...) (lcm (lcm/2 x y) z ...)]
    [_ %residual-lcm]))

; no div
; no mod  

(define-inline (numerator n)
  n)

(define-inline (denominator n)
  1)

(define-inline (rationalize n d)
  n)

(define-inline (floor x)
  (if (fixnum? x) x (flfloor x)))

(define-inline (ceiling x)
  (if (fixnum? x) x (flceiling x)))

(define-inline (truncate x)
  (if (fixnum? x) x (fltruncate x)))

(define-inline (round x)
  (if (fixnum? x) x (flround x)))

; need exact version?
(define-inline (sqrt x)
  (flsqrt (real->flonum x)))

(define-inline (exp x)
  (flexp (real->flonum x)))

(define-syntax log
  (syntax-rules ()
    [(_ x) (fllog (real->flonum x))]
    [(_ x b) (if (fx=? b 10) (fllog10 (real->flonum x)) (fl/ (log x) (log b)))]
    [_ %residual-log]))

(define-inline (sin x)
  (flsin (real->flonum x)))

(define-inline (cos x)
  (flcos (real->flonum x)))

(define-inline (tan x)
  (fltan (real->flonum x)))

(define-inline (asin x)
  (flasin (real->flonum x)))

(define-inline (acos x)
  (flacos (real->flonum x)))

(define-syntax atan
  (syntax-rules ()
    [(_ x) (flatan (real->flonum x))]
    [(_ y x) (flatan (real->flonum y) (real->flonum x))]
    [_ %residual-atan]))

(define-inline (expt x y)
  (if (and (fixnum? x) (fixnum? y) (fx>=? y 0))
      (fxexpt x y)
      (flexpt (real->flonum x) (real->flonum y))))

(define-inline (square x) (* x x))


; characters

(define-syntax %const
  (let-syntax ([old-%const %const])
    (syntax-rules (char)
      [(_ char 8 c) (%prim ("char(" c ")"))]
      [(_ char cs) (%prim ("char('" cs "')"))] 
      [(_ arg ...) (old-%const arg ...)]))) 

(define-inline (char? x)
  (%prim "bool(is_char_$arg)" x))

(define-syntax char=?
  (syntax-rules ()
    [(_ x y) (%prim "bool(char_from_$arg == char_from_$arg)" x y)]
    [(_ x y z ...) (let ([t y]) (and (char=? x t) (char=? t z ...)))]
    [_ %residual-char=?]))

(define-syntax char>?
  (syntax-rules ()
    [(_ x y) (%prim "bool(char_from_$arg > char_from_$arg)" x y)]
    [(_ x y z ...) (let ([t y]) (and (char>? x t) (char>? t z ...)))]
    [_ %residual-char>?]))

(define-syntax char<?
  (syntax-rules ()
    [(_ x y) (%prim "bool(char_from_$arg < char_from_$arg)" x y)]
    [(_ x y z ...) (let ([t y]) (and (char<? x t) (char<? t z ...)))]
    [_ %residual-char<?]))

(define-syntax char>=?
  (syntax-rules ()
    [(_ x y) (%prim "bool(char_from_$arg >= char_from_$arg)" x y)]
    [(_ x y z ...) (let ([t y]) (and (char>=? x t) (char>=? t z ...)))]
    [_ %residual-char>=?]))

(define-syntax char<=?
  (syntax-rules ()
    [(_ x y) (%prim "bool(char_from_$arg <= char_from_$arg)" x y)]
    [(_ x y z ...) (let ([t y]) (and (char<=? x t) (char<=? t z ...)))]
    [_ %residual-char<=?]))

(define-syntax char-ci=?
  (syntax-rules ()
    [(_ x y) (%prim "bool(tolower(char_from_$arg) == tolower(char_from_$arg))" x y)]
    [(_ x y z ...) (let ([t y]) (and (char-ci=? x t) (char-ci=? t z ...)))]
    [_ %residual-char-ci=?]))

(define-syntax char-ci>?
  (syntax-rules ()
    [(_ x y) (%prim "bool(tolower(char_from_$arg) > tolower(char_from_$arg))" x y)]
    [(_ x y z ...) (let ([t y]) (and (char-ci>? x t) (char-ci>? t z ...)))]
    [_ %residual-char-ci>?]))

(define-syntax char-ci<?
  (syntax-rules ()
    [(_ x y) (%prim "bool(tolower(char_from_$arg) < tolower(char_from_$arg))" x y)]
    [(_ x y z ...) (let ([t y]) (and (char-ci<? x t) (char-ci<? t z ...)))]
    [_ %residual-char-ci<?]))

(define-syntax char-ci>=?
  (syntax-rules ()
    [(_ x y) (%prim "bool(tolower(char_from_$arg) >= tolower(char_from_$arg))" x y)]
    [(_ x y z ...) (let ([t y]) (and (char-ci>=? x t) (char-ci>=? t z ...)))]
    [_ %residual-char-ci>=?]))

(define-syntax char-ci<=?
  (syntax-rules ()
    [(_ x y) (%prim "bool(tolower(char_from_$arg) <= tolower(char_from_$arg))" x y)]
    [(_ x y z ...) (let ([t y]) (and (char-ci<=? x t) (char-ci<=? t z ...)))]
    [_ %residual-char-ci<=?]))

(define-inline (char-alphabetic? x)
  (%prim "bool(isalpha(char_from_$arg))" x))

(define-inline (char-numeric? x)
  (%prim "bool(isdigit(char_from_$arg))" x))

(define-inline (char-whitespace? x)
  (%prim "bool(isspace(char_from_$arg))" x))

(define-inline (char-upper-case? x)
  (%prim "bool(isupper(char_from_$arg))" x))

(define-inline (char-lower-case? x)
  (%prim "bool(islower(char_from_$arg))" x))

(define-inline (char->integer x)
  (%prim "fixnum((fixnum_t)char_from_$arg)" x))

(define-inline (integer->char x)
  (%prim "char((char_t)fixnum_from_$arg)" x))

(define-inline (char-upcase x)
  (%prim "char(toupper(char_from_$arg))" x))

(define-inline (char-downcase x)
  (%prim "char(tolower(char_from_$arg))" x))

(define-syntax char-foldcase char-downcase)

(define-inline (digit-value x)
  (and (char<=? #\0 x #\9) (fx- (char->integer x) (%prim "fixnum('0')"))))


; strings

(define-syntax %const
  (let-syntax ([old-%const %const])
    (syntax-rules (string)
      [(_ string s)
       (%prim* ("obj(hpushstr($live, newstring(\"" s "\")))"))]
      [(_ string 8 c ...)
       (%prim* ("{ static char s[] = { " (c ", ") ... "0 };\n"
                "    $return obj(hpushstr($live, newstring(s))); }"))]
      [(_ arg ...) (old-%const arg ...)]))) 

(define-inline (string? x)
  (%prim "bool(isstring(obj_from_$arg))" x))

(define-syntax make-string
  (syntax-rules ()
    [(_ k) (%prim* "obj(hpushstr($live, allocstring(fixnum_from_$arg, '?')))" k)]
    [(_ k c) (%prim* "obj(hpushstr($live, allocstring(fixnum_from_$arg, char_from_$arg)))" k c)]
    [_ %residual-make-string]))

(define-syntax string
  (syntax-rules ()
    [(_ c ...)
     (%prim* "{ /* string */
    obj o = hpushstr($live, allocstring($argc, ' '));
    unsigned char *s = (unsigned char *)stringchars(o);
    ${*s++ = (unsigned char)char_from_$arg;
    $}$return obj(o); }" c ...)]
    [_ %residual-string]))

(define-inline (string-length s)
  (%prim "fixnum(stringlen(obj_from_$arg))" s))

(define-inline (string-ref s k)
  (%prim? "char(*(unsigned char*)stringref(obj_from_$arg, fixnum_from_$arg))" s k))

(define-inline (string-set! s k c)
  (%prim! "void(*stringref(obj_from_$arg, fixnum_from_$arg) = char_from_$arg)" s k c))

(define-syntax string=?
  (syntax-rules ()
    [(_ x y) (%prim? "bool(strcmp(stringchars(obj_from_$arg), stringchars(obj_from_$arg)) == 0)" x y)]
    [(_ x y z ...) (let ([t y]) (and (string=? x t) (string=? t z ...)))]
    [_ %residual-string=?]))

(define-syntax string<?
  (syntax-rules ()
    [(_ x y) (%prim? "bool(strcmp(stringchars(obj_from_$arg), stringchars(obj_from_$arg)) < 0)" x y)]
    [(_ x y z ...) (let ([t y]) (and (string<? x t) (string<? t z ...)))]
    [_ %residual-string<?]))

(define-syntax string>?
  (syntax-rules ()
    [(_ x y) (%prim? "bool(strcmp(stringchars(obj_from_$arg), stringchars(obj_from_$arg)) > 0)" x y)]
    [(_ x y z ...) (let ([t y]) (and (string>? x t) (string>? t z ...)))]
    [_ %residual-string>?]))

(define-syntax string<=?
  (syntax-rules ()
    [(_ x y) (%prim? "bool(strcmp(stringchars(obj_from_$arg), stringchars(obj_from_$arg)) <= 0)" x y)]
    [(_ x y z ...) (let ([t y]) (and (string<=? x t) (string<=? t z ...)))]
    [_ %residual-string<=?]))

(define-syntax string>=?
  (syntax-rules ()
    [(_ x y) (%prim? "bool(strcmp(stringchars(obj_from_$arg), stringchars(obj_from_$arg)) >= 0)" x y)]
    [(_ x y z ...) (let ([t y]) (and (string>=? x t) (string>=? t z ...)))]
    [_ %residual-string>=?]))

(define-syntax string-ci=?
  (syntax-rules ()
    [(_ x y) (%prim? "bool(strcmp_ci(stringchars(obj_from_$arg), stringchars(obj_from_$arg)) == 0)" x y)]
    [(_ x y z ...) (let ([t y]) (and (string-ci=? x t) (string-ci=? t z ...)))]
    [_ %residual-string-ci=?]))

(define-syntax string-ci<?
  (syntax-rules ()
    [(_ x y) (%prim? "bool(strcmp_ci(stringchars(obj_from_$arg), stringchars(obj_from_$arg)) < 0)" x y)]
    [(_ x y z ...) (let ([t y]) (and (string-ci<? x t) (string-ci<? t z ...)))]
    [_ %residual-string-ci<?]))

(define-syntax string-ci>?
  (syntax-rules ()
    [(_ x y) (%prim? "bool(strcmp_ci(stringchars(obj_from_$arg), stringchars(obj_from_$arg)) > 0)" x y)]
    [(_ x y z ...) (let ([t y]) (and (string-ci>? x t) (string-ci>? t z ...)))]
    [_ %residual-string-ci>?]))

(define-syntax string-ci<=?
  (syntax-rules ()
    [(_ x y) (%prim? "bool(strcmp_ci(stringchars(obj_from_$arg), stringchars(obj_from_$arg)) <= 0)" x y)]
    [(_ x y z ...) (let ([t y]) (and (string-ci<=? x t) (string-ci<=? t z ...)))]
    [_ %residual-string-ci<=?]))

(define-syntax string-ci>=?
  (syntax-rules ()
    [(_ x y) (%prim? "bool(strcmp_ci(stringchars(obj_from_$arg), stringchars(obj_from_$arg)) >= 0)" x y)]
    [(_ x y z ...) (let ([t y]) (and (string-ci>=? x t) (string-ci>=? t z ...)))]
    [_ %residual-string-ci>=?]))

(define-inline (string-upcase s)
  (%prim*? "{ /* string-upcase */
    int *d = dupstring(stringdata(obj_from_$arg)); char *s;
    for (s = sdatachars(d); *s; ++s) *s = toupper(*s);
    $return obj(hpushstr($live, d)); }" s))

(define-inline (string-downcase s)
  (%prim*? "{ /* string-downcase */
    int *d = dupstring(stringdata(obj_from_$arg)); char *s;
    for (s = sdatachars(d); *s; ++s) *s = tolower(*s);
    $return obj(hpushstr($live, d)); }" s))

(define-syntax string-foldcase string-downcase)

(define-inline (substring s start end)
  (%prim*? "{ /* substring */
    int *d = substring(stringdata(obj_from_$arg), fixnum_from_$arg, fixnum_from_$arg);
    $return obj(hpushstr($live, d)); }" s start end))

(define-inline (%string-append s1 s2)
  (%prim*? "{ /* string-append */
    int *d = stringcat(stringdata(obj_from_$arg), stringdata(obj_from_$arg));
    $return obj(hpushstr($live, d)); }" s1 s2))

(define-syntax string-append
  (syntax-rules ()
    [(_) ""] [(_ x) x]
    [(_ x y) (%string-append x y)]
    [(_ x y z ...) (%string-append x (string-append y z ...))]
    [_ %residual-string-append]))

(define-inline (%string-copy s)
  (%prim*? "{ /* string-copy */
    int *d = dupstring(stringdata(obj_from_$arg));
    $return obj(hpushstr($live, d)); }" s))

(define (substring-copy! to at from start end)
  (let ([limit (fxmin end (fx+ start (fx- (string-length to) at)))])
    (if (fx<=? at start)
        (do ([i at (fx+ i 1)] [j start (fx+ j 1)]) 
          [(fx>=? j limit)]
          (string-set! to i (string-ref from j)))
        (do ([i (fx+ at (fx- end start 1)) (fx- i 1)] [j (fx- limit 1) (fx- j 1)])
          [(fx<? j start)]
          (string-set! to i (string-ref from j))))))

(define (substring-fill! str c start end)
  (do ([i start (fx+ i 1)]) [(fx>=? i end)] (string-set! str i c)))

(define-inline (%string-fill! s c)
  (%prim! "void(stringfill(stringdata(obj_from_$arg), char_from_$arg))" s c))

(define-inline (string-position c s)
  (%prim? "{ /* string-position */
    char *s = stringchars(obj_from_$arg), *p = strchr(s, char_from_$arg);
    if (p) $return fixnum(p-s); else $return bool(0); }" s c))


; vectors

(define-inline (vector? o)
  (%prim "bool(isvector(obj_from_$arg))" o))

(define-inline (%new-vector n)
  (%prim* "{ /* new-vector */
    int c = fixnum_from_$arg;
    hreserve(hbsz(c+1), $live); /* $live live regs */
    hp -= c; memset(hp, 0, c * sizeof(obj));
    *--hp = obj_from_size(VECTOR_BTAG);
    $return obj(hendblk(c+1)); }" n))

(define-inline (%make-vector n i)
  (%prim* "{ /* make-vector */
    obj o; int i = 0, c = fixnum_from_$arg;
    hreserve(hbsz(c+1), $live); /* $live live regs */
    o = obj_from_$arg; /* gc-safe */
    while (i++ < c) *--hp = o;
    *--hp = obj_from_size(VECTOR_BTAG);
    $return obj(hendblk(c+1)); }" n i))

(define-syntax make-vector
  (syntax-rules ()
    [(_ n) (%new-vector n)]
    [(_ n i) (%make-vector n i)]
    [_ %residual-make-vector]))

(define-syntax vector
  (syntax-rules ()
    [(_ i ...)
     (%prim*/rev "{ /* vector */
    hreserve(hbsz($argc+1), $live); /* $live live regs */
    ${*--hp = obj_from_$arg;
    $}*--hp = obj_from_size(VECTOR_BTAG);
    $return obj(hendblk($argc+1)); }" i ...)]
    [_ %residual-vector]))

(define-syntax %const
  (let-syntax ([old-%const %const])
    (syntax-rules (vector)
      [(_ vector x ...) (vector x ...)] 
      [(_ arg ...) (old-%const arg ...)]))) 

(define-inline (vector-length v)
  (%prim "fixnum(vectorlen(obj_from_$arg))" v))

(define-inline (vector-ref v i)
  (%prim? "obj(vectorref(obj_from_$arg, fixnum_from_$arg))" v i))

(define-inline (vector-set! v i x)
  (%prim! "void(vectorref(obj_from_$arg, fixnum_from_$arg) = obj_from_$arg)" v i x))

(define (subvector-copy! to at from start end)
  (let ([limit (fxmin end (fx+ start (fx- (vector-length to) at)))])
    (if (fx<=? at start)
        (do ([i at (fx+ i 1)] [j start (fx+ j 1)]) 
          [(fx>=? j limit)]
          (vector-set! to i (vector-ref from j)))
        (do ([i (fx+ at (fx- end start 1)) (fx- i 1)] [j (fx- limit 1) (fx- j 1)])
          [(fx<? j start)]
          (vector-set! to i (vector-ref from j))))))

(define (subvector vec start end)
  (let ([v (make-vector (fx- end start))])
    (subvector-copy! v 0 vec start end)
    v))

(define (subvector-fill! vec x start end)
  (do ([i start (fx+ i 1)]) [(fx>=? i end)] (vector-set! vec i x)))


; bytevectors

#read #u8<list> as (%const bytevector <list>)

(define-syntax %const
  (let-syntax ([old-%const %const])
    (syntax-rules (bytevector)
      [(_ bytevector (x ...)) (bytevector x ...)] 
      [(_ arg ...) (old-%const arg ...)])))  

(define-inline (byte? x)
  (%prim "bool(is_byte_obj(obj_from_$arg))" x))

(define-inline (bytevector? x)
  (%prim "bool(isbytevector(obj_from_$arg))" x))

(define-syntax make-bytevector
  (syntax-rules ()
    [(_ k) (%prim* "obj(hpushu8v($live, allocbytevector(fixnum_from_$arg)))" k)]
    [(_ k c) (%prim* "obj(hpushu8v($live, makebytevector(fixnum_from_$arg, byte_from_fixnum(fixnum_from_$arg))))" k c)]
    [_ %residual-make-bytevector]))

(define-syntax bytevector
  (syntax-rules ()
    [(_ b ...)
     (%prim* "{ /* bytevector */
    obj o = hpushu8v($live, allocbytevector($argc));
    unsigned char *s = bytevectorbytes(o);
    ${*s++ = byte_from_fixnum(fixnum_from_$arg);
    $}$return obj(o); }" b ...)]
    [_ %residual-bytevector]))

(define-inline (bytevector-length bv)
  (%prim "fixnum(bytevectorlen(obj_from_$arg))" bv))

(define-inline (bytevector-u8-ref bv k)
  (%prim? "fixnum(*bytevectorref(obj_from_$arg, fixnum_from_$arg))" bv k))

(define-inline (bytevector-u8-set! bv k b)
  (%prim! "void(*bytevectorref(obj_from_$arg, fixnum_from_$arg) = byte_from_fixnum(fixnum_from_$arg))" bv k b))

(define-inline (bytevector=? x y)
  (%prim? "bool(bytevectoreq(bytevectordata(obj_from_$arg), bytevectordata(obj_from_$arg)))" x y))

(define (subbytevector-copy! to at from start end)
  (let ([limit (fxmin end (fx+ start (fx- (bytevector-length to) at)))])
    (if (fx<=? at start)
        (do ([i at (fx+ i 1)] [j start (fx+ j 1)]) 
          [(fx>=? j limit)]
          (bytevector-u8-set! to i (bytevector-u8-ref from j)))
        (do ([i (fx+ at (fx- end start 1)) (fx- i 1)] [j (fx- limit 1) (fx- j 1)])
          [(fx<? j start)]
          (bytevector-u8-set! to i (bytevector-u8-ref from j))))))

(define-inline (subbytevector bv start end)
  (%prim*? "{ /* subbytevector */
    int *d = subbytevector(bytevectordata(obj_from_$arg), fixnum_from_$arg, fixnum_from_$arg);
    $return obj(hpushu8v($live, d)); }" bv start end))


; boxes

(define-inline (box? o)
  (%prim "bool(isbox(obj_from_$arg))" o))

(define-inline (box o) 
  (%prim* "{ /* box */ 
    hreserve(hbsz(2), $live); /* $live live regs */
    *--hp = obj_from_$arg;
    *--hp = obj_from_size(BOX_BTAG); 
    $return obj(hendblk(2)); }" o))

(define-syntax %const
  (let-syntax ([old-%const %const])
    (syntax-rules (box)
      [(_ box x) (box x)] 
      [(_ arg ...) (old-%const arg ...)]))) 

(define-inline (unbox b)
  (%prim? "obj(boxref(obj_from_$arg))" b))

(define-inline (set-box! b o)
  (%prim! "void(boxref(obj_from_$arg) = obj_from_$arg)" b o))



; null

(define-syntax %const
  (let-syntax ([old-%const %const])
    (syntax-rules (null)
      [(_ null) (%prim "obj(mknull())")] 
      [(_ arg ...) (old-%const arg ...)]))) 

(define-inline (null? x)
  (%prim "bool(isnull(obj_from_$arg))" x))


; pairs and lists

(define-inline (pair? o)
  (%prim "bool(ispair(obj_from_$arg))" o))

(define-inline (atom? o)
  (%prim "bool(!ispair(obj_from_$arg))" o))

(define-inline (list? o)
  (%prim? "bool(islist(obj_from_$arg))" o))

(define-inline (cons a d) 
  (%prim* "{ /* cons */ 
    hreserve(hbsz(3), $live); /* $live live regs */
    *--hp = obj_from_$arg;
    *--hp = obj_from_$arg;
    *--hp = obj_from_size(PAIR_BTAG); 
    $return obj(hendblk(3)); }" d a))

(define-syntax %const
  (let-syntax ([old-%const %const])
    (syntax-rules (pair list)
      [(_ pair x y) (cons x y)] 
      [(_ list x ...) (list x ...)] 
      [(_ arg ...) (old-%const arg ...)]))) 

(define-inline (car p)
  (%prim? "obj(car(obj_from_$arg))" p))

(define-inline (set-car! p a)
  (%prim! "void(car(obj_from_$arg) = obj_from_$arg)" p a))

(define-inline (cdr p)
  (%prim? "obj(cdr(obj_from_$arg))" p))

(define-inline (set-cdr! p d)
  (%prim! "void(cdr(obj_from_$arg) = obj_from_$arg)" p d))

(define-syntax c?r
  (syntax-rules (a d)
    [(c?r x) x]
    [(c?r a ? ... x) (car (c?r ? ... x))]
    [(c?r d ? ... x) (cdr (c?r ? ... x))]))

(define-inline (caar x) (c?r a a x))
(define-inline (cadr x) (c?r a d x))
(define-inline (cdar x) (c?r d a x))
(define-inline (cddr x) (c?r d d x))
(define-inline (caaar x) (c?r a a a x))
(define-inline (caadr x) (c?r a a d x))
(define-inline (cadar x) (c?r a d a x))
(define-inline (caddr x) (c?r a d d x))
(define-inline (cdaar x) (c?r d a a x))
(define-inline (cdadr x) (c?r d a d x))
(define-inline (cddar x) (c?r d d a x))
(define-inline (cdddr x) (c?r d d d x))
(define-inline (caaaar x) (c?r a a a a x))
(define-inline (caaadr x) (c?r a a a d x))
(define-inline (caadar x) (c?r a a d a x))
(define-inline (caaddr x) (c?r a a d d x))
(define-inline (cadaar x) (c?r a d a a x))
(define-inline (cadadr x) (c?r a d a d x))
(define-inline (caddar x) (c?r a d d a x))
(define-inline (cadddr x) (c?r a d d d x))
(define-inline (cdaaar x) (c?r d a a a x))
(define-inline (cdaadr x) (c?r d a a d x))
(define-inline (cdadar x) (c?r d a d a x))
(define-inline (cdaddr x) (c?r d a d d x))
(define-inline (cddaar x) (c?r d d a a x))
(define-inline (cddadr x) (c?r d d a d x))
(define-inline (cdddar x) (c?r d d d a x))
(define-inline (cddddr x) (c?r d d d d x))

(define (%make-list n i)
  (let loop ([n n] [l '()])
    (if (<= n 0) l (loop (- n 1) (cons i l))))) 

(define-syntax make-list
  (syntax-rules ()
    [(_ n) (%make-list n (void))]
    [(_ n i) (%make-list n i)]
    [_ %residual-make-list]))

(define-syntax list
  (syntax-rules ()
    [(_) '()]
    [(_ x . more) (cons x (list . more))]
    [_ %residual-list]))

(define-syntax cons*
  (syntax-rules ()
    [(_ i ... j)
     (%prim*/rev "{ /* cons* */
    obj p;
    hreserve(hbsz(3)*$argc, $live); /* $live live regs */
    p = obj_from_$arg; /* gc-safe */
    ${*--hp = p; *--hp = obj_from_$arg;
    *--hp = obj_from_size(PAIR_BTAG); p = hendblk(3);
    $}$return obj(p); }" i ... j)]
    [_ %residual-cons*]))

(define-syntax list* cons*)

(define-inline (length l)
  (%prim? "{ /* length */
    int n; obj l = obj_from_$arg;
    for (n = 0; l != mknull(); ++n, l = cdr(l)) ;
    $return fixnum(n); }" l)) 

(define-inline (reverse l)
  (%prim*? "{ /* reverse */
    obj l, o = mknull(); int c = fixnum_from_$arg;
    hreserve(hbsz(3)*c, $live); /* $live live regs */
    l = obj_from_$arg; /* gc-safe */
    for (; l != mknull(); l = cdr(l)) { *--hp = o; *--hp = car(l);
    *--hp = obj_from_size(PAIR_BTAG); o = hendblk(3); }  
    $return obj(o); }" (length l) l))

(define-inline (reverse! l)
  (%prim?! "{ /* reverse! */
    obj t, v = mknull(), l = obj_from_$arg;
    while (l != mknull()) t = cdr(l), cdr(l) = v, v = l, l = t;
    $return obj(v); }" l))

(define (%append l o)
  (%prim*? "{ /* append */
    obj t, l, o, *p, *d; int c = fixnum_from_$arg;
    hreserve(hbsz(3)*c, $live); /* $live live regs */
    l = obj_from_$arg; t = obj_from_$arg; /* gc-safe */
    o = t; p = &o; 
    for (; l != mknull(); l = cdr(l)) {
    *--hp = t; d = hp; *--hp = car(l);
    *--hp = obj_from_size(PAIR_BTAG); 
    *p = hendblk(3); p = d; }  
    $return obj(o); }" (length l) l o))

(define-syntax append
  (syntax-rules ()
    [(_) '()] [(_ x) x]
    [(_ x y) (%append x y)]
    [(_ x y z ...) (%append x (append y z ...))]
    [_ %residual-append]))

(define (list-copy obj)
  (if (pair? obj)
      (cons (car obj) (list-copy (cdr obj)))
      obj))

(define-inline (list-ref l n)
  (%prim? "{ /* list-ref */
    obj l = obj_from_$arg; int c = fixnum_from_$arg;
    while (c-- > 0) l = cdr(l);
    $return obj(car(l)); }" l n)) 

(define-inline (list-tail l n)
  (%prim? "{ /* list-tail */
    obj l = obj_from_$arg; int c = fixnum_from_$arg;
    while (c-- > 0) l = cdr(l);
    $return obj(l); }" l n)) 

(define-inline (list-set! l n obj)
  (set-car! (list-tail list n) obj)) 

(define-inline (last-pair l)
  (%prim? "{ /* last-pair */
    obj l = obj_from_$arg, p;
    for (p = cdr(l); ispair(p); p = cdr(p)) l = p;
    $return obj(l); }" l)) 

(define-syntax map
  (syntax-rules ()
    [(_ fun lst)
     (let ([f fun]) 
       (let loop ([l lst]) 
         (if (pair? l) (cons (f (car l)) (loop (cdr l))) '())))]
    [(_ fun lst . l*) (%residual-map fun lst . l*)]
    [_ %residual-map])) 

(define-syntax for-each
  (syntax-rules ()
    [(_ fun lst)
     (let ([f fun]) 
       (let loop ([l lst]) 
         (if (pair? l) (begin (f (car l)) (loop (cdr l))))))]
    [(_ fun lst . l*) (%residual-for-each fun lst . l*)]
    [_ %residual-for-each]))



; symbols

(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 (fx<? i start) l (loop (fx- i 1) (cons (vector-ref vec i) l)))))

(define (list->vector l)
  (%prim*? "{ /* list->vector */
    obj l; int i, c = fixnum_from_$arg;
    hreserve(hbsz(c+1), $live); /* $live live regs */
    l = obj_from_$arg; /* gc-safe */
    for (i = 0; i < c; ++i, l = cdr(l)) hp[i-c] = car(l);
    hp -= c; *--hp = obj_from_size(VECTOR_BTAG);
    $return obj(hendblk(c+1)); }" (length l) l))

(define (list->string l)
  (%prim*? "{ /* list->string */
    int i, c = fixnum_from_$arg; 
    obj o = hpushstr($live, allocstring(c, ' ')); /* $live live regs */
    obj l = obj_from_$arg; /* gc-safe */
    unsigned char *s = (unsigned char *)stringchars(o);
    for (i = 0; i < c; ++i, l = cdr(l)) s[i] = (unsigned char)char_from_obj(car(l));
    $return obj(o); }" (length l) l))

(define (substring->list str start end)
  (let loop ([i (fx- end 1)] [l '()])
    (if (fx<? i start) l (loop (fx- i 1) (cons (string-ref str i) l)))))

(define (%subvector-string-copy! to at from start end)
  (let ([limit (fxmin end (fx+ start (fx- (string-length to) at)))])
    (do ([i at (fx+ i 1)] [j start (fx+ j 1)]) 
      [(fx>=? j limit) to]
      (string-set! to i (vector-ref from j)))))

(define (subvector->string vec start end)
  (%subvector-string-copy! (make-string (fx- end start)) 0 vec start end))

(define (%substring-vector-copy! to at from start end)
  (let ([limit (fxmin end (fx+ start (fx- (vector-length to) at)))])
    (do ([i at (fx+ i 1)] [j start (fx+ j 1)]) 
      [(fx>=? j limit) to]
      (vector-set! to i (string-ref from j)))))

(define (substring->vector str start end)
  (%substring-vector-copy! (make-vector (fx- end start)) 0 str start end))

(define (list->bytevector l)
  (%prim*? "{ /* list->bytevector */
    int i, c = fixnum_from_$arg; 
    obj o = hpushu8v($live, allocbytevector(c)); /* $live live regs */
    obj l = obj_from_$arg; /* gc-safe */
    unsigned char *s = bytevectorbytes(o);
    for (i = 0; i < c; ++i, l = cdr(l)) s[i] = byte_from_obj(car(l));
    $return obj(o); }" (length l) l))

(define (subbytevector->list vec start end)
  (let loop ([i (fx- end 1)] [l '()])
    (if (fx<? i start) l (loop (fx- i 1) (cons (bytevector-u8-ref vec i) l)))))



; control

; closure procedures are heap blocks of length >= 1 which
; have a pointer to the static code entry as 0th element;
; sfc allocates env-less global procedures in static memory,
; so procedure? answers #t to any nonzero out-of-heap pointer

(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, \"#<procedure @%p>\", objptr_from_obj(obj_from_$arg));
    $return void(oportputs(buf, obj_from_$arg)); }" x p)]
    [_ %residual-display-procedure]))

(define-syntax display-input-port
  (syntax-rules ()
    [(_ x) (display-input-port x (current-output-port))]
    [(_ x p) (%prim?! "{ /* display-input-port */
    char buf[60]; sprintf(buf, \"#<%s>\", ckiportvt(obj_from_$arg)->tname);
    $return void(oportputs(buf, obj_from_$arg)); }" x p)]
    [_ %residual-display-input-port]))

(define-syntax display-output-port
  (syntax-rules ()
    [(_ x) (display-output-port x (current-output-port))]
    [(_ x p) (%prim?! "{ /* display-output-port */
    char buf[60]; sprintf(buf, \"#<%s>\", ckoportvt(obj_from_$arg)->tname);
    $return void(oportputs(buf, obj_from_$arg)); }" x p)]
    [_ %residual-display-output-port]))

; simple binary i/o

(define-syntax read-u8
  (syntax-rules ()
    [(_) (read-u8 (current-input-port))]
    [(_ p) (%prim?! "{ int c = iportgetc(obj_from_$arg);  $return obj(c == EOF ? mkeof() : obj_from_fixnum(c & 0xff)); }" p)]
    [_ %residual-read-u8]))

(define-syntax peek-u8
  (syntax-rules ()
    [(_) (peek-u8 (current-input-port))]
    [(_ p) (%prim?! "{ int c = iportpeekc(obj_from_$arg);  $return obj(c == EOF ? mkeof() : obj_from_fixnum(c & 0xff)); }" p)]
    [_ %residual-peek-char]))

(define-syntax u8-ready?
  (syntax-rules ()
    [(_) (u8-ready? (current-input-port))]
    [(_ p) #t] ; no better solution for FILE/STRING ports
    [_ %residual-u8-ready?]))

(define (read-subbytevector! vec start end p)
  (let loop ([i start])
    (if (fx>=? i end)
        (fx- i start)
        (let ([u8 (read-u8 p)])
          (cond [(eof-object? u8) (if (fx=? i start) u8 (fx- i start))]
                [else (bytevector-u8-set! vec i u8) (loop (fx+ i 1))])))))

(define (read-subbytevector k p)
  (let ([vec (make-bytevector k)])
    (let ([r (read-subbytevector! vec 0 k p)])
      (if (eof-object? r)
          r
          (if (fx=? r k) vec (subbytevector vec 0 r))))))

(define-syntax write-u8
  (syntax-rules ()
    [(_ c) (write-u8 c (current-output-port))]
    [(_ c p) (%prim?! "void(oportputc(fixnum_from_$arg, obj_from_$arg))" c p)]
    [_ %residual-write-u8]))

(define (write-subbytevector from start end p)
  (do ([i start (fx+ i 1)]) [(fx>=? i end)] (write-u8 (bytevector-u8-ref from i) p)))

(define-syntax write-bytevector
  (syntax-rules ()
    [(_ bv) (write-bytevector bv (current-output-port))]
    [(_ bv p) (%prim?! "{ /* write-bytevector */
    int *d = bytevectordata(obj_from_$arg);
    $return void(oportwrite((char *)bvdatabytes(d), *d,  obj_from_$arg)); }" bv p)]
    [(_ bv p start) (let ([vec bv]) (write-subbytevector vec start (bytevector-length vec) p))]
    [(_ bv p start end) (write-subbytevector bv start end p)]
    [_ %residual-write-bytevector]))


; circularity

(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 `<datum> as (quasiquote <datum>)
#read ,<datum> as (unquote <datum>)
#read ,@<datum> as (unquote-splicing <datum>)

(define-syntax quasiquote ; from eiod
  (syntax-rules (unquote unquote-splicing quasiquote)
    [(_ (unquote x)) x]
    [(_ ((unquote-splicing x))) x] ;esl: allow `(,@improper-list)
    [(_ ((unquote-splicing x) . y)) (append x (quasiquote y))]
    [(_ (quasiquote x) . d) (cons 'quasiquote (quasiquote (x) d))]
    [(_ (unquote x) d) (cons 'unquote (quasiquote (x) . d))]
    [(_ (unquote-splicing x) d) (cons 'unquote-splicing (quasiquote (x) . d))]
    [(_ (x . y) . d) (cons (quasiquote x . d) (quasiquote y . d))]
    [(_ #(x ...) . d) (list->vector (quasiquote (x ...) . d))]
    [(_ x . d) 'x]))


; S-expression writer

(define-syntax write-simple
  (syntax-rules ()
    [(_ x) (%prim?! "void(oportputsimple(obj_from_$arg, obj_from_$arg, 0))" x (current-output-port))]
    [(_ x p) (%prim?! "void(oportputsimple(obj_from_$arg, obj_from_$arg, 0))" x p)]
    [_ %residual-write-simple]))

(define-syntax write-shared
  (syntax-rules ()
    [(_ x) (%prim?! "void(oportputshared(obj_from_$arg, obj_from_$arg, 0))" x (current-output-port))]
    [(_ x p) (%prim?! "void(oportputshared(obj_from_$arg, obj_from_$arg, 0))" x p)]
    [_ %residual-write-shared]))

(define-syntax write
  (syntax-rules ()
    [(_ x) (%prim?! "void(oportputcircular(obj_from_$arg, obj_from_$arg, 0))" x (current-output-port))]
    [(_ x p) (%prim?! "void(oportputcircular(obj_from_$arg, obj_from_$arg, 0))" x p)]
    [_ %residual-write]))

(define-syntax display
  (syntax-rules ()
    [(_ x) (%prim?! "void(oportputcircular(obj_from_$arg, obj_from_$arg, 1))" x (current-output-port))]
    [(_ x p) (%prim?! "void(oportputcircular(obj_from_$arg, obj_from_$arg, 1))" x p)]
    [_ %residual-display]))



; simple errors

(define (print-error-message prefix args ep)
  (define (pr-where args ep)
    (when (pair? args) 
      (cond [(not (car args)) 
             (write-string ": " ep)
             (pr-msg (cdr args) ep)]
            [(symbol? (car args)) 
             (write-string " in " ep) (write (car args) ep) (write-string ": " ep)
             (pr-msg (cdr args) ep)]
            [else 
             (write-string ": " ep)
             (pr-msg args ep)]))) 
  (define (pr-msg args ep)
    (when (pair? args) 
      (cond [(string? (car args))
             (display (car args) ep)
             (pr-rest (cdr args) ep)]
            [else (pr-rest args ep)])))
   (define (pr-rest args ep)
     (when (pair? args)
       (write-char #\space ep) (write (car args) ep)
       (pr-rest (cdr args) ep)))
   (cond [(or (string? prefix) (symbol? prefix)) 
          (write-string prefix ep)]
         [else (write-string "Error" ep)])
   (pr-where args ep)
   (newline ep))

(define (simple-error . args)
  (let ([ep (current-error-port)])
    (newline ep)
    (print-error-message "Error" args ep)
    (reset)))

(define (assertion-violation . args)
  (let ([ep (current-error-port)])
    (newline ep)
    (print-error-message "Assertion violation" args ep)
    (%prim! "{ assert(0); exit(1); $return void(0); }")))


; S-expression reader

(define (%read port simple?)

  (define-syntax r-error
    (syntax-rules () [(_ p msg a ...) (read-error msg a ... 'port: p)])) ; see read-error below

  (define shared '())
  (define (make-shared-ref loc) (lambda () (unbox loc)))
  (define (shared-ref? form) (procedure? form))
  (define (patch-ref! form) (if (procedure? form) (patch-ref! (form)) form))
  (define (patch-shared! form)
    (cond [(pair? form)
           (if (procedure? (car form)) 
               (set-car! form (patch-ref! (car form)))
               (patch-shared! (car form)))
           (if (procedure? (cdr form)) 
               (set-cdr! form (patch-ref! (cdr form)))
               (patch-shared! (cdr form)))]
          [(vector? form)
           (let loop ([i 0])
             (when (fx<? i (vector-length form))
               (let ([fi (vector-ref form i)])
                 (if (procedure? fi) 
                     (vector-set! form i (patch-ref! fi))
                     (patch-shared! fi)))
               (loop (fx+ i 1))))]
          [(box? form)
           (if (procedure? (unbox form))
               (set-box! form (patch-shared! (unbox form)))
               (patch-shared! (unbox form)))]))
  (define (patch-shared form) (patch-shared! form) form)           

  (define reader-token-marker #f)
  (define close-paren #f)
  (define close-bracket #f)
  (define dot #f)
  (define (let ([rtm (list 'reader-token)])
            (set! reader-token-marker rtm)
            (set! close-paren (cons rtm "right parenthesis"))
            (set! close-bracket (cons rtm "right bracket"))
            (set! dot (cons rtm "\" . \""))))

  (define (reader-token? form)
    (and (pair? form) (eq? (car form) reader-token-marker)))

  (define (char-symbolic? c)
    (string-position c
      "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!$%&*/:<=>?^_~0123456789+-.@"))

  (define (char-hex-digit? c)
    (let ([scalar-value (char->integer c)])
      (or (and (>= scalar-value 48) (<= scalar-value 57))
          (and (>= scalar-value 65) (<= scalar-value 70))
          (and (>= scalar-value 97) (<= scalar-value 102)))))

  (define (char-delimiter? c)
    (or (char-whitespace? c)
        (char=? c #\)) (char=? c #\()
        (char=? c #\]) (char=? c #\[)
        (char=? c #\") (char=? c #\;)))

  (define (sub-read-carefully p)
    (let ([form (sub-read p)])
      (cond [(eof-object? form)
             (r-error p "unexpected end of file")]
            [(reader-token? form) 
             (r-error p "unexpected token:" (cdr form))]
            [else form])))

  (define (sub-read p)
    (let ([c (read-char p)])
      (cond [(eof-object? c) c]
            [(char-whitespace? c) (sub-read p)]
            [(char=? c #\() (sub-read-list c p close-paren #t)]
            [(char=? c #\)) close-paren]
            [(char=? c #\[) (sub-read-list c p close-bracket #t)]
            [(char=? c #\]) close-bracket]
            [(char=? c #\') (list 'quote (sub-read-carefully p))]
            [(char=? c #\`) (list 'quasiquote (sub-read-carefully p))]
            [(char-symbolic? c) (sub-read-number-or-symbol c p)]
            [(char=? c #\;)
             (let loop ([c (read-char p)])
               (or (eof-object? c) (char=? c #\newline)
                   (loop (read-char p))))
             (sub-read p)]
            [(char=? c #\,)
             (let ([next (peek-char p)])
               (cond [(eof-object? next)
                      (r-error p "end of file after ,")]
                     [(char=? next #\@)
                      (read-char p)
                      (list 'unquote-splicing (sub-read-carefully p))]
                     [else (list 'unquote (sub-read-carefully p))]))]
            [(char=? c #\")
             (let loop ([l '()])
               (let ([c (read-char p)])
                 (cond [(eof-object? c)
                        (r-error p "end of file within a string")]
                       [(char=? c #\\)
                        (let ([e (sub-read-strsym-char-escape p 'string)])
                          (loop (if e (cons e l) l)))]
                       [(char=? c #\") (list->string (reverse! l))]
                       [else (loop (cons c l))])))]
            [(char=? c #\|)
             (let loop ([l '()])
               (let ([c (read-char p)])
                 (cond [(eof-object? c)
                        (r-error p "end of file within a |symbol|")]
                       [(char=? c #\\)
                        (let ([e (sub-read-strsym-char-escape p 'symbol)])
                          (loop (if e (cons e l) l)))]
                       [(char=? c #\|) (string->symbol (list->string (reverse! l)))]
                       [else (loop (cons c l))])))]
            [(char=? c #\#)
             (let ([c (peek-char p)])
               (cond [(eof-object? c) (r-error p "end of file after #")]
                     [(or (char-ci=? c #\t) (char-ci=? c #\f))
                      (let ([name (sub-read-carefully p)])
                        (case name [(t true) #t] [(f false) #f]
                          [else (r-error p "unexpected name after #" name)]))]
                     [(or (char-ci=? c #\b) (char-ci=? c #\o)
                          (char-ci=? c #\d) (char-ci=? c #\x)
                          (char-ci=? c #\i) (char-ci=? c #\e))
                      (sub-read-number-or-symbol #\# p)]
                     [(char=? c #\&)
                      (read-char p)
                      (box (sub-read-carefully p))]
                     [(char=? c #\;)
                      (read-char p)
                      (sub-read-carefully p) 
                      (sub-read p)]
                     [(char=? c #\|)
                      (read-char p)
                      (let recur () ;starts right after opening #|
                        (let ([next (read-char p)])
                          (cond
                            [(eof-object? next)
                             (r-error p "end of file in #| comment")]
                            [(char=? next #\|)
                             (let ([next (peek-char p)])
                               (cond
                                 [(eof-object? next)
                                  (r-error p "end of file in #| comment")]
                                 [(char=? next #\#) (read-char p)]
                                 [else (recur)]))]
                            [(char=? next #\#)
                             (let ([next (peek-char p)])
                               (cond
                                 [(eof-object? next)
                                  (r-error p "end of file in #| comment")]
                                 [(char=? next #\|) (read-char p) (recur) (recur)]
                                 [else (recur)]))]
                            [else (recur)])))
                      (sub-read p)]
                     [(char=? c #\() ;)
                      (read-char p)
                      (list->vector (sub-read-list c p close-paren #f))]
                     [(char=? c #\u)
                      (read-char p)
                      (if (and (eq? (read-char p) #\8) (eq? (read-char p) #\())
                          (list->bytevector (sub-read-byte-list p))
                          (r-error p "invalid bytevector syntax"))]
                     [(char=? c #\\)
                      (read-char p)
                      (let ([c (peek-char p)])
                        (cond
                          [(eof-object? c)
                           (r-error p "end of file after #\\")]
                          [(char=? #\x c)
                           (read-char p)
                           (if (char-delimiter? (peek-char p))
                               c
                               (sub-read-x-char-escape p #f))]
                          [(char-alphabetic? c)
                           (let ([name (sub-read-carefully p)])
                             (if (= (string-length (symbol->string name)) 1)
                                 c
                                 (case name
                                   [(null) (integer->char #x00)]
                                   [(space) #\space]
                                   [(alarm) #\alarm]
                                   [(backspace) #\backspace]
                                   [(delete) (integer->char #x7F)] ; todo: support by SFC
                                   [(escape) (integer->char #x1B)]
                                   [(tab) #\tab]
                                   [(newline linefeed) #\newline]
                                   [(vtab) #\vtab]
                                   [(page) #\page]
                                   [(return) #\return]
                                   [else (r-error p "unknown #\\ name" name)])))]
                          [else (read-char p) c]))]
                     [(char-numeric? c)
                      (when simple? (r-error p "#N=/#N# notation is not allowed in this mode")) 
                      (let loop ([l '()])
                        (let ([c (read-char p)])
                          (cond [(eof-object? c)
                                 (r-error p "end of file within a #N notation")]
                                [(char-numeric? c)
                                 (loop (cons c l))]
                                [(char=? c #\#) 
                                 (let* ([s (list->string (reverse! l))] [n (string->number s)])
                                   (cond [(and (fixnum? n) (assq n shared)) => cdr]
                                         [else (r-error "unknown #n# reference:" s)]))]   
                                [(char=? c #\=) 
                                 (let* ([s (list->string (reverse! l))] [n (string->number s)])
                                   (cond [(not (fixnum? n)) (r-error "invalid #n= reference:" s)]
                                         [(assq n shared) (r-error "duplicate #n= tag:" n)])
                                   (let ([loc (box #f)])
                                     (set! shared (cons (cons n (make-shared-ref loc)) shared))
                                     (let ([form (sub-read-carefully p)])
                                       (cond [(shared-ref? form) (r-error "#n= has another label as target" s)]
                                             [else (set-box! loc form) form]))))]
                                [else (r-error p "invalid terminator for #N notation")])))]
                     [else (r-error p "unknown # syntax" c)]))]
            [else (r-error p "illegal character read" c)])))

  (define (sub-read-list c p close-token dot?)
    (let ([form (sub-read p)])
      (if (eq? form dot)
          (r-error p "missing car -- ( immediately followed by .") ;)
          (let recur ([form form])
            (cond [(eof-object? form)
                   (r-error p "eof inside list -- unbalanced parentheses")]
                  [(eq? form close-token) '()]
                  [(eq? form dot)
                   (if dot?
                       (let* ([last-form (sub-read-carefully p)]
                              [another-form (sub-read p)])
                         (if (eq? another-form close-token)
                             last-form
                             (r-error p "randomness after form after dot" another-form)))
                       (r-error p "dot in #(...)"))]
                  [(reader-token? form)
                   (r-error p "error inside list --" (cdr form))]
                  [else (cons form (recur (sub-read p)))])))))

  (define (sub-read-byte-list p)
    (let recur ([form (sub-read p)])
      (cond [(eof-object? form)
              (r-error p "eof inside bytevector")]
            [(eq? form close-paren) '()]
            [(reader-token? form)
              (r-error p "error inside bytevector --" (cdr form))]
            [(or (not (fixnum? form)) (fx<? form 0) (fx>? form 255))
              (r-error p "invalid byte inside bytevector --" form)]
            [else (cons form (recur (sub-read p)))])))

  (define (sub-read-strsym-char-escape p what)
    (let ([c (read-char p)])
      (if (eof-object? c)
          (r-error p "end of file within a" what))
      (cond [(or (char=? c #\\) (char=? c #\") (char=? c #\|)) c]
            [(char=? c #\a) #\alarm]
            [(char=? c #\b) #\backspace]
            [(char=? c #\t) #\tab]
            [(char=? c #\n) #\newline]
            [(char=? c #\v) #\vtab]
            [(char=? c #\f) #\page]
            [(char=? c #\r) #\return]
            [(char=? c #\x) (sub-read-x-char-escape p #t)]
            [(and (eq? what 'string) (char-whitespace? c))
             (let loop ([gotnl (char=? c #\newline)] [nc (peek-char p)])
               (cond [(or (eof-object? nc) (not (char-whitespace? nc)))
                      (if gotnl #f (r-error p "no newline in line ending escape"))]
                     [(and gotnl (char=? nc #\newline)) #f]
                     [else (read-char p) (loop (or gotnl (char=? nc #\newline)) (peek-char p))]))]
            [else (r-error p "invalid char escape in" what ': c)])))

  (define (sub-read-x-char-escape p in-string?)
    (define (rev-digits->char l)
      (if (null? l)
          (r-error p "\\x escape sequence is too short")
          (integer->char (string->fixnum (list->string (reverse! l)) 16))))
    (let loop ([c (peek-char p)] [l '()] [cc 0])
      (cond [(eof-object? c)
             (if in-string?
               (r-error p "end of file within a string")
               (rev-digits->char l))]
            [(and in-string? (char=? c #\;))
             (read-char p)
             (rev-digits->char l)]
            [(and (not in-string?) (char-delimiter? c))
             (rev-digits->char l)]
            [(not (char-hex-digit? c))
             (r-error p "unexpected char in \\x escape sequence" c)]
            [(> cc 2)
             (r-error p "\\x escape sequence is too long")]
            [else
             (read-char p)
             (loop (peek-char p) (cons c l) (+ cc 1))])))

  (define (suspect-number-or-symbol-peculiar? hash? c l s)
    (cond [(or hash? (char-numeric? c)) #f]
          [(or (string-ci=? s "+i") (string-ci=? s "-i")) #f]
          [(or (string-ci=? s "+nan.0") (string-ci=? s "-nan.0")) #f]
          [(or (string-ci=? s "+inf.0") (string-ci=? s "-inf.0")) #f]
          [(or (char=? c #\+) (char=? c #\-))
           (cond [(null? (cdr l)) #t]
                 [(char=? (cadr l) #\.) (and (pair? (cddr l)) (not (char-numeric? (caddr l))))]
                 [else (not (char-numeric? (cadr l)))])]
          [else (and (char=? c #\.) (pair? (cdr l)) (not (char-numeric? (cadr l))))]))

  (define (sub-read-number-or-symbol c p)
    (let loop ([c (peek-char p)] [l (list c)] [hash? (char=? c #\#)])
      (cond [(or (eof-object? c) (char-delimiter? c))
             (let* ([l (reverse! l)] [c (car l)] [s (list->string l)])
               (if (or hash? (char-numeric? c) 
                     (char=? c #\+) (char=? c #\-) (char=? c #\.))   
                   (cond [(string=? s ".") dot]
                         [(suspect-number-or-symbol-peculiar? hash? c l s) (string->symbol s)]
                         [(string->number s)]
                         [else (r-error p "unsupported number syntax (implementation restriction)" s)])
                   (string->symbol s)))]
            [(char=? c #\#)
             (read-char p) 
             (loop (peek-char p) (cons c l) #t)]
            [(char-symbolic? c)
             (read-char p) 
             (loop (peek-char p) (cons c l) hash?)]
            [else (r-error p "unexpected number/symbol char" c)])))
            
  ; body of %read
  (let ([form (sub-read port)])
    (if (not (reader-token? form))
        (if (null? shared) form (patch-shared form))
        (r-error port "unexpected token:" (cdr form)))))

(define-syntax read
  (syntax-rules ()
    [(_) (%read (current-input-port) #f)]
    [(_ p) (%read p #f)]
    [_ %residual-read]))

(define-syntax read-simple
  (syntax-rules ()
    [(_) (%read (current-input-port) #t)]
    [(_ p) (%read p #t)]
    [_ %residual-read-simple]))


; file system

(define (file-exists? fn) ; fixme?
  (%prim?! "{ /* file-exists? */ 
    FILE *f = fopen(stringchars(obj_from_$arg), \"r\");
    if (f != NULL) fclose(f);
    $return bool(f != NULL); }" fn))

(define (delete-file fn)
  (unless (%prim?! "{ /* delete-file */ 
    int res = remove(stringchars(obj_from_$arg));
    $return bool(res == 0); }" fn)
    (file-error "cannot delete file:" fn)))

(define (rename-file fnold fnnew) ; not in r7rs
  (unless (%prim?! "{ /* rename-file */ 
    int res = rename(stringchars(obj_from_$arg), stringchars(obj_from_$arg));
    $return bool(res == 0); }" fnold fnnew)
    (file-error "cannot rename file:" fnold fnnew)))



; multiple values & continuations

(define-inline (call-with-values producer consumer)
  (letcc k
    (withcc 
      (lambda results
        (withcc k (apply consumer results)))
      (producer))))

(define *current-dynamic-state* (list #f))

(define (call-with-current-continuation proc)
  (let ([here *current-dynamic-state*])
    (letcc cont
      (proc 
        (lambda results
           (dynamic-state-reroot! here)
           (apply cont results))))))

(define-syntax call/cc call-with-current-continuation)

(define-syntax throw
  (syntax-rules ()
    [(_ k expr ...) 
     (withcc (%prim "ktrap()") (k expr ...))]))

(define-syntax values
  (syntax-rules ()
    [(_ expr ...) 
     (call/cc (lambda (k) (throw k expr ...)))]
    [_ %residual-values]))

(define (dynamic-wind before during after)
  (let ([here *current-dynamic-state*])
    (dynamic-state-reroot! (cons (cons before after) here))
    (call-with-values during
      (lambda results
        (dynamic-state-reroot! here)
        (apply values results)))))

(define (dynamic-state-reroot! there)
  (if (not (eq? *current-dynamic-state* there))
      (begin (dynamic-state-reroot! (cdr there))
             (let ([before (caar there)] [after (cdar there)])
               (set-car! *current-dynamic-state* (cons after before))
               (set-cdr! *current-dynamic-state* there)
               (set-car! there #f)
               (set-cdr! there '())
               (set! *current-dynamic-state* there)
               (before)))))


; exceptions and errors

(define-record-type <error-object>
  (error-object kind message irritants)
  error-object?
  (kind error-object-kind)
  (message error-object-message)
  (irritants error-object-irritants))

(define (error msg . args)
  (raise (error-object #f msg args)))

(define current-exception-handler 
  (make-parameter
    (letrec 
      ([default-handler
        (case-lambda 
          [() default-handler] ;this one its own parent 
          [(obj) 
           (if (error-object? obj)
               (apply simple-error (error-object-kind obj) (error-object-message obj) (error-object-irritants obj)) 
               (simple-error #f "unhandled exception" obj))])])
      default-handler)))

(define (with-exception-handler handler thunk)
  (let ([eh (current-exception-handler)])
    (parameterize ([current-exception-handler (case-lambda [() eh] [(obj) (handler obj)])])
      (thunk)))) 

(define (raise obj)
  (let ([eh (current-exception-handler)])
    (parameterize ([current-exception-handler (eh)])
      (eh obj)
      (raise (error-object 'raise "exception handler returned" (list eh obj))))))

(define (raise-continuable obj)
  (let ([eh (current-exception-handler)])
    (parameterize ([current-exception-handler (eh)])
      (eh obj))))

(define-inline (abort) (%prim! "void(exit(1))"))
(define (reset) (%prim! "void(exit(1))"))
(define (set-reset-handler! fn) (set! reset fn))

(define-syntax guard
  (letrec-syntax
    ([guard-aux
      (syntax-rules (else =>)
        [(guard-aux reraise (else result1 result2 ...))
        (begin result1 result2 ...)]
        [(guard-aux reraise (test => result))
        (let ([temp test]) (if temp (result temp) reraise))]
        [(guard-aux reraise (test => result) clause1 clause2 ...)
        (let ([temp test])
          (if temp
              (result temp)
              (guard-aux reraise clause1 clause2 ...)))]
        [(guard-aux reraise (test)) (or test reraise)]
        [(guard-aux reraise (test) clause1 clause2 ...)
        (let ([temp test])
          (if temp temp (guard-aux reraise clause1 clause2 ...)))]
        [(guard-aux reraise (test result1 result2 ...))
        (if test (begin result1 result2 ...) reraise)]
        [(guard-aux reraise (test result1 result2 ...) clause1 clause2 ...)
        (if test
            (begin result1 result2 ...)
            (guard-aux reraise clause1 clause2 ...))])])
    (syntax-rules ()
      [(guard (var clause ...) e1 e2 ...)
      ((call/cc
        (lambda (guard-k)
          (with-exception-handler
            (lambda (condition)
              ((call/cc
                  (lambda (handler-k)
                    (guard-k
                      (lambda ()
                        (let ([var condition])
                          (guard-aux
                            (handler-k
                              (lambda ()
                                (raise-continuable condition)))
                            clause
                            ...))))))))
            (lambda ()
              (call-with-values
                (lambda () e1 e2 ...)
                (lambda args
                  (guard-k (lambda () (apply values args))))))))))])))


(define (read-error msg . args)
  (raise (error-object 'read msg args)))

(define (read-error? obj)
  (and (error-object? obj) (eq? (error-object-kind obj) 'read))) 

(define (file-error msg . args)
  (raise (error-object 'file msg args)))

(define (file-error? obj)
  (and (error-object? obj) (eq? (error-object-kind obj) 'file))) 


; time

(define-inline (current-jiffy)
  (%prim*! "flonum($live, clock())"))

(define-inline (jiffies-per-second)
  (%prim* "flonum($live, CLOCKS_PER_SEC)"))

(define-inline (current-second)
  (%prim* "flonum($live, difftime(time(NULL), 0)+37.0)"))


; miscellaneous / system

(define emergency-exit  
  (case-lambda ; exits no matter what
    [() (%prim! "void(exit(0))")]
    [(n) (cond [(eq? n #t) (%prim! "void(exit(0))")] 
               [(fixnum? n) (%prim! "void(exit(fixnum_from_$arg))" n)]
               [else (%prim! "void(exit(1))")])]
    [args (%prim! "void(exit(1))")]))

(define exit 
  (let ([exit-ds *current-dynamic-state*])
    (lambda args
      (dynamic-state-reroot! exit-ds)
      (apply emergency-exit args))))    

(define-inline (argv-ref argv i)
  (%prim* "{ /* argv-ref */
    int i = fixnum_from_$arg;
    char *s = ((char **)(obj_from_$arg))[i];
    if (s) $return obj(hpushstr($live, newstring(s)));
    else $return bool(0); }" i argv))

(define (command-line)
  (let loop ([r '()] [i (%prim "fixnum(0)")])
    (let ([arg (argv-ref (%prim "obj(cxg_argv)") i)])
      (if arg 
          (loop (cons arg r) (fx+ i (%prim "fixnum(1)")))
          (reverse! r)))))

(define-inline (get-environment-variable s)
  (%prim*? "{ /* get-environment-variable */
    char *v = getenv(stringchars(obj_from_$arg));
    if (v) $return obj(hpushstr($live, newstring(v)));
    else $return bool(0); }" s))

(define-inline (system cmd)
  (%prim?! "{ /* system */
    int res = system(stringchars(obj_from_$arg));
    $return fixnum(res); }" cmd))


;------------------------------------------------------------------------------

; stubs

(define-inline (make-rectangular r i)
  (if (= i 0) r (error 'make-rectangular "nonzero imag part not supported" i)))
(define-inline (make-polar m a)
  (cond [(= a 0) m]
        [(= a 3.141592653589793238462643) (- m)]
        [else (error 'make-polar "angle not supported" a)]))
(define-inline (real-part x) x)
(define-inline (imag-part x) 0)
(define-inline (magnitude x) (abs x))
(define-inline (angle x) (if (negative? x) 3.141592653589793238462643 0))


; procedures requiring call-with-values / values

(define (truncate/ x y)
  (values (truncate-quotient x y) (truncate-remainder x y)))

(define (floor/ x y)
  (values (floor-quotient x y) (floor-remainder x y)))

(define (exact-integer-sqrt x)
  (let ([r (fxsqrt x)])
    (values r (- x (* r r)))))

(define (call-with-port port proc)
  (call-with-values (lambda () (proc port))
    (lambda vals (close-port port) (apply values vals))))


; procedures of variable arity (plain and making use of case-lambda)

(define string->list
  (case-lambda
     [(str) (substring->list str 0 (string-length str))]
     [(str start) (substring->list str start (string-length str))]
     [(str start end) (substring->list str start end)]))

(define string-copy 
  (case-lambda
     [(str) (%string-copy str)]
     [(str start) (substring str start (string-length str))]
     [(str start end) (substring str start end)]))

(define string-copy!
  (case-lambda
     [(to at from) (substring-copy! to at from 0 (string-length from))]
     [(to at from start) (substring-copy! to at from start (string-length from))]
     [(to at from start end) (substring-copy! to at from start end)]))

(define string-fill!
  (case-lambda
     [(str c) (%string-fill! str c)]
     [(str c start) (substring-fill! str c start (string-length str))]
     [(str c start end) (substring-fill! str c start end)]))

(define vector->list
  (case-lambda
     [(vec) (subvector->list vec 0 (vector-length vec))]
     [(vec start) (subvector->list vec start (vector-length vec))]
     [(vec start end) (subvector->list vec start end)]))

(define vector->string
  (case-lambda
     [(vec) (subvector->string vec 0 (vector-length vec))]
     [(vec start) (subvector->string vec start (vector-length vec))]
     [(vec start end) (subvector->string vec start end)]))

(define string->vector
  (case-lambda
     [(str) (substring->vector str 0 (string-length str))]
     [(str start) (substring->vector str start (string-length str))]
     [(str start end) (substring->vector str start end)]))

(define vector-copy!
  (case-lambda
     [(to at from) (subvector-copy! to at from 0 (vector-length from))]
     [(to at from start) (subvector-copy! to at from start (vector-length from))]
     [(to at from start end) (subvector-copy! to at from start end)]))

(define vector-copy
  (case-lambda
     [(vec) (subvector vec 0 (vector-length vec))]
     [(vec start) (subvector vec start (vector-length vec))]
     [(vec start end) (subvector vec start end)]))

(define (%vectors-sum-length vecs)
  (let loop ([vecs vecs] [l 0])
    (if (null? vecs) l (loop (cdr vecs) (fx+ l (vector-length (car vecs)))))))

(define (%vectors-copy-into! to vecs)
  (let loop ([vecs vecs] [i 0])
    (if (null? vecs)
        to
        (let ([vec (car vecs)] [vecs (cdr vecs)])
          (let ([len (vector-length vec)])
            (subvector-copy! to i vec 0 len)
            (loop vecs (fx+ i len)))))))  

(define (vector-append . vecs)
  (%vectors-copy-into! (make-vector (%vectors-sum-length vecs)) vecs))

(define vector-fill!
  (case-lambda
     [(vec x) (subvector-fill! vec x 0 (vector-length vec))]
     [(vec x start) (subvector-fill! vec x start (vector-length vec))]
     [(vec x start end) (subvector-fill! vec x start end)]))

(define bytevector->list
  (case-lambda
     [(vec) (subbytevector->list vec 0 (bytevector-length vec))]
     [(vec start) (subbytevector->list vec start (bytevector-length vec))]
     [(vec start end) (subbytevector->list vec start end)]))

(define bytevector-copy!
  (case-lambda
     [(to at from) (subbytevector-copy! to at from 0 (bytevector-length from))]
     [(to at from start) (subbytevector-copy! to at from start (bytevector-length from))]
     [(to at from start end) (subbytevector-copy! to at from start end)]))

(define bytevector-copy
  (case-lambda
     [(vec) (subbytevector vec 0 (bytevector-length vec))]
     [(vec start) (subbytevector vec start (bytevector-length vec))]
     [(vec start end) (subbytevector vec start end)]))

(define (%bytevectors-sum-length vecs)
  (let loop ([vecs vecs] [l 0])
    (if (null? vecs) l (loop (cdr vecs) (fx+ l (bytevector-length (car vecs)))))))

(define (%bytevectors-copy-into! to vecs)
  (let loop ([vecs vecs] [i 0])
    (if (null? vecs)
        to
        (let ([vec (car vecs)] [vecs (cdr vecs)])
          (let ([len (bytevector-length vec)])
            (subbytevector-copy! to i vec 0 len)
            (loop vecs (fx+ i len)))))))  

(define (bytevector-append . vecs)
  (%bytevectors-copy-into! (make-bytevector (%bytevectors-sum-length vecs)) vecs))

(define (subutf8->string vec start end)
  (let ([p (open-output-string)])
    (write-subbytevector vec start end p)
    ; todo: make a single operation: get-final-output-string (can reuse cbuf?)
    (let ([s (get-output-string p)]) (close-output-port p) s)))

(define utf8->string
  (case-lambda
    [(vec) (%prim*? "{ /* bytevector->string */
    int *d = bytevectordata(obj_from_$arg);
    $return obj(hpushstr($live, newstringn((char *)bvdatabytes(d), *d))); }" vec)]
    [(vec start) (subutf8->string vec start (bytevector-length vec))]
    [(vec start end) (subutf8->string vec start end)]))

(define (substring->utf8 str start end)
  (let ([p (open-output-bytevector)])
    (write-substring str start end p)
    ; todo: make a single operation: get-final-output-bytevector (can reuse cbuf?)
    (let ([v (get-output-bytevector p)]) (close-output-port p) v)))

(define string->utf8
  (case-lambda
    [(str) (%prim*? "{ /* string->bytevector */
    int *d = stringdata(obj_from_$arg);
    $return obj(hpushu8v($live, newbytevector((unsigned char *)sdatachars(d), *d))); }" str)]
    [(str start) (substring->utf8 str start (string-length str))]
    [(str start end) (substring->utf8 str start end)]))

(define read-string!
  (case-lambda
    [(str) (read-substring! str 0 (string-length str) (current-input-port))]
    [(str p) (read-substring! str 0 (string-length str) p)]
    [(str p start) (read-substring! str start (string-length str) p)]
    [(str p start end) (read-substring! str start end p)]))

(define read-string
  (case-lambda
    [(k) (read-substring k (current-input-port))]
    [(k p) (read-substring k p)]))

(define read-bytevector!
  (case-lambda
    [(vec) (read-subbytevector! vec 0 (bytevector-length vec) (current-input-port))]
    [(vec p) (read-subbytevector! vec 0 (bytevector-length vec) p)]
    [(vec p start) (read-subbytevector! vec start (bytevector-length vec) p)]
    [(vec p start end) (read-subbytevector! vec start end p)]))

(define read-bytevector
  (case-lambda
    [(k) (read-subbytevector k (current-input-port))]
    [(k p) (read-subbytevector k p)]))


; residual versions of inline procedures

(define (%residual-values . l)
  (call/cc (lambda (k) (throw apply k l))))

(define-syntax cmp-reducer
  (syntax-rules ()
    [(_ f)
     (lambda args
       (or (null? args)
           (let loop ([x (car args)] [args (cdr args)])
             (or (null? args)
                 (let ([y (car args)])
                   (and (f x y) (loop y (cdr args))))))))]))

(define %residual-boolean=? (cmp-reducer boolean=?))  

(define %residual-fx=? (cmp-reducer fx=?))
(define %residual-fx<? (cmp-reducer fx<?))
(define %residual-fx>? (cmp-reducer fx>?))
(define %residual-fx<=? (cmp-reducer fx<=?))
(define %residual-fx>=? (cmp-reducer fx>=?))
(define %residual-fl=? (cmp-reducer fl=?))
(define %residual-fl<? (cmp-reducer fl<?))
(define %residual-fl>? (cmp-reducer fl>?))
(define %residual-fl<=? (cmp-reducer fl<=?))
(define %residual-fl>=? (cmp-reducer fl>=?))
(define %residual= (cmp-reducer =))  
(define %residual< (cmp-reducer <))
(define %residual> (cmp-reducer >))
(define %residual<= (cmp-reducer <=))
(define %residual>= (cmp-reducer >=))

(define-syntax minmax-reducer
  (syntax-rules ()
    [(_ f)
     (lambda (x . args)
       (let loop ([x x] [args args])
         (if (null? args)
             x
             (loop (f x (car args)) (cdr args)))))]))

(define %residual-fxmax (minmax-reducer fxmax))
(define %residual-fxmin (minmax-reducer fxmin))
(define %residual-flmax (minmax-reducer flmax))
(define %residual-flmin (minmax-reducer flmin))

(define (%residual-max/2 a b)
  (if (fixnum? a)
      (if (fixnum? b)
          (if (fx>? a b) a b)
          (let ([a (fixnum->flonum a)]) (if (fl>? a b) a b)))
      (if (fixnum? b)
          (let ([b (fixnum->flonum b)]) (if (fl>? a b) a b))
          (if (fl>? a b) a b))))
(define %residual-max (minmax-reducer %residual-max/2))

(define (%residual-min/2 a b)
  (if (fixnum? a)
      (if (fixnum? b)
          (if (fx<? a b) a b)
          (let ([a (fixnum->flonum a)]) (if (fl<? a b) a b)))
      (if (fixnum? b)
          (let ([b (fixnum->flonum b)]) (if (fl<? a b) a b))
          (if (fl<? a b) a b))))
(define %residual-min (minmax-reducer %residual-min/2))
  
(define-syntax addmul-reducer
  (syntax-rules ()
    [(_ f s)
     (lambda args
       (if (null? args)
           s
           (let loop ([x (car args)] [args (cdr args)])
             (if (null? args)
                 x
                 (loop (f x (car args)) (cdr args))))))]))

(define %residual-fx+ (addmul-reducer fx+ 0))
(define %residual-fx* (addmul-reducer fx* 1))
(define %residual-fl+ (addmul-reducer fl+ 0.0))
(define %residual-fl* (addmul-reducer fl* 1.0))
(define %residual+ (addmul-reducer + 0))
(define %residual* (addmul-reducer * 1))
(define %residual-gcd (addmul-reducer gcd 0))
(define %residual-lcm (addmul-reducer lcm 1))

(define-syntax subdiv-reducer
  (syntax-rules ()
    [(_ f)
     (lambda (x . args)
       (if (null? args)
           (f x)
           (let loop ([x x] [args args])
             (if (null? args)
                 x
                 (loop (f x (car args)) (cdr args))))))]))

(define %residual-fx- (subdiv-reducer fx-))
(define %residual-fx/ (subdiv-reducer fx/))
(define %residual-fl- (subdiv-reducer fl-))
(define %residual-fl/ (subdiv-reducer fl/))
(define %residual- (subdiv-reducer -))
(define %residual/ (subdiv-reducer /))

(define-syntax nullary-unary-adaptor
  (syntax-rules ()
    [(_ f)
     (lambda args
       (if (null? args) (f) (f (car args))))]))

(define-syntax nullary-unary-binary-adaptor
  (syntax-rules ()
    [(_ f)
     (lambda args
       (if (null? args) (f) (if (null? (cdr args)) (f (car args)) (f (car args) (cadr args)))))])) 

(define-syntax unary-binary-adaptor
  (syntax-rules ()
    [(_ f)
     (lambda (x . args)
       (if (null? args) (f x) (f x (car args))))]))

(define-syntax unary-binary-ternary-adaptor
  (syntax-rules ()
    [(_ f)
     (lambda (x . args)
       (if (null? args) (f x) (if (null? (cdr args)) (f x (car args)) (f x (car args) (cadr args)))))])) 

(define-syntax unary-binary-ternary-quaternary-adaptor
  (syntax-rules ()
    [(_ f)
     (lambda (x . args)
       (if (null? args) (f x) (if (null? (cdr args)) (f x (car args)) 
         (if (null? (cddr args)) (f x (car args) (cadr args)) (f x (car args) (cadr args) (caddr args))))))])) 

(define-syntax binary-ternary-adaptor
  (syntax-rules ()
    [(_ f)
     (lambda (x y . args)
       (if (null? args) (f x y) (f x y (car args))))]))

(define-syntax binary-ternary-quaternary-adaptor
  (syntax-rules ()
    [(_ f)
     (lambda (x y . args)
       (if (null? args) (f x y) 
           (if (null? (cdr args)) (f x y (car args)) (f x y (car args) (cadr args)))))]))

(define %residual-log (unary-binary-adaptor log))

(define %residual-flatan (unary-binary-adaptor flatan))
(define %residual-atan (unary-binary-adaptor atan))

(define %residual-member (binary-ternary-adaptor member)) 
(define %residual-assoc (binary-ternary-adaptor assoc)) 

(define (%residual-map p l . l*)
  (if (null? l*) 
      (let loop ([l l] [r '()])
        (if (pair? l) (loop (cdr l) (cons (p (car l)) r)) (reverse! r)))
      (let loop ([l* (cons l l*)] [r '()])
        (if (let lp ([l* l*]) (or (null? l*) (and (pair? (car l*)) (lp (cdr l*)))))
            (loop (map cdr l*) (cons (apply p (map car l*)) r))
            (reverse! r)))))

(define (%residual-for-each p l . l*)
  (if (null? l*) 
      (let loop ([l l]) (if (pair? l) (begin (p (car l)) (loop (cdr l)))))
      (let loop ([l* (cons l l*)])
        (if (let lp ([l* l*]) (or (null? l*) (and (pair? (car l*)) (lp (cdr l*)))))
            (begin (apply p (map car l*)) (loop (map cdr l*)))))))

(define (string-map p s . s*)
  (if (null? s*)
      (let* ([len (string-length s)] [res (make-string len)])
        (do ([i 0 (fx+ i 1)]) [(fx>=? i len) res]
           (string-set! res i (p (string-ref s i)))))
      (list->string (apply map p (map string->list (cons s s*))))))

(define (vector-map p v . v*)
  (if (null? v*)
      (let* ([len (vector-length v)] [res (make-vector len)])
        (do ([i 0 (fx+ i 1)]) [(fx>=? i len) res]
          (vector-set! res i (p (vector-ref v i)))))
      (list->vector (apply map p (map vector->list (cons v v*))))))

(define (string-for-each p s . s*)
  (if (null? s*) 
      (let ([len (string-length s)])
        (do ([i 0 (fx+ i 1)]) [(fx>=? i len)] (p (string-ref s i))))
      (apply for-each p (map string->list (cons s s*)))))

(define (vector-for-each p v . v*)
  (if (null? v*)
      (let ([len (vector-length v)])
        (do ([i 0 (fx+ i 1)]) [(fx>=? i len)] (p (vector-ref v i))))
      (apply for-each p (map vector->list (cons v v*)))))

(define-syntax append-reducer
  (syntax-rules ()
    [(_ f s)
     (lambda args
       (let loop ([args args])
         (cond [(null? args) s]
               [(null? (cdr args)) (car args)]
               [else (f (car args) (loop (cdr args)))])))]))

(define %residual-char=? (cmp-reducer char=?))
(define %residual-char<? (cmp-reducer char<?))
(define %residual-char>? (cmp-reducer char>?))
(define %residual-char<=? (cmp-reducer char<=?))
(define %residual-char>=? (cmp-reducer char>=?))
(define %residual-char-ci=? (cmp-reducer char-ci=?))
(define %residual-char-ci<? (cmp-reducer char-ci<?))
(define %residual-char-ci>? (cmp-reducer char-ci>?))
(define %residual-char-ci<=? (cmp-reducer char-ci<=?))
(define %residual-char-ci>=? (cmp-reducer char-ci>=?))

(define %residual-make-string (unary-binary-adaptor make-string))

(define (%residual-string . l) 
  (list->string l))

(define %residual-string-append (append-reducer string-append ""))

(define %residual-string=? (cmp-reducer string=?))
(define %residual-string<? (cmp-reducer string<?))
(define %residual-string>? (cmp-reducer string>?))
(define %residual-string<=? (cmp-reducer string<=?))
(define %residual-string>=? (cmp-reducer string>=?))
(define %residual-string-ci=? (cmp-reducer string-ci=?))
(define %residual-string-ci<? (cmp-reducer string-ci<?))
(define %residual-string-ci>? (cmp-reducer string-ci>?))
(define %residual-string-ci<=? (cmp-reducer string-ci<=?))
(define %residual-string-ci>=? (cmp-reducer string-ci>=?))

(define %residual-make-vector (unary-binary-adaptor make-vector))

(define (%residual-vector . l) 
  (list->vector l))

(define %residual-make-bytevector (unary-binary-adaptor make-bytevector))

(define (%residual-bytevector . l) 
  (list->bytevector l))

(define (%residual-list . l) l)

(define %residual-make-list (unary-binary-adaptor make-list))

(define (%residual-cons* x . l)
  (let loop ([x x] [l l])
    (if (null? l) x (cons x (loop (car l) (cdr l))))))

(define %residual-append (append-reducer append '()))

(define %residual-record? (unary-binary-adaptor record?))

(define %residual-number->string (unary-binary-adaptor number->string))
(define %residual-string->number (unary-binary-adaptor string->number))

(define %residual-symbol=? (cmp-reducer symbol=?))  

(define (%fail-lambda . args)
  (error 'case-lambda "unexpected number of arguments" args))

(define (%residual-make-case-lambda . l)
  (%prim* "{ /* %residual-make-case-lambda */
    obj l; int i, c = fixnum_from_$arg;
    hreserve(hbsz(c+1), $live); /* $live live regs */
    l = obj_from_$arg; /* gc-safe */
    for (i = 0; i < c; ++i, l = cdr(l)) hp[i-c] = car(l);
    hp -= c; *--hp = obj_from_objptr(appcases+4);
    $return obj(hendblk(c+1)); }" (length l) l))

(define %residual-current-input-port (nullary-unary-binary-adaptor current-input-port))
(define %residual-current-output-port (nullary-unary-binary-adaptor current-output-port))
(define %residual-current-error-port (nullary-unary-binary-adaptor current-error-port))

(define %residual-read-char (nullary-unary-adaptor read-char))
(define %residual-peek-char (nullary-unary-adaptor peek-char))
(define %residual-char-ready? (nullary-unary-adaptor char-ready?))
(define %residual-read-line (nullary-unary-adaptor read-line))

(define %residual-display-fixnum (unary-binary-adaptor display-fixnum))
(define %residual-display-flonum (unary-binary-adaptor display-flonum))
(define %residual-display-procedure (unary-binary-adaptor display-procedure))
(define %residual-display-input-port (unary-binary-adaptor display-input-port))
(define %residual-display-output-port (unary-binary-adaptor display-output-port))

(define %residual-write-char (unary-binary-adaptor write-char))
(define %residual-write-string (unary-binary-ternary-quaternary-adaptor write-string))
(define %residual-newline (nullary-unary-adaptor newline))
(define %residual-flush-output-port (nullary-unary-adaptor flush-output-port))

(define %residual-read-u8 (nullary-unary-adaptor read-u8))
(define %residual-peek-u8 (nullary-unary-adaptor peek-u8))
(define %residual-u8-ready? (nullary-unary-adaptor u8-ready?))
(define %residual-write-u8 (unary-binary-adaptor write-u8))
(define %residual-write-bytevector (unary-binary-ternary-quaternary-adaptor write-bytevector))

(define %residual-write-simple (unary-binary-adaptor write-simple))
(define %residual-write-shared (unary-binary-adaptor write-shared))
(define %residual-write (unary-binary-adaptor write))
(define %residual-display (unary-binary-adaptor display))

(define %residual-read (nullary-unary-adaptor read))
(define %residual-read-simple (nullary-unary-adaptor read-simple))

(define %residual-exit (nullary-unary-adaptor exit))



;---------------------------------------------------------------------------------------------
;
;  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
;---------------------------------------------------------------------------------------------

;  <core> -> (quote <object>)
;  <core> -> (ref <id>)
;  <core> -> (set! <id> <core>)
;  <core> -> (set& <id>)
;  <core> -> (lambda <ids> <core>) where <ids> -> (<id> ...) | (<id> ... . <id>) | <id>
;  <core> -> (lambda* (<arity> <core>) ...) where <arity> -> (<cnt> <rest?>)
;  <core> -> (syntax-lambda (<id> ...) <core>)
;  <core> -> (letcc <id> <core>) 
;  <core> -> (withcc <core> <core>) 
;  <core> -> (begin <core> ...)
;  <core> -> (if <core> <core> <core>)
;  <core> -> (call <core> <core> ...)
;  <core> -> (integrable <ig> <core> ...) where <ig> is an index in the integrables table

;  NB: (begin) is legit, returns unspecified value
;  on top level, these two extra core forms are legal:

;  <core> -> (define <id> <core>)
;  <core> -> (define-syntax <id> <transformer>)

(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' <ids> 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.

; <identifier>  ->  <symbol> | <thunk returning (sym . den)>
; <denotation>  ->  <location>
; <location>    ->  #&<value>
; <value>       ->  <special> | <core>
; <special>     ->  <builtin> | <transformer>
; <builtin>     ->  syntax-quote | quote | set! | set& | if | lambda | lambda* |
;                   letcc | withcc | body | begin | define | define-syntax |
;                   syntax-lambda | syntax-rules | syntax-length | syntax-error  
; <transformer> ->  <procedure of exp and env returning exp>

(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 <core>
  (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 <core>
; (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 <core> 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 #\space) (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<?)))

(define test2
 '(let ()
    (define tak
      (lambda (x y z)
        (if (< y x)
            (tak (tak (- x 1) y z)
                (tak (- y 1) z x)
                (tak (- z 1) x y))
            z)))
    (define runtak
      (lambda (n r)
        (let loop ([n n] [r r] [s 7])
          (if (= n 0) r
              (let ([v (tak 18 12 (- s 1))])
                (loop (- n 1) (+ r v) v))))))
    (runtak 10 0)))

(define test3
 '(let ()
    (define (nqueens n)
      (define (one-to n)
        (let loop ((i n) (l '()))
          (cond
            ((zero? i) l)
            (else (loop (- i 1) (cons i l))))))
      (define (try-it x y z)
        (if (null? x)
            (if (null? y) 1 0)
            (+ (if (ok? (car x) 1 z)
                   (try-it (append (cdr x) y) '() (cons (car x) z))
                   0)
              (try-it (cdr x) (cons (car x) y) z))))
      (define (ok? row dist placed)
        (if (null? placed) #t
            (and (not (= (car placed) (+ row dist)))
                 (not (= (car placed) (- row dist)))
                 (ok? row (+ dist 1) (cdr placed)))))
      (try-it (one-to n) '() '()))
    (define (run-test count)
      (let loop ((n count) (v 92))
        (cond
          ((zero? n) v)
          (else (loop (- n 1) (nqueens (- v 84)))))))
    (run-test 10)))

(define test4
 '(let ()
    (define y
      (lambda (e) 
        ((call/cc call/cc) 
        (lambda (f) 
          (e (lambda (x) (((call/cc (call/cc call/cc)) f) x)))))))
    (define fakt
      (y (lambda (self) (lambda (x) (if (= x 0) 1 (* x (self (- x 1))))))))
    (fakt 10)))

(define test5
 '(let ()
    (define y
      (lambda (e) 
        ((call/cc call/cc) 
        (lambda (f) 
          (e (lambda (x) (((call/cc (call/cc call/cc)) f) x)))))))
    (define fakty
      (y (lambda (self) 
            (lambda (x) (if (= x 0) 1 (* x (self (- x 1))))))))
    (define (fakti x)
      (let loop ((n 1) (x x))
          (if (= x 1)
            n
            (loop (* n x) (- x 1)))))
    (define (faktr x)
      (if (= x 1)
          1
          (* x (faktr (- x 1)))))
    (define faktl
      (lambda (x)
          ((lambda (self) (self self x))
          (lambda (self x)
            (if (= x 1)
                x
                (* (self self (- x 1)) x))))))
    (let ([y (fakty 10)] [i (fakti 10)] [r (faktr 10)] [l (faktl 10)])
      (cons y (cons i (cons r (cons l '())))))))

; (evaluate test1) =>
; ("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))])))