r6rs_lib.js

import { TopEnv, CoreEnv, nil, undef } from "../header.js";
import { define_libfunc, alias_libfunc, define_syntax, define_scmfunc,
         assert_number, assert_integer, assert_real, assert_between, assert_string,
         assert_char, assert_symbol, assert_port, assert_pair, assert_list,
         assert_vector, assert_hashtable, assert_mutable_hashtable, assert_promise,
         assert_function, assert_closure, assert_procedure, assert_date, assert, deprecate,
         parse_fraction, parse_integer, parse_float  } from "./infra.js"; 
import { eq, eqv, equal } from "../system/_equality.js"
import { to_write, to_display, inspect, write_shared, write_simple } from "../system/_writer.js"
import { isNil, isSymbol, isVector, isProcedure, lt } from "../system/_types.js"
import Call from "../system/call.js"
import { Char } from "../system/char.js"
import { Bug, BiwaError, UserError } from "../system/error.js"
import { Enumeration, assert_enum_set } from "../system/enumeration.js"
import { Hashtable } from "../system/hashtable.js"
import Interpreter from "../system/interpreter.js"
import { Complex, Rational, isNumber, isComplex, isReal, isRational, isInteger } from "../system/number.js"
import { Pair, List, isPair, isList, array_to_list, deep_array_to_list, Cons } from "../system/pair.js"
import { Port, eof } from "../system/port.js"
import { BiwaPromise } from "../system/promise.js"
import { Record, isRecord, assert_record, assert_record_td, assert_record_cd } from "../system/record.js"
import { BiwaSymbol, Sym, gensym } from "../system/symbol.js"
import Values from "../system/values.js"

///
/// R6RS Base library
///

//
//        11.4  Expressions
//
//            11.4.1  Quotation
//(quote)
//            11.4.2  Procedures
//(lambda)
//            11.4.3  Conditionaar
//(if)
//            11.4.4  Assignments
//(set!)
//            11.4.5  Derived conditionaar

define_syntax("cond", function(x){
  var clauses = x.cdr;
  if(!(clauses instanceof Pair) || clauses === nil){
    throw new BiwaError("malformed cond: cond needs list but got " +
                    write_ss(clauses));
  }
  // TODO: assert that clauses is a proper list

  var ret = null;
  clauses.to_array().reverse().forEach(function(clause){
    if(!(clause instanceof Pair)){
      throw new BiwaError("bad clause in cond: " + write_ss(clause));
    }

    if(clause.car === Sym("else")){
      if(ret !== null){
        throw new BiwaError("'else' clause of cond followed by more clauses: " +
                        write_ss(clauses));
      }
      else if(clause.cdr === nil){
        // pattern A: (else)
        //  -> #f            ; not specified in R6RS...?
        ret = false;
      }
      else if(clause.cdr.cdr === nil){
        // pattern B: (else expr)
        //  -> expr
        ret = clause.cdr.car;
      }
      else{
        // pattern C: (else expr ...)
        //  -> (begin expr ...)
        ret = new Pair(Sym("begin"), clause.cdr);
      }
    }
    else{
      var test = clause.car;
      if(clause.cdr === nil){
        // pattern 1: (test)
        //  -> (or test ret)
        ret = List(Sym("or"), test, ret);
      }
      else if (clause.cdr.cdr === nil){
        // pattern 2: (test expr)
        //  -> (if test expr ret)
        ret = List(Sym("if"), test, clause.cdr.car, ret);
      }
      else if(clause.cdr.car === Sym("=>")){
        // pattern 3: (test => expr)
        //  -> (let ((#<gensym1> test))
        //       (if test (expr #<gensym1>) ret))
        var test = clause.car, expr = clause.cdr.cdr.car;
        var tmp_sym = gensym();

        ret = List(Sym("let"),
                   List( List(tmp_sym, test) ),
                   List(Sym("if"), test, List(expr, tmp_sym), ret));
      }
      else{
        // pattern 4: (test expr ...)
        //  -> (if test (begin expr ...) ret)
        ret = List(Sym("if"), test,
                   new Pair(Sym("begin"), clause.cdr),
                   ret);
      }
    }
  });
  return ret;
});

define_syntax("case", function(x){
  var tmp_sym = gensym();

  if(x.cdr === nil){
    throw new BiwaError("case: at least one clause is required");
  }
  else if(!(x.cdr instanceof Pair)){
    throw new BiwaError("case: proper list is required");
  }
  else{
    // (case key clauses ....)
    //  -> (let ((#<gensym1> key))
    var key = x.cdr.car;
    var clauses = x.cdr.cdr;

    var ret = undefined;
    clauses.to_array().reverse().forEach(function(clause){
      if(clause.car === Sym("else")){
        // pattern 0: (else expr ...)
        //  -> (begin expr ...)
        if(ret === undefined){
          ret = new Pair(Sym("begin"), clause.cdr);
        }
        else{
          throw new BiwaError("case: 'else' clause followed by more clauses: " +
                          write_ss(clauses));
        }
      }
      else{
        // pattern 1: ((datum ...) expr ...)
        //  -> (if (or (eqv? key (quote d1)) ...) (begin expr ...) ret)
        ret = List(
          Sym("if"),
          new Pair(Sym("or"), array_to_list(clause.car.to_array().map(function(d){
              return List(Sym("eqv?"),
                          tmp_sym,
                          List(Sym("quote"), d));
          }))),
          new Pair(Sym("begin"), clause.cdr),
          ret
        );
      }
    });
    return new Pair(Sym("let1"),
             new Pair(tmp_sym,
               new Pair(key,
                 new Pair(ret, nil))));
  }
});

define_syntax("and", function(x){
  // (and a b c) => (if a (if b c #f) #f)
  //todo: check improper list
  if(x.cdr == nil) return true;

  var objs = x.cdr.to_array();
  var i = objs.length-1;
  var t = objs[i];
  for(i=i-1; i>=0; i--)
    t = List(Sym("if"), objs[i], t, false);

  return t;
})

define_syntax("or", function(x){
  // (or a b c) => (if a a (if b b (if c c #f)))
  //todo: check improper list

  var objs = x.cdr.to_array()
  var f = false;
  for(var i=objs.length-1; i>=0; i--)
    f = List(Sym("if"), objs[i], objs[i], f);

  return f;
})

//            11.4.6  Binding constructs
define_syntax("let", function(x){
  //(let ((a 1) (b 2)) (print a) (+ a b))
  //=> ((lambda (a b) (print a) (+ a b)) 1 2)
  var name = null;
  if (x.cdr.car instanceof BiwaSymbol) {
    name = x.cdr.car;
    x = x.cdr;
  }
  var binds = x.cdr.car, body = x.cdr.cdr;

  if((!(binds instanceof Pair)) && binds != nil){
    throw new BiwaError("let: need a pair for bindings: got "+to_write(binds));
  }

  var vars = nil, vals = nil;
  for(var p=binds; p instanceof Pair; p=p.cdr){
    if(!(p.car instanceof Pair)){
      throw new BiwaError("let: need a pair for bindings: got "+to_write(p.car));
    }
    vars = new Pair(p.car.car, vars);
    vals = new Pair(p.car.cdr.car, vals);
  }

  var lambda = null;
  if (name) {
    // (let loop ((a 1) (b 2)) body ..)
    //=> (letrec ((loop (lambda (a b) body ..))) (loop 1 2))
    vars = array_to_list(vars.to_array().reverse());
    vals = array_to_list(vals.to_array().reverse());

    var body_lambda = new Pair(Sym("lambda"), new Pair(vars, body));
    var init_call = new Pair(name, vals);

    lambda = List(Sym("letrec"),
                  new Pair(List(name, body_lambda), nil),
                  init_call);
  }
  else {
    lambda = new Pair(new Pair(Sym("lambda"),
                               new Pair(vars, body)),
                      vals);
  }
  return lambda;
})

define_syntax("let*", function(x){
  //(let* ((a 1) (b a)) (print a) (+ a b))
  //-> (let ((a 1))
  //     (let ((b a)) (print a) (+ a b)))
  var binds = x.cdr.car, body = x.cdr.cdr;

  if(binds === nil)
    return new Pair(Sym("let"), new Pair(nil, body));

  if(!(binds instanceof Pair))
    throw new BiwaError("let*: need a pair for bindings: got "+to_write(binds));

  var ret = null;
  binds.to_array().reverse().forEach(function(bind){
    ret = new Pair(Sym("let"),
             new Pair(new Pair(bind, nil),
               ret == null ? body : new Pair(ret, nil)));
  })
  return ret;
})

var expand_letrec_star = function(x){
  var binds = x.cdr.car, body = x.cdr.cdr;

  if(!(binds instanceof Pair))
    throw new BiwaError("letrec*: need a pair for bindings: got "+to_write(binds));

  var ret = body;
  binds.to_array().reverse().forEach(function(bind){
    ret = new Pair(new Pair(Sym("set!"), bind),
            ret);
  })
  var letbody = nil;
  binds.to_array().reverse().forEach(function(bind){
    letbody = new Pair(new Pair(bind.car,
                         new Pair(undef, nil)),
                letbody);
  })
  return new Pair(Sym("let"),
           new Pair(letbody,
             ret));
}
define_syntax("letrec", expand_letrec_star);
define_syntax("letrec*", expand_letrec_star);

define_syntax("let-values", function(x) {
  // (let-values (((a b) (values 1 2))
  //               ((c d . e) (values 3 4 a)))
  //              (print a b c d e))
  // =>
  // (let ((#<gensym1> (lambda () (values 1 2)))
  //       (#<gensym2> (lambda () (values 3 4 a))))
  //   (let*-values (((a b) #<gensym1>)
  //                 ((c d . e) #<gensym2>))
  //                 (print a b c d e)))
    var mv_bindings = x.cdr.car;
    var body = x.cdr.cdr;
    var ret = null;

    var let_bindings = nil;
    var let_star_values_bindings = nil;
    mv_bindings.to_array().reverse().forEach(function (item) {
  var init = item.cdr.car;
  var tmpsym = gensym()
  var binding = new Pair(tmpsym,
       new Pair(
          new Pair(Sym("lambda"), new Pair(nil,
                   new Pair(init, nil))),
          nil));
  let_bindings = new Pair(binding, let_bindings);

  var formals = item.car;
  let_star_values_bindings = new Pair(new Pair (formals, new Pair(new Pair(tmpsym, nil), nil)),
              let_star_values_bindings);
    });

    var let_star_values = new Pair(Sym("let*-values"),
           new Pair(let_star_values_bindings,
              body));
    ret = new Pair(Sym("let"),
       new Pair(let_bindings,
          new Pair (let_star_values, nil)));
    return ret;

});

//let*-values
define_syntax("let*-values", function(x){
  // (let*-values (((a b) (values 1 2))
  //               ((c d . e) (values 3 4 a)))
  //   (print a b c d e))
  // -> (call-with-values
  //      (lambda () (values 1 2))
  //      (lambda (a b)
  //        (call-with-values
  //          (lambda () (values 3 4 a))
  //          (lambda (c d . e)
  //            (print a b c d e)))))
  var mv_bindings = x.cdr.car;
  var body = x.cdr.cdr;

  var ret = null;

  mv_bindings.to_array().reverse().forEach(function(item){
    var formals = item.car, init = item.cdr.car;
    ret = new Pair(Sym("call-with-values"),
            new Pair(new Pair(Sym("lambda"),
                       new Pair(nil,
                         new Pair(init, nil))),
              new Pair(new Pair(Sym("lambda"),
                         new Pair(formals,
                           (ret == null ? body
                                        : new Pair(ret, nil)))), nil)));
  });
  return ret;
});
//            11.4.7  Sequencing
//(begin)

//
//        11.5  Equivalence predicates
//
define_libfunc("eqv?", 2, 2, function(ar){
  return eqv(ar[0], ar[1]);
})
define_libfunc("eq?", 2, 2, function(ar){
  return eq(ar[0], ar[1]);
})
define_libfunc("equal?", 2, 2, function(ar){
  return equal(ar[0], ar[1]);
})

//
//        11.6  Procedure predicate
//
//"procedure?", 1, 1
define_libfunc("procedure?", 1, 1, function(ar){
  return isProcedure(ar[0]);
})

//
//        11.7  Arithmetic
//

//            11.7.1  Propagation of exactness and inexactness
//            11.7.2  Representability of infinities and NaNs
//            11.7.3  Semantics of common operations
//                11.7.3.1  Integer division
//                11.7.3.2  Transcendental functions
//(no functions are introduced by above sections)

//
//            11.7.4  Numerical operations
//

//                11.7.4.1  Numerical type predicates
define_libfunc("number?", 1, 1, function(ar){
  return isNumber(ar[0]);
});
define_libfunc("complex?", 1, 1, function(ar){
  return isComplex(ar[0]);
});
define_libfunc("real?", 1, 1, function(ar){
  return isReal(ar[0]);
});
define_libfunc("rational?", 1, 1, function(ar){
  return isRational(ar[0]);
});
define_libfunc("integer?", 1, 1, function(ar){
  return isInteger(ar[0]);
});

//(real-valued? obj)    procedure
//(rational-valued? obj)    procedure
//(integer-valued? obj)    procedure
//
//(exact? z)    procedure
//(inexact? z)    procedure

//                11.7.4.2  Generic conversions
//
//(inexact z)    procedure
//(exact z)    procedure
//
//                11.7.4.3  Arithmetic operations

//inf & nan: ok (for this section)
define_libfunc("=", 2, null, function(ar){
  var v = ar[0];
  assert_number(ar[0]);
  for(var i=1; i<ar.length; i++){
    assert_number(ar[i]);
    if(real_part(ar[i]) != real_part(v)) return false;
    if(imag_part(ar[i]) != imag_part(v)) return false;
  }
  return true;
});
define_libfunc("<", 2, null, function(ar){
  assert_number(ar[0]);
  for(var i=1; i<ar.length; i++){
    assert_number(ar[i]);
    if(!(ar[i-1] < ar[i])) return false;
  }
  return true;
});
define_libfunc(">", 2, null, function(ar){
  assert_number(ar[0]);
  for(var i=1; i<ar.length; i++){
    assert_number(ar[i]);
    if(!(ar[i-1] > ar[i])) return false;
  }
  return true;
});
define_libfunc("<=", 2, null, function(ar){
  assert_number(ar[0]);
  for(var i=1; i<ar.length; i++){
    assert_number(ar[i]);
    if(!(ar[i-1] <= ar[i])) return false;
  }
  return true;
});
define_libfunc(">=", 2, null, function(ar){
  assert_number(ar[0]);
  for(var i=1; i<ar.length; i++){
    assert_number(ar[i]);
    if(!(ar[i-1] >= ar[i])) return false;
  }
  return true;
});

