figl/glut/types.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 ;; Mappings from GLUT to FFI types.
  21 ;;
  22 ;;; Code:
  23
  24 (define-module (figl glut types)
  25   #:use-module (figl runtime)
  26   #:use-module (figl gl types)
  27   #:use-module ((system foreign) #:renamer (symbol-prefix-proc 'ffi:))
  28   #:use-module (srfi srfi-26) ; cut
  29   #:export (unsigned-char
  30             int
  31             unsigned-int
  32             char-*
  33             int-*
  34             char-**
  35
  36             display-callback-*
  37             overlay-display-callback-*
  38             reshape-callback-*
  39             keyboard-callback-*
  40             mouse-callback-*
  41             motion-callback-*
  42             passive-motion-callback-*
  43             visibility-callback-*
  44             entry-callback-*
  45             special-callback-*
  46             spaceball-motion-callback-*
  47             spaceball-rotate-callback-*
  48             spaceball-button-callback-*
  49             button-box-callback-*
  50             dials-callback-*
  51             tablet-motion-callback-*
  52             tablet-button-callback-*
  53             menu-status-callback-*
  54             idle-callback-*
  55             timer-callback-*))
  56
  57 (define-simple-foreign-type unsigned-char ffi:uint8)
  58 (define-simple-foreign-type int ffi:int)
  59 (define-simple-foreign-type unsigned-int ffi:unsigned-int)
  60
  61 ;; GLUT specifies that all strings are ASCII encoded.
  62 (define-foreign-type char-* '*
  63   (cut ffi:string->pointer <> "ASCII")
  64   (cut ffi:pointer->string <> -1 "ASCII"))
  65
  66 (define-simple-foreign-type int-* '*)
  67 (define-simple-foreign-type char-** '*)
  68
  69 ;; Callbacks are either "ephemeral" or "sticky".  Ephemeral callbacks
  70 ;; are only called once, and are protected between the time they are
  71 ;; wrapped and the time they are called.  Sticky callbacks can be called
  72 ;; multiple times, and are protected for all time.  Perhaps we should
  73 ;; allow sticky callbacks to be unprotected at some time, but it
  74 ;; probably doesn't matter.
  75
  76 (define *gc-protected* '())
  77
  78 (define (gc-protect! proc)
  79   (set! *gc-protected* (cons proc *gc-protected*)))
  80
  81 (define (gc-unprotect! proc)
  82   (set! *gc-protected* (delq! proc *gc-protected*)))
  83
  84 (define (coerce-callback-pointer/ephemeral x return-type arg-types)
  85   (cond
  86    ((not x)
  87     ffi:%null-pointer)
  88    ((ffi:pointer? x)
  89     x)
  90    ((procedure? x)
  91     (letrec ((ptr (ffi:procedure->pointer return-type
  92                                           (lambda args
  93                                             (gc-unprotect! ptr)
  94                                             (apply x args))
  95                                           arg-types)))
  96       (gc-protect! ptr)
  97       ptr))
  98    (else
  99     (error "unhandled callback-pointer type" x))))
 100
 101 (define (coerce-callback-pointer/sticky x return-type arg-types)
 102   (cond
 103    ((not x)
 104     ffi:%null-pointer)
 105    ((ffi:pointer? x)
 106     x)
 107    ((procedure? x)
 108     (let ((ptr (ffi:procedure->pointer return-type x arg-types)))
 109       (gc-protect! ptr)
 110       ptr))
 111    (else
 112     (error "unhandled callback-pointer type" x))))
 113
 114 (define-syntax define-ephemeral-callback-pointer-type
 115   (syntax-rules (->)
 116     ((_ name ((pname ptype) ... -> type))
 117      (define-foreign-type name '*
 118        (cute coerce-callback-pointer/ephemeral <> (type) (list (ptype) ...))
 119        (lambda (x) x)))))
 120
 121 (define-syntax define-sticky-callback-pointer-type
 122   (syntax-rules (->)
 123     ((_ name ((pname ptype) ... -> type))
 124      (define-foreign-type name '*
 125        (cute coerce-callback-pointer/sticky <> (type) (list (ptype) ...))
 126        (lambda (x) x)))))
 127
 128 (define-sticky-callback-pointer-type display-callback-*
 129   (-> void))
 130 (define-sticky-callback-pointer-type overlay-display-callback-*
 131   (-> void))
 132 (define-sticky-callback-pointer-type reshape-callback-*
 133   ((width int) (height int) -> void))
 134 (define-sticky-callback-pointer-type keyboard-callback-*
 135   ((key unsigned-char) (x int) (y int) -> void))
 136 (define-sticky-callback-pointer-type mouse-callback-*
 137   ((button int) (state int) (x int) (y int) -> void))
 138 (define-sticky-callback-pointer-type motion-callback-*
 139   ((x int) (y int) -> void))
 140 (define-sticky-callback-pointer-type passive-motion-callback-*
 141   ((x int) (y int) -> void))
 142 (define-sticky-callback-pointer-type visibility-callback-*
 143   ((state int) -> void))
 144 (define-sticky-callback-pointer-type entry-callback-*
 145   ((state int) -> void))
 146 (define-sticky-callback-pointer-type special-callback-*
 147   ((key int) (x int) (y int) -> void))
 148 (define-sticky-callback-pointer-type spaceball-motion-callback-*
 149   ((x int) (y int) (z int) -> void))
 150 (define-sticky-callback-pointer-type spaceball-rotate-callback-*
 151   ((x int) (y int) (z int) -> void))
 152 (define-sticky-callback-pointer-type spaceball-button-callback-*
 153   ((button int) (state int) -> void))
 154 (define-sticky-callback-pointer-type button-box-callback-*
 155   ((button int) (state int) -> void))
 156 (define-sticky-callback-pointer-type dials-callback-*
 157   ((dial int) (value int) -> void))
 158 (define-sticky-callback-pointer-type tablet-motion-callback-*
 159   ((x int) (y int) -> void))
 160 (define-sticky-callback-pointer-type tablet-button-callback-*
 161   ((button int) (state int) (x int) (y int) -> void))
 162 (define-sticky-callback-pointer-type menu-status-callback-*
 163   ((status int) (x int) (y int) -> void))
 164 (define-sticky-callback-pointer-type idle-callback-*
 165   (-> void))
 166
 167 (define-ephemeral-callback-pointer-type timer-callback-*
 168   ((value int) -> void))