(posix)
		(only (data-structures) string-intersperse ->string))

	(define c-eval-includes (make-parameter '("stdio.h")))
	
	(define (c-eval-printf format . values)
	  (c-eval (string-append "printf (\"" format "\"," (string-intersperse (map ->string values) ",") ");")))
		
	(define (c-eval expr)
	  (with-mktemp
	   "/tmp/c-eval-XXXXXX"
	   (lambda (file)
	     (apply
	      (lambda (in out pid)
		(for-each (lambda (x)

		(posix)
		(only (data-structures) string-intersperse ->string))

	(define c-eval-includes (make-parameter '("stdio.h")))
	
	(define (c-eval-printf format . values)
	  (c-eval (string-append "printf (\"" format "\"," (string-intersperse (map ->string values) ",") ");")))
	
	(define (c-eval expr)
	  (with-mktemp
	   "/tmp/c-eval-XXXXXX"
	   (lambda (file)
	     (apply
	      (lambda (in out pid)
		(for-each (lambda (x)

  cpp-include cpp-define cpp-wrap-header cpp-pragma cpp-line
  cpp-error cpp-warning cpp-stringify cpp-sym-cat
  c-comment c-block-comment c-attribute
  )

 (import (chezscheme) 
	 (fmt fmt)

	 (only (srfi s1 lists) every)
	 (only (srfi s13 strings) substring/shared string-index string-index-right))

 (include "fmt-c.scm")

 )

  cpp-include cpp-define cpp-wrap-header cpp-pragma cpp-line
  cpp-error cpp-warning cpp-stringify cpp-sym-cat
  c-comment c-block-comment c-attribute
  )

 (import (chezscheme) 
	 (fmt fmt)
	 (srfi private include)
	 (only (srfi s1 lists) every)
	 (only (srfi s13 strings) substring/shared string-index string-index-right))

 (include/resolve ("fmt") "fmt-c.scm")

 )

;; BSD-style license: http://synthcode.com/license.txt

;; a condensed non-spacing mark range from UnicodeData.txt (chars with
;; the Mn property) - generated partially by hand, should automate
;; this better

(define low-non-spacing-chars
  (u8vector
#xff #xff #xff #xff #xff #xff #xff #xff #xff #xff #xff #xff #xff #xff    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
#x78    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0 #xfe #xff #xff #xff #xff #xff #x1f    0    0    0    0    0    0    0
   0    0 #x3f    0    0    0    0    0    0 #xf8 #xff #x01    0    0 #x01    0
................................................................................
      ((<= #x20000 ci #x30000) 2)
      ;; non-spacing mark (Mn) ranges from UnicodeData.txt
      ((<= #x0300 ci #x3029)
       ;; inlined bit-vector-ref for portability
       (let* ((i (- ci #x0300))
              (byte (quotient i 8))
              (off (remainder i 8)))
         (if (zero? (bitwise-and (u8vector-ref low-non-spacing-chars byte)
                                 (arithmetic-shift 1 off)))
             1
             0)))
      ((<= #x302A ci #x302F) 0)
      ((<= #x3099 ci #x309A) 0)
      ((= #xFB1E ci) 0)
      ((<= #xFE00 ci #xFE23) 0)
      ((<= #x1D167 ci #x1D169) 0)

;; BSD-style license: http://synthcode.com/license.txt

;; a condensed non-spacing mark range from UnicodeData.txt (chars with
;; the Mn property) - generated partially by hand, should automate
;; this better

(define low-non-spacing-chars
  (bytevector
#xff #xff #xff #xff #xff #xff #xff #xff #xff #xff #xff #xff #xff #xff    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
#x78    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0 #xfe #xff #xff #xff #xff #xff #x1f    0    0    0    0    0    0    0
   0    0 #x3f    0    0    0    0    0    0 #xf8 #xff #x01    0    0 #x01    0
................................................................................
      ((<= #x20000 ci #x30000) 2)
      ;; non-spacing mark (Mn) ranges from UnicodeData.txt
      ((<= #x0300 ci #x3029)
       ;; inlined bit-vector-ref for portability
       (let* ((i (- ci #x0300))
              (byte (quotient i 8))
              (off (remainder i 8)))
         (if (zero? (bitwise-and (bytevector-u8-ref low-non-spacing-chars byte)
                                 (bitwise-arithmetic-shift 1 off)))
             1
             0)))
      ((<= #x302A ci #x302F) 0)
      ((<= #x3099 ci #x309A) 0)
      ((= #xFB1E ci) 0)
      ((<= #xFE00 ci #xFE23) 0)
      ((<= #x1D167 ci #x1D169) 0)

#!r6rs
(library 
 (fmt js)
 (export
  js-expr js-function js-var js-comment js-array js-object js=== js>>>)
 
 (import (chezscheme)
	 (fmt fmt) (fmt c))

 
 (include "fmt-js.scm")

 
 )

#!r6rs
(library 
 (fmt js)
 (export
  js-expr js-function js-var js-comment js-array js-object js=== js>>>)
 
 (import (chezscheme)
	 (fmt fmt) (fmt c)
	 (srfi private include))
 

 (include ("fmt") "fmt-js.scm")
 
 )

(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 (cond [(null? argv)
		   (nn-connect sock "tcp://localhost:9888")]
		  [else
		   (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))))

(define clisock (accept sock))
(define (read-all sock) 
  (do ([c (get-u8 sock) (get-u8 sock)] 
	     [l '() (cons c l)])
      ((eof-object? c) (utf8->string (apply bytevector (reverse l))))))
(read-all clisock)
|#

(define clisock (accept sock))
(define (read-all sock) 
  (do ([c (get-u8 sock) (get-u8 sock)] 
	     [l '() (cons c l)])
      ((eof-object? c) (utf8->string (apply bytevector (reverse l))))))
(read-all clisock)
|#

;; Copyright (c) 2009 Derick Eddington.  All rights reserved.
;; Licensed under an MIT-style license.  My license is in the file
;; named LICENSE from the original collection this file is distributed
;; with.  If this file is redistributed with some other collection, my
;; license must also be included.

#!r6rs
(library (srfi s2 and-let)  
  (export 
    and-let*)
  (import 
    (rnrs))
  
  (define-syntax and-let*
    (lambda (stx)

;; Copyright (c) 2009 Derick Eddington.  All rights reserved.
;; Licensed under an MIT-style license.  My license is in the file
;; named LICENSE from the original collection this file is distributed
;; with.  If this file is redistributed with some other collection, my
;; license must also be included.

#!r6rs
(library (srfi s2 and-let)
  (export 
    and-let*)
  (import 
    (rnrs))
  
  (define-syntax and-let*
    (lambda (stx)

;	   HTML Authoring in SXML for my personal Web pages
;
; The present file defines several functions and higher-order
; SXML "tags" that are used to compose HTML pages on my web site.
; In LaTeX terms, this file is similar to article.cls.
;
; See http://pobox.com/~oleg/ftp/Scheme/xml.html#XML-authoring
; for more examples and explanation.
;
; IMPORT
; Approporiate Prelude: myenv.scm or myenv-bigloo.scm
; srfi-13-local.scm or the appropriate native implementation of SRFI-13
; util.scm
; SXML-tree-trans.scm
; SXML-to-HTML.scm
; OS:file-length, unless it is included into the core system
;   (see myenv-bigloo.scm for example)
;
; $Id: SXML-to-HTML-ext.scm,v 2.10 2006/12/02 01:09:22 oleg Exp oleg $

; skip the lst trough the first significant element
; return the tail of lst such that (car result) is significant
; Insignificant elems are '(), #f, and lists made of them
; If all of the list is insignificant, return #f
(define (signif-tail lst)
  (define (signif? obj)
    (and (not (null? obj)) obj
	 (if (pair? obj)
	     (or (signif? (car obj))
		 (signif? (cdr obj)))
	     obj)))
  (and (signif? lst)
       (assert (pair? lst))
       (if (signif? (car lst)) lst
	   (signif-tail (cdr lst)))))

; Procedure make-header HEAD-PARMS
; Create the 'head' SXML/HTML tag. HEAD-PARMS is an assoc list of
; (h-key h-value), where h-value is a typically string;
; h-key is a symbol:
; title, description, AuthorAddress, keywords,
; Date-Revision-yyyymmdd, Date-Creation-yyyymmdd,
; long-title
; One of the h-key can be Links.
; In that case, h-value is a list of
;	(l-key l-href (attr value) ...)
; where l-key is one of the following:
;	start, contents, prev, next, top, home

(define (make-header head-parms)
  `(head
    (title ,(lookup-def 'title head-parms))
    ,(map
      (lambda (key)
	(let ((val (lookup-def key head-parms warn: #f)))
	  (and val
	       `(meta (@ (name ,(symbol->string key)) (content ,val))))))
      '(description AuthorAddress keywords
	Date-Revision-yyyymmdd Date-Creation-yyyymmdd))
    ,(let ((links (lookup-def 'Links head-parms '())))
      (and (pair? links)
	   (map
	    (lambda (link-key)
	      (let ((val (lookup-def link-key links #f)))
		(and val
		  (let ((val (if (not (pair? val)) (list val) val)))
		     `(link (@ (rel ,(symbol->string link-key))
			       (href ,(car val))
			       ,@(cdr val)))))))
	    '(start contents prev next)))))
)

; Create a navigational bar. The argument head-parms is the same
; as the one passed to make-header. We're only concerned with the
; h-value Links
(define (make-navbar head-parms)
  (let ((links (lookup-def 'Links head-parms '()))
	(nav-labels '((prev . "previous")
		      (next . "next")
		      (contents . "contents")
		      (top . "top"))))
    (and (pair? links)
      `(div (@ (align "center") (class "navbar"))
	 ,(let loop ((nav-labels nav-labels) (first? #t))
	    (if (null? nav-labels) '()
		(let ((val (lookup-def (caar nav-labels) links warn: #f)))
		  (if (not val)
		      (loop (cdr nav-labels) first?)
		      (cons
		       (list " " (if first? #f '(n_)) " "
			     `(a (@ (href ,val)) ,(cdar nav-labels)))
		       (loop (cdr nav-labels) #f))))))
	 (hr)))
))
			      

; Create a footer. The argument head-parms is the same
					; as passed to make-header.
(define (make-footer head-parms)
  `((br)
    (div (hr))
    (h3 "Last updated "
	,(let* ((date-revised
		  (lookup-def 'Date-Revision-yyyymmdd head-parms))
		(year (string->integer date-revised 0 4))
		(month (string->integer date-revised 4 6))
		(day   (string->integer date-revised 6 8))
		(month-name
		 (vector-ref
		  '#("January" "February" "March" "April" "May" "June"
		    "July"   "August" "September" "October" "November"
		    "December")
		  (dec month))))
	   (list month-name " " day ", " year)))
    ,(let ((links (lookup-def 'Links head-parms '())))
       (and (pair? links)
	    (let ((home (lookup-def 'home links warn: #f)))
	      (and home
		   `(p "This site's top page is "
		       (a (@ (href ,home)) (strong ,home)))))))
    (div 
      (address "oleg-at-pobox.com or oleg-at-okmij.org"
       (br)
       "Your comments, problem reports, questions are very welcome!"))
    (p (font (@ (size "-2")) "Converted from SXML by SXML->HTML"))
    ,(let ((rcs-id (lookup-def 'rcs-id head-parms #f)))
       (and rcs-id `(h4 ,rcs-id)))
    ))

; Bindings for the post-order function, which traverses the SXML tree
; and converts it to a tree of fragments

(define entag*
  (let ((with-nl	; Block-level HTML elements:
				; We insert a NL before them.
				; No NL is inserted before or after an
				; inline element.
	  '(br 			; BR is technically inline, but we
				; treat it as block
	     p div hr
	     h1 h2 h3 h3 h5 h6 meta
	     dl ul ol li dt dd pre
	     table tr th td link title script
	     center blockquote form
	     address body thead tfoot tbody col colgroup)))
    (lambda (tag elems)
      (let ((nl? (and (memq tag with-nl) #\newline)))
	(if (and (pair? elems) (pair? (car elems))
	      (eq? '@ (caar elems)))
	  (list nl? #\< tag (cdar elems) #\>
	    (if (pair? (cdr elems))
		(list (cdr elems) "</" tag #\> nl?)
		(list "</" tag #\> nl?)))
	  (list nl? #\< tag #\> 
	    (and (pair? elems) (list elems "</" tag #\> nl?))
	    ))))))

; The universal transformation from SXML to HTML. The following rules
; work for every HTML, present and future
(define universal-conversion-rules
  `((@
      ((*default*       ; local override for attributes
        . ,(lambda (attr-key . value) (enattr attr-key value))))
      . ,(lambda (trigger . value) (cons '@ value)))
    (*default* . ,(lambda (tag . elems) (entag* tag elems)))
    (*text* . ,(lambda (trigger str) 
		 (if (string? str) (string->goodHTML str) str)))
    (n_		; a non-breaking space
     . ,(lambda (tag . elems)
	  (cons "&nbsp;" elems)))))

; A variation of universal-conversion-rules which keeps '<', '>', '&'
; and similar characters intact. The universal-protected-rules are
; useful when the tree of fragments has to be traversed one more time.
(define universal-protected-rules
  `((@
      ((*default*       ; local override for attributes
        . ,(lambda (attr-key . value) (enattr attr-key value))))
      . ,(lambda (trigger . value) (cons '@ value)))
    (*default* . ,(lambda (tag . elems) (entag tag elems)))
    (*text* . ,(lambda (trigger str) 
		 str))
    (n_		; a non-breaking space
     . ,(lambda (tag . elems)
	  (cons "&nbsp;" elems)))))

; The following rules define the identity transformation
(define alist-conv-rules
  `((*default* . ,(lambda (tag . elems) (cons tag elems)))
    (*text* . ,(lambda (trigger str) str))))


; Find the 'Header' node within the 'Content' SXML expression.
; Currently this query is executed via a transformation, with
; rules that drop out everything but the 'Header' node.
; We use the _breadth-first_ traversal of the Content tree.
(define (find-Header Content)
  (letrec 
    ((search-rules
	 `((*default*
	    *preorder*
	    . ,(lambda (tag . elems)
		 (let loop ((elems elems) (worklist '()))
		   (cond
		    ((null? elems) 
		     (if (null? worklist) '()
			 (pre-post-order worklist search-rules)))
		    ((not (pair? (car elems))) (loop (cdr elems) worklist))
		    ((eq? 'Header (caar elems)) (car elems)) ; found
		    (else (loop (cdr elems) (cons (car elems) worklist)))))))
	   )))
    (lookup-def 'Header
		(list (pre-post-order Content search-rules))
		)))


; Transformation rules that define a number of higher-order tags,
; which give "style" to all my pages.
; Some of these rules require a pre-post-order iterator
; See xml.scm or any other of my web page master files for an example
; of using these stylesheet rules

(define (generic-web-rules Content additional-rules)
  (append
   additional-rules
   universal-conversion-rules
   `((html:begin 
      . ,(lambda (tag . elems)
	   (list
	     "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\""
	     nl 
	     "\"http://www.w3.org/TR/html4/loose.dtd\">" nl
	     "<html>" nl
	     elems
	     "</html>" nl)))

     (Header
      *preorder*
      . ,(lambda (tag . headers)
	   (post-order (make-header headers) universal-conversion-rules)
	   ))

     (body
      . ,(lambda (tag . elems)
	   (list "<body bgcolor=\"#FFFFFF\">" nl elems "</body>")))

     (navbar			; Find the Header in the Content
      . ,(lambda (tag)		; and create the navigation bar
	   (let ((header-parms (find-Header Content)))
	     (post-order (make-navbar header-parms)
			 universal-conversion-rules))))
     
     (footer			; Find the Header in the Content
      . ,(lambda (tag)		; and create the footer of the page
	   (let ((header-parms (find-Header Content)))
	     (post-order (make-footer header-parms)
			 universal-conversion-rules))))
     
     (page-title		; Find the Header in the Content
      . ,(lambda (tag)		; and create the page title rule
	   (let ((header-parms (find-Header Content)))
	     (list "<h1 align=center>" 
		   (lookup-def 'long-title header-parms) "</h1>" nl))))


     (Section	; (Section level "content ...")
      . ,(lambda (tag level head-word . elems)
	   (list "<br>&nbsp;<a name=\"" head-word "\">&nbsp;</a>" nl
		 "<h" level ">"  head-word elems "</h" level ">" nl)))

     (TOC	; Re-scan the Content for "Section" tags and generate
      . ,(lambda (tag)	; the Hierarchical Table of contents
	   (let ((sections
		  (post-order Content
		    `((Section	; (Section level "content ...")
		       ((*text* . ,(lambda (tag str) str)))
		       . ,(lambda (tag level head-word . elems)
			    (vector level
				    (list "<li><a href=\"#" head-word
					  "\">" head-word elems "</a>" nl))))
		      (*default*
		       . ,(lambda (attr-key . elems) elems))
		      (*text* . ,(lambda (trigger str) '()))))))
	     ;(cerr sections)
	     (list "<div>"
	      (let loop ((curr-level 1) (sections sections))
	       (cond
		((null? sections)
		 (let fill ((curr-level curr-level))
		   (if (> curr-level 1)
		       (cons "</ol>" (fill (dec curr-level)))
		       '())))
		((null? (car sections)) (loop curr-level (cdr sections)))
		((pair? (car sections)) (loop curr-level
					      (append (car sections)
						      (cdr sections))))
		((vector? (car sections))
		 (let ((new-level (vector-ref (car sections) 0)))
		   (cond
		    ((= new-level curr-level)
		     (cons (vector-ref (car sections) 1)
			   (loop curr-level (cdr sections))))
		    ((= (inc new-level) curr-level)
		     (cons "</ol>"
			   (cons (vector-ref (car sections) 1)
				 (loop new-level (cdr sections)))))
		    ((= new-level (inc curr-level))
		     (cons nl (cons "<ol>"
			   (cons (vector-ref (car sections) 1)
				 (loop new-level (cdr sections))))))
		    (else 
		     (error "inconsistent levels: " curr-level new-level)))))
		(else "wrong item: " sections)))
	      nl "</div>" nl))))

     (bibitem *macro*
       . ,(lambda (tag label key . text)
	   `(p (a (@ (name ,key)) "[" ,label "]") " " ,text)))

     (cite		; ought to locate the label and use the label!
      . ,(lambda (tag key)
	   (list "[<a href=\"#" key "\">" key "</a>]")))


     (trace		; A debugging aid
      . ,(lambda (tag . content)
	   (cerr tag content nl)
	   '()))

     (URL  *macro*
      . ,(lambda (tag url)
	   `((br) "<" (a (@ (href ,url)) ,url) ">")))


     (verbatim	; set off pieces of code: one or several lines
      . ,(lambda (tag . lines)
	   (list "<pre>"
		 (map (lambda (line) (list "     " line nl))
		      lines)
		 "</pre>")))
		; (note . text-strings)
		; A note (remark), similar to a footnote
     (note
      . ,(lambda (tag . text-strings)
	   (list " <font size=\"-1\">[" text-strings "]</font>" nl)))

		; A reference to a file
     (fileref
      . ,(lambda (tag pathname . descr-text)
	   (list "<a href=\"" pathname "\">"
		 (car (reverse (string-split pathname #\/)))
		 "</a> [" 
		 (let ((file-size (OS:file-length pathname)))
		   (if (not (positive? file-size))
		       (error "File not found: " pathname))
		   (cond
		    ((< file-size 1024) "&lt;1K")
		    (else (list (quotient (+ file-size 1023) 1024) "K"))))
		 "]<br>"
		 descr-text)))

		; A reference to a plain-text file (article)
     (textref
       . ,(lambda (tag pathname title . descr)
	    (let ((file-size (OS:file-length pathname)))
	      (if (not (positive? file-size))
		  (error "File not found: " pathname))
	      (list "<a href=\"" pathname "\">" title
		    "</a> <font size=\"-1\">[plain text file]</font><br>" nl
		    descr))))

		; A reference to an anchor in the present file
		; (local-ref target . title)
		; If title is given, generate a regular
		;	<a href="#target">title</a>
		; Otherwise, transform the content so that a
		; construct that may generate an anchor 'target' (such
		; as Section or Description-unit) is re-written to the
		; title SXML. All other constructs re-write to
		; nothing.
     (local-ref
      *macro*
      . ,(lambda (tag target . title)
	   (let
	       ((title
		 (if (pair? title) title	; it is given explicitly
		     (pre-post-order Content
		       `((*text* . ,(lambda (trigger str) '()))
			 (*default*
			  . ,(lambda (tag . elems)
			       (let ((first-sign (signif-tail elems)))
				 (if first-sign
				     (let ((second-sign
					    (signif-tail (cdr first-sign))))
				       (assert (not second-sign))
				       (car first-sign))
				     '()))))
			 (Description-unit
			  *preorder*
			  . ,(lambda (tag key title . elems)
			       (if (equal? key target)
				   (list title)
				   '()))))))))
	     (assert (pair? title))
	     (cerr "title: " title nl)
	     `(a (@ (href #\# ,target)) ,title))))

		; Unit of a description for a piece of code
		; (Description-unit key title . elems)
		; where elems is one of the following:
		; headline, body, platforms, version
     (Description-unit
      ((headline
	. ,(lambda (tag . elems)
	     (list "<dt>" elems "</dt>" nl)))
       (body
	. ,(lambda (tag . elems)
	     (list "<dd>" elems "</dd>" nl)))
       (platforms
	. ,(lambda (tag . elems)
	     (list "<dt><strong>Platforms</strong><dt><dd>"
		   elems "</dd>" nl)))
       (version
	. ,(lambda (tag . elems)
	     (list "<dt><strong>Version</strong><dt><dd>"
		   "The current version is " elems ".</dd>" nl)))
       (license
	. ,(lambda (tag . elems)
	     (list "<dt><strong>License</strong><dt><dd>"
		   elems "</dd>" nl)))
       (references
	. ,(lambda (tag . elems)
	     (list "<dt><strong>References</strong><dt><dd>"
		   elems "</dd>" nl)))
       (requires
	. ,(lambda (tag . elems)
	     (list "<dt><strong>Requires</strong><dt><dd>"
		   elems "</dd>" nl)))
       )
      . ,(lambda (tag key title . elems)
	   (post-order
	    `((a (@ (name ,key)) (n_))
	      (h2 ,title)
	      (dl (insert-elems))
	      )
	    `(,@universal-protected-rules
	      (insert-elems
	       . ,(lambda (tag) elems))))))
)))

;	   An advanced example of SXML-to-HTML transformations
;
; The problem
; We are given a source document in SXML. The document has the
; HTML-like 'head' and the 'body'. The latter is made of sections,
; each of which is a sequence of paragraphs or (sub)sections. The
; sub-sections are in turn are made of paragraphs or other (subsub...)
; sections, etc.  See the definition of 'doc' below for a sample
; document.
;
; We need to number the sections and (sub...)sections and output
; an HTML document of the following structure:
;
;    1. First Section
;       ...
;    2. Second Section
;    2.1. First sub-section
;    2.2. Another sub-section
;   ...section contents...
;
; We should use the appropriate HTML tags (H2, H3, ...) to set off the
; title of the sections and subsections.
; In addition, we have to generate a hierarchical table of contents
; and place it at the beginning.
;
; This example is due to Jim Bender, who used a similar transformation for
; compiling an XML Schema into ASN.1 specifications.
;
; This file presents a solution, which relies on SXML transformations
; by a traversal combinator pre-post-order. The latter is defined in a
; file ../lib/SXML-tree-trans.scm
;
; The present solution is not the only one possible, nor is it the
; most optimal. The most efficient solution should visit each node of
; the SXML tree exactly once and should not create any closures, let
; alone trees of closures. The pre-post-order combinator -- the tree
; fold in general -- cannot express this single traversal, but an
; accumulating tree fold 'foldts' (also defined in
; ../lib/SXML-tree-trans.scm) can.
;
; The approach taken in this file is not meant to be the most
; efficient.  Rather, it is aimed to be illustrative of various SXSLT
; facilities and idioms.  In particular, we demonstrate: higher-order
; tags, pre-order and post-order transformations, re-writing of SXML
; elements in regular and special ways, context-sensitive applications
; of re-writing rules. Finally, we illustrate SXSLT reflection: an
; ability of a rule to query its own stylesheet and to re-apply the
; stylesheet with "modifications".
;
; All SXSLT transformations in this file are purely functional and
; declarative. The entire code has no mutations. The code maintains
; the full referential transparency.
;
; $Id: sxslt-advanced.scm,v 1.3 2003/08/07 19:55:31 oleg Exp oleg $
;
; IMPORT
; The following is a Bigloo-specific module declaration.
; Other Scheme systems have something similar.
;
; (module sxslt-advanced
; 	(include "myenv-bigloo.scm")
; 	(include "srfi-13-local.scm") ; or import from SRFI-13 if available
; 	(include "util.scm")
; 	(include "SXML-tree-trans.scm")
; 	(include "SXML-to-HTML.scm")
; 	(include "SXML-to-HTML-ext.scm")
; 	)
; See the Makefile for the rules to run this example on Bigloo, SCM
; and other systems

; A sample source document, marked up in SXML.
; Note the ampersand character in the text of the first Section
; paragraph. We should also point out the space character in the name
; of the document file (in the href attribute of the link). These
; characters must be properly escaped in the target HTML document.

(define doc
  '(html (head (title "Document"))
   (body
     (section "First Section"
       (p "This is the intro section.")
       (p "Paragraph &c"))
     (section "Second Section"
       (section "A sub-section"
	 (p "This is section 2.1."
	   (br)
	   (a (@ (href "another doc.html"))
	     "link")))
       (section "Another sub-section"
	 (p "This is section 2.2.")))
     (section "Last major section"
       (p "This is the third section")))))


; Auxiliary procedures

; (a b c ...) => (1 2 3 ...)
(define (list-numbering lst)
  (let loop ((i 1) (lst lst))
    (if (null? lst) '()
      (cons i (loop (+ 1 i) (cdr lst))))))

; The ordinary filter combinator
(define (filter pred lst)
  (cond
    ((null? lst) lst)
    ((pred (car lst)) (cons (car lst) (filter pred (cdr lst))))
    (else (filter pred (cdr lst)))))

; (3 2 1) => "1.2.3"
(define (numbers->string lst)
  (apply string-append
    (list-intersperse 
      (map number->string (reverse lst)) ".")))



; Recursive numbering of sections: given a list of 'sections', return
; the list of '*sections':
;
;   ((section title (section title el ...) ...) 
;    (section title (section title el ...) ...) ...)
; =>
;   ((*section (1) title (*section (1 1) title el ...) el ...)
;    (*section (2) title (*section (1 2) title el ...) el ...) ...)
;
; The numbering (the first element of a *section) is a list of section
; numbers in reverse order: the numeric label of the current section
; followed by the labels of its ancestors.
;
; A 'section' of the source document may contain either (sub)sections,
; or other SXML nodes such as strings or paragraphs. The numbering
; transformation should not affect the latter nodes.
;
; The function 'number-sections' illustrates a typical XSLT-like
; processing. We transform an SXML tree by invoking the traversal
; combinator pre-post-order and passing it the source tree and a
; stylesheet. In the code below, the stylesheet has only three
; rules. The *text* rule is the identity rule. It passes the character
; data from the source SXML tree to the result SXML tree as they are.
; The *default* rule is also an identity rule. A *preorder* label by
; the rule tells pre-post-order to return a non-'section' branch as it
; is, _without_ recursing into it.  A 'section' rule tells what to do
; when we encounter a section: we make a (*section ...) element out of
; the title and the _numbered_ children of the section in question.
;
; We should point out that the traversal combinator pre-post-order is
; an ordinary Scheme function, and can be _mapped_. The stylesheet
; handlers are likewise ordinary Scheme functions, which can invoke
; other Scheme functions, including pre-post-order itself.

(define (number-sections ancestor-numbers sections)
  (map (lambda (el i) 
	 (pre-post-order el
	   ; the stylesheet
	   `((section *preorder*
	       . ,(lambda (tag title . elems)
		    (let ((my-number (cons i ancestor-numbers)))
		    (cons* '*section my-number title
		      (number-sections my-number elems)))))
	      (*default* *preorder* . ,(lambda x x))
	      (*text* . ,(lambda (tag str) str)))))
    sections (list-numbering sections)))



; Building a hierarchical table of contents
;
; It is more lucid to build the TOC in a separate pass, by traversing
; the previously numbered sections. In this pass, we turn '*section'
; elements into TOC entries, and rewrite everything else to nothing.
;
; The function make-toc-entries takes the output of the procedure
; 'number-sections' and yields the list of TOC entries. To be more
; precise, we do the following transformation:
;
;   ((*section (1) title1 non-section-el ...)
;    (*section (2) title2 (*section (1 2) title21 el ...) el ...) ...)
; =>
;   ((li "1. " title1)
;    (li "2. " title2 (ul (li "2.1. " title21) ...)) ...)
;
; Again, we execute the pre-post-order transformation with a
; three-rule stylesheet.  As before, the character data are not
; affected: see the *text* rule.  The *default* rule is different now:
; it transforms a non-'section' branch to nothing at all. To be more
; precise, an SXML element other than *section is turned into '(),
; which will be filtered out later. As a matter of fact, we do not
; have to filter out '() because they will be disregarded by the
; SRV:send-reply function at the very end. In any case, we can regard
; the empty list as being nothing.
;
; The stylesheet almost literally looks like the above re-writing
; example.  We should note that the stylesheet rules are applied to
; all elements of the tree, recursively. We indeed process the
; arbitrary nesting of *sections without much ado. We do not need to
; write something like <apply-templates/>.  Unlike XSLT, but like tree
; fold, the pre-post-order combinator traverses the tree in post-order
; by default. That is, the handler for the *section rule below (lambda
; (tag numbering title . elems) ...) receives, as 'elems', the list of
; the _transformed_ children of the *section in question. To be more
; precise, 'elems' will be the list of TOC elements for internal
; subsections -- or the list of nothing.
;
; We use an auxiliary function 'numbers->string' to convert the list
; of numerical labels such as (1 2 3) into a string label "3.2.1"

(define (make-toc-entries numbered-sections)
  (pre-post-order numbered-sections
    ; the stylesheet
    `((*section
	. ,(lambda (tag numbering title . elems)
	     (let ((elems (filter pair? elems)))
	       `(li ,(numbers->string numbering) ". " ,title
		  ,(and (pair? elems) (list 'ul elems))))))
       (*default* . ,(lambda _ '()))
       (*text* . ,(lambda (tag str) str)))))



; The main transformation stylesheet: from the source SXML document
; to the tree of HTML fragments.
;
; Note [1]
; The general SXML-to-HTML conversion is taken care by the *default*
; and *text* rules in 'universal-conversion-rules', which are defined
; in SXML-to-HTML-ext.scm. xThe *text* rule checks text strings for
; dangerous characters such as angular brackets and the ampersand. The
; rule encodes these characters as the corresponding HTML entities.
; The *default* rule turns an SXML element into the appropriate HTML
; element. These two transformations will be uniformly applied to all
; nodes of the source SXML tree. We _only_ need to add rules for the
; SXML elements that have to be treated in a special way.
;
; Note [2]
; The 'body' of the document, a collection of sections, has to be
; processed specially.  First we recursively number the sections and
; replace them with *sections.  Frankly, there is no need to introduce
; the auxiliary element *section.  Doing so however seems to make the
; example clearer.  We pass the renumbered sections to
; make-toc-entries and get the list of TOC entries (as 'low-level'
; SXML elements).
;
; Note [3]
; We insert the TOC elements before the numbered sections, and
; re-apply main-ss. Actually, we re-apply a slightly "modified"
; stylesheet: the element 'body' no longer needs to be processed
; specially.  In the present example, this 'switching off' of a rule
; is a bit contrived.  We wanted to illustrate however the ability
; to re-apply a stylesheet with some dynamic 'modifications'.  XSLT
; can accomplish something similar, with the help of modes. SXSLT
; gives far simpler tools to dynamically 'modify' the effective
; ruleset.  There are, of course, no mutations. We merely re-invoke
; pre-post-order and pass it main-ss with the modified rules
; prepended.
;
; The 'overridden' rule for the 'body' element has the same handler as
; that of the *default* rule. To find the latter, we _query_ the
; stylesheet itself!  Indeed, the stylesheet is a simple data
; structure, an associative list, and can be manipulated as such. This
; example demonstrates reflexive abilities of SXSLT. A stylesheet can
; analyze itself.
;
; Note [4]
; On the re-application pass, the traversal combinator treats 'body'
; as any other element. The combinator processes its children first,
; and now notices *section elements. We transform a *section as
; follows:
;   (*section (1 2 3) "title321" elem ...)
; =>
;   ((h4 "3.2.1. " "title321") elem ...)
; and re-apply the main stylesheet. Our auxiliary function
; numbers->string helps us to convert the list of labels to a
; string. We use the length of the list (that is, the depth of the
; section in question) to choose the HTML tag for the section: h2, h3,
; h4, etc.
;
; We should point out that *section elements are processed twice, with
; two _different_ stylesheets. First we scan *sections and turn them
; into TOC entries. Later we turn the same *sections into HTML
; headers.
;
; The elements 'section' and 'body' of the source document act as
; higher-level SXML elements. They are recursively re-written into
; more primitive SXML elements until they are finally turned into HTML
; text fragments. Essentially, we compute the fixpoint of the
; re-writing stylesheet. We do not iterate on the whole document
; however, only on the branches that need iterating. The whole
; approach is rather similar to that of Scheme macros.  Scheme macros
; do not have '*default*' rules however. R5RS macros cannot transform
; in post-order and cannot explicitly re-invoke the macro-expander.

; Note [5]
; We have one more thing to take care of. The source document had an
; anchor element '(a (@ (href "another doc.html")) "link")' with the
; name of a local file in the 'href' attribute. In the output HTML
; document, that name will become a URL. File names may contain spaces
; -- but URLs may not. Therefore, we need to encode the space
; character. We should URL-encode the space character only in the
; context of the 'href' node, and nowhere else. The white space
; elsewhere in the document must remain the white space.  Hence we
; need a special rule for 'href', with its own handler for character
; data. This *text* handler is _local_: it acts only in scope of the
; 'href' node. The local text handler looks for the space character
; and URL-encodes it. We have just shown a context-sensitive
; application of re-writing rules. It still appears clear and
; intuitive.
;
; Note [6]
; Joerg-Cyril Hoehle observed that the handler for the 'body' can be
; written as a *macro*. The macro re-writes (body sections) into
; (*body toc numbered-sections), where the auxiliary SXML element *body
; expands into an HTML element 'body'. We need this extra indirection
; to avoid endless recursion. His submission follows (see his message
; on the SSAX-SXML mailing list on Aug 1, 2003).
;      (body *macro*
;        . ,(lambda (tag . elems)
;             (let ((numbered-sections
;                     (number-sections '() elems)))
;               (display numbered-sections)
;               (let*
;                 ((toc
;                    (make-toc-entries numbered-sections)))
;                 ; Now the body contain the TOC entries and the
;                 ; numbered sections. See Note [3] above
;                 `(*body (ul ,toc) ,numbered-sections))) ))
;      (*body
;        ; prevent endless recursion once TOC was generated
;        . ,(lambda (tag . elems) (entag 'body elems)))

(define main-ss 
  `(
     ; see Notes [2,6]
     (body *preorder*
       . ,(lambda (tag . elems)
	    (let ((numbered-sections
		    (number-sections '() elems)))
	      ;(pp numbered-sections)
	      (let*
		((toc
		   (make-toc-entries numbered-sections)))
		; re-apply the main-ss.
		; Now the body contain the TOC entries and the
		; numbered sections. See Note [3] above
		(pre-post-order
		  `(body (ul ,toc) ,numbered-sections)
		  ; now process 'body' without an exception
		  ; an example of a dynamic "amending" a stylesheet
		  (append
		    `((body . ,(cdr (assq '*default* main-ss))))
		       main-ss)))
	      )))
     ; see Note [4]
     (*section *preorder*
       . ,(lambda (tag numbering title . elems)
	    (let ((header-tag
		    (list-ref '(h1 h2 h3 h4 h5 h6)
		      (length numbering))))
	      (pre-post-order
		`((,header-tag ,(numbers->string numbering) ". " ,title)
		  ,@ elems)
		main-ss))))
     ; see Note [5]
     (href
       ((*text* . ,(lambda (tag str)
		     (if (string? str)
		       ((make-char-quotator '((#\space . "%20"))) str) str))))
       . ,(lambda (attr-key . value) (enattr attr-key value)))
     ; see Note [1]
     ,@universal-conversion-rules))



; The main function
; The following expression executes the transformation of 'doc' into
; a target SXML tree: a tree of HTML fragments. The expression then
; writes out that tree on the standard output. You may want to save
; the result in a file and load the file in a web browser.

(SRV:send-reply (pre-post-order doc main-ss))

(library (sxml to-html)
  (export
   SXML->HTML
   string->goodHTML
   entag
   enattr)









   (import (except (scheme)
                  string-copy string-for-each string->list string-upcase
                  string-downcase string-titlecase string-hash string-copy! string-fill!
                  fold-right error filter)
          (prefix (only (scheme) error) scheme:)
          (srfi s13 strings)
	  (sxml tree-trans))

   (include "utils.ss")
   (include "SXML-to-HTML.scm"))

		

(library (sxml to-html)
  (export
   SXML->HTML
   string->goodHTML
   entag
   enattr
   universal-conversion-rules
   universal-protected-rules
   alist-conv-rules
   generic-web-rules
   signif-tail
   make-header
   make-navbar
   make-footer
   find-Header)
   (import (except (scheme)
                  string-copy string-for-each string->list string-upcase
                  string-downcase string-titlecase string-hash string-copy! string-fill!
                  fold-right error filter)
          (prefix (only (scheme) error) scheme:)
          (srfi s13 strings)
	  (sxml tree-trans)
	  (only (thunder-utils) string-split))
   (include "utils.ss")
   (include "SXML-to-HTML.scm")
   (include "SXML-to-HTML-ext.scm"))
		

(library (sxml tree-trans)
  (export
   SRV:send-reply
   pre-post-order
   post-order
   foldts
   replace-range)

(library (sxml tree-trans)
  (export
   SRV:send-reply
   pre-post-order
   post-order
   foldts
   replace-range)

		       (index-cset str (inc to) bad-chars)))
		  (if (< from to)
		      (cons
		       (substring str from to)
		       (cons quoted-char (loop (inc to) new-to)))
		      (cons quoted-char (loop (inc to) new-to))))))))))
))

		       (index-cset str (inc to) bad-chars)))
		  (if (< from to)
		      (cons
		       (substring str from to)
		       (cons quoted-char (loop (inc to) new-to)))
		      (cons quoted-char (loop (inc to) new-to))))))))))
))

;; from https://sourceforge.net/p/sisc/mailman/message/2909294/

(define-syntax lookup-def 
  (syntax-rules (warn:)
    ((lookup-def key alist)
     (let ((nkey key) (nalist alist)) ; evaluate them only once
       (let ((res (assq nkey nalist)))
	 (if res
	     (let ((res (cdr res)))
	       (cond
		((not (pair? res)) res)
		((null? (cdr res)) (car res))
		(else res)))
	     (error "Failed to find " nkey " in " nalist)))))
    ((lookup-def key alist default-exp)
     (let ((res (assq key alist)))
       (if res
	   (let ((res (cdr res)))
	     (cond
	      ((not (pair? res)) res)
	      ((null? (cdr res)) (car res))
	      (else res)))
	   default-exp)))
    ((lookup-def key alist warn: default-exp)
     (let ((nkey key) (nalist alist)) ; evaluate them only once
       (let ((res (assq nkey nalist)))
	 (if res
	     (let ((res (cdr res)))
	       (cond
		((not (pair? res)) res)
		((null? (cdr res)) (car res))
		(else res)))
	     (begin
	       (cerr "Failed to find " nkey " in " nalist #\newline)
	       default-exp)))))
    ))

(define OS:file-length (lambda (path) (call-with-input-file path (lambda (p) (file-length p)))))

(define string->integer
  (case-lambda
    [(str)
     (string->number str)]
    [(str start end)
     (string->number (substring str start end))]))

;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;; See the License for the specific language governing permissions and
;; limitations under the License.

#!chezscheme
(library (usb)
 (export 
  usb-device-descriptor

  usb-device
  usb-device-handle


  usb-init
  usb-exit
  usb-get-device-list
  usb-get-device-descriptor






  usb-find-vid-pid
  usb-display-device-list
  usb-strerror
  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*))
 (define-ftype usb-device*** (* usb-device*-array))
 (define-ftype usb-device-handle* void*)
 (define-ftype usb-device-handle** (* usb-device-handle*))

 (define-ftype usb-device-descriptor 
   (struct 
       [length unsigned-8]
       [type unsigned-8]
       [USB unsigned-16]
       [class unsigned-8]
       [subclass unsigned-8]
       [protocol unsigned-8]
................................................................................
 (define (usb-device-handle-addr dev)
   (ftype-pointer-address (usb-device-handle-ptr dev)))

 (define (usb-free-garbage)
   (let loop ([p (usb-guardian)])
     (when p
       (when (ftype-pointer? p)
	 (printf "freeing memory at ~x\n" p)
	 (cond [(ftype-pointer? usb-device*-array p)
		; FIXME THIS HANGS IF ENABLED
		#;((foreign-procedure "libusb_free_device_list" (void* int) void)
		 (ftype-pointer-address p) 0)]
	       [(ftype-pointer? usb-device* p)
		((foreign-procedure "libusb_unref_device" (void*) void) 
		 (ftype-pointer-address p))]
	       [else
		(foreign-free (ftype-pointer-address p))]))
       (loop (usb-guardian)))))
   
 (define (usb-get-device-list)
   (usb-free-garbage)
   (let* ([ptr (make-ftype-pointer usb-device*** (foreign-alloc (ftype-sizeof usb-device***)))]
	  [f (foreign-procedure "libusb_get_device_list" (void* void*) int)]
	  [%g (usb-guardian ptr)]
	  [e (f 0 (ftype-pointer-address ptr))])
     (if (< e 0)
	 (error 'usb-get-device-list "error" e))
     (let ((devices (ftype-&ref usb-device*** (*) ptr)))
       (usb-guardian devices)
       (let loop ((i 0) (l '()))
	 (if (>= i e) l
	     (loop (fx+ i 1) 
		   (cons (make-usb-device 
			  (make-ftype-pointer 
			   usb-device* 
			   (ftype-ref usb-device*-array (i) devices))) l)))))))

 (define (usb-get-device-descriptor dev)
   (usb-free-garbage)
   (let* ([ptr (make-ftype-pointer usb-device-descriptor 
				   (foreign-alloc (ftype-sizeof usb-device-descriptor)))]
	  [%g (usb-guardian ptr)]
	  [f (foreign-procedure "libusb_get_device_descriptor" (void* void*) int)]
	  [e (f (usb-device-addr dev) (ftype-pointer-address ptr))])
     (if (< e 0)
	 (error 'usb-get-device-descriptor "error" e)
	 ptr)))













 (define (usb-init) 
   (let ([e ((foreign-procedure "libusb_init" (void*) int) 0)])
     (when (< e 0)
       (error 'usb-init "error" e))
     #t))

 (define (usb-exit) 
................................................................................
	     (usb-log-level-index level))])
     (when (< e 0)
       (error 'usb-exit "error" e))
     (void)))

 (define (usb-strerror code)
    ((foreign-procedure "libusb_strerror" (int) string) code))

 (define (usb-find-vid-pid vid pid) 
   (call/cc 
    (lambda (k)
      (for-each 
       (lambda (dev)
	 (let ([descriptor (usb-get-device-descriptor dev)])
	   (if (and (equal? (ftype-ref usb-device-descriptor (vendor) descriptor) vid)
		    (equal? (ftype-ref usb-device-descriptor (product) descriptor) pid))
	       (k dev))))
       (usb-get-device-list))
      #f)))

 (define (usb-display-device-list)
   (pretty-print 
    (map
     (lambda (dev) 
       (ftype-pointer->sexpr (usb-get-device-descriptor dev)))
     (usb-get-device-list))))
















 (define (usb-open device)
   (assert (and 'usb-open (usb-device? device)))
   (usb-free-garbage)
   (let* ([ptr (make-ftype-pointer usb-device-handle** 
				   (foreign-alloc (ftype-sizeof usb-device-handle*)))]
	  [%g (usb-guardian ptr)]
	  [f (foreign-procedure "libusb_open" (void* void*) int)]
	  [e (f (usb-device-addr device) (ftype-pointer-address ptr))])
     (if (< e 0)
	 (error 'usb-open (usb-strerror e) e))
     (make-usb-device-handle (ftype-&ref usb-device-handle** (*) ptr))))
 
 (define-ftype int* (* int))























 (define (alloc-int*) 
   (let ([ptr (make-ftype-pointer int* (foreign-alloc (ftype-sizeof int*)))])
     (usb-guardian ptr)
     ptr))
 
 (define (usb-control-transfer handle type request value index data timeout)
   (assert (and 'usb-control-transfer (usb-device-handle? handle)))
   (assert (and 'usb-control-transfer (number? type)))
   (assert (and 'usb-control-transfer (number? request)))
................................................................................
				       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

;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;; See the License for the specific language governing permissions and
;; limitations under the License.

#!chezscheme
(library (usb)
 (export 
  c-usb-device-descriptor
  c-usb-device
  usb-device
  usb-device-handle
  usb-device?

  usb-init
  usb-exit
  usb-get-device-list
  usb-get-device-descriptor
  
  usb-get-port-number
  usb-get-port-numbers
  usb-get-bus-number
  usb-get-device
  
  usb-find-vid-pid
  usb-display-device-list
  usb-strerror
  usb-open
  usb-close
  usb-claim-interface
  usb-release-interface
  
  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 c-usb-device (struct))
 (define-ftype c-usb-device*-array (array 0 (* c-usb-device)))
 (define-ftype c-usb-device*** (* c-usb-device*-array))
 (define-ftype usb-device-handle* void*)
 (define-ftype usb-device-handle** (* usb-device-handle*))

 (define-ftype c-usb-device-descriptor 
   (struct 
       [length unsigned-8]
       [type unsigned-8]
       [USB unsigned-16]
       [class unsigned-8]
       [subclass unsigned-8]
       [protocol unsigned-8]
................................................................................
 (define (usb-device-handle-addr dev)
   (ftype-pointer-address (usb-device-handle-ptr dev)))

 (define (usb-free-garbage)
   (let loop ([p (usb-guardian)])
     (when p
       (when (ftype-pointer? p)
	 ;(printf "freeing memory at ~x\n" p)
	 (cond [(ftype-pointer? c-usb-device*-array p)
		; FIXME THIS HANGS IF ENABLED
		#;((foreign-procedure "libusb_free_device_list" (void* int) void)
		 (ftype-pointer-address p) 0)]
	       [(ftype-pointer? c-usb-device p)
		((foreign-procedure "libusb_unref_device" ((* c-usb-device)) void) p)]

	       [else
		(foreign-free (ftype-pointer-address p))]))
       (loop (usb-guardian)))))
   
 (define (usb-get-device-list)
   (usb-free-garbage)
   (let* ([ptr (make-ftype-pointer c-usb-device*** (foreign-alloc (ftype-sizeof c-usb-device***)))]
	  [f (foreign-procedure "libusb_get_device_list" (void* void*) int)]
	  [%g (usb-guardian ptr)]
	  [e (f 0 (ftype-pointer-address ptr))])
     (if (< e 0)
	 (error 'usb-get-device-list "error" e))
     (let ((devices (ftype-&ref c-usb-device*** (*) ptr)))
       (usb-guardian devices)
       (let loop ((i 0) (l '()))
	 (if (>= i e) l
	     (loop (fx+ i 1) 
		   (cons (make-usb-device


			   (ftype-ref c-usb-device*-array (i) devices)) l)))))))

 (define (usb-get-device-descriptor dev)
   (usb-free-garbage)
   (let* ([ptr (make-ftype-pointer c-usb-device-descriptor 
				   (foreign-alloc (ftype-sizeof c-usb-device-descriptor)))]
	  [%g (usb-guardian ptr)]
	  [f (foreign-procedure "libusb_get_device_descriptor" ((* c-usb-device) (* c-usb-device-descriptor)) int)]
	  [e (f (usb-device-ptr dev) ptr )])
     (if (< e 0)
	 (error 'usb-get-device-descriptor "error" e)
	 ptr)))

  (define (usb-ref-device dev)
   (let* ([f (foreign-procedure "libusb_ref_device" ((* c-usb-device) ) (* c-usb-device))]
	  [ptr (f dev)])
     ptr))

  ;;FIXME: this would cause problems if the device is freed?
  (define (usb-get-device dev)
   (usb-free-garbage)
   (let* ([f (foreign-procedure "libusb_get_device" (usb-device-handle*) (* c-usb-device))]
	  [ptr (f (usb-device-handle-addr dev) )])
     (make-usb-device (usb-ref-device ptr))))

 (define (usb-init) 
   (let ([e ((foreign-procedure "libusb_init" (void*) int) 0)])
     (when (< e 0)
       (error 'usb-init "error" e))
     #t))

 (define (usb-exit) 
................................................................................
	     (usb-log-level-index level))])
     (when (< e 0)
       (error 'usb-exit "error" e))
     (void)))

 (define (usb-strerror code)
    ((foreign-procedure "libusb_strerror" (int) string) code))
 
 (define (usb-find-vid-pid vid pid) 
   (filter 


    (lambda (dev)
      (let ([descriptor (usb-get-device-descriptor dev)])
	(and (equal? (ftype-ref c-usb-device-descriptor (vendor) descriptor) vid)
	     (equal? (ftype-ref c-usb-device-descriptor (product) descriptor) pid))))

    (usb-get-device-list)))


 (define (usb-display-device-list)
   (pretty-print 
    (map
     (lambda (dev) 
       (ftype-pointer->sexpr (usb-get-device-descriptor dev)))
     (usb-get-device-list))))

 (define (usb-get-port-number dev)
   ((foreign-procedure "libusb_get_port_number" (void*) unsigned-8) (usb-device-addr dev)))
 
 (define (usb-get-port-numbers dev)
   (let* ([l (make-bytevector 10)]
	  [p (foreign-procedure "libusb_get_port_numbers" (void* u8* int)
				unsigned-8)]
	  [e (p (usb-device-addr dev) l (bytevector-length l))])
       (when (< e 0)
	 (error 'usb-open (usb-strerror e) e))
       (list-head (bytevector->u8-list l) e)))

 (define (usb-get-bus-number dev)
    ((foreign-procedure "libusb_get_bus_number" (void*) unsigned-8) (usb-device-addr dev)))

 (define (usb-open device)
   (assert (and 'usb-open (usb-device? device)))
   (usb-free-garbage)
   (let* ([ptr (make-ftype-pointer usb-device-handle** 
				   (foreign-alloc (ftype-sizeof usb-device-handle*)))]
	  [%g (usb-guardian ptr)]
	  [f (foreign-procedure "libusb_open" ((* c-usb-device) void*) int)]
	  [e (f (usb-device-ptr device) (ftype-pointer-address ptr))])
     (when (< e 0)
	 (error 'usb-open (usb-strerror e) e))
     (make-usb-device-handle (ftype-&ref usb-device-handle** (*) ptr))))

  (define (usb-close device)
   (assert (and 'usb-close (usb-device-handle? device)))
   (usb-free-garbage)
   (let* ([f (foreign-procedure "libusb_close" (void*) int)]
	  [e (f (usb-device-handle-addr device))])
     (when (< e 0)
       (error 'usb-open (usb-strerror e) e))))

 (define (usb-claim-interface h interface-number)
   (assert (and 'usb-claim-interface (usb-device-handle? h)))
   (usb-free-garbage)
   (let* ([f (foreign-procedure "libusb_claim_interface" (void* int) int)]
	  [e (f (ftype-pointer-address (usb-device-handle-ptr h)) interface-number)])
     (when (< e 0)
       (error 'usb-claim-interface (usb-strerror e) e))))

 (define (usb-release-interface h interface-number)
   (assert (and 'usb-release-interface (usb-device-handle? h)))
   (usb-free-garbage)
   (let* ([f (foreign-procedure "libusb_release_interface" (void* int) int)]
	  [e (f (ftype-pointer-address (usb-device-handle-ptr h)) interface-number)])
     (when (< e 0)
       (error 'usb-release-interface (usb-strerror e) e))))
     
 (define (alloc-int) 
   (let ([ptr (make-ftype-pointer int (foreign-alloc (ftype-sizeof int)))])
     (usb-guardian ptr)
     ptr))
 
 (define (usb-control-transfer handle type request value index data timeout)
   (assert (and 'usb-control-transfer (usb-device-handle? handle)))
   (assert (and 'usb-control-transfer (number? type)))
   (assert (and 'usb-control-transfer (number? request)))
................................................................................
				       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-*-write (usb-device-handle? handle)))
   (assert (and 'usb-*-write (number? endpoint)))
   (assert (and 'usb-*-write (bytevector? data)))
   (assert (and 'usb-*-write (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)])
     (when (< e 0)

       (error 'usb-*-write (usb-strerror e) e))
     ;;(ftype-pointer-address (ftype-ref int* () ptr))
     (void)))
 
 (import (only (thunder-utils) sub-bytevector))
 
 (define (usb-*-read handle endpoint len timeout func)
   (assert (and 'usb-*-read (usb-device-handle? handle)))
   (assert (and 'usb-*-read (number? endpoint)))
   (assert (and 'usb-*-read (number? len)))
   (assert (and 'usb-*-read (number? timeout)))
   (usb-free-garbage)
   (let* ([ptr (alloc-int)]
	  [data (make-bytevector len)]
	  [data% (usb-guardian data)]
	  [e (func (usb-device-handle-addr handle) endpoint
		   data len 
		   (ftype-pointer-address ptr) timeout)])
     (if (< e 0)
	 (error 'usb-*-read (usb-strerror e) e))
     (let ([read-len (ftype-ref int () ptr)])
       (sub-bytevector data 0 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