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
|
#lang racket/base
|
||||||
(require mzlib/foreign
|
(require ffi/unsafe
|
||||||
"gl-info.ss")
|
ffi/cvector)
|
||||||
|
|
||||||
(provide (all-defined-except get-unsigned-type get-signed-type make-gl-vector-type))
|
|
||||||
|
|
||||||
(define _float*
|
(provide (all-defined-out))
|
||||||
(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)))))
|
|
||||||
|
|
||||||
(define (get-signed-type size)
|
(define _float*
|
||||||
(case size
|
(make-ctype _float
|
||||||
((1) _sint8)
|
(lambda (n)
|
||||||
((2) _sint16)
|
(if (exact? n)
|
||||||
((4) _sint32)
|
(exact->inexact n)
|
||||||
((8) _sint64)
|
n))
|
||||||
(else (error 'get-signed-type (format "no ~a byte signed type" size)))))
|
#f))
|
||||||
|
|
||||||
(define (make-gl-vector-type t)
|
(define (make-gl-vector-type t)
|
||||||
(make-ctype _cvector
|
(make-ctype _cvector
|
||||||
(lambda (sval)
|
(lambda (sval)
|
||||||
(unless (cvector? sval)
|
(unless (cvector? sval)
|
||||||
(raise-type-error 'Scheme->C "cvector" sval))
|
(raise-type-error 'Scheme->C "cvector" sval))
|
||||||
(unless (eq? (cvector-type sval) t)
|
(unless (eq? (cvector-type sval) t)
|
||||||
(error 'Scheme->C "wrong kind of cvector"))
|
(error 'Scheme->C "wrong kind of cvector"))
|
||||||
sval)
|
sval)
|
||||||
#f))
|
#f))
|
||||||
|
|
||||||
(define _gl-byte (get-signed-type gl-byte-size))
|
;; Beware of problems with these type definitions.
|
||||||
(define _gl-ubyte (get-unsigned-type gl-ubyte-size))
|
;; They seem to be right for all currently supported
|
||||||
(define _gl-short (get-signed-type gl-short-size))
|
;; platforms, but in principle they can differ.
|
||||||
(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*)
|
|
||||||
|
|
||||||
(define _gl-bytev (make-gl-vector-type _gl-byte))
|
(define _gl-byte _int8)
|
||||||
(define _gl-ubytev (make-gl-vector-type _gl-ubyte))
|
(define _gl-ubyte _uint8)
|
||||||
(define _gl-shortv (make-gl-vector-type _gl-short))
|
(define _gl-short _int16)
|
||||||
(define _gl-ushortv (make-gl-vector-type _gl-ushort))
|
(define _gl-ushort _uint16)
|
||||||
(define _gl-intv (make-gl-vector-type _gl-int))
|
(define _gl-int _int)
|
||||||
(define _gl-uintv (make-gl-vector-type _gl-uint))
|
(define _gl-uint _uint)
|
||||||
(define _gl-booleanv (make-gl-vector-type _gl-boolean))
|
(define _gl-boolean (make-ctype _int8
|
||||||
(define _gl-floatv (make-gl-vector-type _gl-float))
|
(lambda (x)
|
||||||
(define _gl-doublev (make-gl-vector-type _gl-double))
|
(if x 1 0))
|
||||||
(define _gl-voidv _cvector)
|
(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
|
#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 compile-omit-paths '("examples"))
|
||||||
|
|
||||||
(define scribblings '(("scribblings/sgl.scrbl" (multi-page) (gui-library 50))))
|
(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