define_libfunc("zero?", 1, 1, function(ar){
  assert_number(ar[0]);
  return ar[0] === 0;
});
define_libfunc("positive?", 1, 1, function(ar){
  assert_number(ar[0]);
  return (ar[0] > 0);
});
define_libfunc("negative?", 1, 1, function(ar){
  assert_number(ar[0]);
  return (ar[0] < 0);
});
define_libfunc("odd?", 1, 1, function(ar){
  assert_number(ar[0]);
  return (ar[0] % 2 == 1) || (ar[0] % 2 == -1);
})
define_libfunc("even?", 1, 1, function(ar){
  assert_number(ar[0]);
  return ar[0] % 2 == 0;
})
define_libfunc("finite?", 1, 1, function(ar){
  assert_number(ar[0]);
  return (ar[0] != Infinity) && (ar[0] != -Infinity) && !isNaN(ar[0]);
})
define_libfunc("infinite?", 1, 1, function(ar){
  assert_number(ar[0]);
  return (ar[0] == Infinity) || (ar[0] == -Infinity);
})
define_libfunc("nan?", 1, 1, function(ar){
  assert_number(ar[0]);
  return isNaN(ar[0]);
})
define_libfunc("max", 2, null, function(ar){
  for(var i=0; i<ar.length; i++)
    assert_number(ar[i]);

  return Math.max.apply(null, ar)
});
define_libfunc("min", 2, null, function(ar){
  for(var i=0; i<ar.length; i++)
    assert_number(ar[i]);

  return Math.min.apply(null, ar);
});

var complex_or_real = function(real,imag){
  if(imag === 0) return real;
  return new Complex(real,imag);
}
var polar_or_real = function(magnitude, angle){
    if(angle === 0) return magnitude;
    return Complex.from_polar(magnitude, angle);
}
define_libfunc("+", 0,null, function(ar){
  var real = 0;
  var imag = 0;
  for(var i=0; i<ar.length; i++){
    assert_number(ar[i]);
    real+=real_part(ar[i]);
    imag+=imag_part(ar[i]);
  }
  return complex_or_real(real,imag);
});
var the_magnitude = function(n) {
    if(n instanceof Complex) return n.magnitude();
    return n;
}
var the_angle = function(n) {
    if(n instanceof Complex) return n.angle();
    return 0;
}
define_libfunc("*", 0,null, function(ar){
  var magnitude = 1;
  var angle = 0;
  for(var i=0; i<ar.length; i++){
    assert_number(ar[i]);
    magnitude*=the_magnitude(ar[i]);
    angle+=the_angle(ar[i]);
  }
  return polar_or_real(magnitude, angle);
});
define_libfunc("-", 1,null, function(ar){
  var len = ar.length;
  assert_number(ar[0]);

  if(len == 1) {
    if(ar[0] instanceof Complex) return new Complex(-real_part(ar[0]),-imag_part(ar[0]));
    return -ar[0];
  }
  else{
    var real = real_part(ar[0]);
    var imag = imag_part(ar[0]);
    for(var i=1; i<len; i++){
      assert_number(ar[i]);
      real-=real_part(ar[i]);
      imag-=imag_part(ar[i]);
    }
    return complex_or_real(real,imag);
  }
});
//for r6rs specification, (/ 0 0) or (/ 3 0) raises '&assertion exception'
define_libfunc("/", 1,null, function(ar){
  var len = ar.length;
  assert_number(ar[0]);

  if(len == 1){
    if (ar[0] instanceof Complex) return Complex.from_polar(1/the_magnitude(ar[0]), -the_angle(ar[0]));
    return 1/ar[0];
  }
  else{
    var magnitude = the_magnitude(ar[0]);
    var angle = the_angle(ar[0]);
    for(var i=1; i<len; i++){
      assert_number(ar[i]);
      magnitude/=the_magnitude(ar[i]);
      angle-=the_angle(ar[i]);
    }
    return polar_or_real(magnitude, angle);
  }
});

define_libfunc("abs", 1, 1, function(ar){
  assert_number(ar[0]);
  return Math.abs(ar[0]);
});

var div = function(n, m){
  return Math.floor(n / m);
}
var mod = function(n, m){
  return n - Math.floor(n / m) * m;
}
var div0 = function(n, m){
  return (n > 0) ? Math.floor(n / m) : Math.ceil(n / m);
}
var mod0 = function(n, m){
  return (n > 0) ? n - Math.floor(n / m) * m
                 : n - Math.ceil(n / m) * m;
}
define_libfunc("div-and-mod", 2, 2, function(ar){
  assert_number(ar[0]);
  assert_number(ar[1]);
  return new Values([div(ar[0], ar[1]), mod(ar[0], ar[1])]);
})
define_libfunc("div", 2, 2, function(ar){
  assert_number(ar[0]);
  assert_number(ar[1]);
  return div(ar[0], ar[1]);
})
define_libfunc("mod", 2, 2, function(ar){
  assert_number(ar[0]);
  assert_number(ar[1]);
  return mod(ar[0], ar[1]);
})
define_libfunc("div0-and-mod0", 2, 2, function(ar){
  assert_number(ar[0]);
  assert_number(ar[1]);
  return new Values([div0(ar[0], ar[1]), mod0(ar[0], ar[1])]);
})
define_libfunc("div0", 2, 2, function(ar){
  assert_number(ar[0]);
  assert_number(ar[1]);
  return div0(ar[0], ar[1]);
})
define_libfunc("mod0", 2, 2, function(ar){
  assert_number(ar[0]);
  assert_number(ar[1]);
  return mod0(ar[0], ar[1]);
})

// R7RS
alias_libfunc("div-and-mod"       , "floor/"            );
alias_libfunc("div"               , "floor-quotient"    );
alias_libfunc("mod"               , "floor-remainder"   );
var truncate_q = function(n, m){
  return Math.trunc(n / m);
}
var truncate_r = function(n, m){
  return n - Math.trunc(n / m) * m;
}
define_libfunc("truncate/", 2, 2, function(ar){
  assert_number(ar[0]);
  assert_number(ar[1]);
  return new Values([truncate_q(ar[0], ar[1]), truncate_r(ar[0], ar[1])]);
})
define_libfunc("truncate-quotient", 2, 2, function(ar){
  assert_number(ar[0]);
  assert_number(ar[1]);
  return truncate_q(ar[0], ar[1]);
})
define_libfunc("truncate-remainder", 2, 2, function(ar){
  assert_number(ar[0]);
  assert_number(ar[1]);
  return truncate_r(ar[0], ar[1]);
})
alias_libfunc("truncate-quotient" , "quotient"          );
alias_libfunc("truncate-remainder", "remainder"         );
alias_libfunc("floor-remainder"   , "modulo"            );

//(gcd n1 ...)    procedure
//(lcm n1 ...)    procedure

define_libfunc("numerator", 1, 1, function(ar){
  assert_number(ar[0]);
  if(ar[0] instanceof Rational)
    return ar[0].numerator;
  else
    throw new Bug("todo");
})
define_libfunc("denominator", 1, 1, function(ar){
  assert_number(ar[0]);
  if(ar[0] instanceof Rational)
    return ar[0].denominator;
  else
    throw new Bug("todo");
})
define_libfunc("floor", 1, 1, function(ar){
  assert_number(ar[0]);
  return Math.floor(ar[0]);
})
define_libfunc("ceiling", 1, 1, function(ar){
  assert_number(ar[0]);
  return Math.ceil(ar[0]);
})
define_libfunc("truncate", 1, 1, function(ar){
  assert_number(ar[0]);
  return (ar[0] < 0) ? Math.ceil(ar[0]) : Math.floor(ar[0]);
})
define_libfunc("round", 1, 1, function(ar){
  assert_number(ar[0]);
  return Math.round(ar[0]);
})

//(rationalize x1 x2)    procedure

define_libfunc("exp", 1, 1, function(ar){
  assert_number(ar[0]);
  return Math.exp(ar[0]);
})
define_libfunc("log", 1, 2, function(ar){
  var num = ar[0], base = ar[1];
  assert_number(num);

  if(base){ // log b num == log e num / log e b
    assert_number(base);
    return Math.log(num) / Math.log(base)
  }
  else
    return Math.log(num);
})
define_libfunc("sin", 1, 1, function(ar){
  assert_number(ar[0]);
  return Math.sin(ar[0]);
})
define_libfunc("cos", 1, 1, function(ar){
  assert_number(ar[0]);
  return Math.cos(ar[0]);
})
define_libfunc("tan", 1, 1, function(ar){
  assert_number(ar[0]);
  return Math.tan(ar[0]);
})
define_libfunc("asin", 1, 1, function(ar){
  assert_number(ar[0]);
  return Math.asin(ar[0]);
})
define_libfunc("acos", 1, 1, function(ar){
  assert_number(ar[0]);
  return Math.acos(ar[0]);
})
define_libfunc("atan", 1, 2, function(ar){
  assert_number(ar[0]);
  if(ar.length == 2){
    assert_number(ar[1]);
    return Math.atan2(ar[0], ar[1]);
  }
  else
    return Math.atan(ar[0]);
})
define_libfunc("sqrt", 1, 1, function(ar){
  assert_number(ar[0]);
  return Math.sqrt(ar[0]);
})
define_libfunc("exact-integer-sqrt", 1, 1, function(ar){
  assert_number(ar[0]);
  var sqrt_f = Math.sqrt(ar[0]);
  var sqrt_i = sqrt_f - (sqrt_f % 1);
  var rest   = ar[0] - sqrt_i * sqrt_i;

  return new Values([sqrt_i, rest]);
})
define_libfunc("expt", 2, 2, function(ar){
  assert_number(ar[0]);
  assert_number(ar[1]);
  return Math.pow(ar[0], ar[1]);
})
define_libfunc("make-rectangular", 2, 2, function(ar){
  assert_number(ar[0]);
  assert_number(ar[1]);
  return new Complex(ar[0], ar[1]);
})
define_libfunc("make-polar", 2, 2, function(ar){
  assert_number(ar[0]);
  assert_number(ar[1]);
  return Complex.from_polar(ar[0], ar[1]);
})
var real_part = function(n) {
  return Complex.assure(n).real;
}
var imag_part = function(n) {
  return Complex.assure(n).imag;
}
define_libfunc("real-part", 1, 1, function(ar){
  assert_number(ar[0]);
  return real_part(ar[0]);
})
define_libfunc("imag-part", 1, 1, function(ar){
  assert_number(ar[0]);
  return Complex.assure(ar[0]).imag;
})
define_libfunc("magnitude", 1, 1, function(ar){
  assert_number(ar[0]);
  return Complex.assure(ar[0]).magnitude();
})
define_libfunc("angle", 1, 1, function(ar){
  assert_number(ar[0]);
  return Complex.assure(ar[0]).angle();
})

//
//                11.7.4.4  Numerical Input and Output
//
define_libfunc("number->string", 1, 3, function(ar){
  var z = ar[0], radix = ar[1], precision = ar[2];
  if(precision)
    throw new Bug("number->string: precision is not yet implemented");

  radix = radix || 10;  //TODO: check radix is 2, 8, 10, or 16.
  return z.toString(radix);
})
define_libfunc("string->number", 1, 3, function(ar){
  var s = ar[0];

  if (s === '+inf.0')
    return Infinity;

  if (s === '-inf.0')
    return -Infinity;

  if (s === '+nan.0')
    return NaN;

  var radix = ar[1];
  
  var int_res = parse_integer(
    s, radix === 0 ? 0 : radix || 10
  );

  if (int_res !== false)
    return int_res;

  if (radix !== undefined && radix !== 10)
    return false;

  var fp_res = parse_float(s);

  if (fp_res !== false)
    return fp_res;

  var frac_res = parse_fraction(s);

  if (frac_res !== false)
    return frac_res;

  return false;
})

//
//        11.8  Booleans
//

define_libfunc("not", 1, 1, function(ar){
  return (ar[0] === false) ? true : false;
});
define_libfunc("boolean?", 1, 1, function(ar){
  return (ar[0] === false || ar[0] === true) ? true : false;
});
define_libfunc("boolean=?", 2, null, function(ar){
  var len = ar.length;
  for(var i=1; i<len; i++){
    if(ar[i] != ar[0]) return false;
  }
  return true;
});

//        11.9  Pairs and lists

define_libfunc("pair?", 1, 1, function(ar){
  return (ar[0] instanceof Pair) ? true : false;
});
define_libfunc("cons", 2, 2, function(ar){
  return new Pair(ar[0], ar[1]);
});
define_libfunc("car", 1, 1, function(ar){
  //should raise &assertion for '()...
  if(!(ar[0] instanceof Pair)) throw new BiwaError("Attempt to apply car on " + ar[0]);
  return ar[0].car;
});
define_libfunc("cdr", 1, 1, function(ar){
  //should raise &assertion for '()...
  if(!(ar[0] instanceof Pair)) throw new BiwaError("Attempt to apply cdr on " + ar[0]);
  return ar[0].cdr;
});
define_libfunc("set-car!", 2, 2, function(ar){
  if(!(ar[0] instanceof Pair)) throw new BiwaError("Attempt to apply set-car! on " + ar[0]);
  ar[0].car = ar[1];
  return undef;
});
define_libfunc("set-cdr!", 2, 2, function(ar){
  if(!(ar[0] instanceof Pair)) throw new BiwaError("Attempt to apply set-cdr! on " + ar[0]);
  ar[0].cdr = ar[1];
  return undef;
});

