figl/glut.scm

   1 ;;; figl
   2 ;;; Copyright (C) 2013 Daniel Hartwig <mandyke@gmail.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)
  25   #:use-module (figl glut low-level)
  26   #:use-module (system foreign)
  27   #:use-module (srfi srfi-39) ; parameter objects
  28   #:export (glut-init))
  29
  30 ;; TODO: Most procedures should prevent themself from being called
  31 ;; before glut-init.
  32
  33 (define glut-init? (make-parameter #f))
  34
  35 ;; Note the use of 'saved-c-strings' to keep a reference to all of the
  36 ;; C string buffers that we ever pass to 'glutInit'. This is important
  37 ;; because the glut docs specify that 'glutInit' wants the original
  38 ;; unmodified 'argv' passed to 'main', which means that it can assume
  39 ;; that the strings will never be freed. 'string->pointer' returns a C
  40 ;; string buffer managed by the garbage collector, which means that
  41 ;; the string may be freed unless the GC can see a pointer to the
  42 ;; _beginning_ of the string.
  43 (define glut-init
  44   (let ((saved-c-strings '()))
  45     (lambda (args)
  46       ;; Avoid calling init twice as GLUT will exit().
  47       (unless (glut-init?)
  48         (let* ((num-args (length args))
  49                (c-strings (map string->pointer args))
  50                (argcp (make-c-struct (list int)
  51                                      (list num-args)))
  52                (argv (make-c-struct (make-list (+ 1 num-args) '*)
  53                                     (append c-strings
  54                                             (list %null-pointer)))))
  55           (set! saved-c-strings (append c-strings saved-c-strings))
  56           (glutInit argcp argv)
  57           (glut-init? #t)
  58           (let ((argc (car (parse-c-struct argcp (list int)))))
  59             (map pointer->string
  60                  (parse-c-struct argv
  61                                  (make-list argc '*)))))))))