1 (define-module (gdal internal)
2 #:use-module (system foreign)
3 #:use-module (rnrs bytevectors)
4 #:use-module (gdal config)
6 #:export (define-gdal-foreign)
7 #:export (data-type-valid?)
8 #:export (boolean->c-bool)
9 #:export (c-bool->boolean)
10 #:export (list->pointerpointer)
11 #:export (list->pointer)
12 #:export (pointer->list)
13 #:export (pointerpointer->list)
14 #:export (pointerpointer->string-list)
15 #:export (string-list->pointerpointer)
16 #:export (struct-list->pointer)
17 #:export (pointer->struct-list))
19 ;;------------------------------------------------------------------------------
23 ;;------------------------------------------------------------------------------
25 ;;; GDALDataType enums
26 (define-public GDT_UNKNOWN 0)
27 (define-public GDT_BYTE 1)
28 (define-public GDT_UINT16 2)
29 (define-public GDT_INT16 3)
30 (define-public GDT_UINT32 4)
31 (define-public GDT_INT32 5)
32 (define-public GDT_FLOAT32 6)
33 (define-public GDT_FLOAT64 7)
34 (define-public GDT_CINT16 8)
35 (define-public GDT_CINT32 9)
36 (define-public GDT_CFLOAT32 10)
37 (define-public GDT_CFLOAT64 11)
38 (define-public GDT_TYPECOUNT 12)
40 ;;------------------------------------------------------------------------------
44 ;;------------------------------------------------------------------------------
47 (define-public %gdal-h-band% (make-object-property))
48 (define-public %gdal-type% (make-object-property))
49 (define-public %gdal-x-off% (make-object-property))
50 (define-public %gdal-y-off% (make-object-property))
51 (define-public %gdal-x-size% (make-object-property))
52 (define-public %gdal-y-size% (make-object-property))
53 (define-public %gdal-pixel-off% (make-object-property))
54 (define-public %gdal-line-off% (make-object-property))
55 (define-public %is-stream% (make-object-property))
57 ;;------------------------------------------------------------------------------
59 ;;; Internal definitions
61 ;;------------------------------------------------------------------------------
64 (lambda* (return-type function-name arg-types gdal-version)
65 (if (>= *gdal-version* gdal-version)
66 (pointer->procedure return-type
67 (dynamic-func function-name *libgdal*)
69 (lambda* (#:rest r) (throw 'unsupported)))))
71 (define-syntax-rule (define-gdal-foreign
72 name return-type func-name arg-types gdal-version)
74 (gdal-func return-type func-name arg-types gdal-version)))
76 (define (data-type-valid? data-type)
77 (and (< GDT_UNKNOWN data-type) (> GDT_TYPECOUNT data-type)))
79 (define (boolean->c-bool b)
80 "Convert the boolean to a c boolean."
83 (define (c-bool->boolean b)
84 "Convert the c boolean to boolean."
87 (define bytevector-pointer-ref
89 ((8) (lambda (bv offset)
90 (make-pointer (bytevector-u64-native-ref bv offset))))
91 ((4) (lambda (bv offset)
92 (make-pointer (bytevector-u32-native-ref bv offset))))
93 (else (error "what machine is this?"))))
95 (define bytevector-pointer-set!
97 ((8) (lambda (bv offset ptr)
98 (bytevector-u64-native-set! bv offset (pointer-address ptr))))
99 ((4) (lambda (bv offset ptr)
100 (bytevector-u32-native-set! bv offset (pointer-address ptr))))
101 (else (error "what machine is this?"))))
103 (define (list->pointerpointer lst item->pointer)
106 (let* ((size (length lst))
107 (ptr (make-bytevector (* (1+ size) (sizeof '*)))))
110 (bytevector-pointer-set! ptr
112 (item->pointer (list-ref lst i))))
113 (bytevector-pointer-set! ptr (* size (sizeof '*)) %null-pointer)
114 (bytevector->pointer ptr))))
116 (define* (pointerpointer->list pointer pointer->item
117 #:optional (count -1))
119 (unless (null-pointer? pointer)
120 (let lp ((sp (dereference-pointer pointer))
122 (unless (or (= count (q-length q)) (null-pointer? sp))
123 (enq! q (pointer->item sp))
124 (lp (dereference-pointer
126 (+ (pointer-address pointer) (* index (sizeof '*)))))
130 (define (struct-list->pointer lst struct-size struct->pointer)
131 (let* ((size (length lst))
132 (bv (make-bytevector (* size struct-size))))
135 (let ((index (* i struct-size))
136 (item (list-ref lst i)))
137 (bytevector-copy! (pointer->bytevector
138 (struct->pointer item) struct-size)
139 0 bv index struct-size)))
140 (bytevector->pointer bv)))
142 (define (pointer->struct-list pointer count struct-size pointer->struct)
143 (let loop ((q (make-q))
149 (enq! q (pointer->struct pointer))
150 (loop q (1+ index) (make-pointer (+ (pointer-address pointer)
153 (define (pointerpointer->string-list string-list-p)
154 (pointerpointer->list string-list-p pointer->string))
156 (define (string-list->pointerpointer lst)
157 (list->pointerpointer lst string->pointer))
160 `((,float . ,bytevector-ieee-single-native-set!)
161 (,double . ,bytevector-ieee-double-native-set!)
162 (,int8 . ,bytevector-s8-set!)
163 (,uint8 . ,bytevector-u8-set!)
164 (,int16 . ,bytevector-s16-native-set!)
165 (,uint16 . ,bytevector-u16-native-set!)
166 (,int32 . ,bytevector-s32-native-set!)
167 (,uint32 . ,bytevector-u32-native-set!)
168 (,int64 . ,bytevector-s64-native-set!)
169 (,uint64 . ,bytevector-u64-native-set!)
170 (,'* . ,bytevector-pointer-set!)))
173 `((,float . ,bytevector-ieee-single-native-ref)
174 (,double . ,bytevector-ieee-double-native-ref)
175 (,int8 . ,bytevector-s8-ref)
176 (,uint8 . ,bytevector-u8-ref)
177 (,int16 . ,bytevector-s16-native-ref)
178 (,uint16 . ,bytevector-u16-native-ref)
179 (,int32 . ,bytevector-s32-native-ref)
180 (,uint32 . ,bytevector-u32-native-ref)
181 (,int64 . ,bytevector-s64-native-ref)
182 (,uint64 . ,bytevector-u64-native-ref)
183 (,'* . ,bytevector-pointer-ref)))
185 (define (list->pointer lst type)
187 ((null? lst) %null-pointer)
188 ((not (pair? lst)) (error "input is not a pair"))
189 (else (let* ((size (length lst))
190 (bv (make-bytevector (* size (sizeof type)))))
194 ((assv-ref *writers* type) bv
197 (bytevector->pointer bv)))))
199 (define (pointer->list pointer count type)
200 (let loop ((q (make-q))
206 (enq! q ((assv-ref *readers* type)
207 (pointer->bytevector pointer (sizeof type)) 0))
208 (loop q (1+ index) (make-pointer (+ (pointer-address pointer)