artulab.com Git - guile-gdal/blob - gdal/internal.scm

   1 (define-module (gdal internal)
   2   #:use-module (system foreign)
   3   #:use-module (rnrs bytevectors)
   4   #:use-module (gdal config)
   5   #:use-module (ice-9 q)
   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))
  18
  19 ;;------------------------------------------------------------------------------
  20
  21 ;;; Enums
  22
  23 ;;------------------------------------------------------------------------------
  24
  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)
  39
  40 ;;------------------------------------------------------------------------------
  41
  42 ;;; Object properties
  43
  44 ;;------------------------------------------------------------------------------
  45
  46 ;;; Buffer properties
  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))
  56
  57 ;;------------------------------------------------------------------------------
  58
  59 ;;; Internal definitions
  60
  61 ;;------------------------------------------------------------------------------
  62
  63 (define gdal-func
  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*)
  68                           arg-types)
  69       (lambda* (#:rest r) (throw 'unsupported)))))
  70
  71 (define-syntax-rule (define-gdal-foreign
  72                       name return-type func-name arg-types gdal-version)
  73   (define name
  74     (gdal-func return-type func-name arg-types gdal-version)))
  75
  76 (define (data-type-valid? data-type)
  77   (and (< GDT_UNKNOWN data-type) (> GDT_TYPECOUNT data-type)))
  78
  79 (define (boolean->c-bool b)
  80   "Convert the boolean to a c boolean."
  81   (if b 1 0))
  82
  83 (define (c-bool->boolean b)
  84   "Convert the c boolean to boolean."
  85   (if (zero? b) #f #t))
  86
  87 (define bytevector-pointer-ref
  88   (case (sizeof '*)
  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?"))))
  94
  95 (define bytevector-pointer-set!
  96   (case (sizeof '*)
  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?"))))
 102
 103 (define (list->pointerpointer lst item->pointer)
 104   (if (null? lst)
 105     %null-pointer
 106     (let* ((size (length lst))
 107            (ptr (make-bytevector (*  (1+ size) (sizeof '*)))))
 108       (do ((i 0 (1+ i)))
 109         ((>= i size))
 110         (bytevector-pointer-set! ptr
 111                                  (* i (sizeof '*))
 112                                  (item->pointer (list-ref lst i))))
 113       (bytevector-pointer-set! ptr (* size (sizeof '*)) %null-pointer)
 114       (bytevector->pointer ptr))))
 115
 116 (define* (pointerpointer->list pointer pointer->item
 117                                #:optional (count -1))
 118   (let ((q (make-q)))
 119     (unless (null-pointer? pointer)
 120       (let lp ((sp (dereference-pointer pointer))
 121               (index 1))
 122         (unless (or (= count (q-length q)) (null-pointer? sp))
 123           (enq! q (pointer->item sp))
 124           (lp (dereference-pointer
 125                (make-pointer
 126                 (+ (pointer-address pointer) (* index (sizeof '*)))))
 127               (1+ index)))))
 128     (car q)))
 129
 130 (define (struct-list->pointer lst struct-size struct->pointer)
 131   (let* ((size (length lst))
 132          (bv (make-bytevector (* size struct-size))))
 133     (do ((i 0 (1+ i)))
 134       ((>= i 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)))
 141
 142 (define (pointer->struct-list pointer count struct-size pointer->struct)
 143   (let loop ((q (make-q))
 144              (index 0)
 145              (pointer pointer))
 146     (if (= index count)
 147       (car q)
 148       (begin
 149        (enq! q (pointer->struct pointer))
 150        (loop q (1+ index) (make-pointer (+ (pointer-address pointer)
 151                                            struct-size)))))))
 152
 153 (define (pointerpointer->string-list string-list-p)
 154   (pointerpointer->list string-list-p pointer->string))
 155
 156 (define (string-list->pointerpointer lst)
 157   (list->pointerpointer lst string->pointer))
 158
 159 (define *writers*
 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!)))
 171
 172 (define *readers*
 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)))
 184
 185 (define (list->pointer lst type)
 186   (cond
 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)))))
 191
 192             (do ((i 0 (1+ i)))
 193               ((>= i size))
 194               ((assv-ref *writers* type) bv
 195                                          (* i (sizeof type))
 196                                          (list-ref lst i)))
 197             (bytevector->pointer bv)))))
 198
 199 (define (pointer->list pointer count type)
 200   (let loop ((q (make-q))
 201              (index 0)
 202              (pointer pointer))
 203     (if (= index count)
 204       (car q)
 205       (begin
 206        (enq! q ((assv-ref *readers* type)
 207                 (pointer->bytevector pointer (sizeof type)) 0))
 208        (loop q (1+ index) (make-pointer (+ (pointer-address pointer)
 209                                            (sizeof type))))))))