module/system/foreign.scm

   1 ;;;;    Copyright (C) 2010 Free Software Foundation, Inc.
   2 ;;;;
   3 ;;;; This library is free software; you can redistribute it and/or
   4 ;;;; modify it under the terms of the GNU Lesser General Public
   5 ;;;; License as published by the Free Software Foundation; either
   6 ;;;; version 2.1 of the License, or (at your option) any later version.
   7 ;;;;
   8 ;;;; This library is distributed in the hope that it will be useful,
   9 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11 ;;;; Lesser General Public License for more details.
  12 ;;;;
  13 ;;;; You should have received a copy of the GNU Lesser General Public
  14 ;;;; License along with this library; if not, write to the Free Software
  15 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  16 ;;;;
  17 \f
  18
  19 (define-module (system foreign)
  20   #:use-module (rnrs bytevectors)
  21   #:use-module (srfi srfi-1)
  22   #:export (void
  23             float double
  24             short
  25             unsigned-short
  26             int unsigned-int long unsigned-long size_t
  27             int8 uint8
  28             uint16 int16
  29             uint32 int32
  30             uint64 int64
  31
  32             sizeof alignof
  33
  34             %null-pointer
  35             null-pointer?
  36             make-pointer
  37             pointer-address
  38
  39             pointer->bytevector
  40             bytevector->pointer
  41             set-pointer-finalizer!
  42
  43             dereference-pointer
  44             string->pointer
  45             pointer->string
  46
  47             pointer->procedure
  48             ;; procedure->pointer (see below)
  49             make-c-struct parse-c-struct))
  50
  51 (eval-when (load eval compile)
  52   (load-extension (string-append "libguile-" (effective-version))
  53                   "scm_init_foreign"))
  54
  55 \f
  56 ;;;
  57 ;;; Pointers.
  58 ;;;
  59
  60 (define (null-pointer? pointer)
  61   "Return true if POINTER is the null pointer."
  62   (= (pointer-address pointer) 0))
  63
  64 (if (defined? 'procedure->pointer)
  65     (export procedure->pointer))
  66
  67 \f
  68 ;;;
  69 ;;; Structures.
  70 ;;;
  71
  72 (define-syntax compile-time-value
  73   (syntax-rules ()
  74     "Evaluate the given expression at compile time.  The expression must
  75 evaluate to a simple datum."
  76     ((_ exp)
  77      (let-syntax ((v (lambda (s)
  78                        (let ((val exp))
  79                          (syntax-case s ()
  80                            (_ (datum->syntax s val)))))))
  81        v))))
  82
  83 (eval-when (eval compile load)
  84   ;; The procedures below are used at compile time by the macros below.
  85
  86   (define (integer-ref type signed?)
  87     (case (sizeof type)
  88       ((8) (if signed?
  89                'bytevector-s64-native-ref
  90                'bytevector-u64-native-ref))
  91       ((4) (if signed?
  92                'bytevector-s32-native-ref
  93                'bytevector-u32-native-ref))
  94       ((2) (if signed?
  95                'bytevector-s16-native-ref
  96                'bytevector-u16-native-ref))
  97       (else
  98        (error "what machine is this?" type (sizeof type)))))
  99
 100   (define (integer-set type signed?)
 101     (case (sizeof type)
 102       ((8) (if signed?
 103                'bytevector-s64-native-set!
 104                'bytevector-u64-native-set!))
 105       ((4) (if signed?
 106                'bytevector-s32-native-set!
 107                'bytevector-u32-native-set!))
 108       ((2) (if signed?
 109                'bytevector-s16-native-set!
 110                'bytevector-u16-native-set!))
 111       (else
 112        (error "what machine is this?" type (sizeof type))))))
 113
 114 (define-syntax define-integer-reader
 115   (syntax-rules ()
 116     ((_ name type signed?)
 117      (letrec-syntax ((ref (identifier-syntax
 118                            (compile-time-value
 119                             (integer-ref type signed?)))))
 120        (define name ref)))))
 121
 122 (define-syntax define-integer-writer
 123   (syntax-rules ()
 124     ((_ name type signed?)
 125      (letrec-syntax ((set (identifier-syntax
 126                            (compile-time-value
 127                             (integer-set type signed?)))))
 128        (define name set)))))
 129
 130
 131 (define-integer-reader %read-short short #t)
 132 (define-integer-reader %read-int int #t)
 133 (define-integer-reader %read-long long #t)
 134 (define-integer-writer %write-short! short #t)
 135 (define-integer-writer %write-int! int #t)
 136 (define-integer-writer %write-long! long #t)
 137
 138 (define-integer-reader %read-unsigned-short unsigned-short #f)
 139 (define-integer-reader %read-unsigned-int unsigned-int #f)
 140 (define-integer-reader %read-unsigned-long unsigned-long #f)
 141 (define-integer-writer %write-unsigned-short! unsigned-short #f)
 142 (define-integer-writer %write-unsigned-int! unsigned-int #f)
 143 (define-integer-writer %write-unsigned-long! unsigned-long #f)
 144
 145 (define-integer-reader %read-size_t size_t #f)
 146 (define-integer-writer %write-size_t! size_t #f)
 147
 148 (define-integer-reader %read-pointer '* #f)
 149 (define-integer-writer %write-pointer! '* #f)
 150
 151
 152 (define *writers*
 153   `((,float . ,bytevector-ieee-single-native-set!)
 154     (,double . ,bytevector-ieee-double-native-set!)
 155     (,int8 . ,bytevector-s8-set!)
 156     (,uint8 . ,bytevector-u8-set!)
 157     (,int16 . ,bytevector-s16-native-set!)
 158     (,uint16 . ,bytevector-u16-native-set!)
 159     (,int32 . ,bytevector-s32-native-set!)
 160     (,uint32 . ,bytevector-u32-native-set!)
 161     (,int64 . ,bytevector-s64-native-set!)
 162     (,uint64 . ,bytevector-u64-native-set!)
 163
 164     (,short         . ,%write-short!)
 165     (,unsigned-short . ,%write-unsigned-short!)
 166     (,int           . ,%write-int!)
 167     (,unsigned-int  . ,%write-unsigned-int!)
 168     (,long          . ,%write-long!)
 169     (,unsigned-long . ,%write-unsigned-long!)
 170     (,size_t        . ,%write-size_t!)
 171
 172     (*              . ,(lambda (bv offset ptr)
 173                          (%write-pointer! bv offset
 174                                           (pointer-address ptr))))))
 175
 176 (define *readers*
 177   `((,float . ,bytevector-ieee-single-native-ref)
 178     (,double . ,bytevector-ieee-double-native-ref)
 179     (,int8 . ,bytevector-s8-ref)
 180     (,uint8 . ,bytevector-u8-ref)
 181     (,int16 . ,bytevector-s16-native-ref)
 182     (,uint16 . ,bytevector-u16-native-ref)
 183     (,int32 . ,bytevector-s32-native-ref)
 184     (,uint32 . ,bytevector-u32-native-ref)
 185     (,int64 . ,bytevector-s64-native-ref)
 186     (,uint64 . ,bytevector-u64-native-ref)
 187
 188     (,short         . ,%read-short)
 189     (,unsigned-short . ,%read-unsigned-short)
 190     (,int           . ,%read-int)
 191     (,unsigned-int  . ,%read-unsigned-int)
 192     (,long          . ,%read-long)
 193     (,unsigned-long . ,%read-unsigned-long)
 194     (,size_t        . ,%read-size_t)
 195
 196     (*              . ,(lambda (bv offset)
 197                          (make-pointer (%read-pointer bv offset))))))
 198
 199 (define (align off alignment)
 200   (1+ (logior (1- off) (1- alignment))))
 201
 202 (define (write-c-struct bv offset types vals)
 203   (let lp ((offset offset) (types types) (vals vals))
 204     (cond
 205      ((not (pair? types))
 206       (or (null? vals)
 207           (error "too many values" vals)))
 208      ((not (pair? vals))
 209       (error "too few values" types))
 210      (else
 211       ;; alignof will error-check
 212       (let* ((type (car types))
 213              (offset (align offset (alignof type))))
 214         (if (pair? type)
 215             (write-c-struct bv offset (car types) (car vals))
 216             ((assv-ref *writers* type) bv offset (car vals)))
 217         (lp (+ offset (sizeof type)) (cdr types) (cdr vals)))))))
 218
 219 (define (read-c-struct bv offset types)
 220   (let lp ((offset offset) (types types) (vals '()))
 221     (cond
 222      ((not (pair? types))
 223       (reverse vals))
 224      (else
 225       ;; alignof will error-check
 226       (let* ((type (car types))
 227              (offset (align offset (alignof type))))
 228         (lp (+ offset (sizeof type)) (cdr types)
 229             (cons (if (pair? type)
 230                       (read-c-struct bv offset (car types))
 231                       ((assv-ref *readers* type) bv offset))
 232                   vals)))))))
 233
 234 (define (make-c-struct types vals)
 235   (let ((bv (make-bytevector (sizeof types) 0)))
 236     (write-c-struct bv 0 types vals)
 237     (bytevector->pointer bv)))
 238
 239 (define (parse-c-struct foreign types)
 240   (let ((size (fold (lambda (type total)
 241                       (+ (sizeof type)
 242                          (align total (alignof type))))
 243                     0
 244                     types)))
 245     (read-c-struct (pointer->bytevector foreign size) 0 types)))