0.sf

; #F, part 0:  SFC runtime library 

;  SFC's predefined forms: 
;
;  begin define define-syntax if lambda quote
;  set! syntax-lambda syntax-rules


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

; basic syntax constructs, extended lambda

(define-syntax syntax-rule
  (syntax-rules ()
    [(_ pat tmpl) (syntax-rules () [(__ . pat) tmpl])]))

(define-syntax let-syntax
  (syntax-rules ()
    [(_ ([kw init] ...))
     (begin)]
    [(_ ([kw init] ...) . body)
     ((syntax-lambda (kw ...) . body)
      init ...)]))

(define-syntax letrec-syntax
  (let-syntax ([let-syntax let-syntax] [define-syntax define-syntax])
    (syntax-rules ()
      [(_ ([kw init] ...) . body)
       (let-syntax ()
         (define-syntax kw init) ... (let-syntax () . body))])))

(define-syntax lambda
  (let-syntax ([old-lambda lambda])
    (syntax-rules ()
      [(_ args . body)
       (old-lambda args (let-syntax () . 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
  (syntax-rules ()
    [(_ (op . ll) . body)
     (define-syntax op (lambda ll . body))]
    [(_ op val)
     (define-syntax op val)]))
     
(define-syntax define-integrable
  (syntax-rules ()
    [(_ (op . ll) . body)
     (define-syntax op 
       (%quote (letrec ([op (lambda ll . body)]) op)))]))

(define-syntax define-rule
  (syntax-rules ()
    [(_ (op . pat) . body)
     (define-syntax op (syntax-rule pat . body))]))


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


; projecting function-like syntax forms

(define-syntax function
  (letrec-syntax
    ([loop
      (syntax-rules (?)
        [(_ (id ...) (arg ...) () e) 
         (lambda (id ...) (e arg ...))]
        [(_ (id ...) (arg ...) (? . more) e) 
         (loop (id ... i) (arg ... i) more e)]
        [(_ ids (arg ...) (kw . more) e) 
         (loop ids (arg ... kw) more e)])])
    (syntax-rules ()
      [(_ (?-or-kw ...) e) 
       (loop () () (?-or-kw ...) e)])))


; type assertions

(define-syntax the
  (syntax-rules ()
    [(_ ta expr) (let ([id expr]) (ta id) id)]))


; control
               
(define-syntax do
  (let-syntax ([do-step (syntax-rules () [(_ x) x] [(_ x y) y])])
    (syntax-rules ()
      [(_ ([var init step ...] ...)
         [test expr ...]
          command ...)
       (let loop ([var init] ...)
         (if test
             (begin (if #f #f) expr ...)
             (let () 
               command ...
               (loop (do-step var step ...) ...))))])))

(define-syntax cond
  (syntax-rules (else =>)
    [(_) (if #f #f)] ; undefined
    [(_ [else . exps]) (let () . exps)]
    [(_ [x] . rest) (or x (cond . rest))]
    [(_ [x => proc] . rest)
     (let ([tmp x]) (cond [tmp (proc tmp)] . rest))]
    [(_ [x . exps] . rest)
     (if x (let () . exps) (cond . rest))]))

(define-syntax 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 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))]))



; varargs & continuations

(define-syntax letcc
  (let-syntax ([old-letcc letcc])
    (syntax-rule (var . body)
      (old-letcc var (let-syntax () . body)))))

(define-syntax call-with-current-continuation
  (lambda (f) (letcc k (f k))))

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

(define-syntax throw
  (syntax-rule (k expr ...) 
    (withcc (%prim "ktrap()") (k expr ...))))

(define-syntax values
  (syntax-rule (expr ...) 
    (letcc k (throw k expr ...))))

(define-syntax receive
  (syntax-rule ((var ...) expr . body)
    (letcc k
      (withcc 
        (lambda (var ...)
          (withcc k (let-syntax () . body)))
        expr))))

(define-syntax let-values
  (syntax-rules ()
    [(_ () . body)
     (let () . body)]
    [(_ ([formals expr] . more) . body)
     (let ([thunk (lambda () expr)])
       (let-values more
         (receive formals (thunk) . body)))]))

(define-syntax let*-values
  (syntax-rules ()
    [(_ () . body)
     (let () . body)]
    [(_ ([formals expr] . more) . body)
     (receive formals expr
       (let*-values more . body))]))


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

; scheme data types 


(%definition "/* basic object representation */")

; immediate objects have 7-bit tag followed by at least 24 bits of data
; subtype bits follow lsb which is 1 in non-pointer objects 

(%definition "#define isimm(o, t) (((o) & 0xff) == (((t) << 1) | 1))")

(%localdef "int getimmu(obj o, int t) {
  assert(isimm(o, t));
  return (int)((o >> 8) & 0xffffff);
}")

(%localdef "int getimms(obj o, int t) {
  assert(isimm(o, t));
  return (int)((((o >> 8) & 0xffffff) ^ 0x800000) - 0x800000);
}")

(%definition "#ifdef NDEBUG
  #define getimmu(o, t) (int)(((o) >> 8) & 0xffffff)
  #define getimms(o, t) (int)(((((o) >> 8) & 0xffffff) ^ 0x800000) - 0x800000)
#else
  extern int getimmu(obj o, int t);
  extern int getimms(obj o, int t);
#endif")

(%definition "#define mkimm(o, t) (obj)((((o) & 0xffffff) << 8) | ((t) << 1) | 1)")



; native blocks are 1-element blocks containing a native
; (non-cx) pointer as 0th element and cxtype ptr in block header

(%localdef "#ifndef NDEBUG
int isnative(obj o, cxtype_t *tp) {
  return isobjptr(o) && objptr_from_obj(o)[-1] == (obj)tp; 
}
void *getnative(obj o, cxtype_t *tp) {
  assert(isnative(o, tp));
  return (void*)(*objptr_from_obj(o));
}
#endif")

(%definition "#ifdef NDEBUG
   static int isnative(obj o, cxtype_t *tp) 
     { return isobjptr(o) && objptr_from_obj(o)[-1] == (obj)tp;  }
   #define getnative(o, t) ((void*)(*objptr_from_obj(o)))
#else
  extern int isnative(obj o, cxtype_t *tp);
  extern void *getnative(obj o, cxtype_t *tp);
#endif")



; tagged blocks are heap blocks with runtime int tag as 0th element
; (disjoint from closures which have a pointer as 0th element)

(%localdef "int istagged(obj o, int t) {
  if (!isobjptr(o)) return 0;
  else { obj h = objptr_from_obj(o)[-1];
    return notaptr(h) && size_from_obj(h) >= 1 
      && hblkref(o, 0) == obj_from_size(t); }
}")

(%localdef "obj cktagged(obj o, int t) {
  assert(istagged(o, t));
  return o;
}")

(%localdef "int taggedlen(obj o, int t) {
  assert(istagged(o, t));
  return hblklen(o) - 1;
}")

(%localdef "obj* taggedref(obj o, int t, int i) {
  int len; assert(istagged(o, t));
  len = hblklen(o);
  assert(i >= 0 && i < len-1);  
  return &hblkref(o, i+1);
}")

(%definition "extern int istagged(obj o, int t);")
(%definition "#ifdef NDEBUG
  #define cktagged(o, t) (o)
  #define taggedlen(o, t) (hblklen(o)-1) 
  #define taggedref(o, t, i) (&hblkref(o, (i)+1))
#else
  extern obj cktagged(obj o, int t);
  extern int taggedlen(obj o, int t);
  extern obj* taggedref(obj o, int t, int i); 
#endif")



; void 

; this is the value to be used where it doesn't really matter what value
; is used. Standard header supports void value, which is some immediate
; which looks funny in the debugger; it might correspond to a useful value,
; but we don't really care.

(define-inline (void) (%prim "void(0)"))



; booleans

; #f is (obj)0, #t is immediate 0 with tag 0 (singular true object)
; this layout is compatible with C conventions (0 = false, 1 = true)
; note that any obj but #f is counted as true in conditionals and that
; bool_from_obj and bool_from_bool are already defined in std prelude


(%definition "/* booleans */")
(%definition "#define TRUE_ITAG 0")  
(%definition "typedef int bool_t;")
(%definition "#define is_bool_obj(o) (!((o) & ~(obj)1))")  
(%definition "#define is_bool_bool(b) ((void)(b), 1)")  
(%definition "#define void_from_bool(b) (void)(b)")
(%definition "#define obj_from_bool(b) ((b) ? mkimm(0, TRUE_ITAG) : 0)")

(define-syntax %const
  (let-syntax ([old-%const %const])
    (syntax-rules (boolean)
      [(_ boolean b) (%prim ("bool(" b ")"))] 
      [(_ arg ...) (old-%const arg ...)]))) 

(define-inline (boolean? x)
  (%prim "bool(is_bool_$arg)" x))

(define-inline (not x)
  (%prim "bool(!bool_from_$arg)" x))



; fixnums

(%definition "/* fixnums */")
(%definition "#define FIXNUM_ITAG 1")  
(%definition "typedef int fixnum_t;")
(%definition "#define is_fixnum_obj(o) (isimm(o, FIXNUM_ITAG))")
(%definition "#define is_fixnum_fixnum(i) ((void)(i), 1)")
(%definition "#define fixnum_from_obj(o) (getimms(o, FIXNUM_ITAG))")
(%definition "#define fixnum_from_fixnum(i) (i)")
(%definition "#define void_from_fixnum(i) (void)(i)")
(%definition "#define obj_from_fixnum(i) mkimm(i, FIXNUM_ITAG)")
(%definition "#define FIXNUM_MIN -8388608")
(%definition "#define FIXNUM_MAX 8388607")

(define-syntax %const
  (let-syntax ([old-%const %const])
    (syntax-rules (integer +)
      [(_ integer 8 + digs 8) (%prim ("fixnum(" "0" digs ")"))] 
      [(_ integer 16 + digs 8) (%prim ("fixnum(" "0" digs ")"))] 
      [(_ integer 24 + digs 8) (%prim ("fixnum(" "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 + digs 16) (%prim ("fixnum(" "0x" digs ")"))] 
      [(_ integer 16 + digs 16) (%prim ("fixnum(" "0x" digs ")"))] 
      [(_ integer 24 + digs 16) (%prim ("fixnum(" "0x" digs ")"))] 
      [(_ arg ...) (old-%const arg ...)]))) 

(define-inline (fixnum? x)
  (%prim "bool(is_fixnum_$arg)" x))

(define-syntax fixnum::
  (syntax-rules ()
    [(_ x) (define (%prim! "void(assert(is_fixnum_$arg))" x))]
    [(_ x ...) (begin (fixnum:: x) ...)])) 

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

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

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

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

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

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

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

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

(define-syntax fx/  ; aka quotient?
  (syntax-rules ()
    [(_ x y) (%prim "fixnum(fixnum_from_$arg / fixnum_from_$arg)" x y)]))

(define-syntax fx%  ; aka remainder?
  (syntax-rules ()
    [(_ x y) (%prim "fixnum(fixnum_from_$arg % fixnum_from_$arg)" x y)]))

(define-syntax fxlogand
  (syntax-rules ()
    [(_) (%prim "fixnum(-1)")]
    [(_ x) x]
    [(_ x y) (%prim "fixnum(fixnum_from_$arg & fixnum_from_$arg)" x y)]
    [(_ x y z ...) (fxlogand x (fxlogand y z ...))]))

(define-syntax fxlogor
  (syntax-rules ()
    [(_) (%prim "fixnum(0)")]
    [(_ x) x]
    [(_ x y) (%prim "fixnum(fixnum_from_$arg | fixnum_from_$arg)" x y)]
    [(_ x y z ...) (fxlogor x (fxlogor y z ...))]))

(define-syntax fxlogxor
  (syntax-rules ()
    [(_) (%prim "fixnum(0)")]
    [(_ x) x]
    [(_ x y) (%prim "fixnum(fixnum_from_$arg ^ fixnum_from_$arg)" x y)]
    [(_ x y z ...) (fxlogxor x (fxlogxor y z ...))]))

(define-syntax fxlognot
  (syntax-rules ()
    [(_ x) (%prim "fixnum(~fixnum_from_$arg)" y)]))

(define-syntax fxsll  ; shift left, logical
  (syntax-rules ()
    [(_ x y) (%prim "fixnum(fixnum_from_$arg << fixnum_from_$arg)" x y)]))

(define-syntax fxsrl  ; shift right, logical
  (syntax-rules ()
    [(_ x y) (%prim "fixnum(fixnum_from_$arg >> fixnum_from_$arg)" x y)]))

(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 ...)))]))

(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 ...)))]))

(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 ...)))]))