// cadr, caddr, cadddr, etc.
(function(){
  // To traverse into pair and raise error
  var get = function(funcname, spec, obj){
    var ret = obj;
    spec.forEach(function(is_cdr){
      if(ret instanceof Pair){
        ret = (is_cdr ? ret.cdr : ret.car);
      }
      else{
        throw new BiwaError(funcname+": attempt to get "+(is_cdr ? "cdr" : "car")+" of "+ret);
      }
    });
    return ret;
  };
  define_libfunc("caar", 1, 1, function(ar){ return get("caar", [0, 0], ar[0]); });
  define_libfunc("cadr", 1, 1, function(ar){ return get("cadr", [1, 0], ar[0]); });
  define_libfunc("cdar", 1, 1, function(ar){ return get("cadr", [0, 1], ar[0]); });
  define_libfunc("cddr", 1, 1, function(ar){ return get("cadr", [1, 1], ar[0]); });

  define_libfunc("caaar", 1, 1, function(ar){ return get("caaar", [0, 0, 0], ar[0]); });
  define_libfunc("caadr", 1, 1, function(ar){ return get("caadr", [1, 0, 0], ar[0]); });
  define_libfunc("cadar", 1, 1, function(ar){ return get("cadar", [0, 1, 0], ar[0]); });
  define_libfunc("caddr", 1, 1, function(ar){ return get("caddr", [1, 1, 0], ar[0]); });
  define_libfunc("cdaar", 1, 1, function(ar){ return get("cdaar", [0, 0, 1], ar[0]); });
  define_libfunc("cdadr", 1, 1, function(ar){ return get("cdadr", [1, 0, 1], ar[0]); });
  define_libfunc("cddar", 1, 1, function(ar){ return get("cddar", [0, 1, 1], ar[0]); });
  define_libfunc("cdddr", 1, 1, function(ar){ return get("cdddr", [1, 1, 1], ar[0]); });

  define_libfunc("caaaar", 1, 1, function(ar){ return get("caaaar", [0, 0, 0, 0], ar[0]); });
  define_libfunc("caaadr", 1, 1, function(ar){ return get("caaadr", [1, 0, 0, 0], ar[0]); });
  define_libfunc("caadar", 1, 1, function(ar){ return get("caadar", [0, 1, 0, 0], ar[0]); });
  define_libfunc("caaddr", 1, 1, function(ar){ return get("caaddr", [1, 1, 0, 0], ar[0]); });
  define_libfunc("cadaar", 1, 1, function(ar){ return get("cadaar", [0, 0, 1, 0], ar[0]); });
  define_libfunc("cadadr", 1, 1, function(ar){ return get("cadadr", [1, 0, 1, 0], ar[0]); });
  define_libfunc("caddar", 1, 1, function(ar){ return get("caddar", [0, 1, 1, 0], ar[0]); });
  define_libfunc("cadddr", 1, 1, function(ar){ return get("cadddr", [1, 1, 1, 0], ar[0]); });
  define_libfunc("cdaaar", 1, 1, function(ar){ return get("cdaaar", [0, 0, 0, 1], ar[0]); });
  define_libfunc("cdaadr", 1, 1, function(ar){ return get("cdaadr", [1, 0, 0, 1], ar[0]); });
  define_libfunc("cdadar", 1, 1, function(ar){ return get("cdadar", [0, 1, 0, 1], ar[0]); });
  define_libfunc("cdaddr", 1, 1, function(ar){ return get("cdaddr", [1, 1, 0, 1], ar[0]); });
  define_libfunc("cddaar", 1, 1, function(ar){ return get("cddaar", [0, 0, 1, 1], ar[0]); });
  define_libfunc("cddadr", 1, 1, function(ar){ return get("cddadr", [1, 0, 1, 1], ar[0]); });
  define_libfunc("cdddar", 1, 1, function(ar){ return get("cdddar", [0, 1, 1, 1], ar[0]); });
  define_libfunc("cddddr", 1, 1, function(ar){ return get("cddddr", [1, 1, 1, 1], ar[0]); });
})();

define_libfunc("null?", 1, 1, function(ar){
  return (ar[0] === nil);
});
define_libfunc("list?", 1, 1, function(ar){
  return isList(ar[0]);
});
define_libfunc("list", 0, null, function(ar){
  var l = nil;
  for(var i=ar.length-1; i>=0; i--)
    l = new Pair(ar[i], l);
  return l;
});
define_libfunc("length", 1, 1, function(ar){
  assert_list(ar[0]);
  var n = 0;
  for(var o=ar[0]; o!=nil; o=o.cdr)
    n++;
  return n;
});
define_libfunc("append", 1, null, function(ar){
  var k = ar.length;
  var ret = ar[--k];
  while(k--){
    ar[k].to_array().reverse().forEach(function(item){
      ret = new Pair(item, ret);
    });
  }
  return ret;
});
define_libfunc("reverse", 1, 1, function(ar){
  // (reverse '()) => '()
  if(ar[0] == nil)
    return nil;
  assert_pair(ar[0]);

  var l = nil;
  for(var o=ar[0]; o!=nil; o=o.cdr)
    l = new Pair(o.car, l);
  return l;
});
define_libfunc("list-tail", 2, 2, function(ar){
  assert_pair(ar[0]);
  assert_integer(ar[1]);
  if(ar[1] < 0)
    throw new BiwaError("list-tail: index out of range ("+ar[1]+")");

  var o = ar[0];
  for(var i=0; i<ar[1]; i++){
    if(!(o instanceof Pair)) throw new BiwaError("list-tail: the list is shorter than " + ar[1]);
    o = o.cdr;
  }
  return o;
});
define_libfunc("list-ref", 2, 2, function(ar){
  assert_pair(ar[0]);
  assert_integer(ar[1]);
  if(ar[1] < 0)
    throw new BiwaError("list-tail: index out of range ("+ar[1]+")");

  var o = ar[0];
  for(var i=0; i<ar[1]; i++){
    if(!(o instanceof Pair)) throw new BiwaError("list-ref: the list is shorter than " + ar[1]);
    o = o.cdr;
  }
  return o.car;
});
define_libfunc("map", 2, null, function(ar){
  var proc = ar.shift(), lists = ar;
  lists.forEach(assert_list);

  var a = [];
  return Call.multi_foreach(lists, {
    // Called for each element
    // input: the element (or the elements, if more than one list is given)
    // output: a Call request of proc and args
    call: function(xs){
      return new Call(proc, xs.map(function(x){ return x.car }));
    },

    // Called when each Call request is finished
    // input: the result of Call request,
    //   the element(s) of the Call request (which is not used here)
    // output: `undefined' to continue,
    //   some value to terminate (the value will be the result)
    result: function(res){ a.push(res); },

    // Called when reached to the end of the list(s)
    // input: none
    // output: the resultant value
    finish: function(){ return array_to_list(a); }
  })
})
define_libfunc("for-each", 2, null, function(ar){
  var proc = ar.shift(), lists = ar;
  lists.forEach(assert_list);

  return Call.multi_foreach(lists, {
    call: function(xs){
      return new Call(proc, xs.map(function(x){ return x.car }));
    },
    finish: function(){ return undef; }
  })
})

//        11.10  Symbols

define_libfunc("symbol?", 1, 1, function(ar){
  return (ar[0] instanceof BiwaSymbol) ? true : false;
});
define_libfunc("symbol->string", 1, 1, function(ar){
  assert_symbol(ar[0]);
  return ar[0].name;
});
define_libfunc("symbol=?", 2, null, function(ar){
  assert_symbol(ar[0]);
  for(var i=1; i<ar.length; i++){
    assert_symbol(ar[i]);
    if(ar[i] != ar[0]) return false;
  }
  return true;
});
define_libfunc("string->symbol", 1, 1, function(ar){
  assert_string(ar[0]);
  return Sym(ar[0]);
});

//
//        11.11  Characters
//
define_libfunc('char?', 1, 1, function(ar){
  return (ar[0] instanceof Char);
});
define_libfunc('char->integer', 1, 1, function(ar){
  assert_char(ar[0]);
  return ar[0].value.charCodeAt(0);
})
define_libfunc('integer->char', 1, 1, function(ar){
  assert_integer(ar[0]);
  return Char.get(String.fromCharCode(ar[0]));
})

var make_char_compare_func = function(test){
  return function(ar){
    assert_char(ar[0]);
    for(var i=1; i<ar.length; i++){
      assert_char(ar[i]);
      if(!test(ar[i-1].value, ar[i].value))
        return false;
    }
    return true;
  }
}
define_libfunc('char=?', 2, null,
  make_char_compare_func(function(a, b){ return a == b }))
define_libfunc('char<?', 2, null,
  make_char_compare_func(function(a, b){ return a < b }))
define_libfunc('char>?', 2, null,
  make_char_compare_func(function(a, b){ return a > b }))
define_libfunc('char<=?', 2, null,
  make_char_compare_func(function(a, b){ return a <= b }))
define_libfunc('char>=?', 2, null,
  make_char_compare_func(function(a, b){ return a >= b }))

//
//        11.12  Strings
//
define_libfunc("string?", 1, 1, function(ar){
  return (typeof(ar[0]) == "string");
})
define_libfunc("make-string", 1, 2, function(ar){
  assert_integer(ar[0]);
  var c = " ";
  if(ar[1]){
    assert_char(ar[1]);
    c = ar[1].value;
  }
  var out = "";
  Array(ar[0]).fill().map(() => { out += c; });
  return out;
})
define_libfunc("string", 0, null, function(ar){
  if(ar.length == 0) return "";
  for(var i=0; i<ar.length; i++)
    assert_char(ar[i]);
  return ar.map(function(c){ return c.value }).join("");
})
define_libfunc("string-length", 1, 1, function(ar){
  assert_string(ar[0]);
  return ar[0].length;
})
define_libfunc("string-ref", 2, 2, function(ar){
  assert_string(ar[0]);
  assert_between(ar[1], 0, ar[0].length-1);
  return Char.get(ar[0].charAt([ar[1]]));
})
define_libfunc("string=?", 2, null, function(ar){
  assert_string(ar[0]);
  for(var i=1; i<ar.length; i++){
    assert_string(ar[i]);
    if(ar[0] != ar[i]) return false;
  }
  return true;
})
define_libfunc("string<?", 2, null, function(ar){
  assert_string(ar[0]);
  for(var i=1; i<ar.length; i++){
    assert_string(ar[i]);
    if(!(ar[i-1] < ar[i])) return false;
  }
  return true;
})
define_libfunc("string>?", 2, null, function(ar){
  assert_string(ar[0]);
  for(var i=1; i<ar.length; i++){
    assert_string(ar[i]);
    if(!(ar[i-1] > ar[i])) return false;
  }
  return true;
})
define_libfunc("string<=?", 2, null, function(ar){
  assert_string(ar[0]);
  for(var i=1; i<ar.length; i++){
    assert_string(ar[i]);
    if(!(ar[i-1] <= ar[i])) return false;
  }
  return true;
})
define_libfunc("string>=?", 2, null, function(ar){
  assert_string(ar[0]);
  for(var i=1; i<ar.length; i++){
    assert_string(ar[i]);
    if(!(ar[i-1] >= ar[i])) return false;
  }
  return true;
})

define_libfunc("substring", 3, 3, function(ar){
  assert_string(ar[0]);
  assert_integer(ar[1]);
  assert_integer(ar[2]);

  if(ar[1] < 0) throw new BiwaError("substring: start too small: "+ar[1]);
  if(ar[2] < 0) throw new BiwaError("substring: end too small: "+ar[2]);
  if(ar[0].length+1 <= ar[1]) throw new BiwaError("substring: start too big: "+ar[1]);
  if(ar[0].length+1 <= ar[2]) throw new BiwaError("substring: end too big: "+ar[2]);
  if(!(ar[1] <= ar[2])) throw new BiwaError("substring: not start <= end: "+ar[1]+", "+ar[2]);

  return ar[0].substring(ar[1], ar[2]);
})

define_libfunc("string-append", 0, null, function(ar){
  for(var i=0; i<ar.length; i++)
    assert_string(ar[i]);

  return ar.join("");
})
define_libfunc("string->list", 1, 1, function(ar){
  assert_string(ar[0]);
  return array_to_list(ar[0].split("").map(function(s){ return Char.get(s[0]); }));
})
define_libfunc("list->string", 1, 1, function(ar){
  assert_list(ar[0]);
  return ar[0].to_array().map(function(c){ return c.value; }).join("");
})
define_libfunc("string-for-each", 2, null, function(ar){
  var proc = ar.shift(), strs = ar;
  strs.forEach(assert_string);

  return Call.multi_foreach(strs, {
    call: function(chars){ return new Call(proc, chars); },
    finish: function(){ return undef; }
  })
})
define_libfunc("string-copy", 1, 1, function(ar){
  // note: this is useless, because javascript strings are immutable
  assert_string(ar[0]);
  return ar[0];
})


//
//        11.13  Vectors
//
define_libfunc("vector?", 1, 1, function(ar){
  return isVector(ar[0]);
})
define_libfunc("make-vector", 1, 2, function(ar){
  assert_integer(ar[0]);
  var vec = new Array(ar[0]);

  if(ar.length == 2){
    for(var i=0; i<ar[0]; i++)
      vec[i] = ar[1];
  }
  return vec;
})
define_libfunc("vector", 0, null, function(ar){
  return ar;
})
define_libfunc("vector-length", 1, 1, function(ar){
  assert_vector(ar[0]);
  return ar[0].length;
})
define_libfunc("vector-ref", 2, 2, function(ar){
  assert_vector(ar[0]);
  assert_integer(ar[1]);
  assert_between(ar[1], 0, ar[0].length-1);

  return ar[0][ar[1]];
})
define_libfunc("vector-set!", 3, 3, function(ar){
  assert_vector(ar[0]);
  assert_integer(ar[1]);

  ar[0][ar[1]] = ar[2];
  return undef;
})
define_libfunc("vector->list", 1, 1, function(ar){
  assert_vector(ar[0]);
  return array_to_list(ar[0]);
})
define_libfunc("list->vector", 1, 1, function(ar){
  assert_list(ar[0]);
  return ar[0].to_array();
})
define_libfunc("vector-fill!", 2, 2, function(ar){
  assert_vector(ar[0]);
  var vec = ar[0], obj = ar[1];

  for(var i=0; i<vec.length; i++)
    vec[i] = obj;
  return vec;
})
define_libfunc("vector-map", 2, null, function(ar){
  var proc = ar.shift(), vecs = ar;
  vecs.forEach(assert_vector);

  var a = [];
  return Call.multi_foreach(vecs, {
    call: function(objs){ return new Call(proc, objs); },
    result: function(res){ a.push(res); },
    finish: function(){ return a; }
  })
})
define_libfunc("vector-for-each", 2, null, function(ar){
  var proc = ar.shift(), vecs = ar;
  vecs.forEach(assert_vector);

  return Call.multi_foreach(vecs, {
    call: function(objs){ return new Call(proc, objs); },
    finish: function(){ return undef; }
  })
})

//
//        11.14  Errors and violations
//
//(error who message irritant1 ...)    procedure
//(assertion-violation who message irritant1 ...)    procedure
//(assert <expression>)    syntax

//
//        11.15  Control features
//
define_libfunc("apply", 2, null, function(ar){
  var proc = ar.shift(), rest_args = ar.pop(), args = ar;
  args = args.concat(rest_args.to_array());

  return new Call(proc, args);
})
define_syntax("call-with-current-continuation", function(x){
  return new Pair(Sym("call/cc"),
           x.cdr);
})
define_libfunc("values", 0, null, function(ar){
  if (ar.length == 1) // eg. (values 3)
    return ar[0];
  else
    return new Values(ar);
})
define_libfunc("call-with-values", 2, 2, function(ar){
  var producer = ar[0], consumer = ar[1];
  assert_procedure(producer);
  assert_procedure(consumer);
  return new Call(producer, [], function(ar){
    var result = ar[0];
    if(result instanceof Values){
      return new Call(consumer, result.content);
    }
    else{
      // eg. (call-with-values (lambda () 3)
      //                       (lambda (x) x))
      return new Call(consumer, [result]);
    }
  })
})

