figl/runtime.scm

   1 ;;; figl
   2 ;;; Copyright (C) 2013 Andy Wingo <wingo@pobox.com>
   3 ;;;
   4 ;;; Figl is free software: you can redistribute it and/or modify it
   5 ;;; under the terms of the GNU Lesser General Public License as
   6 ;;; published by the Free Software Foundation, either version 3 of the
   7 ;;; License, or (at your option) any later version.
   8 ;;;
   9 ;;; Figl is distributed in the hope that it will be useful, but WITHOUT
  10 ;;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  11 ;;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General
  12 ;;; Public License for more details.
  13 ;;;
  14 ;;; You should have received a copy of the GNU Lesser General Public
  15 ;;; License along with this program.  If not, see
  16 ;;; <http://www.gnu.org/licenses/>.
  17
  18 ;;; Commentary:
  19 ;;
  20 ;; figl is the Foreign Interface to GL.
  21 ;;
  22 ;;; Code:
  23
  24 (define-module (figl runtime)
  25   #:use-module (system foreign)
  26   #:export (current-resolver
  27             define-foreign-procedure
  28             define-foreign-procedures
  29             define-foreign-type
  30             define-simple-foreign-type))
  31
  32 (define (default-resolver name)
  33   (dynamic-pointer name (dynamic-link)))
  34
  35 (define current-resolver
  36   (make-parameter default-resolver))
  37
  38 (define (resolve name)
  39   ((current-resolver) name))
  40
  41 (define-syntax foreign-trampoline
  42   (lambda (stx)
  43     (syntax-case stx (->)
  44       ((_ trampoline
  45           name (pname ptype) ... -> type)
  46        (with-syntax ((sname (symbol->string (syntax->datum #'name))))
  47          #'(lambda (pname ...)
  48              (let ((ptr (resolve sname)))
  49                (set! trampoline
  50                      (pointer->procedure (type)
  51                                          ptr
  52                                          (list (ptype) ...)))
  53                (trampoline pname ...))))))))
  54
  55 (define-syntax define-foreign-procedure
  56   (syntax-rules (->)
  57     ((define-foreign-procedure (name (pname ptype) ... -> type)
  58        docstring)
  59      (define name
  60        (letrec ((trampoline
  61                  (foreign-trampoline trampoline
  62                                      name (pname ptype) ... -> type))
  63                 (name (lambda (pname ...)
  64                         docstring
  65                         (let ((pname (ptype #:unwrap pname))
  66                               ...)
  67                           (type #:wrap (trampoline pname ...))))))
  68          name)))))
  69
  70 (define-syntax define-foreign-procedures
  71   (syntax-rules ()
  72     ((define-foreign-procedures ((name prototype ...) ...)
  73        docstring)
  74      (begin
  75        (define-foreign-procedure (name prototype ...)
  76          docstring)
  77        ...))))
  78
  79 (define-syntax define-foreign-type
  80   (syntax-rules ()
  81     ((_ name ffi-type unwrap wrap)
  82      (define-syntax name
  83        (syntax-rules ()
  84          ((_) ffi-type)
  85          ((_ #:wrap x) (wrap x))
  86          ((_ #:unwrap x) (unwrap x)))))))
  87
  88 (define-syntax define-simple-foreign-type
  89   (syntax-rules ()
  90     ((_ name ffi-type)
  91      ;; We could dispatch through to define-foreign-type via:
  92      ;;
  93      ;;   (define-foreign-type name
  94      ;;     ffi-type
  95      ;;     (lambda (x) x)
  96      ;;     (lambda (x) x))
  97      ;;
  98      ;; However the resulting wrap expression:
  99      ;;
 100      ;;   ((lambda (x) x) (trampoline arg ...))
 101      ;;
 102      ;; would not be in tail position, as the optimizer doesn't know
 103      ;; that the foreign function just returns one value.  This hack
 104      ;; just passes the wrapped expression through, allowing it to be in
 105      ;; tail position.
 106      (define-syntax name
 107        (syntax-rules ()
 108          ((_) ffi-type)
 109          ((_ #:wrap x) x)
 110          ((_ #:unwrap x) x))))))