(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 ...)))]))

(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 ...)))]))

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

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

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

(define (fxexpt x y)
  (let ex ([y y])
    (cond [(fxzero? y) 1]
          [(fxzero? x) 0]
          [(fx<? y 0) 0] ; this is a fixnum-only operation!
          [(fx=? y 1) x]
          [(fxodd? y) (fx* x (ex (fx- y 1)))]
          [else (let ([z (ex (fx/ y 2))]) (fx* z z))])))



; flonums

(%include <math.h>)
(%include <errno.h>)

(%definition "/* flonums */")
(%localdef "static cxtype_t cxt_flonum = { \"flonum\", free };")
(%localdef "cxtype_t *FLONUM_NTAG = &cxt_flonum;")
(%definition "extern cxtype_t *FLONUM_NTAG;")
(%definition "typedef double flonum_t;")
(%definition "#define is_flonum_obj(o) (isnative(o, FLONUM_NTAG))")
(%definition "#define is_flonum_flonum(f) ((void)(f), 1)")
(%definition "#define flonum_from_obj(o) (*(flonum_t*)getnative(o, FLONUM_NTAG))")
(%definition "#define flonum_from_flonum(l, f) (f)")
(%definition "#define void_from_flonum(l, f) (void)(f)")
(%definition "#define obj_from_flonum(l, f) hpushptr(dupflonum(f), FLONUM_NTAG, l)")
(%definition "extern flonum_t *dupflonum(flonum_t f);")
(%localdef "flonum_t *dupflonum(flonum_t f) {
  flonum_t *pf = cxm_cknull(malloc(sizeof(flonum_t)), \"malloc(flonum)\");
  *pf = f; return pf;
}")

(define-syntax %const
  (let-syntax ([old-%const %const])
    (syntax-rules (decimal e)
      [(_ 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 ")"))]
      [(_ arg ...) (old-%const arg ...)]))) 

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

