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 (define-foreign-procedure
  27             define-foreign-procedures
  28             define-foreign-type
  29             define-simple-foreign-type))
  30
  31 (define-syntax foreign-trampoline
  32   (syntax-rules (->)
  33     ((_ trampoline resolve-name (pname ptype) ... -> type)
  34      (lambda (pname ...)
  35        (set! trampoline
  36              (pointer->procedure (type)
  37                                  resolve-name
  38                                  (list (ptype) ...)))
  39        (trampoline pname ...)))))
  40
  41 (define-syntax define-foreign-procedure
  42   (syntax-rules (->)
  43     ((define-foreign-procedure (name (pname ptype) ... -> type)
  44        resolve-name
  45        docstring)
  46      (define name
  47        (letrec ((trampoline
  48                  (foreign-trampoline trampoline resolve-name
  49                                      (pname ptype) ... -> type))
  50                 (name (lambda (pname ...)
  51                         docstring
  52                         (let ((pname (ptype #:unwrap pname))
  53                               ...)
  54                           (type #:wrap (trampoline pname ...))))))
  55          name)))))
  56
  57 (define-syntax define-foreign-procedures
  58   (syntax-rules ()
  59     ((define-foreign-procedures ((name prototype ...) ...)
  60        resolve-name
  61        docstring)
  62      (begin
  63        (define-foreign-procedure (name prototype ...)
  64          resolve-name
  65          docstring)
  66        ...))))
  67
  68 (define-syntax define-foreign-type
  69   (syntax-rules ()
  70     ((_ name ffi-type unwrap wrap)
  71      (define-syntax name
  72        (syntax-rules ()
  73          ((_) ffi-type)
  74          ((_ #:wrap x) (wrap x))
  75          ((_ #:unwrap x) (unwrap x)))))))
  76
  77 (define-syntax define-simple-foreign-type
  78   (syntax-rules ()
  79     ((_ name ffi-type)
  80      ;; We could dispatch through to define-foreign-type via:
  81      ;;
  82      ;;   (define-foreign-type name
  83      ;;     ffi-type
  84      ;;     (lambda (x) x)
  85      ;;     (lambda (x) x))
  86      ;;
  87      ;; However the resulting wrap expression:
  88      ;;
  89      ;;   ((lambda (x) x) (trampoline arg ...))
  90      ;;
  91      ;; would not be in tail position, as the optimizer doesn't know
  92      ;; that the foreign function just returns one value.  This hack
  93      ;; just passes the wrapped expression through, allowing it to be in
  94      ;; tail position.
  95      (define-syntax name
  96        (syntax-rules ()
  97          ((_) ffi-type)
  98          ((_ #:wrap x) x)
  99          ((_ #:unwrap x) x))))))