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 (define (coerce-callback-pointer x return-type arg-types)
  70   (cond
  71    ((ffi:pointer? x)
  72     x)
  73    ((procedure? x)
  74     (ffi:procedure->pointer return-type x arg-types))
  75    (else
  76     (error "unhandled callback-pointer type" x))))
  77
  78 (define-syntax define-callback-pointer-type
  79   (syntax-rules (->)
  80     ((_ name ((pname ptype) ... -> type))
  81      (define-foreign-type name '*
  82        (cute coerce-callback-pointer <> (type) (list (ptype) ...))
  83        (lambda (x) x)))))
  84
  85 ;; TODO: These callback-pointer types are not used at, as it is not
  86 ;; clear how to efficiently keep the pointers alive.  Defined now
  87 ;; anyway as a stub, and users can access them if they keep the
  88 ;; pointer alive themselves.
  89
  90 (define-callback-pointer-type display-callback-*
  91   (-> void))
  92 (define-callback-pointer-type overlay-display-callback-*
  93   (-> void))
  94 (define-callback-pointer-type reshape-callback-*
  95   ((width int) (height int) -> void))
  96 (define-callback-pointer-type keyboard-callback-*
  97   ((key unsigned-char) (x int) (y int) -> void))
  98 (define-callback-pointer-type mouse-callback-*
  99   ((button int) (state int) (x int) (y int) -> void))
 100 (define-callback-pointer-type motion-callback-*
 101   ((x int) (y int) -> void))
 102 (define-callback-pointer-type passive-motion-callback-*
 103   ((x int) (y int) -> void))
 104 (define-callback-pointer-type visibility-callback-*
 105   ((state int) -> void))
 106 (define-callback-pointer-type entry-callback-*
 107   ((state int) -> void))
 108 (define-callback-pointer-type special-callback-*
 109   ((key int) (x int) (y int) -> void))
 110 (define-callback-pointer-type spaceball-motion-callback-*
 111   ((x int) (y int) (z int) -> void))
 112 (define-callback-pointer-type spaceball-rotate-callback-*
 113   ((x int) (y int) (z int) -> void))
 114 (define-callback-pointer-type spaceball-button-callback-*
 115   ((button int) (state int) -> void))
 116 (define-callback-pointer-type button-box-callback-*
 117   ((button int) (state int) -> void))
 118 (define-callback-pointer-type dials-callback-*
 119   ((dial int) (value int) -> void))
 120 (define-callback-pointer-type tablet-motion-callback-*
 121   ((x int) (y int) -> void))
 122 (define-callback-pointer-type tablet-button-callback-*
 123   ((button int) (state int) (x int) (y int) -> void))
 124 (define-callback-pointer-type menu-status-callback-*
 125   ((status int) (x int) (y int) -> void))
 126 (define-callback-pointer-type idle-callback-*
 127   (-> void))
 128 (define-callback-pointer-type timer-callback-*
 129   ((value int) -> void))