define_libfunc("dynamic-wind", 3, 3, function(ar, intp) {
  var before = ar[0], thunk = ar[1], after = ar[2];
  return new Call(before, [], function() {
    intp.push_dynamic_winder(before, after);
    return new Call(thunk, [], function(ar2) {
      var result = ar2[0];
      intp.pop_dynamic_winder();
      return new Call(after, [], function(){
        return result;
      });
    });
  });
});

//        11.16  Iteration
//named let

//        11.17  Quasiquotation
// `() is expanded to `cons` and `append`.
// `#() is expanded to `vector` and `vector-append`.
var expand_qq = function(f, lv){
  if(f instanceof BiwaSymbol || f === nil){
    return List(Sym("quote"), f);
  }
  else if(f instanceof Pair){
    var car = f.car;
    if(car instanceof Pair && car.car === Sym("unquote-splicing")){
      if(lv == 1) {
        if (f.cdr === nil) {
          return f.car.cdr.car;
        } else {
          return List(Sym("append"),
                      f.car.cdr.car,
                      expand_qq(f.cdr, lv));
        }
      }
      else
        return List(Sym("cons"),
                    List(Sym("list"),
                         List(Sym("quote"), Sym("unquote-splicing")),
                         expand_qq(f.car.cdr.car, lv-1)),
                    expand_qq(f.cdr, lv));
    }
    else if(car === Sym("unquote")){
      if(lv == 1)
        return f.cdr.car;
      else
        return List(Sym("list"),
                    List(Sym("quote"), Sym("unquote")),
                    expand_qq(f.cdr.car, lv-1));
    }
    else if(car === Sym("quasiquote"))
      return List(Sym("list"),
                  List(Sym("quote"), Sym("quasiquote")),
                  expand_qq(f.cdr.car, lv+1));
    else
      return List(Sym("cons"),
                  expand_qq(f.car, lv),
                  expand_qq(f.cdr, lv));
  }
  else if(f instanceof Array){
    var vecs = [[]];
    for(var i=0; i<f.length; i++){
      if(f[i] instanceof Pair && f[i].car === Sym("unquote-splicing")) {
        if (lv == 1) {
          var item = List(Sym("list->vector"), f[i].cdr.car);
          item["splicing"] = true;
          vecs.push(item);
          vecs.push([]);
        }
        else {
          var item = List(Sym("cons"),
                       List(Sym("list"),
                            List(Sym("quote"), Sym("unquote-splicing")),
                            expand_qq(f[i].car.cdr.car, lv-1)),
                       expand_qq(f[i].cdr, lv));
          vecs[vecs.length-1].push(item);
        }
      }
      else {
        // Expand other things as the same as if they are in a list quasiquote
        vecs[vecs.length-1].push(expand_qq(f[i], lv));
      }
    }

    var vectors = vecs.map(function(vec){
      if (vec["splicing"]) {
        return vec;
      }
      else {
        return Cons(Sym("vector"),
                    array_to_list(vec));
      }
    });
    if (vectors.length == 1) {
       return Cons(Sym("vector"),
                   array_to_list(vecs[0]));
    }
    else {
      return Cons(Sym("vector-append"),
                  array_to_list(vectors));
    }
  }
  else
    return f;
}
define_syntax("quasiquote", function(x){
  return expand_qq(x.cdr.car, 1);
})
//unquote
define_syntax("unquote", function(x){
  throw new BiwaError("unquote(,) must be inside quasiquote(`)");
})
//unquote-splicing
define_syntax("unquote-splicing", function(x){
  throw new BiwaError("unquote-splicing(,@) must be inside quasiquote(`)");
})

//        11.18  Binding constructs for syntactic keywords
//let-syntax
//letrec-syntax

//        11.19  Macro transformers
//syntax-rules
//identifier-syntax
//

//        11.20  Tail calls and tail contexts
//(no library function introduced)


///
/// R6RS Standard Libraries
///

//
// Chapter 1 Unicode
//
//(char-upcase char)    procedure
//(char-downcase char)    procedure
//(char-titlecase char)    procedure
//(char-foldcase char)    procedure
//
//(char-ci=? char1 char2 char3 ...)    procedure
//(char-ci<? char1 char2 char3 ...)    procedure
//(char-ci>? char1 char2 char3 ...)    procedure
//(char-ci<=? char1 char2 char3 ...)    procedure
//(char-ci>=? char1 char2 char3 ...)    procedure
//
//(char-alphabetic? char)    procedure
//(char-numeric? char)    procedure
//(char-whitespace? char)    procedure
//(char-upper-case? char)    procedure
//(char-lower-case? char)    procedure
//(char-title-case? char)    procedure
//
//(char-general-category char)    procedure

//(string-upcase string)    procedure
define_libfunc("string-upcase", 1, 1, function(ar){
  assert_string(ar[0]);
  return ar[0].toUpperCase();
});
//(string-downcase string)    procedure
define_libfunc("string-downcase", 1, 1, function(ar){
  assert_string(ar[0]);
  return ar[0].toLowerCase();
});
//(string-titlecase string)    procedure
//(string-foldcase string)    procedure

const make_string_ci_function = function(compare){
  return function(ar){
    assert_string(ar[0]);
    var str = ar[0].toUpperCase();

    for(var i=1; i<ar.length; i++){
      assert_string(ar[i]);
      if (!compare(str, ar[i].toUpperCase()))
        return false;
    }
    return true;
  }
};
//(string-ci=? string1 string2 string3 ...)    procedure
define_libfunc("string-ci=?", 2, null,
  make_string_ci_function(function(a, b){ return a == b; }));
//(string-ci<? string1 string2 string3 ...)    procedure
define_libfunc("string-ci<?", 2, null,
  make_string_ci_function(function(a, b){ return a < b; }));
//(string-ci>? string1 string2 string3 ...)    procedure
define_libfunc("string-ci>?", 2, null,
  make_string_ci_function(function(a, b){ return a > b; }));
//(string-ci<=? string1 string2 string3 ...)    procedure
define_libfunc("string-ci<=?", 2, null,
  make_string_ci_function(function(a, b){ return a <= b; }));
//(string-ci>=? string1 string2 string3 ...)    procedure
define_libfunc("string-ci>=?", 2, null,
  make_string_ci_function(function(a, b){ return a >= b; }));

//(string-normalize-nfd string)    procedure
//(string-normalize-nfkd string)    procedure
//(string-normalize-nfc string)    procedure
//(string-normalize-nfkc string)    procedure

//
// Chapter 2 Bytevectors
//

//
// Chapter 3 List utilities
//
define_libfunc("find", 2, 2, function(ar){
  var proc = ar[0], ls = ar[1];
  assert_list(ls);
  return Call.foreach(ls, {
    call: function(x){ return new Call(proc, [x.car]) },
    result: function(res, x){ if(res) return x.car; },
    finish: function(){ return false }
  })
})
define_libfunc("for-all", 2, null, function(ar){
  var proc = ar.shift();
  var lists = ar;
  lists.forEach(assert_list);

  var last = true; //holds last result which proc returns
  return Call.multi_foreach(lists, {
    call: function(pairs){
      return new Call(proc, pairs.map(function(x){ return x.car }));
    },
    result: function(res, pairs){
      if(res === false) return false;
      last = res;
    },
    finish: function(){ return last; }
  })
})
define_libfunc("exists", 2, null, function(ar){
  var proc = ar.shift();
  var lists = ar;
  lists.forEach(assert_list);

  return Call.multi_foreach(lists, {
    call: function(pairs){
      return new Call(proc, pairs.map(function(x){ return x.car }));
    },
    result: function(res, pairs){
      if(res !== false) return res;
    },
    finish: function(){ return false; }
  })
})
define_libfunc("filter", 2, 2, function(ar){
  var proc = ar[0], ls = ar[1];
  assert_list(ls);

  var a = [];
  return Call.foreach(ls, {
    call: function(x){ return new Call(proc, [x.car]) },
    result: function(res, x){ if(res) a.push(x.car); },
    finish: function(){ return array_to_list(a) }
  })
})
//  define_scmfunc("partition+", 2, 2,
//    "(lambda (proc ls)  \
//       (define (partition2 proc ls t f) \
//         (if (null? ls) \
//           (values (reverse t) (reverse f)) \
//           (if (proc (car ls)) \
//             (partition2 proc (cdr ls) (cons (car ls) t) f) \
//             (partition2 proc (cdr ls) t (cons (car ls) f))))) \
//       (partition2 proc ls '() '()))");

define_libfunc("partition", 2, 2, function(ar){
  var proc = ar[0], ls = ar[1];
  assert_list(ls);

  var t = [], f = [];
  return Call.foreach(ls, {
    call: function(x){ return new Call(proc, [x.car]) },
    result: function(res, x){
      if(res) t.push(x.car);
      else    f.push(x.car);
    },
    finish: function(){
      return new Values([array_to_list(t), array_to_list(f)]);
    }
  })
})
define_libfunc("fold-left", 3, null, function(ar){
  var proc = ar.shift(), accum = ar.shift(), lists = ar;
  lists.forEach(assert_list);

  return Call.multi_foreach(lists, {
    call: function(pairs){
      var args = pairs.map(function(x){ return x.car });
      args.unshift(accum);
      return new Call(proc, args);
    },
    result: function(res, pairs){ accum = res; },
    finish: function(){ return accum; }
  })
})
define_libfunc("fold-right", 3, null, function(ar){
  var proc = ar.shift(), accum = ar.shift();
  var lists = ar.map(function(ls){
    // reverse each list
    assert_list(ls);
    return array_to_list(ls.to_array().reverse());
  })

  return Call.multi_foreach(lists, {
    call: function(pairs){
      var args = pairs.map(function(x){ return x.car });
      args.push(accum);
      return new Call(proc, args);
    },
    result: function(res, pairs){ accum = res; },
    finish: function(){ return accum; }
  })
})
define_libfunc("remp", 2, 2, function(ar){
  var proc = ar[0], ls = ar[1];
  assert_list(ls);

  var ret = [];
  return Call.foreach(ls, {
    call: function(x){ return new Call(proc, [x.car]) },
    result: function(res, x){ if(!res) ret.push(x.car); },
    finish: function(){ return array_to_list(ret); }
  })
})
var make_remover = function(key){
  return function(ar){
    var obj = ar[0], ls = ar[1];
    assert_list(ls);

    var ret = [];
    return Call.foreach(ls, {
      call: function(x){
        return new Call(TopEnv[key] || CoreEnv[key], [obj, x.car])
      },
      result: function(res, x){ if(!res) ret.push(x.car); },
      finish: function(){ return array_to_list(ret); }
    })
  }
}
define_libfunc("remove", 2, 2, make_remover("equal?"));
define_libfunc("remv", 2, 2, make_remover("eqv?"));
define_libfunc("remq", 2, 2, make_remover("eq?"));

define_libfunc("memp", 2, 2, function(ar){
  var proc = ar[0], ls = ar[1];
  assert_list(ls);

  var ret = [];
  return Call.foreach(ls, {
    call: function(x){ return new Call(proc, [x.car]) },
    result: function(res, x){ if(res) return x; },
    finish: function(){ return false; }
  })
})
var make_finder = function(key){
  return function(ar){
    var obj = ar[0], ls = ar[1];
    assert_list(ls);

    var ret = [];
    return Call.foreach(ls, {
      call: function(x){
        return new Call(TopEnv[key] || CoreEnv[key], [obj, x.car])
      },
      result: function(res, x){ if(res) return x; },
      finish: function(){ return false; }
    })
  }
}
define_libfunc("member", 2, 2, make_finder("equal?"));
define_libfunc("memv", 2, 2, make_finder("eqv?"));
define_libfunc("memq", 2, 2, make_finder("eq?"));

define_libfunc("assp", 2, 2, function(ar){
  var proc = ar[0], als = ar[1];
  assert_list(als);

  var ret = [];
  return Call.foreach(als, {
    call: function(x){
      if(x.car.car)
        return new Call(proc, [x.car.car]);
      else
        throw new BiwaError("ass*: pair required but got "+to_write(x.car));
    },
    result: function(res, x){ if(res) return x.car; },
    finish: function(){ return false; }
  })
})
var make_assoc = function(func_name, eq_func_name){
  return function(ar){
    var obj = ar[0], list = ar[1];
    assert_list(list);

    var ret = [];
    return Call.foreach(list, {
      call: function(ls){
        if(!isPair(ls.car))
          throw new BiwaError(func_name+": pair required but got "+to_write(ls.car));

        var equality = (TopEnv[eq_func_name] || CoreEnv[eq_func_name]);
        return new Call(equality, [obj, ls.car.car]);
      },
      result: function(was_equal, ls){ if(was_equal) return ls.car; },
      finish: function(){ return false; }
    })
  }
}
define_libfunc("assoc", 2, 2, make_assoc("assoc", "equal?"));
define_libfunc("assv", 2, 2, make_assoc("assv", "eqv?"));
define_libfunc("assq", 2, 2, make_assoc("assq", "eq?"));

define_libfunc("cons*", 1, null, function(ar){
  if(ar.length == 1)
    return ar[0];
  else{
    var ret = null;
    ar.reverse().forEach(function(x){
      if(ret){
        ret = new Pair(x, ret);
      }
      else
        ret = x;
    })
    return ret;
  }
});