(define-syntax flonum::
  (syntax-rules ()
    [(_ x) (define (%prim! "void(assert(is_flonum_$arg))" x))]
    [(_ x ...) (begin (flonum:: x) ...)])) 

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

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

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


(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 ...))]))

(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- x (fl+ y z ...))]))

(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 ...))]))

(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/ x (fl* y z ...))]))

(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 ...)))]))

(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 ...)))]))

(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 ...)))]))

(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 ...)))]))

(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 ...)))]))

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

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

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

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

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

(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 (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 (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)]))

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

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



; standard math operators are mapped to fixnum ones

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

(define-syntax exact? fixnum?)
(define-syntax inexact? flonum?)

(define-inline (zero? x) 
  (fxzero? x))

(define-syntax +
  (syntax-rules ()
    [(_) (%prim "fixnum(0)")]
    [(_ x) x]
    [(_ x y) (fx+ x y)]
    [(_ x y z ...) (+ x (+ y z ...))]))

(define-syntax -
  (syntax-rules ()
    [(_ x) (fx- x)]
    [(_ x y) (fx- x y)]
    [(_ x y z ...) (- x (+ y z ...))]))

(define-syntax *
  (syntax-rules ()
    [(_) (%prim "fixnum(1)")]
    [(_ x) x]
    [(_ x y) (fx* x y)]
    [(_ x y z ...) (* x (* y z ...))]))

(define-syntax /
  (syntax-rules ()
    [(_ x) (/ 1 x)]
    [(_ x y) (fx/ x y)]
    [(_ x y z ...) (/ x (* y z ...))]))

(define-syntax =
  (syntax-rules ()
    [(_ x y) (fx=? x y)]
    [(_ x y z ...) (let ([t y]) (and (= x t) (= t z ...)))]))

(define-syntax <
  (syntax-rules ()
    [(_ x y) (fx<? x y)]
    [(_ x y z ...) (let ([t y]) (and (< x t) (< t z ...)))]))

(define-syntax >
  (syntax-rules ()
    [(_ x y) (fx>? x y)]
    [(_ x y z ...) (let ([t y]) (and (> x t) (> t z ...)))]))

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

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

(define-syntax min
  (syntax-rules ()
    [(_ x y) (let ([a x] [b y]) (if (< a b) a b))]
    [(_ x y z ...) (min (min a b) z ...)]))

(define-syntax max
  (syntax-rules ()
    [(_ x y) (let ([a x] [b y]) (if (> a b) a b))]
    [(_ x y z ...) (max (max a b) z ...)]))

(define-inline (negative? x) (< x 0))
(define-inline (positive? x) (> x 0))

(define-inline (even? x) 
  (fxeven? x))

(define-inline (odd? x) 
  (fxodd? x))

(define-inline (abs x) 
  (fxabs x)) 

(define-inline (quotient x y)
  (fx/ x y)) ;fixme: fx/ may behave as div or floor quotient 

(define-inline (remainder x y)
  (fx% x y)) ;fixme: fx% may behave as mod or floor remainder 

(define-inline (modulo x y)
  (fxmodulo x y))

(define-inline (expt x y)
  (fxexpt x y))

 

; characters

(%include <ctype.h>)

(%definition "/* characters */")
(%definition "#define CHAR_ITAG 2")  
(%definition "typedef int char_t;")
(%definition "#define is_char_obj(o) (isimm(o, CHAR_ITAG))")
(%definition "#define is_char_char(i) ((i), 1)")
(%definition "#define char_from_obj(o) (getimms(o, CHAR_ITAG))")
(%definition "#define char_from_char(i) (i)")
(%definition "#define void_from_char(i) (void)(i)")
(%definition "#define obj_from_char(i) mkimm(i, CHAR_ITAG)")

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

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

(define-inline (char=? x y)
  (%prim "bool(char_from_$arg == char_from_$arg)" x y))

(define-inline (char<? x y)
  (%prim "bool(char_from_$arg < char_from_$arg)" x y))

(define-inline (char>? x y)
  (%prim "bool(char_from_$arg > char_from_$arg)" x y))

(define-inline (char<=? x y)
  (%prim "bool(char_from_$arg <= char_from_$arg)" x y))

(define-inline (char>=? x y)
  (%prim "bool(char_from_$arg >= char_from_$arg)" x y))

(define-inline (char-ci=? x y)
  (%prim "bool(tolower(char_from_$arg) == tolower(char_from_$arg))" x y))

(define-inline (char-ci<? x y)
  (%prim "bool(tolower(char_from_$arg) < tolower(char_from_$arg))" x y))

(define-inline (char-ci>? x y)
  (%prim "bool(tolower(char_from_$arg) > tolower(char_from_$arg))" x y))

(define-inline (char-ci<=? x y)
  (%prim "bool(tolower(char_from_$arg) <= tolower(char_from_$arg))" x y))

(define-inline (char-ci>=? x y)
  (%prim "bool(tolower(char_from_$arg) >= tolower(char_from_$arg))" x y))

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

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

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

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

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

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

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

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

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


; strings

(%include <string.h>)

(%definition "/* strings */")
(%localdef "static cxtype_t cxt_string = { \"string\", free };")
(%localdef "cxtype_t *STRING_NTAG = &cxt_string;")
(%definition "extern cxtype_t *STRING_NTAG;")
(%definition "#define isstring(o) (isnative(o, STRING_NTAG))")
(%definition "#define stringdata(o) ((int*)getnative(o, STRING_NTAG))")
(%definition "#define stringlen(o) (*stringdata(o))")
(%definition "#define stringchars(o) ((char*)(stringdata(o)+1))")
(%definition "#define hpushstr(l, s) hpushptr(s, STRING_NTAG, l)")

(%localdef "char* stringref(obj o, int i) {
  int *d = stringdata(o);
  assert(i >= 0 && i < *d);  
  return ((char*)(d+1))+i;
}")

