cairo-rectangle-list-t
  cairo-scaled-font-t
  cairo-font-face-t
  cairo-glyph-t
  cairo-text-cluster-t
  cairo-text-cluster-flags-t
  cairo-text-extents-t
  cairo-text-extents-t
  cairo-font-extents-t
  cairo-font-extents-t
  cairo-font-slant-t
  cairo-font-weight-t
  cairo-subpixel-order-t
  cairo-hint-style-t
  cairo-hint-metrics-t
  cairo-font-options-t
................................................................................
  with-cairo
  let-struct
  )
 (import (chezscheme) (ffi-utils))
 
 (include "cairo/ffi-utils.ss")

 (define (cairo-library-init . t) (load-shared-object (if (null? t) "libcairo.so" (car t))))

 (include "cairo/types.ss")

 (define cairo-guardian (make-guardian))
 (define (cairo-guard-pointer obj) 
   (cairo-free-garbage) 
   (cairo-guardian obj)
   obj)

 (define (cairo-free-garbage)
   (let loop ([p (cairo-guardian)])
     (when p
	   (when (ftype-pointer? p)
		 ;(printf "cairo-free-garbage: freeing memory at ~x\n" p)
		 ;;[(ftype-pointer? usb-device*-array p)
		 (cond 
		  [(ftype-pointer? cairo-t p) (cairo-destroy p)]
		  [(ftype-pointer? cairo-surface-t p) (cairo-surface-destroy p)]
		  [(ftype-pointer? cairo-pattern-t p) (cairo-pattern-destroy p)]
		  [(ftype-pointer? cairo-region-t p) (cairo-region-destroy p)]
		  [(ftype-pointer? cairo-rectangle-list-t p) (cairo-rectangle-list-destroy p)]
		  [(ftype-pointer? cairo-font-options-t p) (cairo-font-options-destroy p)]
		  [(ftype-pointer? cairo-font-face-t p) (cairo-font-face-destroy p)]
		  [(ftype-pointer? cairo-scaled-font-t p) (cairo-scaled-font-destroy p)]
		  [(ftype-pointer? cairo-path-t p) (cairo-path-destroy p)]
		  [(ftype-pointer? cairo-device-t p) (cairo-device-destroy p)]
		  [else
		   (foreign-free (ftype-pointer-address p))]
		  ))
	   (loop (cairo-guardian)))))		

  cairo-rectangle-list-t
  cairo-scaled-font-t
  cairo-font-face-t
  cairo-glyph-t
  cairo-text-cluster-t
  cairo-text-cluster-flags-t
  cairo-text-extents-t


  cairo-font-extents-t
  cairo-font-slant-t
  cairo-font-weight-t
  cairo-subpixel-order-t
  cairo-hint-style-t
  cairo-hint-metrics-t
  cairo-font-options-t
................................................................................
  with-cairo
  let-struct
  )
 (import (chezscheme) (ffi-utils))
 
 (include "cairo/ffi-utils.ss")

 (define (cairo-library-init . t) (load-shared-object (if (null? t) "libcairo.so.2.11502.0" (car t))))

 (include "cairo/types.ss")

 (define cairo-guardian (make-guardian))
 (define (cairo-guard-pointer obj) 
   (cairo-free-garbage) 
   (cairo-guardian obj)
   obj)

 (define (cairo-free-garbage)
   (let loop ([p (cairo-guardian)])
     (when p
	   (when (ftype-pointer? p)
		 (printf "cairo-free-garbage: freeing memory at ~x\n" p)
		 ;;[(ftype-pointer? usb-device*-array p)
		 (cond 
		  [(ftype-pointer? cairo-t p) (cairo-destroy p)]
		  [(ftype-pointer? cairo-surface-t p) (cairo-surface-destroy p)]
		  [(ftype-pointer? cairo-pattern-t p) (cairo-pattern-destroy p)]
		  [(ftype-pointer? cairo-region-t p) (cairo-region-destroy p)]
		  [(ftype-pointer? cairo-rectangle-list-t p) (cairo-rectangle-list-destroy p)]
		  [(ftype-pointer? cairo-font-options-t p) (cairo-font-options-destroy p)]
		  [(ftype-pointer? cairo-font-face-t p) (cairo-font-face-destroy p)]
		  ;[(ftype-pointer? cairo-scaled-font-t p) (cairo-scaled-font-destroy p)]
		  [(ftype-pointer? cairo-path-t p) (cairo-path-destroy p)]
		  [(ftype-pointer? cairo-device-t p) (cairo-device-destroy p)]
		  [else
		   (foreign-free (ftype-pointer-address p))]
		  ))
	   (loop (cairo-guardian)))))		

       (symbol->string (syntax->datum x)))

     (define (string->datum t x)
       (datum->syntax t (string->symbol x)))

     (syntax-case x ()
       [(_ ret-type name ((arg-name arg-type) ...) c-name) 

	(with-syntax ([(renamed-type ...) (map rename-scheme->c #'(arg-type ...))]
		      [renamed-ret (rename-scheme->c #'ret-type)]
		      [function-ftype (datum->syntax #'name (string->symbol (string-append (symbol->string (syntax->datum #'name)) "-ft")))]
		      [((arg-name arg-convert) ...) (map (lambda (n t) 

							   (list n (convert-scheme->c #'name n t))) 
							 #'(arg-name ...) #'(arg-type ...))])
		     (begin
		      ; (indirect-export cairo-guard-pointer)
		       #`(begin
			   (define (name arg-name ...) 
			     (define-ftype function-ftype (function (renamed-type ...) renamed-ret))
			     (let* ([function-fptr  (make-ftype-pointer function-ftype c-name)]
				    [function       (ftype-ref function-ftype () function-fptr)]
				    [arg-name arg-convert] ...)

			       (let ([result (function arg-name ...)])

				 #,(case (syntax->datum #'ret-type)
				     [(cairo-status-t)          #'(cairo-status-enum-ref result)]

				     [((* cairo-t) (* cairo-surface-t) (* cairo-pattern-t)


				       (* cairo-region-t) (* cairo-rectangle-list-t) (* cairo-font-options-t)


				       (* cairo-font-face-t) (* cairo-scaled-font-t) (* cairo-path-t)

				       (* cairo-device-t)) 
				      #'(cairo-guard-pointer result)]
				     [else #'result])))))))])))

 (define-syntax define-ftype-allocator 
   (lambda (x)
     (syntax-case x () 
       [(_ name type) 
	(begin 
	 ; (indirect-export cairo-guard-pointer)

       (symbol->string (syntax->datum x)))

     (define (string->datum t x)
       (datum->syntax t (string->symbol x)))

     (syntax-case x ()
       [(_ ret-type name ((arg-name arg-type) ...) c-name) 
	(with-syntax
	 ([(renamed-type ...) (map rename-scheme->c #'(arg-type ...))]
	  [renamed-ret (rename-scheme->c #'ret-type)]
	  [function-ftype (datum->syntax #'name (string->symbol (string-append (symbol->string (syntax->datum #'name)) "-ft")))]
	  [((arg-name arg-convert) ...)
	   (map (lambda (n t) 
		  (list n (convert-scheme->c #'name n t))) 
		#'(arg-name ...) #'(arg-type ...))])
	 (begin
					; (indirect-export cairo-guard-pointer)
	   #`(begin
	       (define (name arg-name ...) 
		 (define-ftype function-ftype (function (renamed-type ...) renamed-ret))
		 (let* ([function-fptr  (make-ftype-pointer function-ftype c-name)]
			[function       (ftype-ref function-ftype () function-fptr)]
			[arg-name arg-convert] ...)
		   (printf "calling ffi ~d ~n" c-name)
		   (let ([result (function arg-name ...)])
		     
		     #,(case (syntax->datum #'ret-type)
			 [(cairo-status-t)  #'(cairo-status-enum-ref result)]
			 [((* cairo-t)
			   (* cairo-surface-t)
			   (* cairo-pattern-t)
			   (* cairo-region-t)
			   (* cairo-rectangle-list-t)
			   (* cairo-font-options-t)
			   (* cairo-font-face-t)
			   (* cairo-scaled-font-t)
			   (* cairo-path-t)
			   (* cairo-device-t)) 
			  #'(cairo-guard-pointer result)]
			 [else #'result])))))))])))

 (define-syntax define-ftype-allocator 
   (lambda (x)
     (syntax-case x () 
       [(_ name type) 
	(begin 
	 ; (indirect-export cairo-guard-pointer)

#!r6rs

(library
 (ffi-utils)
 (export define-enumeration* define-function 
	 define-flags make-flags flags flags-name flags-alist flags-indexer flags-ref-maker flags-decode-maker
	 let-struct)


 (import (chezscheme))

;; TODO: maybe we should support multiple structs?
;; and maybe also normal let entries? let-struct* also?

 (define-syntax let-struct
   (lambda (x)
................................................................................
;> (flags-name color-flags) -> color

;; TODO, what to do for value 0?

 (define-record flags (name alist))
 
 (define (flags-indexer  flags)
   (lambda (name . more-names)
     (let ([names (append (list name) more-names)])
       (let loop ([f names] [result 0])
	 (if (null? f) result
	   (let ([r (assq (car f) (flags-alist flags))])
	     ;(printf "r: ~d flags: ~d f: ~d\n" r flags f)
	     (if (not r) (assertion-violation (flags-name flags) "symbol not found" f)
		 (loop (cdr f) (logor result (cdr r))))))))))

 (define (flags-ref-maker flags)
   (lambda (index)
     (let ([p (find (lambda (x) (equal? index (cdr x))) (flags-alist flags))])
       (if p (car p) p))))

;; FIXME: WHAT TO DO IF VALUES OVERLAP?
;; AT THE MOMENT RESULT MAYBE NOT WHAT EXPECTED
 (define (flags-decode-maker flags)
................................................................................
			 (define flags-name (make-flags 'name (list (cons 'k v) ...)))
			 (define base-name (flags-indexer flags-name))
			 (define ref-name (flags-ref-maker flags-name))
			 (define decode-name (flags-decode-maker flags-name))
			 (define-ftype name-t type)
			 ;(indirect-export base-name flags-name ref-name decode-name name-t )
			 ))])))




















 ); library ffi-utils

#!r6rs

(library
 (ffi-utils)
 (export define-enumeration* define-function 
	 define-flags make-flags flags flags-name flags-alist flags-indexer flags-ref-maker flags-decode-maker
	 let-struct
	 char*->bytevector cast
	 )
 (import (chezscheme))

;; TODO: maybe we should support multiple structs?
;; and maybe also normal let entries? let-struct* also?

 (define-syntax let-struct
   (lambda (x)
................................................................................
;> (flags-name color-flags) -> color

;; TODO, what to do for value 0?

 (define-record flags (name alist))
 
 (define (flags-indexer  flags)
  (lambda names

    (let loop ([f names] [result 0])
      (if (null? f) result
	  (let ([r (assq (car f) (flags-alist flags))])

	    (if (not r) (assertion-violation (flags-name flags) "symbol not found" f)
		(loop (cdr f) (logor result (cdr r)))))))))

(define (flags-ref-maker flags)
   (lambda (index)
     (let ([p (find (lambda (x) (equal? index (cdr x))) (flags-alist flags))])
       (if p (car p) p))))

;; FIXME: WHAT TO DO IF VALUES OVERLAP?
;; AT THE MOMENT RESULT MAYBE NOT WHAT EXPECTED
 (define (flags-decode-maker flags)
................................................................................
			 (define flags-name (make-flags 'name (list (cons 'k v) ...)))
			 (define base-name (flags-indexer flags-name))
			 (define ref-name (flags-ref-maker flags-name))
			 (define decode-name (flags-decode-maker flags-name))
			 (define-ftype name-t type)
			 ;(indirect-export base-name flags-name ref-name decode-name name-t )
			 ))])))



 (define (char*->bytevector fptr bytes)
   (define bb (make-bytevector bytes))
   (let f ([i 0])
     (if (< i  bytes)
	 (let ([c (ftype-ref char () fptr i)])
	   (bytevector-u8-set! bb i (char->integer c))
	   (f (fx+ i 1)))))
   bb)


 (define-syntax cast
   (syntax-rules ()
     [(_ ftype fptr)
      (make-ftype-pointer ftype
			  (ftype-pointer-address fptr))]))


 ); library ffi-utils

	 (import (chezscheme) 
		 (only (srfi s13 strings) string-count string-index
		       string-index-right 
		       string-concatenate string-concatenate-reverse  
		       substring/shared reverse-list->string string-tokenize
		       string-suffix? string-prefix?)
		 (srfi private let-opt)


		 (only (srfi s1 lists) fold length+))

	 (include "hash-compat.scm")
	 (include "mantissa.scm")
	 (include "read-line.scm")
	 (include "string-ports.scm")
	 (include "fmt.scm")

	 (include "fmt-column.scm")
	 (include "fmt-pretty.scm")
	 )

	 (import (chezscheme) 
		 (only (srfi s13 strings) string-count string-index
		       string-index-right 
		       string-concatenate string-concatenate-reverse  
		       substring/shared reverse-list->string string-tokenize
		       string-suffix? string-prefix?)
		 (srfi private let-opt)
		 (srfi private include)
		 (scheme)
		 (only (srfi s1 lists) fold length+))

	 (include/resolve ("fmt") "hash-compat.scm")
	 (include/resolve ("fmt") "mantissa.scm")
	 (include/resolve ("fmt") "read-line.scm")
	 (include/resolve ("fmt") "string-ports.scm")

	 (include/resolve ("fmt") "fmt.scm")
	 (include/resolve ("fmt") "fmt-column.scm")
	 (include/resolve ("fmt") "fmt-pretty.scm")
	 )

	 ;; clauses.  `g+s' is a list of two elements, the get! and set!
	 ;; expressions respectively.

	 (define-syntax match-next
	 (syntax-rules (=>)
	 ;; no more clauses, the match failed
	 ((match-next v g+s)
	 (error 'match "no matching pattern"))
	 ;; named failure continuation
	 ((match-next v g+s (pat (=> failure) . body) . rest)
	 (let ((failure (lambda () (match-next v g+s . rest))))
	 ;; match-one analyzes the pattern for us
	 (match-one v pat g+s (match-drop-ids (begin . body)) (failure) ())))
	 ;; anonymous failure continuation, give it a dummy name
	 ((match-next v g+s (pat . body) . rest)

	 ;; clauses.  `g+s' is a list of two elements, the get! and set!
	 ;; expressions respectively.

	 (define-syntax match-next
	 (syntax-rules (=>)
	 ;; no more clauses, the match failed
	 ((match-next v g+s)
	 (error 'match "no matching pattern" v))
	 ;; named failure continuation
	 ((match-next v g+s (pat (=> failure) . body) . rest)
	 (let ((failure (lambda () (match-next v g+s . rest))))
	 ;; match-one analyzes the pattern for us
	 (match-one v pat g+s (match-drop-ids (begin . body)) (failure) ())))
	 ;; anonymous failure continuation, give it a dummy name
	 ((match-next v g+s (pat . body) . rest)

 ;;     (let ([c (ftype-ref char () fptr i)])
 ;;       (if (or (char=? c #\nul) (and bytes (>= (+ 1 i) (car bytes))))
 ;; 	   (make-string i)
 ;; 	   (let ([str (f (fx+ i 1))])
 ;; 	     (string-set! str i c)
 ;; 	     str)))))

 (define (char*->bytevector fptr bytes)
   (let f ([i 0])
     (let ([c (ftype-ref char () fptr i)])
       (if (>= i  bytes)
	   (make-bytevector i)
	   (let ([bb (f (fx+ i 1))])
	     (bytevector-u8-set! bb i (char->integer c))
	     bb)))))

 (define-syntax cast
   (syntax-rules ()
     [(_ ftype fptr)
      (make-ftype-pointer ftype
			  (ftype-pointer-address fptr))]))

 (define (nn-recv s buf len flags)
   (define b #f)
   (define r #f)
   (dynamic-wind 
       (lambda ()
	 (set! b (make-ftype-pointer void* (foreign-alloc (ftype-sizeof void*))))
	 (set! r (nn-recv% s (ftype-pointer-address b) len flags)))

 ;;     (let ([c (ftype-ref char () fptr i)])
 ;;       (if (or (char=? c #\nul) (and bytes (>= (+ 1 i) (car bytes))))
 ;; 	   (make-string i)
 ;; 	   (let ([str (f (fx+ i 1))])
 ;; 	     (string-set! str i c)
 ;; 	     str)))))
















 (define (nn-recv s buf len flags)
   (define b #f)
   (define r #f)
   (dynamic-wind 
       (lambda ()
	 (set! b (make-ftype-pointer void* (foreign-alloc (ftype-sizeof void*))))
	 (set! r (nn-recv% s (ftype-pointer-address b) len flags)))

(import (chezscheme) (nanomsg))
(nanomsg-library-init)

(define argv (command-line-arguments))

(define sock (nn-socket AF_SP NN_REQ))
(define eid (nn-connect sock (car argv)))


(call/cc 
 (lambda (return)
   (let loop ()
     (guard 
      (e (else (printf "error in remote-repl: on ~d: ~d with irritants ~d~n" 
							 (if (who-condition? e) (condition-who e) 'unknown)
							 (if (message-condition? e) (condition-message e) "")
							 (if (irritants-condition? e) (condition-irritants e) ""))))
      (printf "> ")
      (nn-send sock (string->utf8 
		     (call-with-string-output-port
		      (lambda (p)
			(let ([token (read)])
			  (if (eof-object? token)
			      (return #f)
			      (write token p)))))) 0)
      (let ([buf (box #t)])
	(nn-recv sock buf NN_MSG 0)
	(let ([s (utf8->string (unbox buf))])
	  (printf "~d" (if (string=? "#<void>\n" s) "" s)))))
     (loop))))

(import (chezscheme) (nanomsg))
(nanomsg-library-init)

(define argv (command-line-arguments))

(define sock (nn-socket AF_SP NN_REQ))
;(define eid (nn-connect sock (car argv)))
(define eid (nn-connect sock "tcp://localhost:9888"))

(call/cc 
 (lambda (return)
   (let loop ()
     (guard 
      (e (else (printf "error in remote-repl: on ~d: ~d with irritants ~d~n" 
		       (if (who-condition? e) (condition-who e) 'unknown)
		       (if (message-condition? e) (condition-message e) "")
		       (if (irritants-condition? e) (condition-irritants e) ""))))
      (printf "> ")
      (nn-send sock (string->utf8 
		     (call-with-string-output-port
		      (lambda (p)
			(let ([token (read)])
			  (if (eof-object? token)
			      (return #f)
			      (write token p)))))) 0)
      (let ([buf (box #t)])
	(nn-recv sock buf NN_MSG 0)
	(let ([s (utf8->string (unbox buf))])
	  (printf "~d" (if (string=? "#<void>\n" s) "" s)))))
     (loop))))

(library (netstring)
  (export read-netstring write-netstring read-netstring/string)
  (import (chezscheme))

  (define (read-netstring port)
    (let loop ([len 0])
      (let ([c (get-u8 port)] )
	(when (eof-object? c)
	    (errorf 'read-netstring "unexpected end of file while reading header"))
	(cond
	 [(<= #x30 c #x39)
	  (loop (fx+ (fx* 10 len) (fx- c #x30)))]
	 [(fx= c (char->integer #\:))
	  (let ([r (get-bytevector-n port len)])
	    (when (or (eof-object? r)
		      (< (bytevector-length r) len))
		  (errorf 'read-netstring "unexpected end of file while reading data"))
	    (unless (eq? (get-u8 port) (char->integer #\,))
		    (errorf 'read-netstring "expected , at end of netstring" ))
	    r)]
	 [else
	  (errorf 'read-netstring "unexpected character while reading header #x~x" c)]))))




  (define (read-netstring/string port)
    (utf8->string (read-netstring port)))
  
  (define (write-netstring port data)
    (let ([data (if (string? data) (string->utf8 data) data)])
      (put-bytevector port (string->utf8 (number->string (bytevector-length data))))
      (put-u8 port (char->integer #\:))
      (put-bytevector port data)
      (put-u8 port (char->integer #\,)))))

(library (netstring)
  (export read-netstring write-netstring read-netstring/string)
  (import (chezscheme))

  (define (read-netstring port get-proc get-proc-n)
    (let loop ([len 0])
      (let ([c (get-proc port)] )
	(when (eof-object? c)
	    (errorf 'read-netstring "unexpected end of file while reading header"))
	(cond
	 [(<= #x30 c #x39)
	  (loop (fx+ (fx* 10 len) (fx- c #x30)))]
	 [(fx= c (char->integer #\:))
	  (let ([r (get-proc-n port len)])
	    (when (or (eof-object? r)
		      (< (bytevector-length r) len))
		  (errorf 'read-netstring "unexpected end of file while reading data"))
	    (unless (eq? (get-proc port) (char->integer #\,))
		    (errorf 'read-netstring "expected , at end of netstring" ))
	    r)]
	 [else
	  (errorf 'read-netstring "unexpected character while reading header #x~x" c)]))))

  (define (read-netstring1 port)
    (read-netstring port get-u8 get-bytevector-n))
  
  (define (read-netstring/string port)
    (utf8->string (read-netstring1 port)))
  
  (define (write-netstring port data)
    (let ([data (if (string? data) (string->utf8 data) data)])
      (put-bytevector port (string->utf8 (number->string (bytevector-length data))))
      (put-u8 port (char->integer #\:))
      (put-bytevector port data)
      (put-u8 port (char->integer #\,)))))

(library (posix)
  (export strerror errno EAGAIN EINTR
	  mktemp mkstemp with-mktemp close
	  wtermsig wifexited wifsignaled wexitstatus
	  wait-for-pid)
  (import (chezscheme))
;;; POSIX STUFF
  (define init (load-shared-object "libc.so.6"))

  (define strerror
    (case-lambda
     [() (strerror (errno))]
     [(n)
      (define strerror* (foreign-procedure "strerror_r" (int u8* size_t) string))
      (define buff (make-bytevector 1024))
      (strerror* n buff 1024)]))

  (define (errno)
    (foreign-ref 'int (foreign-entry "errno") 0))

  (define EAGAIN 11)
  (define EINTR 4)

  (define (mkstemp template)
    (define mkstemp* (foreign-procedure "mkstemp" (u8*) int))
    (define t (string->utf8 template))
    
    (let ([fd (mkstemp* t)])
      (when (< fd 0)
	    (errorf 'mkstemp "failed: ~a" (strerror)))
      (values fd (utf8->string t))))

  (define (mktemp template)
    (define mktemp* (foreign-procedure "mktemp" (string) string))    
    (let ([s (mktemp* template)])
      (when (string=? s "")
	    (errorf 'mktemp "failed: ~a" (strerror)))
      s))

  (define (with-mktemp template f)
	  (define file #f)
	  (dynamic-wind
	      (lambda () (set! file (mktemp template)))
	      (lambda () (f file))
	      (lambda () (delete-file file))))

  
  (define (close fd)
    (define close* (foreign-procedure "close" (int) int))
    (if (< (close* fd) 0)
	(errorf 'close "failed: ~a" (strerror))))


  (define (wtermsig x)
    (logand x #x7f))
  (define (wifexited x)
    (eq? (wtermsig x) 0))
  (define (wifsignaled x)
    (> (logand #xff (bitwise-arithmetic-shift-right
		     (+ 1 (wtermsig x))
		     1))
       0))
  (define (wexitstatus x)
    (bitwise-arithmetic-shift-right (logand x #xff00) 8))

  (define (wait-for-pid pid)
    (define waitpid* (foreign-procedure "waitpid" (int u8* int) int))
    (define status* (make-bytevector (foreign-sizeof 'int)))
    (let loop ()
      (let ([r (waitpid* pid status* 0)])
	(when (< r 0)
	      (errorf 'wait-for-pid "waitpid failed: ~d" (strerror)))
	(let ([status (bytevector-sint-ref status* 0 (native-endianness) (foreign-sizeof 'int))])
	  (cond [(wifexited status) (wexitstatus status)]
		[(wifsignaled status) #f]
		[(loop)])))))
) ;;library posix

  (srfi s2 and-let)
  (matchable)
  (only (srfi s13 strings) string-contains-ci)
  (srfi s11 let-values)
  (srfi s26 cut)
  (sql-null))

 #;(define (sqlite3-library-init)

   (begin
     (case (machine-type)
       [(i3nt a6nt i3mw a6mw)
	(load-shared-object "sqlite3.dll")]
       [else
	(load-shared-object "libsqlite3.so.0")])))
 (define libinit (begin (load-shared-object "sqlite3.dll")))
 ;; compatibility functions
 (define (hashtable-walk ht f)
   (vector-for-each (lambda (x)
                      (f x (hashtable-ref ht x #f)))
                    (hashtable-keys ht)))

 (define (->string x)

  (srfi s2 and-let)
  (matchable)
  (only (srfi s13 strings) string-contains-ci)
  (srfi s11 let-values)
  (srfi s26 cut)
  (sql-null))

 #;(define (sqlite3-library-init))
 (define libinit
   (begin
     (case (machine-type)
       [(i3nt a6nt i3mw a6mw)
	(load-shared-object "sqlite3.dll")]
       [else
	(load-shared-object "libsqlite3.so.0")])))
 ;(define libinit (begin (load-shared-object "sqlite3.dll")))
 ;; compatibility functions
 (define (hashtable-walk ht f)
   (vector-for-each (lambda (x)
                      (f x (hashtable-ref ht x #f)))
                    (hashtable-keys ht)))

 (define (->string x)

        (list->stream objs)))

  (define (port->stream . port)
    (define port->stream
      (stream-lambda (p)
        (let ((c (read-char p)))
          (if (eof-object? c)












              stream-null
              (stream-cons c (port->stream p))))))
    (let ((p (if (null? port) (current-input-port) (car port))))
      (if (not (input-port? p))
          (error 'port->stream "non-input-port argument")
          (port->stream p))))

        (list->stream objs)))

  (define (port->stream . port)
    (define port->stream
      (stream-lambda (p)
        (let ((c (read-char p)))
          (if (eof-object? c)
              stream-null
              (stream-cons c (port->stream p))))))
    (let ((p (if (null? port) (current-input-port) (car port))))
      (if (not (input-port? p))
          (error 'port->stream "non-input-port argument")
          (port->stream p))))

  (define (binary-port->stream . port)
    (define port->stream
      (stream-lambda (p)
        (let ((c (get-u8 p)))
          (if (eof-object? c)
              stream-null
              (stream-cons c (port->stream p))))))
    (let ((p (if (null? port) (current-input-port) (car port))))
      (if (not (input-port? p))
          (error 'port->stream "non-input-port argument")
          (port->stream p))))

;; limitations under the License.

(library (thunder-utils)
	 (export string-split string-replace)
	 (import (scheme) (srfi s14 char-sets))

	 ;; POSSIBLE THAT NOT EXISTS THIS FUNCTION???
					; s is a string , c is a character-set
					; null strings are discarded from result



	 (define (string-split s c)

	   (define res '())
	   (let loop ([l (string->list s)] [t '()])
	     (if (null? l) 

		 (if (null? t) res (append res (list(list->string t))))
		 (if (char-set-contains? c (car l))
		     (begin 
		       (unless (null? t) 

			       (set! res (append res (list (list->string t)))))
		       (loop (cdr l) '()))
		     (loop (cdr l) (append t (list (car l))))))))

	 ;; POSSIBLE THAT THIS NOT EXIST?
	 ;; if x is a character: (eq?  s[i] x) => s[i] = y
	 ;; if x is a list:      (memq s[i] x) => s[i] = y

	 (define (string-replace s x y)
	   (list->string  
	    (let ([cmp (if (list? x) memq eq?)])
	      (map (lambda (z) (if (cmp z x) y z)) (string->list s)))))



);library

;; limitations under the License.

(library (thunder-utils)
	 (export string-split string-replace)
	 (import (scheme) (srfi s14 char-sets))

	 ;; POSSIBLE THAT NOT EXISTS THIS FUNCTION???
	 ;; s is a string , c is a character-set
	 ;; null strings are discarded from result by default unless #f is specified as third argument
	 (define string-split
	   (case-lambda
	    [(s c)
	     (string-split s c #t)]
	    [(s c discard-null?)
	     (define res '())
	     (let loop ([l (string->list s)] [t '()])
	       (if (null? l) 
		   (if (and (null? t) discard-null?)
		       res (append res (list (list->string t))))
		 (if (char-set-contains? c (car l))
		     (begin 

		       (unless (and (null? t) discard-null?)
			       (set! res (append res (list (list->string t)))))
		       (loop (cdr l) '()))
		     (loop (cdr l) (append t (list (car l)))))))]))
	    
	 ;; POSSIBLE THAT THIS NOT EXIST?
	 ;; if x is a character: (eq?  s[i] x) => s[i] = y
	 ;; if x is a list:      (memq s[i] x) => s[i] = y

	 (define (string-replace s x y)
	   (list->string  
	    (let ([cmp (if (list? x) memq eq?)])
	      (map (lambda (z) (if (cmp z x) y z)) (string->list s)))))



);library

  usb-open
  usb-log-level-enum
  usb-log-level-index
  usb-log-level-ref
  usb-set-debug

  usb-control-transfer
  usb-bulk-transfer

  usb-interrupt-transfer

  ) ;export

 (import (chezscheme))


 (define library-init 
   (begin
     (load-shared-object "libusb-1.0.so.0")))

 (define-ftype usb-device* void*)
 (define-ftype usb-device*-array (array 0 usb-device*))
................................................................................
				       u8* unsigned-16 unsigned-int) int)]
	  [e (f (usb-device-handle-addr handle) type request value index 
		data (bytevector-length data) timeout)])
     (if (< e 0)
	 (error 'usb-control-transfer (usb-strerror e) e))
     (void)))

 (define (usb-*-transfer handle endpoint data timeout func)
   (assert (and 'usb-*-transfer (usb-device-handle? handle)))
   (assert (and 'usb-*-transfer (number? endpoint)))
   (assert (and 'usb-*-transfer (bytevector? data)))
   (assert (and 'usb-*-transfer (number? timeout)))
   (usb-free-garbage)
   (let* ([ptr (alloc-int*)]
	  [e (func (usb-device-handle-addr handle) endpoint data (bytevector-length data) 

		   (ftype-pointer-address ptr) timeout)])
     (if (< e 0)
	 (error 'usb-*-transfer (usb-strerror e) e))
     (ftype-pointer-address (ftype-ref int* () ptr))))























(define (usb-bulk-transfer handle endpoint data timeout)
  (usb-*-transfer handle endpoint data timeout 
		  (foreign-procedure "libusb_bulk_transfer" 
				     (void* unsigned-8 u8* int void* unsigned-int) int)))





(define (usb-interrupt-transfer handle endpoint data timeout)
  (usb-*-transfer handle endpoint data timeout 
		  (foreign-procedure "libusb_interrupt_transfer" 
				     (void* unsigned-8 u8* int void* unsigned-int) int)))


) ;library usb

  usb-open
  usb-log-level-enum
  usb-log-level-index
  usb-log-level-ref
  usb-set-debug

  usb-control-transfer
  usb-bulk-read
  usb-bulk-write
  usb-interrupt-write
  usb-interrupt-read
  ) ;export

 (import (chezscheme)
	 (only (ffi-utils) cast char*->bytevector))

 (define library-init 
   (begin
     (load-shared-object "libusb-1.0.so.0")))

 (define-ftype usb-device* void*)
 (define-ftype usb-device*-array (array 0 usb-device*))
................................................................................
				       u8* unsigned-16 unsigned-int) int)]
	  [e (f (usb-device-handle-addr handle) type request value index 
		data (bytevector-length data) timeout)])
     (if (< e 0)
	 (error 'usb-control-transfer (usb-strerror e) e))
     (void)))

 (define (usb-*-write handle endpoint data timeout func)
   (assert (and 'usb-*-transfer (usb-device-handle? handle)))
   (assert (and 'usb-*-transfer (number? endpoint)))
   (assert (and 'usb-*-transfer (bytevector? data)))
   (assert (and 'usb-*-transfer (number? timeout)))
   (usb-free-garbage)
   (let* ([ptr (alloc-int*)]
	  [e (func (usb-device-handle-addr handle) endpoint
		   data (bytevector-length data) 
		   (ftype-pointer-address ptr) timeout)])
     (if (< e 0)
	 (error 'usb-*-transfer (usb-strerror e) e))
     (ftype-pointer-address (ftype-ref int* () ptr))))
 
 (define (usb-*-read handle endpoint len timeout func)
   (assert (and 'usb-*-transfer (usb-device-handle? handle)))
   (assert (and 'usb-*-transfer (number? endpoint)))
   (assert (and 'usb-*-transfer (number? len)))
   (assert (and 'usb-*-transfer (number? timeout)))
   (usb-free-garbage)
   (let* ([ptr (alloc-int*)]
	  [ptr% (usb-guardian ptr)]
	  [data (foreign-alloc len)]
	  [data% (usb-guardian data)]
	  [e (func (usb-device-handle-addr handle) endpoint
		   data (bytevector-length data) 
		   (ftype-pointer-address ptr) timeout)])
     (if (< e 0)
	 (error 'usb-*-transfer (usb-strerror e) e))
     (let ([read-len (ftype-pointer-address (ftype-ref int* () ptr))])
       (char*->bytevector (cast char data) read-len))))

(define (usb-bulk-read handle endpoint len timeout)
  (usb-*-read handle endpoint len timeout 
	      (foreign-procedure "libusb_bulk_transfer" 
				 (void* unsigned-8 u8* int void* unsigned-int) int)))
(define (usb-bulk-write handle endpoint data timeout)
  (usb-*-write handle endpoint data timeout 
	       (foreign-procedure "libusb_bulk_transfer" 
				  (void* unsigned-8 u8* int void* unsigned-int) int)))

(define (usb-interrupt-read handle endpoint len timeout)
  (usb-*-read handle endpoint len timeout 
		  (foreign-procedure "libusb_interrupt_transfer" 
				     (void* unsigned-8 u8* int void* unsigned-int) int)))
(define (usb-interrupt-write handle endpoint data timeout)
  (usb-*-write handle endpoint data timeout 
		  (foreign-procedure "libusb_interrupt_transfer" 
				     (void* unsigned-8 u8* int void* unsigned-int) int)))


) ;library usb