//
// Chapter 4 Sorting
//
(function(){
  // Destructively sort the given array
  // with scheme function `proc` as comparator
  var mergeSort = function(ary, proc, finish) {
    if (ary.length <= 1) return finish(ary);
    return mergeSort_(ary, proc, finish, [[0, ary.length, false]], false);
  };

  var mergeSort_ = function(ary, proc, finish, stack, up) {
    while(true) {
      var start = stack[stack.length-1][0],
          end   = stack[stack.length-1][1],
          left  = stack[stack.length-1][2];
      var len = end - start;
      //console.debug("mergeSort_", ary, stack.join(' '), up?"u":"d", ""+start+".."+(end-1))

      if (len >= 2 && !up) {
        // There are parts to be sorted
        stack.push([start, start+(len>>1), true]); continue;
      }
      else if (left) {
        // Left part sorted. Continue to the right one
        stack.pop();
        var rend = stack[stack.length-1][1];
        stack.push([end, rend, false]); up = false; continue;
      }
      else {
        // Right part sorted. Merge left and right
        stack.pop();
        var lstart = stack[stack.length-1][0];
        var ary1 = ary.slice(lstart, start),
            ary2 = ary.slice(start, end);
        return merge_(ary1, ary2, proc, [], 0, 0, function(ret) {
          //console.debug("mergeSortd", ary, stack.join(' '), up?"u":"d", ary1, ary2, ret, ""+start+".."+(start+len-1));
          for (var i = 0; i < ret.length; i++) {
            ary[lstart + i] = ret[i];
          }

          if (stack.length == 1) {
            return finish(ary);
          }
          else {
            return mergeSort_(ary, proc, finish, stack, true);
          }
        });
      }
    }
  };

  var merge_ = function(ary1, ary2, proc, ret, i, j, cont) {
    //console.debug("merge_", ary1, ary2, ret, i, j);
    var len1 = ary1.length, len2 = ary2.length;
    if (i < len1 && j < len2) {
      return new Call(proc, [ary2[j], ary1[i]], function(ar) {
        //console.debug("comp", [ary2[j], ary1[i]], ar[0]);
        if (ar[0]) {
          ret.push(ary2[j]); j+=1;
        }
        else {
          ret.push(ary1[i]); i+=1;
        }
        return merge_(ary1, ary2, proc, ret, i, j, cont);
      });
    }
    else {
      while (i < len1) { ret.push(ary1[i]); i+=1; }
      while (j < len2) { ret.push(ary2[j]); j+=1; }
      return cont(ret)
    }
  };

  var compareFn = function(a,b){
    return lt(a, b) ? -1 :
           lt(b, a) ? 1 : 0;
  };

  define_libfunc("list-sort", 1, 2, function(ar){
    if(ar[1]){
      assert_procedure(ar[0]);
      assert_list(ar[1]);
      return mergeSort(ar[1].to_array(), ar[0], function(ret) {
        return array_to_list(ret);
      });
    }
    else {
      assert_list(ar[0]);
      return array_to_list(ar[0].to_array().sort(compareFn));
    }
  });

  //(vector-sort proc vector)    procedure
  define_libfunc("vector-sort", 1, 2, function(ar){
    if(ar[1]){
      assert_procedure(ar[0]);
      assert_vector(ar[1]);
      return mergeSort([... ar[1]], ar[0], function(ret){
        return ret;
      });
    }
    else {
      assert_vector(ar[0]);
      return [...ar[0]].sort(compareFn);
    }
  });

  //(vector-sort! proc vector)    procedure
  define_libfunc("vector-sort!", 1, 2, function(ar){
    if(ar[1]){
      assert_procedure(ar[0]);
      assert_vector(ar[1]);
      return mergeSort(ar[1], ar[0], function(ret) {
        return undef;
      });
    }
    else {
      assert_vector(ar[0]);
      ar[0].sort(compareFn);
      return undef;
    }
  });
})();

//
// Chapter 5 Control Structures
//
define_syntax("when", function(x){
  //(when test body ...)
  //=> (if test (begin body ...) #<undef>)
  var test = x.cdr.car, body = x.cdr.cdr;

  return new Pair(Sym("if"),
           new Pair(test,
             new Pair(new Pair(Sym("begin"), body),
               new Pair(undef, nil))));
});

define_syntax("unless", function(x){
  //(unless test body ...)
  //=> (if (not test) (begin body ...) #<undef>)
  var test = x.cdr.car, body = x.cdr.cdr;

  return new Pair(Sym("if"),
           new Pair(new Pair(Sym("not"), new Pair(test, nil)),
             new Pair(new Pair(Sym("begin"), body),
               new Pair(undef, nil))));
});

define_syntax("do", function(x){
  //(do ((var1 init1 step1)
  //     (var2 init2 step2) ...)
  //    (test expr1 expr2 ...)
  //  body1 body2 ...)
  //=> (let loop` ((var1 init1) (var2 init2) ...)
  //     (if test
  //       (begin expr1 expr2 ...)
  //       (begin body1 body2 ...
  //              (loop` step1 step2 ...)))))

  // parse arguments
  if(!isPair(x.cdr))
    throw new BiwaError("do: no variables of do");
  var varsc = x.cdr.car;
  if(!isPair(varsc))
    throw new BiwaError("do: variables must be given as a list");
  if(!isPair(x.cdr.cdr))
    throw new BiwaError("do: no resulting form of do");
  var resultc = x.cdr.cdr.car;
  var bodyc = x.cdr.cdr.cdr;

  // construct subforms
  var loop = gensym();

  var init_vars = array_to_list(varsc.map(function(var_def){
    var a = var_def.to_array();
    return List(a[0], a[1]);
  }));

  var test = resultc.car;
  var result_exprs = new Pair(Sym("begin"), resultc.cdr);

  var next_loop = new Pair(loop, array_to_list(varsc.map(function(var_def){
    var a = var_def.to_array();
    return a[2] || a[0];
  })));
  var body_exprs = new Pair(Sym("begin"), bodyc).concat(List(next_loop));

  // combine subforms
  return List(Sym("let"),
              loop,
              init_vars,
              List(Sym("if"),
                   test,
                   result_exprs,
                   body_exprs));
});

//(case-lambda <case-lambda clause> ...)    syntax
define_syntax("case-lambda", function(x){
  if(!isPair(x.cdr))
    throw new BiwaError("case-lambda: at least 1 clause required");
  var clauses = x.cdr.to_array();
  
  var args_ = gensym();
  var exec = List(Sym("raise"), "case-lambda: no matching clause found");

  clauses.reverse().forEach(function(clause) {
    if(!isPair(clause))
      throw new BiwaError("case-lambda: clause must be a pair: "+
                      to_write(clause));
    var formals = clause.car, clause_body = clause.cdr;

    if (formals === nil) {
      exec = List(Sym("if"),
                  List(Sym("null?"), args_),
                  new Pair(Sym("begin"), clause_body),
                  exec);
    }
    else if (isPair(formals)) {
      var len = formals.length(), last_cdr = formals.last_cdr();
      var pred = (last_cdr === nil ? Sym("=") : Sym(">="));
      var lambda = new Pair(Sym("lambda"),
                     new Pair(formals,
                       clause_body));
      exec = List(Sym("if"),
                  List(pred, List(Sym("length"), args_), len),
                  List(Sym("apply"), lambda, args_),
                  exec);
    }
    else if (isSymbol(formals)) {
      exec = new Pair(Sym("let1"),
               new Pair(formals,
                 new Pair(args_,
                   clause_body)));
      // Note: previous `exec` is just discarded because this is a wildcard pattern.
    }
    else {
      throw new BiwaError("case-lambda: invalid formals: "+
                      to_write(formals));
    }
  });

  return List(Sym("lambda"), args_, exec);
});

//
// Chapter 6 Records
// see also: src/system/record.js
//

// 6.2 Records: Syntactic layer
//eqv, eq

//(define-record-type <name spec> <record clause>*)    syntax
define_syntax("define-record-type", function(x){
  // (define-record-type <name spec> <record clause>*)
  var name_spec = x.cdr.car;
  var record_clauses = x.cdr.cdr;

  // 1. parse name spec
  // <name spec>: either
  // - <record name> eg: point
  // - (<record name> <constructor name> <predicate name>)
  //   eg: (point make-point point?)
  if(isSymbol(name_spec)){
    var record_name = name_spec;
    var constructor_name = Sym("make-"+name_spec.name);
    var predicate_name = Sym(name_spec.name+"?");
  }
  else{
    assert_list(name_spec);
    var record_name = name_spec.car;
    var constructor_name = name_spec.cdr.car;
    var predicate_name = name_spec.cdr.cdr.car;
    assert_symbol(record_name);
    assert_symbol(constructor_name);
    assert_symbol(predicate_name);
  }

  // 2. parse record clauses
  var sealed = false;
  var opaque = false;
  var nongenerative = false;
  var uid = false;
  var parent_name;
  var parent_rtd = false;
  var parent_cd = false;
  var protocol = false;
  var fields = [];

  // <record clause>:
  record_clauses.to_array().forEach(function(clause){
    switch(clause.car){
      // - (fields <field spec>*)
      case Sym("fields"):
        fields = clause.cdr.to_array().map(function(field_spec, idx){
          if(isSymbol(field_spec)){
            // - <field name>
            return {name: field_spec, idx: idx, mutable: false,
                    accessor_name: null, mutator_name: null};
          }
          else{
            assert_list(field_spec);
            assert_symbol(field_spec.car);
            switch(field_spec.car){
              case Sym("immutable"):
                // - (immutable <field name>)
                // - (immutable <field name> <accessor name>)
                var field_name = field_spec.cdr.car;
                assert_symbol(field_name);

                if(isNil(field_spec.cdr.cdr))
                  return {name: field_name, idx: idx, mutable: false};
                else
                  return {name: field_name, idx: idx, mutable: false,
                          accessor_name: field_spec.cdr.cdr.car};
                break;

              case Sym("mutable"):
                // - (mutable <field name>)
                // - (mutable <field name> <accessor name> <mutator name>)
                var field_name = field_spec.cdr.car;
                assert_symbol(field_name);

                if(isNil(field_spec.cdr.cdr))
                  return {name: field_name, idx: idx, mutable: true}
                else
                  return {name: field_name, idx: idx, mutable: true,
                          accessor_name: field_spec.cdr.cdr.car,
                          mutator_name:  field_spec.cdr.cdr.cdr.car};
                break;
              default:
                throw new BiwaError("define-record-type: field definition "+
                            "must start with `immutable' or `mutable' "+
                            "but got "+inspect(field_spec.car));
            }
          }
        });
        break;
      // - (parent <name>)
      case Sym("parent"):
        parent_name = clause.cdr.car;
        assert_symbol(parent_name);
        break;
      // - (protocol <expr>)
      case Sym("protocol"):
        protocol = clause.cdr.car;
        break;
      // - (sealed <bool>)
      case Sym("sealed"):
        sealed = !!clause.cdr.car;
        break;
      // - (opaque <bool>)
      case Sym("opaque"):
        opaque = !!clause.cdr.car;
        break;
      // - (nongenerative <uid>?)
      case Sym("nongenerative"):
        nongenerative = true;
        uid = clause.cdr.car;
        break;
      // - (parent-rtd <rtd> <cd>)
      case Sym("parent-rtd"):
        parent_rtd = clause.cdr.car;
        parent_cd = clause.cdr.cdr.car;
        break;
      default:
        throw new BiwaError("define-record-type: unknown clause `"+
                                   to_write(clause.car)+"'");
    }
  });

  if(parent_name){
    parent_rtd = [Sym("record-type-descriptor"), parent_name];
    parent_cd  = [Sym("record-constructor-descriptor"), parent_name];
  }

  // 3. build the definitions
  // Note: In this implementation, rtd and cd are not bound to symbols.
  // They are referenced through record name by record-type-descriptor
  // and record-constructor-descriptor. These relation are stored in
  // the hash BiwaScheme.Record._DefinedTypes.
  var rtd = [Sym("record-type-descriptor"), record_name];
  var cd  = [Sym("record-constructor-descriptor"), record_name];

  // registration
  var rtd_fields = fields.map(function(field){
    return List(Sym(field.mutable ? "mutable" : "immutable"), field.name);
  });
  rtd_fields.is_vector = true; //tell List not to convert
  var rtd_def = [Sym("make-record-type-descriptor"),
                  [Sym("quote"), record_name], parent_rtd, uid,
                  sealed, opaque, rtd_fields];
  var cd_def = [Sym("make-record-constructor-descriptor"),
                  Sym("__rtd"), parent_cd, protocol];
  var registration =
    [Sym("let*"), [[Sym("__rtd"), rtd_def],
                  [Sym("__cd"), cd_def]],
      [Sym("_define-record-type"),
        [Sym("quote"), record_name], Sym("__rtd"), Sym("__cd")]];

  // accessors and mutators
  var accessor_defs = fields.map(function(field){
    var name = field.accessor_name ||
                 Sym(record_name.name+"-"+field.name.name);

    return [Sym("define"), name, [Sym("record-accessor"), rtd, field.idx]];
  });

  var mutator_defs = fields.filter(function(field){
    return field.mutable;
  });
  mutator_defs = mutator_defs.map(function(field){
    var name = field.mutator_name ||
                 Sym(record_name.name+"-"+field.name.name+"-set!");

    return [Sym("define"), name, [Sym("record-mutator"), rtd, field.idx]];
  });

  // Wrap the definitions with `begin'
  // Example:
  //   (begin
  //     (let* ((__rtd (make-record-type-descriptor 'square
  //                     (record-type-descriptor rect)
  //                     #f #f #f
  //                     #((mutable w) (mutable h))))
  //            (__cd (make-record-constructor-descriptor __rtd
  //                    (record-constructor-descriptor rect)
  //                    (lambda (n) ...))))
  //       (_define-record-type 'square __rtd __cd))
  //
  //     (define make-square
  //       (record-constructor
  //         (record-constructor-descriptor square)))
  //     (define square?
  //       (record-predicate (record-type-descriptor square)))
  //     (define square-w
  //       (record-accessor (record-type-descriptor square) 0))
  //     (define square-h
  //       (record-accessor (record-type-descriptor square) 1))
  //     (define set-square-w!
  //       (record-mutator (record-type-descriptor square) 0))
  //     (define set-square-h!
  //       (record-mutator (record-type-descriptor square) 1)))
  //
  return deep_array_to_list(
    [Sym("begin"),
      registration,
      [Sym("define"), constructor_name, [Sym("record-constructor"), cd]],
      [Sym("define"), predicate_name, [Sym("record-predicate"), rtd]],
      ].concat(accessor_defs).
        concat(mutator_defs)
  );
});

define_libfunc("_define-record-type", 3, 3, function(ar){
  assert_symbol(ar[0]);
  assert_record_td(ar[1]);
  assert_record_cd(ar[2]);
  Record.define_type(ar[0].name, ar[1], ar[2]);
  return undef;
});

//(record-type-descriptor <record name>)    syntax
define_syntax("record-type-descriptor", function(x){
  return deep_array_to_list([Sym("_record-type-descriptor"), [Sym("quote"), x.cdr.car]]);
});
define_libfunc("_record-type-descriptor", 1, 1, function(ar){
  assert_symbol(ar[0]);
  var type = Record.get_type(ar[0].name);
  if(type)
    return type.rtd;
  else
    throw new BiwaError("record-type-descriptor: unknown record type "+ar[0].name);
});