(%definition "#ifdef NDEBUG
  #define stringref(o, i) (stringchars(o)+(i))
#else
  extern char* stringref(obj o, int i);
#endif")

(%definition "extern int *newstring(char *s);")
(%localdef "int *newstring(char *s) {
  int l, *d; assert(s); l = (int)strlen(s); 
  d = cxm_cknull(malloc(sizeof(int)+l+1), \"malloc(string)\");
  *d = l; strcpy((char*)(d+1), s); return d;
}")

(%definition "extern int *allocstring(int n, int c);")
(%localdef "int *allocstring(int n, int c) {
  int *d; char *s; assert(n+1 > 0); 
  d = cxm_cknull(malloc(sizeof(int)+n+1), \"malloc(string)\");
  *d = n; s = (char*)(d+1); memset(s, c, n); s[n] = 0;
  return d;
}")

(%definition "extern int *substring(int *d, int from, int to);")
(%localdef "int *substring(int *d0, int from, int to) {
  int n = to-from, *d1; char *s0, *s1; assert(d0);
  assert(0 <= from && from <= to && to <= *d0); 
  d1 = cxm_cknull(malloc(sizeof(int)+n+1), \"malloc(string)\");
  *d1 = n; s0 = (char*)(d0+1); s1 = (char*)(d1+1); 
  memcpy(s1, s0+from, n); s1[n] = 0;
  return d1;
}")

(%definition "extern int *stringcat(int *d0, int *d1);")
(%localdef "int *stringcat(int *d0, int *d1) {
  int l0 = *d0, l1 = *d1, n = l0+l1; char *s0, *s1, *s;
  int *d = cxm_cknull(malloc(sizeof(int)+n+1), \"malloc(string)\");
  *d = n; s = (char*)(d+1); s0 = (char*)(d0+1); s1 = (char*)(d1+1);
  memcpy(s, s0, l0); memcpy(s+l0, s1, l1); s[n] = 0;
  return d;
}")

(%definition "extern int *dupstring(int *d);")
(%localdef "int *dupstring(int *d0) {
  int n = *d0, *d1 = cxm_cknull(malloc(sizeof(int)+n+1), \"malloc(string)\");
  memcpy(d1, d0, sizeof(int)+n+1);
  return d1;
}")

(%definition "extern void stringfill(int *d, int c);")
(%localdef "void stringfill(int *d, int c) {
  int l = *d, i; char *s = (char*)(d+1);
  for (i = 0; i < l; ++i) s[i] = c;
}")

(%definition "extern int strcmp_ci(char *s1, char*s2);")
(%localdef "int strcmp_ci(char *s1, char *s2) {
  int c1, c2, d;
  do { c1 = *s1++; c2 = *s2++; d = (unsigned)tolower(c1) - (unsigned)tolower(c2); }
  while (!d && c1 && c2);
  return d;
}")


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

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

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

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

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

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

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

(define-inline (string=? x y)
  (%prim? "bool(strcmp(stringchars(obj_from_$arg), stringchars(obj_from_$arg)) == 0)" x y))

(define-inline (string<? x y)
  (%prim? "bool(strcmp(stringchars(obj_from_$arg), stringchars(obj_from_$arg)) < 0)" x y))

(define-inline (string>? x y)
  (%prim? "bool(strcmp(stringchars(obj_from_$arg), stringchars(obj_from_$arg)) > 0)" x y))

(define-inline (string<=? x y)
  (%prim? "bool(strcmp(stringchars(obj_from_$arg), stringchars(obj_from_$arg)) <= 0)" x y))

(define-inline (string>=? x y)
  (%prim? "bool(strcmp(stringchars(obj_from_$arg), stringchars(obj_from_$arg)) >= 0)" x y))

(define-inline (string-ci=? x y)
  (%prim? "bool(strcmp_ci(stringchars(obj_from_$arg), stringchars(obj_from_$arg)) == 0)" x y))

(define-inline (string-ci<? x y)
  (%prim? "bool(strcmp_ci(stringchars(obj_from_$arg), stringchars(obj_from_$arg)) < 0)" x y))

(define-inline (string-ci>? x y)
  (%prim? "bool(strcmp_ci(stringchars(obj_from_$arg), stringchars(obj_from_$arg)) > 0)" x y))

(define-inline (string-ci<=? x y)
  (%prim? "bool(strcmp_ci(stringchars(obj_from_$arg), stringchars(obj_from_$arg)) <= 0)" x y))

(define-inline (string-ci>=? x y)
  (%prim? "bool(strcmp_ci(stringchars(obj_from_$arg), stringchars(obj_from_$arg)) >= 0)" x y))

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

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

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

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

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



; vectors

(%definition "/* vectors */")
(%definition "#define VECTOR_BTAG 1")  
(%definition "#define isvector(o) istagged(o, VECTOR_BTAG)")  
(%definition "#define vectorref(v, i) *taggedref(v, VECTOR_BTAG, i)")  
(%definition "#define vectorlen(v) taggedlen(v, VECTOR_BTAG)")  

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

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

(define-syntax make-vector
  (let-syntax ([old-make-vector make-vector])
    (syntax-rules ()
      [(_ n) (old-make-vector n (void))]
      [(_ n i) (old-make-vector n i)])))

(define-rule (vector 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 ...))

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

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

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

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

(define (vector-fill! v x)
  (let ([n (vector-length v)])
    (do ([i 0 (fx+ i 1)])
      [(fx=? i n)]
      (vector-set! v i x))))



; boxes

(%definition "/* boxes */")
(%definition "#define BOX_BTAG 2")  
(%definition "#define isbox(o) istagged(o, BOX_BTAG)")  
(%definition "#define boxref(o) *taggedref(o, BOX_BTAG, 0)")  

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

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

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

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

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



; null

; () is immediate 0 with immediate tag 3 (singular null object)

(%definition "/* null */")
(%definition "#define NULL_ITAG 3")  
(%definition "#define mknull() mkimm(0, NULL_ITAG)")  
(%definition "#define isnull(o) ((o) == mkimm(0, NULL_ITAG))")  

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

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



; pairs and lists

(%definition "/* pairs and lists */")
(%definition "#define PAIR_BTAG 3")  
(%definition "#define ispair(o) istagged(o, PAIR_BTAG)")  
(%definition "#define car(o) *taggedref(o, PAIR_BTAG, 0)")  
(%definition "#define cdr(o) *taggedref(o, PAIR_BTAG, 1)")  

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

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

(%definition "extern int islist(obj l);")
(%localdef "int islist(obj l) {
  obj s = l;
  for (;;) {
    if (isnull(l)) return 1;
    else if (!ispair(l)) return 0;
    else if ((l = cdr(l)) == s) return 0;
    else if (isnull(l)) return 1;
    else if (!ispair(l)) return 0;
    else if ((l = cdr(l)) == s) return 0;
    else s = cdr(s); 
  }
}")

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

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

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

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

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

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

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

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

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

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

(define-rule (list* i ... j)
  (%prim*/rev "{ /* list* */
    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))

(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 (vector->list v)
  (%prim*? "{ /* vector->list */
    obj v, l = mknull(); int c = fixnum_from_$arg;
    hreserve(hbsz(3)*c, $live); /* $live live regs */
    v = obj_from_$arg; /* gc-safe */
    while (c-- > 0) { *--hp = l; *--hp = hblkref(v, 1+c);
    *--hp = obj_from_size(PAIR_BTAG); l = hendblk(3); }
    $return obj(l); }" (vector-length v) v))

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

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

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

(define-syntax append
  (syntax-rules ()
    [(_) '()] [(_ x) x]
    [(_ x y) (append/2 x y)]
    [(_ x y z ...) (append/2 x (append y z ...))]))

(define-inline (list-copy l) 
  (append/2 l '()))

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

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

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

(define-syntax map
  (letrec-syntax 
    ([map-loop
      (syntax-rules ()
        [(_ ([l e] ...) f) 
         (let loop ([l e] ...)
           (if (or (null? l) ...)
               '()
               (cons (f (car l) ...) (loop (cdr l) ...))))]
        [(_ (b ...) f l . ls)
         (map-loop (b ... [id l]) f . ls)])])
    (syntax-rules ()
      [(_ f l0 l ...)
       (map-loop () f l0 l ...)])))

(define-syntax for-each
  (letrec-syntax 
    ([for-each-loop
      (syntax-rules ()
        [(_ ([l e] ...) f) 
         (let loop ([l e] ...)
           (unless (or (null? l) ...)
             (f (car l) ...) 
             (loop (cdr l) ...)))]
        [(_ (b ...) f l . ls)
         (for-each-loop (b ... [id l]) f . ls)])])
    (syntax-rules ()
      [(_ f l0 l ...)
       (for-each-loop () f l0 l ...)])))

(define-syntax fold-right
  (letrec-syntax 
    ([foldr-loop
      (syntax-rules ()
        [(_ ([l e] ...) f n) 
         (let loop ([l e] ...)
           (if (or (null? l) ...)
               n
               (f (car l) ... (loop (cdr l) ...))))]
        [(_ (b ...) f n l . ls)
         (foldr-loop (b ... [id l]) f n . ls)])])
    (syntax-rules ()
      [(_ f n l0 l ...)
       (foldr-loop () f n l0 l ...)])))

(define-syntax fold-left
  (letrec-syntax 
    ([foldl-loop
      (syntax-rules ()
        [(_ ([l e] ...) f n) 
         (let loop ([r n] [l e] ...)
           (if (or (null? l) ...)
               r
               (loop (f r (car l) ...) (cdr l) ...)))]
        [(_ (b ...) f n l . ls)
         (foldl-loop (b ... [id l]) f n . ls)])])
    (syntax-rules ()
      [(_ f n l0 l ...)
       (foldl-loop () f n l0 l ...)])))

(define-syntax andmap
  (letrec-syntax 
    ([and-loop
      (syntax-rules ()
        [(_ ([l e] ...) f) 
         (let loop ([l e] ...)
           (or (null? l) ...
               (and (f (car l) ...)
                    (loop (cdr l) ...))))]
        [(_ (b ...) f l . ls)
         (and-loop (b ... [id l]) f . ls)])])
    (syntax-rules ()
      [(_ f l ...)
       (and-loop () f l ...)])))

(define-syntax ormap
  (letrec-syntax 
    ([or-loop
      (syntax-rules ()
        [(_ ([l e] ...) f) 
         (let loop ([l e] ...)
           (and (not (null? l)) ...
                (or (f (car l) ...)
                    (loop (cdr l) ...))))]
        [(_ (b ...) f l . ls)
         (or-loop (b ... [id l]) f . ls)])])
    (syntax-rules ()
      [(_ f l ...)
       (or-loop () f l ...)])))


; symbols

; symbols are immediate with immediate tag 4

(%definition "/* symbols */")
(%definition "#define SYMBOL_ITAG 4")  
(%definition "#define issymbol(o) (isimm(o, SYMBOL_ITAG))")
(%definition "#define mksymbol(i) mkimm(i, SYMBOL_ITAG)")
(%definition "#define getsymbol(o) getimmu(o, SYMBOL_ITAG)")

(%localdef "static struct { char **a; char ***v; size_t sz; size_t u; size_t maxu; } symt;")
(%localdef "static unsigned long hashs(char *s) {
  unsigned long i = 0, l = (unsigned long)strlen(s), h = l;
  while (i < l) h = (h << 4) ^ (h >> 28) ^ s[i++];
  return h ^ (h  >> 10) ^ (h >> 20);
}")

(%definition "extern char *symbolname(int sym);")
(%localdef "char *symbolname(int sym) {
  assert(sym >= 0); assert(sym < (int)symt.u);
  return symt.a[sym];
}")

(%definition "extern int internsym(char *name);")
(%localdef "int internsym(char *name) {
  size_t i, j; /* based on a code (C) 1998, 1999 by James Clark. */
  if (symt.sz == 0) { /* init */
    symt.a = cxm_cknull(calloc(64, sizeof(char*)), \"symtab[0]\");
    symt.v = cxm_cknull(calloc(64, sizeof(char**)), \"symtab[1]\");
    symt.sz = 64, symt.maxu = 64 / 2;
    i = hashs(name) & (symt.sz-1);
  } else {
    unsigned long h = hashs(name);
    for (i = h & (symt.sz-1); symt.v[i]; i = (i-1) & (symt.sz-1))
      if (strcmp(name, *symt.v[i]) == 0) return (int)(symt.v[i] - symt.a);
    if (symt.u == symt.maxu) { /* rehash */
      size_t nsz = symt.sz * 2;
      char **na = cxm_cknull(calloc(nsz, sizeof(char*)), \"symtab[2]\");
      char ***nv = cxm_cknull(calloc(nsz, sizeof(char**)), \"symtab[3]\");
      for (i = 0; i < symt.sz; i++)
        if (symt.v[i]) {
          for (j = hashs(*symt.v[i]) & (nsz-1); nv[j]; j = (j-1) & (nsz-1)) ;
          nv[j] = symt.v[i] - symt.a + na;
        }
      free(symt.v); symt.v = nv; symt.sz = nsz; symt.maxu = nsz / 2;
      memcpy(na, symt.a, symt.u * sizeof(char*)); free(symt.a); symt.a = na; 
      for (i = h & (symt.sz-1); symt.v[i]; i = (i-1) & (symt.sz-1)) ;
    }
  }
  *(symt.v[i] = symt.a + symt.u) = 
    strcpy(cxm_cknull(malloc(strlen(name)+1), \"symtab[4]\"), name);
  return (int)((symt.u)++);
}")

(define-syntax %const
  (let-syntax ([old-%const %const])
    (syntax-rules (symbol)
      ; wrap code in #() to force constant lifting
      [(_ symbol s)
       (%prim #("obj(mksymbol(internsym(\"" s "\")))"))]
      [(_ symbol 8 c ...)
       (%prim #("{ static obj o = 0; static char s[] = { " (c ", ") ... "0 };\n"
               "    $return obj(o ? o : (o = mksymbol(internsym(s)))); }"))]
      [(_ arg ...) (old-%const arg ...)]))) 

(define-inline (symbol? x)
  (%prim "bool(issymbol(obj_from_$arg))" x))



; 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;
    int num = fixnum_from_$arg;
    int radix = fixnum_from_$arg;
    if (num < 0) { neg = 1; num = -num; }
    *s = 0;
    do { int d = num % radix; *--s = d < 10 ? d + '0' : d - 10 + 'a'; }
    while (num /= radix);
    if (neg) *--s = '-';
    $return obj(hpushstr($live, newstring(s))); }" n r))

(define (flonum->string x)
  (%prim* "{ /* flonum->string */
    char buf[30], *s;
    sprintf(buf, \"%.17g\", flonum_from_$arg);
    for (s = buf; *s != 0; s++) if (*s == 'e' || *s == '.') break;
    if (*s == 0) {  *s++ = '.'; *s++ = '0'; *s = 0; }
    $return obj(hpushstr($live, newstring(buf))); }" x))

(define-syntax number->string
  (syntax-rules ()
    [(_ n r) (fixnum->string n r)]
    [(_ n) (if (fixnum? n) (fixnum->string n 10) (flonum->string n))]))

(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((int)l); }" s r))

(define (string->flonum s)
  (%prim*? "{ /* string->flonum */
    char *e, *s = stringchars(obj_from_$arg);
    double d = (errno = 0, strtod(s, &e));
    if (errno || e == s || *e) $return bool(0);
    else $return flonum($live, d); }" s))

(define-syntax string->number
  (syntax-rules ()
    [(_ s r) (string->fixnum s r)]
    [(_ s) (or (string->fixnum s 10) (string->flonum s))]))

(define-inline (vector->list v)
  (%prim*? "{ /* vector->list */
    obj v, l = mknull(); int c = fixnum_from_$arg;
    hreserve(hbsz(3)*c, $live); /* $live live regs */
    v = obj_from_$arg; /* gc-safe */
    while (c-- > 0) { *--hp = l; *--hp = hblkref(v, 1+c);
    *--hp = obj_from_size(PAIR_BTAG); l = hendblk(3); }
    $return obj(l); }" (vector-length v) v))

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

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

(define-inline (string->list s)
  (%prim*? "{ /* string->list */
    int c = fixnum_from_$arg;
    unsigned char *s; obj l = mknull();
    hreserve(hbsz(3)*c, $live); /* $live live regs */
    s = (unsigned char *)stringchars(obj_from_$arg); /* gc-safe */
    while (c-- > 0) { *--hp = l; *--hp = obj_from_char(s[c]);
    *--hp = obj_from_size(PAIR_BTAG); l = hendblk(3); }
    $return obj(l); }" (string-length s) s))



; control

; procedures (closures) are heap blocks of length >= 1 which
; have a pointer as 0th element

(define-inline (procedure? o)
  (%prim "{ /* procedure? */
    obj o = obj_from_$arg;
    if (!isobjptr(o)) $return bool(0);
    else { obj h = objptr_from_obj(o)[-1];
    $return bool(notaptr(h) && size_from_obj(h) >= 1 && isaptr(hblkref(o, 0))); } }" o))

; delay & force

(define make-promise
  (lambda (proc)
    ((lambda (result-ready? result)
       (lambda ()
         (if result-ready?
             result
             ((lambda (x)
                (if result-ready?
                    result
                    (begin
                      (set! result-ready? #t)
                      (set! result x)
                      result)))
              (proc)))))
     #f
     #f)))

(define-inline force 
  (lambda (promise)
    (promise)))

(define-syntax delay
  (syntax-rules ()
    [(delay exp)
     (make-promise (lambda () exp))]))



; eof

; eof is immediate -1 with immediate tag 127 (compatible with C EOF)

(%definition "/* eof */")
(%definition "#define EOF_ITAG 127")  
(%definition "#define mkeof() mkimm(-1, EOF_ITAG)")  
(%definition "#define iseof(o) ((o) == mkimm(-1, EOF_ITAG))")  

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

(define-inline (eof-object)
  (%prim "obj(mkeof())"))

(define-inline (eof-object? x)
  (%prim "bool(iseof(obj_from_$arg))" x))



; input ports

(%definition "/* input ports */")
(%localdef "static void ipclose(void *vp) {
  /* FILE *fp = vp; assert(fp); 
   * cannot fclose(fp) here because of FILE reuse! */ 
}")
(%localdef "static cxtype_t cxt_iport = { \"iport\", ipclose };")
(%localdef "cxtype_t *IPORT_NTAG = &cxt_iport;")
(%definition "extern cxtype_t *IPORT_NTAG;")
(%definition "#define isiport(o) (isnative(o, IPORT_NTAG))")
(%definition "#define iportdata(o) ((FILE*)getnative(o, IPORT_NTAG))")
(%definition "#define mkiport(l, fp) hpushptr(fp, IPORT_NTAG, l)")

(define-inline (input-port? x)
  (%prim "bool(isiport(obj_from_$arg))" x))

(define *current-input-port* (%prim* "obj(mkiport($live, stdin))"))
(define-inline (current-input-port) *current-input-port*)

(define-inline (open-input-file fn)
  (%prim*?! "obj(mkiport($live, cxm_cknull(fopen(stringchars(obj_from_$arg), \"r\"), \"fopen\")))" fn))

(define-inline (close-input-port p)
  (%prim?! "void(fclose(iportdata(obj_from_$arg)))" p))
  
(define-inline (call-with-input-file fn proc)      ; proc must return 1 value!
  (let* ([p (open-input-file fn)] [v (proc p)])
    (close-input-port p)
    v))  

(define (with-input-from-file fn thunk)
  (let ([p0 *current-input-port*] [p1 (open-input-file fn)])
    (set! *current-input-port* p1)
    (let ([v (thunk)])                             ; thunk must return 1 value!
      (close-input-port p1)
      (set! *current-input-port* p0)
      v)))

(define-syntax read-char
  (syntax-rules ()
    [(_) (read-char (current-input-port))]
    [(_ p) (%prim?! ("{ int c = fgetc(iportdata(obj_from_$arg));\n"
                "    $return obj(c == EOF ? mkeof() : obj_from_char(c)); }") p)]))

(define-syntax peek-char
  (syntax-rules ()
    [(_) (peek-char (current-input-port))]
    [(_ p) (%prim? ("{ FILE *p = iportdata(obj_from_$arg); int c = fgetc(p); ungetc(c, p);\n"
                "    $return obj(c == EOF ? mkeof() : obj_from_char(c)); }") p)]))



; output ports

(%definition "/* output ports */")
(%localdef "static void opclose(void *vp) {
  /* FILE *fp = vp; assert(fp); 
   * cannot fclose(fp) here because of FILE reuse! */ 
}")
(%localdef "static cxtype_t cxt_oport = { \"oport\", opclose };")
(%localdef "cxtype_t *OPORT_NTAG = &cxt_oport;")
(%definition "extern cxtype_t *OPORT_NTAG;")
(%definition "#define isoport(o) (isnative(o, OPORT_NTAG))")
(%definition "#define oportdata(o) ((FILE*)getnative(o, OPORT_NTAG))")
(%definition "#define mkoport(l, fp) hpushptr(fp, OPORT_NTAG, l)")

(define-inline (output-port? x)
  (%prim "bool(isoport(obj_from_$arg))" x))

(define *current-output-port* (%prim* "obj(mkoport($live, stdout))"))
(define-inline (current-output-port) *current-output-port*)
(define *current-error-port* (%prim* "obj(mkoport($live, stderr))"))
(define-inline (current-error-port) *current-error-port*)

(define-inline (open-output-file fn)
  (%prim*?! "obj(mkoport($live, cxm_cknull(fopen(stringchars(obj_from_$arg), \"w\"), \"fopen\")))" fn))

(define-inline (flush-output-port p)
  (%prim?! "void(fflush(oportdata(obj_from_$arg)))" p))

(define-inline (close-output-port p)
  (%prim?! "void(fclose(oportdata(obj_from_$arg)))" p))
  
(define-inline (call-with-output-file fn proc)      ; proc must return 1 value!
  (let* ([p (open-output-file fn)] [v (proc p)])
    (close-output-port p)
    v))  

(define (with-output-to-file fn thunk)
  (let ([p0 *current-output-port*] [p1 (open-output-file fn)])
    (set! *current-output-port* p1)
    (let ([v (thunk)])                              ; thunk must return 1 value!
      (close-output-port p1)
      (set! *current-output-port* p0)
      v)))

(define-syntax display-fixnum
  (syntax-rules ()
    [(_ n) (display-fixnum n (current-output-port))]
    [(_ n p) (%prim! "void(fprintf(oportdata(obj_from_$arg), \"%d\", fixnum_from_$arg))" p n)])) 

(define-syntax display-flonum
  (syntax-rules ()
    [(_ x) (display-flonum x (current-output-port))]
    [(_ x p) (%prim! "void(fprintf(oportdata(obj_from_$arg), \"%.15g\", flonum_from_$arg))" p x)])) 

(define-syntax write-char
  (syntax-rules ()
    [(_ c) (write-char c (current-output-port))]
    [(_ c p) (%prim! "void(fputc(char_from_$arg, oportdata(obj_from_$arg)))" c p)]))

(define-syntax write-string
  (syntax-rules ()
    [(_ s) (write-string s (current-output-port))]
    [(_ s p) (%prim?! "void(fputs(stringchars(obj_from_$arg), oportdata(obj_from_$arg)))" s p)]))

(define-syntax newline
  (syntax-rules ()
    [(_) (newline (current-output-port))]
    [(_ p) (%prim! "void(fputc('\\n', oportdata(obj_from_$arg)))" p)]))


(define (initial-writer x d? p)

  (define (wrpair x d? p)
    (write-char #\( p)
    (let loop ([x x])
      (*current-writer* (car x) d? p)
      (cond
        [(pair? (cdr x)) (write-char #\space p) (loop (cdr x))]
        [(null? (cdr x))]
        [else (write-string " . " p) (*current-writer* (cdr x) d? p)]))
    (write-char #\) p))

  (define (wrchar x p)
    (cond
      [(char=? x #\newline) (write-string "#\\newline" p)]
      [(char=? x #\space) (write-string "#\\space" p)]
      [else (write-string "#\\" p) (write-char x p)]))

  (define (wrstring x p)
    (write-char #\" p)
    (let ([n (string-length x)])
      (do ([i 0 (+ i 1)]) [(= i n)]
        (let ([c (string-ref x i)])
          (if (or (char=? c #\") (char=? c #\\))
              (write-char #\\ p))
          (write-char c p))))
    (write-char #\" p))

  (define (wrvector x d? p)
    (write-string "#(" p)
    (let ([size (vector-length x)])
      (if (not (= size 0))
          (let ([last (- size 1)])
            (let loop ([i 0])
              (*current-writer* (vector-ref x i) d? p)
              (if (not (= i last))
                  (begin (write-char #\space p) (loop (+ i 1))))))))
    (write-char #\) p))

  (define (wrbox x d? p)
    (write-string "#&" p)
    (*current-writer* (unbox x) d? p))

  (cond
    [(eof-object? x) (write-string "#<eof>" p)]
    [(input-port? x) (write-string "#<iport>" p)]
    [(output-port? x) (write-string "#<oport>" p)]
    [(symbol? x) (write-string (symbol->string x) p)]
    [(pair? x) (wrpair x d? p)]
    [(fixnum? x) (display-fixnum x p)]
    [(flonum? x) (display-flonum x p)]
    [(null? x) (write-string "()" p)]
    [(boolean? x) (write-string (if x "#t" "#f") p)]
    [(char? x) (if d? (write-char x p) (wrchar x p))]
    [(string? x) (if d? (write-string x p) (wrstring x p))]
    [(vector? x) (wrvector x d? p)]
    [(box? x) (wrbox x d? p)]
    [(procedure? x) (write-string "#<procedure>" p)]
    [else (write-string "#<unknown>" p)]))

(define *current-writer* initial-writer)
(define (current-writer) *current-writer*)
(define (set-current-writer! fn) (set! *current-writer* fn))

(define (write/3 x d? port)
  ((current-writer) x d? port))

(define-syntax write
  (syntax-rules ()
    [(_ x) (write/3 x #f (current-output-port))]
    [(_ x p) (write/3 x #f p)]))

(define-syntax display
  (syntax-rules ()
    [(_ x) (write/3 x #t (current-output-port))]
    [(_ x p) (write/3 x #t p)]))

(define (fprintf* port fstr olst)
  (let loop ([flst (string->list fstr)] [olst olst])
    (cond [(null? flst) #t]
          [(char=? (car flst) #\~)
           (and (pair? (cdr flst))
             (let ([c (cadr flst)])
               (cond
                 [(char=? c #\a)
                  (unless (null? olst)
                    (display (car olst) port)
                    (loop (cddr flst) (cdr olst)))]
                 [(char=? c #\s)
                  (unless (null? olst)
                    (write (car olst) port)
                    (loop (cddr flst) (cdr olst)))]
                 [(char=? c #\%) 
                  (newline port) 
                  (loop (cddr flst) olst)]
                 [(char=? c #\~)
                  (write-char #\~ port)
                  (loop (cddr flst) olst)]
                 [else #f])))] ; (error 'format "Unrecognized escape sequence")
          [else
           (write-char (car flst) port)
           (loop (cdr flst) olst)])))

(define-syntax fprintf
  (syntax-rules ()
    [(_ p f o ...) (fprintf* p f (list o ...))]))
    
(define-syntax printf
  (syntax-rules ()
    [(_ f o ...) (fprintf* (current-output-port) f (list o ...))]))

(define-syntax pretty-print write) ; fixme?


; file system

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

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


; equivalence

(%definition "extern int iseqv(obj x, obj y);")
(%localdef "int iseqv(obj x, obj y) {
  obj h; if (x == y) return 1;
  if (!x || !y || notaptr(x) || notaptr(y) || notobjptr(x) || notobjptr(y)) return 0;
  if ((h = objptr_from_obj(x)[-1]) != objptr_from_obj(y)[-1]) return 0;
  if (h == (obj)FLONUM_NTAG) return *(flonum_t*)objptr_from_obj(x)[0] == *(flonum_t*)objptr_from_obj(y)[0]; 
  return 0;
}")

(%definition "extern obj ismemv(obj x, obj l);")
(%localdef "obj ismemv(obj x, obj l) {
  if (!x || notaptr(x) || notobjptr(x)) {
    for (; l != mknull(); l = cdr(l)) 
      { if (car(l) == x) return l; }
  } else if (is_flonum_obj(x)) {
    flonum_t fx = flonum_from_obj(x); 
    for (; l != mknull(); l = cdr(l)) 
      { obj y = car(l); if (is_flonum_obj(y) && fx == flonum_from_obj(y)) return l; }
  } else { /* for others, memv == memq */
    for (; l != mknull(); l = cdr(l)) 
      { if (car(l) == x) return l; }
  } return 0;
}")

(%definition "extern obj isassv(obj x, obj l);")
(%localdef "obj isassv(obj x, obj l) {
  if (!x || notaptr(x) || notobjptr(x)) {
    for (; l != mknull(); l = cdr(l)) 
      { obj p = car(l); if (car(p) == x) return p; }
  } else if (is_flonum_obj(x)) {
    flonum_t fx = flonum_from_obj(x); 
    for (; l != mknull(); l = cdr(l)) 
      { obj p = car(l), y = car(p); if (is_flonum_obj(y) && fx == flonum_from_obj(y)) return p; }
  } else { /* for others, assv == assq */
    for (; l != mknull(); l = cdr(l)) 
      { obj p = car(l); if (car(p) == x) return p; }
  } return 0;
}")

(%definition "extern int isequal(obj x, obj y);")
(%localdef "int isequal(obj x, obj y) {
  obj h; int i, n; loop: if (x == y) return 1;
  if (!x || !y || notaptr(x) || notaptr(y) || notobjptr(x) || notobjptr(y)) return 0;
  if ((h = objptr_from_obj(x)[-1]) != objptr_from_obj(y)[-1]) return 0;
  if (h == (obj)FLONUM_NTAG) return *(flonum_t*)objptr_from_obj(x)[0] == *(flonum_t*)objptr_from_obj(y)[0]; 
  if (h == (obj)STRING_NTAG) return strcmp(stringchars(x), stringchars(y)) == 0; 
  if (isaptr(h) || !(n = size_from_obj(h)) || hblkref(x, 0) != hblkref(y, 0)) return 0;
  for (i = 1; i < n-1; ++i) if (!isequal(hblkref(x, i), hblkref(y, i))) return 0;
  if (i == n-1) { x = hblkref(x, i); y = hblkref(y, i); goto loop; } else return 1; 
}")

(%definition "extern obj ismember(obj x, obj l);")
(%localdef "obj ismember(obj x, obj l) {
  if (!x || notaptr(x) || notobjptr(x)) {
    for (; l != mknull(); l = cdr(l)) 
      { if (car(l) == x) return l; }
  } else if (is_flonum_obj(x)) {
    flonum_t fx = flonum_from_obj(x); 
    for (; l != mknull(); l = cdr(l)) 
      { obj y = car(l); if (is_flonum_obj(y) && fx == flonum_from_obj(y)) return l; }
  } else if (isstring(x)) {
    char *xs = stringchars(x);
    for (; l != mknull(); l = cdr(l)) 
      { obj y = car(l); if (isstring(y) && 0 == strcmp(xs, stringchars(y))) return l; }
  } else {
    for (; l != mknull(); l = cdr(l)) 
      { if (isequal(car(l), x)) return l; }
  } return 0;
}")

(%definition "extern obj isassoc(obj x, obj l);")
(%localdef "obj isassoc(obj x, obj l) {
  if (!x || notaptr(x) || notobjptr(x)) {
    for (; l != mknull(); l = cdr(l)) 
      { obj p = car(l); if (car(p) == x) return p; }
  } else if (is_flonum_obj(x)) {
    flonum_t fx = flonum_from_obj(x); 
    for (; l != mknull(); l = cdr(l)) 
      { obj p = car(l), y = car(p); if (is_flonum_obj(y) && fx == flonum_from_obj(y)) return p; }
  } else if (isstring(x)) {
    char *xs = stringchars(x);
    for (; l != mknull(); l = cdr(l)) 
      { obj p = car(l), y = car(p); if (isstring(y) && 0 == strcmp(xs, stringchars(y))) return p; }
  } else {
    for (; l != mknull(); l = cdr(l)) 
      { obj p = car(l); if (isequal(car(p), x)) return p; }
  } return 0;
}")

(define-inline (eq? x y)
  (%prim "bool(obj_from_$arg == obj_from_$arg)" x y))

(define-inline (eqv? x y)
  (or (eq? x y) (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 result1 . results))
         (begin result1 . results)]
        [(case key ((datum ...) result1 . results) . clauses)
         (if (compare key (datum ...))
             (begin result1 . results)
             (case key . clauses))])])
     (syntax-rules ()
       [(_ expr clause1 clause ...)
        (let ([key expr]) (case key clause1 clause ...))])))

(define-inline (memq x l)
  (%prim? "{ /* memq */
    obj x = obj_from_$arg, l = obj_from_$arg;
    for (; l != mknull(); l = cdr(l)) if (car(l) == x) break;
    $return obj(l == mknull() ? obj_from_bool(0) : l); }" x l)) 

(define-inline (memv x l)
  (%prim? "obj(ismemv(obj_from_$arg, obj_from_$arg))" x l)) 

(define-inline (member x l)
  (%prim? "obj(ismember(obj_from_$arg, obj_from_$arg))" x l)) 

(define-inline (assq x l)
  (%prim? "{ /* assq */
    obj x = obj_from_$arg, l = obj_from_$arg, p = mknull();
    for (; l != mknull(); l = cdr(l)) { p = car(l); if (car(p) == x) break; }
    $return obj(l == mknull() ? obj_from_bool(0) : p); }" x l)) 

(define-inline (assv x l)
  (%prim? "obj(isassv(obj_from_$arg, obj_from_$arg))" x l)) 

(define-inline (assoc x l)
  (%prim? "obj(isassoc(obj_from_$arg, obj_from_$arg))" x l)) 


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

; miscellaneous / system

(define-syntax exit
  (syntax-rules ()
    [(_) (exit 0)]
    [(_ n) (%prim! "void(exit(fixnum_from_$arg))" n)]))

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

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

(define-inline (argv->list argv)
  (let loop ([r '()] [i (%prim "fixnum(0)")])
    (let ([arg (argv-ref argv i)])
      (if arg 
          (loop (cons arg r) (fx+ i (%prim "fixnum(1)")))
          (reverse! r)))))


; errors

(define-syntax error
  (syntax-rules ()
    [(_ where fmt arg ...)
     (let ([ep (current-error-port)])
       (newline ep)
       (if where
           (fprintf* ep "Error in ~a: " (list where))
           (display "Error: " ep))
       (fprintf* ep fmt (list arg ...))
       (display ".\n" ep)
       (reset))]))


; variants

(define-syntax variant-case
  (syntax-rules (else)
    [(_ (a . d) clause ...)
     (let ([var (a . d)]) (variant-case var clause ...))]
    [(_ var) (error 'variant-case "no clause matches ~s" var)]
    [(_ var (else exp1 exp2 ...)) (begin exp1 exp2 ...)]
    [(_ var (name (field ...) exp1 exp2 ...) clause ...)
     (if (#&(string->id #&(string-append #&(id->string name) "?")) var)
         (let ([field (#&(string->id #&(string-append #&(id->string name) "->" #&(id->string field))) var)] ...)
           exp1 exp2 ...)
         (variant-case var clause ...))]))

(define-syntax define-variant
  (syntax-rules ()
    [(_ name () ([field0 index0] ...))
     (begin
       (define-syntax name
         (lambda (field0 ...)
           (vector 'name field0 ...)))
       (define-syntax #&(string->id #&(string-append #&(id->string name) "?"))
         (lambda (object)
           (and (vector? object)
             (= (vector-length object) #&(length (name field0 ...)))
             (eq? (vector-ref object 0) 'name))))
       (define-syntax #&(string->id #&(string-append #&(id->string name) "->" #&(id->string field0)))
         (lambda (object)
           (vector-ref object index0)))
       ...)]
    [(_ name (field0 field ...) (pair ...))
     (define-variant name (field ...)  (pair ... [field0 #&(length (name pair ...))]))]
    [(_ name (field0 ...))
     (define-variant name (field0 ...) ())]))