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             define-enumeration
  31             define-bitfield))
  32
  33 (define-syntax foreign-trampoline
  34   (syntax-rules (->)
  35     ((_ trampoline resolve-name (pname ptype) ... -> type)
  36      (lambda (pname ...)
  37        (set! trampoline
  38              (pointer->procedure (type)
  39                                  resolve-name
  40                                  (list (ptype) ...)))
  41        (trampoline pname ...)))))
  42
  43 (define-syntax define-foreign-procedure
  44   (syntax-rules (->)
  45     ((define-foreign-procedure (name (pname ptype) ... -> type)
  46        resolve-name
  47        docstring)
  48      (define name
  49        (letrec ((trampoline
  50                  (foreign-trampoline trampoline resolve-name
  51                                      (pname ptype) ... -> type))
  52                 (name (lambda (pname ...)
  53                         docstring
  54                         (let ((pname (ptype #:unwrap pname))
  55                               ...)
  56                           (type #:wrap (trampoline pname ...))))))
  57          name)))))
  58
  59 (define-syntax define-foreign-procedures
  60   (syntax-rules ()
  61     ((define-foreign-procedures ((name prototype ...) ...)
  62        resolve-name
  63        docstring)
  64      (begin
  65        (define-foreign-procedure (name prototype ...)
  66          resolve-name
  67          docstring)
  68        ...))))
  69
  70 (define-syntax define-foreign-type
  71   (syntax-rules ()
  72     ((_ name ffi-type unwrap wrap)
  73      (define-syntax name
  74        (syntax-rules ()
  75          ((_) ffi-type)
  76          ((_ #:wrap x) (wrap x))
  77          ((_ #:unwrap x) (unwrap x)))))))
  78
  79 (define-syntax define-simple-foreign-type
  80   (syntax-rules ()
  81     ((_ name ffi-type)
  82      ;; We could dispatch through to define-foreign-type via:
  83      ;;
  84      ;;   (define-foreign-type name
  85      ;;     ffi-type
  86      ;;     (lambda (x) x)
  87      ;;     (lambda (x) x))
  88      ;;
  89      ;; However the resulting wrap expression:
  90      ;;
  91      ;;   ((lambda (x) x) (trampoline arg ...))
  92      ;;
  93      ;; would not be in tail position, as the optimizer doesn't know
  94      ;; that the foreign function just returns one value.  This hack
  95      ;; just passes the wrapped expression through, allowing it to be in
  96      ;; tail position.
  97      (define-syntax name
  98        (syntax-rules ()
  99          ((_) ffi-type)
 100          ((_ #:wrap x) x)
 101          ((_ #:unwrap x) x))))))
 102
 103 (define-syntax-rule (define-enumeration enumerator (name value) ...)
 104   (define-syntax enumerator
 105     (lambda (x)
 106       (syntax-case x ()
 107         ((_)
 108          #''(name ...))
 109         ((_ enum) (number? (syntax->datum #'enum))
 110          #'enum)
 111         ((_ enum)
 112          (or (assq-ref '((name . value) ...)
 113                        (syntax->datum #'enum))
 114              (syntax-violation 'enumerator "invalid enumerated value"
 115                                #'enum)))))))
 116
 117 (define-syntax-rule (define-bitfield bitfield (name value) ...)
 118   (define-syntax bitfield
 119     (lambda (x)
 120       (syntax-case x ()
 121         ((_)
 122          #''(name ...))
 123         ((_ bit (... ...))
 124          #`(logior
 125             #,@(map
 126                 (lambda (bit)
 127                   (let ((datum (syntax->datum bit)))
 128                     (if (number? datum)
 129                         datum
 130                         (or (assq-ref '((name . value) ...) datum)
 131                             (syntax-violation 'bitfield "invalid bitfield value"
 132                                               bit)))))
 133                 #'(bit (... ...)))))))))