//(record-constructor-descriptor <record name>)    syntax
define_syntax("record-constructor-descriptor", function(x){
  return deep_array_to_list([Sym("_record-constructor-descriptor"), [Sym("quote"), x.cdr.car]]);
});
define_libfunc("_record-constructor-descriptor", 1, 1, function(ar){
  assert_symbol(ar[0]);
  var type = Record.get_type(ar[0].name);
  if(type)
    return type.cd;
  else
    throw new BiwaError("record-constructor-descriptor: unknown record type "+ar[0].name);
});

// 6.3  Records: Procedural layer
//(make-record-type-descriptor name    procedure
define_libfunc("make-record-type-descriptor", 6, 6, function(ar){
  var name = ar[0], parent_rtd = ar[1], uid = ar[2],
      sealed = ar[3], opaque = ar[4], fields = ar[5];

  assert_symbol(name);
  if(parent_rtd) assert_record_td(parent_rtd);
  if(uid){
    assert_symbol(uid);
    var _rtd = Record.RTD.NongenerativeRecords[uid.name];
    if(_rtd){
      // the record type is already defined.
      return _rtd;
      // should check equality of other arguments..
    }
  }
  sealed = !!sealed;
  opaque = !!opaque;
  assert_vector(fields);
  for(var i=0; i<fields.length; i++){
    var list = fields[i];
    assert_symbol(list.car, "mutability");
    assert_symbol(list.cdr.car, "field name");
    fields[i] = [list.cdr.car.name, (list.car == Sym("mutable"))];
  };

  var rtd = new Record.RTD(name, parent_rtd, uid,
                                   sealed, opaque, fields);
  if(uid)
    Record.RTD.NongenerativeRecords[uid.name] = rtd;

  return rtd;
});

//(record-type-descriptor? obj)    procedure
define_libfunc("record-type-descriptor?", 1, 1, function(ar){
  return (ar[0] instanceof Record.RTD);
});

//(make-record-constructor-descriptor rtd    procedure
define_libfunc("make-record-constructor-descriptor", 3, 3, function(ar){
  var rtd = ar[0], parent_cd = ar[1], protocol = ar[2];

  assert_record_td(rtd);
  if(parent_cd) assert_record_cd(parent_cd);
  if(protocol) assert_procedure(protocol);

  return new Record.CD(rtd, parent_cd, protocol);
});

//(record-constructor constructor-descriptor)    procedure
define_libfunc("record-constructor", 1, 1, function(ar){
  var cd = ar[0];
  assert_record_cd(cd);

  return cd.record_constructor();
});

//(record-predicate rtd)    procedure
define_libfunc("record-predicate", 1, 1, function(ar){
  var rtd = ar[0];
  assert_record_td(rtd);

  return function(args){
    var obj = args[0];

    if (!(obj instanceof Record)) {
      return false;
    } else if (obj.rtd === rtd) { // Fast path
      return true;
    } else {
      for(let _rtd = obj.rtd; _rtd; _rtd = _rtd.parent_rtd){
        if(_rtd == rtd) return true;
      }
      return false;
    }
  };
});

//(record-accessor rtd k)    procedure
define_libfunc("record-accessor", 2, 2, function(ar){
  var rtd = ar[0], k = ar[1];
  assert_record_td(rtd);
  assert_integer(k);
  for(var _rtd = rtd.parent_rtd; _rtd; _rtd = _rtd.parent_rtd)
    k += _rtd.fields.length;

  return function(args){
    var record = args[0];
    var error_msg = rtd.name.name+"-"+rtd.field_name(k)+": "+
                    to_write(record)+
                    " is not a "+rtd.name.name;
    assert(isRecord(record), error_msg);

    var descendant = false;
    for(var _rtd = record.rtd; _rtd; _rtd = _rtd.parent_rtd){
      if(_rtd == rtd) descendant = true;
    }
    assert(descendant, error_msg);

    return record.get(k);
  };
});

//(record-mutator rtd k)    procedure
define_libfunc("record-mutator", 2, 2, function(ar){
  var rtd = ar[0], k = ar[1];
  assert_record_td(rtd);
  assert_integer(k);
  for(var _rtd = rtd.parent_rtd; _rtd; _rtd = _rtd.parent_rtd)
    k += _rtd.fields.length;

  return function(args){
    var record = args[0], val = args[1];
    var func_name = rtd.field_name(k);

    assert_record(record);
    assert(record.rtd === rtd,
          func_name+": "+to_write(record)+
          " is not a "+rtd.name.name);
    assert(!record.rtd.sealed,
          func_name+": "+rtd.name.name+" is sealed (can't mutate)");

    record.set(k, val);
  };
});

// 6.4  Records: Inspection
//(record? obj)    procedure
define_libfunc("record?", 1, 1, function(ar){
  var obj = ar[0];
  if(isRecord(obj)){
    if(obj.rtd.opaque)
      return false; // opaque records pretend as if it is not a record.
    else
      return true;
  }
  else
    return false;
});

//(record-rtd record)    procedure
define_libfunc("record-rtd", 1, 1, function(ar){
  assert_record(ar[0]);
  return ar[0].rtd;
});

//(record-type-name rtd)    procedure
define_libfunc("record-type-name", 1, 1, function(ar){
  assert_record_td(ar[0]);
  return ar[0].name;
});

//(record-type-parent rtd)    procedure
define_libfunc("record-type-parent", 1, 1, function(ar){
  assert_record_td(ar[0]);
  return ar[0].parent_rtd;
});

//(record-type-uid rtd)    procedure
define_libfunc("record-type-uid", 1, 1, function(ar){
  assert_record_td(ar[0]);
  return ar[0].uid;
});

//(record-type-generative? rtd)    procedure
define_libfunc("record-type-generative?", 1, 1, function(ar){
  assert_record_td(ar[0]);
  return ar[0].generative;
});

//(record-type-sealed? rtd)    procedure
define_libfunc("record-type-sealed?", 1, 1, function(ar){
  assert_record_td(ar[0]);
  return ar[0].sealed;
});

//(record-type-opaque? rtd)    procedure
define_libfunc("record-type-opaque?", 1, 1, function(ar){
  assert_record_td(ar[0]);
  return ar[0].opaque;
});

//(record-type-field-names rtd)    procedure
define_libfunc("record-type-field-names", 1, 1, function(ar){
  assert_record_td(ar[0]);
  return ar[0].fields.map(function(field){ return field.name; });
});

//(record-field-mutable? rtd k)    procedure
define_libfunc("record-field-mutable?", 2, 2, function(ar){
  var rtd = ar[0], k = ar[1];
  assert_record_td(ar[0]);
  assert_integer(k);

  for(var _rtd = rtd.parent_rtd; _rtd; _rtd = _rtd.parent_rtd)
    k += _rtd.fields.length;

  return ar[0].fields[k].mutable;
});

//
// Chapter 7 Exceptions and conditions
//
//(with-exception-handler handler thunk)    procedure
//(guard (<variable>    syntax
//(raise obj)    procedure
define_libfunc("raise", 1, 1, function(ar){
  throw new UserError(to_write(ar[0]));
});
//(raise-continuable obj)    procedure
//
//&condition    condition type
//(condition condition1 ...)    procedure
//(simple-conditions condition)    procedure
//(condition? obj)    procedure
//(condition-predicate rtd)    procedure
//(condition-accessor rtd proc)    procedure
//
//&message    condition type
//&warning    condition type
//&serious    condition type
//&error    condition type
//&violation    condition type
//&assertion    condition type
//&irritants    condition type
//&who    condition type
//&non-continuable    condition type
//&implementation-restriction    condition type
//&lexical    condition type
//&syntax    condition type
//&undefined    condition type

//
// Chapter 8 I/O
//
//  //    8  I/O
//  //        8.1  Condition types
//&i/o    condition type
//&i/o-read    condition type
//&i/o-write    condition type
//&i/o-invalid-position    condition type
//&i/o-filename    condition type
//&i/o-file-protection    condition type
//&i/o-file-is-read-only    condition type
//&i/o-file-already-exists    condition type
//&i/o-file-does-not-exist    condition type
//&i/o-port    condition type
//
//  //        8.2  Port I/O
//  //            8.2.1  File names
//  //(no function introduced)
//
//  //            8.2.2  File options
//(file-options <file-options symbol> ...)    syntax
//
//  //            8.2.3  Buffer modes
//(buffer-mode <buffer-mode symbol>)    syntax
//(buffer-mode? obj)    procedure
//
//  //            8.2.4  Transcoders
//(latin-1-codec)    procedure
//(utf-8-codec)    procedure
//(utf-16-codec)    procedure
//(eol-style <eol-style symbol>)    syntax
//(native-eol-style)    procedure
//&i/o-decoding    condition type
//&i/o-encoding    condition type
//(error-handling-mode <error-handling-mode symbol>)    syntax
//(make-transcoder codec)    procedure
//(make-transcoder codec eol-style)    procedure
//(make-transcoder codec eol-style handling-mode)    procedure
//(native-transcoder)    procedure
//(transcoder-codec transcoder)    procedure
//(transcoder-eol-style transcoder)    procedure
//(transcoder-error-handling-mode transcoder)    procedure
//(bytevector->string bytevector transcoder)    procedure
//(string->bytevector string transcoder)    procedure
//
//            8.2.5  End-of-file object
//-> 8.3 (eof-object)    procedure
//-> 8.3 (eof-object? obj)    procedure

//            8.2.6  Input and output ports
define_libfunc("port?", 1, 1, function(ar){
  return (ar[0] instanceof Port);
})
//(port-transcoder port)    procedure
define_libfunc("textual-port?", 1, 1, function(ar){
  assert_port(ar[0]);
  return !ar[0].is_binary;
})
define_libfunc("binary-port?", 1, 1, function(ar){
  assert_port(ar[0]);
  return ar[0].is_binary;
})
//(transcoded-port binary-port transcoder)    procedure
//(port-has-port-position? port)    procedure
//(port-position port)    procedure
//(port-has-set-port-position!? port)    procedure
//(set-port-position! port pos)    procedure
define_libfunc("close-port", 1, 1, function(ar){
  assert_port(ar[0]);
  ar[0].close();
  return undef;
})
//(call-with-port port proc)    procedure
define_libfunc("call-with-port", 2, 2, function(ar){
  var port = ar[0], proc = ar[1];
  assert_port(port);
  assert_closure(proc);

  return new Call(proc, [port], function(ar){
    // Automatically close the port
    port.close();
    return ar[0]; // TODO: values
  });
});

//            8.2.7  Input ports
//8.3 (input-port? obj)    procedure
//(port-eof? input-port)    procedure
//(open-file-input-port filename)    procedure
//(open-bytevector-input-port bytevector)    procedure
//(open-string-input-port string)    procedure
//(standard-input-port)    procedure
//8.3 (current-input-port)    procedure
//(make-custom-binary-input-port id read!    procedure
//(make-custom-textual-input-port id read!    procedure
//
//  //            8.2.8  Binary input
//(get-u8 binary-input-port)    procedure
//(lookahead-u8 binary-input-port)    procedure
//(get-bytevector-n binary-input-port count)    procedure
//(get-bytevector-n! binary-input-port    procedure
//(get-bytevector-some binary-input-port)    procedure
//(get-bytevector-all binary-input-port)    procedure
//
//  //            8.2.9  Textual input
//(get-char textual-input-port)    procedure
//(lookahead-char textual-input-port)    procedure
//(get-string-n textual-input-port count)    procedure
//(get-string-n! textual-input-port string start count)    procedure
//(get-string-all textual-input-port)    procedure
//(get-line textual-input-port)    procedure
//(get-datum textual-input-port)    procedure
//
//            8.2.10  Output ports
//8.3 (output-port? obj)    procedure
//(flush-output-port output-port)    procedure
//(output-port-buffer-mode output-port)    procedure
//(open-file-output-port filename)    procedure
//(open-bytevector-output-port)    procedure
//(call-with-bytevector-output-port proc)    procedure
//(open-string-output-port)    procedure
//(call-with-string-output-port proc)    procedure
define_libfunc("call-with-string-output-port", 1, 1, function(ar){
  var proc = ar[0];
  assert_procedure(proc);

  var port = new Port.StringOutput();

  return new Call(proc, [port], function(ar){
    port.close();
    return port.output_string();
  });
});

//(standard-output-port)    procedure
//(standard-error-port)    procedure
//8.3 (current-output-port)    procedure
//8.3 (current-error-port)    procedure
//(make-custom-binary-output-port id    procedure
//(make-custom-textual-output-port id write! get-position set-position! close)
//  define_libfunc("make-custom-textual-output-port", 5, 5, function(ar){
//    assert_string(ar[0]);
//    assert_closure(ar[1]);
//    assert_closure(ar[2]);
//    assert_closure(ar[3]);
//    assert_closure(ar[4]);
//    return new Port(ar[0], ar[1], ar[2], ar[3], ar[4]);
//  })
//
//  //            8.2.11  Binary output
//(put-u8 binary-output-port octet)    procedure
//(put-bytevector binary-output-port bytevector)    procedure
//
//            8.2.12  Textual output
define_libfunc("put-char", 2, 2, function(ar){
  assert_port(ar[0]);
  assert_char(ar[1]);
  ar[0].put_string(ar[1].value);
  return undef;
})
define_libfunc("put-string", 2, 2, function(ar){
  assert_port(ar[0]);
  assert_string(ar[1]);
  ar[0].put_string(ar[1]);
  return undef;
})
define_libfunc("put-datum", 2, 2, function(ar){
  assert_port(ar[0]);
  ar[0].put_string(to_write(ar[1]));
  return undef;
})
//
//  //            8.2.13  Input/output ports
//(open-file-input/output-port filename)    procedure
//(make-custom-binary-input/output-port    procedure
//(make-custom-textual-input/output-port    procedure
//
//  //        8.3  Simple I/O
define_libfunc("eof-object", 0, 0, function(ar){
  return eof;
})
define_libfunc("eof-object?", 1, 1, function(ar){
  return ar[0] === eof;
})
//(call-with-input-file filename proc)    procedure
//(call-with-output-file filename proc)    procedure
define_libfunc("input-port?", 1, 1, function(ar){
  assert_port(ar[0]);
  return ar[0].is_input;
})
define_libfunc("output-port?", 1, 1, function(ar){
  assert_port(ar[0]);
  return ar[0].is_output;
})
define_libfunc("current-input-port", 0, 0, function(ar){
  return Port.current_input;
})
define_libfunc("current-output-port", 0, 0, function(ar){
  return Port.current_output;
})
define_libfunc("current-error-port", 0, 0, function(ar){
  return Port.current_error;
})
//(with-input-from-file filename thunk)    procedure
//(with-output-to-file filename thunk)    procedure
//(open-input-file filename)    procedure
//(open-output-file filename)    procedure
define_libfunc("close-input-port", 1, 1, function(ar){
  assert_port(ar[0]);
  if(!ar[0].is_input)
    throw new BiwaError("close-input-port: port is not input port");
  ar[0].close();
  return undef;
});
define_libfunc("close-output-port", 1, 1, function(ar){
  assert_port(ar[0]);
  if(!ar[0].is_output)
    throw new BiwaError("close-output-port: port is not output port");
  ar[0].close();
  return undef;
});
//(read-char)    procedure
//(peek-char)    procedure
define_libfunc("read", 0, 1, function(ar){
  var port = ar[0] || Port.current_input;
  assert_port(port);

  return port.get_string(function(str){
    return Interpreter.read(str); 
  });
})

