Check-in [97a1a5b4fb]
Not logged in
Home Timeline Files Branches Tags Tickets Wiki Login

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

Overview
Comment:some fixes to usb.sls guardians
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 97a1a5b4fb091aeb8a6cba10d62ad2b5a6cc65ab
User & Date: ovenpasta@pizzahack.eu 2016-07-08 18:14:49
Context
2016-07-08
18:31
now load-shared-object is automatic check-in: 8f143abc67 user: ovenpasta@pizzahack.eu tags: trunk
18:14
some fixes to usb.sls guardians check-in: 97a1a5b4fb user: ovenpasta@pizzahack.eu tags: trunk
17:14
added more funcs to usb.sls check-in: 35917dddc4 user: ovenpasta@pizzahack.eu tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to usb.sls. 

1
2
3
4
5
6
7
8
9
10
11
..
47
48
49
50
51
52
53
54
55
56
57
58
59






60
61
62
63
64
65
66
67
68
69
70
71
72








73
74
75
76
77
78
79
80
81
82
83
84

85
86
87



88
89
90
91
92
93
94
95
...
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
...
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172

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

  usb-init
  usb-exit
................................................................................
       [device unsigned-16]
       [manufacturer unsigned-8]
       [product-index unsigned-8]
       [serial-number-index unsigned-8]
       [num-configurations unsigned-8]
     ))

 (define-record-type usb-device
   (fields
    (mutable ptr)))
 (define-record-type usb-device-handle
   (fields
    (mutable ptr)))







 (define (usb-device-addr dev)
   (ftype-pointer-address (usb-device-ptr dev)))

 (define (usb-device-handle-addr dev)
   (ftype-pointer-address (usb-device-handle-ptr dev)))

 (define usb-guardian (make-guardian))
 (define (usb-free-garbage)
   (let loop ([p (usb-guardian)])
     (when p
       (when (ftype-pointer? p)
	 ;(printf "freeing memory at ~x\n" p)








	 (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)))

       (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)]
................................................................................
     #t))

 (define usb-log-level-enum (make-enumeration '(none error warning info debug)))
 (define usb-log-level-index (enum-set-indexer usb-log-level-enum))
 (define (usb-log-level-ref index)
   (list-ref (enum-set->list usb-log-level-enum) index))

 (define (usb-set-debug ctx level) 
   (let ([e ((foreign-procedure "libusb_set_debug" (void* int) int) 
	     0 
	     (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))
................................................................................
	  [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*) 
   (define 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)))
   (assert (and 'usb-control-transfer (number? value)))
   (assert (and 'usb-control-transfer (number? index)))


|
<







 







|





>
>
>
>
>
>







<




|
>
>
>
>
>
>
>
>
|











>



>
>
>
|







 







|

|







 







|
|
|








1
2
3

4
5
6
7
8
9
10
..
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71

72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
...
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
...
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188

#!chezscheme
(library (usb)

 (export 
  usb-device-descriptor
  usb-device
  usb-device-handle

  usb-init
  usb-exit
................................................................................
       [device unsigned-16]
       [manufacturer unsigned-8]
       [product-index unsigned-8]
       [serial-number-index unsigned-8]
       [num-configurations unsigned-8]
     ))

 (define-record-type (usb-device make-usb-device% usb-device?)
   (fields
    (mutable ptr)))
 (define-record-type usb-device-handle
   (fields
    (mutable ptr)))

 (define usb-guardian (make-guardian))

 (define (make-usb-device ptr)
   (usb-guardian ptr)
   (make-usb-device% ptr))

 (define (usb-device-addr dev)
   (ftype-pointer-address (usb-device-ptr dev)))

 (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)]
................................................................................
     #t))

 (define usb-log-level-enum (make-enumeration '(none error warning info debug)))
 (define usb-log-level-index (enum-set-indexer usb-log-level-enum))
 (define (usb-log-level-ref index)
   (list-ref (enum-set->list usb-log-level-enum) index))

 (define (usb-set-debug level) 
   (let ([e ((foreign-procedure "libusb_set_debug" (void* int) int) 
	     0 ; FIXME: ctx NULL, allow multiple contexts?
	     (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))
................................................................................
	  [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)))
   (assert (and 'usb-control-transfer (number? value)))
   (assert (and 'usb-control-transfer (number? index)))

Fossil 2.9 [0fd79a3e09] 2019-07-13 13:05:19