module/system/foreign.scm

   1 ;;;;    Copyright (C) 2010, 2011, 2013 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   #:use-module (srfi srfi-9)
  23   #:use-module (srfi srfi-9 gnu)
  24   #:export (void
  25             float double
  26             short
  27             unsigned-short
  28             int unsigned-int long unsigned-long size_t ssize_t ptrdiff_t
  29             int8 uint8
  30             uint16 int16
  31             uint32 int32
  32             uint64 int64
  33
  34             sizeof alignof
  35
  36             %null-pointer
  37             null-pointer?
  38             pointer?
  39             make-pointer
  40             pointer->scm
  41             scm->pointer
  42             pointer-address
  43
  44             pointer->bytevector
  45             bytevector->pointer
  46             set-pointer-finalizer!
  47
  48             dereference-pointer
  49             string->pointer
  50             pointer->string
  51
  52             pointer->procedure
  53             ;; procedure->pointer (see below)
  54             make-c-struct parse-c-struct
  55
  56             define-wrapped-pointer-type))
  57
  58 (eval-when (load eval compile)
  59   (load-extension (string-append "libguile-" (effective-version))
  60                   "scm_init_foreign"))
  61
  62 \f
  63 ;;;
  64 ;;; Pointers.
  65 ;;;
  66
  67 (define (null-pointer? pointer)
  68   "Return true if POINTER is the null pointer."
  69   (= (pointer-address pointer) 0))
  70
  71 (if (defined? 'procedure->pointer)
  72     (export procedure->pointer))
  73
  74 \f
  75 ;;;
  76 ;;; Structures.
  77 ;;;
  78
  79 (define bytevector-pointer-ref
  80   (case (sizeof '*)
  81     ((8) (lambda (bv offset)
  82            (make-pointer (bytevector-u64-native-ref bv offset))))
  83     ((4) (lambda (bv offset)
  84            (make-pointer (bytevector-u32-native-ref bv offset))))
  85     (else (error "what machine is this?"))))
  86
  87 (define bytevector-pointer-set!
  88   (case (sizeof '*)
  89     ((8) (lambda (bv offset ptr)
  90            (bytevector-u64-native-set! bv offset (pointer-address ptr))))
  91     ((4) (lambda (bv offset ptr)
  92            (bytevector-u32-native-set! bv offset (pointer-address ptr))))
  93     (else (error "what machine is this?"))))
  94
  95 (define *writers*
  96   `((,float . ,bytevector-ieee-single-native-set!)
  97     (,double . ,bytevector-ieee-double-native-set!)
  98     (,int8 . ,bytevector-s8-set!)
  99     (,uint8 . ,bytevector-u8-set!)
 100     (,int16 . ,bytevector-s16-native-set!)
 101     (,uint16 . ,bytevector-u16-native-set!)
 102     (,int32 . ,bytevector-s32-native-set!)
 103     (,uint32 . ,bytevector-u32-native-set!)
 104     (,int64 . ,bytevector-s64-native-set!)
 105     (,uint64 . ,bytevector-u64-native-set!)
 106     (* . ,bytevector-pointer-set!)))
 107
 108 (define *readers*
 109   `((,float . ,bytevector-ieee-single-native-ref)
 110     (,double . ,bytevector-ieee-double-native-ref)
 111     (,int8 . ,bytevector-s8-ref)
 112     (,uint8 . ,bytevector-u8-ref)
 113     (,int16 . ,bytevector-s16-native-ref)
 114     (,uint16 . ,bytevector-u16-native-ref)
 115     (,int32 . ,bytevector-s32-native-ref)
 116     (,uint32 . ,bytevector-u32-native-ref)
 117     (,int64 . ,bytevector-s64-native-ref)
 118     (,uint64 . ,bytevector-u64-native-ref)
 119     (* . ,bytevector-pointer-ref)))
 120
 121
 122 (define (align off alignment)
 123   (1+ (logior (1- off) (1- alignment))))
 124
 125 (define (write-c-struct bv offset types vals)
 126   (let lp ((offset offset) (types types) (vals vals))
 127     (cond
 128      ((not (pair? types))
 129       (or (null? vals)
 130           (error "too many values" vals)))
 131      ((not (pair? vals))
 132       (error "too few values" types))
 133      (else
 134       ;; alignof will error-check
 135       (let* ((type (car types))
 136              (offset (align offset (alignof type))))
 137         (if (pair? type)
 138             (write-c-struct bv offset (car types) (car vals))
 139             ((assv-ref *writers* type) bv offset (car vals)))
 140         (lp (+ offset (sizeof type)) (cdr types) (cdr vals)))))))
 141
 142 (define (read-c-struct bv offset types)
 143   (let lp ((offset offset) (types types) (vals '()))
 144     (cond
 145      ((not (pair? types))
 146       (reverse vals))
 147      (else
 148       ;; alignof will error-check
 149       (let* ((type (car types))
 150              (offset (align offset (alignof type))))
 151         (lp (+ offset (sizeof type)) (cdr types)
 152             (cons (if (pair? type)
 153                       (read-c-struct bv offset (car types))
 154                       ((assv-ref *readers* type) bv offset))
 155                   vals)))))))
 156
 157 (define (make-c-struct types vals)
 158   (let ((bv (make-bytevector (sizeof types) 0)))
 159     (write-c-struct bv 0 types vals)
 160     (bytevector->pointer bv)))
 161
 162 (define (parse-c-struct foreign types)
 163   (let ((size (fold (lambda (type total)
 164                       (+ (sizeof type)
 165                          (align total (alignof type))))
 166                     0
 167                     types)))
 168     (read-c-struct (pointer->bytevector foreign size) 0 types)))
 169
 170 \f
 171 ;;;
 172 ;;; Wrapped pointer types.
 173 ;;;
 174
 175 (define-syntax define-wrapped-pointer-type
 176   (lambda (stx)
 177     "Define helper procedures to wrap pointer objects into Scheme
 178 objects with a disjoint type.  Specifically, this macro defines PRED, a
 179 predicate for the new Scheme type, WRAP, a procedure that takes a
 180 pointer object and returns an object that satisfies PRED, and UNWRAP
 181 which does the reverse.  PRINT must name a user-defined object printer."
 182     (syntax-case stx ()
 183       ((_ type-name pred wrap unwrap print)
 184        (with-syntax ((%wrap (datum->syntax #'wrap (gensym "wrap"))))
 185          #'(begin
 186              (define-record-type type-name
 187                (%wrap pointer)
 188                pred
 189                (pointer unwrap))
 190              (define wrap
 191                ;; Use a weak hash table to preserve pointer identity, i.e.,
 192                ;; PTR1 == PTR2 <-> (eq? (wrap PTR1) (wrap PTR2)).
 193                (let ((ptr->obj (make-weak-value-hash-table 3000)))
 194                  (lambda (ptr)
 195                    (or (hash-ref ptr->obj ptr)
 196                        (let ((o (%wrap ptr)))
 197                          (hash-set! ptr->obj ptr o)
 198                          o)))))
 199              (set-record-type-printer! type-name print)))))))