define_libfunc("write-char", 1, 2, function(ar){
  var port = ar[1] || Port.current_output;
  assert_char(ar[0]);
  port.put_string(ar[0].value);
  return undef;
});
define_libfunc("newline", 0, 1, function(ar){
  var port = ar[0] || Port.current_output;
  port.put_string("\n");
  return undef;
});
define_libfunc("display", 1, 2, function(ar){
  var port = ar[1] || Port.current_output;
  port.put_string(to_display(ar[0]));
  return undef;
});
define_libfunc("write", 1, 2, function(ar){
  var port = ar[1] || Port.current_output;
  assert_port(port);
  port.put_string(to_write(ar[0]));
  return undef;
});
define_libfunc("write-shared", 1, 2, function(ar){
  var port = ar[1] || Port.current_output;
  assert_port(port);
  port.put_string(write_shared(ar[0]));
  return undef;
});
define_libfunc("write-simple", 1, 2, function(ar){
  var port = ar[1] || Port.current_output;
  assert_port(port);
  port.put_string(write_simple(ar[0]));
  return undef;
});

//
// Chapter 9 File System
// Chapter 10 Command-line access and exit values
//
// see src/library/node_functions.js

//
// Chapter 11 Arithmetic
//
////        11.1  Bitwise operations
////        11.2  Fixnums
//(fixnum? obj)    procedure
//(fixnum-width)    procedure
//(least-fixnum)    procedure
//(greatest-fixnum)    procedure
//(fx=? fx1 fx2 fx3 ...)    procedure
//(fx>? fx1 fx2 fx3 ...)    procedure
//(fx<? fx1 fx2 fx3 ...)    procedure
//(fx>=? fx1 fx2 fx3 ...)    procedure
//(fx<=? fx1 fx2 fx3 ...)    procedure
//(fxzero? fx)    procedure
//(fxpositive? fx)    procedure
//(fxnegative? fx)    procedure
//(fxodd? fx)    procedure
//(fxeven? fx)    procedure
//(fxmax fx1 fx2 ...)    procedure
//(fxmin fx1 fx2 ...)    procedure
//(fx+ fx1 fx2)    procedure
//(fx* fx1 fx2)    procedure
//(fx- fx1 fx2)    procedure
//(fxdiv-and-mod fx1 fx2)    procedure
//(fxdiv fx1 fx2)    procedure
//(fxmod fx1 fx2)    procedure
//(fxdiv0-and-mod0 fx1 fx2)    procedure
//(fxdiv0 fx1 fx2)    procedure
//(fxmod0 fx1 fx2)    procedure
//(fx+/carry fx1 fx2 fx3)    procedure
//(fx-/carry fx1 fx2 fx3)    procedure
//(fx*/carry fx1 fx2 fx3)    procedure
//(fxnot fx)    procedure
//(fxand fx1 ...)    procedure
//(fxior fx1 ...)    procedure
//(fxxor fx1 ...)    procedure
//(fxif fx1 fx2 fx3)    procedure
//(fxbit-count fx)    procedure
//(fxlength fx)    procedure
//(fxfirst-bit-set fx)    procedure
//(fxbit-set? fx1 fx2)    procedure
//(fxcopy-bit fx1 fx2 fx3)    procedure
//(fxbit-field fx1 fx2 fx3)    procedure
//(fxcopy-bit-field fx1 fx2 fx3 fx4)    procedure
//(fxarithmetic-shift fx1 fx2)    procedure
//(fxarithmetic-shift-left fx1 fx2)    procedure
//(fxarithmetic-shift-right fx1 fx2)    procedure
//(fxrotate-bit-field fx1 fx2 fx3 fx4)    procedure
//(fxreverse-bit-field fx1 fx2 fx3)    procedure
//
////        11.3  Flonums
//(flonum? obj)    procedure
//(real->flonum x)    procedure
//(fl=? fl1 fl2 fl3 ...)    procedure
//(fl<? fl1 fl2 fl3 ...)    procedure
//(fl<=? fl1 fl2 fl3 ...)    procedure
//(fl>? fl1 fl2 fl3 ...)    procedure
//(fl>=? fl1 fl2 fl3 ...)    procedure
//(flinteger? fl)    procedure
//(flzero? fl)    procedure
//(flpositive? fl)    procedure
//(flnegative? fl)    procedure
//(flodd? ifl)    procedure
//(fleven? ifl)    procedure
//(flfinite? fl)    procedure
//(flinfinite? fl)    procedure
//(flnan? fl)    procedure
//(flmax fl1 fl2 ...)    procedure
//(flmin fl1 fl2 ...)    procedure
//(fl+ fl1 ...)    procedure
//(fl* fl1 ...)    procedure
//(fl- fl1 fl2 ...)    procedure
//(fl- fl)    procedure
//(fl/ fl1 fl2 ...)    procedure
//(fl/ fl)    procedure
//(flabs fl)    procedure
//(fldiv-and-mod fl1 fl2)    procedure
//(fldiv fl1 fl2)    procedure
//(flmod fl1 fl2)    procedure
//(fldiv0-and-mod0 fl1 fl2)    procedure
//(fldiv0 fl1 fl2)    procedure
//(flmod0 fl1 fl2)    procedure
//(flnumerator fl)    procedure
//(fldenominator fl)    procedure
//(flfloor fl)    procedure
//(flceiling fl)    procedure
//(fltruncate fl)    procedure
//(flround fl)    procedure
//(flexp fl)    procedure
//(fllog fl)    procedure
//(fllog fl1 fl2)    procedure
//(flsin fl)    procedure
//(flcos fl)    procedure
//(fltan fl)    procedure
//(flasin fl)    procedure
//(flacos fl)    procedure
//(flatan fl)    procedure
//(flatan fl1 fl2)    procedure
//(flsqrt fl)    procedure
//(flexpt fl1 fl2)    procedure
//&no-infinities    condition type
//&no-nans    condition type
//(fixnum->flonum fx)    procedure

////        11.4  Exact bitwise arithmetic
//(bitwise-not ei)    procedure
define_libfunc("bitwise-not", 1, 1, function(ar){
  return ~(ar[0]);
});

//(bitwise-and ei1 ...)    procedure
define_libfunc("bitwise-and", 1, null, function(ar){
  return ar.reduce(function(ret, item){ return ret & item; });
});

//(bitwise-ior ei1 ...)    procedure
define_libfunc("bitwise-ior", 1, null, function(ar){
  return ar.reduce(function(ret, item){ return ret | item; });
});

//(bitwise-xor ei1 ...)    procedure
define_libfunc("bitwise-xor", 1, null, function(ar){
  return ar.reduce(function(ret, item){ return ret ^ item; });
});

//(bitwise-if ei1 ei2 ei3)    procedure
define_libfunc("bitwise-if", 3, 3, function(ar){
  return (ar[0] & ar[1]) | (~ar[0] & ar[2]);
});

//(bitwise-bit-count ei)    procedure
define_libfunc("bitwise-bit-count", 1, 1, function(ar){
  var e = Math.abs(ar[0]), ret = 0;
  for (; e != 0; e >>= 1) {
    if(e & 1) ret++;
  }
  return ret;
});

//(bitwise-length ei)    procedure
define_libfunc("bitwise-length", 1, 1, function(ar){
  var e = Math.abs(ar[0]), ret = 0;
  for (; e != 0; e >>= 1) {
    ret++;
  }
  return ret;
});

//(bitwise-first-bit-set ei)    procedure
define_libfunc("bitwise-first-bit-set", 1, 1, function(ar){
  var e = Math.abs(ar[0]), ret = 0;
  if (e == 0) return -1;
  for (; e != 0; e >>= 1) {
    if (e & 1) return ret;
    ret++;
  }
});

//(bitwise-bit-set? ei1 ei2)    procedure
define_libfunc("bitwise-bit-set?", 2, 2, function(ar){
  return !!(ar[0] & (1 << ar[1]));
});

//(bitwise-copy-bit ei1 n b)    procedure
define_libfunc("bitwise-copy-bit", 3, 3, function(ar){
  var mask = (1 << ar[1]);
  return (mask & (ar[2] << ar[1])) |   // Set n-th bit to b
         (~mask & ar[0]);              // and use ei1 for rest of the bits
});

//(bitwise-bit-field ei1 start end)    procedure
define_libfunc("bitwise-bit-field", 3, 3, function(ar){
  var mask = ~(-1 << ar[2]);  // Has 1 at 0...end
  return (mask & ar[0]) >> ar[1];
});

//(bitwise-copy-bit-field dst start end src)    procedure
define_libfunc("bitwise-copy-bit-field", 4, 4, function(ar){
  var dst=ar[0], start=ar[1], end=ar[2], src=ar[3];
  var mask = ~(-1 << end) &   // Has 1 at 0...end
              (-1 << start)   // Clear 0...start
  return (mask & (src << start)) |
         (~mask & dst);
});

//(bitwise-arithmetic-shift ei1 ei2)    procedure
define_libfunc("bitwise-arithmetic-shift", 2, 2, function(ar){
  return (ar[1] >= 0) ? (ar[0] << ar[1]) : (ar[0] >> -ar[1]);
});

//(bitwise-arithmetic-shift-left ei1 ei2)    procedure
define_libfunc("bitwise-arithmetic-shift-left", 2, 2, function(ar){
  return ar[0] << ar[1];
});

//(bitwise-arithmetic-shift-right ei1 ei2)    procedure
define_libfunc("bitwise-arithmetic-shift-right", 2, 2, function(ar){
  return ar[0] >> ar[1];
});

//(bitwise-rotate-bit-field ei1 start end count)    procedure
define_libfunc("bitwise-rotate-bit-field", 4, 4, function(ar){
  var n=ar[0], start=ar[1], end=ar[2], count=ar[3];
  var width = end - start;
  if (width <= 0) return n;

  count %= width;
  var orig_field = (~(-1 << end) & n) >> start;
  var rotated_field = (orig_field << count) |
                      (orig_field >> (width - count))

  var mask = ~(-1 << end) & (-1 << start);
  return (mask & (rotated_field << start)) |
         (~mask & n);
});

//(bitwise-reverse-bit-field ei1 ei2 ei3)    procedure
define_libfunc("bitwise-reverse-bit-field", 3, 3, function(ar){
  var ret=ar[0], n=ar[0], start=ar[1], end=ar[2];
  var orig_field = ((~(-1 << end) & n) >> start);
  for (var i=0; i<(end-start); i++, orig_field>>=1) {
    var bit = orig_field & 1;
    var setpos = end - 1 - i;
    var mask = (1 << setpos);
    ret = (mask & (bit << setpos)) | (~mask & ret);
  }
  return ret;
});

//
// Chapter 12 syntax-case
//

//
// Chapter 13 Hashtables
//

//13.1  Constructors
//(define h (make-eq-hashtale)
//(define h (make-eq-hashtable 1000))
define_libfunc("make-eq-hashtable", 0, 1, function(ar){
  // Note: ar[1] (hashtable size) is just ignored
  return new Hashtable(Hashtable.eq_hash, Hashtable.eq_equiv);
});
//(make-eqv-hashtable)    procedure
//(make-eqv-hashtable k)    procedure
define_libfunc("make-eqv-hashtable", 0, 1, function(ar){
  return new Hashtable(Hashtable.eqv_hash, Hashtable.eqv_equiv);
});
//(make-hashtable hash-function equiv)    procedure
//(make-hashtable hash-function equiv k)    procedure
define_libfunc("make-hashtable", 2, 3, function(ar){
  assert_procedure(ar[0]);
  assert_procedure(ar[1]);
  return new Hashtable(ar[0], ar[1]);
});

//13.2  Procedures
// (hashtable? hash)
define_libfunc("hashtable?", 1, 1, function(ar){
  return ar[0] instanceof Hashtable;
});
//(hashtable-size hash)
define_libfunc("hashtable-size", 1, 1, function(ar){
  assert_hashtable(ar[0]);
  return ar[0].keys().length;
});

// Find a pair from a hashtable with given key.
//
// hash      - a BiwaScheme.Hashtable
// key       - an object
// callbacks - an object contains callback functions
//             .on_found     - function(pair, hashed)
//               pair   - [Object key, Object value]
//               hashed - Object hashed
//             .on_not_found - function(hashed)
//               hashed - Object hashed
//
// Returns an instance of BiwaScheme.Call.
const find_hash_pair = function(hash, key, callbacks){
  // invoke hash proc
  return new Call(hash.hash_proc, [key], function(ar){
    var hashed = ar[0];
    var candidate_pairs = hash.candidate_pairs(hashed);

    if (!candidate_pairs){ // shortcut: obviously not found
      return callbacks.on_not_found(hashed);
    }

    // search the exact key from candidates
    return Call.foreach(candidate_pairs, {
      call: function(pair){
        // invoke the equivalence proc
        return new Call(hash.equiv_proc, [key, pair[0]]);
      },
      result: function(equal, pair){
        if(equal) {       // found
          return callbacks.on_found(pair, hashed);
        }
      },
      finish: function(){ // not found
        return callbacks.on_not_found(hashed);
      }
    });
  });
};

//(hashtable-ref hash "foo" #f)
define_libfunc("hashtable-ref", 3, 3, function(ar){
  var hash = ar[0], key = ar[1], ifnone = ar[2];
  assert_hashtable(hash);

  return find_hash_pair(hash, key, {
    on_found: function(pair){
      return pair[1];
    },
    on_not_found: function(hashed){
      return ifnone;
    }
  });
});

//(hashtable-set! hash "foo" '(1 2))
define_libfunc("hashtable-set!", 3, 3, function(ar){
  var hash = ar[0], key = ar[1], value = ar[2];
  assert_hashtable(hash);
  assert(hash.mutable, "hashtable is not mutable");

  return find_hash_pair(hash, key, {
    on_found: function(pair){
      pair[1] = value;
      return undef;
    },
    on_not_found: function(hashed){
      hash.add_pair(hashed, key, value);
      return undef;
    }
  });
});

