;; -*- scheme -*-
(library (core)
    (export :all)
    (import :none)
  (decl-code
   (.define "LIBSAGITTARIUS_BODY")
   (.include <sagittarius/private.h>
	     <sagittarius/private/instruction.h>
	     <sagittarius/private/builtin-symbols.h>
	     ;; need this...
	     "shortnames.incl"
	     "gc-incl.inc"))

  (define-cise-stmt assertion-violation
    ((_ who msg)
     `(begin
	(Sg_AssertionViolation ,who (SG_MAKE_STRING ,msg) '())))
    ((_ who msg irritants)
     `(begin
	(Sg_AssertionViolation ,who (SG_MAKE_STRING ,msg) ,irritants)
	 )))

  (define-cise-stmt wrong-type-of-argument-violation
    ((_ who msg got)
     `(begin
	(Sg_WrongTypeOfArgumentViolation ,who (SG_MAKE_STRING ,msg) ,got '())))
    ((_ who msg got irritants)
     `(begin
	(Sg_WrongTypeOfArgumentViolation ,who (SG_MAKE_STRING ,msg) ,got ,irritants))))
  
  (define-cise-stmt throw-i/o-error
    ((_ type who msg file)
     `(throw-i/o-error ,type ,who ,msg ,file SG_UNDEF))
    ((_ type who msg file ret)
     `(begin
	(Sg_IOError ,type ,who (SG_MAKE_STRING ,msg) ,file SG_UNDEF)
	(return ,ret))))

  ;; x=? macro
  (define-cise-stmt x=?
    ((_ checker compare name first second rest)
     `(begin
	(,checker ,name ,first)
	(,checker ,name ,second)
	(cond ((SG_NULLP ,rest)
	       (result (,compare ,first ,second)))
	      ((not (,compare ,first ,second))
	       (result FALSE))
	      (else
	       (let ((prev ,second))
		 (dolist (p ,rest)
		   (,checker ,name p)
		   (unless (,compare prev p)
		     (return #f))
		   (set! prev p))
		 (result TRUE)))))))

  ;; 11.1 base type
  (define-c-proc boolean? (o) ::<boolean> :constant SG_BOOLP)
  (define-c-proc pair? (o) ::<boolean> :constant (inline PAIRP) SG_PAIRP)
  (define-c-proc symbol? (o) ::<boolean> :constant (inline SYMBOLP) SG_SYMBOLP)
  (define-c-proc number? (o) ::<boolean> :constant SG_NUMBERP)
  (define-c-proc char? (o) ::<boolean> :constant SG_CHARP)
  (define-c-proc string? (o) ::<boolean> :constant SG_STRINGP)
  (define-c-proc vector? (o) ::<boolean> :constant (inline VECTORP) SG_VECTORP)
  (define-c-proc procedure? (o) ::<boolean> :constant SG_PROCEDUREP)
  (define-c-proc null? (o) ::<boolean> :constant (inline NULLP) SG_NULLP)

  ;; 11.5 equivalence predicates
  ;; defined in compare.c
  ;;(define-c-proc eq? (a b) ::<boolean> :constant (inline EQ) SG_EQ)
  ;;(define-c-proc eqv? (a b) ::<boolean> :constant (inline EQV) Sg_EqvP)
  ;;(define-c-proc equal? (a b) ::<boolean> :constant Sg_EqualP)

  ;; 11.7.4.1 numerical type predicates
  (define-c-proc complex? (o) ::<boolean> :constant SG_NUMBERP)
  (define-c-proc real? (o) ::<boolean> :constant SG_REALP)
  (define-c-proc rational? (o) ::<boolean> :constant Sg_RationalP)
  (define-c-proc integer? (o) ::<boolean> :constant Sg_IntegerP)
  (define-c-proc real-valued? (o) ::<boolean> :constant Sg_RealValuedP)
  (define-c-proc rational-valued? (o) ::<boolean> :constant Sg_RationalValuedP)
  (define-c-proc integer-valued? (o) ::<boolean> :constant Sg_IntegerValuedP)
  (define-c-proc exact? (o) ::<boolean> :constant Sg_ExactP)
  (define-c-proc inexact? (o) ::<boolean> :constant Sg_InexactP)

  ;; 11.7.4.2 generic conversions
  (define-c-proc inexact (z::<number>) :constant Sg_Inexact)
  (define-c-proc exact (z::<number>) :constant Sg_Exact)

  ;; 11.7.4.3 arithmetic operations
  (define-cise-stmt check-real
    ((_ name o)
     `(unless (SG_REALP ,o)
	(wrong-type-of-argument-violation ',name "real number" ,o))))

  (define-cise-stmt numcmp
    ((_ op compar)
     `(loop (cond ((not (,op (,compar arg0 arg1) 0)) (break))
		  ((SG_NULLP rest) (result TRUE) (break))
		  (else (set! arg0 arg1)
			(set! arg1 (SG_CAR rest))
			(set! rest (SG_CDR rest)))))))
  ;; = < > <= >=
  (define-c-proc = (arg0 arg1 :rest rest) ::<boolean> :constant
    (result FALSE)
    (loop (cond ((not (Sg_NumEq arg0 arg1)) (break))
		((SG_NULLP rest) (result TRUE) (break))
		(else (set! arg0 arg1)
		      (set! arg1 (SG_CAR rest))
		      (set! rest (SG_CDR rest))))))
  (define-c-proc < (arg0 arg1 :rest rest) ::<boolean> :constant
    (result FALSE)
    (numcmp < Sg_NumCmp))
  (define-c-proc <= (arg0 arg1 :rest rest) ::<boolean> :constant
    (result FALSE)
    (numcmp <= Sg_NumCmp))
  (define-c-proc > (arg0 arg1 :rest rest) ::<boolean> :constant
    (result FALSE)
    (numcmp > Sg_NumCmp))
  (define-c-proc >= (arg0 arg1 :rest rest) ::<boolean> :constant
    (result FALSE)
    (numcmp >= Sg_NumCmp))

  (define-c-proc zero?     (n::<number>) ::<boolean> :constant Sg_ZeroP)
  (define-c-proc positive? (x::<number>) ::<boolean> :constant Sg_PositiveP)
  (define-c-proc negative? (x::<number>) ::<boolean> :constant Sg_NegativeP)
  (define-c-proc odd?      (x::<number>) ::<boolean> :constant Sg_OddP)
  (define-c-proc even?     (x::<number>) ::<boolean> :constant
    (result (not (Sg_OddP x))))
  (define-c-proc finite?   (x::<number>) ::<boolean> Sg_FiniteP)
  (define-c-proc infinite? (x::<number>) ::<boolean> Sg_InfiniteP)
  (define-c-proc nan?      (x::<number>) ::<boolean> Sg_NanP)
    
  (define-c-proc max (arg0 :rest rest) :constant
    (Sg_MinMax arg0 rest NULL (& SG_RESULT)))
  (define-c-proc min (arg0 :rest rest) :constant
    (Sg_MinMax arg0 rest (& SG_RESULT) NULL))

  ;; arithmetic
  (define-cise-stmt check-number
    ((_ name v)
     `(unless (SG_NUMBERP ,v)
	(wrong-type-of-argument-violation ',name "number" ,v))))

  ;; are these arithmetic operation constant?
  (define-c-proc + (:rest rest) :constant
    (cond ((not (SG_PAIRP rest)) (result (SG_MAKE_INT 0)))
	  ((not (SG_NUMBERP (SG_CAR rest)))
	   (wrong-type-of-argument-violation '+ "number" (SG_CAR rest) rest)
	   (result SG_UNDEF))		; dummy
	  (else 
	   (let ((r (SG_CAR rest)))
	     (dolist (v (SG_CDR rest))
	       (check-number + v)
	       (set! r (Sg_Add r v)))
	     (result r)))))

  (define-c-proc * (:rest rest) :constant
    (cond ((not (SG_PAIRP rest)) (result (SG_MAKE_INT 1)))
	  ((not (SG_NUMBERP (SG_CAR rest)))
	   (wrong-type-of-argument-violation '+ "number" (SG_CAR rest) rest)
	   (result SG_UNDEF))		; dummy
	  (else 
	   (let ((r (SG_CAR rest)))
	     (dolist (v (SG_CDR rest))
	       (check-number * v)
	       (set! r (Sg_Mul r v)))
	     (result r)))))

  (define-c-proc - (arg1::<number> :rest rest) :constant
    (if (SG_NULLP rest)
	(result (Sg_Negate arg1))
	(begin 
	  (dolist (v rest)
	    (check-number - v)
	    (set! arg1 (Sg_Sub arg1 v)))
	  (result arg1))))

  (define-c-proc / (arg1::<number> :rest rest) :constant
    (if (SG_NULLP rest)
	(result (Sg_Inverse arg1))
	(let ((exact::int (Sg_ExactP arg1)))
	  (dolist (v rest)
	    (check-number / v)
	    ;; if inexact numbers have already appeared, 
	    ;; we can skip checking
	    (when exact (set! exact (Sg_ExactP v)))
	    (when (and exact (Sg_ZeroP v))
	      (assertion-violation '/ "undefined for 0" (Sg_Cons arg1 rest)))
	    (set! arg1 (Sg_Div arg1 v)))
	  (result arg1))))

  ;; base arithmetic
  (define-c-proc abs (x::<number>) :constant Sg_Abs)
  (define-c-proc numerator (x::<number>) :constant Sg_Numerator)
  (define-c-proc denominator (x::<number>) :constant Sg_Denominator)

  (define-cise-stmt check-real-valued
    ((_ name n)
     `(unless (Sg_RealValuedP ,n)
	(wrong-type-of-argument-violation ',name "real number" ,n))))

  (define-c-proc floor (x::<number>) :constant
    (check-real-valued floor x)
    (result (Sg_Round x SG_ROUND_FLOOR)))

  (define-c-proc ceiling (x::<number>) :constant
    (check-real-valued ceiling x)
    (result (Sg_Round x SG_ROUND_CEIL)))

  (define-c-proc truncate (x::<number>) :constant
    (check-real-valued truncate x)
    (result (Sg_Round x SG_ROUND_TRUNC)))

  (define-c-proc round (x::<number>) :constant
    (check-real-valued round x)
    (result (Sg_Round x SG_ROUND_ROUND)))

  (define-cise-stmt check-finite
    ((_ name n)
     `(unless (Sg_FiniteP ,n)
	(wrong-type-of-argument-violation ',name "finite" ,n))))

  (define-cise-stmt check-not-nan
    ((_ name n)
     `(when (Sg_NanP ,n)
	(wrong-type-of-argument-violation ',name "non nan" ,n))))

  (define-cise-stmt check-not-zero
    ((_ name n)
     `(when (Sg_ZeroP ,n)
	(wrong-type-of-argument-violation ',name "not zero" ,n))))

  (define-cise-stmt check-integer-arith-argument
    ((_ name x y)
     `(begin
	(check-finite ,name ,x)
	(check-not-nan ,name ,x)
	(check-not-zero ,name ,y))))

  (define-c-proc div (x::<number> y::<number>) :constant
    (check-integer-arith-argument div x y)
    (result (Sg_IntegerDiv x y)))

  (define-c-proc mod (x::<number> y::<number>) :constant
    (check-integer-arith-argument mod x y)
    (result (Sg_IntegerMod x y)))

  (define-c-proc div0 (x::<number> y::<number>) :constant
    (check-integer-arith-argument div0 x y)
    (result (Sg_IntegerDiv0 x y)))

  (define-c-proc mod0 (x::<number> y::<number>) :constant
    (check-integer-arith-argument mod0 x y)
    (result (Sg_IntegerMod0 x y)))

  ;; takes 2. r6rs implementation is in scmlib.scm
  (define-c-proc %gcd (x::<number> y::<number>) :constant Sg_Gcd)

  (define-c-proc exp (x::<number>) :constant Sg_Exp)
  (define-c-proc expt (x::<number> y::<number>) :constant Sg_Expt)

  (define-c-proc log (x::<number> :optional base::<number>) :constant
    (if (SG_UNBOUNDP base)
	(if (== x (SG_MAKE_INT 0))
	    (assertion-violation 'log "undefined for 0" x)
	    (result (Sg_Log x)))
	(result (Sg_Div (Sg_Log x) (Sg_Log base)))))

  (define-c-proc make-rectangular (a::<number> b::<number>) :constant
    (unless (SG_REALP a)
      (wrong-type-of-argument-violation 'make-rectangular "real number required"
					a (SG_LIST2 a b)))
    (unless (SG_REALP b)
      (wrong-type-of-argument-violation 'make-rectangular "real number required"
					b (SG_LIST2 a b)))
    (result (Sg_MakeComplex a b)))

  (define-c-proc make-polar (r::<number> t::<number>) :constant
    (unless (SG_REALP r)
      (wrong-type-of-argument-violation 'make-polar "real number required"
					r (SG_LIST2 r t)))
    (unless (SG_REALP t)
      (wrong-type-of-argument-violation 'make-polar "real number required"
					t (SG_LIST2 r t)))
    (result (Sg_MakeComplexPolar r t)))

  (define-c-proc real-part (r::<number>) :constant
    (cond ((SG_COMPLEXP r)
	   (result (-> (SG_COMPLEX r) real)))
	  ((SG_REALP r) (result r))
	  (else
	   ;; never happen
	   (wrong-type-of-argument-violation 'real-part "number required" r))))

  (define-c-proc imag-part (r::<number>) :constant
    (cond ((SG_COMPLEXP r)
	   (result (-> (SG_COMPLEX r) imag)))
	  ((SG_REALP r)
	   (result (SG_MAKE_INT 0)))
	  (else
	   (wrong-type-of-argument-violation 'imag-part "number required" r))))

  (define-c-proc magnitude (n::<number>) :constant Sg_Magnitude)
  (define-c-proc angle (n::<number>) :constant Sg_Angle)

  (define-c-proc sin (n::<number>) :constant Sg_Sin)
  (define-c-proc cos (n::<number>) :constant Sg_Cos)
  (define-c-proc tan (n::<number>) :constant Sg_Tan)
  (define-c-proc asin (n::<number>) :constant Sg_Asin)
  (define-c-proc acos (n::<number>) :constant Sg_Acos)

  (define-c-proc atan (n::<number> :optional n2::<number>) :constant
    (cond ((SG_UNBOUNDP n2) (result (Sg_Atan n)))
	  (else 
	   (check-real-valued atan n)
	   (check-real-valued atan n2)
	   (result (Sg_Atan2 n n2)))))

  (define-c-proc sqrt (n::<number>) :constant Sg_Sqrt)
  (define-c-proc exact-integer-sqrt (n::<number>) :constant
    (when (or (Sg_NegativeP n) (not (SG_EXACT_INTP n)))
      (wrong-type-of-argument-violation 'exact-integer-sqrt
					"non-negative exact integer required"
					n))
    (result (Sg_ExactIntegerSqrt n)))

  (define-c-proc rationalize (x::<number> e::<number>) :constant
    (check-real rationalize x)
    (check-real rationalize e)
    (result (Sg_Rationalize x e)))

  ;; r5rs compatible
  (define-c-proc quotient (n1::<number> n2::<number>) :constant
    (when (SG_EQ n2 (SG_MAKE_INT 0))
      (assertion-violation 'quotient "attempt to calculate a quotient by zero"
			   (SG_LIST2 n1 n2)))
    (result (Sg_Quotient n1 n2 NULL)))

  (define-c-proc remainder (n1::<number> n2::<number>) :constant
    (result (Sg_Modulo n1 n2 TRUE)))

  (define-c-proc modulo (n1::<number> n2::<number>) :constant
    (result (Sg_Modulo n1 n2 FALSE)))

  (define-c-proc integer-length (n::<number>) ::<fixnum> :constant 
    Sg_IntegerLength)

  ;; 11.7.4.4 numerical input and output
  (define-c-proc number->string (z::<number>
				 :optional (radix::<fixnum> 10)
				 precision) :constant
    ;; ignore precision
    (result (Sg_NumberToString z (cast int radix) FALSE)))

  (define-c-proc string->number (s::<string> :optional (radix::<fixnum> 10)) 
    :constant
    (result (Sg_StringToNumber s (cast int radix) FALSE)))

  ;; 11.8 booleans
  (define-c-proc not (arg0) ::<boolean> :constant (inline NOT) SG_FALSEP)

  (define-cise-stmt check-boolean
    ((_ name b)
     `(unless (SG_BOOLP ,b)
	(wrong-type-of-argument-violation ',name "boolean" ,b))))

  (define-c-proc boolean=? (b1 b2 :rest rest) ::<boolean> :constant
    (x=? check-boolean SG_EQ boolean=? b1 b2 rest))

  ;; 11.9 pairs and lists
  (define-c-proc cons (o1 o2) :no-side-effect (inline CONS) Sg_Cons)
  (define-c-proc car (o::<pair>) :constant
    (inline CAR) (setter set-car!) SG_CAR)

  (define-c-proc cdr (o::<pair>) :constant
    (inline CDR) (setter set-cdr!) SG_CDR)

  "#define CXR_SETTER(PRE, pre, tail)   \
    SgObject cell = Sg_C##tail##r(obj); \
    if (!SG_PAIRP(cell)) \
     Sg_Error(UC(\"can't set c\" #pre #tail \"r of %S\"), obj); \
    SG_SET_C##PRE##R(cell, value);"

  (define-c-proc caar (o::<pair>) :constant (inline CAAR)
    (setter (obj value) ::<void> (CXR_SETTER A a a)) Sg_Caar)
  (define-c-proc cadr (o::<pair>) :constant (inline CADR)
    (setter (obj value) ::<void> (CXR_SETTER A a d)) Sg_Cadr)
  (define-c-proc cdar (o::<pair>) :constant (inline CDAR)
    (setter (obj value) ::<void> (CXR_SETTER D d a)) Sg_Cdar)
  (define-c-proc cddr (o::<pair>) :constant (inline CDDR)
    (setter (obj value) ::<void> (CXR_SETTER D d d)) Sg_Cddr)

  ;; moved from (core base)
  ;; Why did I do this...
  "#define CXXR_SETTER(PRE, pre, tail)   \
    SgObject cell = Sg_C##pre##r(Sg_C##tail##r(obj)); \
    if (!SG_PAIRP(cell)) \
     Sg_Error(UC(\"can't set c\" #pre #tail \"r of %S\"), obj); \
    SG_SET_C##PRE##R(cell, value);"  

  (define-c-proc caaar 	(o) :constant
    (setter (obj value) ::<void> (CXXR_SETTER A a a))
    (result (Sg_Car  (Sg_Caar o))))
  (define-c-proc caadr 	(o) :constant
    (setter (obj value) ::<void> (CXXR_SETTER A a d))
    (result (Sg_Car  (Sg_Cadr o))))
  (define-c-proc cadar 	(o) :constant
    (setter (obj value) ::<void> (CXXR_SETTER A d a))
    (result (Sg_Car  (Sg_Cdar o))))
  (define-c-proc caddr 	(o) :constant
    (setter (obj value) ::<void> (CXXR_SETTER A d d))
    (result (Sg_Car  (Sg_Cddr o))))
  (define-c-proc cdaar 	(o) :constant
    (setter (obj value) ::<void> (CXXR_SETTER D a a))
    (result (Sg_Cdr  (Sg_Caar o))))
  (define-c-proc cdadr 	(o) :constant
    (setter (obj value) ::<void> (CXXR_SETTER D a d))
    (result (Sg_Cdr  (Sg_Cadr o))))
  (define-c-proc cddar 	(o) :constant
    (setter (obj value) ::<void> (CXXR_SETTER D d a))
    (result (Sg_Cdr  (Sg_Cdar o))))
  (define-c-proc cdddr 	(o) :constant
    (setter (obj value) ::<void> (CXXR_SETTER D d d))
    (result (Sg_Cdr  (Sg_Cddr o))))
  (define-c-proc caaaar (o) :constant
    (setter (obj value) ::<void> (CXXR_SETTER A a aa))
    (result (Sg_Caar (Sg_Caar o))))
  (define-c-proc caaadr (o) :constant
    (setter (obj value) ::<void> (CXXR_SETTER A a ad))
    (result (Sg_Caar (Sg_Cadr o))))
  (define-c-proc caadar (o) :constant
    (setter (obj value) ::<void> (CXXR_SETTER A a da))
    (result (Sg_Caar (Sg_Cdar o))))
  (define-c-proc caaddr (o) :constant
    (setter (obj value) ::<void> (CXXR_SETTER A a dd))
    (result (Sg_Caar (Sg_Cddr o))))
  (define-c-proc cadaar (o) :constant
    (setter (obj value) ::<void> (CXXR_SETTER A d aa))
    (result (Sg_Cadr (Sg_Caar o))))
  (define-c-proc cadadr (o) :constant
    (setter (obj value) ::<void> (CXXR_SETTER A d ad))
    (result (Sg_Cadr (Sg_Cadr o))))
  (define-c-proc caddar (o) :constant
    (setter (obj value) ::<void> (CXXR_SETTER A d da))
    (result (Sg_Cadr (Sg_Cdar o))))
  (define-c-proc cadddr (o) :constant
    (setter (obj value) ::<void> (CXXR_SETTER A d dd))
    (result (Sg_Cadr (Sg_Cddr o))))
  (define-c-proc cdaaar (o) :constant
    (setter (obj value) ::<void> (CXXR_SETTER D a aa))
    (result (Sg_Cdar (Sg_Caar o))))
  (define-c-proc cdaadr (o) :constant
    (setter (obj value) ::<void> (CXXR_SETTER D a ad))
    (result (Sg_Cdar (Sg_Cadr o))))
  (define-c-proc cdadar (o) :constant
    (setter (obj value) ::<void> (CXXR_SETTER D a da))
    (result (Sg_Cdar (Sg_Cdar o))))
  (define-c-proc cdaddr (o) :constant
    (setter (obj value) ::<void> (CXXR_SETTER D a dd))
    (result (Sg_Cdar (Sg_Cddr o))))
  (define-c-proc cddaar (o) :constant
    (setter (obj value) ::<void> (CXXR_SETTER D d aa))
    (result (Sg_Cddr (Sg_Caar o))))
  (define-c-proc cddadr (o) :constant
    (setter (obj value) ::<void> (CXXR_SETTER D d ad))
    (result (Sg_Cddr (Sg_Cadr o))))
  (define-c-proc cdddar (o) :constant
    (setter (obj value) ::<void> (CXXR_SETTER D d da))
    (result (Sg_Cddr (Sg_Cdar o))))
  (define-c-proc cddddr (o) :constant
    (setter (obj value) ::<void> (CXXR_SETTER D d dd))
    (result (Sg_Cddr (Sg_Cddr o))))


  (define-c-proc list? (arg0) ::<boolean> :constant SG_PROPER_LISTP)
  (define-c-proc list (:rest rest) :no-side-effect (inline LIST) (result rest))
  (define-c-proc length (lst) ::<fixnum> :constant Sg_Length)
  ;; are these transparent?
  (define-c-proc append (:rest lst) :no-side-effect (inline APPEND) Sg_Append)
  (define-c-proc reverse (lst) :no-side-effect Sg_Reverse)

  (define-c-proc list-tail (lst k::<fixnum> :optional fallback) :constant
    Sg_ListTail)
  ;; from where should we expose this?
  (define-c-proc list-set! (lst k::<fixnum> v)
    (let ((p (Sg_ListTail lst k SG_FALSE)))
      (if (SG_PAIRP p)
	  (SG_SET_CAR p v)
	  (assertion-violation 'list-set! "index out of bound"
			       (SG_LIST2 lst (SG_MAKE_INT k))))))
  (define-c-proc list-ref (lst k::<fixnum> :optional fallback) :constant
    (setter list-set!)
    Sg_ListRef)
  ;; list miscs
  (define-c-proc last-pair (lst) :constant Sg_LastPair)

  ;; 11.10 symbols
  (define-c-proc symbol->string (z::<symbol>) :constant SG_SYMBOL_NAME)

  (define-cise-stmt check-symbol
    ((_ name s)
     `(unless (SG_SYMBOLP ,s)
	(wrong-type-of-argument-violation ',name "symbol" ,s))))

  (define-c-proc symbol=? (s1::<symbol> s2::<symbol> :rest rest)
    ::<boolean> :constant
    (x=? check-symbol SG_EQ symbol=? s1 s2 rest))

  (define-c-proc string->symbol (z::<string>) :constant Sg_Intern)

  ;; 11.11 characters
  (define-cise-stmt check-char
    ((_ name c)
     `(unless (SG_CHARP ,c)
	(wrong-type-of-argument-violation ',name "char" ,c))))

  (define-c-proc char->integer (c::<char>) :constant SG_MAKE_INT)

  (define-c-proc integer->char (ch::<fixnum>) :constant
    (unless (or (and (<= 0 ch) (<= ch #xD7FF))
		(and (<= #xE000 ch) (<= ch #x10FFFF)))
      (assertion-violation 'integer->char "code point out of range"
			   (SG_MAKE_INT ch)))
    (result (SG_MAKE_CHAR ch)))

  (define-c-proc char=? (c1 c2 :rest rest) ::<boolean> :constant
    (x=? check-char SG_EQ char=? c1 c2 rest))

  (define-cise-stmt char<>=?
    ((_ compare name first second rest)
     `(begin
	(check-char ,name ,first)
	(check-char ,name ,second)
	(cond ((SG_NULLP ,rest)
	       (result (,compare ,first ,second)))
	      ((not (,compare ,first ,second))
	       (result FALSE))
	      (else
	       (let ((prev ,second))
		 (dolist (p ,rest)
		   (check-char ,name p)
		   (unless (,compare prev p)
		     (return #f))
		   (set! prev p))
		 (result TRUE)))))))

  (define-c-proc char<? (c1 c2 :rest rest) ::<boolean> :constant
    (char<>=? < char<? c1 c2 rest))

  (define-c-proc char>? (c1 c2 :rest rest) ::<boolean> :constant
    (char<>=? > char>? c1 c2 rest))

  (define-c-proc char<=? (c1 c2 :rest rest) ::<boolean> :constant
    (char<>=? <= char<=? c1 c2 rest))

  (define-c-proc char>=? (c1 c2 :rest rest) ::<boolean> :constant
    (char<>=? >= char>=? c1 c2 rest))

  ;; 11.12 strings
  (define-cise-stmt check-string
    ((_ name s)
     `(unless (SG_STRINGP ,s)
	(wrong-type-of-argument-violation ',name "string" ,s))))

  (define-c-proc make-string (k::<fixnum> :optional (c::<char> #\space))
    Sg_ReserveString)
  (define-c-proc string (:rest rest) :no-side-effect
    (result (Sg_ListToString rest 0 -1)))
  (define-c-proc string-length (s::<string>) ::<fixnum> :constant 
    SG_STRING_SIZE)

  (define-c-proc string-ref (s::<string> k::<fixnum> :optional fallback)
    :constant
    (setter string-set!)
    (cond ((SG_UNBOUNDP fallback)
	   (result (SG_MAKE_CHAR (Sg_StringRef s k))))
	  ((and (<= 0 k) (< k (SG_STRING_SIZE s)))
	   (result (SG_MAKE_CHAR (Sg_StringRef s k))))
	  (else (result fallback))))

  ;; string compares
  (define-c-proc string=? (s1::<string> s2::<string> :rest rest)
    ::<boolean> :constant
    (x=? check-string Sg_StringEqual string=? s1 s2 rest))

  (define-cise-stmt string-compare
    ((_ compare value name first second rest)
     `(begin
	(cond ((SG_NULLP ,rest)
	       (result (,compare (Sg_StringCompare ,first ,second) ,value)))
	      ((not (,compare (Sg_StringCompare ,first ,second) ,value))
	       (result FALSE))
	      (else
	       (let ((prev ,second))
		 (dolist (p ,rest)
		   (check-string ,name p)
		   (unless (,compare (Sg_StringCompare prev p) ,value)
		     (return #f))
		   (set! prev p))
		 (result TRUE)))))))

  (define-c-proc string<? (s1::<string> s2::<string> :rest rest)
    ::<boolean> :constant
    (string-compare == -1 string<? s1 s2 rest))
  (define-c-proc string>? (s1::<string> s2::<string> :rest rest)
    ::<boolean> :constant
    (string-compare == 1 string>? s1 s2 rest))
  (define-c-proc string<=? (s1::<string> s2::<string> :rest rest)
    ::<boolean> :constant
    (string-compare <= 0 string<=? s1 s2 rest))
  (define-c-proc string>=? (s1::<string> s2::<string> :rest rest)
    ::<boolean> :constant
    (string-compare >= 0 string>=? s1 s2 rest))

  (define-c-proc substring (s::<string> start::<fixnum> end::<fixnum>)
    :no-side-effect
    (when (< start 0)
      (wrong-type-of-argument-violation 'substring "non negative exact integer"
					(SG_MAKE_INT start)
					(SG_LIST3 s (SG_MAKE_INT start) 
						  (SG_MAKE_INT end))))
    (when (< end 0)
      (wrong-type-of-argument-violation 'substring "non negative exact integer"
					(SG_MAKE_INT end)
					(SG_LIST3 s (SG_MAKE_INT start)
						  (SG_MAKE_INT end))))
    (when (< end start)
      (assertion-violation 'substring "end index is smaller than start index"
			   (SG_LIST3 s (SG_MAKE_INT start) (SG_MAKE_INT end))))
    (when (< (SG_STRING_SIZE s) end)
      (assertion-violation 'substring "end index out of bounds"
			   (SG_LIST3 s (SG_MAKE_INT start) (SG_MAKE_INT end))))
    (result (Sg_Substring s start end)))

  (define-c-proc string-append (:rest rest) :no-side-effect Sg_StringAppend)

  ;; we take start+end as optional arguments for srfi-13
  (define-c-proc string->list
    (s::<string> :optional (start::<fixnum> 0) (end::<fixnum> -1))
    :no-side-effect
    Sg_StringToList)
  
  (define-c-proc list->string 
    (o::<list> :optional (start::<fixnum> 0) (end::<fixnum> -1))
    :no-side-effect
    Sg_ListToString)

  ;; we take start+end as optional arguments for srfi-13
  (define-c-proc string-copy
    (s::<string> :optional (start::<fixnum> 0) (end::<fixnum> -1))
    :no-side-effect
    Sg_Substring)

  ;; 11.13 vectors
  (define-c-proc make-vector (size::<fixnum> :optional fill) :no-side-effect
    (when (SG_UNBOUNDP fill) (set! fill  SG_UNDEF))
    (result (Sg_MakeVector size fill)))

  (define-c-proc vector (:rest rest) :no-side-effect (inline VECTOR)
    (result (Sg_ListToVector rest 0 -1)))

  (define-c-proc vector-length (vec::<vector>) ::<fixnum> :constant
    (inline VEC_LEN)
    (result (SG_VECTOR_SIZE vec)))

  (define-c-proc vector-ref (vec::<vector> i::<fixnum> :optional fallback)
    :constant (setter vector-set!)
    (cond ((or (< i 0)
	       (>= i (SG_VECTOR_SIZE vec)))
	   (when (SG_UNBOUNDP fallback)
	     (assertion-violation 'vector-ref "index out of range" 
				  (SG_MAKE_INT i)))
	   (result fallback))
	  (else (result (SG_VECTOR_ELEMENT vec i)))))
     
  (define-c-proc vector-set! (vec::<vector> i::<fixnum> obj) ::<void>
    (when (SG_LITERAL_VECTORP vec)
      (assertion-violation 'vector-set "attempt to modify immutable vector"
			   (SG_LIST1 vec)))
    (cond ((or (< i 0) (>= i (SG_VECTOR_SIZE vec)))
	   (assertion-violation 'vector-ref "index out of range"
				(SG_MAKE_INT i)))
	  (else (set! (SG_VECTOR_ELEMENT vec i) obj))))

  (define-c-proc vector->list 
    (vec::<vector> :optional (start::<fixnum> 0) (end::<fixnum> -1))
    :no-side-effect
    Sg_VectorToList)
  
  (define-c-proc list->vector 
    (lst :optional (start::<fixnum> 0) (end::<fixnum> -1)) :no-side-effect
    (unless (SG_LISTP lst)
      (wrong-type-of-argument-violation 'list->vector "propert list" lst))
    (result (Sg_ListToVector lst start end)))

  (define-c-proc vector-fill! 
    (vec::<vector> fill :optional (start::<fixnum> 0) (end::<fixnum> -1))
    ::<void>
    Sg_VectorFill)

  ;; 11.14 errors and violations
  (define-c-proc assertion-violation (who message :rest irritants) ::<void>
    Sg_AssertionViolation)

  (define-c-proc error (who message :rest irritants) ::<void>
    (let ((condi SG_FALSE))
      (if (SG_FALSEP who)
	  (set! condi 
		(Sg_Condition 
		 (SG_LIST2 (Sg_MakeError message)
			   (Sg_MakeIrritantsCondition irritants))))
	  (set! condi 
		(Sg_Condition 
		 (SG_LIST3 (Sg_MakeError message)
			   (Sg_MakeWhoCondition who)
			   (Sg_MakeIrritantsCondition irritants)))))
      (Sg_Raise condi FALSE)))

  ;; we might remove this
  (define-c-proc scheme-error (who msg :rest irritant) ::<void>
    (Sg_Error (UC "%S %A %S") who msg irritant))

  (define-c-proc syntax-error (form :rest irritant) ::<void>
    Sg_SyntaxError)

  ;; 11.15 control features
  ;; is apply constant? I think it's depending on the given procedure...
  (define-c-proc apply (proc::<procedure> arg1 :rest rest) :no-side-effect
    (inline APPLY)
    ;; can we consider this no-side-effect?
    (let ((head::SgObject '()) (tail::SgObject '()))
      (cond ((SG_NULLP rest) (result (Sg_VMApply proc arg1)))
	    (else 
	     (set! head (Sg_Cons arg1 '()))
	     (set! tail head)
	     (dopairs (cp rest)
	       (when (SG_NULLP (SG_CDR cp))
		 (SG_APPEND head tail (SG_CAR cp))
		 (break))
	       (unless (SG_PAIRP (SG_CDR cp))
		 (assertion-violation 'apply "improper list not allowed"
				      rest))
	       (SG_APPEND1 head tail (SG_CAR cp)))
	     (result (Sg_VMApply proc head))))))

  ;; call/cc
  (define-c-proc call/cc (proc::<procedure>) Sg_VMCallCC)
  (define-c-proc call-with-current-continuation (proc::<procedure>) Sg_VMCallCC)

  (define-c-proc values (:rest rest) :constant (inline VALUES) Sg_Values)
  (define-c-proc dynamic-wind (before thunk after) Sg_VMDynamicWind)

  ;; standard libraries
  ;; 1 Unicode
  ;; 1.1 characters
  (define-cise-stmt check-char
    ((_ name c)
     `(unless (SG_CHARP ,c)
	(wrong-type-of-argument-violation ',name "character" ,c))))

  ;; these can be constant since we always return the same value
  ;; however no guarantee that unicode spec itself gets changed
  ;; so just as it is for now.
  ;; remember unicode 1.1 to unicode 2.0, this may happen in future...
  (define-c-proc char-upcase (c::<char>) ::<char> :no-side-effect Sg_CharUpCase)
  (define-c-proc char-downcase (c::<char>) ::<char> :no-side-effect 
    Sg_CharDownCase)
  (define-c-proc char-titlecase (c::<char>) ::<char> :no-side-effect
    Sg_CharTitleCase)
  (define-c-proc char-foldcase (c::<char>) ::<char> :no-side-effect
    Sg_CharFoldCase)

  (define-c-proc char-general-category (c::<char>) :no-side-effect
    (result (Sg_CategroyToSymbol (Sg_CharGeneralCategory c))))

  (define-c-proc char-alphabetic? (c::<char>) ::<boolean> :no-side-effect
    Sg_CharAlphabeticP)
  (define-c-proc char-numeric? (c::<char>) ::<boolean> :no-side-effect
    Sg_CharNumericP)
  (define-c-proc char-whitespace? (c::<char>) ::<boolean> :no-side-effect
    Sg_Ucs4WhiteSpaceP)
  (define-c-proc char-upper-case? (c::<char>) ::<boolean> :no-side-effect
    Sg_CharUpperCaseP)
  (define-c-proc char-lower-case? (c::<char>) ::<boolean> :no-side-effect
    Sg_CharLowerCaseP)
  (define-c-proc char-title-case? (c::<char>) ::<boolean> :no-side-effect
    Sg_CharTitleCaseP)

  ;; 1.2 strings
  ;; for SRFI-13

  ;; these will allocate new string so not constant
  (define-c-proc string-upcase
    (s::<string> :optional (start::<fixnum> 0) (end::<fixnum> -1))
    :no-side-effect
    (result (Sg_StringUpCase (Sg_MaybeSubstring s start end))))

  (define-c-proc string-downcase
    (s::<string> :optional (start::<fixnum> 0) (end::<fixnum> -1))
    :no-side-effect
    (result (Sg_StringDownCase (Sg_MaybeSubstring s start end))))

  (define-c-proc string-titlecase
    (s::<string> :optional (start::<fixnum> 0) (end::<fixnum> -1))
    :no-side-effect
    (result (Sg_StringTitleCase (Sg_MaybeSubstring s start end) FALSE)))

  (define-c-proc string-foldcase
    (s::<string> :optional (start::<fixnum> 0) (end::<fixnum> -1))
    :no-side-effect
    (result (Sg_StringFoldCase (Sg_MaybeSubstring s start end))))
  ;; TODO Should we also add start end to these?
  (define-c-proc string-normalize-nfd (s::<string>)  :no-side-effect 
    Sg_StringNormalizeNfd)
  (define-c-proc string-normalize-nfkd (s::<string>) :no-side-effect 
    Sg_StringNormalizeNfkd)
  (define-c-proc string-normalize-nfc  (s::<string>) :no-side-effect 
    Sg_StringNormalizeNfc)
  (define-c-proc string-normalize-nfkc (s::<string>) :no-side-effect 
    Sg_StringNormalizeNfkc)

  ;; 2 Bytevectors
  ;; 2.2 general operations
  (define-c-proc native-endianness () :no-side-effect Sg_NativeEndianness)
  (define-c-proc bytevector=? (bv1::<bytevector> bv2::<bytevector>)
    ::<boolean> :constant
    Sg_ByteVectorEqP)

  (define-c-proc bytevector-copy 
    (src::<bytevector> :optional (start::<fixnum> 0) (end::<fixnum> -1))
    :no-side-effect
    Sg_ByteVectorCopy)

  (define-cise-stmt check-non-negative-fixnum
    ((_ name n)
     `(when (< ,n 0)
	(wrong-type-of-argument-violation ',name
					  "non negative exact integer"
					  (SG_MAKE_INT ,n)))))

  (define-c-proc bytevector-copy! (src::<bytevector> sstart::<fixnum>
				   dst::<bytevector> dstart::<fixnum>
				   k::<fixnum>)
    ::<void>
    (check-non-negative-fixnum bytevector-copy! sstart)
    (check-non-negative-fixnum bytevector-copy! dstart)
    (Sg_ByteVectorCopyX src sstart dst dstart k))

  (define-c-proc make-bytevector (len::<fixnum> :optional (fill::<fixnum> 0))
    :no-side-effect
    (check-non-negative-fixnum make-bytevector len)
    (result (Sg_MakeByteVector len (cast int fill))))

  (define-c-proc bytevector? (o) ::<boolean> :constant SG_BVECTORP)

  (define-c-proc bytevector-length (bv::<bytevector>) ::<fixnum> :constant
    SG_BVECTOR_SIZE)

  (define-c-proc bytevector-fill! 
    (bv::<bytevector> fill::<fixnum> :optional (start::<fixnum> 0) (end::<fixnum> -1)) ::<void>
    (Sg_ByteVectorFill bv (cast int fill) start end))
  
  ;; 2.3 operations on bytes and octets
  (define-c-proc u8-list->bytevector (lst) :no-side-effect
    (result (Sg_ListToByteVector lst 8 FALSE)))

  (define-c-proc bytevector->u8-list (lst) :no-side-effect
    (result (Sg_ByteVectorToList lst 8 FALSE)))

  (define-cise-stmt bv-check-index
    ((_ name bv index)
     `(unless (and (> (SG_BVECTOR_SIZE ,bv) ,index) (>= ,index 0))
	(assertion-violation ',name "index out of range"
			     (SG_LIST2 ,bv (SG_MAKE_INT ,index)))))
    ((_ name bv index offset)
     `(let ((len::long (SG_BVECTOR_SIZE ,bv)))
	(unless (and (> len ,offset)
		     (< ,index (- len ,offset)))
	  (assertion-violation ',name "index out of range"
			       (SG_LIST2 ,bv (SG_MAKE_INT ,index)))))))

  (define-cise-stmt bv-check-literal
    ((_ name bv)
     `(when (SG_LITERAL_BVECTORP ,bv)
	(assertion-violation ',name "attempt to modify literal bytevector"
			     ,bv))))

  (define-c-proc bytevector-u8-ref (bv::<bytevector> index::<fixnum>)
    ::<fixnum> :constant
    (setter bytevector-u8-set!)
    (bv-check-index bytevector-u8-ref bv index)
    (result (SG_BVECTOR_ELEMENT bv index)))

  (define-c-proc bytevector-u8-set! 
    (bv::<bytevector> index::<fixnum> value::<fixnum>) ::<void>
    (bv-check-literal bytevector-u8-set! bv)
    (bv-check-index bytevector-u8-set! bv index)
    (unless (SG_IS_OCTET value)
      (assertion-violation 'bytevector-u8-set!
			   "value out of range. must be 0 <= value <= 255"
			   (SG_MAKE_INT value)))
    (set! (SG_BVECTOR_ELEMENT bv index) (cast uint8_t value)))

  (define-c-proc bytevector-s8-ref (bv::<bytevector> index::<fixnum>)
    ::<fixnum> :constant
    (setter bytevector-s8-set!)
    (bv-check-index bytevector-s8-ref bv index)
    (result (cast int8_t (SG_BVECTOR_ELEMENT bv index))))

  (define-c-proc bytevector-s8-set!
    (bv::<bytevector> index::<fixnum> value::<fixnum>) ::<void>
    (bv-check-literal bytevector-s8-set! bv)
    (bv-check-index bytevector-s8-set! bv index)
    (unless (SG_IS_BYTE value)
      (assertion-violation 'bytevector-s8-set! 
			   "value out of range. must be -128 <= value <= 127"
			   (SG_MAKE_INT value)))
    (set! (SG_BVECTOR_ELEMENT bv index) (cast uint8_t value)))

  (define-cise-stmt bv-check-align
    ((_ name index align)
     `(unless (== (% ,index ,align) 0)
	(assertion-violation ',name "index not aligned" 
			     (SG_MAKE_INT ,index)))))

  (define-cise-stmt bv-check-value
    ((_ name value min max)
     (let ((v (gensym "cise__")))
       `(let ((,v :: long ,value))
	  (unless (and (<= ,min ,v)
		       (<= ,v ,max))
	    (assertion-violation ',name "value out of range" 
				 (SG_MAKE_INT ,v)))))))

  ;; 2.5 operations on 16-bit integers
  ;; u16
  (define-c-proc bytevector-u16-native-ref
    (bv::<bytevector> index::<fixnum>) ::<fixnum> :constant
    (setter bytevector-u16-native-set!)
    (bv-check-index bytevector-u16-native-ref bv index 1)
    (bv-check-align bytevector-u16-native-ref index 2)
    (result (Sg_ByteVectorU16NativeRef bv index)))

  (define-c-proc bytevector-u16-native-set!
    (bv::<bytevector> index::<fixnum> value::<fixnum>) ::<void>
    (bv-check-literal bytevector-u16-native-set! bv)
    (bv-check-index bytevector-u16-native-set! bv index 1)
    (bv-check-value bytevector-u16-native-set! value 0 #xFFFF)
    (Sg_ByteVectorU16NativeSet bv index value))

  (define-c-proc bytevector-u16-ref
    (bv::<bytevector> index::<fixnum> endian::<symbol>) ::<fixnum> :constant
    ;;(setter bytevector-u16-set!)
    (bv-check-index bytevector-u16-ref bv index 1)
    (cond ((SG_EQ endian 'big)
	   (result (Sg_ByteVectorU16BigRef bv index)))
	  ((SG_EQ endian 'little)
	   (result (Sg_ByteVectorU16LittleRef bv index)))
	  (else
	   (assertion-violation 'bytevector-u16-ref "unsupported endianness"
				endian))))

  (define-c-proc bytevector-u16-set!
    (bv::<bytevector> index::<fixnum> value::<fixnum> endian::<symbol>) ::<void>
    (bv-check-literal bytevector-u16-set! bv)
    (bv-check-index bytevector-u16-set! bv index 1)
    (bv-check-value bytevector-u16-set! value 0 #xFFFF)
    (cond ((SG_EQ endian 'big)
	   (Sg_ByteVectorU16BigSet bv index value))
	  ((SG_EQ endian 'little)
	   (Sg_ByteVectorU16LittleSet bv index value))
	  (else
	   (assertion-violation 'bytevector-u16-set!
				"unsupported endianness" endian))))

  ;; s16
  (define-c-proc bytevector-s16-native-ref
    (bv::<bytevector> index::<fixnum>) ::<fixnum> :constant
    (setter bytevector-s16-native-set!)
    (bv-check-index bytevector-s16-native-ref bv index 1)
    (bv-check-align bytevector-s16-native-ref index 2)
    (result (Sg_ByteVectorS16NativeRef bv index)))

  (define-c-proc bytevector-s16-native-set!
    (bv::<bytevector> index::<fixnum> value::<fixnum>) ::<void>
    (bv-check-literal bytevector-s16-native-set! bv)
    (bv-check-index bytevector-s16-native-set! bv index 1)
    (bv-check-value bytevector-s16-native-set! value #x-8000 #x7FFF)
    (Sg_ByteVectorS16NativeSet bv index value))

  (define-c-proc bytevector-s16-ref
    (bv::<bytevector> index::<fixnum> endian::<symbol>) ::<fixnum> :constant
    ;;(setter bytevector-s16-set!)
    (bv-check-index bytevector-s16-ref bv index 1)
    (cond ((SG_EQ endian 'big)
	   (result (Sg_ByteVectorS16BigRef bv index)))
	  ((SG_EQ endian 'little)
	   (result (Sg_ByteVectorS16LittleRef bv index)))
	  (else
	   (assertion-violation 'bytevector-s16-ref "unsupported endianness"
				endian))))

  (define-c-proc bytevector-s16-set!
    (bv::<bytevector> index::<fixnum> value::<fixnum> endian::<symbol>) ::<void>
    (bv-check-literal bytevector-s16-set! bv)
    (bv-check-index bytevector-s16-set! bv index 1)
    (bv-check-value bytevector-s16-set! value #x-8000 #x7FFF)
    (cond ((SG_EQ endian 'big)
	   (Sg_ByteVectorS16BigSet bv index value))
	  ((SG_EQ endian 'little)
	   (Sg_ByteVectorS16LittleSet bv index value))
	  (else
	   (assertion-violation 'bytevector-s16-set! "unsupported endianness"
				endian))))
  ;; 2.6 operations on 32-bit integers
  ;; u32
  (define-c-proc bytevector-u32-native-ref (bv::<bytevector> index::<fixnum>)
    :constant
    (setter bytevector-u32-native-set!)
    (bv-check-index bytevector-u32-native-ref bv index 3)
    (bv-check-align bytevector-u32-native-ref index 4)
    (result (Sg_MakeIntegerFromU32 (Sg_ByteVectorU32NativeRef bv index))))

  (define-c-proc bytevector-u32-native-set!
    (bv::<bytevector> index::<fixnum> v::<number>) ::<void>
    (bv-check-literal bytevector-u32-native-set! bv)
    (bv-check-index bytevector-u32-native-set! bv index 3)
    (let ((value::uint32_t 0))
      (cond ((SG_INTP v)
	     (bv-check-value bytevector-u32-native-set! (SG_INT_VALUE v)
			     0 UINT32_MAX)
	     (set! value (cast uint32_t (SG_INT_VALUE v))))
	    ((SG_BIGNUMP v)
	     (set! value (Sg_BignumToU32 v SG_CLAMP_NONE NULL)))
	    (else
	     (wrong-type-of-argument-violation 'bytevector-u32-native-set!
					       "exact integer" v)))
      (Sg_ByteVectorU32NativeSet bv index value)))

  (define-c-proc bytevector-u32-ref 
    (bv::<bytevector> index::<fixnum> endian::<symbol>) :constant
    ;;(setter bytevector-u32-set!)
    (bv-check-index bytevector-u32-ref bv index 3)
    (cond ((SG_EQ endian 'big)
	   (result (Sg_MakeIntegerFromU32 (Sg_ByteVectorU32BigRef bv index))))
	  ((SG_EQ endian 'little)
	   (result (Sg_MakeIntegerFromU32 
		    (Sg_ByteVectorU32LittleRef bv index))))
	  (else
	   (assertion-violation 'bytevector-u32-ref
				"unsupported endianness" endian))))

  (define-c-proc bytevector-u32-set! 
    (bv::<bytevector> index::<fixnum> v::<number> endian::<symbol>) ::<void>
    (bv-check-literal bytevector-u32-set! bv)
    (bv-check-index bytevector-u32-set! bv index 3)
    (let ((value::uint32_t 0))
      (cond ((SG_INTP v)
	     ;; for 64 bit environment fixnum can be more than 32 bits
	     (bv-check-value bytevector-u32-set! (SG_INT_VALUE v)
			     0 UINT32_MAX)
	     (set! value (cast uint32_t (SG_INT_VALUE v))))
	    ((SG_BIGNUMP v)
	     (set! value (Sg_BignumToU32 v SG_CLAMP_NONE NULL)))
	    (else
	     (wrong-type-of-argument-violation 'bytevector-u32-set!
					       "exact integer" v)))
      (cond ((SG_EQ endian 'big)
	     (Sg_ByteVectorU32BigSet bv index value))
	    ((SG_EQ endian 'little)
	     (Sg_ByteVectorU32LittleSet bv index value))
	    (else
	     (assertion-violation 'bytevector-u32-set!
				  "unsupported endianness" endian)))))
  ;; s32
  (define-c-proc bytevector-s32-native-ref (bv::<bytevector> index::<fixnum>)
    :constant
    (setter bytevector-s32-native-set!)
    (bv-check-index bytevector-s32-native-ref bv index 3)
    (bv-check-align bytevector-s32-native-ref index 4)
    (result (Sg_MakeIntegerFromS32 (Sg_ByteVectorS32NativeRef bv index))))

  (define-c-proc bytevector-s32-native-set!
    (bv::<bytevector> index::<fixnum> v::<number>) ::<void>
    (bv-check-literal bytevector-s32-native-set! bv)
    (bv-check-index bytevector-s32-native-set! bv index 3)
    (let ((value::int32_t 0))
      (cond ((SG_INTP v)
	     (bv-check-value bytevector-s32-native-set! (SG_INT_VALUE v)
			     INT32_MIN INT32_MAX)
	     (set! value (cast int32_t (SG_INT_VALUE v))))
	    ((SG_BIGNUMP v)
	     (set! value (Sg_BignumToS32 v SG_CLAMP_NONE NULL)))
	    (else
	     (wrong-type-of-argument-violation 'bytevector-s32-native-set!
					       "exact integer" v)))
      (Sg_ByteVectorS32NativeSet bv index value)))

  (define-c-proc bytevector-s32-ref
    (bv::<bytevector> index::<fixnum> endian::<symbol>) :constant
    ;;(setter bytevector-s32-set!)
    (bv-check-index bytevector-s32-ref bv index 3)
    (cond ((SG_EQ endian 'big)
	   (result (Sg_MakeIntegerFromS32 (Sg_ByteVectorS32BigRef bv index))))
	  ((SG_EQ endian 'little)
	   (result (Sg_MakeIntegerFromS32
		    (Sg_ByteVectorS32LittleRef bv index))))
	  (else
	   (assertion-violation 'bytevector-s32-ref 
				"unsupported endianness" endian))))

  (define-c-proc bytevector-s32-set!
    (bv::<bytevector> index::<fixnum> v::<number> endian::<symbol>) ::<void>
    (bv-check-literal bytevector-s32-set! bv)
    (bv-check-index bytevector-s32-set! bv index 3)
    (let ((value::int32_t 0))
      (cond ((SG_INTP v)
	     (bv-check-value bytevector-s32-set! (SG_INT_VALUE v)
			     INT32_MIN INT32_MAX)
	     (set! value (cast int32_t (SG_INT_VALUE v))))
	    ((SG_BIGNUMP v)
	     (set! value (Sg_BignumToS32 v SG_CLAMP_NONE NULL)))
	    (else
	     (wrong-type-of-argument-violation 'bytevector-s32-set!
					       "exact integer" v)))
      (cond ((SG_EQ endian 'big)
	     (Sg_ByteVectorS32BigSet bv index value))
	    ((SG_EQ endian 'little)
	     (Sg_ByteVectorS32LittleSet bv index value))
	    (else
	     (assertion-violation 'bytevector-s32-set!
				  "unsupported endianness" endian)))))
  ;; 2.7 operations on 64-bit integers
  ;; u64
  (define-c-proc bytevector-u64-native-ref (bv::<bytevector> index::<fixnum>)
    :constant
    (setter bytevector-u64-native-set!)
    (bv-check-index bytevector-u64-native-ref bv index 7)
    (bv-check-align bytevector-u64-native-ref index 8)
    (result (Sg_MakeIntegerFromU64 (Sg_ByteVectorU64NativeRef bv index))))

  (define-c-proc bytevector-u64-native-set!
    (bv::<bytevector> index::<fixnum> v::<number>) ::<void>
    (bv-check-literal bytevector-u64-native-set! bv)
    (bv-check-index bytevector-u64-native-set! bv index 7)
    (let ((value::uint64_t 0))
      (cond ((SG_INTP v)
	     ;; we don't have to check the limit value
	     ;; unless we would get 128 bit environment...
	     (when (< (SG_INT_VALUE v) 0)
	       (assertion-violation 'bytevector-u64-native-set!
				    "value out of range" v))
	     (set! value (cast uint64_t (SG_INT_VALUE v))))
	    ((SG_BIGNUMP v)
	     (set! value (Sg_BignumToU64 v SG_CLAMP_NONE NULL)))
	    (else
	     (wrong-type-of-argument-violation 'bytevector-u64-native-set! 
					       "exact integer" v)))
      (Sg_ByteVectorU64NativeSet bv index value)))

  (define-c-proc bytevector-u64-ref
    (bv::<bytevector> index::<fixnum> endian::<symbol>) :constant
    ;;(setter bytevector-u64-set!)
    (bv-check-index bytevector-u64-ref bv index 7)
    (cond ((SG_EQ endian 'big)
	   (result (Sg_MakeIntegerFromU64
		    (Sg_ByteVectorU64BigRef bv index))))
	  ((SG_EQ endian 'little)
	   (result (Sg_MakeIntegerFromU64
		    (Sg_ByteVectorU64LittleRef bv index))))
	  (else
	   (assertion-violation 'bytevector-u64-ref
				"unsupported endianness" endian))))

  (define-c-proc bytevector-u64-set!
    (bv::<bytevector> index::<fixnum> v::<number> endian::<symbol>) ::<void>
    (bv-check-literal bytevector-u64-set! bv)
    (bv-check-index bytevector-u64-set! bv index 7)
    (let ((value::uint64_t 0))
      (cond ((SG_INTP v)
	     (when (< (SG_INT_VALUE v) 0)
	       (assertion-violation 'bytevector-u64-set!
				    "value out of range" v))
	     (set! value (cast uint64_t (SG_INT_VALUE v))))
	    ((SG_BIGNUMP v)
	     (set! value (Sg_BignumToU64 v SG_CLAMP_NONE NULL)))
	    (else
	     (wrong-type-of-argument-violation 'bytevector-u64-set!
					       "exact integer" v)))
      (cond ((SG_EQ endian 'big)
	     (Sg_ByteVectorU64BigSet bv index value))
	    ((SG_EQ endian 'little)
	     (Sg_ByteVectorU64LittleSet bv index value))
	    (else
	     (assertion-violation 'bytevector-u64-set!
				  "unsupported endianness" endian)))))
  ;; s64
  (define-c-proc bytevector-s64-native-ref (bv::<bytevector> index::<fixnum>)
    :constant
    (setter bytevector-s64-native-set!)
    (bv-check-index bytevector-s64-native-ref bv index 7)
    (bv-check-align bytevector-s64-native-ref index 8)
    (result (Sg_MakeIntegerFromS64 (Sg_ByteVectorS64NativeRef bv index))))

  (define-c-proc bytevector-s64-native-set!
    (bv::<bytevector> index::<fixnum> v::<number>) ::<void>
    (bv-check-literal bytevector-s64-native-set! bv)
    (bv-check-index bytevector-s64-native-set! bv index 7)
    (let ((value::int64_t 0))
      (cond ((SG_INTP v)
	     (when (or (< (SG_INT_VALUE v) SG_INT_MIN)
		       (> (SG_INT_VALUE v) SG_INT_MAX))
	       (assertion-violation 'bytevector-s64-native-set!
				    "value out of range" v))
	     (set! value (cast int64_t (SG_INT_VALUE v))))
	    ((SG_BIGNUMP v)
	     (set! value (Sg_BignumToS64 v SG_CLAMP_NONE NULL)))
	    (else
	     (wrong-type-of-argument-violation 'bytevector-s64-native-set!
					       "exact integer" v)))
      (Sg_ByteVectorS64NativeSet bv index value)))

  (define-c-proc bytevector-s64-ref 
    (bv::<bytevector> index::<fixnum> endian::<symbol>) :constant
    ;;(setter bytevector-s64-set!)
    (bv-check-index bytevector-s64-ref bv index 7)
    (cond ((SG_EQ endian 'big)
	   (result (Sg_MakeIntegerFromS64 (Sg_ByteVectorS64BigRef bv index))))
	  ((SG_EQ endian 'little)
	   (result (Sg_MakeIntegerFromS64
		    (Sg_ByteVectorS64LittleRef bv index))))
	  (else
	   (assertion-violation 'bytevector-s64-ref
				"unsupported endianness" endian))))

  (define-c-proc bytevector-s64-set!
    (bv::<bytevector> index::<fixnum> v::<number> endian::<symbol>) ::<void>
    (bv-check-literal bytevector-s64-set! bv)
    (bv-check-index bytevector-s64-set! bv index 7)
    (let ((value::int64_t 0))
      (cond ((SG_INTP v)
	     (when (or (< (SG_INT_VALUE v) SG_INT_MIN)
		       (> (SG_INT_VALUE v) SG_INT_MAX))
	       (assertion-violation 'bytevector-s64-set!
				    "value out of range" v))
	     (set! value (cast int64_t (SG_INT_VALUE v))))
	    ((SG_BIGNUMP v)
	     (set! value (Sg_BignumToS64 v SG_CLAMP_NONE NULL)))
	    (else
	     (wrong-type-of-argument-violation 'bytevector-s64-set!
					       "exact integer" v)))
      (cond ((SG_EQ endian 'big)
	     (Sg_ByteVectorS64BigSet bv index value))
	    ((SG_EQ endian 'little)
	     (Sg_ByteVectorS64LittleSet bv index value))
	    (else
	     (assertion-violation 'bytevector-s64-set! 
				  "unsupported endianness" endian)))))
  ;; 2.8 operations on ieee-754 representations
  ;; ieee-single
  (define-c-proc bytevector-ieee-single-native-ref
    (bv::<bytevector> index::<fixnum>) :constant
    (setter bytevector-ieee-single-native-set!)
    (bv-check-index bytevector-ieee-single-native-ref bv index 3)
    (bv-check-align bytevector-ieee-single-native-ref index 4)
    (result (Sg_MakeFlonum (Sg_ByteVectorIEEESingleNativeRef bv index))))

  (define-c-proc bytevector-ieee-single-ref
    (bv::<bytevector> index::<fixnum> endian::<symbol>) :constant
    ;;(setter bytevector-ieee-single-set!)
    (bv-check-index bytevector-ieee-single-ref bv index 3)
    (cond ((SG_EQ endian 'big)
	   (result (Sg_MakeFlonum (Sg_ByteVectorIEEESingleBigRef bv index))))
	  ((SG_EQ endian 'little)
	   (result (Sg_MakeFlonum (Sg_ByteVectorIEEESingleLittleRef bv index))))
	  (else
	   (assertion-violation 'bytevector-ieee-single-ref
				"unsupported endianness" endian))))
  
  (define-c-proc bytevector-ieee-single-native-set!
    (bv::<bytevector> index::<fixnum> v::<number>) ::<void>
    (bv-check-literal bytevector-ieee-single-native-set! bv)
    (bv-check-index bytevector-ieee-single-native-set! bv index 3)
    (bv-check-align bytevector-ieee-single-native-set! index 4)
    (check-real bytevector-ieee-single-native-set! v)
    (let ((value::double (Sg_GetDouble v)))
      (Sg_ByteVectorIEEESingleNativeSet bv index (cast float value))))

  (define-c-proc bytevector-ieee-single-set!
    (bv::<bytevector> index::<fixnum> v::<number> endian::<symbol>) ::<void>
    (bv-check-literal bytevector-ieee-single-set! bv)
    (bv-check-index bytevector-ieee-single-set! bv index 3)
    (check-real bytevector-ieee-single-set! v)
    (let ((value::double (Sg_GetDouble v)))
      (cond ((SG_EQ endian 'big)
	     (Sg_ByteVectorIEEESingleBigSet bv index (cast float value)))
	    ((SG_EQ endian 'little)
	     (Sg_ByteVectorIEEESingleLittleSet bv index (cast float value)))
	    (else
	     (assertion-violation 'bytevector-ieee-single-set!
				  "unsupported endianness" endian)))))
  ;; ieee-double
  (define-c-proc bytevector-ieee-double-native-ref
    (bv::<bytevector> index::<fixnum>) :constant
    (setter bytevector-ieee-double-native-set!)
    (bv-check-index bytevector-ieee-double-native-ref bv index 7)
    (bv-check-align bytevector-ieee-double-native-ref index 8)
    (result (Sg_MakeFlonum (Sg_ByteVectorIEEEDoubleNativeRef bv index))))

  (define-c-proc bytevector-ieee-double-ref 
    (bv::<bytevector> index::<fixnum> endian::<symbol>) :constant
    ;;(setter bytevector-ieee-double-set!)
    (bv-check-index bytevector-ieee-double-ref bv index 7)
    (cond ((SG_EQ endian 'big)
	   (result (Sg_MakeFlonum (Sg_ByteVectorIEEEDoubleBigRef bv index))))
	  ((SG_EQ endian 'little)
	   (result (Sg_MakeFlonum (Sg_ByteVectorIEEEDoubleLittleRef bv index))))
	  (else
	   (assertion-violation 'bytevector-ieee-double-ref
				"unsupported endianness" endian))))
  
  (define-c-proc bytevector-ieee-double-native-set!
    (bv::<bytevector> index::<fixnum> v::<number>) ::<void>
    (bv-check-literal bytevector-ieee-double-native-set! bv)
    (bv-check-index bytevector-ieee-double-native-set! bv index 7)
    (bv-check-align bytevector-ieee-double-native-set! index 8)
    (check-real bytevector-ieee-double-native-set! v)
    (let ((value::double (Sg_GetDouble v)))
      (Sg_ByteVectorIEEEDoubleNativeSet bv index value)))

  (define-c-proc bytevector-ieee-double-set!
    (bv::<bytevector> index::<fixnum> v::<number> endian::<symbol>) ::<void>
    (bv-check-literal bytevector-ieee-double-set! bv)
    (bv-check-index bytevector-ieee-double-set! bv index 7)
    (check-real bytevector-ieee-double-set! v)
    (let ((value::double (Sg_GetDouble v)))
      (cond ((SG_EQ endian 'big)
	     (Sg_ByteVectorIEEEDoubleBigSet bv index value))
	    ((SG_EQ endian 'little)
	     (Sg_ByteVectorIEEEDoubleLittleSet bv index value))
	    (else
	     (assertion-violation 'bytevector-ieee-double-set!
				  "unsupported endianness" endian)))))
  ;; 2.9 operations on strings
  ;; converter
  ;; utf8 <-> string
  (define-cise-expr utf8-tail?
    ((_ b)
     `(and (<= #x80 ,b) (<= ,b #xbf))))
  (define-cfn check-utf8-3bytes (bv i::long)
    ::int :static
    (let ((first::int (SG_BVECTOR_ELEMENT bv i))
	  (second::int (SG_BVECTOR_ELEMENT bv (+ i 1)))
	  (third::int (SG_BVECTOR_ELEMENT bv (+ i 2))))
      (cond ((not (utf8-tail? third)) (return FALSE))
	    ((not (or (and (== #xe0 first) (<= #xa0 second) (<= second #xbf))
		      (and (== #xed first) (<= #x80 second) (<= second #x9f))
		      (and (<= #xe1 first) (<= first #xec) (utf8-tail? second))
		      (and (or (== #xee first) (== #xef first))
			   (utf8-tail? second))))
	     (return FALSE))
	    (else (return TRUE)))))
  (define-cfn check-utf8-4bytes (bv i::long)
    ::int :static
    (let ((first::int (SG_BVECTOR_ELEMENT bv i))
	  (second::int (SG_BVECTOR_ELEMENT bv (+ i 1)))
	  (third::int (SG_BVECTOR_ELEMENT bv (+ i 2)))
	  (forth::int (SG_BVECTOR_ELEMENT bv (+ i 3))))
      (cond ((or (not (utf8-tail? third)) (not (utf8-tail? forth)))
	     (return FALSE))
	    ((not (or (and (== #xf0 first) (<= #x90 second) (<= second #xbf))
		      (and (== #xf4 first) (<= #x80 second) (<= second #x8f))
		      (and (<= #xf1 first) (<= first #xf3)
			   (utf8-tail? second))))
	     (return FALSE))
	    (else (return TRUE)))))
  (define-c-proc utf8->string (bv::<bytevector> :optional (start::<fixnum> 0)
						(end::<fixnum> -1))
    :no-side-effect
    (let ((s)
	  (count::long 0)
	  (size::long (SG_BVECTOR_SIZE bv))
	  (i::long start))
      (SG_CHECK_START_END start end size)
      (while (< i end)
	(post++ count)
	(let ((f::uint8_t (SG_BVECTOR_ELEMENT bv i)))
	  (+= i (?: (< f #x80) 1
		    (?: (and (<= #xc2 f) (<= f #xdf)
			     (utf8-tail? (SG_BVECTOR_ELEMENT bv (+ i 1)))) 2
			(?: (and (<= #xe0 f) (<= f #xef)
				 (check-utf8-3bytes bv i)) 3
			    ;; the last one is error replacing so 1
			    (?: (and (<= #xf0 f) (<= f #xf4)
				     (check-utf8-4bytes bv i)) 4 1)))))))
      (set! s (Sg_ReserveString count 0))
      (Sg_ConvertUtf8BufferToUcs4 (Sg_MakeUtf8Codec)
				  (+ (SG_BVECTOR_ELEMENTS bv) start) size
				  (SG_STRING_VALUE s) count NULL
				  SG_REPLACE_ERROR FALSE)
      (result s)))

  (define-c-proc string->utf8 (s::<string> :optional (start::<fixnum> 0)
					   (end::<fixnum> -1))
    :no-side-effect
    (let ((bv)
	  (count::long 0)
	  (size::long (SG_STRING_SIZE s)))
      (SG_CHECK_START_END start end size)
      (dotimes (i (- end start) long)
	(let ((ucs4::SgChar (SG_STRING_VALUE_AT s (+ i start))))
	  (+= count (?: (< ucs4 #x80) 1
			(?: (< ucs4 #x800) 2
			    (?: (< ucs4 #x10000) 3
				;; the last one is error replacing so 2
				(?: (< ucs4 #x200000) 4 2)))))))
      (set! bv (Sg_MakeByteVector count 0))
      (set! count 0)
      (dotimes (i (- end start) long)
	(+= count (Sg_ConvertUcs4ToUtf8 
		   (SG_STRING_VALUE_AT s (+ i start)) 
		   (+ (SG_BVECTOR_ELEMENTS bv) count)
		   SG_REPLACE_ERROR)))
      (result bv)))

  ;; utf16 <-> string
  (define-c-proc utf16->string (bv::<bytevector> endian::<symbol>
						 :optional mandatory)
    :no-side-effect
    (let ((endianness::SgEndianness NO_BOM)
	  (skipBOM::int FALSE))
      (when (SG_UNBOUNDP mandatory)
	(set! endianness (Sg_Utf16CheckBOM bv))
	(when (not (== endianness NO_BOM)) (set! skipBOM TRUE)))
      (when (or (and (not (SG_UNBOUNDP mandatory))
		     (not (SG_FALSEP mandatory)))
		(== endianness  NO_BOM))
	(cond ((SG_EQ endian 'little)
	       (set! endianness UTF_16LE))
	      ((SG_EQ endian 'big)
	       (set! endianness UTF_16BE))
	      (else
	       (assertion-violation 
		'utf16->string "endianness should be little or big" endian))))
      (let ((skipSize::int 0)
	    (codec SG_UNDEF)
	    (trans::SgTranscoder))
	(when skipBOM (set! skipSize 2))
	(set! codec (Sg_MakeUtf16Codec endianness))
	(Sg_InitTranscoder (& trans) codec E_NONE SG_REPLACE_ERROR)
	;; TODO guard
	(result (Sg_ByteVectorToString bv (& trans) skipSize -1)))))

  (define-c-proc string->utf16 (s::<string> :optional endian::<symbol>)
    :no-side-effect
    (let ((endianness::SgEndianness UTF_16BE)
	  (trans::SgTranscoder))
      (if (not (SG_UNBOUNDP endian))
	  (cond ((SG_EQ endian 'little)
		 (set! endianness UTF_16LE))
		((SG_EQ endian 'big)
		 (set! endianness UTF_16BE))
		(else
		 (assertion-violation
		  'string->utf16 "endianness should be little or big" endian))))
      (Sg_InitTranscoder (& trans) (Sg_MakeUtf16Codec endianness)
			 E_NONE SG_REPLACE_ERROR)
      (result (Sg_StringToByteVector s (& trans) 0 -1))))


  (define-c-proc string->utf32 (s::<string> :optional endian::<symbol>)
    :no-side-effect
    (let ((endianness::SgEndianness UTF_32BE)
	  (trans::SgTranscoder))
      (if (not (SG_UNBOUNDP endian))
	  (cond ((SG_EQ endian 'little)
		 (set! endianness UTF_32LE))
		((SG_EQ endian 'big)
		 (set! endianness UTF_32BE))
		(else
		 (assertion-violation
		  'string->utf32 "endianness should be little or big" endian))))
      (Sg_InitTranscoder (& trans) (Sg_MakeUtf32Codec endianness)
			 E_NONE SG_REPLACE_ERROR)
      (result (Sg_StringToByteVector s (& trans) 0 -1))))

  (define-c-proc utf32->string (bv::<bytevector> endian::<symbol> 
						 :optional mandatory)
    :no-side-effect
    (let ((endianness::SgEndianness NO_BOM)
	  (skipBOM::int FALSE))
      (when (SG_UNBOUNDP mandatory)
	(set! endianness (Sg_Utf32CheckBOM bv))
	(if (not (== endianness NO_BOM))
	    (set! skipBOM TRUE)))
      (when (or (and (not (SG_UNBOUNDP mandatory))
		     (not (SG_FALSEP mandatory)))
		(== endianness NO_BOM))
	(cond ((SG_EQ endian 'little)
	       (set! endianness UTF_32LE))
	      ((SG_EQ endian 'big)
	       (set! endianness UTF_32BE))
	      (else
	       (assertion-violation
		'utf32->string "endianness should be little or big" endian))))
      (let ((skipSize::int 0)
	    (codec SG_UNDEF)
	    (trans::SgTranscoder))
	(if skipBOM
	    (set! skipSize 4))
	(set! codec (Sg_MakeUtf32Codec endianness))
	(Sg_InitTranscoder (& trans) codec E_NONE SG_REPLACE_ERROR)
	;; TODO guard
	(result (Sg_ByteVectorToString bv (& trans) skipSize -1)))))
  
  ;; 3 List utilities
  (define-c-proc memq (arg0 arg1) :constant Sg_Memq)
  (define-c-proc memv (arg0 arg1) :constant Sg_Memv)
  (define-c-proc assq (obj alist) :constant Sg_Assq)
  (define-c-proc assv (obj alist) :constant Sg_Assv)

  (define-c-proc cons* (:rest rest) :no-side-effect
    (let ((h '()) (t '()))
      (when (SG_PAIRP rest)
	(dopairs (cp rest)
	  (unless (SG_PAIRP (SG_CDR cp))
	    (if (SG_NULLP h)
		(set! h (SG_CAR cp))
		(SG_SET_CDR t (SG_CAR cp)))
	    (break))
	  (SG_APPEND1 h t (SG_CAR cp))))
      (result h)))

  ;; 7 Exceptions and conditions
  ;; 7.1 exceptions
;; these are moved to Scheme
;;  (define-c-proc with-exception-handler (handler thunk) 
;;    Sg_VMWithExceptionHandler)
;;
;;  (define-c-proc raise (c) 
;;    (result (Sg_Raise c FALSE)))
;;
;;  (define-c-proc raise-continuable (c) 
;;    (result (Sg_Raise c TRUE)))

  ;; 8 I/O
  ;; 8.2 port i/o
  ;; 8.2.3 buffer modes
  (define-c-proc buffer-mode? (o) ::<boolean> :constant
    (result (or (SG_EQ o 'none)
		(SG_EQ o 'line)
		(SG_EQ o 'block))))
  
  ;; 8.2.4 transcoders
  (define-c-proc latin-1-codec () :no-side-effect Sg_MakeLatin1Codec)
  (define-c-proc utf-8-codec () :no-side-effect Sg_MakeUtf8Codec)
  (define-c-proc utf-16-codec () :no-side-effect
    (result (Sg_MakeUtf16Codec UTF_16CHECK_BOM)))

  (define-c-proc native-eol-style () :no-side-effect
    (let ((style::SgEolStyle (Sg_NativeEol)))
      (cond ((== style LF)
	     (result 'lf))
	    ((== style CR)
	     (result 'cr))
	    ((== style LS)
	     (result 'ls))
	    ((== style NEL)
	     (result 'nel))
	    ((== style CRNEL)
	     (result 'crnel))
	    ((== style CRLF)
	     (result 'crlf))
	    ((== style E_NONE)
	     (result 'none))
	    (else
	     ;; all plat form should return eol style by Sg_NativeEol.
	     ;; so this never happen. just dummy
	     (assertion-violation 'native-eol-style
				  "platform native eol style not found"
				  '())))))

  (define-c-proc make-transcoder (c::<codec> :optional eol mode::<symbol>)
    :no-side-effect
    (unless (or (SG_UNBOUNDP eol)
		(SG_SYMBOLP eol))
      (wrong-type-of-argument-violation 'make-transcoder
					"symbol" eol))
    (let ((style::SgEolStyle (Sg_NativeEol))
	  (handling::SgErrorHandlingMode SG_REPLACE_ERROR))
      (cond ((SG_UNBOUNDP eol)) ;; do nothing
	    ((SG_EQ eol 'lf)
	     (set! style LF))
	    ((SG_EQ eol 'cr)
	     (set! style CR))
	    ((SG_EQ eol 'ls)
	     (set! style LS))
	    ((SG_EQ eol 'nel)
	     (set! style NEL))
	    ((SG_EQ eol 'crnel)
	     (set! style CRNEL))
	    ((SG_EQ eol 'crlf)
	     (set! style CRLF))
	    ((SG_EQ eol 'none)
	     (set! style E_NONE))
	    (else
	     (assertion-violation 'make-transcoder
				  "invalid eol-style"
				  eol)))
      (cond ((or (SG_UNBOUNDP mode)
		 (SG_EQ mode 'replace))) ;; do nothing
	    ((SG_EQ mode 'raise)
	     (set! handling SG_RAISE_ERROR))
	    ((SG_EQ mode 'ignore)
	     (set! handling SG_IGNORE_ERROR))
	    (else
	     (assertion-violation 'make-transcoder
				  "invalid error-handling-mode"
				  mode)))
      (result (Sg_MakeTranscoder c style handling))))

  (define-c-proc native-transcoder () :no-side-effect Sg_MakeNativeTranscoder)

  (define-c-proc transcoder-codec (t::<transcoder>) :no-side-effect
    SG_TRANSCODER_CODEC)

  (define-c-proc transcoder-eol-style (t::<transcoder>) :no-side-effect
    (let ((style::SgEolStyle (SG_TRANSCODER_EOL_STYLE t)))
      (cond ((== style LF)
	     (result 'lf))
	    ((== style CR)
	     (result 'cr))
	    ((== style LS)
	     (result 'ls))
	    ((== style NEL)
	     (result 'nel))
	    ((== style CRNEL)
	     (result 'crnel))
	    ((== style CRLF)
	     (result 'crlf))
	    ((== style E_NONE)
	     (result 'none))
	    (else
	     ;; never happen
	     (assertion-violation 'transcoder-eol-style
				  "transcoder had unknown eol-style. this must be a bug, please report it"
				  '())))))

  (define-c-proc transcoder-error-handling-mode (t::<transcoder>) 
    :no-side-effect
    (let ((mode::SgErrorHandlingMode (SG_TRANSCODER_MODE t)))
      (cond ((SG_EQ mode SG_REPLACE_ERROR)
	     (result SG_SYMBOL_REPLACE))
	    ((SG_EQ mode SG_IGNORE_ERROR)
	     (result SG_SYMBOL_IGNORE))
	    ((SG_EQ mode SG_RAISE_ERROR)
	     (result SG_SYMBOL_RAISE))
	    (else
	     (assertion-violation 'transcoder-error-handling-mode
				  "transcoder had unknown error-handling-mode. this must be a bug, please report it"
				  '())))))

  (define-c-proc bytevector->string
    (b::<bytevector> t::<transcoder>
		     :optional (start::<fixnum> 0) (end::<fixnum> -1))
    :no-side-effect
    Sg_ByteVectorToString)

  (define-c-proc string->bytevector
    (s::<string> t::<transcoder>
		 :optional (start::<fixnum> 0) (end::<fixnum> -1))
    :no-side-effect
    Sg_StringToByteVector)

  ;; 8.2.5 end-of-file object
  (define-c-proc eof-object () :no-side-effect (result SG_EOF))
  (define-c-proc eof-object? (o) ::<boolean> :constant SG_EOFP)

  ;; 8.2.6 input port and output port
  ;; check utility for opened port
  (define-cise-stmt check-port-open
    ((_ name p)
     `(when (Sg_PortClosedP ,p)
	(wrong-type-of-argument-violation ',name "opened port" ,p))))

  (define-cise-stmt check-binary-port
    ((_ name p)
     `(unless (SG_BINARY_PORTP ,p)
	(wrong-type-of-argument-violation ',name "binary-port" ,p))))

  (define-c-proc port? (obj) ::<boolean> :constant SG_PORTP)

  (define-c-proc port-transcoder (p::<port>) :no-side-effect
    Sg_PortTranscoder)

  (define-c-proc textual-port? (p) ::<boolean> :constant SG_TEXTUAL_PORTP)

  (define-c-proc binary-port? (p) ::<boolean> :constant SG_BINARY_PORTP)

  (define-c-proc transcoded-port (p::<port> t::<transcoder>) 
    (check-binary-port transcoded-port p)
    (check-port-open transcoded-port p)
    (Sg_PseudoClosePort p)
    (result (Sg_MakeTranscodedPort p t)))

  (define-c-proc port-has-port-position? (p::<port>) ::<boolean> :no-side-effect
    Sg_HasPortPosition)

  (define-c-proc port-has-set-port-position!? (p::<port>) ::<boolean>
    :no-side-effect
    Sg_HasSetPortPosition)

  (define-c-proc port-position (p::<port>) :no-side-effect
    (check-port-open port-position p)
    (result (Sg_MakeIntegerFromS64 (Sg_PortPosition p))))

  (define-c-proc set-port-position! 
    (p::<port> off::<number> :optional (whence::<symbol> 'begin))
    ::<void>
    (check-port-open set-port-position! p)
    (let ((w::SgWhence SG_BEGIN))
      (cond ((SG_EQ whence 'begin)
	     (when (Sg_NegativeP off)
	       (wrong-type-of-argument-violation 'set-port-position!
						 "non negative number"
						 off
						 (SG_LIST3 p off whence)))
	     (set! w SG_BEGIN))
	    ((SG_EQ whence 'current) (set! w SG_CURRENT))
	    ((SG_EQ whence 'end)     (set! w SG_END))
	    (else (assertion-violation 'set-port-position!
				       "unknown whence" whence)))
      (Sg_SetPortPosition p (Sg_GetIntegerS64Clamp off SG_CLAMP_NONE NULL) w)))

  (define-c-proc close-port (p::<port>) ::<void>
    (Sg_ClosePort p))

  ;; 8.2.7 input port
  (define-cise-stmt check-input-port
    ((_ name p)
     `(unless (SG_INPUT_PORTP ,p)
	(wrong-type-of-argument-violation ',name "input port" ,p))))

  (define-c-proc input-port? (obj) ::<boolean> :constant SG_INPUT_PORTP)

  (define-c-proc port-eof? (p::<port>) ::<boolean> :no-side-effect
    (if (SG_BINARY_PORTP p)
	(let ((ch::int (Sg_Peekb p)))
	     (result (== ch EOF)))
	(let ((ch::SgChar (Sg_Peekc p)))
	     (result (== ch EOF)))))

  (define-c-proc open-file-input-port (file::<string> 
				       :optional (option #f)
				                 mode::<symbol>
				                 (transcoder::<transcoder> #f))
    ;; we can ignore option
    (when (SG_UNBOUNDP mode)
      (set! mode 'block))
    (let ((fo (Sg_OpenFile file SG_READ))
	  (bufferMode::int SG_BUFFER_MODE_BLOCK))
      (unless (SG_FILEP fo)
	(Sg_IOError SG_IO_FILE_NOT_EXIST_ERROR
		    'open-file-input-port fo file SG_UNDEF))
      ;; we only support 'block or none for now.
      (if (SG_EQ mode 'none)
	  (set! bufferMode SG_BUFFER_MODE_NONE))
      (if (SG_FALSEP transcoder)
	  (result (Sg_MakeFileBinaryInputPort fo bufferMode))
	  (let ((in (Sg_MakeFileBinaryInputPort fo bufferMode)))
	    (result (Sg_MakeTranscodedPort in transcoder))))))

  (define-c-proc open-bytevector-input-port
    (bv::<bytevector> :optional (t::<transcoder> #f) 
		      (start::<fixnum> 0) (end::<fixnum> -1))
    (let ((bp (Sg_MakeByteVectorInputPort bv start end)))
      (if (SG_FALSEP t)
	  (result bp)
	  (result (Sg_MakeTranscodedPort bp t)))))

  (define-c-proc open-string-input-port 
    (s::<string> :optional (start::<fixnum> 0) (end::<fixnum> -1))
    (result (Sg_MakeStringInputPort s start end)))

  (define-c-proc standard-input-port () Sg_StandardInputPort)

  (define-c-proc current-input-port (:optional p::<port>)
    (let ((vm::SgVM* (Sg_VM)))
      (if (SG_UNBOUNDP p)
	  (result (-> vm currentInputPort))
	  (begin
	    (check-input-port current-input-port p)
	    (set! (-> vm currentInputPort) p)
	    (result SG_UNDEF)))))
  
  (define-cise-stmt check-procedure-or-false
    ((_ name proc)
     `(unless (or (SG_FALSEP ,proc)
		  (SG_PROCEDUREP ,proc))
	(wrong-type-of-argument-violation ',name
					  "procedure or #f"
					  ,proc))))

  (define-c-proc make-custom-binary-input-port
    (id::<string> read::<procedure> getter setter close
		  :optional (ready #f))
    (check-procedure-or-false make-custom-binary-input-port getter)
    (check-procedure-or-false make-custom-binary-input-port setter)
    (check-procedure-or-false make-custom-binary-input-port close)
    (check-procedure-or-false make-custom-binary-input-port ready)
    (result (Sg_MakeCustomBinaryPort id SG_INPUT_PORT read SG_FALSE
				     getter setter close ready)))

  (define-c-proc make-custom-textual-input-port
    (id::<string> read::<procedure> getter setter close
		  :optional (ready #f))
    (check-procedure-or-false make-custom-textual-input-port getter)
    (check-procedure-or-false make-custom-textual-input-port setter)
    (check-procedure-or-false make-custom-textual-input-port close)
    (check-procedure-or-false make-custom-textual-input-port ready)
    (result (Sg_MakeCustomTextualPort id SG_INPUT_PORT read SG_FALSE
				      getter setter close ready)))

  ;; 8.2.8 binary input
  (decl-code (.include <string.h>))

  ;; we don't know what would happen in custom port
  ;; so if it's custom port we lock it.
  (define-cise-stmt binary-port-read-u8-op
    ((_ p safe)
     (let ((unsafe (string->symbol (format "~aUnsafe" safe))))
       `(let ((b::int))
	  (if (SG_CUSTOM_PORTP ,p)
	      (set! b (,safe ,p))
	      (set! b (,unsafe ,p)))
	  (if (== EOF b)
	      (result SG_EOF)
	      (result (SG_MAKE_INT b)))))))
  (define-cise-stmt binary-port-write-u8-op
    ((_ p b safe)
     (let ((unsafe (string->symbol (format "~aUnsafe" safe))))
       `(if (SG_CUSTOM_PORTP ,p)
	    (,safe ,p ,b)
	    (,unsafe ,p ,b)))))

  (define-c-proc get-u8 (p::<port> :optional (reckless #f))
    (check-port-open get-u8 p)
    (when (SG_FALSEP reckless) (check-binary-port get-u8 p))
    (check-input-port get-u8 p)
    (binary-port-read-u8-op p Sg_Getb))
  
  (define-c-proc lookahead-u8 (p::<port> :optional (reckless #f))
    (check-port-open lookahead-u8 p)
    (when (SG_FALSEP reckless) (check-binary-port lookahead-u8 p))
    (check-input-port lookahead-u8 p)
    (binary-port-read-u8-op p Sg_Peekb))

  (define-cise-stmt check-fixnum-range
    ((_ name t start end start-op end-op)
     `(unless (and (,start-op ,start ,t)
		   (,end-op ,t ,end))
	(assertion-violation ',name "out of range" (SG_MAKE_INT ,t))))
    ((_ name t range op)
     `(unless (,op ,t ,range)
	(assertion-violation ',name "out of range" (SG_MAKE_INT ,t)))))

  (define-cise-stmt read-to-buffer
    ((_ port result buf start count read)
     (let ((i (gensym))
	   (r (gensym))
	   (c (gensym))
	   (t (gensym)))
     `(let ((,(string->symbol (format "~a::int64_t" i)) ,start)
	    (,(string->symbol (format "~a::int64_t" r)) 0)
	    (,(string->symbol (format "~a::int64_t" c)) ,count)
	    (,(string->symbol (format "~a::int" t)) (Sg_ReadOncePortP ,port)))
	(for (() (not (== ,c 0)) ())
	  (set! ,r (,read ,port (+ ,buf ,i) ,c))
	  (set! ,result (+ ,r ,result))
	  ;; (when (< ,r ,c) (break))
	  (when (== ,r 0) (break))
	  (when ,t (break))
	  (set! ,c (- ,c ,r))
	  (set! ,i (+ ,i ,r)))))))

  (define-c-proc get-bytevector-n
    (p::<port> count::<fixnum> :optional (reckless #f))
    (check-port-open get-bytevector-n p)
    (when (SG_FALSEP reckless) (check-binary-port get-bytevector-n p))
    (check-input-port get-bytevector-n p)
    (check-non-negative-fixnum get-bytevector-n count)
    (if (== count 0)
	(result (Sg_MakeByteVector 0 0))
	(let ((buf (Sg_MakeByteVector count 0))
	      (res::int64_t 0))
	  ;; (Sg_Readb p (SG_BVECTOR_ELEMENTS buf) count)
	  (SG_PORT_LOCK_READ p)
	  (read-to-buffer p res (SG_BVECTOR_ELEMENTS buf) 
			  0 count Sg_ReadbUnsafe)
	  (SG_PORT_UNLOCK_READ p)
	  (cond ((== res 0) (result SG_EOF))
		(else
		 (unless (== count res)
		   (set! (SG_BVECTOR_SIZE buf) res))
		 (result buf))))))

  (define-c-proc get-bytevector-n!
    (p::<port> bv::<bytevector> start::<fixnum> count::<fixnum>
	       :optional (reckless #f))
    (check-port-open get-bytevector-n! p)
    (when (SG_FALSEP reckless) (check-binary-port get-bytevector-n p))
    (check-input-port get-bytevector-n! p)
    (check-non-negative-fixnum get-bytevector-n! start)
    (check-non-negative-fixnum get-bytevector-n! count)
    (check-fixnum-range get-bytevector-n! (SG_BVECTOR_SIZE bv)(+ start count)>=)
    (if (== count 0)
	(result (SG_MAKE_INT 0))
	(let ((res::int64_t 0))
	  ;; (Sg_Readb p (+ (SG_BVECTOR_ELEMENTS bv) start) count)
	  (SG_PORT_LOCK_READ p)
	  (read-to-buffer p res (SG_BVECTOR_ELEMENTS bv) 
			  start count Sg_ReadbUnsafe)
	  (SG_PORT_UNLOCK_READ p)
	  (if (== res 0)
	      (result SG_EOF)
	      (result (SG_MAKE_INT res))))))

  ;; TODO this allocates memory twice.
  (define-c-proc get-bytevector-some (p::<port> :optional (reckless #f))
    (check-port-open get-bytevector-some p)
    (when (SG_FALSEP reckless)
      (check-binary-port get-bytevector-n p))
    (check-input-port get-bytevector-some p)
    (let ((buf (Sg_MakeByteVector 512 0)) ;; some
	  (res::int64_t 0))
      ;; (Sg_Readb p (SG_BVECTOR_ELEMENTS buf) 512)
      (SG_PORT_LOCK_READ p)
      (read-to-buffer p res (SG_BVECTOR_ELEMENTS buf) 0 512 Sg_ReadbUnsafe)
      (SG_PORT_UNLOCK_READ p)
      (cond ((== res 0)
	     (result SG_EOF))
	    (else
	     (unless (== res 512)
	       (set! (SG_BVECTOR_SIZE buf) res))
	     (result buf)))))

  (define-c-proc get-bytevector-all (p::<port> :optional (reckless #f))
    (check-port-open get-bytevector-all p)
    (when (SG_FALSEP reckless)
      (check-binary-port get-bytevector-n p))
    (check-input-port get-bytevector-all p)
    ;; TODO we need to get the rest size to reduce memory allocation.
    ;; but for now I implement like this
    (let ((buf::uint8_t* NULL)
	  (res::int64_t (Sg_ReadbAll p (& buf))))
      (if (== res 0)
	  (result SG_EOF)
	  (let ((r (Sg_MakeByteVectorFromU8Array buf res)))
	    (set! buf NULL)		; gc friendliness 
	    (result r)))))

  ;; 8.2.9 textual port
  (define-cise-stmt check-textual-port
    ((_ name p)
     `(unless (SG_TEXTUAL_PORTP ,p)
	(wrong-type-of-argument-violation ',name
					  "textual-port"
					  ,p))))

  (define-cise-expr string-port?
    ((_ p)
     `(SG_STRING_PORTP ,p)))
  ;; If it's transcoded port there is always a chance to read more then
  ;; one byte and if that happens in multi thread script it would not
  ;; read a char properly. in case of the we need lock
  ;; custom port is the same reason as binary port.
  ;; so only string port which is buffering and it always put one char
  ;; in one operation.
  (define-cise-stmt string-port-read-char-op
    ((_ p safe)
     (let ((unsafe (string->symbol (format "~aUnsafe" safe))))
       `(let ((c::SgChar))
	  (if (string-port? ,p)
	      (set! c (,unsafe ,p))
	      (set! c (,safe ,p)))
	  (if (== c EOF)
	      (result SG_EOF)
	      (result (SG_MAKE_CHAR c)))))))
  (define-cise-stmt string-port-write-char-op
    ((_ p c safe)
     (let ((unsafe (string->symbol (format "~aUnsafe" safe))))
       `(if (string-port? ,p)
	      (,unsafe ,p ,c)
	      (,safe ,p ,c)))))

  (define-c-proc get-char (p::<port>) 
    (check-port-open get-char p)
    (check-textual-port get-char p)
    (check-input-port get-char p)
    (string-port-read-char-op p Sg_Getc))

  (define-c-proc lookahead-char (p::<port>) 
    (check-port-open lookahead-char p)
    (check-textual-port lookahead-char p)
    (check-input-port lookahead-char p)
    (string-port-read-char-op p Sg_Peekc))

  (define-c-proc get-string-n (p::<port> count::<fixnum>)
    (check-port-open get-string-n p)
    (check-textual-port get-string-n p)
    (check-input-port get-string-n p)
    (check-non-negative-fixnum get-string-n count)
    (if (== count 0)
	(result (Sg_MakeEmptyString))
	(let ((ch::SgChar (Sg_Peekc p)))
	  (if (== ch EOF)
	      (result SG_EOF)
	      (let* ((buf::SgString* (Sg_ReserveString count 0))
		     (len::int64_t 0))
		;; (Sg_Reads p (SG_STRING_VALUE buf) count)
		(SG_PORT_LOCK_READ p)
		(read-to-buffer p len (SG_STRING_VALUE buf) 0 count
				Sg_ReadsUnsafe)
		(SG_PORT_UNLOCK_READ p)
		(if (== len count)
		    (result buf)
		    (result (Sg_Substring buf 0 len))))))))

  (define-c-proc get-string-n!
    (p::<port> s::<string> start::<fixnum> count::<fixnum>)

    (check-port-open get-string-n! p)
    (check-textual-port get-string-n! p)
    (check-input-port get-string-n! p)
    (check-non-negative-fixnum get-string-n! start)
    (check-non-negative-fixnum get-string-n! count)
    (check-fixnum-range get-string-n! (SG_STRING_SIZE s) (+ start count) >=)
    ;; string must not be literal
    (when (SG_IMMUTABLE_STRINGP s)
      (assertion-violation 'get-string-n!
			   "attempt to modify an immutable string" s))
    (if (== count 0)
	(result (SG_MAKE_INT 0))
	(let ((ch::SgChar (Sg_Peekc p)))
	  (if (== ch EOF)
	      (result SG_EOF)
	      (let ((len::int64_t 0))
		;; (Sg_Reads p (+ (SG_STRING_VALUE s) start) count)
		(SG_PORT_LOCK_READ p)
		(read-to-buffer p len (SG_STRING_VALUE s) start count
				Sg_ReadsUnsafe)
		(SG_PORT_UNLOCK_READ p)
		(result (SG_MAKE_INT len)))))))

  (define-c-proc get-string-all (p::<port>) 
    (check-port-open get-string-all p)
    (check-textual-port get-string-all p)
    (check-input-port get-string-all p)
    (let ((ch::SgChar (Sg_Peekc p)))
      (cond ((== ch EOF)
	     (result SG_EOF))
	    (else
	     (SG_PORT_LOCK_READ p)
	     ;; TODO how much should we allocate as default size?
	     (let ((buf (Sg_ReserveString 1024 0))
		   (out SG_FALSE)
		   (firstP::int TRUE)) ;; to avoid unnecessary allocation
	       (loop
		(let ((len::int64_t 
		       (Sg_ReadsUnsafe p (SG_STRING_VALUE buf) 1024)))
		  ;; ok if len is less, then read everything
		  (cond ((== len 0)
			 (when firstP 
			   (SG_PORT_UNLOCK_READ p)
			   (return SG_EOF))
			 (break))
			((< len 1024)
			 (when firstP 
			   (SG_PORT_UNLOCK_READ p)
			   (return (Sg_Substring buf 0 len)))
			 (Sg_Writes out (SG_STRING_VALUE buf) len)
			 (break))
			(else
			 (if firstP (set! out (Sg_MakeStringOutputPort -1)))
			 (Sg_PutsUnsafe out buf)))
		  (set! firstP FALSE)))
	       (SG_PORT_UNLOCK_READ p)
	       (result (Sg_GetStringFromStringPort out)))))))

  (define-c-proc get-line (p::<port>) 
    (check-port-open get-line p)
    (check-textual-port get-line p)
    (check-input-port get-line p)
    (result (Sg_ReadLine p LF)))

  (define-c-proc get-datum (p::<port>) 
    (check-port-open get-dutum p)
    (check-textual-port get-datum p)
    (check-input-port get-dutum p)
    ;; TODO should get-datum read shared-object too?
    (let ((ctx::SgReadContext SG_STATIC_READ_CONTEXT))
      (result (Sg_ReadWithContext p (& ctx)))))

  ;; 8.2.10 output port
  (define-cise-stmt check-output-port
    ((_ name p)
     `(unless (SG_OUTPUT_PORTP ,p)
	(wrong-type-of-argument-violation ',name "output port" ,p))))

  (define-c-proc output-port? (obj) ::<boolean> :constant SG_OUTPUT_PORTP)

  (define-c-proc flush-output-port 
    (:optional (p::<port> (Sg_CurrentOutputPort))) ::<void>
    Sg_FlushPort)

  (define-c-proc output-port-buffer-mode (p::<port>)
    (if (SG_BUFFERED_PORTP p)
	(cond ((SG_EQ (-> (SG_BUFFERED_PORT p) mode) SG_BUFFER_MODE_NONE)
	       (result 'none))
	      ((SG_EQ (-> (SG_BUFFERED_PORT p) mode) SG_BUFFER_MODE_LINE)
	       (result 'line))
	      ((SG_EQ (-> (SG_BUFFERED_PORT p) mode) SG_BUFFER_MODE_BLOCK)
	       (result 'block))
	      (else
	       (assertion-violation 'output-port-buffer-mode
				    "port has invalid buffer mode. may be bug?"
				    p)))
	(result 'none)))

  (define-cfn get-open-flags 
    (option oflags::int file exists?::int rappend::int*)
    ::int :static
    (let ((opt (Sg_SlotRefUsingClass (Sg_ClassOf option) option 'members)))
      (if (and exists? (SG_NULLP opt))
	  (throw-i/o-error SG_IO_FILE_ALREADY_EXIST_ERROR
			   'open-file-output-port
			   "file already exists" file 0)
	  (let ((no-create?::int (not (SG_FALSEP (Sg_Memq 'no-create opt))))
		(no-truncate?::int (not (SG_FALSEP (Sg_Memq 'no-truncate opt))))
		(no-fail?::int (not (SG_FALSEP (Sg_Memq 'no-fail opt))))
		(append?::int (not (SG_FALSEP (Sg_Memq 'append opt))))
		(open-flags::int oflags))
	    (cond ((and no-create? no-truncate?)
		   (when (not exists?)
		     (throw-i/o-error SG_IO_FILE_NOT_EXIST_ERROR
				      'open-file-output-port
				      "file-options no-create: file not exist" 
				      file 0)))
		  (no-create?
		   (if exists?
		       (set! open-flags (logior SG_TRUNCATE open-flags))
		       (throw-i/o-error SG_IO_FILE_NOT_EXIST_ERROR
					'open-file-output-port 
					"file-options no-create: file not exist"
					file 0)))
		  ((and no-fail? no-truncate?)
		   (when (not exists?)
		     (set! open-flags (logior SG_TRUNCATE open-flags))))
		  (no-fail?
		   ;; no-truncate
		   (set! open-flags (logior SG_TRUNCATE open-flags)))
		  (no-truncate?
		   (cond ((and exists? (not append?))
			  (throw-i/o-error SG_IO_FILE_ALREADY_EXIST_ERROR
			    'open-file-output-port 
			    "file-options no-truncate: file already exist"
			    file 0))
			 ((not append?)
			  (set! open-flags (logior SG_TRUNCATE open-flags))))))
	    (when append? (set! (pointer rappend) append?))
	    (return open-flags)))
      ;; dummy
      (return 0)))

  (define-c-proc open-file-output-port (file::<string> 
					:optional (option #f)
					          mode::<symbol>
						  (transcoder::<transcoder> #f))
    (when (SG_UNBOUNDP mode) (set! mode 'block))
    (let ((fo SG_UNDEF)
	  (isFileExist::int (Sg_FileExistP file))
	  (openFlags::int (logior SG_WRITE SG_CREATE))
	  (bufferMode::int SG_BUFFER_MODE_BLOCK))
      (cond ((SG_EQ mode 'none)
	     (set! bufferMode SG_BUFFER_MODE_NONE))
	    ((SG_EQ mode 'line)
	     (set! bufferMode SG_BUFFER_MODE_LINE)))
      (cond ((SG_FALSEP option)
	     (if isFileExist
		 (throw-i/o-error SG_IO_FILE_ALREADY_EXIST_ERROR
				  'open-file-output-port "file already exists"
				  file))
	     (set! fo (Sg_OpenFile file openFlags))
	     (unless (SG_FILEP fo)
	       (Sg_IOError SG_IO_FILE_NOT_EXIST_ERROR
			   'open-file-output-port
			   fo file SG_UNDEF))
	     (result (Sg_MakeFileBinaryOutputPort fo bufferMode)))
	    (else
	     ;; this is basically depending on the non-compiled Scheme code
	     ;; not so good...
	     (unless (Sg_RecordP option)
	       (assertion-violation 'open-file-output-port 
				    "invalid file options" option))
	     (let ((append?::int 0))
	       (set! openFlags (get-open-flags option openFlags 
					       file isFileExist (& append?)))
	       (set! fo (Sg_OpenFile file openFlags))
	       (unless (SG_FILEP fo)
		 (Sg_IOError SG_IO_FILE_NOT_EXIST_ERROR
			     'open-file-output-port fo file SG_UNDEF))
	       (when append? (Sg_FileSeek fo 0 SG_END))
	       (if (SG_FALSEP transcoder)
		   (result (Sg_MakeFileBinaryOutputPort fo bufferMode))
		   (let ((out (Sg_MakeFileBinaryOutputPort fo bufferMode)))
		     (result (Sg_MakeTranscodedPort out transcoder)))))))))

  (define-c-proc standard-output-port () Sg_StandardOutputPort)

  (define-c-proc standard-error-port () Sg_StandardErrorPort)

  (define-c-proc current-output-port (:optional p)
    (let ((vm::SgVM* (Sg_VM)))
      (if (SG_UNBOUNDP p)
	  (result (-> vm currentOutputPort))
	  (begin
	    (check-output-port current-output-port p)
	    (set! (-> vm currentOutputPort) p)
	    (result SG_UNDEF)))))

  (define-c-proc current-error-port (:optional p)
    (let ((vm::SgVM* (Sg_VM)))
      (if (SG_UNBOUNDP p)
	  (result (-> vm currentErrorPort))
	  (begin
	    (check-output-port current-error-port p)
	    (set! (-> vm currentErrorPort) p)
	    (result SG_UNDEF)))))

  (define-c-proc make-custom-binary-output-port
    (id::<string> write::<procedure> getter setter close)
    (check-procedure-or-false make-custom-binary-output-port getter)
    (check-procedure-or-false make-custom-binary-output-port setter)
    (check-procedure-or-false make-custom-binary-output-port close)
    (result (Sg_MakeCustomBinaryPort id SG_OUTPUT_PORT SG_FALSE write
				     getter setter close SG_FALSE)))

  (define-c-proc make-custom-textual-output-port
    (id::<string> write::<procedure> getter setter close)
    (check-procedure-or-false make-custom-textual-output-port getter)
    (check-procedure-or-false make-custom-textual-output-port setter)
    (check-procedure-or-false make-custom-textual-output-port close)
    (result (Sg_MakeCustomTextualPort id SG_OUTPUT_PORT SG_FALSE write
				      getter setter close SG_FALSE)))

  ;; 8.2.11 binary output
  (define-c-proc put-u8 (p::<port> octet::<fixnum> :optional (reckless #f))
    ::<void>
    (check-port-open put-u8 p)
    (when (SG_FALSEP reckless)
      (check-binary-port put-u8 p))
    (check-output-port put-u8 p)
    (check-fixnum-range put-u8 octet 0 255 <= <=)
    (binary-port-write-u8-op p octet Sg_Putb))

  (define-c-proc put-bytevector
    (p::<port> bv::<bytevector>
     :optional (start::<fixnum> 0)
               (count::<fixnum> (SG_MAKE_INT (- (SG_BVECTOR_SIZE bv) start)))
	       (reckless #f))
    ::<void>
    (check-port-open put-bytevector p)
    (when (SG_FALSEP reckless)
      (check-binary-port put-bytevector p))
    (check-output-port put-bytevector p)
    (check-non-negative-fixnum put-bytevector start)
    (check-non-negative-fixnum put-bytevector count)
    (unless (<= (+ count start) (SG_BVECTOR_SIZE bv))
      (assertion-violation 'put-bytevector
			   "invalid range"))
    (Sg_Writeb p (SG_BVECTOR_ELEMENTS bv) start count))

  ;; 8.2.13 textual output
  (define-c-proc put-char (p::<port> ch::<char>) ::<void>
    (check-port-open put-char p)
    (check-output-port put-char p)
    (check-textual-port put-char p)
    (string-port-write-char-op p ch Sg_Putc))

  (define-c-proc put-string
    (p::<port> s::<string>
     :optional (start::<fixnum> 0)
               (count::<fixnum> (SG_MAKE_INT (- (SG_STRING_SIZE s) start))))
    ::<void>
    (check-port-open put-string p)
    (check-output-port put-string p)
    (check-textual-port put-string p)
    (check-non-negative-fixnum put-string start)
    (check-non-negative-fixnum put-string count)
    (unless (<= (+ count start) (SG_STRING_SIZE s))
      (assertion-violation 'put-string "invalid range"))
    (Sg_Writes p (+ (SG_STRING_VALUE s) start) count))

  (define-c-proc put-datum (p::<port> datum) ::<void>
    (check-port-open put-datum p)
    (check-output-port put-datum p)
    (check-textual-port put-datum p)
    (Sg_Write datum p SG_WRITE_WRITE))

  ;; 8.2.13 input output ports
  (define-c-proc open-file-input/output-port
    (file::<string> :optional (option #f)
		              mode::<symbol>
			      (transcoder::<transcoder> #f))
    (when (SG_UNBOUNDP mode)
      (set! mode 'block))
    (let ((fo SG_UNDEF)
	  (isFileExist::int (Sg_FileExistP file))
	  (openFlags::int (logior SG_READ (logior SG_WRITE SG_CREATE)))
	  (bufferMode::int SG_BUFFER_MODE_BLOCK))
      (cond ((SG_EQ mode 'none)
	     (set! bufferMode SG_BUFFER_MODE_NONE))
	    ((SG_EQ mode 'line)
	     (set! bufferMode SG_BUFFER_MODE_LINE)))
      (cond ((SG_FALSEP option)
	     (if isFileExist
		 (throw-i/o-error SG_IO_FILE_ALREADY_EXIST_ERROR
				  'open-file-input/output-port
				  "file already exists" file))
	     (set! fo (Sg_OpenFile file openFlags))
	     (unless (SG_FILEP fo)
	       (Sg_IOError SG_IO_FILE_NOT_EXIST_ERROR
			   'open-file-input/output-port fo file SG_UNDEF))
	     (result (Sg_MakeFileBinaryInputOutputPort fo bufferMode)))
	    (else
	     (unless (Sg_RecordP option)
	       (assertion-violation 'open-file-output-port 
				    "invalid file options" option))
	     (let ((append?::int 0))
	       (set! openFlags (get-open-flags option openFlags 
					       file isFileExist (& append?)))
	       (set! fo (Sg_OpenFile file openFlags))
	       (unless (SG_FILEP fo)
		 (Sg_IOError SG_IO_FILE_NOT_EXIST_ERROR
			     'open-file-input/output-port fo file SG_UNDEF))
	       (when append? (Sg_FileSeek fo 0 SG_END))
	       (if (SG_FALSEP transcoder)
		   (result (Sg_MakeFileBinaryInputOutputPort fo bufferMode))
		   (let ((out (Sg_MakeFileBinaryInputOutputPort fo bufferMode)))
		     (result (Sg_MakeTranscodedPort out transcoder)))))))))

  (define-c-proc make-custom-binary-input/output-port
    (id::<string> read::<procedure> write::<procedure> getter setter close
		  :optional (ready #f))
    (check-procedure-or-false make-custom-binary-input/output-port getter)
    (check-procedure-or-false make-custom-binary-input/output-port setter)
    (check-procedure-or-false make-custom-binary-input/output-port close)
    (check-procedure-or-false make-custom-binary-input/output-port ready)
    (result (Sg_MakeCustomBinaryPort id SG_IN_OUT_PORT read write
				     getter setter close ready)))

  (define-c-proc make-custom-textual-input/output-port
    (id::<string> read::<procedure> write::<procedure> getter setter close
		  :optional (ready #f))
    (check-procedure-or-false make-custom-textual-input/output-port getter)
    (check-procedure-or-false make-custom-textual-input/output-port setter)
    (check-procedure-or-false make-custom-textual-input/output-port close)
    (check-procedure-or-false make-custom-textual-input/output-port ready)
    (result (Sg_MakeCustomTextualPort id SG_IN_OUT_PORT read write
				      getter setter close ready)))

  ;; 8.3 simple i/o
  (define-c-proc close-input-port (p::<port>) ::<void>
    (unless (SG_INPUT_PORTP p)
      (wrong-type-of-argument-violation 'close-input-port "input port" p))
    (Sg_ClosePort p))

  (define-c-proc close-output-port (p::<port>) ::<void>
    (unless (SG_OUTPUT_PORTP p)
      (wrong-type-of-argument-violation 'close-output-port "output port" p))
    (Sg_ClosePort p))

  (define-c-proc read-char (:optional (p::<port> (Sg_CurrentInputPort)))
    (check-port-open read-char p)
    (check-input-port read-char p)
    (check-textual-port read-char p)
    (string-port-read-char-op p Sg_Getc))

  (define-c-proc peek-char (:optional (p::<port> (Sg_CurrentInputPort)))
    (check-port-open peek-char p)
    (check-input-port peek-char p)
    (check-textual-port peek-char p)
    (string-port-read-char-op p Sg_Peekc))

  (define-c-proc read (:optional (p::<port> (Sg_CurrentInputPort))
		       :key (source-info?::<boolean> #f)
			    (read-shared?::<boolean> #f))
    (check-port-open read p)
    (check-input-port read p)
    (let ((ctx::SgReadContext SG_STATIC_READ_CONTEXT))
      (when source-info?
	(set! (ref ctx flags) SG_READ_SOURCE_INFO))
      (when read-shared?
	(set! (ref ctx graph) (Sg_MakeHashTableSimple SG_HASH_EQ 1)))
      (result (Sg_ReadWithContext p (& ctx)))))

  (define-c-proc write-char (ch::<char> :optional
					(p::<port> (Sg_CurrentOutputPort)))
    ::<void>
    (check-port-open write-char p)
    (check-output-port write-char p)
    (check-textual-port write-char p)
    (string-port-write-char-op p ch Sg_Putc))
  
  (define-c-proc newline (:optional (p::<port> (Sg_CurrentOutputPort))) ::<void>
    (check-port-open newline p)
    (check-output-port newline p)
    (check-textual-port newline p)
    (string-port-write-char-op p #\linefeed Sg_Putc))

  (define-c-proc display (o :optional (p::<port> (Sg_CurrentOutputPort))) ::<void>
    (check-port-open display p)
    (check-output-port display p)
    (Sg_Write o p SG_WRITE_DISPLAY))

  (define-c-proc write (o :optional (p::<port> (Sg_CurrentOutputPort))) ::<void>
    (check-port-open write p)
    (check-output-port write p)
    (Sg_Write o p SG_WRITE_WRITE))

  ;; 9 file system
  ;; the same string can return the different value...
  (define-c-proc file-exists? (filename::<string>) ::<boolean> :no-side-effect
    Sg_FileExistP)

  (define-c-proc delete-file (filename::<string>) ::<void>
    (let ((r::int (Sg_DeleteFile filename)))
      (unless (== r 0)
	(Sg_IOError SG_IO_FILENAME_ERROR 'delete-file
		    (Sg_GetLastErrorMessageWithErrorCode r)
		    filename SG_UNDEF))))

  (define-c-proc exit (:optional obj) ::<void>
    ;; TODO thread
    (if (SG_UNBOUNDP obj)
	(Sg_Exit EXIT_SUCCESS)
	(cond ((SG_INTP obj) (Sg_Exit (cast int (SG_INT_VALUE obj))))
	      ((SG_TRUEP obj) (Sg_Exit EXIT_SUCCESS))
	      (else (Sg_Exit EXIT_FAILURE)))))

  ;; 11 Arithmetic
  ;; 11.2 fixnum (moved to fixnums.stub)
  ;; 11.3 flonums (moved to flonums.stub)

  ;; 11.4 exact bitwise arithmetic
  (define-c-proc bitwise-not (ei::<number>)  :constant
    (unless (Sg_ExactP ei)
      (wrong-type-of-argument-violation 'bitwise-not "exact integer required" ei))
    (result (Sg_LogNot ei)))

  (define-cise-stmt logop
    ((_ fn x y rest)
     `(let ((r (,fn ,x ,y)))
	(for-each (lambda (v) (set! r (,fn r v))) ,rest)
	(result r))))

  (define-c-proc bitwise-and 
    (:optional ei::<integer> ei2::<integer> :rest rest) :constant
    (cond ((SG_UNBOUNDP ei) (result (SG_MAKE_INT -1)))
	  ((SG_NULLP rest) 
	   (if (SG_UNBOUNDP ei2)
	       (result ei)
	       (result (Sg_LogAnd ei ei2))))
	  (else
	   (set! ei (Sg_LogAnd ei ei2))
	   (logop Sg_LogAnd ei (SG_CAR rest) (SG_CDR rest)))))

  (define-c-proc bitwise-ior 
    (:optional ei::<integer> ei2::<integer> :rest rest) :constant
    (cond ((SG_UNBOUNDP ei) (result (SG_MAKE_INT 0)))
	  ((SG_NULLP rest) 
	   (if (SG_UNBOUNDP ei2)
	       (result ei)
	       (result (Sg_LogIor ei ei2))))
	  (else
	   (set! ei (Sg_LogIor ei ei2))
	   (logop Sg_LogIor ei (SG_CAR rest) (SG_CDR rest)))))

  (define-c-proc bitwise-xor 
    (:optional ei::<integer> ei2::<integer> :rest rest) :constant
    (cond ((SG_UNBOUNDP ei) (result (SG_MAKE_INT 0)))
	  ((SG_NULLP rest) 
	   (if (SG_UNBOUNDP ei2)
	       (result ei)
	       (result (Sg_LogXor ei ei2))))
	  (else
	   (set! ei (Sg_LogXor ei ei2))
	   (logop Sg_LogXor ei (SG_CAR rest) (SG_CDR rest)))))

  (define-cise-expr logif
    ((_ n1 n2 n3)
     `(Sg_LogIor (Sg_LogAnd ,n1 ,n2)
		 (Sg_LogAnd (Sg_LogNot ,n1) ,n3))))

  (define-c-proc bitwise-if (ei1::<number> ei2::<number> ei3::<number>)
    :constant
    (result (logif ei1 ei2 ei3)))

  (define-c-proc bitwise-bit-count (ei::<number>) ::<fixnum> :constant
    Sg_BitCount)

  (define-c-proc bitwise-length (ei::<number>) ::<fixnum> :constant
    Sg_BitSize)

  (define-c-proc bitwise-first-bit-set (ei::<number>) ::<fixnum> :constant
    Sg_FirstBitSet)

  (define-c-proc bitwise-bit-set? (ei1::<number> ei2::<fixnum>)
    ::<boolean> :constant
    Sg_BitSetP)

  (define-c-proc bitwise-copy-bit (ei1::<number> ei2::<fixnum> ei3::<number>) 
    :constant
    (let ((mask (Sg_Ash (SG_MAKE_INT 1) ei2)))
      (result (logif mask (Sg_Ash ei3 ei2) ei1))))

  (define-c-proc bitwise-bit-field (ei1::<number> ei2::<fixnum> ei3::<fixnum>)
    :constant
    (when (< ei2 0)
      (assertion-violation 'bitwise-bit-field 
       "2nd parameter (start) must be non-negative" (SG_MAKE_INT ei2)))
    (when (< ei3 0)
      (assertion-violation 'bitwise-bit-field 
       "3rd parameter (end) must be non-negative" (SG_MAKE_INT ei3)))
    (when (> ei2 ei3)
      (assertion-violation 'bitwise-bit-field 
       "2nd parameter must be less than or equal to 3rd parameter"
       (SG_LIST3 ei1 (SG_MAKE_INT ei2) (SG_MAKE_INT ei3))))
    (let ((mask (Sg_LogNot (Sg_Ash (SG_MAKE_INT -1) ei3))))
      (result (Sg_Ash (Sg_LogAnd ei1 mask) (- 0 ei2)))))

  (define-c-proc bitwise-copy-bit-field 
    (ei1::<number> ei2::<fixnum> ei3::<fixnum> ei4::<number>) :constant
    (let ((to ei1)
	  (start::long ei2)
	  (end::long ei3)
	  (from ei4)
	  (mask1 (Sg_Ash (SG_MAKE_INT -1) start))
	  (mask2 (Sg_LogNot (Sg_Ash (SG_MAKE_INT -1) end)))
	  (mask (Sg_LogAnd mask1 mask2)))
      (result (logif mask (Sg_Ash from start) to))))

  (define-c-proc bitwise-arithmetic-shift (ei1::<number> ei2::<fixnum>)
    :constant Sg_Ash)

  (define-c-proc bitwise-arithmetic-shift-left (ei1::<number> ei2::<fixnum>)
    :constant Sg_Ash)

  (define-c-proc bitwise-arithmetic-shift-right (ei1::<number> ei2::<fixnum>)
    :constant
    (result (Sg_Ash ei1 (- 0 ei2))))

  ;; 12 syntax-case
  ;; 12.5 identifier predicates
  (define-c-proc identifier? (id) ::<boolean> :constant SG_IDENTIFIERP)

  ;; free-identifier=? and bound-identifier=? are moved to Scheme
  
  ;; 13 Hashtables
  ;; 13.1 constructors
  (define-cfn retrieve-weakness (weakness) ::SgWeakness :static
    (cond ((SG_EQ weakness 'key)   (return SG_WEAK_KEY))
	  ((SG_EQ weakness 'value) (return SG_WEAK_VALUE))
	  ((SG_EQ weakness 'both)  (return SG_WEAK_BOTH))
	  ;; NB: we don't support ephemerals
	  (else (assertion-violation 'make-hashtable
		  "weakness must be one of 'key, 'value or 'both" weakness)
		;; dummy
		(return -1))))

  (define-c-proc make-eq-hashtable (:optional (k? #f) (weakness #f))
    :no-side-effect
    (let ((k::long -1))
      (cond ((SG_INTP k?) (set! k (SG_INT_VALUE k?)))
	    ((SG_FALSEP k?) (set! k 200))
	    (else 
	     (wrong-type-of-argument-violation 'make-eq-hashtable
					       "#f or fixnum" k?)))
      (when (< k 0) 
	(wrong-type-of-argument-violation 'make-eq-hashtable 
					  "non negative exact integer"
					  k?))
      (if (SG_FALSEP weakness)
	  (result (Sg_MakeHashTableSimple SG_HASH_EQ k))
	  (let ((w::SgWeakness (retrieve-weakness weakness)))
	    (result (Sg_MakeWeakHashTableSimple SG_HASH_EQ w k SG_UNDEF))))))

  (define-c-proc make-eqv-hashtable (:optional (k? #f) (weakness #f)) 
    :no-side-effect
    (let ((k::long -1))
      (cond ((SG_INTP k?) (set! k (SG_INT_VALUE k?)))
	    ((SG_FALSEP k?) (set! k 200))
	    (else 
	     (wrong-type-of-argument-violation 'make-eqv-hashtable
					       "#f or fixnum" k?)))
      (when (< k 0) 
	(wrong-type-of-argument-violation 'make-eqv-hashtable 
					  "non negative exact integer"
					  (SG_MAKE_INT k)))
      (if (SG_FALSEP weakness)
	  (result (Sg_MakeHashTableSimple SG_HASH_EQV k))
	  (let ((w::SgWeakness (retrieve-weakness weakness)))
	    (result (Sg_MakeWeakHashTableSimple SG_HASH_EQV w k SG_UNDEF))))))

  (define-c-proc make-hashtable
    (hasher::<procedure> equiv::<procedure> :optional (k? #f) (weakness #f))
    :no-side-effect
    (let ((k::long -1))
      (cond ((SG_INTP k?) (set! k (SG_INT_VALUE k?)))
	    ((SG_FALSEP k?) (set! k 200))
	    (else 
	     (wrong-type-of-argument-violation 'make-hashtable
					       "#f or fixnum" k?)))
      (when (< k 0) 
	(wrong-type-of-argument-violation 'make-hashtable 
					  "non negative exact integer"
					  (SG_MAKE_INT k)))
      (if (SG_FALSEP weakness)
	  (result (Sg_MakeHashTable hasher equiv k))
	  (let ((w::SgWeakness (retrieve-weakness weakness)))
	    (result (Sg_MakeWeakHashTable hasher equiv  w k SG_UNDEF))))))

  ;; 13.2 procedures
  (define-c-proc hashtable? (o) ::<boolean> :constant SG_HASHTABLE_P)

  (define-c-proc hashtable-size (ht::<hashtable>) ::<fixnum> Sg_HashTableSize)

  (define-c-proc hashtable-ref (ht::<hashtable> key :optional (fallback #f))
    :no-side-effect (setter hashtable-set!)
    (result (Sg_HashTableRef ht key fallback)))

  (define-cise-stmt check-mutable-hashtable
    ((_ name t)
     `(when (SG_IMMUTABLE_HASHTABLE_P ,t)
	(assertion-violation ',name
			     "attemp to modify an immutable hashtable" ,t))))

  (define-c-proc hashtable-set! (ht::<hashtable> key value) ::<void>
    (check-mutable-hashtable hashtable-set! ht)
    (Sg_HashTableSet ht key value 0))

  (define-c-proc hashtable-delete! (ht::<hashtable> key) ::<void>
    (check-mutable-hashtable hashtable-set! ht)
    (Sg_HashTableDelete ht key))

  (define-c-proc hashtable-contains? (ht::<hashtable> key) ::<boolean>
    :no-side-effect
    (result (!= (Sg_HashTableRef ht key NULL) NULL)))

  (define-c-proc hashtable-copy
    (ht::<hashtable> :optional (mutableP::<boolean> #f)) 
    (result (Sg_HashTableCopy ht mutableP)))

  (define-c-proc hashtable-clear!
    (ht::<hashtable> :optional (k::<fixnum> -1)) ::<void>
    (check-mutable-hashtable hashtable-clear! ht)
    (Sg_HashCoreClear (SG_HASHTABLE_CORE ht) k))

  (define-c-proc hashtable-keys (ht::<hashtable>) :no-side-effect
    (let ((itr::SgHashIter)
	  (r (Sg_MakeVector (-> (SG_HASHTABLE_CORE ht) entryCount) SG_UNDEF))
	  (v)
	  (i::int 0))
      (Sg_HashIterInit ht (& itr))
      (while (!= (Sg_HashIterNext (& itr) (& v) NULL) NULL)
	(set! (SG_VECTOR_ELEMENT r (post++ i)) v))
      (result r)))

  (define-c-proc hashtable-entries (ht::<hashtable>) :no-side-effect
    (let ((itr::SgHashIter)
	  (rk (Sg_MakeVector (-> (SG_HASHTABLE_CORE ht) entryCount) SG_UNDEF))
	  (rv (Sg_MakeVector (-> (SG_HASHTABLE_CORE ht) entryCount) SG_UNDEF))
	  (v)
	  (k)
	  (i::int 0))
      (Sg_HashIterInit ht (& itr))
      (while (!= (Sg_HashIterNext (& itr) (& k) (& v)) NULL)
	(set! (SG_VECTOR_ELEMENT rk i) k)
	(set! (SG_VECTOR_ELEMENT rv (post++ i)) v))
      (result (Sg_Values2 rk rv))))
  
  ;; 13.3 inspection
  (define-c-proc hashtable-mutable? (ht::<hashtable>) ::<boolean> :constant
    (result (not (SG_IMMUTABLE_HASHTABLE_P ht))))

  ;; 13.4
  ;; defined in compare.c
  ;; (define-c-proc equal-hash (o) ::<fixnum> :no-side-effect Sg_EqualHash)

  ;; for srfi-13 we need to take bound as an argument
  (define-c-proc string-hash
    (o::<string> :optional bound (start::<fixnum> 0) (end::<fixnum> -1))
    ::<fixnum> :no-side-effect
    (let ((modulo::long 0))
      (cond ((SG_UNBOUNDP bound) (set! modulo (cast uint32_t SG_INT_MAX)))
	    ((SG_INTP bound) (set! modulo (SG_INT_VALUE bound)))
	    ((SG_BIGNUMP bound)
	     (set! modulo (Sg_BignumToUI (SG_BIGNUM bound) SG_CLAMP_BOTH NULL))))
      (when (== modulo 0)
	(assertion-violation 'string-hash
			     "argument out of domain"
			     bound))
      (result (Sg_StringHash (Sg_MaybeSubstring o start end) modulo))))

  (define-c-proc string-ci-hash
    (o::<string> :optional bound (start::<fixnum> 0) (end::<fixnum> -1))
    ::<fixnum> :no-side-effect
    (let ((modulo::long 0))
      (cond ((SG_UNBOUNDP bound) (set! modulo (cast uint32_t SG_INT_MAX)))
	    ((SG_INTP bound) (set! modulo (SG_INT_VALUE bound)))
	    ((SG_BIGNUMP bound)
	     (set! modulo (Sg_BignumToUI (SG_BIGNUM bound) SG_CLAMP_BOTH NULL))))
      (when (== modulo 0)
	(assertion-violation 'string-hash
			     "argument out of domain"
			     bound))
      (result (Sg_StringHash (Sg_StringFoldCase (Sg_MaybeSubstring o start end))
			     modulo))))

  (define-c-proc symbol-hash (o::<symbol> :optional ignore) :no-side-effect
    (result (Sg_MakeIntegerU (Sg_EqHash o 0))))

  ;; 15 composit library
  ;; 16 eval
  (define-c-proc eval (sexp env) Sg_VMEval)

  (define-c-proc environment (:rest spec) 
    (result (Sg_VMEnvironment (Sg_MakeEvalLibrary) spec)))

  ;; 17 mutable pairs
  (define-c-proc set-car! (o::<pair> v) ::<void> (inline SET_CAR)
    (when (Sg_ConstantLiteralP o)
      (assertion-violation 'set-car "attempt to modify constant literal" o))
    (SG_SET_CAR o v))

  (define-c-proc set-cdr! (o::<pair> v) ::<void> (inline SET_CDR)
    (when (Sg_ConstantLiteralP o)
      (assertion-violation 'set-cdr "attempt to modify constant literal" o))
    (SG_SET_CDR o v))

  ;; 18 mutable strings
  (define-c-proc string-set! (s::<string> k::<fixnum> c::<char>) ::<void>
    Sg_StringSet)
  
  ;; we take start and end as optional arguments for srfi-13
  (define-c-proc string-fill! (s::<string> c::<char> :optional
					   (start::<fixnum> 0)
					   (end::<fixnum> -1)) ::<void>
    (when (SG_IMMUTABLE_STRINGP s)
      (assertion-violation 'string-set!
			   "attempted to modify an immutable string"
			   s))
    (Sg_StringFill s c start end))

  ;; record
  (define-c-proc %record? (o) ::<boolean> :constant Sg_RecordP)

  ;; conditions
  (define-c-proc condition (:rest components) Sg_Condition)
  (define-c-proc simple-conditions (obj) Sg_SimpleConditions)

  (define-c-proc compound-condition-component (obj) 
    Sg_CompoundConditionComponent)

  (define-c-proc compound-condition? (obj) ::<boolean> :constant
    Sg_CompoundConditionP)
  (define-c-proc simple-condition? (obj) ::<boolean> :constant
    Sg_SimpleConditionP)
  
  (define-c-proc condition? (obj) ::<boolean> :constant Sg_ConditionP)

  )