figl/glx/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 glx runtime)
  25   #:use-module (system foreign)
  26   #:use-module (figl gl types)
  27   #:use-module (figl gl runtime)
  28   #:use-module (figl runtime)
  29   #:export (define-glx-procedure define-glx-procedures))
  30
  31 (define libGL
  32   (delay (dynamic-link "libGL")))
  33
  34 (define (get-libGL)
  35   (force libGL))
  36
  37 (define (dladdr-resolve name)
  38   (dynamic-pointer (symbol->string name) (get-libGL)))
  39
  40 (define-foreign-procedure (glx-resolve (name const-GLchar-*) -> void-*)
  41   (dladdr-resolve 'glXGetProcAddress)
  42   "The GLX resolver.")
  43
  44 (current-gl-resolver glx-resolve)
  45 (current-gl-get-dynamic-object get-libGL)
  46
  47 (define (resolve name)
  48   (let ((ptr (glx-resolve (symbol->string name))))
  49     (if (null-pointer? ptr)
  50         (dladdr-resolve name)
  51         ptr)))
  52
  53 (define-syntax define-glx-procedure
  54   (syntax-rules (->)
  55     ((define-glx-procedure (name (pname ptype) ... -> type)
  56        docstring)
  57      (define-foreign-procedure (name (pname ptype) ... -> type)
  58        (resolve 'name)
  59        docstring))))
  60
  61 (define-syntax define-glx-procedures
  62   (syntax-rules ()
  63     ((define-glx-procedures ((name prototype ...) ...)
  64        docstring)
  65      (begin
  66        (define-glx-procedure (name prototype ...)
  67          docstring)
  68        ...))))