//(hashtable-delete! hash "foo")
define_libfunc("hashtable-delete!", 2, 2, function(ar){
  var hash = ar[0], key = ar[1];
  assert_hashtable(hash);
  assert(hash.mutable, "hashtable is not mutable");

  return find_hash_pair(hash, key, {
    on_found: function(pair, hashed){
      hash.remove_pair(hashed, pair);
      return undef;
    },
    on_not_found: function(hashed){
      return undef;
    }
  });
});

//(hashtable-contains? hash "foo")
define_libfunc("hashtable-contains?", 2, 2, function(ar){
  var hash = ar[0], key = ar[1];
  assert_hashtable(hash);

  return find_hash_pair(hash, key, {
    on_found: function(pair){
      return true;
    },
    on_not_found: function(hashed){
      return false;
    }
  });
});

//(hashtable-update! hashtable key proc default)    procedure
define_libfunc("hashtable-update!", 4, 4, function(ar){
  var hash = ar[0], key = ar[1], proc = ar[2], ifnone = ar[3];
  assert_hashtable(hash);
  assert(hash.mutable, "hashtable is not mutable");
  assert_procedure(proc);

  return find_hash_pair(hash, key, {
    on_found: function(pair, hashed){
      // invoke proc and get new value
      return new Call(proc, [pair[1]], function(ar){
        // replace the value
        pair[1] = ar[0];
        return undef;
      });
    },
    on_not_found: function(hashed){
      // invoke proc and get new value
      return new Call(proc, [ifnone], function(ar){
        // create new pair
        hash.add_pair(hashed, key, ar[0]);
        return undef;
      });
    }
  });
});
//(hashtable-copy hashtable)    procedure
//(hashtable-copy hashtable mutable)    procedure
define_libfunc("hashtable-copy", 1, 2, function(ar){
  var mutable = (ar[1]===undefined) ? false : !!ar[1];
  assert_hashtable(ar[0]);
  return ar[0].create_copy(mutable);
});
//(hashtable-clear! hashtable)    procedure
//(hashtable-clear! hashtable k)    procedure
define_libfunc("hashtable-clear!", 0, 1, function(ar){
  assert_hashtable(ar[0]);
  assert(ar[0].mutable, "hashtable is not mutable");
  ar[0].clear();
  return undef;
});
//(hashtable-keys hash)  ; => vector
define_libfunc("hashtable-keys", 1, 1, function(ar){
  assert_hashtable(ar[0]);
  return ar[0].keys();
});
//(hashtable-entries hash)  ; => two vectors (keys, values)
define_libfunc("hashtable-entries", 1, 1, function(ar){
  assert_hashtable(ar[0]);
  return new Values([ar[0].keys(), ar[0].values()]);
});

//13.3  Inspection

//(hashtable-equivalence-function hashtable)    procedure
define_libfunc("hashtable-equivalence-function", 1, 1, function(ar){
  assert_hashtable(ar[0]);
  return ar[0].equiv_proc;
});
//(hashtable-hash-function hashtable)    procedure
define_libfunc("hashtable-hash-function", 1, 1, function(ar){
  assert_hashtable(ar[0]);
  return ar[0].hash_proc;
});
//(hashtable-mutable? hashtable)    procedure
define_libfunc("hashtable-mutable?", 1, 1, function(ar){
  assert_hashtable(ar[0]);
  return ar[0].mutable;
});

//13.4  Hash functions

//(equal-hash obj)    procedure
define_libfunc("equal-hash", 0, 0, function(ar){
  return Hashtable.equal_hash;
});
//(string-hash string)    procedure
define_libfunc("string-hash", 0, 0, function(ar){
  return Hashtable.string_hash;
});
//(string-ci-hash string)    procedure
define_libfunc("string-ci-hash", 0, 0, function(ar){
  return Hashtable.string_ci_hash;
});
//(symbol-hash symbol)    procedure
define_libfunc("symbol-hash", 0, 0, function(ar){
  return Hashtable.symbol_hash;
});

//
// Chapter 14 Enumerators
//
//(make-enumeration symbol-list) -> enum-set(new type)
define_libfunc("make-enumeration", 1, 1, function(ar){
  assert_list(ar[0]);
  var members = ar[0].to_array();
  var enum_type = new Enumeration.EnumType(members);
  return enum_type.universe();
});

//(enum-set-universe enum-set) -> enum-set(same type as the argument)
define_libfunc("enum-set-universe", 1, 1, function(ar){
  assert_enum_set(ar[0]);
  return ar[0].enum_type.universe();
});

//(enum-set-indexer enum-set) -> (lambda (sym)) -> integer or #f
define_libfunc("enum-set-indexer", 1, 1, function(ar){
  assert_enum_set(ar[0]);
  return ar[0].enum_type.indexer();
});

//(enum-set-constructor enum-set) -> (lambda (syms)) -> enum-set(same type as the argument)
define_libfunc("enum-set-constructor", 1, 1, function(ar){
  assert_enum_set(ar[0]);
  return ar[0].enum_type.constructor_();
});

//(enum-set->list enum-set) -> symbol-list
define_libfunc("enum-set->list", 1, 1, function(ar){
  assert_enum_set(ar[0]);
  return ar[0].symbol_list();
});

//(enum-set-member? symbol enum-set) -> bool
define_libfunc("enum-set-member?", 2, 2, function(ar){
  assert_symbol(ar[0]);
  assert_enum_set(ar[1]);
  return ar[1].is_member(ar[0]);
});

//(enum-set-subset? esa esb) -> bool
define_libfunc("enum-set-subset?", 2, 2, function(ar){
  assert_enum_set(ar[0]);
  assert_enum_set(ar[1]);
  return ar[0].is_subset(ar[1]);
});

//(enum-set=? esa esb) -> bool
define_libfunc("enum-set=?", 2, 2, function(ar){
  assert_enum_set(ar[0]);
  assert_enum_set(ar[1]);
  return ar[0].equal_to(ar[1]);
});

//(enum-set-union es1 es2) -> enum-set
define_libfunc("enum-set-union", 2, 2, function(ar){
  assert_enum_set(ar[0]);
  assert_enum_set(ar[1]);
  assert(ar[0].enum_type === ar[1].enum_type,
         "two enum-sets must be the same enum-type", "enum-set-union");
  return ar[0].union(ar[1]);
});

//(enum-set-intersection es1 es2) -> enum-set
define_libfunc("enum-set-intersection", 2, 2, function(ar){
  assert_enum_set(ar[0]);
  assert_enum_set(ar[1]);
  return ar[0].intersection(ar[1]);
});

//(enum-set-difference es1 es2) -> enum-set
define_libfunc("enum-set-difference", 2, 2, function(ar){
  assert_enum_set(ar[0]);
  assert_enum_set(ar[1]);
  return ar[0].difference(ar[1]);
});

//(enum-set-complement enum-set) -> enum-set
define_libfunc("enum-set-complement", 1, 1, function(ar){
  assert_enum_set(ar[0]);
  return ar[0].complement();
});

//(enum-set-projection esa esb) -> enum-set
define_libfunc("enum-set-projection", 2, 2, function(ar){
  assert_enum_set(ar[0]);
  assert_enum_set(ar[1]);
  return ar[0].projection(ar[1]);
});

//(define-enumeration <type-name> (<symbol> ...) <constructor-syntax>)
// Example:
//   (define-enumeration color (red green black white) color-set)
//   this defines:
//     - an EnumType
//     - (color red) ;=> 'red
//     - (color-set red black) ;=> #<enum-set (red black)>
define_syntax("define-enumeration", function(x){
  // Extract parameters
  var type_name = x.cdr.car;
  assert(isSymbol(type_name),
         "expected symbol for type_name", "define-enumeration");
  type_name = type_name.name;

  var members = x.cdr.cdr.car;
  assert(isList(members),
         "expected list of symbol for members", "define-enumeration");
  members = members.to_array();

  var constructor_name = x.cdr.cdr.cdr.car;
  assert(isSymbol(constructor_name),
         "expected symbol for constructor_name", "define-enumeration");
  constructor_name = constructor_name.name;

  // Define EnumType
  var enum_type = new Enumeration.EnumType(members);

  // Define (color red)
  define_syntax(type_name, function(x){
    // (color)
    assert(!isNil(x.cdr),
           "an argument is needed", type_name);

    var arg = x.cdr.car;
    assert_symbol(arg, type_name);

    // Check arg is included in the universe
    assert(enum_type.members.includes(arg),
      arg.name+" is not included in the universe: "+
        to_write(enum_type.members),
      type_name);

    return List(Sym("quote"), arg);
  });

  // Define (color-set red black)
  define_syntax(constructor_name, function(x){
    assert_list(x.cdr, constructor_name);

    var symbols = x.cdr.to_array();

    // Check each argument is included in the universe
    symbols.forEach(function(arg){
      assert_symbol(arg, constructor_name);
      assert(enum_type.members.includes(arg),
        arg.name+" is not included in the universe: "+
          to_write(enum_type.members),
        constructor_name);
    });

    // Create an EnumSet
    return new Enumeration.EnumSet(enum_type, symbols);
  });
});

//
// Chapter 15 Composite library
//
//(rnrs 6) = all - eval - mutable pairs - mutable strings - r5rs compatibility

//
// Chapter 16 eval
//
//(eval expression environment)    procedure
define_libfunc("eval", 1, 1, function(ar, intp){
  //TODO: environment
  //TODO: this implementation has a bug that
  //  expressions which contains #<undef>, etc. cannot be evaluated.
  var expr = ar[0];
  var intp2 = new Interpreter(intp);
  return intp2.evaluate(to_write(expr));
});
//(environment import-spec ...)    procedure

//
// Chapter 17 Mutable pairs
//
//(set-car! pair obj)    procedure
//(set-cdr! pair obj)    procedure

//
// Chapter 18 Mutable strings
//
//(string-set! string k char)    procedure
// (string-fill! string char)    procedure

//
// Chapter 19 R5RS compatibility
//
//(exact->inexact z)    procedure
//(inexact->exact z)    procedure
//
//(null-environment n)    procedure
//(scheme-report-environment n)    procedure

//
// R7RS (TODO: split file?)
//

// R7RS Promise
//
// (delay expression)
define_syntax("delay", function(x){
  if (x.cdr === nil) {
    throw new BiwaError("malformed delay: no argument");
  }
  if (x.cdr.cdr !== nil) {
    throw new BiwaError("malformed delay: too many arguments: "+
                    write_ss(x));
  }
  var expr = x.cdr.car;
  // Expand into call of internal function
  // ( procedure->promise (lambda () (make-promise expr)))
  return new Pair(Sym(" procedure->promise"),
           new Pair(new Pair(Sym("lambda"),
                      new Pair(nil,
                        new Pair(new Pair(Sym("make-promise"),
                                   new Pair(expr, nil)),
                          nil)))));
});

// (delay-force promise-expr)
define_syntax("delay-force", function(x){
  if (x.cdr === nil) {
    throw new BiwaError("malformed delay-force: no argument");
  }
  if (x.cdr.cdr !== nil) {
    throw new BiwaError("malformed delay-force: too many arguments: "+
                    write_ss(x));
  }
  var expr = x.cdr.car;
  // Expand into call of internal function
  // ( procedure->promise (lambda () expr))
  return new Pair(Sym(" procedure->promise"),
           new Pair(new Pair(Sym("lambda"),
                      new Pair(nil,
                        new Pair(expr, nil))), nil));
});

// (force promise)
var force = function(promise) {
  if (promise.is_done()) {
    return promise.value();
  }
  return new Call(promise.thunk(), [], function(ar) {
    assert_promise(ar[0]);
    var new_promise = ar[0];
    if (promise.is_done()) {  // reentrant!
      return promise.value();
    }
    else {
      promise.update_with(new_promise);
      return force(new_promise);
    }
  });
};
define_libfunc("force", 1, 1, function(ar, intp){
  assert_promise(ar[0]);
  return force(ar[0]);
});

// (promise? obj)
define_libfunc("promise?", 1, 1, function(ar, intp){
  return (ar[0] instanceof BiwaPromise);
});

// (make-promise obj)
define_libfunc("make-promise", 1, 1, function(ar, intp){
  var obj = ar[0];
  if (obj instanceof BiwaPromise) {
    return obj;
  }
  else {
    return BiwaPromise.done(obj);
  }
});

// internal function
// ( procedure->promise proc)
// proc must be a procedure with no argument and return a promise
define_libfunc(" procedure->promise", 1, 1, function(ar, intp){
  assert_procedure(ar[0]);
  return BiwaPromise.fresh(ar[0]);
});

//
// parameterize
//

// (make-parameter init)
// (make-parameter init converter)
define_libfunc("make-parameter", 1, 2, function(ar, intp){
  let currentValue;
  const converter = ar[1];
  // A parameter is represented by a JS function.
  // (parameterObj)   ;=> Return the current value
  // (parameterObj v) ;=> Set v as the value and return the original value
  const parameterObj = function(ar2) {
    if (ar2.length == 0) { // Get
      return currentValue;
    }
    else { // Set
      const origValue = currentValue;
      if (converter) {
        return new Call(converter, [ar2[0]], ar3 => {
          currentValue = ar3[0];
          return origValue;
        });
      }
      else {
        currentValue = ar2[0];
        return origValue;
      }
    }
  };

  if (converter) {
    return new Call(converter, [ar[0]], initialValue => {
      currentValue = initialValue;
      return parameterObj;
    });
  }
  else {
    const initialValue = ar[0];
    currentValue = initialValue;
    return parameterObj;
  }
});

// (parameterize ((param val) ...) body ...)
define_syntax("parameterize", function(x){
  const inits = x.cdr.car.to_array();
  const body = x.cdr.cdr;
  const tmpNames = inits.map(() => gensym());
  // (let ((tmp0 val0) (tmp1 val1) ...)
  //   (dynamic-wind
  //     (lambda () (begin (set! tmp0 (param0 tmp0))) ...)
  //     (lambda () body ...)
  //     (lambda () (begin (set! tmp0 (param0 tmp0))) ...)))
  const givenValues = List(...inits.map((item, i) =>
    List(tmpNames[i], item.cdr.car)
  ));
  const updateValues = Cons(Sym("begin"), List(...inits.map((item, i) =>
    List(Sym("set!"), tmpNames[i], List(item.car, tmpNames[i]))
  )));
  
  const before = List(Sym("lambda"), nil, updateValues);
  const thunk = Cons(Sym("lambda"),
                  Cons(nil, body));
  const after = List(Sym("lambda"), nil, updateValues);
  //return List(Sym("quote"),
  return List(Sym("let"), givenValues,
           List(Sym("dynamic-wind"), before, thunk, after))
  //)
});