Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Changes to usb.sls.

     1      1   
     2      2   #!chezscheme
     3         -(library 
     4         - (usb)
            3  +(library (usb)
     5      4    (export 
     6      5     usb-device-descriptor
     7      6     usb-device
     8      7     usb-device-handle
     9      8   
    10      9     usb-init
    11     10     usb-exit
................................................................................
    47     46          [device unsigned-16]
    48     47          [manufacturer unsigned-8]
    49     48          [product-index unsigned-8]
    50     49          [serial-number-index unsigned-8]
    51     50          [num-configurations unsigned-8]
    52     51        ))
    53     52   
    54         - (define-record-type usb-device
           53  + (define-record-type (usb-device make-usb-device% usb-device?)
    55     54      (fields
    56     55       (mutable ptr)))
    57     56    (define-record-type usb-device-handle
    58     57      (fields
    59     58       (mutable ptr)))
           59  +
           60  + (define usb-guardian (make-guardian))
           61  +
           62  + (define (make-usb-device ptr)
           63  +   (usb-guardian ptr)
           64  +   (make-usb-device% ptr))
    60     65   
    61     66    (define (usb-device-addr dev)
    62     67      (ftype-pointer-address (usb-device-ptr dev)))
    63     68   
    64     69    (define (usb-device-handle-addr dev)
    65     70      (ftype-pointer-address (usb-device-handle-ptr dev)))
    66     71   
    67         - (define usb-guardian (make-guardian))
    68     72    (define (usb-free-garbage)
    69     73      (let loop ([p (usb-guardian)])
    70     74        (when p
    71     75          (when (ftype-pointer? p)
    72         -	 ;(printf "freeing memory at ~x\n" p)
    73         -	 (foreign-free (ftype-pointer-address p)))
           76  +	 (printf "freeing memory at ~x\n" p)
           77  +	 (cond [(ftype-pointer? usb-device*-array p)
           78  +		; FIXME THIS HANGS IF ENABLED
           79  +		#;((foreign-procedure "libusb_free_device_list" (void* int) void)
           80  +		 (ftype-pointer-address p) 0)]
           81  +	       [(ftype-pointer? usb-device* p)
           82  +		((foreign-procedure "libusb_unref_device" (void*) void) 
           83  +		 (ftype-pointer-address p))]
           84  +	       [else
           85  +		(foreign-free (ftype-pointer-address p))]))
    74     86          (loop (usb-guardian)))))
    75     87      
    76     88    (define (usb-get-device-list)
    77     89      (usb-free-garbage)
    78     90      (let* ([ptr (make-ftype-pointer usb-device*** (foreign-alloc (ftype-sizeof usb-device***)))]
    79     91   	  [f (foreign-procedure "libusb_get_device_list" (void* void*) int)]
    80     92   	  [%g (usb-guardian ptr)]
    81     93   	  [e (f 0 (ftype-pointer-address ptr))])
    82     94        (if (< e 0)
    83     95   	 (error 'usb-get-device-list "error" e))
    84     96        (let ((devices (ftype-&ref usb-device*** (*) ptr)))
           97  +       (usb-guardian devices)
    85     98          (let loop ((i 0) (l '()))
    86     99   	 (if (>= i e) l
    87    100   	     (loop (fx+ i 1) 
    88         -		   (cons (make-usb-device (make-ftype-pointer usb-device* (ftype-ref usb-device*-array (i) devices))) l)))))))
          101  +		   (cons (make-usb-device 
          102  +			  (make-ftype-pointer 
          103  +			   usb-device* 
          104  +			   (ftype-ref usb-device*-array (i) devices))) l)))))))
    89    105   
    90    106    (define (usb-get-device-descriptor dev)
    91    107      (usb-free-garbage)
    92    108      (let* ([ptr (make-ftype-pointer usb-device-descriptor 
    93    109   				   (foreign-alloc (ftype-sizeof usb-device-descriptor)))]
    94    110   	  [%g (usb-guardian ptr)]
    95    111   	  [f (foreign-procedure "libusb_get_device_descriptor" (void* void*) int)]
................................................................................
   112    128        #t))
   113    129   
   114    130    (define usb-log-level-enum (make-enumeration '(none error warning info debug)))
   115    131    (define usb-log-level-index (enum-set-indexer usb-log-level-enum))
   116    132    (define (usb-log-level-ref index)
   117    133      (list-ref (enum-set->list usb-log-level-enum) index))
   118    134   
   119         - (define (usb-set-debug ctx level) 
          135  + (define (usb-set-debug level) 
   120    136      (let ([e ((foreign-procedure "libusb_set_debug" (void* int) int) 
   121         -	     0 
          137  +	     0 ; FIXME: ctx NULL, allow multiple contexts?
   122    138   	     (usb-log-level-index level))])
   123    139        (when (< e 0)
   124    140          (error 'usb-exit "error" e))
   125    141        (void)))
   126    142   
   127    143    (define (usb-strerror code)
   128    144       ((foreign-procedure "libusb_strerror" (int) string) code))
................................................................................
   156    172   	  [e (f (usb-device-addr device) (ftype-pointer-address ptr))])
   157    173        (if (< e 0)
   158    174   	 (error 'usb-open (usb-strerror e) e))
   159    175        (make-usb-device-handle (ftype-&ref usb-device-handle** (*) ptr))))
   160    176    
   161    177    (define-ftype int* (* int))
   162    178    (define (alloc-int*) 
   163         -   (define ptr (make-ftype-pointer int* (foreign-alloc (ftype-sizeof int*))))
   164         -   (usb-guardian ptr)
   165         -   ptr)
          179  +   (let ([ptr (make-ftype-pointer int* (foreign-alloc (ftype-sizeof int*)))])
          180  +     (usb-guardian ptr)
          181  +     ptr))
   166    182    
   167    183    (define (usb-control-transfer handle type request value index data timeout)
   168    184      (assert (and 'usb-control-transfer (usb-device-handle? handle)))
   169    185      (assert (and 'usb-control-transfer (number? type)))
   170    186      (assert (and 'usb-control-transfer (number? request)))
   171    187      (assert (and 'usb-control-transfer (number? value)))
   172    188      (assert (and 'usb-control-transfer (number? index)))