abandon gl-info inference of GL types via C compilation
because it depends on locating GL headers at configure time, and it creates platform-specific code in the collects tree; the platforms that we support all have the obvious mappings for the GL types
This commit is contained in:
Matthew Flatt
parent
0f856dede5
commit
557b799939
|
|
@ -1,76 +1,57 @@
|
|||
(module gl-types mzscheme
|
||||
(require mzlib/foreign
|
||||
"gl-info.ss")
|
||||
|
||||
(provide (all-defined-except get-unsigned-type get-signed-type make-gl-vector-type))
|
||||
#lang racket/base
|
||||
(require ffi/unsafe
|
||||
ffi/cvector)
|
||||
|
||||
(define _float*
|
||||
(make-ctype _float
|
||||
(lambda (n)
|
||||
(if (exact? n)
|
||||
(exact->inexact n)
|
||||
n))
|
||||
#f))
|
||||
|
||||
(define (get-unsigned-type size)
|
||||
(case size
|
||||
((1) _uint8)
|
||||
((2) _uint16)
|
||||
((4) _uint32)
|
||||
((8) _uint64)
|
||||
(else (error 'get-unsigned-type (format "no ~a byte unsigned type" size)))))
|
||||
(provide (all-defined-out))
|
||||
|
||||
(define (get-signed-type size)
|
||||
(case size
|
||||
((1) _sint8)
|
||||
((2) _sint16)
|
||||
((4) _sint32)
|
||||
((8) _sint64)
|
||||
(else (error 'get-signed-type (format "no ~a byte signed type" size)))))
|
||||
(define _float*
|
||||
(make-ctype _float
|
||||
(lambda (n)
|
||||
(if (exact? n)
|
||||
(exact->inexact n)
|
||||
n))
|
||||
#f))
|
||||
|
||||
(define (make-gl-vector-type t)
|
||||
(make-ctype _cvector
|
||||
(lambda (sval)
|
||||
(unless (cvector? sval)
|
||||
(raise-type-error 'Scheme->C "cvector" sval))
|
||||
(unless (eq? (cvector-type sval) t)
|
||||
(error 'Scheme->C "wrong kind of cvector"))
|
||||
sval)
|
||||
#f))
|
||||
(define (make-gl-vector-type t)
|
||||
(make-ctype _cvector
|
||||
(lambda (sval)
|
||||
(unless (cvector? sval)
|
||||
(raise-type-error 'Scheme->C "cvector" sval))
|
||||
(unless (eq? (cvector-type sval) t)
|
||||
(error 'Scheme->C "wrong kind of cvector"))
|
||||
sval)
|
||||
#f))
|
||||
|
||||
(define _gl-byte (get-signed-type gl-byte-size))
|
||||
(define _gl-ubyte (get-unsigned-type gl-ubyte-size))
|
||||
(define _gl-short (get-signed-type gl-short-size))
|
||||
(define _gl-ushort (get-unsigned-type gl-ushort-size))
|
||||
(define _gl-int (get-signed-type gl-int-size))
|
||||
(define _gl-uint (get-unsigned-type gl-uint-size))
|
||||
(define _gl-boolean (make-ctype (get-unsigned-type gl-boolean-size)
|
||||
(lambda (x)
|
||||
(if x 1 0))
|
||||
(lambda (x) (not (= x 0)))))
|
||||
(define _gl-sizei (get-unsigned-type gl-sizei-size))
|
||||
(define _gl-enum (get-unsigned-type gl-enum-size))
|
||||
(define _gl-bitfield (get-unsigned-type gl-bitfield-size))
|
||||
(define _gl-float _float*)
|
||||
(define _gl-double _double*)
|
||||
(define _gl-clampf _float*)
|
||||
(define _gl-clampd _double*)
|
||||
;; Beware of problems with these type definitions.
|
||||
;; They seem to be right for all currently supported
|
||||
;; platforms, but in principle they can differ.
|
||||
|
||||
(define _gl-bytev (make-gl-vector-type _gl-byte))
|
||||
(define _gl-ubytev (make-gl-vector-type _gl-ubyte))
|
||||
(define _gl-shortv (make-gl-vector-type _gl-short))
|
||||
(define _gl-ushortv (make-gl-vector-type _gl-ushort))
|
||||
(define _gl-intv (make-gl-vector-type _gl-int))
|
||||
(define _gl-uintv (make-gl-vector-type _gl-uint))
|
||||
(define _gl-booleanv (make-gl-vector-type _gl-boolean))
|
||||
(define _gl-floatv (make-gl-vector-type _gl-float))
|
||||
(define _gl-doublev (make-gl-vector-type _gl-double))
|
||||
(define _gl-voidv _cvector)
|
||||
(define _gl-byte _int8)
|
||||
(define _gl-ubyte _uint8)
|
||||
(define _gl-short _int16)
|
||||
(define _gl-ushort _uint16)
|
||||
(define _gl-int _int)
|
||||
(define _gl-uint _uint)
|
||||
(define _gl-boolean (make-ctype _int8
|
||||
(lambda (x)
|
||||
(if x 1 0))
|
||||
(lambda (x) (not (= x 0)))))
|
||||
(define _gl-sizei _int)
|
||||
(define _gl-enum _int)
|
||||
(define _gl-bitfield _uint)
|
||||
(define _gl-float _float*)
|
||||
(define _gl-double _double*)
|
||||
(define _gl-clampf _float*)
|
||||
(define _gl-clampd _double*)
|
||||
|
||||
(define _gl-bytev (make-gl-vector-type _gl-byte))
|
||||
(define _gl-ubytev (make-gl-vector-type _gl-ubyte))
|
||||
(define _gl-shortv (make-gl-vector-type _gl-short))
|
||||
(define _gl-ushortv (make-gl-vector-type _gl-ushort))
|
||||
(define _gl-intv (make-gl-vector-type _gl-int))
|
||||
(define _gl-uintv (make-gl-vector-type _gl-uint))
|
||||
(define _gl-booleanv (make-gl-vector-type _gl-boolean))
|
||||
(define _gl-floatv (make-gl-vector-type _gl-float))
|
||||
(define _gl-doublev (make-gl-vector-type _gl-double))
|
||||
(define _gl-voidv _cvector)
|
||||
|
||||
;; If GLfloat and GLdouble don't correspond to C's float and double, things
|
||||
;; won't work.
|
||||
(unless (= gl-float-size (compiler-sizeof '(float)))
|
||||
(error 'gl-float "GLfloat does not correspond to C's float type"))
|
||||
(unless (= gl-double-size (compiler-sizeof '(double)))
|
||||
(error 'gl-double "GLdouble does not correspond to C's double type"))
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1,9 +1,5 @@
|
|||
#lang setup/infotab
|
||||
|
||||
(define pre-install-collection "makefile.rkt")
|
||||
(define virtual-sources '("gl-info.rkt"))
|
||||
(define clean (list (build-path "compiled" "native" (system-library-subpath))
|
||||
"compiled"))
|
||||
(define compile-omit-paths '("examples"))
|
||||
|
||||
(define scribblings '(("scribblings/sgl.scrbl" (multi-page) (gui-library 50))))
|
||||
|
|
|
|||
|
|
@ -1,178 +0,0 @@
|
|||
#lang mzscheme
|
||||
|
||||
(require (prefix dynext: dynext/compile)
|
||||
dynext/file
|
||||
(prefix dynext: dynext/link)
|
||||
mzlib/file
|
||||
setup/dirs
|
||||
launcher
|
||||
srfi/13/string)
|
||||
|
||||
(provide make-gl-info)
|
||||
|
||||
(define c-file #<<end-string
|
||||
#include <escheme.h>
|
||||
#include <GL/gl.h>
|
||||
#include <GL/glu.h>
|
||||
|
||||
Scheme_Object *scheme_reload(Scheme_Env *env)
|
||||
{
|
||||
Scheme_Env *mod_env;
|
||||
|
||||
mod_env = scheme_primitive_module(scheme_intern_symbol("make-gl-info-helper"), env);
|
||||
scheme_add_global("gl-byte-size",
|
||||
scheme_make_integer_value(sizeof(GLbyte)),
|
||||
mod_env);
|
||||
scheme_add_global("gl-ubyte-size",
|
||||
scheme_make_integer_value(sizeof(GLubyte)),
|
||||
mod_env);
|
||||
scheme_add_global("gl-short-size",
|
||||
scheme_make_integer_value(sizeof(GLshort)),
|
||||
mod_env);
|
||||
scheme_add_global("gl-ushort-size",
|
||||
scheme_make_integer_value(sizeof(GLushort)),
|
||||
mod_env);
|
||||
scheme_add_global("gl-int-size",
|
||||
scheme_make_integer_value(sizeof(GLint)),
|
||||
mod_env);
|
||||
scheme_add_global("gl-uint-size",
|
||||
scheme_make_integer_value(sizeof(GLuint)),
|
||||
mod_env);
|
||||
scheme_add_global("gl-float-size",
|
||||
scheme_make_integer_value(sizeof(GLfloat)),
|
||||
mod_env);
|
||||
scheme_add_global("gl-double-size",
|
||||
scheme_make_integer_value(sizeof(GLdouble)),
|
||||
mod_env);
|
||||
scheme_add_global("gl-boolean-size",
|
||||
scheme_make_integer_value(sizeof(GLboolean)),
|
||||
mod_env);
|
||||
scheme_add_global("gl-sizei-size",
|
||||
scheme_make_integer_value(sizeof(GLsizei)),
|
||||
mod_env);
|
||||
scheme_add_global("gl-clampf-size",
|
||||
scheme_make_integer_value(sizeof(GLclampf)),
|
||||
mod_env);
|
||||
scheme_add_global("gl-clampd-size",
|
||||
scheme_make_integer_value(sizeof(GLclampd)),
|
||||
mod_env);
|
||||
scheme_add_global("gl-enum-size",
|
||||
scheme_make_integer_value(sizeof(GLenum)),
|
||||
mod_env);
|
||||
scheme_add_global("gl-bitfield-size",
|
||||
scheme_make_integer_value(sizeof(GLbitfield)),
|
||||
mod_env);
|
||||
scheme_finish_primitive_module(mod_env);
|
||||
|
||||
return scheme_void;
|
||||
}
|
||||
|
||||
Scheme_Object *scheme_initialize(Scheme_Env *env)
|
||||
{
|
||||
return scheme_reload(env);
|
||||
}
|
||||
|
||||
Scheme_Object *scheme_module_name(void)
|
||||
{
|
||||
return scheme_intern_symbol("make-gl-info-helper");
|
||||
}
|
||||
|
||||
end-string
|
||||
)
|
||||
|
||||
(define (delete/continue x)
|
||||
(with-handlers ([exn:fail:filesystem? void])
|
||||
(delete-file x)))
|
||||
|
||||
(define (parse-includes s)
|
||||
(map (lambda (s) (substring s 2 (string-length s)))
|
||||
(string-tokenize s)))
|
||||
|
||||
(define (get-args which-arg)
|
||||
(let ([fp (build-path (find-lib-dir) "buildinfo")])
|
||||
(if (file-exists? fp)
|
||||
(call-with-input-file fp
|
||||
(lambda (i)
|
||||
(let loop ([l (read-line i)])
|
||||
(if (eof-object? l)
|
||||
""
|
||||
(let ([m (regexp-match (format "^~a=(.*)$" which-arg) l)])
|
||||
(if m
|
||||
(cadr m)
|
||||
(loop (read-line i))))))))
|
||||
"")))
|
||||
|
||||
(define (compile-c-to-so file file.c file.so)
|
||||
(let ([file.o (append-object-suffix file)])
|
||||
(dynext:compile-extension #f file.c file.o
|
||||
`(,@(parse-includes (get-args "X_CFLAGS"))
|
||||
,(collection-path "compiler")))
|
||||
(dynext:link-extension #f (list file.o) file.so)
|
||||
(delete/continue file.o)))
|
||||
|
||||
(define (build-helper compile-directory variant)
|
||||
(let* ([file "make-gl-info-helper.rkt"]
|
||||
[c (build-path compile-directory (append-c-suffix file))]
|
||||
[so (build-path compile-directory "native"
|
||||
(system-library-subpath variant)
|
||||
(append-extension-suffix file))])
|
||||
(make-directory* (build-path compile-directory "native"
|
||||
(system-library-subpath variant)))
|
||||
(with-output-to-file c (lambda () (display c-file)) 'replace)
|
||||
(compile-c-to-so file c so)))
|
||||
|
||||
(define (effective-system-type)
|
||||
(let ([t (system-type)])
|
||||
(if (not (eq? t 'unix))
|
||||
t
|
||||
;; Check "buildinfo" for USE_GL flag:
|
||||
(let ([buildinfo (build-path (find-lib-dir) "buildinfo")])
|
||||
(if (not (file-exists? buildinfo))
|
||||
(begin (printf "WARNING: buildinfo file missing: ~a\n" buildinfo)
|
||||
t)
|
||||
(with-input-from-file buildinfo
|
||||
(lambda ()
|
||||
(if (regexp-match? #rx"-DUSE_GL" (current-input-port))
|
||||
t
|
||||
(begin (printf "WARNING: no GL support\n")
|
||||
'no-gl)))))))))
|
||||
|
||||
(define (make-gl-info compile-directory)
|
||||
(let ([zo (build-path compile-directory (append-zo-suffix "gl-info.rkt"))]
|
||||
[mod
|
||||
(compile
|
||||
(case (effective-system-type)
|
||||
[(macosx windows no-gl)
|
||||
`(,#'module gl-info mzscheme
|
||||
(provide (all-defined))
|
||||
(define gl-byte-size 1)
|
||||
(define gl-ubyte-size 1)
|
||||
(define gl-short-size 2)
|
||||
(define gl-ushort-size 2)
|
||||
(define gl-int-size 4)
|
||||
(define gl-uint-size 4)
|
||||
(define gl-boolean-size 1)
|
||||
(define gl-sizei-size 4)
|
||||
(define gl-bitfield-size 4)
|
||||
(define gl-enum-size 4)
|
||||
(define gl-float-size 4)
|
||||
(define gl-double-size 8)
|
||||
(define gl-clampf-size 4)
|
||||
(define gl-clampd-size 8))]
|
||||
[else
|
||||
(for-each (lambda (variant)
|
||||
(parameterize ([dynext:link-variant variant])
|
||||
(build-helper compile-directory variant)))
|
||||
(available-mzscheme-variants))
|
||||
`(,#'module gl-info mzscheme
|
||||
(provide (all-defined))
|
||||
,@(map
|
||||
(lambda (x)
|
||||
`(define ,x ,(dynamic-require 'sgl/make-gl-info-helper x)))
|
||||
'(gl-byte-size gl-ubyte-size gl-short-size gl-ushort-size
|
||||
gl-int-size gl-uint-size gl-boolean-size gl-sizei-size
|
||||
gl-bitfield-size gl-enum-size gl-float-size gl-double-size
|
||||
gl-clampf-size gl-clampd-size)))]))])
|
||||
(with-output-to-file zo
|
||||
(lambda () (write mod))
|
||||
'replace)))
|
||||
|
|
@ -1,17 +0,0 @@
|
|||
#lang mzscheme
|
||||
(require make
|
||||
setup/dirs
|
||||
"make-gl-info.rkt")
|
||||
|
||||
(provide pre-installer)
|
||||
|
||||
(define dir (build-path "compiled"))
|
||||
|
||||
(define (pre-installer home)
|
||||
(parameterize ([current-directory (collection-path "sgl")]
|
||||
[make-print-reasons #f]
|
||||
[make-print-checking #f])
|
||||
(make/proc
|
||||
`((,(build-path dir "gl-info_rkt.zo")
|
||||
("make-gl-info.rkt" ,(build-path (find-include-dir) "schvers.h"))
|
||||
,(lambda () (make-gl-info dir)))))))
|
||||
Loading…
Reference in New Issue
Block a user