figl/glut/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 glut runtime)
  25   #:use-module (system foreign)
  26   #:use-module (figl runtime)
  27   #:use-module (figl gl runtime)
  28   #:export (*resolve-hook*
  29             define-glut-procedure))
  30
  31 (define libglut
  32   (delay (dynamic-link "libglut")))
  33
  34 (define (get-libglut)
  35   (force libglut))
  36
  37 (current-gl-get-dynamic-object get-libglut)
  38
  39 (define *resolve-hook* (make-hook 1))
  40
  41 (define (resolve name)
  42   (let ((name-str (symbol->string name)))
  43     (run-hook *resolve-hook* name-str)
  44     (dynamic-pointer name-str (get-libglut))))
  45
  46 (define-syntax define-glut-procedure
  47   (syntax-rules (->)
  48     ((define-glut-procedure (name (pname ptype) ... -> type)
  49        docstring)
  50      (define-foreign-procedure (name (pname ptype) ... -> type)
  51        (resolve 'name)
  52        docstring))))